1{-# LANGUAGE TypeSynonymInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5-- | Provides functionality for runtime Hamlet templates. Please use
6-- "Text.Hamlet.Runtime" instead.
7module Text.Hamlet.RT
8    ( -- * Public API
9      HamletRT (..)
10    , HamletData (..)
11    , HamletMap
12    , HamletException (..)
13    , parseHamletRT
14    , renderHamletRT
15    , renderHamletRT'
16    , SimpleDoc (..)
17    ) where
18
19import Text.Shakespeare.Base
20import Data.Monoid (mconcat)
21import Control.Monad (liftM, forM)
22import Control.Exception (Exception)
23import Data.Typeable (Typeable)
24import Text.Hamlet.Parse
25import Data.List (intercalate)
26import Text.Blaze.Html (Html)
27import Text.Blaze.Internal (preEscapedString, preEscapedText)
28import Data.Text (Text)
29
30import Control.Monad.Catch (MonadThrow, throwM)
31
32type HamletMap url = [([String], HamletData url)]
33type UrlRenderer url = (url -> [(Text, Text)] -> Text)
34
35data HamletData url
36    = HDHtml Html
37    | HDUrl url
38    | HDUrlParams url [(Text, Text)]
39    | HDTemplate HamletRT
40    | HDBool Bool
41    | HDMaybe (Maybe (HamletMap url))
42    | HDList [HamletMap url]
43
44-- FIXME switch to Text?
45data SimpleDoc = SDRaw String
46               | SDVar [String]
47               | SDUrl Bool [String]
48               | SDTemplate [String]
49               | SDForall [String] String [SimpleDoc]
50               | SDMaybe [String] String [SimpleDoc] [SimpleDoc]
51               | SDCond [([String], [SimpleDoc])] [SimpleDoc]
52
53newtype HamletRT = HamletRT [SimpleDoc]
54
55data HamletException = HamletParseException String
56                     | HamletUnsupportedDocException Doc
57                     | HamletRenderException String
58    deriving (Show, Typeable)
59instance Exception HamletException
60
61
62
63parseHamletRT :: MonadThrow m
64              => HamletSettings -> String -> m HamletRT
65parseHamletRT set s =
66    case parseDoc set s of
67        Error s' -> throwM $ HamletParseException s'
68        Ok (_, x) -> liftM HamletRT $ mapM convert x
69  where
70    convert x@(DocForall deref (BindAs _ _) docs) =
71       error "Runtime Hamlet does not currently support 'as' patterns"
72    convert x@(DocForall deref (BindVar (Ident ident)) docs) = do
73        deref' <- flattenDeref' x deref
74        docs' <- mapM convert docs
75        return $ SDForall deref' ident docs'
76    convert DocForall{} = error "Runtime Hamlet does not currently support tuple patterns"
77    convert x@(DocMaybe deref (BindAs _ _) jdocs ndocs) =
78       error "Runtime Hamlet does not currently support 'as' patterns"
79    convert x@(DocMaybe deref (BindVar (Ident ident)) jdocs ndocs) = do
80        deref' <- flattenDeref' x deref
81        jdocs' <- mapM convert jdocs
82        ndocs' <- maybe (return []) (mapM convert) ndocs
83        return $ SDMaybe deref' ident jdocs' ndocs'
84    convert DocMaybe{} = error "Runtime Hamlet does not currently support tuple patterns"
85    convert (DocContent (ContentRaw s')) = return $ SDRaw s'
86    convert x@(DocContent (ContentVar deref)) = do
87        y <- flattenDeref' x deref
88        return $ SDVar y
89    convert x@(DocContent (ContentUrl p deref)) = do
90        y <- flattenDeref' x deref
91        return $ SDUrl p y
92    convert x@(DocContent (ContentEmbed deref)) = do
93        y <- flattenDeref' x deref
94        return $ SDTemplate y
95    convert (DocContent ContentMsg{}) =
96        error "Runtime hamlet does not currently support message interpolation"
97    convert (DocContent ContentAttrs{}) =
98        error "Runtime hamlet does not currently support attrs interpolation"
99
100    convert x@(DocCond conds els) = do
101        conds' <- mapM go conds
102        els' <- maybe (return []) (mapM convert) els
103        return $ SDCond conds' els'
104      where
105        -- | See the comments in Text.Hamlet.Parse.testIncludeClazzes. The conditional
106        -- added there doesn't work for runtime Hamlet, so we remove it here.
107        go (DerefBranch (DerefIdent x) _, docs') | x == specialOrIdent = do
108            docs'' <- mapM convert docs'
109            return (["True"], docs'')
110        go (deref, docs') = do
111            deref' <- flattenDeref' x deref
112            docs'' <- mapM convert docs'
113            return (deref', docs'')
114    convert DocWith{} = error "Runtime hamlet does not currently support $with"
115    convert DocCase{} = error "Runtime hamlet does not currently support $case"
116
117renderHamletRT :: MonadThrow m
118               => HamletRT
119               -> HamletMap url
120               -> UrlRenderer url
121               -> m Html
122renderHamletRT = renderHamletRT' False
123
124renderHamletRT' :: MonadThrow m
125                => Bool -- ^ should embeded template (via ^{..}) be plain Html or actual templates?
126                -> HamletRT
127                -> HamletMap url
128                -> (url -> [(Text, Text)] -> Text)
129                -> m Html
130renderHamletRT' tempAsHtml (HamletRT docs) scope0 renderUrl =
131    liftM mconcat $ mapM (go scope0) docs
132  where
133    go _ (SDRaw s) = return $ preEscapedString s
134    go scope (SDVar n) = do
135        v <- lookup' n n scope
136        case v of
137            HDHtml h -> return h
138            _ -> fa $ showName n ++ ": expected HDHtml"
139    go scope (SDUrl p n) = do
140        v <- lookup' n n scope
141        case (p, v) of
142            (False, HDUrl u) -> return $ preEscapedText $ renderUrl u []
143            (True, HDUrlParams u q) ->
144                return $ preEscapedText $ renderUrl u q
145            (False, _) -> fa $ showName n ++ ": expected HDUrl"
146            (True, _) -> fa $ showName n ++ ": expected HDUrlParams"
147    go scope (SDTemplate n) = do
148        v <- lookup' n n scope
149        case (tempAsHtml, v) of
150            (False, HDTemplate h) -> renderHamletRT' tempAsHtml h scope renderUrl
151            (False, _) -> fa $ showName n ++ ": expected HDTemplate"
152            (True, HDHtml h) -> return h
153            (True, _) -> fa $ showName n ++ ": expected HDHtml"
154    go scope (SDForall n ident docs') = do
155        v <- lookup' n n scope
156        case v of
157            HDList os ->
158                liftM mconcat $ forM os $ \o -> do
159                    let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope
160                    renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl
161            _ -> fa $ showName n ++ ": expected HDList"
162    go scope (SDMaybe n ident jdocs ndocs) = do
163        v <- lookup' n n scope
164        (scope', docs') <-
165            case v of
166                HDMaybe Nothing -> return (scope, ndocs)
167                HDMaybe (Just o) -> do
168                    let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope
169                    return (scope', jdocs)
170                _ -> fa $ showName n ++ ": expected HDMaybe"
171        renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl
172    go scope (SDCond [] docs') =
173        renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl
174    go scope (SDCond ((b, docs'):cs) els) = do
175        v <- lookup' b b scope
176        case v of
177            HDBool True ->
178                renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl
179            HDBool False -> go scope (SDCond cs els)
180            _ -> fa $ showName b ++ ": expected HDBool"
181    lookup' :: MonadThrow m => [String] -> [String] -> HamletMap url -> m (HamletData url)
182    lookup' orig k m =
183        case lookup k m of
184            Nothing | k == ["True"] -> return $ HDBool True
185            Nothing -> fa $ showName orig ++ ": not found"
186            Just x -> return x
187
188fa :: MonadThrow m => String -> m a
189fa = throwM . HamletRenderException
190
191showName :: [String] -> String
192showName = intercalate "." . reverse
193
194flattenDeref' :: MonadThrow f => Doc -> Deref -> f [String]
195flattenDeref' orig deref =
196    case flattenDeref deref of
197        Nothing -> throwM $ HamletUnsupportedDocException orig
198        Just x -> return x
199