{-# 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 = 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 = forall a. a -> a
id
instance ToAttributes [(String, String)] where
    toAttributes :: [(FilePath, FilePath)] -> [(Text, Text)]
toAttributes = forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
pack 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 =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. ToMarkup a => (Text, a) -> Html -> Html
go forall a. Monoid a => a
mempty
  where
    go :: (Text, a) -> Html -> Html
go (Text
k, a
v) Html
rest =
        forall a. ToMarkup a => a -> Html
toHtml FilePath
" "
        forall a. Monoid a => a -> a -> a
`mappend` Text -> Html
preEscapedText Text
k
        forall a. Monoid a => a -> a -> a
`mappend` Text -> Html
preEscapedText (FilePath -> Text
pack FilePath
"=\"")
        forall a. Monoid a => a -> a -> a
`mappend` forall a. ToMarkup a => a -> Html
toHtml a
v
        forall a. Monoid a => a -> a -> a
`mappend` Text -> Html
preEscapedText (FilePath -> Text
pack FilePath
"\"")
        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
    [Exp]
exps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> HamletRules -> Scope -> Doc -> Q Exp
docToExp Env
env HamletRules
hr Scope
scope) [Doc]
docs
    case [Exp]
exps of
        [] -> [|return ()|]
        [Exp
x] -> forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
        [Exp]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe ModName -> [Stmt] -> Exp
DoE
#if MIN_VERSION_template_haskell(2,17,0)
                forall a. Maybe a
Nothing
#endif
                forall a b. (a -> b) -> a -> b
$ 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
name <- forall (m :: * -> *). Quote m => FilePath -> m Name
newName FilePath
s
    (Pat
newPattern, Scope
scope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
b
    forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat -> Pat
AsP Name
name Pat
newPattern, (Ident
i, Name -> Exp
VarE Name
name)forall a. a -> [a] -> [a]
:Scope
scope)
bindingPattern (BindVar i :: Ident
i@(Ident FilePath
s))
    | FilePath
s forall a. Eq a => a -> a -> Bool
== FilePath
"_" = forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
WildP, [])
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit FilePath
s = do
        forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL forall a b. (a -> b) -> a -> b
$ forall a. Read a => FilePath -> a
read FilePath
s, [])
    | Bool
otherwise = do
        Name
name <- forall (m :: * -> *). Quote m => FilePath -> m Name
newName FilePath
s
        forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat
VarP Name
name, [(Ident
i, Name -> Exp
VarE Name
name)])
bindingPattern (BindTuple [Binding]
is) = do
    ([Pat]
patterns, [Scope]
scopes) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
TupP [Pat]
patterns, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes)
bindingPattern (BindList [Binding]
is) = do
    ([Pat]
patterns, [Scope]
scopes) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
ListP [Pat]
patterns, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes)
bindingPattern (BindConstr DataConstr
con [Binding]
is) = do
    ([Pat]
patterns, [Scope]
scopes) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
conP (DataConstr -> Name
mkConName DataConstr
con) [Pat]
patterns, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
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 (Pat
p,Scope
s) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
b
              forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath -> Name
mkName FilePath
field,Pat
p),Scope
s)
    ([(Name, Pat)]
patterns, [Scope]
scopes) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Ident, Binding) -> Q ((Name, Pat), Scope)
f [(Ident, Binding)]
fields
    ([(Name, Pat)]
patterns1, Scope
scopes1) <- if Bool
wild
       then DataConstr -> [Ident] -> Q ([(Name, Pat)], Scope)
bindWildFields DataConstr
con forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Ident, Binding)]
fields
       else forall (m :: * -> *) a. Monad m => a -> m a
return ([],[])
    forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [(Name, Pat)] -> Pat
RecP (DataConstr -> Name
mkConName DataConstr
con) ([(Name, Pat)]
patternsforall a. [a] -> [a] -> [a]
++[(Name, Pat)]
patterns1), forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes forall a. [a] -> [a] -> [a]
++ Scope
scopes1)

