108 lines
4 KiB
Diff
108 lines
4 KiB
Diff
From 3e988dec5ea248611d07d59914e3eb131dc6a165 Mon Sep 17 00:00:00 2001
|
|
From: Joey Hess <joey@kitenet.net>
|
|
Date: Thu, 18 Apr 2013 17:44:46 -0400
|
|
Subject: [PATCH] remove TH code
|
|
|
|
---
|
|
Text/Hamlet/XML.hs | 81 +-----------------------------------------------------
|
|
1 file changed, 1 insertion(+), 80 deletions(-)
|
|
|
|
diff --git a/Text/Hamlet/XML.hs b/Text/Hamlet/XML.hs
|
|
index f587410..bf8ce9e 100644
|
|
--- a/Text/Hamlet/XML.hs
|
|
+++ b/Text/Hamlet/XML.hs
|
|
@@ -1,8 +1,7 @@
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
|
|
module Text.Hamlet.XML
|
|
- ( xml
|
|
- , xmlFile
|
|
+ (
|
|
) where
|
|
|
|
import Language.Haskell.TH.Syntax
|
|
@@ -18,81 +17,3 @@ import Data.String (fromString)
|
|
import qualified Data.Foldable as F
|
|
import Data.Maybe (fromMaybe)
|
|
import qualified Data.Map as Map
|
|
-
|
|
-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
|
|
-
|
|
-docsToExp :: Scope -> [Doc] -> Q Exp
|
|
-docsToExp scope docs = [| concat $(fmap ListE $ mapM (docToExp scope) docs) |]
|
|
-
|
|
-docToExp :: Scope -> Doc -> Q Exp
|
|
-docToExp scope (DocTag name attrs cs) =
|
|
- [| [ X.NodeElement (X.Element ($(liftName name)) $(mkAttrs scope attrs) $(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 deref ident@(Ident ident') inside) = do
|
|
- let list' = derefToExp scope deref
|
|
- name <- newName ident'
|
|
- let scope' = (ident, VarE name) : scope
|
|
- inside' <- docsToExp scope' inside
|
|
- let lam = LamE [VarP name] inside'
|
|
- [| F.concatMap $(return lam) $(return list') |]
|
|
-docToExp scope (DocWith [] inside) = docsToExp scope inside
|
|
-docToExp scope (DocWith ((deref, ident@(Ident name)):dis) inside) = do
|
|
- let deref' = derefToExp scope deref
|
|
- name' <- newName name
|
|
- let scope' = (ident, VarE name') : scope
|
|
- inside' <- docToExp scope' (DocWith dis inside)
|
|
- let lam = LamE [VarP name'] inside'
|
|
- return $ lam `AppE` deref'
|
|
-docToExp scope (DocMaybe deref ident@(Ident name) just nothing) = do
|
|
- let deref' = derefToExp scope deref
|
|
- name' <- newName name
|
|
- let scope' = (ident, VarE name') : scope
|
|
- inside' <- docsToExp scope' just
|
|
- let inside'' = LamE [VarP name'] inside'
|
|
- nothing' <-
|
|
- case nothing of
|
|
- Nothing -> [| [] |]
|
|
- Just n -> docsToExp scope n
|
|
- [| maybe $(return nothing') $(return inside'') $(return deref') |]
|
|
-docToExp scope (DocCond conds final) = do
|
|
- unit <- [| () |]
|
|
- body <- fmap GuardedB $ mapM go $ conds ++ [(DerefIdent $ Ident "otherwise", fromMaybe [] final)]
|
|
- return $ CaseE unit [Match (TupP []) body []]
|
|
- where
|
|
- go (deref, inside) = do
|
|
- inside' <- docsToExp scope inside
|
|
- return (NormalG $ derefToExp scope deref, inside')
|
|
-
|
|
-mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> Q Exp
|
|
-mkAttrs _ [] = [| Map.empty |]
|
|
-mkAttrs scope ((mderef, name, value):rest) = do
|
|
- rest' <- mkAttrs scope rest
|
|
- 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 |]
|
|
--
|
|
1.8.2.rc3
|
|
|