1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# OPTIONS_GHC -fno-warn-missing-fields #-}
5module Text.Hamlet.XML
6    ( xml
7    , xmlFile
8    , ToAttributes (..)
9    ) where
10
11#if MIN_VERSION_template_haskell(2,9,0)
12import Language.Haskell.TH.Syntax hiding (Module)
13#else
14import Language.Haskell.TH.Syntax
15#endif
16import Language.Haskell.TH.Quote
17import Data.Char (isDigit)
18import qualified Data.Text.Lazy as TL
19import Control.Monad ((<=<))
20import Text.Hamlet.XMLParse
21import Text.Shakespeare.Base (readUtf8File, derefToExp, Scope, Deref, Ident (Ident))
22import Data.Text (Text, pack, unpack)
23import qualified Data.Text as T
24import qualified Text.XML as X
25import Data.String (fromString)
26import qualified Data.Foldable as F
27import Data.Maybe (fromMaybe)
28import qualified Data.Map as Map
29import Control.Arrow (first, (***))
30import Data.List (intercalate)
31
32-- | Convert some value to a list of attribute pairs.
33class ToAttributes a where
34    toAttributes :: a -> Map.Map X.Name Text
35instance ToAttributes (X.Name, Text) where
36    toAttributes (k, v) = Map.singleton k v
37instance ToAttributes (Text, Text) where
38    toAttributes (k, v) = Map.singleton (fromString $ unpack k) v
39instance ToAttributes (String, String) where
40    toAttributes (k, v) = Map.singleton (fromString k) (pack v)
41instance ToAttributes [(X.Name, Text)] where
42    toAttributes = Map.fromList
43instance ToAttributes [(Text, Text)] where
44    toAttributes = Map.fromList . map (first (fromString . unpack))
45instance ToAttributes [(String, String)] where
46    toAttributes = Map.fromList . map (fromString *** pack)
47instance ToAttributes (Map.Map X.Name Text) where
48    toAttributes = id
49instance ToAttributes (Map.Map Text Text) where
50    toAttributes = Map.mapKeys (fromString . unpack)
51instance ToAttributes (Map.Map String String) where
52    toAttributes = Map.mapKeys fromString . Map.map pack
53
54docsToExp :: Scope -> [Doc] -> Q Exp
55docsToExp scope docs = [| concat $(fmap ListE $ mapM (docToExp scope) docs) |]
56
57unIdent :: Ident -> String
58unIdent (Ident s) = s
59
60bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
61bindingPattern (BindAs i@(Ident s) b) = do
62    name <- newName s
63    (pattern, scope) <- bindingPattern b
64    return (AsP name pattern, (i, VarE name):scope)
65bindingPattern (BindVar i@(Ident s))
66    | s == "_" = return (WildP, [])
67    | all isDigit s = do
68        return (LitP $ IntegerL $ read s, [])
69    | otherwise = do
70        name <- newName s
71        return (VarP name, [(i, VarE name)])
72bindingPattern (BindTuple is) = do
73    (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
74    return (TupP patterns, concat scopes)
75bindingPattern (BindList is) = do
76    (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
77    return (ListP patterns, concat scopes)
78bindingPattern (BindConstr con is) = do
79    (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
80    return (ConP (mkConName con) patterns, concat scopes)
81bindingPattern (BindRecord con fields wild) = do
82    let f (Ident field,b) =
83           do (p,s) <- bindingPattern b
84              return ((mkName field,p),s)
85    (patterns, scopes) <- fmap unzip $ mapM f fields
86    (patterns1, scopes1) <- if wild
87       then bindWildFields con $ map fst fields
88       else return ([],[])
89    return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1)
90
91mkConName :: DataConstr -> Name
92mkConName = mkName . conToStr
93
94conToStr :: DataConstr -> String
95conToStr (DCUnqualified (Ident x)) = x
96conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x]
97
98-- Wildcards bind all of the unbound fields to variables whose name
99-- matches the field name.
100--
101-- For example: data R = C { f1, f2 :: Int }
102-- C {..}           is equivalent to   C {f1=f1, f2=f2}
103-- C {f1 = a, ..}   is equivalent to   C {f1=a,  f2=f2}
104-- C {f2 = a, ..}   is equivalent to   C {f1=f1, f2=a}
105bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
106bindWildFields conName fields = do
107  fieldNames <- recordToFieldNames conName
108  let available n     = nameBase n `notElem` map unIdent fields
109  let remainingFields = filter available fieldNames
110  let mkPat n = do
111        e <- newName (nameBase n)
112        return ((n,VarP e), (Ident (nameBase n), VarE e))
113  fmap unzip $ mapM mkPat remainingFields
114
115-- Important note! reify will fail if the record type is defined in the
116-- same module as the reify is used. This means quasi-quoted Hamlet
117-- literals will not be able to use wildcards to match record types
118-- defined in the same module.
119recordToFieldNames :: DataConstr -> Q [Name]
120recordToFieldNames conStr = do
121  -- use 'lookupValueName' instead of just using 'mkName' so we reify the
122  -- data constructor and not the type constructor if their names match.
123  Just conName                <- lookupValueName $ conToStr conStr
124#if MIN_VERSION_template_haskell(2,11,0)
125  DataConI _ _ typeName         <- reify conName
126  TyConI (DataD _ _ _ _ cons _) <- reify typeName
127#else
128  DataConI _ _ typeName _     <- reify conName
129  TyConI (DataD _ _ _ cons _) <- reify typeName
130#endif
131  [fields] <- return [fields | RecC name fields <- cons, name == conName]
132  return [fieldName | (fieldName, _, _) <- fields]
133
134docToExp :: Scope -> Doc -> Q Exp
135docToExp scope (DocTag name attrs attrsD cs) =
136    [| [ X.NodeElement (X.Element ($(liftName name)) $(mkAttrs scope attrs attrsD) $(docsToExp scope cs))
137       ] |]
138docToExp _ (DocContent (ContentRaw s)) = [| [ X.NodeContent (pack $(lift s)) ] |]
139docToExp scope (DocContent (ContentVar d)) = [| [ X.NodeContent $(return $ derefToExp scope d) ] |]
140docToExp scope (DocContent (ContentEmbed d)) = return $ derefToExp scope d
141docToExp scope (DocForall list idents inside) = do
142    let list' = derefToExp scope list
143    (pat, extraScope) <- bindingPattern idents
144    let scope' = extraScope ++ scope
145    mh <- [|F.concatMap|]
146    inside' <- docsToExp scope' inside
147    let lam = LamE [pat] inside'
148    return $ mh `AppE` lam `AppE` list'
149docToExp scope (DocWith [] inside) = docsToExp scope inside
150docToExp scope (DocWith ((deref, idents):dis) inside) = do
151    let deref' = derefToExp scope deref
152    (pat, extraScope) <- bindingPattern idents
153    let scope' = extraScope ++ scope
154    inside' <- docToExp scope' (DocWith dis inside)
155    let lam = LamE [pat] inside'
156    return $ lam `AppE` deref'
157docToExp scope (DocMaybe val idents inside mno) = do
158    let val' = derefToExp scope val
159    (pat, extraScope) <- bindingPattern idents
160    let scope' = extraScope ++ scope
161    inside' <- docsToExp scope' inside
162    let inside'' = LamE [pat] inside'
163    ninside' <- case mno of
164                    Nothing -> [| [] |]
165                    Just no -> docsToExp scope no
166    [| maybe $(return ninside') $(return inside'') $(return val') |]
167docToExp scope (DocCond conds final) = do
168    unit <- [| () |]
169    otherwise' <- [|otherwise|]
170    body <- fmap GuardedB $ mapM go $ map (first (derefToExp scope)) conds ++ [(otherwise', fromMaybe [] final)]
171    return $ CaseE unit [Match (TupP []) body []]
172  where
173    go (deref, inside) = do
174        inside' <- docsToExp scope inside
175        return (NormalG deref, inside')
176docToExp scope (DocCase deref cases) = do
177    let exp_ = derefToExp scope deref
178    matches <- mapM toMatch cases
179    return $ CaseE exp_ matches
180  where
181    toMatch :: (Binding, [Doc]) -> Q Match
182    toMatch (idents, inside) = do
183        (pat, extraScope) <- bindingPattern idents
184        let scope' = extraScope ++ scope
185        insideExp <- docsToExp scope' inside
186        return $ Match pat (NormalB insideExp) []
187
188mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp
189mkAttrs _ [] [] = [| Map.empty |]
190mkAttrs scope [] (deref:rest) = do
191    rest' <- mkAttrs scope [] rest
192    [| Map.union (toAttributes $(return $ derefToExp scope deref)) $(return rest') |]
193mkAttrs scope ((mderef, name, value):rest) attrs = do
194    rest' <- mkAttrs scope rest attrs
195    this <- [| Map.insert $(liftName name) (T.concat $(fmap ListE $ mapM go value)) |]
196    let with = [| $(return this) $(return rest') |]
197    case mderef of
198        Nothing -> with
199        Just deref -> [| if $(return $ derefToExp scope deref) then $(with) else $(return rest') |]
200  where
201    go (ContentRaw s) = [| pack $(lift s) |]
202    go (ContentVar d) = return $ derefToExp scope d
203    go ContentEmbed{} = error "Cannot use embed interpolation in attribute value"
204
205liftName :: String -> Q Exp
206liftName s = do
207    X.Name local mns _ <- return $ fromString s
208    case mns of
209        Nothing -> [| X.Name (pack $(lift $ unpack local)) Nothing Nothing |]
210        Just ns -> [| X.Name (pack $(lift $ unpack local)) (Just $ pack $(lift $ unpack ns)) Nothing |]
211
212xml :: QuasiQuoter
213xml = QuasiQuoter { quoteExp = strToExp }
214
215xmlFile :: FilePath -> Q Exp
216xmlFile = strToExp . TL.unpack <=< qRunIO . readUtf8File
217
218strToExp :: String -> Q Exp
219strToExp s =
220    case parseDoc s of
221        Error e -> error e
222        Ok x -> docsToExp [] x
223
224