{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | Provides functionality for runtime Hamlet templates. Please use
-- "Text.Hamlet.Runtime" instead.
module Text.Hamlet.RT
    ( -- * Public API
      HamletRT (..)
    , HamletData (..)
    , HamletMap
    , HamletException (..)
    , parseHamletRT
    , renderHamletRT
    , renderHamletRT'
    , SimpleDoc (..)
    ) where

import Text.Shakespeare.Base
import Data.Monoid (mconcat)
import Control.Monad (liftM, forM)
import Control.Exception (Exception)
import Data.Typeable (Typeable)
import Text.Hamlet.Parse
import Data.List (intercalate)
import Text.Blaze.Html (Html)
import Text.Blaze.Internal (preEscapedString, preEscapedText)
import Data.Text (Text)

import Control.Monad.Catch (MonadThrow, throwM)

type HamletMap url = [([String], HamletData url)]
type UrlRenderer url = (url -> [(Text, Text)] -> Text)

data HamletData url
    = HDHtml Html
    | HDUrl url
    | HDUrlParams url [(Text, Text)]
    | HDTemplate HamletRT
    | HDBool Bool
    | HDMaybe (Maybe (HamletMap url))
    | HDList [HamletMap url]

-- FIXME switch to Text?
data SimpleDoc = SDRaw String
               | SDVar [String]
               | SDUrl Bool [String]
               | SDTemplate [String]
               | SDForall [String] String [SimpleDoc]
               | SDMaybe [String] String [SimpleDoc] [SimpleDoc]
               | SDCond [([String], [SimpleDoc])] [SimpleDoc]

newtype HamletRT = HamletRT [SimpleDoc]

data HamletException = HamletParseException String
                     | HamletUnsupportedDocException Doc
                     | HamletRenderException String
    deriving (Int -> HamletException -> ShowS
[HamletException] -> ShowS
HamletException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HamletException] -> ShowS
$cshowList :: [HamletException] -> ShowS
show :: HamletException -> String
$cshow :: HamletException -> String
showsPrec :: Int -> HamletException -> ShowS
$cshowsPrec :: Int -> HamletException -> ShowS
Show, Typeable)
instance Exception HamletException



parseHamletRT :: MonadThrow m
              => HamletSettings -> String -> m HamletRT
parseHamletRT :: forall (m :: * -> *).
MonadThrow m =>
HamletSettings -> String -> m HamletRT
parseHamletRT HamletSettings
set String
s =
    case HamletSettings -> String -> Result (Maybe NewlineStyle, [Doc])
parseDoc HamletSettings
set String
s of
        Error String
s' -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> HamletException
HamletParseException String
s'
        Ok (Maybe NewlineStyle
_, [Doc]
x) -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [SimpleDoc] -> HamletRT
HamletRT 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 :: * -> *}. MonadThrow m => Doc -> m SimpleDoc
convert [Doc]
x
  where
    convert :: Doc -> m SimpleDoc
convert x :: Doc
x@(DocForall Deref
deref (BindAs Ident
_ Binding
_) [Doc]
docs) =
       forall a. HasCallStack => String -> a
error String
"Runtime Hamlet does not currently support 'as' patterns"
    convert x :: Doc
x@(DocForall Deref
deref (BindVar (Ident String
ident)) [Doc]
docs) = do
        [String]
deref' <- forall (f :: * -> *). MonadThrow f => Doc -> Deref -> f [String]
flattenDeref' Doc
x Deref
deref
        [SimpleDoc]
docs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Doc -> m SimpleDoc
convert [Doc]
docs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String] -> String -> [SimpleDoc] -> SimpleDoc
SDForall [String]
deref' String
ident [SimpleDoc]
docs'
    convert DocForall{} = forall a. HasCallStack => String -> a
error String
"Runtime Hamlet does not currently support tuple patterns"
    convert x :: Doc
x@(DocMaybe Deref
deref (BindAs Ident
_ Binding
_) [Doc]
jdocs Maybe [Doc]
ndocs) =
       forall a. HasCallStack => String -> a
