module Language.Haskell.HSX.Transform (
transform
, transformExp
) where
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Build
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad (ap)
import Data.List (union)
import Debug.Trace (trace)
newtype HsxM a = MkHsxM (HsxState -> (a, HsxState))
instance Applicative HsxM where
pure = return
(<*>) = ap
instance Monad HsxM where
return x = MkHsxM (\s -> (x,s))
(MkHsxM f) >>= k = MkHsxM (\s -> let (a, s') = f s
(MkHsxM f') = k a
in f' s')
getHsxState :: HsxM HsxState
getHsxState = MkHsxM (\s -> (s, s))
setHsxState :: HsxState -> HsxM ()
setHsxState s = MkHsxM (\_ -> ((),s))
instance Functor HsxM where
fmap f hma = do a <- hma
return $ f a
type HsxState = (Bool, Bool)
initHsxState :: HsxState
initHsxState = (False, False)
setHarpTransformed :: HsxM ()
setHarpTransformed =
do (_,x) <- getHsxState
setHsxState (True,x)
setXmlTransformed :: HsxM ()
setXmlTransformed =
do (h,_) <- getHsxState
setHsxState (h,True)
runHsxM :: HsxM a -> (a, (Bool, Bool))
runHsxM (MkHsxM f) = f initHsxState
transform :: Module () -> Module ()
transform (Module l m pragmas is decls) =
let (decls', (harp, hsx)) = runHsxM $ mapM transformDecl decls
imps1 = if harp
then (:) $ ImportDecl () match_mod True False False Nothing
(Just match_qual_mod)
Nothing
else id
imps2 = id
in Module l m pragmas (imps1 $ imps2 is) decls'
transformDecl :: Decl () -> HsxM (Decl ())
transformDecl d = case d of
PatBind l pat rhs decls -> do
let ([pat'], rnpss) = unzip $ renameIrrPats [pat]
([pat''], attrGuards, guards, decls'') <- transformPatterns [pat']
rhs' <- mkRhs (attrGuards ++ guards) (concat rnpss) rhs
decls' <- case decls of
Nothing -> return Nothing
Just (BDecls l ds)
-> do ds' <- transformLetDecls ds
return $ Just $ BDecls l $ decls'' ++ ds'
_ -> error "Cannot bind implicit parameters in the \
\ \'where\' clause of a function using regular patterns."
return $ PatBind l pat'' rhs' decls'
FunBind l ms -> fmap (FunBind l) $ mapM transformMatch ms
InstDecl l mo irule Nothing -> pure d
InstDecl l mo irule (Just idecls) ->
fmap (InstDecl l mo irule . Just) $ mapM transformInstDecl idecls
ClassDecl l c dh fd Nothing -> pure d
ClassDecl l c dh fd (Just cdecls) ->
fmap (ClassDecl l c dh fd . Just) $ mapM transformClassDecl cdecls
SpliceDecl l e ->
fmap (SpliceDecl l) $ transformExpM e
_ -> return d
transformInstDecl :: InstDecl () -> HsxM (InstDecl ())
transformInstDecl d = case d of
InsDecl l decl -> fmap (InsDecl l) $ transformDecl decl
_ -> return d
transformClassDecl :: ClassDecl () -> HsxM (ClassDecl ())
transformClassDecl d = case d of
ClsDecl l decl -> fmap (ClsDecl l) $ transformDecl decl
_ -> return d
transformMatch :: Match () -> HsxM (Match ())
transformMatch (Match l name pats rhs decls) = do
let (pats', rnpss) = unzip $ renameIrrPats pats
(pats'', attrGuards, guards, decls'') <- transformPatterns pats'
rhs' <- mkRhs (attrGuards ++ guards) (concat rnpss) rhs
decls' <- case decls of
Nothing -> return Nothing
Just (BDecls l ds)
-> do ds' <- transformLetDecls ds
return $ Just $ BDecls l $ decls'' ++ ds'
_ -> error "Cannot bind implicit parameters in the \
\ \'where\' clause of a function using regular patterns."
return $ Match l name pats'' rhs' decls'
mkRhs :: [Guard ()] -> [(Name (), Pat ())] -> Rhs () -> HsxM (Rhs ())
mkRhs guards rnps (UnGuardedRhs l rhs) = do
rhs' <- transformExpM $ addLetDecls rnps rhs
case guards of
[] -> return $ UnGuardedRhs l rhs'
_ -> return $ GuardedRhss l [GuardedRhs l (map mkStmtGuard guards) rhs']
mkRhs guards rnps (GuardedRhss l gdrhss) = fmap (GuardedRhss l) $ mapM (mkGRhs guards rnps) gdrhss
where mkGRhs :: [Guard ()] -> [(Name (), Pat ())] -> GuardedRhs () -> HsxM (GuardedRhs ())
mkGRhs gs rnps (GuardedRhs l oldgs rhs) = do
rhs' <- transformExpM $ addLetDecls rnps rhs
oldgs' <- fmap concat $ mapM (transformStmt GuardStmt) oldgs
return $ GuardedRhs l ((map mkStmtGuard gs) ++ oldgs') rhs'
addLetDecls :: [(Name (), Pat ())] -> Exp () -> Exp ()
addLetDecls [] e = e
addLetDecls rnps e =
letE (map mkDecl rnps) e
mkDecl :: (Name (), Pat ()) -> Decl ()
mkDecl (n,p) = patBind p (var n)
transformExp :: Exp () -> Exp ()
transformExp e =
let (e', _) = runHsxM $ transformExpM e
in e'
transformExpM :: Exp () -> HsxM (Exp ())
transformExpM e = case e of
XTag _ name attrs mattr cs -> do
setXmlTransformed
let
as = map mkAttr attrs
cs' <- mapM transformChild cs
return $ paren $ metaGenElement name as mattr cs'
XETag _ name attrs mattr -> do
setXmlTransformed
let
as = map mkAttr attrs
return $ paren $ metaGenEElement name as mattr
XChildTag _ cs -> do
setXmlTransformed
cs' <- mapM transformChild cs
return $ paren $ metaAsChild $ listE cs'
XPcdata _ pcdata -> do setXmlTransformed
return $ metaFromStringLit $ strE pcdata
XExpTag _ e -> do setXmlTransformed
e' <- transformExpM e
return $ paren $ metaAsChild e'
Lambda l pats rhs -> do
let
(ps, rnpss) = unzip $ renameRPats pats
(rns, rps) = unzip (concat rnpss)
alt1 = alt (pTuple rps) rhs
texp = varTuple rns
e = if null rns then rhs else caseE texp [alt1]
rhs' <- transformExpM e
return $ Lambda l ps rhs'
Let _ (BDecls _ ds) e -> do
ds' <- transformLetDecls ds
e' <- transformExpM e
return $ letE ds' e'
Let l (IPBinds l' is) e -> do
is' <- mapM transformIPBind is
e' <- transformExpM e
return $ Let l (IPBinds l' is') e'
Case l e alts -> do
e' <- transformExpM e
alts' <- mapM transformAlt alts
return $ Case l e' alts'
Do l stmts -> do
stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts
return $ Do l stmts'
MDo l stmts -> do
stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts
return $ MDo l stmts'
ListComp l e stmts -> do
e' <- transformExpM e
stmts' <- fmap concat $ mapM transformQualStmt stmts
return $ ListComp l e' stmts'
ParComp l e stmtss -> do
e' <- transformExpM e
stmtss' <- fmap (map concat) $ mapM (mapM transformQualStmt) stmtss
return $ ParComp l e' stmtss'
Proc l pat rhs -> do
let
([p], [rnps]) = unzip $ renameRPats [pat]
(rns, rps) = unzip rnps
alt1 = alt (pTuple rps) rhs
texp = varTuple rns
e = if null rns then rhs else caseE texp [alt1]
rhs' <- transformExpM e
return $ Proc l p rhs'
InfixApp l e1 op e2 -> transform2exp e1 e2
(\e1 e2 -> InfixApp l e1 op e2)
App l e1 e2 -> transform2exp e1 e2 (App l)
NegApp l e -> fmap (NegApp l) $ transformExpM e
If l e1 e2 e3 -> transform3exp e1 e2 e3 (If l)
Tuple l bx es -> fmap (Tuple l bx) $ mapM transformExpM es
List l es -> fmap (List l) $ mapM transformExpM es
Paren l e -> fmap (Paren l) $ transformExpM e
LeftSection l e op -> do e' <- transformExpM e
return $ LeftSection l e' op
RightSection l op e -> fmap (RightSection l op) $ transformExpM e
RecConstr l n fus -> fmap (RecConstr l n) $ mapM transformFieldUpdate fus
RecUpdate l e fus -> do e' <- transformExpM e
fus' <- mapM transformFieldUpdate fus
return $ RecUpdate l e' fus'
EnumFrom l e -> fmap (EnumFrom l) $ transformExpM e
EnumFromTo l e1 e2 -> transform2exp e1 e2 (EnumFromTo l)
EnumFromThen l e1 e2 -> transform2exp e1 e2 (EnumFromThen l)
EnumFromThenTo l e1 e2 e3 -> transform3exp e1 e2 e3 (EnumFromThenTo l)
ExpTypeSig l e t -> do e' <- transformExpM e
return $ ExpTypeSig l e' t
SpliceExp l s -> fmap (SpliceExp l) $ transformSplice s
LeftArrApp l e1 e2 -> transform2exp e1 e2 (LeftArrApp l)
RightArrApp l e1 e2 -> transform2exp e1 e2 (RightArrApp l)
LeftArrHighApp l e1 e2 -> transform2exp e1 e2 (LeftArrHighApp l)
RightArrHighApp l e1 e2 -> transform2exp e1 e2 (RightArrHighApp l)
CorePragma l s e -> fmap (CorePragma l s) $ transformExpM e
SCCPragma l s e -> fmap (SCCPragma l s) $ transformExpM e
GenPragma l s a b e -> fmap (GenPragma l s a b) $ transformExpM e
_ -> return e
where
transformChild :: Exp () -> HsxM (Exp ())
transformChild e = do
te <- transformExpM e
return $ metaAsChild te
transformFieldUpdate :: FieldUpdate () -> HsxM (FieldUpdate ())
transformFieldUpdate (FieldUpdate l n e) =
fmap (FieldUpdate l n) $ transformExpM e
transformFieldUpdate fup = return fup
transformSplice :: Splice () -> HsxM (Splice ())
transformSplice s = case s of
ParenSplice l e -> fmap (ParenSplice l) $ transformExpM e
_ -> return s
transform2exp :: Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a
transform2exp e1 e2 f = do e1' <- transformExpM e1
e2' <- transformExpM e2
return $ f e1' e2'
transform3exp :: Exp () -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp () -> a) -> HsxM a
transform3exp e1 e2 e3 f = do e1' <- transformExpM e1
e2' <- transformExpM e2
e3' <- transformExpM e3
return $ f e1' e2' e3'
mkAttr :: XAttr () -> Exp ()
mkAttr (XAttr _ name e) =
paren (metaMkName name `metaAssign` (textTypeSig e))
where
textTypeSig e@(Lit _ (String _ _ _)) = metaFromStringLit e
textTypeSig e = e
transformLetDecls :: [Decl ()] -> HsxM [Decl ()]
transformLetDecls ds = do
let ds' = renameLetDecls ds
transformLDs 0 0 ds'
where transformLDs :: Int -> Int -> [Decl ()] -> HsxM [Decl ()]
transformLDs k l ds = case ds of
[] -> return []
(d:ds) -> case d of
PatBind l'' pat rhs decls -> do
([pat'], ags, gs, ws, k', l') <- runTrFromTo k l (trPatterns [pat])
decls' <- case decls of
Nothing -> return Nothing
Just (BDecls l'' decls) -> fmap (Just . BDecls l'') $ transformLetDecls decls
Just (IPBinds l'' decls) -> fmap (Just . IPBinds l'') $ mapM transformIPBind decls
let gs' = case gs of
[] -> []
[g] -> [mkDeclGuard g ws]
_ -> error "This should not happen since we have called renameLetDecls already!"
ags' = map (flip mkDeclGuard $ []) ags
rhs' <- mkRhs [] [] rhs
ds' <- transformLDs k' l' ds
return $ (PatBind l'' pat' rhs' decls') : ags' ++ gs' ++ ds'
d -> do d' <- transformDecl d
ds' <- transformLDs k l ds
return $ d':ds'
transformIPBind :: IPBind () -> HsxM (IPBind ())
transformIPBind (IPBind l n e) =
fmap (IPBind l n) $ transformExpM e
data StmtType = DoStmt | GuardStmt | ListCompStmt
transformStmt :: StmtType -> Stmt () -> HsxM [Stmt ()]
transformStmt t s = case s of
Generator s p e -> do
let
guardFun = case t of
DoStmt -> monadify
ListCompStmt -> monadify
GuardStmt -> mkStmtGuard
([p'], rnpss) = unzip $ renameIrrPats [p]
([p''], ags, gs, ds) <- transformPatterns [p']
let lt = case ds of
[] -> []
_ -> [letStmt ds]
gs' = map guardFun (ags ++ gs)
e' <- transformExpM $ addLetDecls (concat rnpss) e
return $ Generator s p'' e':lt ++ gs'
where monadify :: Guard () -> Stmt ()
monadify (p,e) = genStmt p (metaReturn $ paren e)
Qualifier l e -> fmap (\e -> [Qualifier l $ e]) $ transformExpM e
LetStmt _ (BDecls _ ds) ->
fmap (\ds -> [letStmt ds]) $ transformLetDecls ds
LetStmt l (IPBinds l' is) ->
fmap (\is -> [LetStmt l (IPBinds l' is)]) $ mapM transformIPBind is
RecStmt l stmts ->
fmap (return . RecStmt l . concat) $ mapM (transformStmt t) stmts
transformQualStmt :: QualStmt () -> HsxM [QualStmt ()]
transformQualStmt qs = case qs of
QualStmt l s -> fmap (map (QualStmt l)) $ transformStmt ListCompStmt s
ThenTrans l e -> fmap (return . ThenTrans l) $ transformExpM e
ThenBy l e f -> fmap return $ transform2exp e f (ThenBy l)
GroupBy l e -> fmap (return . GroupBy l) $ transformExpM e
GroupUsing l f -> fmap (return . GroupUsing l) $ transformExpM f
GroupByUsing l e f -> fmap return $ transform2exp e f (GroupByUsing l)
transformAlt :: Alt () -> HsxM (Alt ())
transformAlt (Alt l pat rhs decls) = do
let ([pat'], rnpss) = unzip $ renameIrrPats [pat]
([pat''], attrGuards, guards, decls'') <- transformPatterns [pat']
rhs' <- mkRhs (attrGuards ++ guards) (concat rnpss) rhs
decls' <- case decls of
Nothing -> return Nothing
Just (BDecls l' ds) -> do ds' <- mapM transformDecl ds
return $ Just $ BDecls l' $ decls'' ++ ds
_ -> error "Cannot bind implicit parameters in the \
\ \'where\' clause of a function using regular patterns."
return $ Alt l pat'' rhs' decls'
type Guard l = (Pat l, Exp l)
mkStmtGuard :: Guard () -> Stmt ()
mkStmtGuard (p, e) = genStmt p e
mkDeclGuard :: Guard () -> [Decl ()] -> Decl ()
mkDeclGuard (p, e) ds = patBindWhere p e ds
newtype RN a = RN (RNState -> (a, RNState))
type RNState = Int
initRNState = 0
instance Applicative RN where
pure = return
(<*>) = ap
instance Monad RN where
return a = RN $ \s -> (a,s)
(RN f) >>= k = RN $ \s -> let (a,s') = f s
(RN g) = k a
in g s'
instance Functor RN where
fmap f rna = do a <- rna
return $ f a
runRename :: RN a -> a
runRename (RN f) = let (a,_) = f initRNState
in a
getRNState :: RN RNState
getRNState = RN $ \s -> (s,s)
setRNState :: RNState -> RN ()
setRNState s = RN $ \_ -> ((), s)
genVarName :: RN (Name ())
genVarName = do
k <- getRNState
setRNState $ k+1
return $ name $ "harp_rnvar" ++ show k
type NameBind l = (Name l, Pat l)
rename1pat :: a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename1pat p f rn = do (q, ms) <- rn p
return (f q, ms)
rename2pat :: a -> a -> (b -> b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
rename2pat p1 p2 f rn = do (q1, ms1) <- rn p1
(q2, ms2) <- rn p2
return $ (f q1 q2, ms1 ++ ms2)
renameNpat :: [a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
renameNpat ps f rn = do (qs, mss) <- fmap unzip $ mapM rn ps
return (f qs, concat mss)
renameRPats :: [Pat ()] -> [(Pat (), [NameBind ()])]
renameRPats ps = runRename $ mapM renameRP ps
renameRP :: Pat () -> RN (Pat (), [NameBind ()])
renameRP p = case p of
PRPat _ _ -> rename p
PXTag _ _ _ _ _ -> rename p
PXETag _ _ _ _ -> rename p
PInfixApp l p1 n p2 -> rename2pat p1 p2
(\p1 p2 -> PInfixApp l p1 n p2)
renameRP
PApp l n ps -> renameNpat ps (PApp l n) renameRP
PTuple l bx ps -> renameNpat ps (PTuple l bx) renameRP
PList l ps -> renameNpat ps (PList l) renameRP
PParen l p -> rename1pat p (PParen l) renameRP
PRec l n pfs -> renameNpat pfs (PRec l n) renameRPf
PAsPat l n p -> rename1pat p (PAsPat l n) renameRP
PIrrPat l p -> rename1pat p (PIrrPat l) renameRP
PXPatTag l p -> rename1pat p (PXPatTag l) renameRP
PatTypeSig l p t -> rename1pat p (\p -> PatTypeSig l p t) renameRP
_ -> return (p, [])
where renameRPf :: PatField () -> RN (PatField (), [NameBind ()])
renameRPf (PFieldPat l n p) = rename1pat p (PFieldPat l n) renameRP
renameRPf pf = return (pf, [])
renameAttr :: PXAttr () -> RN (PXAttr (), [NameBind ()])
renameAttr (PXAttr l s p) = rename1pat p (PXAttr l s) renameRP
rename :: Pat () -> RN (Pat (), [NameBind ()])
rename p = do
n <- genVarName
return (pvar n, [(n,p)])
renameLetDecls :: [Decl ()] -> [Decl ()]
renameLetDecls ds =
let
(ds', smss) = unzip $ runRename $ mapM renameLetDecl ds
gs = map (\(n,p) -> mkDecl (n,p)) (concat smss)
in ds' ++ gs
where renameLetDecl :: Decl () -> RN (Decl (), [(Name (), Pat ())])
renameLetDecl d = case d of
PatBind l pat rhs decls -> do
(p, ms) <- renameRP pat
let sms = map (\(n,p) -> (n, p)) ms
return $ (PatBind l p rhs decls, sms)
_ -> return (d, [])
renameIrrPats :: [Pat ()] -> [(Pat (), [NameBind ()])]
renameIrrPats ps = runRename (mapM renameIrrP ps)
renameIrrP :: Pat () -> RN (Pat (), [(Name (), Pat ())])
renameIrrP p = case p of
PIrrPat l p -> do (q, ms) <- renameRP p
return $ (PIrrPat l q, ms)
PInfixApp l p1 n p2 -> rename2pat p1 p2
(\p1 p2 -> PInfixApp l p1 n p2)
renameIrrP
PApp l n ps -> renameNpat ps (PApp l n) renameIrrP
PTuple l bx ps -> renameNpat ps (PTuple l bx) renameIrrP
PList l ps -> renameNpat ps (PList l) renameIrrP
PParen l p -> rename1pat p (PParen l) renameIrrP
PRec l n pfs -> renameNpat pfs (PRec l n) renameIrrPf
PAsPat l n p -> rename1pat p (PAsPat l n) renameIrrP
PatTypeSig l p t -> rename1pat p (\p -> PatTypeSig l p t) renameIrrP
PXTag l n attrs mat ps -> do (attrs', nss) <- fmap unzip $ mapM renameIrrAttr attrs
(mat', ns1) <- case mat of
Nothing -> return (Nothing, [])
Just at -> do (at', ns) <- renameIrrP at
return (Just at', ns)
(q, ns) <- renameNpat ps (PXTag l n attrs' mat') renameIrrP
return (q, concat nss ++ ns1 ++ ns)
PXETag l n attrs mat -> do (as, nss) <- fmap unzip $ mapM renameIrrAttr attrs
(mat', ns1) <- case mat of
Nothing -> return (Nothing, [])
Just at -> do (at', ns) <- renameIrrP at
return (Just at', ns)
return $ (PXETag l n as mat', concat nss ++ ns1)
PXPatTag l p -> rename1pat p (PXPatTag l) renameIrrP
_ -> return (p, [])
where renameIrrPf :: PatField () -> RN (PatField (), [NameBind ()])
renameIrrPf (PFieldPat l n p) = rename1pat p (PFieldPat l n) renameIrrP
renameIrrPf pf = return (pf, [])
renameIrrAttr :: PXAttr () -> RN (PXAttr (), [NameBind ()])
renameIrrAttr (PXAttr l s p) = rename1pat p (PXAttr l s) renameIrrP
transformPatterns :: [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])
transformPatterns ps = runTr (trPatterns ps)
type State = (Int, Int, Int, [Guard ()], [Guard ()], [Decl ()])
newtype Tr a = Tr (State -> HsxM (a, State))
instance Applicative Tr where
pure = return
(<*>) = ap
instance Monad Tr where
return a = Tr $ \s -> return (a, s)
(Tr f) >>= k = Tr $ \s ->
do (a, s') <- f s
let (Tr f') = k a
f' s'
instance Functor Tr where
fmap f tra = tra >>= (return . f)
liftTr :: HsxM a -> Tr a
liftTr hma = Tr $ \s -> do a <- hma
return (a, s)
initState = initStateFrom 0 0
initStateFrom k l = (0, k, l, [], [], [])
runTr :: Tr a -> HsxM (a, [Guard ()], [Guard ()], [Decl ()])
runTr (Tr f) = do (a, (_,_,_,gs1,gs2,ds)) <- f initState
return (a, reverse gs1, reverse gs2, reverse ds)
runTrFromTo :: Int -> Int -> Tr a -> HsxM (a, [Guard ()], [Guard ()], [Decl ()], Int, Int)
runTrFromTo k l (Tr f) = do (a, (_,k',l',gs1,gs2,ds)) <- f $ initStateFrom k l
return (a, reverse gs1, reverse gs2, reverse ds, k', l')
getState :: Tr State
getState = Tr $ \s -> return (s,s)
setState :: State -> Tr ()
setState s = Tr $ \_ -> return ((),s)
updateState :: (State -> (a,State)) -> Tr a
updateState f = do s <- getState
let (a,s') = f s
setState s'
return a
pushGuard :: Pat () -> Exp () -> Tr ()
pushGuard p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,(p,e):gs2,ds))
pushDecl :: Decl () -> Tr ()
pushDecl d = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,gs2,d:ds))
pushAttrGuard :: Pat () -> Exp () -> Tr ()
pushAttrGuard p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,(p,e):gs1,gs2,ds))
genMatchName :: Tr (Name ())
genMatchName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (n,(n+1,m,a,gs1,gs2,ds))
return $ Ident () $ "harp_match" ++ show k
genPatName :: Tr (Name ())
genPatName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m+1,a,gs1,gs2,ds))
return $ Ident () $ "harp_pat" ++ show k
genAttrName :: Tr (Name ())
genAttrName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m,a+1,gs1,gs2,ds))
return $ Ident () $ "hsx_attrs" ++ show k
setHarpTransformedT, setXmlTransformedT :: Tr ()
setHarpTransformedT = liftTr setHarpTransformed
setXmlTransformedT = liftTr setXmlTransformed
tr1pat :: a -> (b -> c) -> (a -> Tr b) -> Tr c
tr1pat p f tr = do q <- tr p
return $ f q
tr2pat :: a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c
tr2pat p1 p2 f tr = do q1 <- tr p1
q2 <- tr p2
return $ f q1 q2
trNpat :: [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
trNpat ps f tr = do qs <- mapM tr ps
return $ f qs
trPatterns :: [Pat ()] -> Tr [Pat ()]
trPatterns = mapM trPattern
trPattern :: Pat () -> Tr (Pat ())
trPattern p = case p of
PRPat _ rps -> do
n <- genPatName
(mname, vars, _) <- trRPat True (RPSeq () rps)
topmname <- mkTopDecl mname vars
mkGuard vars topmname n
setHarpTransformedT
return $ pvar n
PXTag _ name attrs mattr cpats -> do
an <- case (mattr, attrs) of
(Just ap, []) -> return $ ap
(_, []) -> return wildcard
(_, _) -> do
n <- genAttrName
mkAttrGuards n attrs mattr
return $ pvar n
cpat' <- case cpats of
(p@(PXRPats _ _)):[] -> trPattern p
_ -> trPattern (PList () cpats)
setHarpTransformedT
let (dom, n) = xNameParts name
return $ metaTag dom n an cpat'
PXETag _ name attrs mattr -> do
an <- case (mattr, attrs) of
(Just ap, []) -> return $ ap
(_, []) -> return wildcard
(_, _) -> do
n <- genAttrName
mkAttrGuards n attrs mattr
return $ pvar n
setHarpTransformedT
let (dom, n) = xNameParts name
return $ metaTag dom n an peList
PXPcdata _ st -> setHarpTransformedT >> (return $ metaPcdata st)
PXPatTag _ p -> setHarpTransformedT >> trPattern p
PXRPats l rps -> trPattern $ PRPat l rps
PViewPat l e p -> do
e' <- liftTr $ transformExpM e
tr1pat p (PViewPat l e') trPattern
PVar _ _ -> return p
PLit _ _ _ -> return p
PInfixApp l p1 op p2 -> tr2pat p1 p2 (\p1 p2 -> PInfixApp l p1 op p2) trPattern
PApp l n ps -> trNpat ps (PApp l n) trPattern
PTuple l bx ps -> trNpat ps (PTuple l bx) trPattern
PList l ps -> trNpat ps (PList l) trPattern
PParen l p -> tr1pat p (PParen l) trPattern
PRec l n pfs -> trNpat pfs (PRec l n) trPatternField
PAsPat l n p -> tr1pat p (PAsPat l n) trPattern
PWildCard l -> return p
PIrrPat l p -> tr1pat p (PIrrPat l) trPattern
PatTypeSig l p t -> tr1pat p (\p -> PatTypeSig l p t) trPattern
PQuasiQuote _ _ _ -> return p
PBangPat l p -> tr1pat p (PBangPat l) trPattern
PNPlusK _ _ _ -> return p
where
trPatternField :: PatField () -> Tr (PatField ())
trPatternField (PFieldPat l n p) =
tr1pat p (PFieldPat l n) trPattern
trPatternField p = return p
mkAttrGuards :: Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()
mkAttrGuards attrs [PXAttr _ n q] mattr = do
let rhs = metaExtract n attrs
pat = metaPJust q
rml = case mattr of
Nothing -> wildcard
Just ap -> ap
pushAttrGuard (pTuple [pat, rml]) rhs
mkAttrGuards attrs ((PXAttr _ a q):xs) mattr = do
let rhs = metaExtract a attrs
pat = metaPJust q
newAttrs <- genAttrName
pushAttrGuard (pTuple [pat, pvar newAttrs]) rhs
mkAttrGuards newAttrs xs mattr
mkTopDecl :: Name () -> [Name ()] -> Tr (Name ())
mkTopDecl mname vars =
do
n <- genMatchName
pushDecl $ topDecl n mname vars
return n
topDecl :: Name () -> Name () -> [Name ()] -> Decl ()
topDecl n mname vs =
let pat = pTuple [wildcard, pvarTuple vs]
g = var mname
a = genStmt pat g
vars = map (\v -> app (var v) eList) vs
b = qualStmt $ metaReturn $ tuple vars
e = doE [a,b]
in nameBind n e
mkGuard :: [Name ()] -> Name () -> Name () -> Tr ()
mkGuard vars mname n = do
let tvs = pvarTuple vars
ge = appFun runMatchFun [var mname, var n]
pushGuard (pApp just_name [tvs]) ge
data MType = S
| L MType
| E MType MType
| M MType
type MFunMetaInfo l = (Name l, [Name l], MType)
trRPat :: Bool -> RPat () -> Tr (MFunMetaInfo ())
trRPat linear rp = case rp of
RPPat _ p -> mkBaseDecl linear p
where
mkBaseDecl :: Bool -> Pat () -> Tr (MFunMetaInfo ())
mkBaseDecl linear p = case p of
PWildCard _ -> mkWCMatch
PVar _ v -> mkVarMatch linear v
PXPatTag _ q -> mkBaseDecl linear q
p -> do
(name, vars, _) <- mkBasePat linear p
newname <- mkBaseMatch name
return (newname, vars, S)
mkBasePat :: Bool -> Pat () -> Tr (MFunMetaInfo ())
mkBasePat b p =
do
n <- genMatchName
let vs = gatherPVars p
basePatDecl b n vs p >>= pushDecl
return (n, vs, S)
basePatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> Tr (Decl ())
basePatDecl linear f vs p = do
let a = Ident () $ "harp_a"
rhs <- baseCaseE linear p a vs
return $ simpleFun f a rhs
where baseCaseE :: Bool -> Pat () -> Name () -> [Name ()] -> Tr (Exp ())
baseCaseE b p a vs = do
let alt1 = alt p
(app (con just_name) $
tuple (map (retVar b) vs))
alt2 = alt wildcard (con nothing_name)
alt1' <- liftTr $ transformAlt alt1
return $ caseE (var a) [alt1', alt2]
retVar :: Bool -> Name () -> Exp ()
retVar linear v
| linear = metaConst (var v)
| otherwise = app consFun (var v)
RPGuard _ p gs -> mkGuardDecl linear p gs
where mkGuardDecl :: Bool -> Pat () -> [Stmt ()] -> Tr (MFunMetaInfo ())
mkGuardDecl linear p gs = case p of
PXPatTag _ q -> mkGuardDecl linear q gs
p -> do
(name, vars, _) <- mkGuardPat linear p gs
newname <- mkBaseMatch name
return (newname, vars, S)
mkGuardPat :: Bool -> Pat () -> [Stmt ()] -> Tr (MFunMetaInfo ())
mkGuardPat b p gs =
do
n <- genMatchName
let vs = gatherPVars p ++ concatMap gatherStmtVars gs
guardPatDecl b n vs p gs >>= pushDecl
return (n, vs, S)
guardPatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> [Stmt ()] -> Tr (Decl ())
guardPatDecl linear f vs p gs = do
let a = Ident () $ "harp_a"
rhs <- guardedCaseE linear p gs a vs
return $ simpleFun f a rhs
where guardedCaseE :: Bool -> Pat () -> [Stmt ()] -> Name () -> [Name ()] -> Tr (Exp ())
guardedCaseE b p gs a vs = do
let alt1 = altGW p gs
(app (con just_name) $
tuple (map (retVar b) vs)) (binds [])
alt2 = alt wildcard (con nothing_name)
alt1' <- liftTr $ transformAlt alt1
return $ caseE (var a) [alt1', alt2]
retVar :: Bool -> Name () -> Exp ()
retVar linear v
| linear = metaConst (var v)
| otherwise = app consFun (var v)
RPSeq _ rps -> do
nvts <- mapM (trRPat linear) rps
mkSeqDecl nvts
where
mkSeqDecl :: [MFunMetaInfo ()] -> Tr (MFunMetaInfo ())
mkSeqDecl nvts = do
name <- genMatchName
let
(gs, vals) = unzip $ mkGenExps 0 nvts
vars = concatMap (\(_,vars,_) -> vars) nvts
fldecls = flattenVals vals
ret = qualStmt $ metaReturn $
tuple [var retname, varTuple vars]
rhs = doE $ gs ++
[letStmt fldecls, ret]
pushDecl $ nameBind name rhs
return (name, vars, L S)
flattenVals :: [(Name (), MType)] -> [Decl ()]
flattenVals nts =
let
(nns, ds) = unzip $ map flVal nts
ret = nameBind retname $ app
(paren $ app foldCompFun
(listE $ map var nns)) $ eList
in ds ++ [ret]
flVal :: (Name (), MType) -> (Name (), Decl ())
flVal (name, mt) =
let
newname = extendVar name "f"
f = flatten mt
in (newname, nameBind newname $
app f (var name))
flatten :: MType -> Exp ()
flatten S = consFun
flatten (L mt) =
let f = flatten mt
r = paren $ metaMap [f]
in paren $ foldCompFun `metaComp` r
flatten (E mt1 mt2) =
let f1 = flatten mt1
f2 = flatten mt2
in paren $ metaEither f1 f2
flatten (M mt) =
let f = flatten mt
in paren $ metaMaybe idFun f
RPCAs _ v rp -> do
nvt@(name, vs, mt) <- trRPat linear rp
n <- mkCAsDecl nvt
return (n, (v:vs), mt)
where
mkCAsDecl :: MFunMetaInfo () -> Tr (Name ())
mkCAsDecl = asDecl $ app consFun
RPAs _ v rp
| linear ->
do
nvt@(name, vs, mt) <- trRPat linear rp
n <- mkAsDecl nvt
return (n, (v:vs), mt)
| otherwise -> case v of
Ident () n -> fail $ "Attempting to bind variable "++n++
" inside the context of a numerable regular pattern"
_ -> fail $ "This should never ever ever happen... how the #% did you do it??!?"
where
mkAsDecl :: MFunMetaInfo () -> Tr (Name ())
mkAsDecl = asDecl metaConst
RPParen _ rp -> trRPat linear rp
RPOp _ rp (RPOpt _)->
do
nvt <- trRPat False rp
mkOptDecl False nvt
RPOp _ rp (RPOptG _) ->
do
nvt <- trRPat False rp
mkOptDecl True nvt
RPEither _ rp1 rp2 ->
do
nvt1 <- trRPat False rp1
nvt2 <- trRPat False rp2
mkEitherDecl nvt1 nvt2
where mkEitherDecl :: MFunMetaInfo () -> MFunMetaInfo () -> Tr (MFunMetaInfo ())
mkEitherDecl nvt1@(_, vs1, t1) nvt2@(_, vs2, t2) = do
n <- genMatchName
let
(g1, v1) = mkGenExp nvt1
(g2, v2) = mkGenExp nvt2
allvs = vs1 `union` vs2
vals1 = map (varOrId vs1) allvs
vals2 = map (varOrId vs2) allvs
ret1 = metaReturn $ tuple
[app (con left_name)
(var v1), tuple vals1]
ret2 = metaReturn $ tuple
[app (con right_name)
(var v2), tuple vals2]
exp1 = doE [g1, qualStmt ret1]
exp2 = doE [g2, qualStmt ret2]
rhs = (paren exp1) `metaChoice`
(paren exp2)
pushDecl $ nameBind n rhs
return (n, allvs, E t1 t2)
varOrId :: [Name ()] -> Name () -> Exp ()
varOrId vs v = if v `elem` vs
then var v
else idFun
RPOp _ rp (RPStar _) ->
do
nvt <- trRPat False rp
mkStarDecl False nvt
RPOp _ rp (RPStarG _) ->
do
nvt <- trRPat False rp
mkStarDecl True nvt
RPOp _ rp (RPPlus _) ->
do
nvt <- trRPat False rp
mkPlusDecl False nvt
RPOp _ rp (RPPlusG _) ->
do
nvt <- trRPat False rp
mkPlusDecl True nvt
where
mkVarMatch :: Bool -> Name () -> Tr (MFunMetaInfo ())
mkVarMatch linear v = do
n <- genMatchName
let e = paren $ lamE [pvar v] $
app (con just_name)
(paren $ retVar linear v)
pushDecl $ nameBind n $
app baseMatchFun e
return (n, [v], S)
where retVar :: Bool -> Name () -> Exp ()
retVar linear v
| linear = metaConst (var v)
| otherwise = app consFun (var v)
mkWCMatch :: Tr (MFunMetaInfo ())
mkWCMatch = do
n <- genMatchName
let e = paren $ lamE [wildcard] $
app (con just_name) (unit_con ())
pushDecl $ nameBind n $
app baseMatchFun e
return (n, [], S)
gatherPVars :: Pat () -> [Name ()]
gatherPVars p = case p of
PVar _ v -> [v]
PInfixApp _ p1 _ p2 -> gatherPVars p1 ++
gatherPVars p2
PApp _ _ ps -> concatMap gatherPVars ps
PTuple _ _ ps -> concatMap gatherPVars ps
PList _ ps -> concatMap gatherPVars ps
PParen _ p -> gatherPVars p
PRec _ _ pfs -> concatMap help pfs
where help (PFieldPat _ _ p) = gatherPVars p
help _ = []
PAsPat _ n p -> n : gatherPVars p
PWildCard _ -> []
PIrrPat _ p -> gatherPVars p
PatTypeSig _ p _ -> gatherPVars p
PRPat _ rps -> concatMap gatherRPVars rps
PXTag _ _ attrs mattr cps ->
concatMap gatherAttrVars attrs ++ concatMap gatherPVars cps ++
case mattr of
Nothing -> []
Just ap -> gatherPVars ap
PXETag _ _ attrs mattr ->
concatMap gatherAttrVars attrs ++
case mattr of
Nothing -> []
Just ap -> gatherPVars ap
PXPatTag _ p -> gatherPVars p
_ -> []
gatherRPVars :: RPat () -> [Name ()]
gatherRPVars rp = case rp of
RPOp _ rq _ -> gatherRPVars rq
RPEither _ rq1 rq2 -> gatherRPVars rq1 ++ gatherRPVars rq2
RPSeq _ rqs -> concatMap gatherRPVars rqs
RPCAs _ n rq -> n : gatherRPVars rq
RPAs _ n rq -> n : gatherRPVars rq
RPParen _ rq -> gatherRPVars rq
RPGuard _ q gs -> gatherPVars q ++ concatMap gatherStmtVars gs
RPPat _ q -> gatherPVars q
gatherAttrVars :: PXAttr () -> [Name ()]
gatherAttrVars (PXAttr _ _ p) = gatherPVars p
gatherStmtVars :: Stmt () -> [Name ()]
gatherStmtVars gs = case gs of
Generator _ p _ -> gatherPVars p
_ -> []
mkBaseMatch :: Name () -> Tr (Name ())
mkBaseMatch name =
do
n <- genMatchName
pushDecl $ baseMatchDecl n name
return n
baseMatchDecl :: Name () -> Name () -> Decl ()
baseMatchDecl newname oldname =
let e = app baseMatchFun (var oldname)
in nameBind newname e
mkGenExps :: Int -> [MFunMetaInfo ()] -> [(Stmt (), (Name (), MType))]
mkGenExps _ [] = []
mkGenExps k ((name, vars, t):nvs) =
let valname = mkValName k
pat = pTuple [pvar valname, pvarTuple vars]
g = var name
in (genStmt pat g, (valname, t)) :
mkGenExps (k+1) nvs
mkGenExp :: MFunMetaInfo () -> (Stmt (), Name ())
mkGenExp nvt = let [(g, (name, _t))] = mkGenExps 0 [nvt]
in (g, name)
mkManyGen :: Bool -> Name () -> Stmt ()
mkManyGen greedy mname =
let mf = if greedy then gManyMatchFun else manyMatchFun
in genStmt (pvar valsvarsname) $
app mf (var mname)
asDecl :: (Exp () -> Exp ()) -> MFunMetaInfo () -> Tr (Name ())
asDecl mf nvt@(_, vs, _) = do
n <- genMatchName
let
(g, val) = mkGenExp nvt
vars = map var vs
ret = qualStmt $ metaReturn $ tuple
[var val, tuple $ mf (var val) : vars]
pushDecl $ nameBind n $ doE [g, ret]
return n
mkOptDecl :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())
mkOptDecl greedy nvt@(_, vs, t) = do
n <- genMatchName
let
(g, val) = mkGenExp nvt
ret1 = metaReturn $ tuple
[app (con just_name)
(var val), varTuple vs]
exp1 = doE [g, qualStmt ret1]
ids = map (const idFun) vs
ret2 = metaReturn $ tuple
[con nothing_name, tuple ids]
mc = if greedy
then metaChoice
else (flip metaChoice)
rhs = (paren exp1) `mc`
(paren ret2)
pushDecl $ nameBind n rhs
return (n, vs, M t)
mkStarDecl :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())
mkStarDecl greedy (mname, vs, t) = do
n <- genMatchName
let
g = mkManyGen greedy mname
metaUnzipK = mkMetaUnzip (length vs)
dec1 = patBind (pvarTuple [valname, varsname])
(metaUnzip $ var valsvarsname)
dec2 = patBind (pvarTuple vs)
(metaUnzipK $ var varsname)
retExps = map ((app foldCompFun) . var) vs
ret = metaReturn $ tuple $
[var valname, tuple retExps]
pushDecl $ nameBind n $
doE [g, letStmt [dec1, dec2], qualStmt ret]
return (n, vs, L t)
mkPlusDecl :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())
mkPlusDecl greedy nvt@(mname, vs, t) = do
n <- genMatchName
let k = length vs
(g1, val1) = mkGenExp nvt
g2 = mkManyGen greedy mname
metaUnzipK = mkMetaUnzip k
dec1 = patBind
(pvarTuple [valsname, varsname])
(metaUnzip $ var valsvarsname)
vlvars = genNames "harp_vl" k
dec2 = patBind (pvarTuple vlvars)
(metaUnzipK $ var varsname)
letSt = letStmt [dec1, dec2]
retExps = map mkRetFormat $ zip vs vlvars
retVal = (var val1) `metaCons`
(var valsname)
ret = metaReturn $ tuple $
[retVal, tuple retExps]
rhs = doE [g1, g2, letSt, qualStmt ret]
pushDecl $ nameBind n rhs
return (n, vs, L t)
where mkRetFormat :: (Name (), Name ()) -> Exp ()
mkRetFormat (v, vl) =
(var v) `metaComp`
(paren $ (app foldCompFun) $ var vl)
runMatchFun, baseMatchFun, manyMatchFun, gManyMatchFun :: Exp ()
runMatchFun = match_qual runMatch_name
baseMatchFun = match_qual baseMatch_name
manyMatchFun = match_qual manyMatch_name
gManyMatchFun = match_qual gManyMatch_name
runMatch_name, baseMatch_name, manyMatch_name, gManyMatch_name :: Name ()
runMatch_name = Ident () "runMatch"
baseMatch_name = Ident () "baseMatch"
manyMatch_name = Ident () "manyMatch"
gManyMatch_name = Ident () "gManyMatch"
match_mod, match_qual_mod :: ModuleName ()
match_mod = ModuleName () "Harp.Match"
match_qual_mod = ModuleName () "HaRPMatch"
match_qual :: Name () -> Exp ()
match_qual = qvar match_qual_mod
choiceOp :: QOp ()
choiceOp = QVarOp () $ Qual () match_qual_mod choice
appendOp :: QOp ()
appendOp = QVarOp () $ UnQual () append
foldCompFun :: Exp ()
foldCompFun = match_qual $ Ident () "foldComp"
mkMetaUnzip :: Int -> Exp () -> Exp ()
mkMetaUnzip k | k <= 7 = let n = "unzip" ++ show k
in (\e -> matchFunction n [e])
| otherwise =
let vs = genNames "x" k
lvs = genNames "xs" k
uz = name $ "unzip" ++ show k
ys = name "ys"
xs = name "xs"
alt1 = alt peList $ tuple $ replicate k eList
pat2 = (pvarTuple vs) `metaPCons` (pvar xs)
ret2 = tuple $ map appCons $ zip vs lvs
rhs2 = app (var uz) (var xs)
dec2 = patBind (pvarTuple lvs) rhs2
exp2 = letE [dec2] ret2
alt2 = alt pat2 exp2
topexp = lamE [pvar ys] $ caseE (var ys) [alt1, alt2]
topbind = nameBind uz topexp
in app (paren $ letE [topbind] (var uz))
where appCons :: (Name (), Name ()) -> Exp ()
appCons (x, xs) = metaCons (var x) (var xs)
matchFunction :: String -> [Exp ()] -> Exp ()
matchFunction s es = mf s (reverse es)
where mf s [] = match_qual $ Ident () s
mf s (e:es) = app (mf s es) e
retname :: Name ()
retname = name "harp_ret"
varsname :: Name ()
varsname = name "harp_vars"
valname :: Name ()
valname = name "harp_val"
valsname :: Name ()
valsname = name "harp_vals"
valsvarsname :: Name ()
valsvarsname = name "harp_vvs"
mkValName :: Int -> Name ()
mkValName k = name $ "harp_val" ++ show k
extendVar :: Name () -> String -> Name ()
extendVar (Ident l n) s = Ident l $ n ++ s
extendVar n _ = n
xNameParts :: XName () -> (Maybe String, String)
xNameParts n = case n of
XName _ s -> (Nothing, s)
XDomName _ d s -> (Just d, s)
metaReturn, metaConst, metaUnzip :: Exp () -> Exp ()
metaReturn e = metaFunction "return" [e]
metaConst e = metaFunction "const" [e]
metaUnzip e = metaFunction "unzip" [e]
metaEither, metaMaybe :: Exp () -> Exp () -> Exp ()
metaEither e1 e2 = metaFunction "either" [e1,e2]
metaMaybe e1 e2 = metaFunction "maybe" [e1,e2]
metaConcat, metaMap :: [Exp ()] -> Exp ()
metaConcat es = metaFunction "concat" [listE es]
metaMap = metaFunction "map"
metaAppend :: Exp () -> Exp () -> Exp ()
metaAppend l1 l2 = infixApp l1 appendOp l2
metaChoice :: Exp () -> Exp () -> Exp ()
metaChoice e1 e2 = infixApp e1 choiceOp e2
metaPCons :: Pat () -> Pat () -> Pat ()
metaPCons p1 p2 = PInfixApp () p1 cons p2
metaCons, metaComp :: Exp () -> Exp () -> Exp ()
metaCons e1 e2 = infixApp e1 (QConOp () cons) e2
metaComp e1 e2 = infixApp e1 (op fcomp) e2
metaPJust :: Pat () -> Pat ()
metaPJust p = pApp just_name [p]
metaPNothing :: Pat ()
metaPNothing = pvar nothing_name
metaPMkMaybe :: Maybe (Pat ()) -> Pat ()
metaPMkMaybe mp = case mp of
Nothing -> metaPNothing
Just p -> pParen $ metaPJust p
metaJust :: Exp () -> Exp ()
metaJust e = app (con just_name) e
metaNothing :: Exp ()
metaNothing = con nothing_name
metaMkMaybe :: Maybe (Exp ()) -> Exp ()
metaMkMaybe me = case me of
Nothing -> metaNothing
Just e -> paren $ metaJust e
consFun, idFun :: Exp ()
consFun = Con () cons
idFun = function "id"
con :: Name () -> Exp ()
con = Con () . UnQual ()
cons :: QName ()
cons = Special () (Cons ())
fcomp, choice, append :: Name ()
fcomp = Symbol () "."
choice = Symbol () "+++"
append = Symbol () "++"
just_name, nothing_name, left_name, right_name :: Name ()
just_name = Ident () "Just"
nothing_name = Ident () "Nothing"
left_name = Ident () "Left"
right_name = Ident () "Right"
metaGenElement :: XName () -> [Exp ()] -> Maybe (Exp ()) -> [Exp ()] -> Exp ()
metaGenElement name ats mat cs =
let (d,n) = xNameParts name
ne = tuple [metaMkMaybe $ fmap (metaFromStringLit . strE) d, metaFromStringLit $ strE n]
m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat
attrs = m $ listE $ map metaAsAttr ats
in metaFunction "genElement" [ne, attrs, listE cs]
metaGenEElement :: XName () -> [Exp ()] -> Maybe (Exp ()) -> Exp ()
metaGenEElement name ats mat =
let (d,n) = xNameParts name
ne = tuple [metaMkMaybe $ fmap (metaFromStringLit . strE) d, metaFromStringLit $ strE n]
m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat
attrs = m $ listE $ map metaAsAttr ats
in metaFunction "genEElement" [ne, attrs]
metaAsAttr :: Exp () -> Exp ()
metaAsAttr e@(Lit _ (String _ _ _)) = metaFunction "asAttr" [metaFromStringLit e]
metaAsAttr e = metaFunction "asAttr" [e]
argAsAttr :: Exp ()
argAsAttr = var $ name "asAttr"
metaAssign :: Exp () -> Exp () -> Exp ()
metaAssign e1 e2 = infixApp e1 assignOp e2
where assignOp = QConOp () $ UnQual () $ Symbol () ":="
metaAsChild :: Exp () -> Exp ()
metaAsChild e = metaFunction "asChild" [paren e]
metaFromStringLit :: Exp () -> Exp ()
metaFromStringLit e = metaFunction "fromStringLit" [e]
metaExtract :: XName () -> Name () -> Exp ()
metaExtract name attrs =
let (d,n) = xNameParts name
np = tuple [metaMkMaybe $ fmap strE d, strE n]
in metaFunction "extract" [np, var attrs]
metaTag :: (Maybe String) -> String -> Pat () -> Pat () -> Pat ()
metaTag dom name ats cpat =
let d = metaPMkMaybe $ fmap strP dom
n = pTuple [d, strP name]
in metaConPat "Element" [n, ats, cpat]
metaPcdata :: String -> Pat ()
metaPcdata s = metaConPat "CDATA" [strP s]
metaMkName :: XName () -> Exp ()
metaMkName n = case n of
XName _ s -> metaFromStringLit (strE s)
XDomName _ d s -> tuple [metaFromStringLit $ strE d, metaFromStringLit $ strE s]