{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module Text.Hamlet
    ( -- * Plain HTML
      Html
    , shamlet
    , shamletFile
    , xshamlet
    , xshamletFile
      -- * Hamlet
    , HtmlUrl
    , Render
    , hamlet
    , hamletFile
    , hamletFileReload
    , xhamlet
    , xhamletFile
      -- * I18N Hamlet
    , HtmlUrlI18n
    , Translate
    , ihamlet
    , ihamletFile
    , ihamletFileReload
      -- * Type classes
    , ToAttributes (..)
      -- * Internal, for making more
    , HamletSettings (..)
    , NewlineStyle (..)
    , hamletWithSettings
    , hamletFileWithSettings
    , defaultHamletSettings
    , xhtmlHamletSettings
    , Env (..)
    , HamletRules (..)
    , hamletRules
    , ihamletRules
    , htmlRules
    , CloseStyle (..)
      -- * Used by generated code
    , condH
    , maybeH
    , asHtmlUrl
    , attrsToHtml
     -- * low-level
    , hamletFromString
    ) where

import Text.Shakespeare.Base
import Text.Hamlet.Parse
import Language.Haskell.TH.Syntax hiding (Module)
import Language.Haskell.TH.Quote
import Data.Char (isUpper, isDigit)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import qualified Data.Text.Lazy as TL
import Text.Blaze.Html (Html, toHtml)
import Text.Blaze.Internal (preEscapedText)
import qualified Data.Foldable as F
import Control.Monad (mplus)
import Data.Monoid (mempty, mappend, mconcat)
import Control.Arrow ((***))
import Data.List (intercalate)

import Data.IORef
import qualified Data.Map as M
import System.IO.Unsafe (unsafePerformIO)
import System.Directory (getModificationTime)
import Data.Time (UTCTime)
import Text.Blaze.Html (preEscapedToHtml)

-- | Convert some value to a list of attribute pairs.
class ToAttributes a where
    toAttributes :: a -> [(Text, Text)]
instance ToAttributes (Text, Text) where
    toAttributes :: (Text, Text) -> [(Text, Text)]
toAttributes = (Text, Text) -> [(Text, Text)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return
instance ToAttributes (String, String) where
    toAttributes :: (FilePath, FilePath) -> [(Text, Text)]
toAttributes (FilePath
k, FilePath
v) = [(FilePath -> Text
pack FilePath
k, FilePath -> Text
pack FilePath
v)]
instance ToAttributes [(Text, Text)] where
    toAttributes :: [(Text, Text)] -> [(Text, Text)]
toAttributes = [(Text, Text)] -> [(Text, Text)]
forall a. a -> a
id
instance ToAttributes [(String, String)] where
    toAttributes :: [(FilePath, FilePath)] -> [(Text, Text)]
toAttributes = ((FilePath, FilePath) -> (Text, Text))
-> [(FilePath, FilePath)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
pack (FilePath -> Text)
-> (FilePath -> Text) -> (FilePath, FilePath) -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** FilePath -> Text
pack)

attrsToHtml :: [(Text, Text)] -> Html
attrsToHtml :: [(Text, Text)] -> Html
attrsToHtml =
    ((Text, Text) -> Html -> Html) -> Html -> [(Text, Text)] -> Html
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, Text) -> Html -> Html
forall {a}. ToMarkup a => (Text, a) -> Html -> Html
go Html
forall a. Monoid a => a
mempty
  where
    go :: (Text, a) -> Html -> Html
go (Text
k, a
v) Html
rest =
        FilePath -> Html
forall a. ToMarkup a => a -> Html
toHtml FilePath
" "
        Html -> Html -> Html
forall a. Monoid a => a -> a -> a
`mappend` Text -> Html
preEscapedText Text
k
        Html -> Html -> Html
forall a. Monoid a => a -> a -> a
`mappend` Text -> Html
preEscapedText (FilePath -> Text
pack FilePath
"=\"")
        Html -> Html -> Html
forall a. Monoid a => a -> a -> a
`mappend` a -> Html
forall a. ToMarkup a => a -> Html
toHtml a
v
        Html -> Html -> Html
forall a. Monoid a => a -> a -> a
`mappend` Text -> Html
preEscapedText (FilePath -> Text
pack FilePath
"\"")
        Html -> Html -> Html
forall a. Monoid a => a -> a -> a
`mappend` Html
rest

type Render url = url -> [(Text, Text)] -> Text
type Translate msg = msg -> Html

-- | A function generating an 'Html' given a URL-rendering function.
type HtmlUrl url = Render url -> Html

-- | A function generating an 'Html' given a message translator and a URL rendering function.
type HtmlUrlI18n msg url = Translate msg -> Render url -> Html

docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
docs = do
    exps <- (Doc -> Q Exp) -> [Doc] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Env -> HamletRules -> Scope -> Doc -> Q Exp
docToExp Env
env HamletRules
hr Scope
scope) [Doc]
docs
    case exps of
        [] -> [|return ()|]
        [Exp
x] -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
        [Exp]
_ -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Maybe ModName -> [Stmt] -> Exp
DoE
#if MIN_VERSION_template_haskell(2,17,0)
                Maybe ModName
forall a. Maybe a
Nothing
#endif
                ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Stmt) -> [Exp] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Stmt
NoBindS [Exp]
exps

unIdent :: Ident -> String
unIdent :: Ident -> FilePath
unIdent (Ident FilePath
s) = FilePath
s

bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern :: Binding -> Q (Pat, Scope)
bindingPattern (BindAs i :: Ident
i@(Ident FilePath
s) Binding
b) = do
    name <- FilePath -> Q Name
forall (m :: * -> *). Quote m => FilePath -> m Name
newName FilePath
s
    (newPattern, scope) <- bindingPattern b
    return (AsP name newPattern, (i, VarE name):scope)
bindingPattern (BindVar i :: Ident
i@(Ident FilePath
s))
    | FilePath
s FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"_" = (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
WildP, [])
    | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit FilePath
