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