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
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
|
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module Text.Hamlet.XML
( xml
, xmlFile
, ToAttributes (..)
) where
#if MIN_VERSION_template_haskell(2,9,0)
import Language.Haskell.TH.Syntax hiding (Module)
#else
import Language.Haskell.TH.Syntax
#endif
import Language.Haskell.TH.Quote
import Data.Char (isDigit)
import qualified Data.Text.Lazy as TL
import Control.Monad ((<=<))
import Text.Hamlet.XMLParse
import Text.Shakespeare.Base (readUtf8File, derefToExp, Scope, Deref, Ident (Ident))
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import qualified Text.XML as X
import Data.String (fromString)
import qualified Data.Foldable as F
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import Control.Arrow (first, (***))
import Data.List (intercalate)
conP :: Name -> [Pat] -> Pat
#if MIN_VERSION_template_haskell(2,18,0)
conP name = ConP name []
#else
conP = ConP
#endif
-- | Convert some value to a list of attribute pairs.
class ToAttributes a where
toAttributes :: a -> Map.Map X.Name Text
instance ToAttributes (X.Name, Text) where
toAttributes (k, v) = Map.singleton k v
instance ToAttributes (Text, Text) where
toAttributes (k, v) = Map.singleton (fromString $ unpack k) v
instance ToAttributes (String, String) where
toAttributes (k, v) = Map.singleton (fromString k) (pack v)
instance ToAttributes [(X.Name, Text)] where
toAttributes = Map.fromList
instance ToAttributes [(Text, Text)] where
toAttributes = Map.fromList . map (first (fromString . unpack))
instance ToAttributes [(String, String)] where
toAttributes = Map.fromList . map (fromString *** pack)
instance ToAttributes (Map.Map X.Name Text) where
toAttributes = id
instance ToAttributes (Map.Map Text Text) where
toAttributes = Map.mapKeys (fromString . unpack)
instance ToAttributes (Map.Map String String) where
toAttributes = Map.mapKeys fromString . Map.map pack
docsToExp :: Scope -> [Doc] -> Q Exp
docsToExp scope docs = [| concat $(fmap ListE $ mapM (docToExp scope) docs) |]
unIdent :: Ident -> String
unIdent (Ident s) = s
bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern (BindAs i@(Ident s) b) = do
name <- newName s
(pattern, scope) <- bindingPattern b
return (AsP name pattern, (i, VarE name):scope)
bindingPattern (BindVar i@(Ident s))
| s == "_" = return (WildP, [])
| all isDigit s = do
return (LitP $ IntegerL $ read s, [])
| otherwise = do
name <- newName s
return (VarP name, [(i, VarE name)])
bindingPattern (BindTuple is) = do
(patterns, scopes) <- fmap unzip $ mapM bindingPattern is
return (TupP patterns, concat scopes)
bindingPattern (BindList is) = do
(patterns, scopes) <- fmap unzip $ mapM bindingPattern is
return (ListP patterns, concat scopes)
bindingPattern (BindConstr con is) = do
(patterns, scopes) <- fmap unzip $ mapM bindingPattern is
return (conP (mkConName con) patterns, concat scopes)
bindingPattern (BindRecord con fields wild) = do
let f (Ident field,b) =
do (p,s) <- bindingPattern b
return ((mkName field,p),s)
(patterns, scopes) <- fmap unzip $ mapM f fields
(patterns1, scopes1) <- if wild
then bindWildFields con $ map fst fields
else return ([],[])
return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1)
mkConName :: DataConstr -> Name
mkConName = mkName . conToStr
conToStr :: DataConstr -> String
conToStr (DCUnqualified (Ident x)) = x
conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [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 conName fields = do
fieldNames <- recordToFieldNames conName
let available n = nameBase n `notElem` map unIdent fields
let remainingFields = filter available fieldNames
let mkPat n = do
e <- newName (nameBase n)
return ((n,VarP e), (Ident (nameBase n), VarE e))
fmap unzip $ mapM mkPat 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 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 <- lookupValueName $ conToStr conStr
#if MIN_VERSION_template_haskell(2,11,0)
DataConI _ _ typeName <- reify conName
TyConI (DataD _ _ _ _ cons _) <- reify typeName
#else
DataConI _ _ typeName _ <- reify conName
TyConI (DataD _ _ _ cons _) <- reify typeName
#endif
[fields] <- return [fields | RecC name fields <- cons, name == conName]
return [fieldName | (fieldName, _, _) <- fields]
docToExp :: Scope -> Doc -> Q Exp
docToExp scope (DocTag name attrs attrsD cs) =
[| [ X.NodeElement (X.Element ($(liftName name)) $(mkAttrs scope attrs attrsD) $(docsToExp scope cs))
] |]
docToExp _ (DocContent (ContentRaw s)) = [| [ X.NodeContent (pack $(lift s)) ] |]
docToExp scope (DocContent (ContentVar d)) = [| [ X.NodeContent $(return $ derefToExp scope d) ] |]
docToExp scope (DocContent (ContentEmbed d)) = return $ derefToExp scope d
docToExp scope (DocForall list idents inside) = do
let list' = derefToExp scope list
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
mh <- [|F.concatMap|]
inside' <- docsToExp scope' inside
let lam = LamE [pat] inside'
return $ mh `AppE` lam `AppE` list'
docToExp scope (DocWith [] inside) = docsToExp scope inside
docToExp scope (DocWith ((deref, idents):dis) inside) = do
let deref' = derefToExp scope deref
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
inside' <- docToExp scope' (DocWith dis inside)
let lam = LamE [pat] inside'
return $ lam `AppE` deref'
docToExp scope (DocMaybe val idents inside mno) = do
let val' = derefToExp scope val
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
inside' <- docsToExp scope' inside
let inside'' = LamE [pat] inside'
ninside' <- case mno of
Nothing -> [| [] |]
Just no -> docsToExp scope no
[| maybe $(return ninside') $(return inside'') $(return val') |]
docToExp scope (DocCond conds final) = do
unit <- [| () |]
otherwise' <- [|otherwise|]
body <- fmap GuardedB $ mapM go $ map (first (derefToExp scope)) conds ++ [(otherwise', fromMaybe [] final)]
return $ CaseE unit [Match (TupP []) body []]
where
go (deref, inside) = do
inside' <- docsToExp scope inside
return (NormalG deref, inside')
docToExp scope (DocCase deref cases) = do
let exp_ = derefToExp scope deref
matches <- mapM toMatch cases
return $ CaseE exp_ matches
where
toMatch :: (Binding, [Doc]) -> Q Match
toMatch (idents, inside) = do
(pat, extraScope) <- bindingPattern idents
let scope' = extraScope ++ scope
insideExp <- docsToExp scope' inside
return $ Match pat (NormalB insideExp) []
mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp
mkAttrs _ [] [] = [| Map.empty |]
mkAttrs scope [] (deref:rest) = do
rest' <- mkAttrs scope [] rest
[| Map.union (toAttributes $(return $ derefToExp scope deref)) $(return rest') |]
mkAttrs scope ((mderef, name, value):rest) attrs = do
rest' <- mkAttrs scope rest attrs
this <- [| Map.insert $(liftName name) (T.concat $(fmap ListE $ mapM go value)) |]
let with = [| $(return this) $(return rest') |]
case mderef of
Nothing -> with
Just deref -> [| if $(return $ derefToExp scope deref) then $(with) else $(return rest') |]
where
go (ContentRaw s) = [| pack $(lift s) |]
go (ContentVar d) = return $ derefToExp scope d
go ContentEmbed{} = error "Cannot use embed interpolation in attribute value"
liftName :: String -> Q Exp
liftName s = do
X.Name local mns _ <- return $ fromString s
case mns of
Nothing -> [| X.Name (pack $(lift $ unpack local)) Nothing Nothing |]
Just ns -> [| X.Name (pack $(lift $ unpack local)) (Just $ pack $(lift $ unpack ns)) Nothing |]
xml :: QuasiQuoter
xml = QuasiQuoter { quoteExp = strToExp }
xmlFile :: FilePath -> Q Exp
xmlFile = strToExp . TL.unpack <=< qRunIO . readUtf8File
strToExp :: String -> Q Exp
strToExp s =
case parseDoc s of
Error e -> error e
Ok x -> docsToExp [] x
|