s = do
        (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP (Lit -> Pat) -> Lit -> Pat
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ FilePath -> Integer
forall a. Read a => FilePath -> a
read FilePath
s, [])
    | Bool
otherwise = do
        name <- FilePath -> Q Name
forall (m :: * -> *). Quote m => FilePath -> m Name
newName FilePath
s
        return (VarP name, [(i, VarE name)])
bindingPattern (BindTuple [Binding]
is) = do
    (patterns, scopes) <- ([(Pat, Scope)] -> ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, Scope)] -> ([Pat], [Scope])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, Scope)] -> Q ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, Scope)) -> [Binding] -> Q [(Pat, Scope)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    return (TupP patterns, concat scopes)
bindingPattern (BindList [Binding]
is) = do
    (patterns, scopes) <- ([(Pat, Scope)] -> ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, Scope)] -> ([Pat], [Scope])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, Scope)] -> Q ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, Scope)) -> [Binding] -> Q [(Pat, Scope)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    return (ListP patterns, concat scopes)
bindingPattern (BindConstr DataConstr
con [Binding]
is) = do
    (patterns, scopes) <- ([(Pat, Scope)] -> ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, Scope)] -> ([Pat], [Scope])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, Scope)] -> Q ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, Scope)) -> [Binding] -> Q [(Pat, Scope)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    return (conP (mkConName con) patterns, concat scopes)
bindingPattern (BindRecord DataConstr
con [(Ident, Binding)]
fields Bool
wild) = do
    let f :: (Ident, Binding) -> Q ((Name, Pat), Scope)
f (Ident FilePath
field,Binding
b) =
           do (p,s) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
b
              return ((mkName field,p),s)
    (patterns, scopes) <- ([((Name, Pat), Scope)] -> ([(Name, Pat)], [Scope]))
-> Q [((Name, Pat), Scope)] -> Q ([(Name, Pat)], [Scope])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((Name, Pat), Scope)] -> ([(Name, Pat)], [Scope])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [((Name, Pat), Scope)] -> Q ([(Name, Pat)], [Scope]))
-> Q [((Name, Pat), Scope)] -> Q ([(Name, Pat)], [Scope])
forall a b. (a -> b) -> a -> b
$ ((Ident, Binding) -> Q ((Name, Pat), Scope))
-> [(Ident, Binding)] -> Q [((Name, Pat), Scope)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Ident, Binding) -> Q ((Name, Pat), Scope)
f [(Ident, Binding)]
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 :: DataConstr -> Name
mkConName = FilePath -> Name
mkName (FilePath -> Name)
-> (DataConstr -> FilePath) -> DataConstr -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataConstr -> FilePath
conToStr

conToStr :: DataConstr -> String
conToStr :: DataConstr -> FilePath
conToStr (DCUnqualified (Ident FilePath
x)) = FilePath
x
conToStr (DCQualified (Module [FilePath]
xs) (Ident FilePath
x)) = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"." ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath]
xs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
x]

conP :: Name -> [Pat] -> Pat
#if MIN_VERSION_template_haskell(2,18,0)
conP :: Name -> [Pat] -> Pat
conP Name
name = Name -> [Type] -> [Pat] -> Pat
ConP Name
name []
#else
conP = ConP
#endif

-- 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 :: DataConstr -> [Ident] -> Q ([(Name, Pat)], Scope)
bindWildFields DataConstr
conName [Ident]
fields = do
  fieldNames <- DataConstr -> Q [Name]
recordToFieldNames DataConstr
conName
  let available Name
n     = Name -> FilePath
nameBase Name
n FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Ident -> FilePath) -> [Ident] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> FilePath
unIdent [Ident]
fields
  let remainingFields = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
available [Name]
fieldNames
  let mkPat Name
n = do
        e <- FilePath -> m Name
