heterocephalus-1.0.5.7/src/ 0000755 0000000 0000000 00000000000 13504632260 013653 5 ustar 00 0000000 0000000 heterocephalus-1.0.5.7/src/Text/ 0000755 0000000 0000000 00000000000 14263303313 014574 5 ustar 00 0000000 0000000 heterocephalus-1.0.5.7/src/Text/Hamlet/ 0000755 0000000 0000000 00000000000 13504632260 016011 5 ustar 00 0000000 0000000 heterocephalus-1.0.5.7/src/Text/Heterocephalus/ 0000755 0000000 0000000 00000000000 13504632260 017552 5 ustar 00 0000000 0000000 heterocephalus-1.0.5.7/src/Text/Heterocephalus/Parse/ 0000755 0000000 0000000 00000000000 13504632260 020624 5 ustar 00 0000000 0000000 heterocephalus-1.0.5.7/templates/ 0000755 0000000 0000000 00000000000 13504632260 015062 5 ustar 00 0000000 0000000 heterocephalus-1.0.5.7/test/ 0000755 0000000 0000000 00000000000 13504632260 014043 5 ustar 00 0000000 0000000 heterocephalus-1.0.5.7/src/Text/Heterocephalus.hs 0000644 0000000 0000000 00000047431 14263303603 020116 0 ustar 00 0000000 0000000 {-# 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 qualified Data.Semigroup as Sem
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 TemplateHaskell.Compat.V0208
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 Sem.Semigroup (ScopeM ()) where
a <> b = a >> b
instance Monoid (ScopeM ()) where
mempty = pure ()
#if !(MIN_VERSION_base(4,11,0))
mappend = (Sem.<>)
#endif
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 $ nonUnaryTupE [d', docs']
where
nonUnaryTupE :: [Exp] -> Exp
nonUnaryTupE es = tupE es
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
#if MIN_VERSION_template_haskell_compat_v0208(0,1,8)
{-
Todo: Note, the use of conP below (note lowercase 'c') is from the package 'template-haskell-compat-v0208'.
This allows Heterocephalus to compile with GHC 9.2, as the ConP constructor takes an additional argument in GHC 9.2
Note however this _probably_ means there was some new extension or new syntax extension that GHC now allows post GHC 9.2
that we are not able to handle. As I (clintonmead@gmail.com) am just writing a PR to the library and don't fully understand it
(I'm making this PR just to make our current project build under GHC 9.2) there's probably some more work to be done here.
The github issue relating to this is at https://github.com/arowM/heterocephalus/issues/32
-}
return (conP (mkConName con) patterns, concat scopes)
#else
return (ConP (mkConName con) patterns, concat scopes)
#endif
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"
heterocephalus-1.0.5.7/src/Text/Hamlet/Parse.hs 0000644 0000000 0000000 00000002104 13504632260 017414 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
module Text.Hamlet.Parse
( Binding (..)
, specialOrIdent
, DataConstr (..)
, Module (..)
)
where
import Data.Data (Data)
import Data.Typeable (Typeable)
import Text.Shakespeare.Base (Ident(..))
data Binding = BindVar Ident
| BindAs Ident Binding
| BindConstr DataConstr [Binding]
| BindTuple [Binding]
| BindList [Binding]
| BindRecord DataConstr [(Ident, Binding)] Bool
deriving (Eq, Show, Read, Data, Typeable)
data DataConstr = DCQualified Module Ident
| DCUnqualified Ident
deriving (Eq, Show, Read, Data, Typeable)
newtype Module = Module [String]
deriving (Eq, Show, Read, Data, Typeable)
-- | This funny hack is to allow us to refer to the 'or' function without
-- requiring the user to have it in scope. See how this function is used in
-- Text.Hamlet.
specialOrIdent :: Ident
specialOrIdent = Ident "__or__hamlet__special"
heterocephalus-1.0.5.7/src/Text/Heterocephalus/Parse.hs 0000644 0000000 0000000 00000002004 13504632260 021154 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Text.Heterocephalus.Parse
( module Text.Heterocephalus.Parse
, module Text.Heterocephalus.Parse.Control
, module Text.Heterocephalus.Parse.Doc
, module Text.Heterocephalus.Parse.Option
) where
import Text.Heterocephalus.Parse.Control (Content(..), parseLineControl)
import Text.Heterocephalus.Parse.Doc
(Doc(..), parseDocFromControls)
import Text.Heterocephalus.Parse.Option
(ParseOptions(..), createParseOptions, defaultParseOptions)
docFromString :: ParseOptions -> String -> [Doc]
docFromString opts s =
case parseDoc opts s of
Left s' -> error s'
Right d -> d
parseDoc :: ParseOptions -> String -> Either String [Doc]
parseDoc opts s = do
controls <- parseLineControl opts s
case parseDocFromControls controls of
Left parseError -> Left $ show parseError
Right docs -> Right docs
heterocephalus-1.0.5.7/src/Text/Heterocephalus/Parse/Control.hs 0000644 0000000 0000000 00000026107 13504632260 022606 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Text.Heterocephalus.Parse.Control where
#if MIN_VERSION_base(4,9,0)
#else
import Control.Applicative ((<$>), (*>), (<*), pure)
#endif
import Control.Monad (guard, void)
import Control.Monad.Reader (Reader, runReaderT)
import Data.Char (isUpper)
import Data.Data (Data)
import Data.Functor (($>))
import Data.Functor.Identity (runIdentity)
import Data.Typeable (Typeable)
import Text.Parsec
(Parsec, ParsecT, (), (<|>), alphaNum, between, char, choice,
eof, many, many1, manyTill, mkPT, noneOf, oneOf, option, optional,
runParsecT, runParserT, sepBy, skipMany, spaces, string,
try)
import Text.Shakespeare.Base
(Ident(Ident), Deref, parseDeref, parseVar)
import Text.Hamlet.Parse
import Text.Heterocephalus.Parse.Option
(ParseOptions, getControlPrefix, getVariablePrefix)
data Control
= ControlForall Deref Binding
| ControlEndForall
| ControlIf Deref
| ControlElse
| ControlElseIf Deref
| ControlEndIf
| ControlCase Deref
| ControlCaseOf Binding
| ControlEndCase
| NoControl Content
deriving (Data, Eq, Read, Show, Typeable)
data Content = ContentRaw String
| ContentVar Deref
deriving (Data, Eq, Read, Show, Typeable)
type UserParser = ParsecT String () (Reader ParseOptions)
parseLineControl :: ParseOptions -> String -> Either String [Control]
parseLineControl opts s =
let readerT = runParserT lineControl () "" s
res = runIdentity $ runReaderT readerT opts
in case res of
Left e -> Left $ show e
Right x -> Right x
lineControl :: UserParser [Control]
lineControl = manyTill control $ try eof >> return ()
control :: UserParser Control
control = noControlVariable <|> controlStatement <|> noControlRaw
where
controlStatement :: UserParser Control
controlStatement = do
x <- parseControlStatement
case x of
Left str -> return (NoControl $ ContentRaw str)
Right ctrl -> return ctrl
noControlVariable :: UserParser Control
noControlVariable = do
variablePrefix <- getVariablePrefix
x <- identityToReader $ parseVar variablePrefix
return . NoControl $
case x of
Left str -> ContentRaw str
Right deref -> ContentVar deref
noControlRaw :: UserParser Control
noControlRaw = do
controlPrefix <- getControlPrefix
variablePrefix <- getVariablePrefix
(NoControl . ContentRaw) <$>
many (noneOf [controlPrefix, variablePrefix])
parseControlStatement :: UserParser (Either String Control)
parseControlStatement = do
a <- parseControl
optional eol
return a
where
eol :: UserParser ()
eol = void (char '\n') <|> void (string "\r\n")
parseControl :: UserParser (Either String Control)
parseControl = do
controlPrefix <- getControlPrefix
void $ char controlPrefix
let escape = char '\\' $> Left [controlPrefix]
escape <|>
(Right <$> parseControlBetweenBrackets) <|>
return (Left [controlPrefix])
parseControlBetweenBrackets :: UserParser Control
parseControlBetweenBrackets =
between (char '{') (char '}') $ spaces *> parseControl' <* spaces
parseControl' :: UserParser Control
parseControl' =
try parseForall <|> try parseEndForall <|> try parseIf <|> try parseElseIf <|>
try parseElse <|>
try parseEndIf <|>
try parseCase <|>
try parseCaseOf <|>
try parseEndCase
where
parseForall :: UserParser Control
parseForall = do
string "forall" *> spaces
(x, y) <- binding
pure $ ControlForall x y
parseEndForall :: UserParser Control
parseEndForall = string "endforall" $> ControlEndForall
parseIf :: UserParser Control
parseIf =
string "if" *> spaces *> fmap ControlIf (identityToReader parseDeref)
parseElseIf :: UserParser Control
parseElseIf =
string "elseif" *>
spaces *>
fmap ControlElseIf (identityToReader parseDeref)
parseElse :: UserParser Control
parseElse = string "else" $> ControlElse
parseEndIf :: UserParser Control
parseEndIf = string "endif" $> ControlEndIf
parseCase :: UserParser Control
parseCase =
string "case" *>
spaces *>
fmap ControlCase (identityToReader parseDeref)
parseCaseOf :: UserParser Control
parseCaseOf = string "of" *> spaces *> fmap ControlCaseOf identPattern
parseEndCase :: UserParser Control
parseEndCase = string "endcase" $> ControlEndCase
binding :: UserParser (Deref, Binding)
binding = do
y <- identPattern
spaces
_ <- string "<-"
spaces
x <- identityToReader parseDeref
_ <- spaceTabs
return (x, y)
spaceTabs :: UserParser String
spaceTabs = many $ oneOf " \t"
-- | Parse an indentifier. This is an sequence of alphanumeric characters,
-- or an operator.
ident :: UserParser Ident
ident = do
i <- (many1 (alphaNum <|> char '_' <|> char '\'')) <|> try operator
white
return (Ident i) "identifier"
-- | Parse an operator. An operator is a sequence of characters in
-- 'operatorList' in between parenthesis.
operator :: UserParser String
operator = do
oper <- between (char '(') (char ')') . many1 $ oneOf operatorList
pure $ oper
operatorList :: String
operatorList = "!#$%&*+./<=>?@\\^|-~:"
parens :: UserParser a -> UserParser a
parens = between (char '(' >> white) (char ')' >> white)
brackets :: UserParser a -> UserParser a
brackets = between (char '[' >> white) (char ']' >> white)
braces :: UserParser a -> UserParser a
braces = between (char '{' >> white) (char '}' >> white)
comma :: UserParser ()
comma = char ',' >> white
atsign :: UserParser ()
atsign = char '@' >> white
equals :: UserParser ()
equals = char '=' >> white
white :: UserParser ()
white = skipMany $ char ' '
wildDots :: UserParser ()
wildDots = string ".." >> white
-- | Return 'True' if 'Ident' is a variable. Variables are defined as
-- starting with a lowercase letter.
isVariable :: Ident -> Bool
isVariable (Ident (x:_)) = not (isUpper x)
isVariable (Ident []) = error "isVariable: bad identifier"
-- | Return 'True' if an 'Ident' is a constructor. Constructors are
-- defined as either starting with an uppercase letter, or being an
-- operator.
isConstructor :: Ident -> Bool
isConstructor (Ident (x:_)) = isUpper x || elem x operatorList
isConstructor (Ident []) = error "isConstructor: bad identifier"
-- | This function tries to parse an entire pattern binding with either
-- @'gcon' True@ or 'apat'. For instance, in the pattern
-- @let Foo a b = ...@, this function tries to parse @Foo a b@ with 'gcon'.
-- In the pattern @let n = ...@, this function tries to parse @n@ with
-- 'apat'.
identPattern :: UserParser Binding
identPattern = gcon True <|> apat
where
apat :: UserParser Binding
apat = choice [varpat, gcon False, parens tuplepat, brackets listpat]
-- | Parse a variable in a pattern. For instance in, in a pattern like
-- @let Just n = ...@, this function would be what is used to parse the
-- @n@. This function also handles aliases with @\@@.
varpat :: UserParser Binding
varpat = do
v <-
try $ do
v <- ident
guard (isVariable v)
return v
option (BindVar v) $ do
atsign
b <- apat
return (BindAs v b) "variable"
-- | This function tries to parse an entire pattern binding. For
-- instance, in the pattern @let Foo a b = ...@, this function tries to
-- parse @Foo a b@.
--
-- This function first tries to parse a data contructor (using
-- 'dataConstr'). In the example above, that would be like parsing
-- @Foo@.
--
-- Then, the function tries to do two different things.
--
-- 1. It tries to parse record syntax with 'record'. In a pattern like
-- @let Foo{foo1 = 3, foo2 = "hello"} = ...@, it would parse the
-- @{foo1 = 3, foo2 = "hello"}@ part.
--
-- 2. If parsing the record syntax fails, it then tries to parse
-- many normal patterns with 'apat'. In a pattern like
-- @let Foo a b = ...@, it would be like parsing the @a b@ part.
--
-- If that fails, then it just returns the original data contructor
-- with no arguments.
--
-- The 'Bool' argument determines whether or not it tries to parse
-- normal patterns in 2. If the boolean argument is 'True', then it
-- tries parsing normal patterns in 2. If the boolean argument is
-- 'False', then 2 is skipped altogether.
gcon :: Bool -> UserParser Binding
gcon allowArgs = do
c <- try dataConstr
choice
[ record c
, fmap (BindConstr c) (guard allowArgs >> many apat)
, return (BindConstr c [])
]
"constructor"
-- | Parse a possibly qualified identifier using 'ident'.
dataConstr :: UserParser DataConstr
dataConstr = do
p <- dcPiece
ps <- many dcPieces
return $ toDataConstr p ps
dcPiece :: UserParser String
dcPiece = do
x@(Ident y) <- ident
guard $ isConstructor x
return y
dcPieces :: UserParser String
dcPieces = do
_ <- char '.'
dcPiece
toDataConstr :: String -> [String] -> DataConstr
toDataConstr x [] = DCUnqualified $ Ident x
toDataConstr x (y:ys) = go (x :) y ys
where
go :: ([String] -> [String]) -> String -> [String] -> DataConstr
go front next [] = DCQualified (Module $ front []) (Ident next)
go front next (rest:rests) = go (front . (next :)) rest rests
record :: DataConstr -> UserParser Binding
record c =
braces $ do
(fields, wild) <- option ([], False) go
return (BindRecord c fields wild)
where
go :: UserParser ([(Ident, Binding)], Bool)
go =
(wildDots >> return ([], True)) <|>
(do x <- recordField
(xs, wild) <- option ([], False) (comma >> go)
return (x : xs, wild))
recordField :: UserParser (Ident, Binding)
recordField = do
field <- ident
p <-
option
(BindVar field) -- support punning
(equals >> identPattern)
return (field, p)
tuplepat :: UserParser Binding
tuplepat = do
xs <- identPattern `sepBy` comma
return $
case xs of
[x] -> x
_ -> BindTuple xs
listpat :: UserParser Binding
listpat = BindList <$> identPattern `sepBy` comma
identityToReader :: Parsec String () a -> UserParser a
identityToReader p =
mkPT $ pure . fmap (pure . runIdentity) . runIdentity . runParsecT p
heterocephalus-1.0.5.7/src/Text/Heterocephalus/Parse/Doc.hs 0000644 0000000 0000000 00000010026 13504632260 021664 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Text.Heterocephalus.Parse.Doc where
#if MIN_VERSION_base(4,9,0)
#else
import Control.Applicative ((*>), (<*), pure)
#endif
import Control.Monad (void)
import Data.Data (Data)
import Data.Typeable (Typeable)
import Text.Parsec
(Parsec, ParseError, SourcePos, (<|>), eof, incSourceLine, many,
many1, optional, optionMaybe, parse, tokenPrim)
import Text.Shakespeare.Base (Deref)
import Text.Hamlet.Parse
import Text.Heterocephalus.Parse.Control (Content(..), Control(..))
data Doc = DocForall Deref Binding [Doc]
| DocCond [(Deref, [Doc])] (Maybe [Doc])
| DocCase Deref [(Binding, [Doc])]
| DocContent Content
deriving (Data, Eq, Read, Show, Typeable)
type DocParser = Parsec [Control] ()
parseDocFromControls :: [Control] -> Either ParseError [Doc]
parseDocFromControls = parse (docsParser <* eof) ""
docsParser :: DocParser [Doc]
docsParser = many docParser
docParser :: DocParser Doc
docParser = forallDoc <|> condDoc <|> caseDoc <|> contentDoc
forallDoc :: DocParser Doc
forallDoc = do
ControlForall deref binding <- forallControlStatement
innerDocs <- docsParser
void endforallControlStatement
pure $ DocForall deref binding innerDocs
condDoc :: DocParser Doc
condDoc = do
ControlIf ifDeref <- ifControlStatement
ifInnerDocs <- docsParser
elseIfs <- condElseIfs
maybeElseInnerDocs <- optionMaybe $ elseControlStatement *> docsParser
void endifControlStatement
let allConds = (ifDeref, ifInnerDocs) : elseIfs
pure $ DocCond allConds maybeElseInnerDocs
caseDoc :: DocParser Doc
caseDoc = do
ControlCase caseDeref <- caseControlStatement
-- Ignore a single, optional NoControl statement (with whitespace that will be
-- ignored).
optional contentDoc
caseOfs <- many1 $ do
ControlCaseOf caseBinding <- caseOfControlStatement
innerDocs <- docsParser
pure (caseBinding, innerDocs)
void endcaseControlStatement
pure $ DocCase caseDeref caseOfs
contentDoc :: DocParser Doc
contentDoc = primControlStatement $ \case
NoControl content -> Just $ DocContent content
_ -> Nothing
condElseIfs :: DocParser [(Deref, [Doc])]
condElseIfs = many $ do
ControlElseIf elseIfDeref <- elseIfControlStatement
elseIfInnerDocs <- docsParser
pure (elseIfDeref, elseIfInnerDocs)
ifControlStatement :: DocParser Control
ifControlStatement = primControlStatement $ \case
ControlIf deref -> Just $ ControlIf deref
_ -> Nothing
elseIfControlStatement :: DocParser Control
elseIfControlStatement = primControlStatement $ \case
ControlElseIf deref -> Just $ ControlElseIf deref
_ -> Nothing
elseControlStatement :: DocParser Control
elseControlStatement = primControlStatement $ \case
ControlElse -> Just ControlElse
_ -> Nothing
endifControlStatement :: DocParser Control
endifControlStatement = primControlStatement $ \case
ControlEndIf -> Just ControlEndIf
_ -> Nothing
caseControlStatement :: DocParser Control
caseControlStatement = primControlStatement $ \case
ControlCase deref -> Just $ ControlCase deref
_ -> Nothing
caseOfControlStatement :: DocParser Control
caseOfControlStatement = primControlStatement $ \case
ControlCaseOf binding -> Just $ ControlCaseOf binding
_ -> Nothing
endcaseControlStatement :: DocParser Control
endcaseControlStatement = primControlStatement $ \case
ControlEndCase -> Just ControlEndCase
_ -> Nothing
forallControlStatement :: DocParser Control
forallControlStatement = primControlStatement $ \case
ControlForall deref binding -> Just $ ControlForall deref binding
_ -> Nothing
endforallControlStatement :: DocParser Control
endforallControlStatement = primControlStatement $ \case
ControlEndForall -> Just ControlEndForall
_ -> Nothing
primControlStatement :: (Control -> Maybe x)-> DocParser x
primControlStatement = tokenPrim show incSourcePos
incSourcePos :: SourcePos -> a -> b -> SourcePos
incSourcePos sourcePos _ _ = incSourceLine sourcePos 1
heterocephalus-1.0.5.7/src/Text/Heterocephalus/Parse/Option.hs 0000644 0000000 0000000 00000001716 13504632260 022435 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module Text.Heterocephalus.Parse.Option where
import Control.Monad.Reader (MonadReader, reader)
data ParseOptions = ParseOptions
{ parseOptionsControlPrefix :: Char
, parseOptionsVariablePrefix :: Char
}
-- | Default set of parser options.
--
-- Sets 'parseOptionsControlPrefix' to @\'%\'@ and
-- 'parseOptionsVariablePrefix' to @\'#\'@.
defaultParseOptions :: ParseOptions
defaultParseOptions = createParseOptions '%' '#'
createParseOptions
:: Char -- ^ The control prefix.
-> Char -- ^ The variable prefix.
-> ParseOptions
createParseOptions controlPrefix varPrefix = ParseOptions
{ parseOptionsControlPrefix = controlPrefix
, parseOptionsVariablePrefix = varPrefix
}
getControlPrefix :: MonadReader ParseOptions m => m Char
getControlPrefix = reader parseOptionsControlPrefix
getVariablePrefix :: MonadReader ParseOptions m => m Char
getVariablePrefix = reader parseOptionsVariablePrefix
heterocephalus-1.0.5.7/test/Doctest.hs 0000644 0000000 0000000 00000000561 14206077554 016017 0 ustar 00 0000000 0000000 module Main where
import Data.Monoid ((<>))
import System.FilePath.Glob (glob)
import Test.DocTest (doctest)
main :: IO ()
-- main = glob "src/**/*.hs" >>= doDocTest
main = return ()
doDocTest :: [String] -> IO ()
doDocTest options = doctest $ options <> ghcExtensions
ghcExtensions :: [String]
ghcExtensions =
[ "-XTemplateHaskell"
, "-XQuasiQuotes"
]
heterocephalus-1.0.5.7/test/Spec.hs 0000644 0000000 0000000 00000000077 13504632260 015275 0 ustar 00 0000000 0000000 main :: IO ()
main = putStrLn "Test suite not yet implemented"
heterocephalus-1.0.5.7/templates/sample.txt 0000644 0000000 0000000 00000000065 13504632260 017105 0 ustar 00 0000000 0000000 sample
%{ forall a <- as }
key: #{a},
%{ endforall }
heterocephalus-1.0.5.7/README.md 0000644 0000000 0000000 00000016777 14263325267 014376 0 ustar 00 0000000 0000000 [](https://github.com/arowM/heterocephalus/actions/workflows/test.yaml)
[](https://hackage.haskell.org/package/heterocephalus)
[](http://stackage.org/lts/package/heterocephalus)
[](http://stackage.org/nightly/package/heterocephalus)
# Heterocephalus template engine
A type-safe template engine for working with popular front end development tools.
Any PRs are welcome, even for documentation fixes. (The main author of this library is not an English native.)
* [Who should use this?](#who-should-use-this)
* [Features](#features)
* [Usage](#usage)
* [Checking behaviours in `ghci`](#checking-behaviours-in-ghci)
* [Syntax](#syntax)
* [Why "heterocephalus"?](#why-heterocephalus)
## Who should use this?
If you are planning to use Haskell with recent web front-end tools like gulp,
webpack, npm, etc, then this library can help you!
There are many Haskell template engines today.
[Shakespeare](http://hackage.haskell.org/package/shakespeare) is great because
it checks template variables at compile time. Using Shakespeare, it's not
possible for the template file to cause a runtime-error.
Shakespeare provides its own original ways of writing HTML
([Hamlet](https://hackage.haskell.org/package/shakespeare/docs/Text-Hamlet.html)),
CSS
([Cassius](https://hackage.haskell.org/package/shakespeare/docs/Text-Cassius.html)
/
[Lucius](https://hackage.haskell.org/package/shakespeare/docs/Text-Lucius.html)),
and JavaScript
([Julius](https://hackage.haskell.org/package/shakespeare-2.0.11.2/docs/Text-Julius.html)).
If you use these original markup languages, it is possible to use control
statements like `forall` (for looping), `if` (for conditionals), and `case`
(for case-splitting).
However, if you're using any other markup language (like
[pug](https://pugjs.org), [slim](http://slim-lang.com/),
[haml](http://haml.info/), normal HTML, normal CSS, etc), Shakespeare only
provides you with the
[Text.Shakespeare.Text](https://hackage.haskell.org/package/shakespeare/docs/Text-Shakespeare-Text.html)
module. This gives you variable interpolation, but no control statements like
`forall`, `if`, or `case`.
[`Haiji`](https://hackage.haskell.org/package/haiji) is another interesting
library. It has all the features we require, but its templates take a very
[long time to compile](https://github.com/blueimpact/kucipong/pull/7) with
GHC >= 7.10.
Heterocephalus fills this missing niche. It gives you variable interpolation
along with control statements that can be used with any markup language. Its
compile times are reasonable.
## Features
Here are the main features of this module.
* __DO__ ensure that all interpolated variables are in scope
* __DO__ ensure that all interpolated variables have proper types for the template
* __DO__ expand the template literal on compile time
* __DO__ provide a way to use `forall`, `if`, and `case` statments in the template
`Text.Shakespeare.Text.text` has a way to do variable interpolation, but no
way to use these types of control statements.
* __DO NOT__ enforce that templates obey a peculiar syntax
Shakespeare templates make you use their original style (Hamlet, Cassius,
Lucius, Julius, etc). The
[`Text.Shakespeare.Text.text`](https://hackage.haskell.org/package/shakespeare/docs/Text-Shakespeare-Text.html#v:text)
function does not require you to use any particular style, but it does not
have control statements like `forall`, `if` and `case`.
This makes it impossible to use Shakespeare with another template engine
such as `pug` in front end side. It is not suitable for recent rich front
end tools.
* __DO NOT__ have a long compile time
`haiji` is another awesome template library. It has many of our required
features, but it takes too long to compile when used with ghc >= 7.10.
* __DO NOT__ provide unneeded control statements
Other template engines like [EDE](https://hackage.haskell.org/package/ede)
provide rich control statements like importing external files.
Heterocephalus does not provide control statements like this because it is
meant to be used with a rich front-end template engine (like pug, slim,
etc).
## Usage
You can compile external template files with the following four functions:
* `compileTextFile`: A basic function that embeds variables without escaping and without default values.
* `compileTextFileWithDefault`: Same as `compileTextFile` but you can set default template values.
* `compileHtmlFile`: Same as `compileTextFile` but all embeded variables are escaped for html.
* `compileHtmlFileWithDefault`: Same as `compileHtmlFile` but you can set default template values.
For more details, see the [latest haddock
document](https://www.stackage.org/haddock/nightly/heterocephalus/Text-Heterocephalus.html).
## Checking behaviours in `ghci`
To check the behaviour, you can test in `ghci` as follows. Note that
`compileText` and `compileHtml` are used for checking syntaxes.
```haskell
$ stack install heterocephalus # Only first time
$ stack repl --no-build --no-load
Prelude> :m Text.Heterocephalus Text.Blaze.Renderer.String
Prelude> :set -XTemplateHaskell -XQuasiQuotes
Prelude> let a = 34; b = "