mkConName :: DataConstr -> Name
mkConName :: DataConstr -> Name
mkConName = FilePath -> Name
mkName 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)) = forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"." forall a b. (a -> b) -> a -> b
$ [FilePath]
xs 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
  [Name]
fieldNames <- DataConstr -> Q [Name]
recordToFieldNames DataConstr
conName
  let available :: Name -> Bool
available Name
n     = Name -> FilePath
nameBase Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a b. (a -> b) -> [a] -> [b]
map Ident -> FilePath
unIdent [Ident]
fields
  let remainingFields :: [Name]
remainingFields = forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
available [Name]
fieldNames
  let mkPat :: Name -> m ((Name, Pat), (Ident, Exp))
mkPat Name
n = do
        Name
e <- forall (m :: * -> *). Quote m => FilePath -> m Name
newName (Name -> FilePath
nameBase Name
n)
        forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n,Name -> Pat
VarP Name
e), (FilePath -> Ident
Ident (Name -> FilePath
nameBase Name
n), Name -> Exp
VarE Name
e))
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}.
Quote m =>
Name -> m ((Name, Pat), (Ident, Exp))
mkPat [Name]
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 Name
conName                <- FilePath -> Q (Maybe Name)
lookupValueName forall a b. (a -> b) -> a -> b
$ DataConstr -> FilePath
conToStr DataConstr
conStr
  DataConI Name
_ Type
_ Name
typeName         <- Name -> Q Info
reify Name
conName
  TyConI (DataD [Type]
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con]
cons [DerivClause]
_) <- Name -> Q Info
reify Name
typeName
  [[VarBangType]
fields] <- forall (m :: * -> *) a. Monad m => a -> m a
return [[VarBangType]
fields | RecC Name
name [VarBangType]
fields <- [Con]
cons, Name
name forall a. Eq a => a -> a -> Bool
== Name
conName]
  forall (m :: * -> *) a. Monad m => a -> m a
return [Name
fieldName | (Name
fieldName, Bang
_, Type
_) <- [VarBangType]
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
pat, Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' :: Scope
scope' = Scope
extraScope forall a. [a] -> [a] -> [a]
++ Scope
scope
    Exp
mh <- [|F.mapM_|]
    Exp
inside' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope' [Doc]
inside
    let lam :: Exp
lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
mh Exp -> Exp -> Exp
`AppE` Exp
lam Exp -> Exp -> Exp
`AppE` Exp
list'
docToExp Env
env HamletRules
hr Scope
scope (DocWith [] [Doc]
inside) = do
    Exp
inside' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
inside
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
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
pat, Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' :: Scope
scope' = Scope
extraScope forall a. [a] -> [a] -> [a]
++ Scope
scope
    Exp
inside' <- Env -> HamletRules -> Scope -> Doc -> Q Exp
docToExp Env
env HamletRules
hr Scope
scope' ([(Deref, Binding)] -> [Doc] -> Doc
DocWith [(Deref, Binding)]
dis [Doc]
inside)
    let lam :: Exp
lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
lam Exp -> Exp -> Exp
`AppE` Exp
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
pat, Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' :: Scope
scope' = Scope
extraScope forall a. [a] -> [a] -> [a]
++ Scope
scope
    Exp
inside' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope' [Doc]
inside
    let inside'' :: Exp
inside'' = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    Exp
ninside' <- case Maybe [Doc]
mno of
                    Maybe [Doc]
Nothing -> [|Nothing|]
                    Just [Doc]
no -> do
                        Exp
no' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
no
                        Exp
j <- [|Just|]
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
j Exp -> Exp -> Exp
`AppE` Exp
no'
    Exp
