module Data.ConfigFile.TH(genConf,conf) where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Control.Applicative hiding (many,(<|>))
import Control.Monad (when,mzero)
import Data.Char(isUpper,isSpace)
import Text.Parsec.Char
import Text.ParserCombinators.Parsec hiding (between)
import qualified Text.Parsec.Token as P
import Text.Parsec.Language
tok = P.makeTokenParser haskellDef
pCd = (,,,) <$> (spaces *> P.identifier tok)
<*> (char '/' *> P.identifier tok <* spaces)
<*> (string "->" *> spaces *> ntpe <* spaces)
<*> (string "::" *> spaces *> tpe <* spaces)
where
ntpe = P.identifier tok >>= \x -> if (not.isUpper.head $x) then (return x) else fail $ x ++" is not a valid field name"
tpe = P.identifier tok >>= \x -> if (isUpper.head $x) then (return x) else fail $ "Identifier " ++ x ++ " does not name a type"
toList = ListE . map (TupE . map (LitE . StringL) . \(a,b,c,d) -> [a,b,c,d] )
conf = QuasiQuoter undefined undefined undefined (sToExpQ)
sToExpQ str = let
hd':rst = filter (not.null) $ lines str
hd = takeWhile (not . isSpace) . dropWhile isSpace $ hd'
in genConf hd . map parseIt . filter (not.all isSpace) $ rst
parseIt :: [Char] -> (String, String, String, String)
parseIt x = case runParser pCd () "Quasiquote" x of
Right x -> x
Left e -> error (show e++show x)
genConf :: Monad m => String -> [(String, String, String, String)] -> m [Dec]
genConf name cs
= do
return $ decls
where
decls = [DataD [] (mkName name) [] [RecC (mkName name) fields] []
,FunD (mkName $ "load"++name)
[Clause [VarP (mkName "file")]
(NormalB (AppE (var "runErrorT") (DoE loads)))
[]]
]
loads = [BindS (pat "cp") open] ++ map load1 cs ++
[NoBindS $ AppE (var "return") (bind)]
bind = RecConE (mkName name) [(mkName nam,var nam) | (_,_,nam,_) <- cs]
open = AppE (var "join")
(AppE (var "liftIO")
(appM "readfile" [var "emptyCP",var "file"]))
load1 (section,vname,name,tpe) = BindS (VarP $ mkName name) $ appM "get"
[var "cp"
,slit section
,slit vname]
field1 (section,var,name,tpe) = (mkName name,NotStrict,ConT (mkName tpe))
fields :: [Language.Haskell.TH.Syntax.VarStrictType]
fields = map field1 cs
slit = LitE . StringL
pat = VarP . mkName
var = VarE . mkName
appM a xs = foldl AppE (var a) xs