forall (m :: * -> *). Quote m => FilePath -> m Name
newName (Name -> FilePath
nameBase Name
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 :: DataConstr -> Q [Name]
recordToFieldNames DataConstr
conStr = do
  -- use 'lookupValueName' instead of just using 'mkName' so we reify the
  -- data constructor and not the type constructor if their names match.
  Just conName                <- FilePath -> Q (Maybe Name)
lookupValueName (FilePath -> Q (Maybe Name)) -> FilePath -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ DataConstr -> FilePath
conToStr DataConstr
conStr
  DataConI _ _ typeName         <- reify conName
  TyConI (DataD _ _ _ _ cons _) <- reify typeName
  [fields] <- return [fields | RecC name fields <- cons, name == conName]
  return [fieldName | (fieldName, _, _) <- fields]

docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
docToExp Env
env HamletRules
hr Scope
scope (DocForall Deref
list Binding
idents [Doc]
inside) = do
    let list' :: Exp
list' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
list
    (pat, extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
    mh <- [|F.mapM_|]
    inside' <- docsToExp env hr scope' inside
    let lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    return $ mh `AppE` lam `AppE` list'
docToExp Env
env HamletRules
hr Scope
scope (DocWith [] [Doc]
inside) = do
    inside' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
inside
    return $ inside'
docToExp Env
env HamletRules
hr Scope
scope (DocWith ((Deref
deref, Binding
idents):[(Deref, Binding)]
dis) [Doc]
inside) = do
    let deref' :: Exp
deref' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
deref
    (pat, extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
    inside' <- docToExp env hr scope' (DocWith dis inside)
    let lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    return $ lam `AppE` deref'
docToExp Env
env HamletRules
hr Scope
scope (DocMaybe Deref
val Binding
idents [Doc]
inside Maybe [Doc]
mno) = do
    let val' :: Exp
val' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
val
    (pat, extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
    inside' <- docsToExp env hr scope' inside
    let inside'' = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    ninside' <- case mno of
                    Maybe [Doc]
Nothing -> [|Nothing|]
                    Just [Doc]
no -> do
                        no' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
no
                        j <- [|Just|]
                        return $ j `AppE` no'
    mh <- [|maybeH|]
    return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'
docToExp Env
env HamletRules
hr Scope
scope (DocCond [(Deref, [Doc])]
conds Maybe [Doc]
final) = do
    conds' <- ((Deref, [Doc]) -> Q Exp) -> [(Deref, [Doc])] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Deref, [Doc]) -> Q Exp
go [(Deref, [Doc])]
conds
    final' <- case final of
                Maybe [Doc]
Nothing -> [|Nothing|]
                Just [Doc]
f -> do
                    f' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
f
                    j <- [|Just|]
                    return $ j `AppE` f'
    ch <- [|condH|]
    return $ ch `AppE` ListE conds' `AppE` final'
  where
    go :: (Deref, [Doc]) -> Q Exp
    go :: (Deref, [Doc]) -> Q Exp
go (Deref
d, [Doc]
docs) = do
        let d' :: Exp
d' = Scope -> Deref -> Exp
derefToExp ((Ident
specialOrIdent, Name -> Exp
VarE 'or)(Ident, Exp) -> Scope -> Scope
forall a. a -> [a] -> [a]
:Scope
scope) Deref
d
        docs' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
docs
        return $ TupE
#if MIN_VERSION_template_haskell(2,16,0)
          $ map Just
#endif
          [d', docs']
docToExp Env
env HamletRules
hr Scope
scope (DocCase Deref
deref [(Binding, [Doc])]
cases) = do
    let exp_ :: Exp
exp_ = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
deref
    matches <- ((Binding, [Doc]) -> Q Match) -> [(Binding, [Doc])] -> Q [Match]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Binding, [Doc]) -> Q Match
toMatch [(Binding, [Doc])]
cases
    return $ CaseE exp_ matches
  where
    toMatch :: (Binding, [Doc]) -> Q Match
    toMatch :: (Binding, [Doc]) -> Q Match
toMatch (Binding
idents, [Doc]
inside) = do
        (pat, extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
        let scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
        insideExp <- docsToExp env hr scope' inside
        return $ Match pat (NormalB insideExp) []
docToExp Env
env HamletRules
hr Scope
v (DocContent Content
c) = Env -> HamletRules -> Scope -> Content -> Q Exp
contentToExp Env
env HamletRules
hr Scope
v Content
c

contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp
contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp
contentToExp Env
_ HamletRules
hr Scope
_ (ContentRaw FilePath
s) = do
    os <- [|preEscapedText . pack|]
    let s' = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ FilePath -> Lit
StringL FilePath
s
    return $ hrFromHtml hr `AppE` (os `AppE` s')
contentToExp Env
_ HamletRules
hr Scope
scope (ContentVar Deref
d) = do
    str <- [|toHtml|]
    return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)
contentToExp Env
env HamletRules
hr Scope
scope (ContentUrl Bool
hasParams Deref
d) =
    case Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
urlRender Env
env of
        Maybe ((Exp -> Q Exp) -> Q Exp)
Nothing -> FilePath -> Q Exp
forall a. HasCallStack => FilePath -> a
error FilePath
"URL interpolation used, but no URL renderer provided"
        Just (Exp -> Q Exp) -> Q Exp
wrender -> (Exp -> Q Exp) -> Q Exp
wrender ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
render -> do
            let render' :: Q Exp
render' = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
render
            ou <- if Bool
hasParams
                    then [|\(u, p) -> $(Q Exp
render') u p|]
                    else [|\u -> $(Q Exp
render') u []|]
            let d' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
d
            pet <- [|toHtml|]
            return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))
contentToExp Env
env HamletRules
hr Scope
scope (ContentEmbed Deref
d) = HamletRules -> Env -> Exp -> Q Exp
hrEmbed HamletRules
hr Env
env (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Scope -> Deref -> Exp
derefToExp Scope
scope Deref
d
contentToExp Env
env HamletRules
hr Scope
scope (ContentMsg Deref
d) =
    case Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
msgRender Env
env of
        Maybe ((Exp -> Q Exp) -> Q Exp)
Nothing -> FilePath -> Q Exp
forall a. HasCallStack => FilePath -> a
error FilePath
"Message interpolation used, but no message renderer provided"
        Just (Exp -> Q Exp) -> Q Exp
wrender -> (Exp -> Q Exp) -> Q Exp
wrender ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
render ->
            Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ HamletRules -> Exp
hrFromHtml HamletRules
hr Exp -> Exp -> Exp
`AppE` (Exp
render Exp -> Exp -> Exp
`AppE` Scope -> Deref -> Exp
derefToExp Scope
scope Deref
d)
contentToExp Env
_ HamletRules
hr Scope
scope (ContentAttrs Deref
d) = do
    html <- [|attrsToHtml . toAttributes|]
    return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d)

-- | "Simple Hamlet" quasi-quoter. May only be used to generate expressions.
--
-- Generated expressions have type 'Html'.
--
-- @
-- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.renderHtml' ['shamlet'|\<div\>Hello, world!|])
-- \<div\>Hello, world!\</div\>
-- @
shamlet :: QuasiQuoter
shamlet :: QuasiQuoter
shamlet = Q HamletRules -> HamletSettings -> QuasiQuoter
hamletWithSettings Q HamletRules
htmlRules HamletSettings
defaultHamletSettings

-- | Like 'shamlet', but produces XHTML.
xshamlet :: QuasiQuoter
xshamlet :: QuasiQuoter
xshamlet = Q HamletRules -> HamletSettings -> QuasiQuoter
hamletWithSettings Q HamletRules
htmlRules HamletSettings
xhtmlHamletSettings

htmlRules :: Q HamletRules
htmlRules :: Q HamletRules
htmlRules = do
    i <- [|id|]
    return $ HamletRules i ($ (Env Nothing Nothing)) (\Env
_ Exp
b -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
b)

-- | Hamlet quasi-quoter. May only be used to generate expressions.
--
-- Generated expression have type @'HtmlUrl' url@, for some @url@.
--
-- @
-- data MyRoute = Home
--
-- render :: 'Render' MyRoute
-- render Home _ = \"/home\"
--
-- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.String.renderHtml' (['hamlet'|\<a href=@{Home}\>Home|] render))
-- \<a href="\/home"\>Home\<\/a\>
-- @
hamlet :: QuasiQuoter
hamlet :: QuasiQuoter
hamlet = Q HamletRules -> HamletSettings -> QuasiQuoter
hamletWithSettings Q HamletRules
hamletRules HamletSettings
defaultHamletSettings

-- | Like 'hamlet', but produces XHTML.
xhamlet :: QuasiQuoter
xhamlet :: QuasiQuoter
xhamlet = Q HamletRules -> HamletSettings -> QuasiQuoter
hamletWithSettings Q HamletRules
hamletRules HamletSettings
xhtmlHamletSettings

asHtmlUrl :: HtmlUrl url -> HtmlUrl url
asHtmlUrl :: forall url. HtmlUrl url -> HtmlUrl url
asHtmlUrl = HtmlUrl url -> HtmlUrl url
forall a. a -> a
id

hamletRules :: Q HamletRules
hamletRules :: Q HamletRules
hamletRules = do
    i <- [|id|]
    let ur Env -> m Exp
f = do
            r <- FilePath -> m Name
forall (m :: * -> *). Quote m => FilePath -> m Name
newName FilePath
"_render"
            let env = Env
                    { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
urlRender = ((Exp -> Q Exp) -> Q Exp) -> Maybe ((Exp -> Q Exp) -> Q Exp)
forall a. a -> Maybe a
Just ((Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp
VarE Name
r))
                    , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
msgRender = Maybe ((Exp -> Q Exp) -> Q Exp)
forall a. Maybe a
Nothing
                    }
            h <- f env
            return $ LamE [VarP r] h
    return $ HamletRules i ur em
  where
    em :: Env -> Exp -> Q Exp
em (Env (Just (Exp -> Q Exp) -> Q Exp
urender) Maybe ((Exp -> Q Exp) -> Q Exp)
Nothing) Exp
e = do
        asHtmlUrl' <- [|asHtmlUrl|]
        urender $ \Exp
ur' -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Exp
asHtmlUrl' Exp -> Exp -> Exp
`AppE` Exp
e) Exp -> Exp -> Exp
`AppE` Exp
ur')
    em Env
_ Exp
_ = FilePath -> Q Exp
forall a. HasCallStack => FilePath -> a
error FilePath
"bad Env"

-- | Hamlet quasi-quoter with internationalization. May only be used to generate
-- expressions.
--
-- Generated expressions have type @'HtmlUrlI18n' msg url@, for some @msg@ and
-- @url@.
--
-- @
-- data MyMsg = Hi | Bye
--
-- data MyRoute = Home
--
-- renderEnglish :: 'Translate' MyMsg
-- renderEnglish Hi  = \"hi\"
-- renderEnglish Bye = \"bye\"
--
-- renderUrl :: 'Render' MyRoute
-- renderUrl Home _ = \"/home\"
--
-- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.renderHtml' (['ihamlet'|@{Home} _{Hi} _{Bye}|] renderEnglish renderUrl))
-- \<div\>/home hi bye \<div\>
-- @
ihamlet :: QuasiQuoter
ihamlet :: QuasiQuoter
ihamlet = Q HamletRules -> HamletSettings -> QuasiQuoter
hamletWithSettings Q HamletRules
ihamletRules HamletSettings
defaultHamletSettings

ihamletRules :: Q HamletRules
ihamletRules :: Q HamletRules
ihamletRules = do
    i <- [|id|]
    let ur Env -> m Exp
f = do
            u <- FilePath -> m Name
forall (m :: * -> *). Quote m => FilePath -> m Name
newName FilePath
"_urender"
            m <- newName "_mrender"
            let env = Env
                    { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
urlRender = ((Exp -> Q Exp) -> Q Exp) -> Maybe ((Exp -> Q Exp) -> Q Exp)
forall a. a -> Maybe a
Just ((Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp
VarE Name
u))
                    , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
msgRender = ((Exp -> Q Exp) -> Q Exp) -> Maybe ((Exp -> Q Exp) -> Q Exp)
forall a. a -> Maybe a
Just ((Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp
VarE Name
m))
                    }
            h <- f env
            return $ LamE [VarP m, VarP u] h
    return $ HamletRules i ur em
  where
    em :: Env -> Exp -> Q Exp
em (Env (Just (Exp -> Q Exp) -> Q Exp
urender) (Just (Exp -> Q Exp) -> Q Exp
mrender)) Exp
e =
          (Exp -> Q Exp) -> Q Exp
urender ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
ur' -> (Exp -> Q Exp) -> Q Exp
mrender ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \Exp
mr -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
e Exp -> Exp -> Exp
`AppE` Exp
mr Exp -> Exp -> Exp
`AppE` Exp
ur')
    em Env
_ Exp
_ = FilePath -> Q Exp
forall a. HasCallStack => FilePath -> a
error FilePath
"bad Env"

-- | Quasiquoter that follows XHTML serialization rules and supports i18n.
--
-- @since 2.0.10
ixhamlet :: QuasiQuoter
ixhamlet :: QuasiQuoter
ixhamlet = Q HamletRules -> HamletSettings -> QuasiQuoter
hamletWithSettings Q HamletRules
ihamletRules HamletSettings
xhtmlHamletSettings

hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter
hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter
hamletWithSettings Q HamletRules
hr HamletSettings
set =
    QuasiQuoter
        { quoteExp :: FilePath -> Q Exp
quoteExp = Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFromString Q HamletRules
hr HamletSettings
set
        }

data HamletRules = HamletRules
    { HamletRules -> Exp
hrFromHtml :: Exp
    , HamletRules -> (Env -> Q Exp) -> Q Exp
hrWithEnv :: (Env -> Q Exp) -> Q Exp
    , HamletRules -> Env -> Exp -> Q Exp
hrEmbed :: Env -> Exp -> Q Exp
    }

data Env = Env
    { Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
    , Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
    }

hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp
hamletFromString :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFromString Q HamletRules
qhr HamletSettings
set FilePath
s = do
    hr <- Q HamletRules
qhr
    hrWithEnv hr $ \Env
env -> Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr [] ([Doc] -> Q Exp) -> [Doc] -> Q Exp
forall a b. (a -> b) -> a -> b
$ HamletSettings -> FilePath -> [Doc]
docFromString HamletSettings
set FilePath
s

docFromString :: HamletSettings -> String -> [Doc]
docFromString :: HamletSettings -> FilePath -> [Doc]
docFromString HamletSettings
set FilePath
s =
    case HamletSettings -> FilePath -> Result (Maybe NewlineStyle, [Doc])
parseDoc HamletSettings
set FilePath
s of
        Error FilePath
s' -> FilePath -> [Doc]
forall a. HasCallStack => FilePath -> a
error FilePath
s'
        Ok (Maybe NewlineStyle
_, [Doc]
d) -> [Doc]
d

hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFileWithSettings Q HamletRules
qhr HamletSettings
set FilePath
fp = do
    contents <- FilePath -> Q FilePath
readFileRecompileQ FilePath
fp
    hamletFromString qhr set contents

-- | Like 'hamlet', but reads an external file at compile time.
--
-- @
-- $('hamletFile' \"foo.hamlet\") :: 'HtmlUrl' MyRoute
-- @
hamletFile :: FilePath -> Q Exp
hamletFile :: FilePath -> Q Exp
hamletFile = Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFileWithSettings Q HamletRules
hamletRules HamletSettings
defaultHamletSettings

-- | Like 'hamletFile', but the external file is parsed at runtime. Allows for
-- more rapid development, but should not be used in production.
hamletFileReload :: FilePath -> Q Exp
hamletFileReload :: FilePath -> Q Exp
hamletFileReload = HamletRuntimeRules -> HamletSettings -> FilePath -> Q Exp
hamletFileReloadWithSettings HamletRuntimeRules
runtimeRules HamletSettings
defaultHamletSettings
  where runtimeRules :: HamletRuntimeRules
runtimeRules = HamletRuntimeRules { hrrI18n :: Bool
hrrI18n = Bool
False }

-- | Like 'ihamletFile', but the external file is parsed at runtime. Allows for
-- more rapid development, but should not be used in production.
ihamletFileReload :: FilePath -> Q Exp
ihamletFileReload :: FilePath -> Q Exp
ihamletFileReload = HamletRuntimeRules -> HamletSettings -> FilePath -> Q Exp
hamletFileReloadWithSettings HamletRuntimeRules
runtimeRules HamletSettings
defaultHamletSettings
  where runtimeRules :: HamletRuntimeRules
runtimeRules = HamletRuntimeRules { hrrI18n :: Bool
hrrI18n = Bool
True }

-- | Like 'hamletFile', but produces XHTML.
xhamletFile :: FilePath -> Q Exp
xhamletFile :: FilePath -> Q Exp
xhamletFile = Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFileWithSettings Q HamletRules
hamletRules HamletSettings
xhtmlHamletSettings

-- | Like 'shamlet', but reads an external file at compile time.
--
-- @
-- $('shamletFile' \"foo.hamlet\") :: 'Html'
-- @
shamletFile :: FilePath -> Q Exp
shamletFile :: FilePath -> Q Exp
shamletFile = Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFileWithSettings Q HamletRules
htmlRules HamletSettings
defaultHamletSettings

-- | Like 'shamletFile', but produces XHTML.
xshamletFile :: FilePath -> Q Exp
xshamletFile :: FilePath -> Q Exp
xshamletFile = Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFileWithSettings Q HamletRules
htmlRules HamletSettings
xhtmlHamletSettings

-- | Like 'ihamlet', but reads an external file at compile time.
--
-- @
-- $('ihamletFile' \"foo.hamlet\") :: 'HtmlUrlI18n' MyMsg MyRoute
-- @
ihamletFile :: FilePath -> Q Exp
ihamletFile :: FilePath -> Q Exp
ihamletFile = Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFileWithSettings Q HamletRules
ihamletRules HamletSettings
defaultHamletSettings

varName :: Scope -> String -> Exp
varName :: Scope -> FilePath -> Exp
varName Scope
_ FilePath
"" = FilePath -> Exp
forall a. HasCallStack => FilePath -> a
error FilePath
"Illegal empty varName"
varName Scope
scope v :: FilePath
v@(Char
_:FilePath
_) = Exp -> Maybe Exp -> Exp
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Exp
strToExp FilePath
v) (Maybe Exp -> Exp) -> Maybe Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Ident -> Scope -> Maybe Exp
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (FilePath -> Ident
Ident FilePath
v) Scope
scope

strToExp :: String -> Exp
strToExp :: FilePath -> Exp
strToExp s :: FilePath
s@(Char
c:FilePath
_)
    | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit FilePath
s = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ FilePath -> Integer
forall a. Read a => FilePath -> a
read FilePath
s
    | Char -> Bool
isUpper Char
c = Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
mkName FilePath
s
    | Bool
otherwise = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
mkName FilePath
s
strToExp FilePath
"" = FilePath -> Exp
forall a. HasCallStack => FilePath -> a
error FilePath
"strToExp on empty string"

-- | Checks for truth in the left value in each pair in the first argument. If
-- a true exists, then the corresponding right action is performed. Only the
-- first is performed. In there are no true values, then the second argument is
-- performed, if supplied.
condH :: Monad m => [(Bool, m ())] -> Maybe (m ()) -> m ()
condH :: forall (m :: * -> *).
Monad m =>
[(Bool, m ())] -> Maybe (m ()) -> m ()
condH [(Bool, m ())]
bms Maybe (m ())
mm = m () -> Maybe (m ()) -> m ()
forall a. a -> Maybe a -> a
fromMaybe (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Maybe (m ()) -> m ()) -> Maybe (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> [(Bool, m ())] -> Maybe (m ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Bool
True [(Bool, m ())]
bms Maybe (m ()) -> Maybe (m ()) -> Maybe (m ())
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe (m ())
mm

-- | Runs the second argument with the value in the first, if available.
-- Otherwise, runs the third argument, if available.
maybeH :: Monad m => Maybe v -> (v -> m ()) -> Maybe (m ()) -> m ()
maybeH :: forall (m :: * -> *) v.
Monad m =>
Maybe v -> (v -> m ()) -> Maybe (m ()) -> m ()
maybeH Maybe v
mv v -> m ()
f Maybe (m ())
mm = m () -> Maybe (m ()) -> m ()
forall a. a -> Maybe a -> a
fromMaybe (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Maybe (m ()) -> m ()) -> Maybe (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ (v -> m ()) -> Maybe v -> Maybe (m ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> m ()
f Maybe v
mv Maybe (m ()) -> Maybe (m ()) -> Maybe (m ())
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe (m ())
mm


type MTime = UTCTime
data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin | VTMsg | VTAttrs

type QueryParameters = [(Text, Text)]
type RenderUrl url   = (url -> QueryParameters -> Text)
type Shakespeare url = RenderUrl url -> Html
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 :: VarExp msg url -> FilePath
show (EPlain Html
html) = FilePath
"EPlain"
  show (EUrl url
url) = FilePath
"EUrl"
  show (EUrlParam (url, [(Text, Text)])
url) = FilePath
"EUrlParam"
  show (EMixin HtmlUrl url
url) = FilePath
"EMixin"
  show (EMixinI18n HtmlUrlI18n msg url
msg_url) = FilePath
"EMixinI18n"
  show (EMsg msg
msg) = FilePath
"EMsg"

getVars :: Content -> [(Deref, VarType)]
getVars :: Content -> [(Deref, VarType)]
getVars ContentRaw{}     = []
getVars (ContentVar Deref
d)   = [(Deref
d, VarType
VTPlain)]
getVars (ContentUrl Bool
False Deref
d) = [(Deref
d, VarType
VTUrl)]
getVars (ContentUrl Bool
True Deref
d) = [(Deref
d, VarType
VTUrlParam)]
getVars (ContentEmbed Deref
d) = [(Deref
d, VarType
VTMixin)]
getVars (ContentMsg Deref
d)   = [(Deref
d, VarType
VTMsg)]
getVars (ContentAttrs Deref
d) = [(Deref
d, VarType
VTAttrs)]

hamletUsedIdentifiers :: HamletSettings -> String -> [(Deref, VarType)]
hamletUsedIdentifiers :: HamletSettings -> FilePath -> [(Deref, VarType)]
hamletUsedIdentifiers HamletSettings
settings =
    (Content -> [(Deref, VarType)]) -> [Content] -> [(Deref, VarType)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Content -> [(Deref, VarType)]
getVars ([Content] -> [(Deref, VarType)])
-> (FilePath -> [Content]) -> FilePath -> [(Deref, VarType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HamletSettings -> FilePath -> [Content]
contentFromString HamletSettings
settings


data HamletRuntimeRules = HamletRuntimeRules {
                            HamletRuntimeRules -> Bool
hrrI18n :: Bool
                          }

hamletFileReloadWithSettings :: HamletRuntimeRules
                             -> HamletSettings -> FilePath -> Q Exp
hamletFileReloadWithSettings :: HamletRuntimeRules -> HamletSettings -> FilePath -> Q Exp
hamletFileReloadWithSettings HamletRuntimeRules
hrr HamletSettings
settings FilePath
fp = do
    s <- FilePath -> Q FilePath
readFileQ FilePath
fp
    let b = HamletSettings -> FilePath -> [(Deref, VarType)]
hamletUsedIdentifiers HamletSettings
settings FilePath
s
    c <- mapM vtToExp b
    rt <- if hrrI18n hrr
      then [|hamletRuntimeMsg settings fp|]
      else [|hamletRuntime settings fp|]
    return $ rt `AppE` ListE c
  where
    vtToExp :: (Deref, VarType) -> Q Exp
    vtToExp :: (Deref, VarType) -> Q Exp
vtToExp (Deref
d, VarType
vt) = do
        d' <- Deref -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Deref -> m Exp
lift Deref
d
        c' <- toExp vt
        return $ TupE
#if MIN_VERSION_template_haskell(2,16,0)
          $ map Just
#endif
          [d', c' `AppE` derefToExp [] d]
      where
        toExp :: VarType -> Q Exp
toExp = VarType -> Q Exp
c
          where
            c :: VarType -> Q Exp
            c :: VarType -> Q Exp
c VarType
VTAttrs = [|EPlain . attrsToHtml . toAttributes|]
            c VarType
VTPlain = [|EPlain . toHtml|]
            c VarType
VTUrl = [|EUrl|]
            c VarType
VTUrlParam = [|EUrlParam|]
            c VarType
VTMixin = [|\r -> EMixin $ \c -> r c|]
            c VarType
VTMsg = [|EMsg|]

{-# NOINLINE reloadMapRef #-}
reloadMapRef :: IORef (M.Map FilePath (MTime, [Content]))
reloadMapRef :: IORef (Map FilePath (MTime, [Content]))
reloadMapRef = IO (IORef (Map FilePath (MTime, [Content])))
-> IORef (Map FilePath (MTime, [Content]))
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map FilePath (MTime, [Content])))
 -> IORef (Map FilePath (MTime, [Content])))
-> IO (IORef (Map FilePath (MTime, [Content])))
-> IORef (Map FilePath (MTime, [Content]))
forall a b. (a -> b) -> a -> b
$ Map FilePath (MTime, [Content])
-> IO (IORef (Map FilePath (MTime, [Content])))
forall a. a -> IO (IORef a)
newIORef Map FilePath (MTime, [Content])
forall k a. Map k a
M.empty

lookupReloadMap :: FilePath -> IO (Maybe (MTime, [Content]))
lookupReloadMap :: FilePath -> IO (Maybe (MTime, [Content]))
lookupReloadMap FilePath
fp = do
  reloads <- IORef (Map FilePath (MTime, [Content]))
-> IO (Map FilePath (MTime, [Content]))
forall a. IORef a -> IO a
readIORef IORef (Map FilePath (MTime, [Content]))
reloadMapRef
  return $ M.lookup fp reloads

insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content]
insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content]
insertReloadMap FilePath
fp (MTime
mt, [Content]
content) = IORef (Map FilePath (MTime, [Content]))
-> (Map FilePath (MTime, [Content])
    -> (Map FilePath (MTime, [Content]), [Content]))
-> IO [Content]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Map FilePath (MTime, [Content]))
reloadMapRef
  (\Map FilePath (MTime, [Content])
reloadMap -> (FilePath
-> (MTime, [Content])
-> Map FilePath (MTime, [Content])
-> Map FilePath (MTime, [Content])
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
fp (MTime
mt, [Content]
content) Map FilePath (MTime, [Content])
reloadMap, [Content]
content))

contentFromString :: HamletSettings -> String -> [Content]
contentFromString :: HamletSettings -> FilePath -> [Content]
contentFromString HamletSettings
set = (Doc -> Content) -> [Doc] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Doc -> Content
justContent ([Doc] -> [Content])
-> (FilePath -> [Doc]) -> FilePath -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HamletSettings -> FilePath -> [Doc]
docFromString HamletSettings
set
  where
    unsupported :: FilePath -> a
unsupported FilePath
msg = FilePath -> a
forall a. HasCallStack => FilePath -> a
error (FilePath -> a) -> FilePath -> a
forall a b. (a -> b) -> a -> b
$ FilePath
"hamletFileReload does not support " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
msg

    justContent :: Doc -> Content
    justContent :: Doc -> Content
justContent (DocContent Content
c) = Content
c
    justContent DocForall{} = FilePath -> Content
forall {a}. FilePath -> a
unsupported FilePath
"$forall"
    justContent DocWith{} = FilePath -> Content
forall {a}. FilePath -> a
unsupported FilePath
"$with"
    justContent DocMaybe{} = FilePath -> Content
forall {a}. FilePath -> a
unsupported FilePath
"$maybe"
    justContent DocCase{} = FilePath -> Content
forall {a}. FilePath -> a
unsupported FilePath
"$case"
    justContent DocCond{} = FilePath -> Content
forall {a}. FilePath -> a
unsupported FilePath
"attribute conditionals"


hamletRuntime :: HamletSettings
              -> FilePath
              -> [(Deref, VarExp msg url)]
              -> Shakespeare url
hamletRuntime :: forall msg url.
HamletSettings
-> FilePath -> [(Deref, VarExp msg url)] -> Shakespeare url
hamletRuntime HamletSettings
settings FilePath
fp [(Deref, VarExp msg url)]
cd RenderUrl url
render = IO Html -> Html
forall a. IO a -> a
unsafePerformIO (IO Html -> Html) -> IO Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    mtime <- IO MTime -> IO MTime
forall a. IO a -> IO a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO MTime -> IO MTime) -> IO MTime -> IO MTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO MTime
getModificationTime FilePath
fp
    mdata <- lookupReloadMap fp
    case mdata of
      Just (MTime
lastMtime, [Content]
lastContents) ->
        if MTime
mtime MTime -> MTime -> Bool
forall a. Eq a => a -> a -> Bool
== MTime
lastMtime then Html -> IO Html
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Html -> IO Html) -> Html -> IO Html
forall a b. (a -> b) -> a -> b
$ [Content] -> Html
go' [Content]
lastContents
          else ([Content] -> Html) -> IO [Content] -> IO Html
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Content] -> Html
go' (IO [Content] -> IO Html) -> IO [Content] -> IO Html
forall a b. (a -> b) -> a -> b
$ MTime -> IO [Content]
newContent MTime
mtime
      Maybe (MTime, [Content])
Nothing -> ([Content] -> Html) -> IO [Content] -> IO Html
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Content] -> Html
go' (IO [Content] -> IO Html) -> IO [Content] -> IO Html
forall a b. (a -> b) -> a -> b
$ MTime -> IO [Content]
newContent MTime
mtime
  where
    newContent :: MTime -> IO [Content]
newContent MTime
mtime = do
        s <- FilePath -> IO FilePath
readUtf8FileString FilePath
fp
        insertReloadMap fp (mtime, contentFromString settings s)

    go' :: [Content] -> Html
go' = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> ([Content] -> [Html]) -> [Content] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Content -> Html) -> [Content] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map ([(Deref, VarExp msg url)]
-> RenderUrl url
-> Translate msg
-> (Deref -> Html)
-> Content
-> Html
forall msg url.
RuntimeVars msg url
-> Render url
-> Translate msg
-> (Deref -> Html)
-> Content
-> Html
runtimeContentToHtml [(Deref, VarExp msg url)]
cd RenderUrl url
render (FilePath -> Translate msg
forall a. HasCallStack => FilePath -> a
error FilePath
"I18n embed IMPOSSIBLE") Deref -> Html
forall {p} {a}. p -> a
handleMsgEx)
    handleMsgEx :: p -> a
handleMsgEx p
_ = FilePath -> a
forall a. HasCallStack => FilePath -> a
error FilePath
"i18n _{} encountered, but did not use ihamlet"

type RuntimeVars msg url = [(Deref, VarExp msg url)]
hamletRuntimeMsg :: HamletSettings
              -> FilePath
              -> RuntimeVars msg url
              -> HtmlUrlI18n msg url
hamletRuntimeMsg :: forall msg url.
HamletSettings
-> FilePath -> RuntimeVars msg url -> HtmlUrlI18n msg url
hamletRuntimeMsg HamletSettings
settings FilePath
fp RuntimeVars msg url
cd Translate msg
i18nRender Render url
render = IO Html -> Html
forall a. IO a -> a
unsafePerformIO (IO Html -> Html) -> IO Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    mtime <- IO MTime -> IO MTime
forall a. IO a -> IO a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO MTime -> IO MTime) -> IO MTime -> IO MTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO MTime
getModificationTime FilePath
fp
    mdata <- lookupReloadMap fp
    case mdata of
      Just (MTime
lastMtime, [Content]
lastContents) ->
        if MTime
mtime MTime -> MTime -> Bool
forall a. Eq a => a -> a -> Bool
== MTime
lastMtime then Html -> IO Html
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Html -> IO Html) -> Html -> IO Html
forall a b. (a -> b) -> a -> b
$ [Content] -> Html
go' [Content]
lastContents
          else ([Content] -> Html) -> IO [Content] -> IO Html
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Content] -> Html
go' (IO [Content] -> IO Html) -> IO [Content] -> IO Html
forall a b. (a -> b) -> a -> b
$ MTime -> IO [Content]
newContent MTime
mtime
      Maybe (MTime, [Content])
Nothing -> ([Content] -> Html) -> IO [Content] -> IO Html
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Content] -> Html
go' (IO [Content] -> IO Html) -> IO [Content] -> IO Html
forall a b. (a -> b) -> a -> b
$ MTime -> IO [Content]
newContent MTime
mtime
  where
    newContent :: MTime -> IO [Content]
newContent MTime
mtime = do
        s <- FilePath -> IO FilePath
readUtf8FileString FilePath
fp
        insertReloadMap fp (mtime, contentFromString settings s)

    go' :: [Content] -> Html
go' = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> ([Content] -> [Html]) -> [Content] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Content -> Html) -> [Content] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (RuntimeVars msg url
-> Render url
-> Translate msg
-> (Deref -> Html)
-> Content
-> Html
forall msg url.
RuntimeVars msg url
-> Render url
-> Translate msg
-> (Deref -> Html)
-> Content
-> Html
runtimeContentToHtml RuntimeVars msg url
cd Render url
render Translate msg
i18nRender Deref -> Html
handleMsg)
    handleMsg :: Deref -> Html
