{-# 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
name <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s
    (Pat
pattern, Scope
scope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
b
    (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat -> Pat
AsP Name
name Pat
pattern, (Ident
i, Name -> Exp
VarE Name
name)(Ident, Exp) -> Scope -> Scope
forall a. a -> [a] -> [a]
:Scope
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
name <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s
        (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat
VarP Name
name, [(Ident
i, Name -> Exp
VarE Name
name)])
bindingPattern (BindTuple [Binding]
is) = do
    ([Pat]
patterns, [Scope]
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
    (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
TupP [Pat]
patterns, [Scope] -> Scope
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes)
bindingPattern (BindList [Binding]
is) = do
    ([Pat]
patterns, [Scope]
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
    (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
ListP [Pat]
patterns, [Scope] -> Scope
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes)
bindingPattern (BindConstr DataConstr
con [Binding]
is) = do
    ([Pat]
patterns, [Scope]
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
    (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
conP (DataConstr -> Name
mkConName DataConstr
con) [Pat]
patterns, [Scope] -> Scope
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
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 (Pat
p,Scope
s) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
b
              ((Name, Pat), Scope) -> Q ((Name, Pat), Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> Name
mkName String
field,Pat
p),Scope
s)
    ([(Name, Pat)]
patterns, [Scope]
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
    ([(Name, Pat)]
patterns1, Scope
scopes1) <- if Bool
wild
       then DataConstr -> [Ident] -> Q ([(Name, Pat)], Scope)
bindWildFields DataConstr
con ([Ident] -> Q ([(Name, Pat)], Scope))
-> [Ident] -> Q ([(Name, Pat)], Scope)
forall a b. (a -> b) -> a -> b
$ ((Ident, Binding) -> Ident) -> [(Ident, Binding)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Binding) -> Ident
forall a b. (a, b) -> a
fst [(Ident, Binding)]
fields
       else ([(Name, Pat)], Scope) -> Q ([(Name, Pat)], Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[])
    (Pat, Scope) -> Q (Pat, Scope)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [(Name, Pat)] -> Pat
RecP (DataConstr -> Name
mkConName DataConstr
con) ([(Name, Pat)]
patterns[(Name, Pat)] -> [(Name, Pat)] -> [(Name, Pat)]
forall a. [a] -> [a] -> [a]
++[(Name, Pat)]
patterns1), [Scope] -> Scope
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Scope]
scopes Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
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
  [Name]
fieldNames <- DataConstr -> Q [Name]
recordToFieldNames DataConstr
conName
  let available :: Name -> Bool
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]
remainingFields = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
available [Name]
fieldNames
  let mkPat :: Name -> m ((Name, Pat), (Ident, Exp))
mkPat Name
n = do
        Name
e <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
n)
        ((Name, Pat), (Ident, Exp)) -> m ((Name, Pat), (Ident, Exp))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n,Name -> Pat
VarP Name
e), (String -> Ident
Ident (Name -> String
nameBase Name
n), Name -> Exp
VarE Name
e))
  ([((Name, Pat), (Ident, Exp))] -> ([(Name, Pat)], Scope))
-> Q [((Name, Pat), (Ident, Exp))] -> 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), (Ident, Exp))] -> ([(Name, Pat)], Scope)
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [((Name, Pat), (Ident, Exp))] -> Q ([(Name, Pat)], Scope))
-> Q [((Name, Pat), (Ident, Exp))] -> Q ([(Name, Pat)], Scope)
forall a b. (a -> b) -> a -> b
$ (Name -> Q ((Name, Pat), (Ident, Exp)))
-> [Name] -> Q [((Name, Pat), (Ident, 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 Name -> Q ((Name, Pat), (Ident, Exp))
forall {m :: * -> *}.
Quote m =>
Name -> m ((Name, Pat), (Ident, Exp))
mkPat [Name]
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 Name
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 Name
_ Type
_ Name
typeName         <- Name -> Q Info
reify Name
conName
  TyConI (DataD [Type]
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con]
cons [DerivClause]
_) <- Name -> Q Info
reify Name
typeName
#else
  DataConI _ _ typeName _     <- reify conName
  TyConI (DataD _ _ _ cons _) <- reify typeName
#endif
  [[VarBangType]
fields] <- [[VarBangType]] -> Q [[VarBangType]]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [[VarBangType]
fields | RecC Name
name [VarBangType]
fields <- [Con]
cons, Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
conName]
  [Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
fieldName | (Name
fieldName, Bang
_, Type
_) <- [VarBangType]
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
pat, Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' :: Scope
scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
    Exp
mh <- [|F.concatMap|]
    Exp
inside' <- Scope -> [Doc] -> Q Exp
docsToExp Scope
scope' [Doc]
inside
    let lam :: Exp
lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    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
$ Exp
mh Exp -> Exp -> Exp
`AppE` Exp
lam Exp -> Exp -> Exp
`AppE` Exp
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
pat, Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' :: Scope
scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
    Exp
inside' <- Scope -> Doc -> Q Exp
docToExp Scope
scope' ([(Deref, Binding)] -> [Doc] -> Doc
DocWith [(Deref, Binding)]
dis [Doc]
inside)
    let lam :: Exp
lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    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
$ Exp
lam Exp -> Exp -> Exp
`AppE` Exp
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
pat, Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
    let scope' :: Scope
scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
    Exp
inside' <- Scope -> [Doc] -> Q Exp
docsToExp Scope
scope' [Doc]
inside
    let inside'' :: Exp
inside'' = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
    Exp
ninside' <- case Maybe [Doc]
mno of
                    Maybe [Doc]
Nothing -> [| [] |]
                    Just [Doc]
no -> Scope -> [Doc] -> Q Exp
docsToExp Scope
scope [Doc]
no
    [| maybe $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
ninside') $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
inside'') $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
val') |]
docToExp Scope
scope (DocCond [(Deref, [Doc])]
conds Maybe [Doc]
final) = do
    Exp
unit <- [| () |]
    Exp
otherwise' <- [|otherwise|]
    Body
body <- ([(Guard, Exp)] -> Body) -> Q [(Guard, Exp)] -> Q Body
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Guard, Exp)] -> Body
GuardedB (Q [(Guard, Exp)] -> Q Body) -> Q [(Guard, Exp)] -> Q Body
forall a b. (a -> b) -> a -> b
$ ((Exp, [Doc]) -> Q (Guard, Exp))
-> [(Exp, [Doc])] -> Q [(Guard, 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 (Exp, [Doc]) -> Q (Guard, Exp)
go ([(Exp, [Doc])] -> Q [(Guard, Exp)])
-> [(Exp, [Doc])] -> Q [(Guard, Exp)]
forall a b. (a -> b) -> a -> b
$ ((Deref, [Doc]) -> (Exp, [Doc]))
-> [(Deref, [Doc])] -> [(Exp, [Doc])]
forall a b. (a -> b) -> [a] -> [b]
map ((Deref -> Exp) -> (Deref, [Doc]) -> (Exp, [Doc])
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 (Scope -> Deref -> Exp
derefToExp Scope
scope)) [(Deref, [Doc])]
conds [(Exp, [Doc])] -> [(Exp, [Doc])] -> [(Exp, [Doc])]
forall a. [a] -> [a] -> [a]
++ [(Exp
otherwise', [Doc] -> Maybe [Doc] -> [Doc]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Doc]
final)]
    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
$ Exp -> [Match] -> Exp
CaseE Exp
unit [Pat -> Body -> [Dec] -> Match
Match ([Pat] -> Pat
TupP []) Body
body []]
  where
    go :: (Exp, [Doc]) -> Q (Guard, Exp)
go (Exp
deref, [Doc]
inside) = do
        Exp
inside' <- Scope -> [Doc] -> Q Exp
docsToExp Scope
scope [Doc]
inside
        (Guard, Exp) -> Q (Guard, Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Guard
NormalG Exp
deref, Exp
inside')
docToExp Scope
scope (DocCase Deref
deref [(Binding, [Doc])]
cases) = do
    let exp_ :: Exp
exp_ = Scope -> Deref -> Exp
derefToExp Scope
scope Deref
deref
    [Match]
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
    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
$ Exp -> [Match] -> Exp
CaseE Exp
exp_ [Match]
matches
  where
    toMatch :: (Binding, [Doc]) -> Q Match
    toMatch :: (Binding, [Doc]) -> Q Match
toMatch (Binding
idents, [Doc]
inside) = do
        (Pat
pat, Scope
extraScope) <- Binding -> Q (Pat, Scope)
bindingPattern Binding
idents
        let scope' :: Scope
scope' = Scope
extraScope Scope -> Scope -> Scope
forall a. [a] -> [a] -> [a]
++ Scope
scope
        Exp
insideExp <- Scope -> [Doc] -> Q Exp
docsToExp Scope
scope' [Doc]
inside
        Match -> Q Match
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
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
    Exp
rest' <- Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp
mkAttrs Scope
scope [] [Deref]
rest
    [| Map.union (toAttributes $(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)) $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
rest') |]
mkAttrs Scope
scope ((Maybe Deref
mderef, String
name, [Content]
value):[(Maybe Deref, String, [Content])]
rest) [Deref]
attrs = do
    Exp
rest' <- Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp
mkAttrs Scope
scope [(Maybe Deref, String, [Content])]
rest [Deref]
attrs
    Exp
this <- [| Map.insert $(String -> Q Exp
liftName String
name) (T.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
$ (Content -> Q Exp) -> [Content] -> 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 Content -> Q Exp
forall {m :: * -> *}. Quote m => Content -> m Exp
go [Content]
value)) |]
    let with :: Q Exp
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 Maybe Deref
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 Text
local Maybe Text
mns Maybe Text
_ <- 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 Maybe Text
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