error String
"Runtime Hamlet does not currently support 'as' patterns"
    convert x :: Doc
x@(DocMaybe Deref
deref (BindVar (Ident String
ident)) [Doc]
jdocs Maybe [Doc]
ndocs) = do
        [String]
deref' <- forall (f :: * -> *). MonadThrow f => Doc -> Deref -> f [String]
flattenDeref' Doc
x Deref
deref
        [SimpleDoc]
jdocs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Doc -> m SimpleDoc
convert [Doc]
jdocs
        [SimpleDoc]
ndocs' <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return []) (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Doc -> m SimpleDoc
convert) Maybe [Doc]
ndocs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String] -> String -> [SimpleDoc] -> [SimpleDoc] -> SimpleDoc
SDMaybe [String]
deref' String
ident [SimpleDoc]
jdocs' [SimpleDoc]
ndocs'
    convert DocMaybe{} = forall a. HasCallStack => String -> a
error String
"Runtime Hamlet does not currently support tuple patterns"
    convert (DocContent (ContentRaw String
s')) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> SimpleDoc
SDRaw String
s'
    convert x :: Doc
x@(DocContent (ContentVar Deref
deref)) = do
        [String]
y <- forall (f :: * -> *). MonadThrow f => Doc -> Deref -> f [String]
flattenDeref' Doc
x Deref
deref
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String] -> SimpleDoc
SDVar [String]
y
    convert x :: Doc
x@(DocContent (ContentUrl Bool
p Deref
deref)) = do
        [String]
y <- forall (f :: * -> *). MonadThrow f => Doc -> Deref -> f [String]
flattenDeref' Doc
x Deref
deref
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> [String] -> SimpleDoc
SDUrl Bool
p [String]
y
    convert x :: Doc
x@(DocContent (ContentEmbed Deref
deref)) = do
        [String]
y <- forall (f :: * -> *). MonadThrow f => Doc -> Deref -> f [String]
flattenDeref' Doc
x Deref
deref
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String] -> SimpleDoc
SDTemplate [String]
y
    convert (DocContent ContentMsg{}) =
        forall a. HasCallStack => String -> a
error String
"Runtime hamlet does not currently support message interpolation"
    convert (DocContent ContentAttrs{}) =
        forall a. HasCallStack => String -> a
error String
"Runtime hamlet does not currently support attrs interpolation"

    convert x :: Doc
x@(DocCond [(Deref, [Doc])]
conds Maybe [Doc]
els) = do
        [([String], [SimpleDoc])]
conds' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {t :: * -> *}.
Traversable t =>
(Deref, t Doc) -> m ([String], t SimpleDoc)
go [(Deref, [Doc])]
conds
        [SimpleDoc]
els' <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return []) (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Doc -> m SimpleDoc
convert) Maybe [Doc]
els
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [([String], [SimpleDoc])] -> [SimpleDoc] -> SimpleDoc
SDCond [([String], [SimpleDoc])]
conds' [SimpleDoc]
els'
      where
        -- | See the comments in Text.Hamlet.Parse.testIncludeClazzes. The conditional
        -- added there doesn't work for runtime Hamlet, so we remove it here.
        go :: (Deref, t Doc) -> m ([String], t SimpleDoc)