handleMsg Deref
d = case Deref -> RuntimeVars msg url -> Maybe (VarExp msg url)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d RuntimeVars msg url
cd of
            Just (EMsg msg
s) -> Translate msg
i18nRender msg
s
            Maybe (VarExp msg url)
_ -> FilePath -> Deref -> Html
forall a b. Show a => FilePath -> a -> b
nothingError FilePath
"EMsg for ContentMsg" Deref
d

nothingError :: Show a => String -> a -> b
nothingError :: forall a b. Show a => FilePath -> a -> b
nothingError FilePath
expected a
d = FilePath -> b
forall a. HasCallStack => FilePath -> a
error (FilePath -> b) -> FilePath -> b
forall a b. (a -> b) -> a -> b
$ FilePath
"expected " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
expected FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" but got Nothing for: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
d

runtimeContentToHtml :: RuntimeVars msg url -> Render url -> Translate msg -> (Deref -> Html) -> Content -> Html
runtimeContentToHtml :: forall msg url.
RuntimeVars msg url
-> Render url
-> Translate msg
-> (Deref -> Html)
-> Content
-> Html
runtimeContentToHtml RuntimeVars msg url
cd Render url
render Translate msg
i18nRender Deref -> Html
handleMsg = Content -> Html
go
  where
    go :: Content -> Html
    go :: Content -> Html
