module Text.Bravo.Translate (
mkTemplates,
mkTemplatesWithOptions,
mkTemplatesFromFile,
mkTemplatesFromFileWithOptions,
TplOptions (..),
defaultTplOptions
)
where
import Control.Monad.State
import Data.Char
import Data.Generics
import Data.Maybe
import Data.Function
import qualified Language.Haskell.Exts.Syntax as Hs
import Language.Haskell.Meta.Syntax.Translate
import Language.Haskell.TH
import Text.Bravo.Syntax
import Text.Bravo.Util
import Text.Bravo.Parser
import Text.ParserCombinators.Parsec (parse, eof)
mkTemplates :: String -> Q [Dec]
mkTemplates = mkTemplates' defaultTplOptions ""
mkTemplatesWithOptions :: TplOptions -> String -> Q [Dec]
mkTemplatesWithOptions = flip mkTemplates' ""
mkTemplates' :: TplOptions -> FilePath -> String -> Q [Dec]
mkTemplates' options path s = case parse (templates << eof) path s of
Left err -> report True ("Error while parsing templates:\n" ++ show err) >> return []
Right tpl -> liftM join $ mapM (translateTpl options) tpl
mkTemplatesFromFile :: FilePath -> Q [Dec]
mkTemplatesFromFile = mkTemplatesFromFile' defaultTplOptions
mkTemplatesFromFileWithOptions :: TplOptions -> FilePath -> Q [Dec]
mkTemplatesFromFileWithOptions = mkTemplatesFromFile'
mkTemplatesFromFile' :: TplOptions -> FilePath -> Q [Dec]
mkTemplatesFromFile' options path = do
text <- runIO $ safeReadFile path
case text of
Nothing -> report True ("Error while reading file \"" ++ path ++ "\"") >> return []
Just text' -> mkTemplates' options path text'
data TplOptions = TplOptions {
tplMkName :: String -> String,
tplMkFieldName :: String -> String -> String,
tplModifyText :: String -> String
}
defaultTplOptions :: TplOptions
defaultTplOptions = TplOptions {
tplMkName = defaultMkName,
tplMkFieldName = defaultMkFieldName,
tplModifyText = id
}
defaultMkName :: String -> String
defaultMkName "" = error "*** bug: empty name in defaultMkName"
defaultMkName (c:cs) = "Tpl" ++ (toUpper c : cs)
defaultMkFieldName :: String -> String -> String
defaultMkFieldName _ "" = error "*** bug: empty field name in defaultMkFieldName"
defaultMkFieldName name (c:cs) = name ++ (toUpper c : cs)
data TplState = TplState {
tplName :: String,
tplFields :: [(String, Maybe Type)],
tplOptions :: TplOptions
}
type TplTrans a = State TplState a
translateTpl :: TplOptions -> Template -> Q [Dec]
translateTpl options (Template name ts) = sequence decls
where
transFields cs = let parts = partition' ((==) `on` fst) cs in
zip (map (fst . head) parts) (map (listToMaybe . catMaybes . map snd) parts)
(decls, _) = runState trans TplState { tplName = name, tplFields = [], tplOptions = options}
trans = do
expr <- translateTplSplices ts
modify $ \st -> st { tplFields = transFields $ tplFields st }
recD <- mkRecDecl
showD <- mkShowInstance expr
return [recD, showD]
mkRecDecl :: TplTrans DecQ
mkRecDecl = do
st <- get
let name' = mkName . tplMkName (tplOptions st) . tplName $ st
fDec (f, t) = return (mkName $ tplMkFieldName (tplOptions st) (tplName st) f, NotStrict,
fromMaybe (ConT $ mkName "String") t)
return $ dataD (cxt []) name' [] [recC name' . map fDec . tplFields $ st] []
mkShowInstance :: ExpQ -> TplTrans DecQ
mkShowInstance e = get >>= \st -> return $ instanceD (cxt [])
(appT (conT $ mkName "Show") (conT . mkName . tplMkName (tplOptions st) . tplName $ st))
[funD (mkName "show") [clause [varP $ mkName "tpl"] (normalB e) []]]
translateTplSplice :: TemplateSplice -> TplTrans (Maybe ExpQ)
translateTplSplice (TText s) = do
f <- gets $ (tplModifyText . tplOptions)
return . Just . litE . stringL . f $ s
translateTplSplice (TComment _) = return Nothing
translateTplSplice (TExpr e) = liftM Just $ translateExpr e
translateTplSplice (TConditions conds) = liftM2
(\cs es -> Just $ (newName "cond") >>=
\name -> letE [valD (varP name) (guardedB $ fCond cs es) []] (varE name))
(mapM (translateExpr . fst) conds)
(mapM (translateTplSplices . snd) conds)
where
fCond = zipWith (\c -> liftM2 (,) (normalG c))
translateTplSplices :: [TemplateSplice] -> TplTrans ExpQ
translateTplSplices = liftM ((\es -> appE (varE $ mkName "concat") (listE es)) . catMaybes) .
mapM translateTplSplice
translateExpr :: Hs.Exp -> TplTrans ExpQ
translateExpr e = liftM (return . toExp) $ replaceVars e
replaceVars :: Hs.Exp -> TplTrans Hs.Exp
replaceVars = everywhereM $ mkM f
where
f (Hs.SpliceExp (Hs.IdSplice field)) = rep Nothing field
f (Hs.SpliceExp (Hs.ParenSplice (Hs.Var (Hs.UnQual (Hs.Ident field))))) = rep Nothing field
f (Hs.SpliceExp (Hs.ParenSplice (Hs.ExpTypeSig _
(Hs.Var (Hs.UnQual (Hs.Ident field))) t))) = rep (Just $ toType t) field
f e = return e
rep t field = do
st <- get
modify $ \st' -> st' { tplFields = (field, t) : tplFields st'}
return $ Hs.App (var $ (tplMkFieldName . tplOptions) st (tplName st) field) (var "tpl")
var = Hs.Var . Hs.UnQual . Hs.Ident