{-# 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 (m :: * -> *) a. Monad m => a -> m a
return
instance ToAttributes (String, String) where
    toAttributes :: (String, String) -> [(Text, Text)]
toAttributes (k :: String
k, v :: String
v) = [(String -> Text
pack String
k, String -> Text
pack String
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 :: [(String, String)] -> [(Text, Text)]
toAttributes = ((String, String) -> (Text, Text))
-> [(String, String)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
pack (String -> Text)
-> (String -> Text) -> (String, String) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
pack)

attrsToHtml :: [(Text, Text)] -> Html
attrsToHtml :: [(Text, Text)] -> Html
attrsToHtml =
    ((Text, Text) -> Html -> Html) -> Html -> [(Text, Text)] -> Html
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 (k :: Text
k, v :: a
v) rest :: Html
rest =
        String -> Html
forall a. ToMarkup a => a -> Html
toHtml " "
        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 (String -> Text
pack "=\"")
        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 (String -> Text
pack "\"")
        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
env hr :: HamletRules
hr scope :: Scope
scope docs :: [Doc]
docs = do
    [Exp]
exps <- (Doc -> Q Exp) -> [Doc] -> Q [Exp]
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 ()|]
        [x :: Exp
x] -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
        _ -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
DoE ([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 -> String
unIdent (Ident s :: String
s) = String
s

bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern :: Binding -> Q (Pat, Scope)
bindingPattern (BindAs i :: Ident
i@(Ident s :: String
s) b :: Binding
b) = do
    Name
name <- String -> Q Name
newName String
s
    (newPattern :: Pat
newPattern, scope :: Scope
scope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
b
    (Pat, Scope) -> Q (Pat, Scope)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat -> Pat
AsP Name
name Pat
newPattern, (Ident
i, Name -> Exp
VarE Name
name)(Ident, Exp) -> Scope -> Scope
forall a. a -> [a] -> [a]
:Scope
scope)
bindingPattern (BindVar i :: Ident
i@(Ident s :: String
s))
    | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "_" = (Pat, Scope) -> Q (Pat, Scope)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
WildP, [])
    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
s = do
        (Pat, Scope) -> Q (Pat, Scope)
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
$ String -> Integer
forall a. Read a => String -> a
read String
s, [])
    | Bool
otherwise = do
        Name
name <- String -> Q Name
newName String
s
        (Pat, Scope) -> Q (Pat, Scope)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat
VarP Name
name, [(Ident
i, Name -> Exp
VarE Name
name)])
bindingPattern (BindTuple is :: [Binding]
is) = do
    (patterns :: [Pat]
patterns, scopes :: [Scope]
scopes) <- ([(Pat, Scope)] -> ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
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)
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    (Pat, Scope) -> Q (Pat, Scope)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
TupP [Pat]
patterns, [Scope] -> Scope
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes)
bindingPattern (BindList is :: [Binding]
is) = do
    (patterns :: [Pat]
patterns, scopes :: [Scope]
scopes) <- ([(Pat, Scope)] -> ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
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)
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    (Pat, Scope) -> Q (Pat, Scope)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
ListP [Pat]
patterns, [Scope] -> Scope
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes)
bindingPattern (BindConstr con :: DataConstr
con is :: [Binding]
is) = do
    (patterns :: [Pat]
patterns, scopes :: [Scope]
scopes) <- ([(Pat, Scope)] -> ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
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)
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    (Pat, Scope) -> Q (Pat, Scope)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
ConP (DataConstr -> Name
mkConName DataConstr
con) [Pat]
patterns, [Scope] -> Scope
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes)
bindingPattern (BindRecord con :: DataConstr
con fields :: [(Ident, Binding)]
fields wild :: Bool
wild) = do
    let f :: (Ident, Binding) -> Q ((Name, Pat), Scope)
f (Ident field :: String
field,b :: Binding
b) =
           do (p :: Pat
p,s :: Scope
s) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
b
              ((Name, Pat), Scope) -> Q ((Name, Pat), Scope)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> Name
