{-# 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 -> [Pat] -> Pat
conP Name
name = Name -> [Type] -> [Pat] -> Pat
ConP Name
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 :: (Name, Text) -> Map Name Text
toAttributes (Name
k, Text
v) = Name -> Text -> Map Name Text
forall k a. k -> a -> Map k a
Map.singleton Name
k Text
v
instance ToAttributes (Text, Text) where
    toAttributes :: (Text, Text) -> Map Name Text
toAttributes (Text
k, Text
v) = Name -> Text -> Map Name Text
forall k a. k -> a -> Map k a
Map.singleton (String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
k) Text
v
instance ToAttributes (String, String) where
    toAttributes :: (String, String) -> Map Name Text
toAttributes (String
k, String
v) = Name -> Text -> Map Name Text
forall k a. k -> a -> Map k a
Map.singleton (String -> Name
forall a. IsString a => String -> a
fromString String
k) (String -> Text
pack String
v)
instance ToAttributes [(X.Name, Text)] where
    toAttributes :: [(Name, Text)] -> Map Name Text
toAttributes = [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
instance ToAttributes [(Text, Text)] where
    toAttributes :: [(Text, Text)] -> Map Name Text
toAttributes = [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Text)] -> Map Name Text)
-> ([(Text, Text)] -> [(Name, Text)])
-> [(Text, Text)]
-> Map Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> (Name, Text)) -> [(Text, Text)] -> [(Name, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Name) -> (Text, Text) -> (Name, Text)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack))
instance ToAttributes [(String, String)] where
    toAttributes :: [(String, String)] -> Map Name Text
toAttributes = [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Text)] -> Map Name Text)
-> ([(String, String)] -> [(Name, Text)])
-> [(String, String)]
-> Map Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> (Name, Text))
-> [(String, String)] -> [(Name, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
forall a. IsString a => String -> a
fromString (String -> Name)
-> (String -> Text) -> (String, String) -> (Name, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
pack)
instance ToAttributes (Map.Map X.Name Text) where
    toAttributes :: Map Name Text -> Map Name Text
toAttributes = Map Name Text -> Map Name Text
forall a. a -> a
id
instance ToAttributes (Map.Map Text Text) where
    toAttributes :: Map Text Text -> Map Name Text
toAttributes = (Text -> Name) -> Map Text Text -> Map Name Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (String -> Name
forall a. IsString a => String -> a
fromString (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack)
instance ToAttributes (Map.Map String String) where
    toAttributes :: Map String String -> Map Name Text
toAttributes = (String -> Name) -> Map String Text -> Map Name Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys String -> Name
forall a. IsString a => String -> a
fromString (Map String Text -> Map Name Text)
-> (Map String String -> Map String Text)
-> Map String String
-> Map Name Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> Map String String -> Map String Text
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map String -> Text
pack

docsToExp :: Scope -> [Doc] -> Q Exp
docsToExp :: Scope -> [Doc] -> Q Exp
docsToExp Scope
scope [Doc]
docs = [| concat $(([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Doc -> Q Exp) -> [Doc] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Scope -> Doc -> Q Exp
docToExp Scope
scope) [Doc]
docs) |]

unIdent :: Ident -> String
unIdent :: Ident -> String
unIdent (Ident String
s) = String
s

bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern :: Binding -> Q (Pat, Scope)
bindingPattern (BindAs i :: Ident
i@(Ident String
s) Binding
b) = do
    name <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s
    (pattern, scope) <- bindingPattern b
    return (AsP name pattern, (i, VarE name):scope)
bindingPattern (BindVar i :: Ident
i@(Ident String
s))
    | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"_" = (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
WildP, [])
    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
s = do
        (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP (Lit -> Pat) -> Lit -> Pat
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ String -> Integer
forall a. Read a => String -> a
read String
s, [])
    | Bool
otherwise = do
        name <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s
        return (VarP name, [(i, VarE name)])
bindingPattern (BindTuple [Binding]
is) = do
    (patterns, scopes) <- ([(Pat, Scope)] -> ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, Scope)] -> ([Pat], [Scope])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, Scope)] -> Q ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, Scope)) -> [Binding] -> Q [(Pat, Scope)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    return (TupP patterns, concat scopes)
bindingPattern (BindList [Binding]
is) = do
    (patterns, scopes) <- ([(Pat, Scope)] -> ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, Scope)] -> ([Pat], [Scope])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, Scope)] -> Q ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, Scope)) -> [Binding] -> Q [(Pat, Scope)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    return (ListP patterns, concat scopes)
bindingPattern (BindConstr DataConstr
con [Binding]
is) = do
    (patterns, scopes) <- ([(Pat, Scope)] -> ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, Scope)] -> ([Pat], [Scope])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, Scope)] -> Q ([Pat], [Scope]))
