    {-# 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