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