{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
Module : Text.Heterocephalus
Copyright : Kadzuya Okamoto 2016
License : MIT
Stability : experimental
Portability : unknown
This module exports functions for working with frontend templates from Haskell.
-}
module Text.Heterocephalus
(
-- * Core functions
compileTextFile
, compileTextFileWith
, compileTextFileWithDefault
, compileHtmlFile
, compileHtmlFileWith
, compileHtmlFileWithDefault
-- * QuasiQuoters
, compileText
, compileHtml
-- * ScopeM
, ScopeM
, setDefault
, overwrite
-- * low-level
, 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)
{- $setup
>>> :set -XTemplateHaskell -XQuasiQuotes
>>> import Text.Blaze.Renderer.String
-}
{-| A function to compile template file.
This function __DOES NOT__ escape template variables.
To render the compiled file, use @'Text.Blaze.Renderer'.*.renderMarkup@.
>>> putStr $ renderMarkup (let as = ["", "b"] in $(compileTextFile "templates/sample.txt"))
sample
key: ,
key: b,
-}
compileTextFile :: FilePath -> Q Exp
compileTextFile = compileFile textSetting
{-| Same as 'compileText' but allows the user to specify extra values for template parameters.
Values declared by 'overwrite' overwrites same name variables.
Values declared by 'setDefault' are overwritten by same name variables.
>>> :set -XOverloadedStrings
>>> :{
putStr $ renderMarkup (
let as = ["", "b"]
in $(compileTextFileWith "templates/sample.txt" $ do
setDefault "as" [| ["foo", "bar"] |]
)
)
:}
sample
key: ,
key: b,
>>> :{
putStr $ renderMarkup (
let as = ["", "b"]
in $(compileTextFileWith "templates/sample.txt" $ do
overwrite "as" [| ["foo", "bar"] |]
)
)
:}
sample
key: foo,
key: bar,
>>> :{
putStr $ renderMarkup (
let as = ["", "b"]
in $(compileTextFileWith "templates/sample.txt" $ do
overwrite "as" [| ["bazbaz", "barbar"] |]
setDefault "as" [| ["foo", "bar"] |]
overwrite "as" [| ["baz", "foobar"] |]
)
)
:}
sample
key: baz,
key: foobar,
-}
compileTextFileWith :: FilePath -> ScopeM () -> Q Exp
compileTextFileWith fp scopeM = compileFileWith scopeM textSetting fp
{-| Same as 'compileText' but allows the user to specify default values for template parameters.
>>> :set -XOverloadedStrings
>>> :{
putStr $ renderMarkup (
let as = ["", "b"]
in $(compileTextFileWithDefault "templates/sample.txt"
[("as", [| ["foo", "bar"] |])]
)
)
:}
sample
key: ,
key: b,
>>> :{
putStr $ renderMarkup (
$(compileTextFileWithDefault "templates/sample.txt"
[("as", [| ["foo", "bar"] |])]
)
)
:}
sample
key: foo,
key: bar,
-}
compileTextFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileTextFileWithDefault fp scope = compileFileWithDefault scope textSetting fp
{-| Same as 'compileTextFile' but escapes template variables in HTML.
>>> putStr $ renderMarkup (let as = ["", "b"] in $(compileHtmlFile "templates/sample.txt"))
sample
key: <a>,
key: b,
-}
compileHtmlFile :: FilePath -> Q Exp
compileHtmlFile fp = compileHtmlFileWithDefault fp []
{-| Same as 'compileHtmlFile' but allows the user to specify extra values for template parameters.
Values declared by 'overwrite' overwrites same name variables.
Values declared by 'setDefault' are overwritten by same name variables.
>>> :set -XOverloadedStrings
>>> :{
putStr $ renderMarkup (
let as = ["", "b"]
in $(compileHtmlFileWith "templates/sample.txt" $ do
setDefault "as" [| ["foo", "bar"] |]
)
)
:}
sample
key: <a>,
key: b,
>>> :{
putStr $ renderMarkup (
let as = ["", "b"]
in $(compileHtmlFileWith "templates/sample.txt" $ do
overwrite "as" [| ["foo", "bar"] |]
)
)
:}
sample
key: foo,
key: bar,
>>> :{
putStr $ renderMarkup (
let as = ["", "b"]
in $(compileHtmlFileWith "templates/sample.txt" $ do
overwrite "as" [| ["bazbaz", "barbar"] |]
setDefault "as" [| ["foo", "bar"] |]
overwrite "as" [| ["baz", "foobar"] |]
)
)
:}
sample
key: baz,
key: foobar,
-}
compileHtmlFileWith :: FilePath -> ScopeM () -> Q Exp
compileHtmlFileWith fp scopeM = compileFileWith scopeM htmlSetting fp
{-| Same as 'compileHtmlFile' but allows the user to specify default values for template parameters.
>>> :set -XOverloadedStrings
:{
putStr $ renderMarkup (
let as = ["", "b"]
in $(compileHtmlFileWithDefault "templates/sample.txt"
[("as", [| ["foo", "bar"] |])]
)
)
:}
sample
key: <a>,
key: b,
>>> :{
putStr $ renderMarkup (
$(compileHtmlFileWithDefault "templates/sample.txt"
[("as", [| ["foo", "bar"] |])]
)
)
:}
sample
key: foo,
key: bar,
-}
compileHtmlFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileHtmlFileWithDefault fp scope = compileFileWithDefault scope htmlSetting fp
{-| Heterocephalus quasi-quoter.
This function __DOES NOT__ escape template variables.
To render the compiled file, use @'Text.Blaze.Renderer'.*.renderMarkup@.
>>> renderMarkup (let as = ["", "b"] in [compileText|sample %{ forall a <- as }key: #{a}, %{ endforall }|])
"sample key: , key: b, "
>>> renderMarkup (let num=2 in [compileText|#{num} is %{ if even num }an even number.%{ elseif (num > 100) }big.%{ else }an odd number.%{ endif }|])
"2 is an even number."
-}
compileText :: QuasiQuoter
compileText = compile textSetting
{-| Heterocephalus quasi-quoter for HTML.
Same as 'compileText' but this function does escape template variables in HTML.
>>> renderMarkup (let as = ["", "b"] in [compileHtml|sample %{ forall a <- as }key: #{a}, %{ endforall }|])
"sample key: <a>, key: b, "
-}
compileHtml :: QuasiQuoter
compileHtml = compile htmlSetting
compile :: HeterocephalusSetting -> QuasiQuoter
compile = compileWithDefault []
{-| QuasiQuoter.
-}
compileWith :: ScopeM () -> HeterocephalusSetting -> QuasiQuoter
compileWith scopeM set =
QuasiQuoter
{ quoteExp = compileFromStringWith scopeM set
, quotePat = error "not used"
, quoteType = error "not used"
, quoteDec = error "not used"
}
{-| QuasiQuoter.
-}
compileWithDefault :: DefaultScope -> HeterocephalusSetting -> QuasiQuoter
compileWithDefault scope set =
QuasiQuoter
{ quoteExp = compileFromStringWithDefault scope set
, quotePat = error "not used"
, quoteType = error "not used"
, quoteDec = error "not used"
}
{-| Compile a template file.
-}
compileFile :: HeterocephalusSetting -> FilePath -> Q Exp
compileFile = compileFileWithDefault []
{-| Same as 'compileFile' but we can specify default scope.
-}
compileFileWith :: ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWith scopeM set fp = do
qAddDependentFile fp
contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
compileFromStringWith scopeM set contents
{-| Same as 'compileFile' but we can specify default scope.
-}
compileFileWithDefault :: DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWithDefault scope' set fp = do
qAddDependentFile fp
contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
compileFromStringWithDefault scope' set contents
{-| Same as 'compileFile', but just compile the 'String' given.
>>> let as = ["", "b"]
>>> let template = "sample %{ forall a <- as }key: #{a}, %{ endforall }"
>>> renderMarkup $(compileFromString textSetting template)
"sample key: , key: b, "
>>> let as = ["", "b"]
>>> let options = createParseOptions '|' '?'
>>> let setting = textSetting { parseOptions = options }
>>> let template = "sample |{ forall a <- as }key: ?{a}, |{ endforall }"
>>> renderMarkup $(compileFromString setting template)
"sample key: , key: b, "
-}
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
{-| Settings that are used when processing heterocephalus templates.
-}
data HeterocephalusSetting = HeterocephalusSetting
{ escapeExp :: Q Exp
-- ^ Template variables are passed to 'escapeExp' in the output. This allows
-- things like escaping HTML entities. (See 'htmlSetting'.)
, parseOptions :: ParseOptions
}
{-| A setting that escapes template variables for Html
This sets 'escapeExp' to 'toHtml'.
-}
htmlSetting :: HeterocephalusSetting
htmlSetting = HeterocephalusSetting
{ escapeExp = [|toHtml|]
, parseOptions = defaultParseOptions
}
{-| A setting that DOES NOT escape template variables.
This sets 'escapeExp' to 'preEscapedToMarkup'.
-}
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)
{- | A type to handle extra scopes.
This is opaque type, so use 'setDefault' and 'overwrite'
to construct new 'ScopeM'.
-}
data ScopeM a
= SetDefault Ident ExpQ (ScopeM a)
| Overwrite Ident ExpQ (ScopeM a)
| PureScopeM a
{- | Get default values and values to overwrite from 'ScopeM'.
-}
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
{-| Constructor for 'ScopeM'.
Values declared by this function are overwritten
by same name variables exits in scope of render function.
-}
setDefault :: Ident -> Q Exp -> ScopeM ()
setDefault ident qexp = SetDefault ident qexp $ pure ()
{-| Constructor for 'ScopeM'.
Values declared by this function overwrites
same name variables exits in scope of render function.
-}
overwrite :: Ident -> Q Exp -> ScopeM ()
overwrite ident qexp = Overwrite ident qexp $ pure ()
instance IsString Ident where
fromString = Ident
-- ==============================================
-- Helper functions
-- ==============================================
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
-- ==============================================
-- Codes from Text.Hamlet that is not exposed
-- ==============================================
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]
-- Wildcards bind all of the unbound fields to variables whose name
-- matches the field name.
--
-- For example: data R = C { f1, f2 :: Int }
-- C {..} is equivalent to C {f1=f1, f2=f2}
-- C {f1 = a, ..} is equivalent to C {f1=a, f2=f2}
-- C {f2 = a, ..} is equivalent to C {f1=f1, f2=a}
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
-- Important note! reify will fail if the record type is defined in the
-- same module as the reify is used. This means quasi-quoted Hamlet
-- literals will not be able to use wildcards to match record types
-- defined in the same module.
recordToFieldNames :: DataConstr -> Q [Name]
recordToFieldNames conStr
-- use 'lookupValueName' instead of just using 'mkName' so we reify the
-- data constructor and not the type constructor if their names match.
= 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"