go (DerefBranch (DerefIdent Ident
x) Deref
_, t Doc
docs') | Ident
x forall a. Eq a => a -> a -> Bool
== Ident
specialOrIdent = do
            t SimpleDoc
docs'' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Doc -> m SimpleDoc
convert t Doc
docs'
            forall (m :: * -> *) a. Monad m => a -> m a
return ([String
"True"], t SimpleDoc
docs'')
        go (Deref
deref, t Doc
docs') = do
            [String]
deref' <- forall (f :: * -> *). MonadThrow f => Doc -> Deref -> f [String]
flattenDeref' Doc
x Deref
deref
            t SimpleDoc
docs'' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Doc -> m SimpleDoc
convert t Doc
docs'
            forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
deref', t SimpleDoc
docs'')
    convert DocWith{} = forall a. HasCallStack => String -> a
error String
"Runtime hamlet does not currently support $with"
    convert DocCase{} = forall a. HasCallStack => String -> a
error String
"Runtime hamlet does not currently support $case"

renderHamletRT :: MonadThrow m
               => HamletRT
               -> HamletMap url
               -> UrlRenderer url
               -> m Html
renderHamletRT :: forall (m :: * -> *) url.
MonadThrow m =>
HamletRT -> HamletMap url -> UrlRenderer url -> m Html
renderHamletRT = forall (m :: * -> *) url.
MonadThrow m =>
Bool
-> HamletRT
-> HamletMap url
-> (url -> [(Text, Text)] -> Text)
-> m Html
renderHamletRT' Bool
False

renderHamletRT' :: MonadThrow m
                => Bool -- ^ should embeded template (via ^{..}) be plain Html or actual templates?
                -> HamletRT
                -> HamletMap url
                -> (url -> [(Text, Text)] -> Text)
                -> m Html
renderHamletRT' :: forall (m :: * -> *) url.
MonadThrow m =>
Bool
-> HamletRT
-> HamletMap url
-> (url -> [(Text, Text)] -> Text)
-> m Html
renderHamletRT' Bool
tempAsHtml (HamletRT [SimpleDoc]
docs) HamletMap url
scope0 url -> [(Text, Text)] -> Text
renderUrl =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Monoid a => [a] -> a
mconcat 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 :: * -> *}.
MonadThrow m =>
HamletMap url -> SimpleDoc -> m Html
go HamletMap url
scope0) [SimpleDoc]
docs
  where
    go :: HamletMap url -> SimpleDoc -> m Html
go HamletMap url
_ (SDRaw String
s) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Html
preEscapedString String
s
    go HamletMap url
scope (SDVar [String]
n) = do
        HamletData url
v <- forall (m :: * -> *) url.
MonadThrow m =>
[String] -> [String] -> HamletMap url -> m (HamletData url)
lookup' [String]
n [String]
n HamletMap url
scope
        case HamletData url
v of
            HDHtml Html
h -> forall (m :: * -> *) a. Monad m => a -> m a
return Html
h
            HamletData url
_ -> forall (m :: * -> *) a. MonadThrow m => String -> m a
fa forall a b. (a -> b) -> a -> b
$ [String] -> String
showName [String]
n forall a. [a] -> [a] -> [a]
++ String
": expected HDHtml"
    go HamletMap url
scope (SDUrl Bool
p [String]
n) = do
        HamletData url
v <- forall (m :: * -> *) url.
MonadThrow m =>
[String] -> [String] -> HamletMap url -> m (HamletData url)
lookup' [String]
n [String]
n HamletMap url
scope
        case (Bool
p, HamletData url
v) of
            (Bool
False, HDUrl url
u) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Html
preEscapedText forall a b. (a -> b) -> a -> b
$ url -> [(Text, Text)] -> Text
renderUrl url
u []
            (Bool
True, HDUrlParams url
u [(Text, Text)]
q) ->
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Html
preEscapedText forall a b. (a -> b) -> a -> b
$ url -> [(Text, Text)] -> Text
renderUrl url
u [(Text, Text)]
q
            (Bool
False, HamletData url
_) -> forall (m :: * -> *) a. MonadThrow m => String -> m a
fa forall a b. (a -> b) -> a -> b
$ [String] -> String
showName [String]
n forall a. [a] -> [a] -> [a]
++ String
": expected HDUrl"
            (Bool
True, HamletData url
_) -> forall (m :: * -> *) a. MonadThrow m => String -> m a
fa forall a b. (a -> b) -> a -> b
$ [String] -> String
showName [String]
n forall a. [a] -> [a] -> [a]
++ String
": expected HDUrlParams"
    go HamletMap url
scope (SDTemplate [String]
n) = do
        HamletData url