-> Q [(Pat, Scope)] -> Q ([Pat], [Scope])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, Scope)) -> [Binding] -> Q [(Pat, Scope)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> Q (Pat, Scope)
bindingPattern [Binding]
is
    return (conP (mkConName con) patterns, concat scopes)
bindingPattern (BindRecord DataConstr
con [(Ident, Binding)]
fields Bool
wild) = do
    let f :: (Ident, Binding) -> Q ((Name, Pat), Scope)
f (Ident String
field,Binding
b) =
           do (p,s) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
b
              return ((mkName field,p),s)
    (patterns, scopes) <- ([((Name, Pat), Scope)] -> ([(Name, Pat)], [Scope]))
-> Q [((Name, Pat), Scope)] -> Q ([(Name, Pat)], [Scope])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((Name, Pat), Scope)] -> ([(Name, Pat)], [Scope])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [((Name, Pat), Scope)] -> Q ([(Name, Pat)], [Scope]))
-> Q [((Name, Pat), Scope)] -> Q ([(Name, Pat)], [Scope])
forall a b. (a -> b) -> a -> b
$ ((Ident, Binding) -> Q ((Name, Pat), Scope))
-> [(Ident, Binding)] -> Q [((Name, Pat), Scope)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Ident, Binding) -> Q ((Name, Pat), Scope)
f [(Ident, Binding)]
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 :: DataConstr -> Name
mkConName = String -> Name
mkName (String -> Name) -> (DataConstr -> String) -> DataConstr -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataConstr -> String
conToStr

conToStr :: DataConstr -> String
conToStr :: DataConstr -> String
conToStr (DCUnqualified (Ident String
x)) = String
x
conToStr (DCQualified (Module [String]
xs) (Ident String
x)) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
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 :: DataConstr -> [Ident] -> Q ([(Name, Pat)], Scope)
bindWildFields DataConstr
conName [Ident]
fields = do
  fieldNames <- DataConstr -> Q [Name]
recordToFieldNames DataConstr
conName
  let available Name
n     = Name -> String
nameBase Name
n String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Ident -> String) -> [Ident] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
unIdent [Ident]
fields
  let remainingFields = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
available [Name]
fieldNames
  let mkPat Name
n = do
        e <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
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 :: DataConstr -> Q [Name]
recordToFieldNames DataConstr
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                <- String -> Q (Maybe Name)
lookupValueName (String -> Q (Maybe Name)) -> String -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ DataConstr -> String
conToStr DataConstr
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 -> Doc -> Q Exp
docToExp Scope
scope (DocTag String
name [(Maybe Deref, String, [Content])]
attrs [Deref]
attrsD [Doc]
cs) =
    [| [ X.NodeElement (X.Element ($(String -> Q Exp
liftName String
name)) $(Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp
mkAttrs Scope
scope [(Maybe Deref, String, [Content])]
attrs [Deref]
attrsD) $(Scope -> [Doc] -> Q Exp
docsToExp Scope
scope [Doc]
cs))
       ] |]
docToExp Scope
_ (DocContent (ContentRaw String
s)) = [| [ X.NodeContent (pack $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
s)) ] |]
docToExp Scope
scope (DocContent (ContentVar Deref
d)) = [| [ X.NodeContent $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Scope -> Deref -> Exp
derefToExp Scope
scope Deref
d) ] |]
docToExp Scope
scope (DocContent (ContentEmbed Deref
d)) = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Scope -> Deref -> Exp
derefToExp Scope
scope Deref
d
docToExp Scope
scope (DocForall Deref
list Binding
idents [Doc]
inside) = do
    let list' :: Exp
list' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
list
    (pat, extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
    mh <- [|F.concatMap|]
    inside' <- docsToExp scope' inside
    let lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    return $ mh `AppE` lam `AppE` list'
docToExp Scope
scope (DocWith [] [Doc]
inside) = Scope -> [Doc] -> Q Exp
docsToExp Scope
scope [Doc]
inside
docToExp Scope
scope (DocWith ((Deref
deref, Binding
idents):[(Deref, Binding)]
dis) [Doc]
inside) = do
    let deref' :: Exp
deref' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
deref
    (pat, extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
    inside' <- docToExp scope' (DocWith dis inside)
    let lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    return $ lam `AppE` deref'
docToExp Scope
scope (DocMaybe Deref
val Binding
idents [Doc]
inside Maybe [Doc]
mno) = do
    let val' :: Exp
val' = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
val
    (pat, extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
    inside' <- docsToExp scope' inside
    let inside'' = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    ninside' <- case mno of
                    Maybe [Doc]
Nothing -> [| [] |]
                    Just [Doc]
no -> Scope -> [Doc] -> Q Exp
docsToExp Scope
scope [Doc]
no
    [| maybe $(return ninside') $(return inside'') $(return val') |]
docToExp Scope
scope (DocCond [(Deref, [Doc])]
conds Maybe [Doc]
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 :: (Exp, [Doc]) -> Q (Guard, Exp)
go (Exp
deref, [Doc]
inside) = do
        inside' <- Scope -> [Doc] -> Q Exp
docsToExp Scope
scope [Doc]
inside
        return (NormalG deref, inside')
docToExp Scope
scope (DocCase Deref
deref [(Binding, [Doc])]
cases) = do
    let exp_ :: Exp
exp_ = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
deref
    matches <- ((Binding, [Doc]) -> Q Match) -> [(Binding, [Doc])] -> Q [Match]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Binding, [Doc]) -> Q Match
toMatch [(Binding, [Doc])]
cases
    return $ CaseE exp_ matches
  where
    toMatch :: (Binding, [Doc]) -> Q Match
    toMatch :: (Binding, [Doc]) -> Q Match
toMatch (Binding
idents, [Doc]
inside) = do
        (pat, extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
        let scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
        insideExp <- docsToExp scope' inside
        return $ Match pat (NormalB insideExp) []

mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp
mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp
mkAttrs Scope
_ [] [] = [| Map.empty |]
mkAttrs Scope
scope [] (Deref
deref:[Deref]
rest) = do
    rest' <- Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp
mkAttrs Scope
scope [] [Deref]
rest
    [| Map.union (toAttributes $(return $ derefToExp scope deref)) $(return rest') |]
mkAttrs Scope
scope ((Maybe Deref
mderef, String
name, [Content]
value):[(Maybe Deref, String, [Content])]
rest) [Deref]
attrs = do
    rest' <- Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp
mkAttrs Scope
scope [(Maybe Deref, String, [Content])]
rest [Deref]
attrs
    this <- [| Map.insert $(liftName name) (T.concat $(fmap ListE $ mapM go value)) |]
    let with = [| $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
this) $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
rest') |]
    case mderef of
        Maybe Deref
Nothing -> Q Exp
with
        Just Deref
deref -> [| if $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Scope -> Deref -> Exp
derefToExp Scope
scope Deref
deref) then $(Q Exp
with) else $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
rest') |]
  where
    go :: Content -> m Exp
go (ContentRaw String
s) = [| pack $(String -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
s) |]
    go (ContentVar Deref
d) = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Scope -> Deref -> Exp
derefToExp Scope
scope Deref
d
    go ContentEmbed{} = String -> m Exp
forall a. HasCallStack => String -> a
error String
"Cannot use embed interpolation in attribute value"

liftName :: String -> Q Exp
liftName :: String -> Q Exp
liftName String
s = do
    X.Name local mns _ <- Name -> Q Name
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Q Name) -> Name -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Name
forall a. IsString a => String -> a
fromString String
s
    case mns of
        Maybe Text
Nothing -> [| X.Name (pack $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
local)) Nothing Nothing |]
        Just Text
ns -> [| X.Name (pack $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
local)) (Just $ pack $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
ns)) Nothing |]

xml :: QuasiQuoter
xml :: QuasiQuoter
xml = QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
strToExp }

xmlFile :: FilePath -> Q Exp
xmlFile :: String -> Q Exp
xmlFile = String -> Q Exp
strToExp (String -> Q Exp) -> (Text -> String) -> Text -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack (Text -> Q Exp) -> (String -> Q Text) -> String -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO Text -> Q Text
forall a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> (String -> IO Text) -> String -> Q Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
readUtf8File

strToExp :: String -> Q Exp
strToExp :: String -> Q Exp
strToExp String
s =
    case String -> Result [Doc]
parseDoc String
s of
        Error String
e -> String -> Q Exp
forall a. HasCallStack => String -> a
error String
e
        Ok [Doc]
x -> Scope -> [Doc] -> Q Exp
docsToExp [] [Doc]
x