mh <- [|maybeH|]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
mh Exp -> Exp -> Exp
`AppE` Exp
val' Exp -> Exp -> Exp
`AppE` Exp
inside'' Exp -> Exp -> Exp
`AppE` Exp
ninside'
docToExp Env
env HamletRules
hr Scope
scope (DocCond [(Deref, [Doc])]
conds Maybe [Doc]
final) = do
    [Exp]
conds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Deref, [Doc]) -> Q Exp
go [(Deref, [Doc])]
conds
    Exp
final' <- case Maybe [Doc]
final of
                Maybe [Doc]
Nothing -> [|Nothing|]
                Just [Doc]
f -> do
                    Exp
f' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
f
                    Exp
j <- [|Just|]
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
j Exp -> Exp -> Exp
`AppE` Exp
f'
    Exp
ch <- [|condH|]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
ch Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE [Exp]
conds' Exp -> Exp -> Exp
`AppE` Exp
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)forall a. a -> [a] -> [a]
:Scope
scope) Deref
d
        Exp
docs' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
docs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
          forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#endif
          [Exp
d', Exp
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
    [Match]
matches <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Binding, [Doc]) -> Q Match
toMatch [(Binding, [Doc])]
cases
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
exp_ [Match]
matches
  where
    toMatch :: (Binding, [Doc]) -> Q Match
    toMatch :: (Binding, [Doc]) -> Q Match
