module Text.Config.TH
(
mkConfig
, config
) where
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Control.Applicative
import Text.Parsec hiding ((<|>), many)
import Text.Parsec.ByteString (Parser)
import Data.Default
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Text.Config.Parser
import Text.Config.Types
import Text.Config.Lib
config :: QuasiQuoter
config = QuasiQuoter
{ quoteExp = \str -> [|confTmpParser str|]
, quotePat = undefined
, quoteType = undefined
, quoteDec = undefined
}
mkConfig :: String -> ConfTmp -> DecsQ
mkConfig name (nameStr, confLines) = f
<$> mkRecord recName confLines
<*> instanceDef recName confLines
<*> mkParsers recName confLines
<*> mkParser name recName confLines
where
recName = mkName nameStr
f a b c d = a:b:(c++d)
mkRecord :: Name -> [ConfLine] -> DecQ
mkRecord recName confLines =
dataD (cxt []) recName [] [rec] [''Show]
where
rec = recC recName $ map confVSType confLines
confVSType :: ConfLine -> VarStrictTypeQ
confVSType (name, ctype) = confVSType' name $ confTypeQ ctype
confVSType' :: String -> TypeQ -> VarStrictTypeQ
confVSType' name typeq =
varStrictType (mkName name) $ strictType notStrict typeq
confTypeQ :: ConfType -> TypeQ
confTypeQ ConfString = [t|String|]
confTypeQ ConfURI = [t|String|]
confTypeQ ConfInt = [t|Int|]
confTypeQ ConfByteString = [t|ByteString|]
confTypeQ (ConfList ctype) = [t|[$(confTypeQ ctype)]|]
instanceDef :: Name -> [ConfLine] -> DecQ
instanceDef recName confLines =
instanceD (return []) types [func]
where
types = [t|Default $(conT recName)|]
cons = recConE recName $ map defVal confLines
func = valD (varP 'def) (normalB cons) []
defVal :: ConfLine -> Q (Name, Exp)
defVal (n, ConfString) = (,) (mkName n) <$> [|""|]
defVal (n, ConfURI) = (,) (mkName n) <$> [|"http://localhost/"|]
defVal (n, ConfInt) = (,) (mkName n) <$> [|0::Int|]
defVal (n, ConfByteString) = (,) (mkName n) <$> [|BS.empty|]
defVal (n, ConfList _) = (,) (mkName n) <$> [|[]|]
mkParsers :: Name -> [ConfLine] -> DecsQ
mkParsers recName confLines =
concat <$> mapM (mkVal recName) confLines
mkVal :: Name -> ConfLine -> DecsQ
mkVal recName (name, ctype) = do
s <- sigD funcName sigt
a <- newName "a"
c <- newName "c"
f <- funD funcName [clause [] (body a c) []]
return [s, f]
where
fieldName = mkName name
funcName = parserName name
sigt = [t|StateT $(conT recName) Parser ()|]
body a c = normalB $ doE [
bindS (varP a) [|lift $ try $ val $(confParser ctype) name|],
bindS (varP c) [|get|],
noBindS [|put $(recUpdE (varE c) [(,) fieldName <$> (varE a)])|]]
mkParser :: String -> Name -> [ConfLine] -> DecsQ
mkParser name recName cl = do
s <- sigD funcName [t|Parser $(conT recName)|]
v <- valD (varP funcName) (normalB body) []
return [s, v]
where
funcName = mkName name
body = [|execStateT (lift commentLines *> (many ($(getFieldParser cl) <* lift commentLines)) <* lift eof) def|]
getFieldParser :: [ConfLine] -> ExpQ
getFieldParser confLines = [|foldl1 (<|>) $(listE funcs)|]
where
funcs = map (varE . parserName . fst) confLines
parserName :: String -> Name
parserName name = mkName $ "val_" ++ name
confParser :: ConfType -> ExpQ
confParser ConfString = [|cv_string|]
confParser ConfURI = [|cv_uri|]
confParser ConfInt = [|cv_int|]
confParser ConfByteString = [|cv_bytestring|]
confParser (ConfList ctype) = [|cv_list $(confParser ctype)|]
val :: Parser a -> String -> Parser a
val p name = (string name *> spcs *> sep *> p) <* spcs <* commentLine