v <- forall (m :: * -> *) url.
MonadThrow m =>
[String] -> [String] -> HamletMap url -> m (HamletData url)
lookup' [String]
n [String]
n HamletMap url
scope
        case (Bool
tempAsHtml, HamletData url
v) of
            (Bool
False, HDTemplate HamletRT
h) -> forall (m :: * -> *) url.
MonadThrow m =>
Bool
-> HamletRT
-> HamletMap url
-> (url -> [(Text, Text)] -> Text)
-> m Html
renderHamletRT' Bool
tempAsHtml HamletRT
h HamletMap url
scope url -> [(Text, Text)] -> Text
renderUrl
            (Bool
False, HamletData url
_) -> forall (m :: * -> *) a. MonadThrow m => String -> m a
fa forall a b. (a -> b) -> a -> b
$ [String] -> String
showName [String]
n forall a. [a] -> [a] -> [a]
++ String
": expected HDTemplate"
            (Bool
True, HDHtml Html
h) -> forall (m :: * -> *) a. Monad m => a -> m a
return Html
h
            (Bool
True, HamletData url
_) -> forall (m :: * -> *) a. MonadThrow m => String -> m a
fa forall a b. (a -> b) -> a -> b
$ [String] -> String
showName [String]
n forall a. [a] -> [a] -> [a]
++ String
": expected HDHtml"
    go HamletMap url
