From b53713fbb4f3bb6bdd25b07afcaed4940b32dfa8 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 18 Dec 2013 03:32:44 +0000
Subject: [PATCH] remove TH

---
 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..4e830bd 100644
--- a/Text/Hamlet/XML.hs
+++ b/Text/Hamlet/XML.hs
@@ -1,9 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-}
 module Text.Hamlet.XML
-    ( xml
-    , xmlFile
-    ) where
+    () where
 
 import Language.Haskell.TH.Syntax
 import Language.Haskell.TH.Quote
@@ -19,80 +17,3 @@ 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.5.1