module Text.Heterocephalus
(
compileTextFile
, compileTextFileWith
, compileTextFileWithDefault
, compileHtmlFile
, compileHtmlFileWith
, compileHtmlFileWithDefault
, compileText
, compileHtml
, ScopeM
, setDefault
, overwrite
, HeterocephalusSetting(..)
, textSetting
, htmlSetting
, ParseOptions(..)
, defaultParseOptions
, createParseOptions
, DefaultScope
, compile
, compileWith
, compileWithDefault
, compileFile
, compileFileWith
, compileFileWithDefault
, compileFromString
, compileFromStringWithDefault
) where
#if MIN_VERSION_base(4,9,0)
#else
import Control.Applicative ((<$>), (<*>), Applicative(..))
import Data.Monoid (Monoid, mempty, mappend)
#endif
import Control.Monad (forM)
import Data.Char (isDigit)
import Data.DList (DList)
import qualified Data.DList as DList
import qualified Data.Foldable as F
import Data.List (intercalate)
import Data.String (IsString(..))
import Data.Text (Text, pack)
import qualified Data.Text.Lazy as TL
import Language.Haskell.TH.Lib (ExpQ, varE)
import Language.Haskell.TH.Quote
(QuasiQuoter(QuasiQuoter), quoteExp, quoteDec, quotePat, quoteType)
#if MIN_VERSION_template_haskell(2,9,0)
import Language.Haskell.TH.Syntax
(Body(..), Con(..), Dec(..), Exp(..), Info(..), Lit(..), Match(..),
Name(..), Pat(..), Q, Stmt(..), lookupValueName, mkName, nameBase,
newName, qAddDependentFile, qRunIO, reify)
#else
import Language.Haskell.TH.Syntax
#endif
import Text.Blaze (preEscapedToMarkup)
import Text.Blaze.Html (toHtml)
import Text.Blaze.Internal (preEscapedText)
import Text.Hamlet (Html, HtmlUrl, HtmlUrlI18n, condH)
import Text.Hamlet.Parse
(Binding(..), DataConstr(..), Module(Module), specialOrIdent)
import Text.Shakespeare.Base
(Deref, Ident(..), Scope, derefToExp, readUtf8File)
import Text.Heterocephalus.Parse
(Doc(..), Content(..), ParseOptions(..), createParseOptions,
defaultParseOptions, docFromString)
compileTextFile :: FilePath -> Q Exp
compileTextFile = compileFile textSetting
compileTextFileWith :: FilePath -> ScopeM () -> Q Exp
compileTextFileWith fp scopeM = compileFileWith scopeM textSetting fp
compileTextFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileTextFileWithDefault fp scope = compileFileWithDefault scope textSetting fp
compileHtmlFile :: FilePath -> Q Exp
compileHtmlFile fp = compileHtmlFileWithDefault fp []
compileHtmlFileWith :: FilePath -> ScopeM () -> Q Exp
compileHtmlFileWith fp scopeM = compileFileWith scopeM htmlSetting fp
compileHtmlFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileHtmlFileWithDefault fp scope = compileFileWithDefault scope htmlSetting fp
compileText :: QuasiQuoter
compileText = compile textSetting
compileHtml :: QuasiQuoter
compileHtml = compile htmlSetting
compile :: HeterocephalusSetting -> QuasiQuoter
compile = compileWithDefault []
compileWith :: ScopeM () -> HeterocephalusSetting -> QuasiQuoter
compileWith scopeM set =
QuasiQuoter
{ quoteExp = compileFromStringWith scopeM set
, quotePat = error "not used"
, quoteType = error "not used"
, quoteDec = error "not used"
}
compileWithDefault :: DefaultScope -> HeterocephalusSetting -> QuasiQuoter
compileWithDefault scope set =
QuasiQuoter
{ quoteExp = compileFromStringWithDefault scope set
, quotePat = error "not used"
, quoteType = error "not used"
, quoteDec = error "not used"
}
compileFile :: HeterocephalusSetting -> FilePath -> Q Exp
compileFile = compileFileWithDefault []
compileFileWith :: ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWith scopeM set fp = do
qAddDependentFile fp
contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
compileFromStringWith scopeM set contents
compileFileWithDefault :: DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWithDefault scope' set fp = do
qAddDependentFile fp
contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
compileFromStringWithDefault scope' set contents
compileFromString :: HeterocephalusSetting -> String -> Q Exp
compileFromString = compileFromStringWithDefault []
compileFromStringWith :: ScopeM () -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWith scopeM set s = do
defScope' <-
forM defScope $ \(ident, qexp) -> (ident, ) <$> overwriteScope ident qexp
owScope' <-
forM owScope $ \(ident, qexp) -> (ident, ) <$> qexp
docsToExp set (owScope' ++ defScope') $ docFromString (parseOptions set) s
where
(defDList, owDList) = runScopeM scopeM
defScope = DList.toList defDList
owScope = DList.toList owDList
compileFromStringWithDefault :: DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWithDefault scope' set s = do
scope <-
forM scope' $ \(ident, qexp) -> (ident, ) <$> overwriteScope ident qexp
docsToExp set scope $ docFromString (parseOptions set) s
overwriteScope :: Ident -> Q Exp -> Q Exp
overwriteScope (Ident str) qexp = do
mName <- lookupValueName str
case mName of
Just x -> varE x
Nothing -> qexp
data HeterocephalusSetting = HeterocephalusSetting
{ escapeExp :: Q Exp
, parseOptions :: ParseOptions
}
htmlSetting :: HeterocephalusSetting
htmlSetting = HeterocephalusSetting
{ escapeExp = [|toHtml|]
, parseOptions = defaultParseOptions
}
textSetting :: HeterocephalusSetting
textSetting = HeterocephalusSetting
{ escapeExp = [|preEscapedToMarkup|]
, parseOptions = defaultParseOptions
}
type DefaultScope = [(Ident, Q Exp)]
type DefaultDList = DList (Ident, Q Exp)
type OverwriteDList = DList (Ident, Q Exp)
data ScopeM a
= SetDefault Ident ExpQ (ScopeM a)
| Overwrite Ident ExpQ (ScopeM a)
| PureScopeM a
runScopeM :: ScopeM a -> (DefaultDList, OverwriteDList)
runScopeM (SetDefault ident qexp next) =
let (defaults, overwrites) = runScopeM next
in (DList.snoc defaults (ident, qexp), overwrites)
runScopeM (Overwrite ident qexp next) =
let (defaults, overwrites) = runScopeM next
in (defaults, DList.snoc overwrites (ident, qexp))
runScopeM (PureScopeM _) =
(mempty, mempty)
instance Monoid (ScopeM ()) where
mempty = pure ()
mappend a b = a >> b
instance Functor ScopeM where
fmap f (SetDefault ident qexp next) =
SetDefault ident qexp $ fmap f next
fmap f (Overwrite ident qexp next) =
Overwrite ident qexp $ fmap f next
fmap f (PureScopeM x) =
PureScopeM $ f x
instance Applicative ScopeM where
pure = PureScopeM
SetDefault ident qexp next <*> f =
SetDefault ident qexp $ next <*> f
Overwrite ident qexp next <*> f =
Overwrite ident qexp $ next <*> f
PureScopeM g <*> f = f >>= (PureScopeM . g)
instance Monad ScopeM where
#if MIN_VERSION_base(4,9,0)
#else
return = PureScopeM
#endif
SetDefault ident qexp next >>= f = SetDefault ident qexp $ next >>= f
Overwrite ident qexp next >>= f = Overwrite ident qexp $ next >>= f
PureScopeM a >>= f = f a
setDefault :: Ident -> Q Exp -> ScopeM ()
setDefault ident qexp = SetDefault ident qexp $ pure ()
overwrite :: Ident -> Q Exp -> ScopeM ()
overwrite ident qexp = Overwrite ident qexp $ pure ()
instance IsString Ident where
fromString = Ident
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 scope (DocCase deref cases) = do
let exp_ = derefToExp scope deref
matches <- mapM toMatch cases
return $ CaseE exp_ matches
where
toMatch :: (Binding, [Doc]) -> Q Match
toMatch (idents, inside) = do
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
insideExp <- docsToExp set scope' inside
return $ Match pat (NormalB insideExp) []
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
#if MIN_VERSION_template_haskell(2,11,0)
DataConI _ _ typeName <- reify conName
TyConI (DataD _ _ _ _ cons _) <- reify typeName
#else
DataConI _ _ typeName _ <- reify conName
TyConI (DataD _ _ _ cons _) <- reify typeName
#endif
[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"