{-# LANGUAGE TupleSections #-}

module Boilerplate.ConfigParser (configParser, configCommentParser) where

import Boilerplate.Types
import Control.Applicative
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Text.Parser.Char
import Text.Parser.Combinators

-- parse the whole comment section to enhance locations in errors
configCommentParser :: CharParsing m => m Config
configCommentParser :: forall (m :: * -> *). CharParsing m => m Config
configCommentParser = (m Config
block forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Config
line) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). Parsing m => m ()
eof
  where
    block :: m Config
block = forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
between (forall (m :: * -> *). CharParsing m => String -> m String
string String
"{-" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
header) (forall (m :: * -> *) a. Parsing m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CharParsing m => String -> m String
string String
"-}") forall (m :: * -> *). CharParsing m => m Config
configParser
    line :: m Config
line = forall (m :: * -> *). CharParsing m => String -> m String
string String
"--" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
header forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CharParsing m => m Config
configParser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => m ()
spaces
    header :: m ()
header = m ()
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CharParsing m => String -> m String
string String
"BOILERPLATE" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
whitespace
    whitespace :: m ()
whitespace = forall (m :: * -> *). CharParsing m => m Char
space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CharParsing m => m ()
spaces

configParser :: CharParsing m => m Config
configParser :: forall (m :: * -> *). CharParsing m => m Config
configParser = forall (m :: * -> *) a. Parsing m => m a -> m a
try m Config
start forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Parsing m => m a -> m a
try m Config
end forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Config
config
  where
    start :: m Config
start = Config
ConfigStart forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
string String
"START"
    end :: m Config
end = Config
ConfigEnd forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
string String
"END"
    config :: m Config
config = Text -> [Text] -> [(Text, Custom)] -> Config
Config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Text
conid forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (m Char
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m [Text]
rules) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option [] (forall (m :: * -> *) a. Parsing m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ m Char
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m [(Text, Custom)]
customs)
    whitespace :: m Char
whitespace = forall (m :: * -> *). CharParsing m => m Char
space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => m ()
spaces
    conid :: m Text
conid = (\Char
c String
cs -> String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Char
c forall a. a -> [a] -> [a]
: String
cs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CharParsing m => m Char
upper forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (m :: * -> *). CharParsing m => String -> m Char
noneOf String
" \t\n\r\f,")
    rules :: m [Text]
rules = forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepBy1 m Text
conid (forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => m ()
spaces)
    customs :: m [(Text, Custom)]
customs = forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepEndBy1 m (Text, Custom)
custom m Char
whitespace -- consumes trailing whitespace
      where
        custom :: m (Text, Custom)
custom = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m Text
key forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => m ()
spaces) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). CharParsing m => m Custom
customParser forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"custom key/value"
        key :: m Text
key = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall (m :: * -> *). CharParsing m => m Char
alphaNum forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"custom key"

customParser :: CharParsing m => m Custom
customParser :: forall (m :: * -> *). CharParsing m => m Custom
customParser = (forall (m :: * -> *) a. Parsing m => m a -> m a
try m Custom
nindexed forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Custom
named forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Custom
indexed forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Custom
global) forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"custom value"
  where
    nindexed :: m Custom
nindexed = Map Text [Text] -> Custom
NamedIndexed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. m a -> m (Map Text a)
object m [Text]
array
    named :: m Custom
named = Map Text Text -> Custom
Named forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. m a -> m (Map Text a)
object m Text
txt
    indexed :: m Custom
indexed = [Text] -> Custom
Indexed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Text]
array
    global :: m Custom
global = Text -> Custom
Global forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Text
txt

    object :: m a -> m (Map Text a)
object m a
v = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
between (forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'{' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CharParsing m => m ()
spaces) (forall (m :: * -> *). CharParsing m => m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'}') (forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepBy m (Text, a)
kv m Char
comma)
      where kv :: m (Text, a)
kv = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m Text
symbol forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
':') forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (m :: * -> *). CharParsing m => m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
v)
    array :: m [Text]
array = forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
between (forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'[' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CharParsing m => m ()
spaces) (forall (m :: * -> *). CharParsing m => m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
']') (forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
sepBy m Text
txt m Char
comma)
    comma :: m Char
comma = forall (m :: * -> *) a. Parsing m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => m ()
spaces
    txt :: m Text
txt = m Text
quoted forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Text
symbol
      where quoted :: m Text
quoted = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). CharParsing m => Char -> m Char
notChar Char
'"') forall (m :: * -> *) a sur. Applicative m => m a -> m sur -> m a
`surroundedBy` (forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'"')
    symbol :: m Text
symbol = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall (m :: * -> *). CharParsing m => m Char
alphaNum forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
"symbol"