toMatch (Binding
idents, [Doc]
inside) = do
        (Pat
pat, Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
        let scope' :: Scope
scope' = Scope
extraScope forall a. [a] -> [a] -> [a]
++ Scope
scope
        Exp
insideExp <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope' [Doc]
inside
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
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
    Exp
os <- [|preEscapedText . pack|]
    let s' :: Exp
s' = Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ FilePath -> Lit
StringL FilePath
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HamletRules -> Exp
hrFromHtml HamletRules
hr Exp -> Exp -> Exp
`AppE` (Exp
os Exp -> Exp -> Exp
`AppE` Exp
s')
contentToExp Env
_ HamletRules
hr Scope
scope (ContentVar Deref
d) = do
    Exp
str <- [|toHtml|]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HamletRules -> Exp
hrFromHtml HamletRules
hr Exp -> Exp -> Exp
`AppE` (Exp
str Exp -> Exp -> Exp
`AppE` Scope -> Deref -> Exp
derefToExp Scope
scope Deref
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 -> 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 forall a b. (a -> b) -> a -> b
$ \Exp
render -> do
            let render' :: Q Exp
render' = forall (m :: * -> *) a. Monad m => a -> m a
return Exp
render
            Exp
ou <- if Bool
hasParams
                    then [|\(u, p) -> $(render') u p|]
                    else [|\u -> $(render') u []|]
            let d' :: Exp
d' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
d
            Exp
pet <- [|toHtml|]
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HamletRules -> Exp
hrFromHtml HamletRules
hr Exp -> Exp -> Exp
`AppE` (Exp
pet Exp -> Exp -> Exp
`AppE` (Exp
ou Exp -> Exp -> Exp
`AppE` Exp
d'))
contentToExp Env
env HamletRules
hr Scope
scope (ContentEmbed Deref
d) = HamletRules -> Env -> Exp -> Q Exp
hrEmbed HamletRules
hr Env
env 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 -> 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 forall a b. (a -> b) -> a -> b
$ \Exp
render ->
            forall (m :: * -> *) a. Monad m => a -> m a
return 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
    Exp
html <- [|attrsToHtml . toAttributes|]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HamletRules -> Exp
hrFromHtml HamletRules
hr Exp -> Exp -> Exp
`AppE` (Exp
html Exp -> Exp -> Exp
`AppE` Scope -> Deref -> Exp
derefToExp Scope
scope Deref
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
    Exp
i <- [|id|]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
-> ((Env -> Q Exp) -> Q Exp)
-> (Env -> Exp -> Q Exp)
-> HamletRules
HamletRules Exp
i (forall a b. (a -> b) -> a -> b
$ (Maybe ((Exp -> Q Exp) -> Q Exp)
-> Maybe ((Exp -> Q Exp) -> Q Exp) -> Env
Env forall a. Maybe a
Nothing forall a. Maybe a
Nothing)) (\Env
_ Exp
b -> 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 = forall a. a -> a
id

hamletRules :: Q HamletRules
hamletRules :: Q HamletRules
hamletRules = do
    Exp
i <- [|id|]
    let ur :: (Env -> m Exp) -> m Exp
ur Env -> m Exp
f = do
            Name
r <- forall (m :: * -> *). Quote m => FilePath -> m Name
newName FilePath
"_render"
            let env :: Env
env = Env
                    { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
urlRender = forall a. a -> Maybe a
Just (forall a b. (a -> b) -> a -> b
$ (Name -> Exp
VarE Name
r))
                    , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
msgRender = forall a. Maybe a
Nothing
                    }
            Exp
h <- Env -> m Exp
f Env
env
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
r] Exp
h
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
-> ((Env -> Q Exp) -> Q Exp)
-> (Env -> Exp -> Q Exp)
-> HamletRules
HamletRules Exp
i forall {m :: * -> *}. Quote m => (Env -> m Exp) -> m Exp
ur Env -> Exp -> Q Exp
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
        Exp
asHtmlUrl' <- [|asHtmlUrl|]
        (Exp -> Q Exp) -> Q Exp
urender forall a b. (a -> b) -> a -> b
$ \Exp
ur' -> 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
_ = 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
    Exp
i <- [|id|]
    let ur :: (Env -> m Exp) -> m Exp
ur Env -> m Exp
f = do
            Name
u <- forall (m :: * -> *). Quote m => FilePath -> m Name
newName FilePath
"_urender"
            Name
m <- forall (m :: * -> *). Quote m => FilePath -> m Name
newName FilePath
"_mrender"
            let env :: Env
env = Env
                    { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
urlRender = forall a. a -> Maybe a
Just (forall a b. (a -> b) -> a -> b
$ (Name -> Exp
VarE Name
u))
                    , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
msgRender = forall a. a -> Maybe a
Just (forall a b. (a -> b) -> a -> b
$ (Name -> Exp
VarE Name
m))
                    }
            Exp
h <- Env -> m Exp
f Env
env
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
m, Name -> Pat
VarP Name
u] Exp
h
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
-> ((Env -> Q Exp) -> Q Exp)
-> (Env -> Exp -> Q Exp)
-> HamletRules
HamletRules Exp
i forall {m :: * -> *}. Quote m => (Env -> m Exp) -> m Exp
ur Env -> Exp -> Q Exp
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 forall a b. (a -> b) -> a -> b
$ \Exp
ur' -> (Exp -> Q Exp) -> Q Exp
mrender forall a b. (a -> b) -> a -> b
$ \Exp
mr -> 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
_ = 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
    HamletRules
hr <- Q HamletRules
qhr
    HamletRules -> (Env -> Q Exp) -> Q Exp
hrWithEnv HamletRules
hr forall a b. (a -> b) -> a -> b
$ \Env
env -> Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr [] 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' -> 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
    FilePath
contents <- FilePath -> Q FilePath
readFileRecompileQ FilePath
fp
    Q HamletRules -> HamletSettings -> FilePath -> Q Exp
hamletFromString Q HamletRules
qhr HamletSettings
set FilePath
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
"" = forall a. HasCallStack => FilePath -> a
error FilePath
"Illegal empty varName"
varName Scope
scope v :: FilePath
v@(Char
_:FilePath
_) = forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Exp
strToExp FilePath
v) forall a b. (a -> b) -> a -> b
$ 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
_)
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit FilePath
s = Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL forall a b. (a -> b) -> a -> b
$ forall a. Read a => FilePath -> a
read FilePath
s
    | Char -> Bool
isUpper Char
c = Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ FilePath -> Name
mkName FilePath
s
    | Bool
otherwise = Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ FilePath -> Name
mkName FilePath
s
strToExp FilePath
"" = 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 = forall a. a -> Maybe a -> a
fromMaybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Bool
True [(Bool, m ())]
bms 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 = forall a. a -> Maybe a -> a
fromMaybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> m ()
f Maybe v
mv 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 =
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Content -> [(Deref, VarType)]
getVars 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
    FilePath
s <- FilePath -> Q FilePath
readFileQ FilePath
fp
    let b :: [(Deref, VarType)]
b = HamletSettings -> FilePath -> [(Deref, VarType)]
hamletUsedIdentifiers HamletSettings
settings FilePath
s
    [Exp]
c <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Deref, VarType) -> Q Exp
vtToExp [(Deref, VarType)]
b
    Exp
rt <- if HamletRuntimeRules -> Bool
hrrI18n HamletRuntimeRules
hrr
      then [|hamletRuntimeMsg settings fp|]
      else [|hamletRuntime settings fp|]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
rt Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE [Exp]
c
  where
    vtToExp :: (Deref, VarType) -> Q Exp
    vtToExp :: (Deref, VarType) -> Q Exp
vtToExp (Deref
d, VarType
vt) = do
        Exp
d' <- forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift Deref
d
        Exp
c' <- VarType -> Q Exp
toExp VarType
vt
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
          forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#endif
          [Exp
d', Exp
c' Exp -> Exp -> Exp
`AppE` Scope -> Deref -> Exp
derefToExp [] Deref
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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
M.empty

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

insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content]
insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content]
insertReloadMap FilePath
fp (MTime
mt, [Content]
content) = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Map FilePath (MTime, [Content]))
reloadMapRef
  (\Map FilePath (MTime, [Content])
reloadMap -> (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 = forall a b. (a -> b) -> [a] -> [b]
map Doc -> Content
justContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. HamletSettings -> FilePath -> [Doc]
docFromString HamletSettings
set
  where
    unsupported :: FilePath -> a
unsupported FilePath
msg = forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"hamletFileReload does not support " forall a. [a] -> [a] -> [a]
++ FilePath
msg

    justContent :: Doc -> Content
    justContent :: Doc -> Content
justContent (DocContent Content
c) = Content
c
    justContent DocForall{} = forall {a}. FilePath -> a
unsupported FilePath
"$forall"
    justContent DocWith{} = forall {a}. FilePath -> a
unsupported FilePath
"$with"
    justContent DocMaybe{} = forall {a}. FilePath -> a
unsupported FilePath
"$maybe"
    justContent DocCase{} = forall {a}. FilePath -> a
unsupported FilePath
"$case"
    justContent DocCond{} = 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    MTime
mtime <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO MTime
getModificationTime FilePath
fp
    Maybe (MTime, [Content])
mdata <- FilePath -> IO (Maybe (MTime, [Content]))
lookupReloadMap FilePath
fp
    case Maybe (MTime, [Content])
mdata of
      Just (MTime
lastMtime, [Content]
lastContents) ->
        if MTime
mtime forall a. Eq a => a -> a -> Bool
== MTime
lastMtime then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Content] -> Html
go' [Content]
lastContents
          else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Content] -> Html
go' forall a b. (a -> b) -> a -> b
$ MTime -> IO [Content]
newContent MTime
mtime
      Maybe (MTime, [Content])
Nothing -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Content] -> Html
go' forall a b. (a -> b) -> a -> b
$ MTime -> IO [Content]
newContent MTime
mtime
  where
    newContent :: MTime -> IO [Content]
newContent MTime
mtime = do
        FilePath
s <- FilePath -> IO FilePath
readUtf8FileString FilePath
fp
        FilePath -> (MTime, [Content]) -> IO [Content]
insertReloadMap FilePath
fp (MTime
mtime, HamletSettings -> FilePath -> [Content]
contentFromString HamletSettings
settings FilePath
s)

    go' :: [Content] -> Html
go' = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall msg url.
RuntimeVars msg url
-> Render url
-> Translate msg
-> (Deref -> Html)
-> Content
-> Html
runtimeContentToHtml [(Deref, VarExp msg url)]
cd RenderUrl url
render (forall a. HasCallStack => FilePath -> a
error FilePath
"I18n embed IMPOSSIBLE") forall {p} {a}. p -> a
handleMsgEx)
    handleMsgEx :: p -> a
handleMsgEx p
_ = 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    MTime
mtime <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO MTime
getModificationTime FilePath
fp
    Maybe (MTime, [Content])
mdata <- FilePath -> IO (Maybe (MTime, [Content]))
lookupReloadMap FilePath
fp
    case Maybe (MTime, [Content])
mdata of
      Just (MTime
lastMtime, [Content]
lastContents) ->
        if MTime
mtime forall a. Eq a => a -> a -> Bool
== MTime
lastMtime then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Content] -> Html
go' [Content]
lastContents
          else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Content] -> Html