go (ContentMsg Deref
d) = Deref -> Html
handleMsg Deref
d
    go (ContentRaw FilePath
s) = FilePath -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml FilePath
s
    go (ContentAttrs Deref
d) =
        case Deref -> RuntimeVars msg url -> Maybe (VarExp msg url)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d RuntimeVars msg url
cd of
            Just (EPlain Html
s) -> Html
s
            Maybe (VarExp msg url)
_ -> FilePath -> Html
forall a. HasCallStack => FilePath -> a
error (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ Deref -> FilePath
forall a. Show a => a -> FilePath
show Deref
d FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": expected EPlain for ContentAttrs"
    go (ContentVar Deref
d) =
        case Deref -> RuntimeVars msg url -> Maybe (VarExp msg url)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d RuntimeVars msg url
cd of
            Just (EPlain Html
s) -> Html
s
            Maybe (VarExp msg url)
_ -> FilePath -> Html
forall a. HasCallStack => FilePath -> a
error (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ Deref -> FilePath
forall a. Show a => a -> FilePath
show Deref
d FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": expected EPlain for ContentVar"
    go (ContentUrl Bool
False Deref
d) =
        case Deref -> RuntimeVars msg url -> Maybe (VarExp msg url)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d RuntimeVars msg url
cd of
            Just (EUrl url
u) -> Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Render url
render url
u []
            Just VarExp msg url
wrong -> FilePath -> Html
forall a. HasCallStack => FilePath -> a
error (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$  FilePath
"expected EUrl but got: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ VarExp msg url -> FilePath
forall a. Show a => a -> FilePath
show VarExp msg url
wrong FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\nfor: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Deref -> FilePath
forall a. Show a => a -> FilePath
show Deref
d
            Maybe (VarExp msg url)
_ -> FilePath -> Deref -> Html
forall a b. Show a => FilePath -> a -> b
nothingError FilePath
"EUrl" Deref
d
    go (ContentUrl Bool
True Deref
d) =
        case Deref -> RuntimeVars msg url -> Maybe (VarExp msg url)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d RuntimeVars msg url
cd of
            Just (EUrlParam (url
u, [(Text, Text)]
p)) ->
                Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Render url
render url
u [(Text, Text)]
p
            Maybe (VarExp msg url)
_ -> FilePath -> Html
forall a. HasCallStack => FilePath -> a
error (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ Deref -> FilePath
forall a. Show a => a -> FilePath
show Deref
d FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": expected EUrlParam"
    go (ContentEmbed Deref
d) = case Deref -> RuntimeVars msg url -> Maybe (VarExp msg url)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d RuntimeVars msg url
cd of
        Just (EMixin HtmlUrl url
m) -> HtmlUrl url
m Render url
render
        Just (EMixinI18n HtmlUrlI18n msg url
m) -> HtmlUrlI18n msg url
m Translate msg
i18nRender Render url
render
        Maybe (VarExp msg url)
_ -> FilePath -> Html
forall a. HasCallStack => FilePath -> a
error (FilePath -> Html) -> FilePath -> Html
forall a b. (a -> b) -> a -> b
$ Deref -> FilePath
forall a. Show a => a -> FilePath
show Deref
d FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": expected EMixin"