module Text.Heterocephalus
(
compileText
, compileTextFile
, compileHtml
, compileHtmlFile
, HeterocephalusSetting(escapeExp)
, compile
, compileFile
, compileFromString
) where
import Data.Char (isDigit)
import qualified Data.Foldable as F
import Data.List (intercalate)
import Data.Text (Text, pack)
import qualified Data.Text.Lazy as TL
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax hiding (Module)
import Text.Blaze (preEscapedToMarkup)
import Text.Blaze.Html (toHtml)
import Text.Blaze.Internal (preEscapedText)
import Text.Hamlet
import Text.Hamlet.Parse
import Text.Shakespeare.Base
import Text.Heterocephalus.Parse (Doc(..), Content(..), parseDoc)
compileText :: QuasiQuoter
compileText = compile textSetting
compileHtml :: QuasiQuoter
compileHtml = compile htmlSetting
compileTextFile :: FilePath -> Q Exp
compileTextFile = compileFile textSetting
compileHtmlFile :: FilePath -> Q Exp
compileHtmlFile = compileFile htmlSetting
compile :: HeterocephalusSetting -> QuasiQuoter
compile set =
QuasiQuoter
{ quoteExp = compileFromString set
, quotePat = error "not used"
, quoteType = error "not used"
, quoteDec = error "not used"
}
compileFile :: HeterocephalusSetting -> FilePath -> Q Exp
compileFile set fp = do
qAddDependentFile fp
contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
compileFromString set contents
compileFromString :: HeterocephalusSetting -> String -> Q Exp
compileFromString set s =
docsToExp set [] $ docFromString s
docFromString :: String -> [Doc]
docFromString s =
case parseDoc s of
Error s' -> error s'
Ok d -> d
data HeterocephalusSetting = HeterocephalusSetting
{ escapeExp :: Q Exp
}
htmlSetting :: HeterocephalusSetting
htmlSetting = HeterocephalusSetting
{ escapeExp = [|toHtml|]
}
textSetting :: HeterocephalusSetting
textSetting = HeterocephalusSetting
{ escapeExp = [|preEscapedToMarkup|]
}
docsToExp :: HeterocephalusSetting -> Scope -> [Doc] -> Q Exp
docsToExp set scope docs = do
exps <- mapM (docToExp set scope) docs
case exps of
[] -> [|return ()|]
[x] -> return x
_ -> return $ DoE $ map NoBindS exps
docToExp :: HeterocephalusSetting -> Scope -> Doc -> Q Exp
docToExp set scope (DocForall list idents inside) = do
let list' = derefToExp scope list
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
mh <- [|F.mapM_|]
inside' <- docsToExp set scope' inside
let lam = LamE [pat] inside'
return $ mh `AppE` lam `AppE` list'
docToExp set scope (DocCond conds final) = do
conds' <- mapM go conds
final' <-
case final of
Nothing -> [|Nothing|]
Just f -> do
f' <- docsToExp set scope f
j <- [|Just|]
return $ j `AppE` f'
ch <- [|condH|]
return $ ch `AppE` ListE conds' `AppE` final'
where
go :: (Deref, [Doc]) -> Q Exp
go (d, docs) = do
let d' = derefToExp ((specialOrIdent, VarE 'or) : scope) d
docs' <- docsToExp set scope docs
return $ TupE [d', docs']
docToExp set v (DocContent c) = contentToExp set v c
contentToExp :: HeterocephalusSetting -> Scope -> Content -> Q Exp
contentToExp _ _ (ContentRaw s) = do
os <- [|preEscapedText . pack|]
let s' = LitE $ StringL s
return $ os `AppE` s'
contentToExp set scope (ContentVar d) = do
str <- escapeExp set
return $ str `AppE` derefToExp scope d
unIdent :: Ident -> String
unIdent (Ident s) = s
bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern (BindAs i@(Ident s) b) = do
name <- newName s
(pattern, scope) <- bindingPattern b
return (AsP name pattern, (i, VarE name) : scope)
bindingPattern (BindVar i@(Ident s))
| s == "_" = return (WildP, [])
| all isDigit s = do return (LitP $ IntegerL $ read s, [])
| otherwise = do
name <- newName s
return (VarP name, [(i, VarE name)])
bindingPattern (BindTuple is) = do
(patterns, scopes) <- fmap unzip $ mapM bindingPattern is
return (TupP patterns, concat scopes)
bindingPattern (BindList is) = do
(patterns, scopes) <- fmap unzip $ mapM bindingPattern is
return (ListP patterns, concat scopes)
bindingPattern (BindConstr con is) = do
(patterns, scopes) <- fmap unzip $ mapM bindingPattern is
return (ConP (mkConName con) patterns, concat scopes)
bindingPattern (BindRecord con fields wild) = do
let f (Ident field, b) = do
(p, s) <- bindingPattern b
return ((mkName field, p), s)
(patterns, scopes) <- fmap unzip $ mapM f fields
(patterns1, scopes1) <-
if wild
then bindWildFields con $ map fst fields
else return ([], [])
return
(RecP (mkConName con) (patterns ++ patterns1), concat scopes ++ scopes1)
mkConName :: DataConstr -> Name
mkConName = mkName . conToStr
conToStr :: DataConstr -> String
conToStr (DCUnqualified (Ident x)) = x
conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x]
bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
bindWildFields conName fields = do
fieldNames <- recordToFieldNames conName
let available n = nameBase n `notElem` map unIdent fields
let remainingFields = filter available fieldNames
let mkPat n = do
e <- newName (nameBase n)
return ((n, VarP e), (Ident (nameBase n), VarE e))
fmap unzip $ mapM mkPat remainingFields
recordToFieldNames :: DataConstr -> Q [Name]
recordToFieldNames conStr
= do
Just conName <- lookupValueName $ conToStr conStr
DataConI _ _ typeName <- reify conName
TyConI (DataD _ _ _ _ cons _) <- reify typeName
[fields] <- return [fields | RecC name fields <- cons, name == conName]
return [fieldName | (fieldName, _, _) <- fields]
type QueryParameters = [(Text, Text)]
data VarExp msg url
= EPlain Html
| EUrl url
| EUrlParam (url, QueryParameters)
| EMixin (HtmlUrl url)
| EMixinI18n (HtmlUrlI18n msg url)
| EMsg msg
instance Show (VarExp msg url) where
show (EPlain _) = "EPlain"
show (EUrl _) = "EUrl"
show (EUrlParam _) = "EUrlParam"
show (EMixin _) = "EMixin"
show (EMixinI18n _) = "EMixinI18n"
show (EMsg _) = "EMsg"