mkName String
field,Pat
p),Scope
s)
    (patterns :: [(Name, Pat)]
patterns, scopes :: [Scope]
scopes) <- ([((Name, Pat), Scope)] -> ([(Name, Pat)], [Scope]))
-> Q [((Name, Pat), Scope)] -> Q ([(Name, Pat)], [Scope])
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)
mapM (Ident, Binding) -> Q ((Name, Pat), Scope)
f [(Ident, Binding)]
fields
    (patterns1 :: [(Name, Pat)]
patterns1, scopes1 :: Scope
scopes1) <- if Bool
wild
       then DataConstr -> [Ident] -> Q ([(Name, Pat)], Scope)
bindWildFields DataConstr
con ([Ident] -> Q ([(Name, Pat)], Scope))
-> [Ident] -> Q ([(Name, Pat)], Scope)
forall a b. (a -> b) -> a -> b
$ ((Ident, Binding) -> Ident) -> [(Ident, Binding)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Binding) -> Ident
forall a b. (a, b) -> a
fst [(Ident, Binding)]
fields
       else ([(Name, Pat)], Scope) -> Q ([(Name, Pat)], Scope)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[])
    (Pat, Scope) -> Q (Pat, Scope)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [(Name, Pat)] -> Pat
RecP (DataConstr -> Name
mkConName DataConstr
con) ([(Name, Pat)]
patterns[(Name, Pat)] -> [(Name, Pat)] -> [(Name, Pat)]
forall a. [a] -> [a] -> [a]
++[(Name, Pat)]
patterns1), [Scope] -> Scope
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scopes1)

mkConName :: DataConstr -> Name
mkConName :: DataConstr -> Name
mkConName = String -> Name
mkName (String -> Name) -> (DataConstr -> String) -> DataConstr -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataConstr -> String
conToStr

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

-- Wildcards bind all of the unbound fields to variables whose name
-- matches the field name.
--
-- For example: data R = C { f1, f2 :: Int }
-- C {..}           is equivalent to   C {f1=f1, f2=f2}
-- C {f1 = a, ..}   is equivalent to   C {f1=a,  f2=f2}
-- C {f2 = a, ..}   is equivalent to   C {f1=f1, f2=a}
bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], Scope)
bindWildFields conName :: DataConstr
conName fields :: [Ident]
fields = do
  [Name]
fieldNames <- DataConstr -> Q [Name]
recordToFieldNames DataConstr
conName
  let available :: Name -> Bool
available n :: Name
n     = Name -> String
nameBase Name
n String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Ident -> String) -> [Ident] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
unIdent [Ident]
fields
  let remainingFields :: [Name]
remainingFields = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
available [Name]
fieldNames
  let mkPat :: Name -> Q ((Name, Pat), (Ident, Exp))
mkPat n :: Name
n = do
        Name
e <- String -> Q Name
newName (Name -> String
nameBase Name
n)
        ((Name, Pat), (Ident, Exp)) -> Q ((Name, Pat), (Ident, Exp))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n,Name -> Pat
VarP Name
e), (String -> Ident
Ident (Name -> String
nameBase Name
n), Name -> Exp
VarE Name
e))
  ([((Name, Pat), (Ident, Exp))] -> ([(Name, Pat)], Scope))