go' forall a b. (a -> b) -> a -> b
$ MTime -> IO [Content]
newContent MTime
mtime
      Maybe (MTime, [Content])
Nothing -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Content] -> Html
go' forall a b. (a -> b) -> a -> b
$ MTime -> IO [Content]
newContent MTime
mtime
  where
    newContent :: MTime -> IO [Content]
newContent MTime
mtime = do
        FilePath
s <- FilePath -> IO FilePath
readUtf8FileString FilePath
fp
        FilePath -> (MTime, [Content]) -> IO [Content]
insertReloadMap FilePath
fp (MTime
mtime, HamletSettings -> FilePath -> [Content]
contentFromString HamletSettings
settings FilePath
s)

    go' :: [Content] -> Html
go' = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (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 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)
_ -> 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 = forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"expected " forall a. [a] -> [a] -> [a]
++ FilePath
expected forall a. [a] -> [a] -> [a]
++ FilePath
" but got Nothing for: " forall a. [a] -> [a] -> [a]
++ 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) = forall a. ToMarkup a => a -> Html
preEscapedToHtml FilePath
s
    go (ContentAttrs Deref
d) =
        case 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)
_ -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show Deref
d forall a. [a] -> [a] -> [a]
++ FilePath
": expected EPlain for ContentAttrs"
    go (ContentVar Deref
d) =
        case 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)