scope (SDForall [String]
n String
ident [SimpleDoc]
docs') = do
        HamletData url
v <- forall (m :: * -> *) url.
MonadThrow m =>
[String] -> [String] -> HamletMap url -> m (HamletData url)
lookup' [String]
n [String]
n HamletMap url
scope
        case HamletData url
v of
            HDList [HamletMap url]
os ->
                forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [HamletMap url]
os forall a b. (a -> b) -> a -> b
$ \HamletMap url
o -> do
                    let scope' :: HamletMap url
scope' = forall a b. (a -> b) -> [a] -> [b]
map (\([String]
x, HamletData url
y) -> (String
ident forall a. a -> [a] -> [a]
: [String]
x, HamletData url
y)) HamletMap url
o forall a. [a] -> [a] -> [a]
++ HamletMap url
scope
                    forall (m :: * -> *) url.
MonadThrow m =>
Bool
-> HamletRT
-> HamletMap url
-> (url -> [(Text, Text)] -> Text)
-> m Html
renderHamletRT' Bool
tempAsHtml ([SimpleDoc] -> HamletRT
HamletRT [SimpleDoc]
docs') HamletMap url
scope' url -> [(Text, Text)] -> Text
renderUrl
            HamletData url
_ -> forall (m :: * -> *) a. MonadThrow m => String -> m a
fa forall a b. (a -> b) -> a -> b
$ [String] -> String
showName [String]
n forall a. [a] -> [a] -> [a]
++ String
": expected HDList"
    go HamletMap url
scope (SDMaybe [String]
n String
ident [SimpleDoc]
jdocs [SimpleDoc]
ndocs) = do
        HamletData url
v <- forall (m :: * -> *) url.
MonadThrow m =>
[String] -> [String] -> HamletMap url -> m (HamletData url)
lookup' [String]
n [String]
n HamletMap url
scope
        (HamletMap url
scope', [SimpleDoc]
docs') <-
            case HamletData url
v of
                HDMaybe Maybe (HamletMap url)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (HamletMap url
scope, [SimpleDoc]
ndocs)
                HDMaybe (Just HamletMap url
o) -> do
                    let scope' :: HamletMap url
scope' = forall a b. (a -> b) -> [a] -> [b]
map (\([String]
x, HamletData url
y) -> (String
ident forall a. a -> [a] -> [a]
: [String]
x, HamletData url
y)) HamletMap url
o forall a. [a] -> [a] -> [a]
++ HamletMap url
scope
                    forall (m :: * -> *) a. Monad m => a -> m a
return (HamletMap url
scope', [SimpleDoc]
jdocs)
                HamletData url
_ -> forall (m :: * -> *) a. MonadThrow m => String -> m a
fa forall a b. (a -> b) -> a -> b
$ [String] -> String
showName [String]
n forall a. [a] -> [a] -> [a]
++ String
": expected HDMaybe"
        forall (m :: * -> *) url.
MonadThrow m =>
Bool
-> HamletRT
-> HamletMap url
-> (url -> [(Text, Text)] -> Text)
-> m Html
renderHamletRT' Bool
tempAsHtml ([SimpleDoc] -> HamletRT
HamletRT [SimpleDoc]
docs') HamletMap url
scope' url -> [(Text, Text)] -> Text
renderUrl
    go HamletMap url
scope (SDCond [] [SimpleDoc]
docs') =
        forall (m :: * -> *) url.
MonadThrow m =>
Bool
-> HamletRT
-> HamletMap url
-> (url -> [(Text, Text)] -> Text)
-> m Html
renderHamletRT' Bool
tempAsHtml ([SimpleDoc] -> HamletRT
HamletRT [SimpleDoc]
docs') HamletMap url
scope url -> [(Text, Text)] -> Text
renderUrl
    go HamletMap url
scope (SDCond (([String]
b, [SimpleDoc]
docs'):[([String], [SimpleDoc])]
cs) [SimpleDoc]
els) = do
        HamletData url
v <- forall (m :: * -> *) url.
MonadThrow m =>
[String] -> [String] -> HamletMap url -> m (HamletData url)
lookup' [String]
b [String]
b HamletMap url
scope
        case HamletData url
v of
            HDBool Bool
True ->
                forall (m :: * -> *) url.
MonadThrow m =>
Bool
-> HamletRT
-> HamletMap url
-> (url -> [(Text, Text)] -> Text)
-> m Html
renderHamletRT' Bool
tempAsHtml ([SimpleDoc] -> HamletRT
HamletRT [SimpleDoc]
docs') HamletMap url
scope url -> [(Text, Text)] -> Text
renderUrl
            HDBool Bool
False -> HamletMap url -> SimpleDoc -> m Html
go HamletMap url
scope ([([String], [SimpleDoc])] -> [SimpleDoc] -> SimpleDoc
SDCond [([String], [SimpleDoc])]
cs [SimpleDoc]
els)
            HamletData url
_ -> forall (m :: * -> *) a. MonadThrow m => String -> m a
fa forall a b. (a -> b) -> a -> b
$ [String] -> String
showName [String]
b forall a. [a] -> [a] -> [a]
++ String
": expected HDBool"
    lookup' :: MonadThrow m => [String] -> [String] -> HamletMap url -> m (HamletData url)
    lookup' :: forall (m :: * -> *) url.
MonadThrow m =>
[String] -> [String] -> HamletMap url -> m (HamletData url)
lookup' [String]
orig [String]
k HamletMap url
m =
        case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [String]
k HamletMap url
m of
            Maybe (HamletData url)
Nothing | [String]
k forall a. Eq a => a -> a -> Bool
== [String
"True"] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall url. Bool -> HamletData url
HDBool Bool
True
            Maybe (HamletData url)
Nothing -> forall (m :: * -> *) a. MonadThrow m => String -> m a
fa forall a b. (a -> b) -> a -> b
$ [String] -> String
showName [String]
orig forall a. [a] -> [a] -> [a]
++ String
": not found"
            Just HamletData url
x -> forall (m :: * -> *) a. Monad m => a -> m a
return HamletData url
x

fa :: MonadThrow m => String -> m a
fa :: forall (m :: * -> *) a. MonadThrow m => String -> m a
fa = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HamletException
HamletRenderException

showName :: [String] -> String
showName :: [String] -> String
showName = forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

flattenDeref' :: MonadThrow f => Doc -> Deref -> f [String]
flattenDeref' :: forall (f :: * -> *). MonadThrow f => Doc -> Deref -> f [String]
flattenDeref' Doc
orig Deref
deref =
    case Deref -> Maybe [String]
flattenDeref Deref
deref of
        Maybe [String]
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Doc -> HamletException
HamletUnsupportedDocException Doc
orig
        Just [String]
x -> forall (m :: * -> *) a. Monad m => a -> m a
return [String]
x