-> Q [((Name, Pat), (Ident, Exp))] -> Q ([(Name, Pat)], Scope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((Name, Pat), (Ident, Exp))] -> ([(Name, Pat)], Scope)
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [((Name, Pat), (Ident, Exp))] -> Q ([(Name, Pat)], Scope))
-> Q [((Name, Pat), (Ident, Exp))] -> Q ([(Name, Pat)], Scope)
forall a b. (a -> b) -> a -> b
$ (Name -> Q ((Name, Pat), (Ident, Exp)))
-> [Name] -> Q [((Name, Pat), (Ident, Exp))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q ((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 conStr :: 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 :: Name
conName                <- String -> Q (Maybe Name)
lookupValueName (String -> Q (Maybe Name)) -> String -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ DataConstr -> String
conToStr DataConstr
conStr
  DataConI _ _ typeName :: Name
typeName         <- Name -> Q Info
reify Name
conName
  TyConI (DataD _ _ _ _ cons :: [Con]
cons _) <- Name -> Q Info
reify Name
typeName
  [fields :: [VarBangType]
fields] <- [[VarBangType]] -> Q [[VarBangType]]
forall (m :: * -> *) a. Monad m => a -> m a
return [[VarBangType]
fields | RecC name :: Name
name fields :: [VarBangType]
fields <- [Con]
cons, Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
conName]
  [Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
fieldName | (fieldName :: Name
fieldName, _, _) <- [VarBangType]
fields]

docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
docToExp env :: Env
env hr :: HamletRules
hr scope :: Scope
scope (DocForall list :: Deref
list idents :: Binding
idents inside :: [Doc]
inside) = do
    let list' :: Exp
list' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
list
    (pat :: Pat
pat, extraScope :: Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' :: Scope
scope' = Scope
extraScope Scope -> Scope -> Scope
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'
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
mh Exp -> Exp -> Exp
`AppE` Exp
lam Exp -> Exp -> Exp
`AppE` Exp
list'
docToExp env :: Env
env hr :: HamletRules
hr scope :: Scope
scope (DocWith [] inside :: [Doc]
inside) = do
    Exp
inside' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
inside
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
inside'
docToExp env :: Env
env hr :: HamletRules
hr scope :: Scope
scope (DocWith ((deref :: Deref
deref, idents :: Binding
idents):dis :: [(Deref, Binding)]
dis) inside :: [Doc]
inside) = do
    let deref' :: Exp
deref' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
deref
    (pat :: Pat
pat, extraScope :: Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' :: Scope
scope' = Scope
extraScope Scope -> Scope -> Scope
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'
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
lam Exp -> Exp -> Exp
`AppE` Exp
deref'
docToExp env :: Env
env hr :: HamletRules
hr scope :: Scope
scope (DocMaybe val :: Deref
val idents :: Binding
idents inside :: [Doc]
inside mno :: Maybe [Doc]
mno) = do
    let val' :: Exp
val' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
val
    (pat :: Pat
pat, extraScope :: Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' :: Scope
scope' = Scope
extraScope Scope -> Scope -> Scope
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
                    Nothing -> [|Nothing|]
                    Just no :: [Doc]
no -> do
                        Exp
no' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
no
                        Exp
j <- [|Just|]
                        Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
j Exp -> Exp -> Exp
`AppE` Exp
no'
    Exp
mh <- [|maybeH|]
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
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
env hr :: HamletRules
hr scope :: Scope
scope (DocCond conds :: [(Deref, [Doc])]
conds final :: Maybe [Doc]
final) = do
    [Exp]
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)
mapM (Deref, [Doc]) -> Q Exp
go [(Deref, [Doc])]
conds
    Exp
final' <- case Maybe [Doc]
final of
                Nothing -> [|Nothing|]
                Just f :: [Doc]
f -> do
                    Exp
f' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
f
                    Exp
j <- [|Just|]
                    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
j Exp -> Exp -> Exp
`AppE` Exp
f'
    Exp
ch <- [|condH|]
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
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 (d :: Deref
d, docs :: [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
        Exp
docs' <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope [Doc]
docs
        Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
          $ map Just
#endif
          [Exp
d', Exp
docs']
docToExp env :: Env
env hr :: HamletRules
hr scope :: Scope
scope (DocCase deref :: Deref
deref cases :: [(Binding, [Doc])]
cases) = do
    let exp_ :: Exp
exp_ = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
deref
    [Match]
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)
mapM (Binding, [Doc]) -> Q Match
toMatch [(Binding, [Doc])]
cases
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
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 (idents :: Binding
idents, inside :: [Doc]
inside) = do
        (pat :: Pat
pat, extraScope :: Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
        let scope' :: Scope
scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
        Exp
insideExp <- Env -> HamletRules -> Scope -> [Doc] -> Q Exp
docsToExp Env
env HamletRules
hr Scope
scope' [Doc]
inside
        Match -> Q Match
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
insideExp) []
docToExp env :: Env
env hr :: HamletRules
hr v :: Scope
v (DocContent c :: 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 _ hr :: HamletRules
hr _ (ContentRaw s :: String
s) = do
    Exp
os <- [|preEscapedText . pack|]
    let s' :: Exp
s' = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
s
    Exp -> Q Exp
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
os Exp -> Exp -> Exp
`AppE` Exp
s')
contentToExp _ hr :: HamletRules
hr scope :: Scope
scope (ContentVar d :: Deref
d) = do
    Exp
str <- [|toHtml|]
    Exp -> Q Exp
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
str Exp -> Exp -> Exp
`AppE` Scope -> Deref -> Exp
derefToExp Scope
scope Deref
d)
contentToExp env :: Env
env hr :: HamletRules
hr scope :: Scope
scope (ContentUrl hasParams :: Bool
hasParams d :: Deref
d) =
    case Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
urlRender Env
env of
        Nothing -> String -> Q Exp
forall a. HasCallStack => String -> a
error "URL interpolation used, but no URL renderer provided"
        Just wrender :: (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
$ \render :: Exp
render -> do
            let render' :: Q Exp
render' = Exp -> Q Exp
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|]
            Exp -> Q Exp
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
pet Exp -> Exp -> Exp
`AppE` (Exp
ou Exp -> Exp -> Exp
`AppE` Exp
d'))
contentToExp env :: Env
env hr :: HamletRules
hr scope :: Scope
scope (ContentEmbed d :: 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
env hr :: HamletRules
hr scope :: Scope
scope (ContentMsg d :: Deref
d) =
    case Env -> Maybe ((Exp -> Q Exp) -> Q Exp)
msgRender Env
env of
        Nothing -> String -> Q Exp
forall a. HasCallStack => String -> a
error "Message interpolation used, but no message renderer provided"
        Just wrender :: (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
$ \render :: Exp
render ->
            Exp -> Q Exp
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 _ hr :: HamletRules
hr scope :: Scope
scope (ContentAttrs d :: Deref
d) = do
    Exp
html <- [|attrsToHtml . toAttributes|]
    Exp -> Q Exp
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
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|]
    HamletRules -> Q HamletRules
forall (m :: * -> *) a. Monad m => a -> m a
return (HamletRules -> Q HamletRules) -> HamletRules -> Q HamletRules
forall a b. (a -> b) -> a -> b
$ Exp
-> ((Env -> Q Exp) -> Q Exp)
-> (Env -> Exp -> Q Exp)
-> HamletRules
HamletRules Exp
i ((Env -> Q Exp) -> Env -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Maybe ((Exp -> Q Exp) -> Q Exp)
-> Maybe ((Exp -> Q Exp) -> Q Exp) -> Env
Env Maybe ((Exp -> Q Exp) -> Q Exp)
forall a. Maybe a
Nothing Maybe ((Exp -> Q Exp) -> Q Exp)
forall a. Maybe a
Nothing)) (\_ b :: Exp
b -> Exp -> Q Exp
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 :: HtmlUrl url -> HtmlUrl url
asHtmlUrl = HtmlUrl url -> HtmlUrl url
forall a. a -> a
id

hamletRules :: Q HamletRules
hamletRules :: Q HamletRules
hamletRules = do
    Exp
i <- [|id|]
    let ur :: (Env -> Q Exp) -> Q Exp
ur f :: Env -> Q Exp
f = do
            Name
r <- String -> Q Name
newName "_render"
            let env :: Env
env = Env :: Maybe ((Exp -> Q Exp) -> Q Exp)
-> Maybe ((Exp -> Q Exp) -> Q Exp) -> 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
                    }
            Exp
h <- Env -> Q Exp
f Env
env
            Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
r] Exp
h
    HamletRules -> Q HamletRules
forall (m :: * -> *) a. Monad m => a -> m a
return (HamletRules -> Q HamletRules) -> HamletRules -> Q HamletRules
forall a b. (a -> b) -> a -> b
$ Exp
-> ((Env -> Q Exp) -> Q Exp)
-> (Env -> Exp -> Q Exp)
-> HamletRules
HamletRules Exp
i (Env -> Q Exp) -> Q Exp
ur Env -> Exp -> Q Exp
em
  where
    em :: Env -> Exp -> Q Exp
em (Env (Just urender :: (Exp -> Q Exp) -> Q Exp
urender) Nothing) e :: Exp
e = do
        Exp
asHtmlUrl' <- [|asHtmlUrl|]
        (Exp -> Q Exp) -> Q Exp
urender ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \ur' :: Exp
ur' -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return ((Exp
asHtmlUrl' Exp -> Exp -> Exp
`AppE` Exp
e) Exp -> Exp -> Exp
`AppE` Exp
ur')
    em _ _ = String -> Q Exp
forall a. HasCallStack => String -> a
error "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 -> Q Exp) -> Q Exp
ur f :: Env -> Q Exp
f = do
            Name
u <- String -> Q Name
newName "_urender"
            Name
m <- String -> Q Name
newName "_mrender"
            let env :: Env
env = Env :: Maybe ((Exp -> Q Exp) -> Q Exp)
-> Maybe ((Exp -> Q Exp) -> Q Exp) -> 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))
                    }
            Exp
h <- Env -> Q Exp
f Env
env
            Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
m, Name -> Pat
VarP Name
u] Exp
h
    HamletRules -> Q HamletRules
forall (m :: * -> *) a. Monad m => a -> m a
return (HamletRules -> Q HamletRules) -> HamletRules -> Q HamletRules
forall a b. (a -> b) -> a -> b
$ Exp
-> ((Env -> Q Exp) -> Q Exp)
-> (Env -> Exp -> Q Exp)
-> HamletRules
HamletRules Exp
i (Env -> Q Exp) -> Q Exp
ur Env -> Exp -> Q Exp
em
  where
    em :: Env -> Exp -> Q Exp
em (Env (Just urender :: (Exp -> Q Exp) -> Q Exp
urender) (Just mrender :: (Exp -> Q Exp) -> Q Exp
mrender)) e :: 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
$ \ur' :: 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
$ \mr :: Exp
mr -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
e Exp -> Exp -> Exp
`AppE` Exp
mr Exp -> Exp -> Exp
`AppE` Exp
ur')
    em _ _ = String -> Q Exp
forall a. HasCallStack => String -> a
error "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 hr :: Q HamletRules
hr set :: HamletSettings
set =
    QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
        { quoteExp :: String -> Q Exp
quoteExp = Q HamletRules -> HamletSettings -> String -> 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 -> String -> Q Exp
hamletFromString qhr :: Q HamletRules
qhr set :: HamletSettings
set s :: String
s = do
    HamletRules
hr <- Q HamletRules
qhr
    HamletRules -> (Env -> Q Exp) -> Q Exp
hrWithEnv HamletRules
hr ((Env -> Q Exp) -> Q Exp) -> (Env -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \env :: 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 -> String -> [Doc]
docFromString HamletSettings
set String
s

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

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

-- | Like 'hamlet', but reads an external file at compile time.
--
-- @
-- $('hamletFile' \"foo.hamlet\") :: 'HtmlUrl' MyRoute
-- @
hamletFile :: FilePath -> Q Exp
hamletFile :: String -> Q Exp
hamletFile = Q HamletRules -> HamletSettings -> String -> 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 :: String -> Q Exp
hamletFileReload = HamletRuntimeRules -> HamletSettings -> String -> Q Exp
hamletFileReloadWithSettings HamletRuntimeRules
runtimeRules HamletSettings
defaultHamletSettings
  where runtimeRules :: HamletRuntimeRules
runtimeRules = HamletRuntimeRules :: Bool -> HamletRuntimeRules
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 :: String -> Q Exp
ihamletFileReload = HamletRuntimeRules -> HamletSettings -> String -> Q Exp
hamletFileReloadWithSettings HamletRuntimeRules
runtimeRules HamletSettings
defaultHamletSettings
  where runtimeRules :: HamletRuntimeRules
runtimeRules = HamletRuntimeRules :: Bool -> HamletRuntimeRules
HamletRuntimeRules { hrrI18n :: Bool
hrrI18n = Bool
True }

-- | Like 'hamletFile', but produces XHTML.
xhamletFile :: FilePath -> Q Exp
xhamletFile :: String -> Q Exp
xhamletFile = Q HamletRules -> HamletSettings -> String -> 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 :: String -> Q Exp
shamletFile = Q HamletRules -> HamletSettings -> String -> Q Exp
hamletFileWithSettings Q HamletRules
htmlRules HamletSettings
defaultHamletSettings

-- | Like 'shamletFile', but produces XHTML.
xshamletFile :: FilePath -> Q Exp
xshamletFile :: String -> Q Exp
xshamletFile = Q HamletRules -> HamletSettings -> String -> 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 :: String -> Q Exp
ihamletFile = Q HamletRules -> HamletSettings -> String -> Q Exp
hamletFileWithSettings Q HamletRules
ihamletRules HamletSettings
defaultHamletSettings

varName :: Scope -> String -> Exp
varName :: Scope -> String -> Exp
varName _ "" = String -> Exp
forall a. HasCallStack => String -> a
error "Illegal empty varName"
varName scope :: Scope
scope v :: String
v@(_:_) = Exp -> Maybe Exp -> Exp
forall a. a -> Maybe a -> a
fromMaybe (String -> Exp
strToExp String
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 (String -> Ident
Ident String
v) Scope
scope

strToExp :: String -> Exp
strToExp :: String -> Exp
strToExp s :: String
s@(c :: Char
c:_)
    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
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
$ String -> Integer
forall a. Read a => String -> a
read String
s
    | Char -> Bool
isUpper Char
c = Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s
    | Bool
otherwise = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s
strToExp "" = String -> Exp
forall a. HasCallStack => String -> a
error "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 :: [(Bool, m ())] -> Maybe (m ()) -> m ()
condH bms :: [(Bool, m ())]
bms mm :: Maybe (m ())
mm = m () -> Maybe (m ()) -> m ()
forall a. a -> Maybe a -> a
fromMaybe (() -> m ()
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 (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 :: Maybe v -> (v -> m ()) -> Maybe (m ()) -> m ()
maybeH mv :: Maybe v
mv f :: v -> m ()
f mm :: Maybe (m ())
mm = m () -> Maybe (m ()) -> m ()
forall a. a -> Maybe a -> a
fromMaybe (() -> m ()
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 (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 (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 -> String
show (EPlain html :: Html
html) = "EPlain"
  show (EUrl url :: url
url) = "EUrl"
  show (EUrlParam url :: (url, [(Text, Text)])
url) = "EUrlParam"
  show (EMixin url :: HtmlUrl url
url) = "EMixin"
  show (EMixinI18n msg_url :: HtmlUrlI18n msg url
msg_url) = "EMixinI18n"
  show (EMsg msg :: msg
msg) = "EMsg"

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

hamletUsedIdentifiers :: HamletSettings -> String -> [(Deref, VarType)]
hamletUsedIdentifiers :: HamletSettings -> String -> [(Deref, VarType)]
hamletUsedIdentifiers settings :: 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)])
-> (String -> [Content]) -> String -> [(Deref, VarType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HamletSettings -> String -> [Content]
contentFromString HamletSettings
settings


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

hamletFileReloadWithSettings :: HamletRuntimeRules
                             -> HamletSettings -> FilePath -> Q Exp
hamletFileReloadWithSettings :: HamletRuntimeRules -> HamletSettings -> String -> Q Exp
hamletFileReloadWithSettings hrr :: HamletRuntimeRules
hrr settings :: HamletSettings
settings fp :: String
fp = do
    String
s <- String -> Q String
readFileQ String
fp
    let b :: [(Deref, VarType)]
b = HamletSettings -> String -> [(Deref, VarType)]
hamletUsedIdentifiers HamletSettings
settings String
s
    [Exp]
c <- ((Deref, VarType) -> Q Exp) -> [(Deref, VarType)] -> Q [Exp]
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|]
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
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 (d :: Deref
d, vt :: VarType
vt) = do
        Exp
d' <- Deref -> Q Exp
forall t. Lift t => t -> Q Exp
lift Deref
d
        Exp
c' <- VarType -> Q Exp
toExp VarType
vt
        Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
          $ map 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 VTAttrs = [|EPlain . attrsToHtml . toAttributes|]
            c VTPlain = [|EPlain . toHtml|]
            c VTUrl = [|EUrl|]
            c VTUrlParam = [|EUrlParam|]
            c VTMixin = [|\r -> EMixin $ \c -> r c|]
            c VTMsg = [|EMsg|]

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

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

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

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

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


hamletRuntime :: HamletSettings
              -> FilePath
              -> [(Deref, VarExp msg url)]
              -> Shakespeare url
hamletRuntime :: HamletSettings
-> String -> [(Deref, VarExp msg url)] -> Shakespeare url
hamletRuntime settings :: HamletSettings
settings fp :: String
fp cd :: [(Deref, VarExp msg url)]
cd render :: 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
mtime <- IO MTime -> IO MTime
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
$ String -> IO MTime
getModificationTime String
fp
    Maybe (MTime, [Content])
mdata <- String -> IO (Maybe (MTime, [Content]))
lookupReloadMap String
fp
    case Maybe (MTime, [Content])
mdata of
      Just (lastMtime :: MTime
lastMtime, lastContents :: [Content]
lastContents) ->
        if MTime
mtime MTime -> MTime -> Bool
forall a. Eq a => a -> a -> Bool
== MTime
lastMtime then Html -> IO Html
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 (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
      Nothing -> ([Content] -> Html) -> IO [Content] -> IO Html
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
mtime = do
        String
s <- String -> IO String
readUtf8FileString String
fp
        String -> (MTime, [Content]) -> IO [Content]
insertReloadMap String
fp (MTime
mtime, HamletSettings -> String -> [Content]
contentFromString HamletSettings
settings String
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 (String -> Translate msg
forall a. HasCallStack => String -> a
error "I18n embed IMPOSSIBLE") Deref -> Html
forall p a. p -> a
handleMsgEx)
    handleMsgEx :: p -> a
handleMsgEx _ = String -> a
forall a. HasCallStack => String -> a
error "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 :: HamletSettings
-> String -> RuntimeVars msg url -> HtmlUrlI18n msg url
hamletRuntimeMsg settings :: HamletSettings
settings fp :: String
fp cd :: RuntimeVars msg url
cd i18nRender :: Translate msg
i18nRender render :: 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
mtime <- IO MTime -> IO MTime
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
$ String -> IO MTime
getModificationTime String
fp
    Maybe (MTime, [Content])
mdata <- String -> IO (Maybe (MTime, [Content]))
lookupReloadMap String
fp
    case Maybe (MTime, [Content])
mdata of
      Just (lastMtime :: MTime
lastMtime, lastContents :: [Content]
lastContents) ->
        if MTime
mtime MTime -> MTime -> Bool
forall a. Eq a => a -> a -> Bool
== MTime
lastMtime then Html -> IO Html
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 (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
      Nothing -> ([Content] -> Html) -> IO [Content] -> IO Html
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
mtime = do
        String
s <- String -> IO String
readUtf8FileString String
fp
        String -> (MTime, [Content]) -> IO [Content]
insertReloadMap String
fp (MTime
mtime, HamletSettings -> String -> [Content]
contentFromString HamletSettings
settings String
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 d :: 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 s :: msg
s) -> Translate msg
i18nRender msg
s
            _ -> String -> Deref -> Html
forall a b. Show a => String -> a -> b
nothingError "EMsg for ContentMsg" Deref
d

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

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