_ -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show Deref
d forall a. [a] -> [a] -> [a]
++ FilePath
": expected EPlain for ContentVar"
    go (ContentUrl Bool
False Deref
d) =
        case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d RuntimeVars msg url
cd of
            Just (EUrl url
u) -> forall a. ToMarkup a => a -> Html
toHtml forall a b. (a -> b) -> a -> b
$ Render url
render url
u []
            Just VarExp msg url
wrong -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$  FilePath
"expected EUrl but got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show VarExp msg url
wrong forall a. [a] -> [a] -> [a]
++ FilePath
"\nfor: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Deref
d
            Maybe (VarExp msg url)
_ -> forall a b. Show a => FilePath -> a -> b
nothingError FilePath
"EUrl" Deref
d
    go (ContentUrl Bool
True Deref
d) =
        case 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)) ->
                forall a. ToMarkup a => a -> Html
toHtml forall a b. (a -> b) -> a -> b
$ Render url
render url
u [(Text, Text)]
p
            Maybe (VarExp msg url)
_ -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show Deref
d forall a. [a] -> [a] -> [a]
++ FilePath
": expected EUrlParam"
    go (ContentEmbed Deref
d) = case 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)
_ -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show Deref
d forall a. [a] -> [a] -> [a]
++ FilePath
": expected EMixin"