module HSX.Transform (
transform
, transformExp
) where
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Build
import Language.Haskell.Exts.SrcLoc (noLoc)
import Data.List (union)
import Debug.Trace (trace)
newtype HsxM a = MkHsxM (HsxState -> (a, HsxState))
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 s m pragmas warn mes is decls) =
let (decls', (harp, hsx)) = runHsxM $ mapM transformDecl decls
imps1 = if harp
then (:) $ ImportDecl s match_mod True False Nothing
(Just match_qual_mod)
Nothing
else id
imps2 = id
in Module s m pragmas warn mes (imps1 $ imps2 is) decls'
transformDecl :: Decl -> HsxM Decl
transformDecl d = case d of
PatBind srcloc pat mty rhs decls -> do
let ([pat'], rnpss) = unzip $ renameIrrPats [pat]
([pat''], attrGuards, guards, decls'') <- transformPatterns srcloc [pat']
rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs
decls' <- case decls of
BDecls ds -> do ds' <- transformLetDecls ds
return $ BDecls $ decls'' ++ ds'
_ -> error "Cannot bind implicit parameters in the \
\ \'where\' clause of a function using regular patterns."
return $ PatBind srcloc pat'' mty rhs' decls'
FunBind ms -> fmap FunBind $ mapM transformMatch ms
InstDecl s c n ts idecls ->
fmap (InstDecl s c n ts) $ mapM transformInstDecl idecls
ClassDecl s c n ns ds cdecls ->
fmap (ClassDecl s c n ns ds) $ mapM transformClassDecl cdecls
SpliceDecl srcloc e ->
fmap (SpliceDecl srcloc) $ transformExpM e
_ -> return d
transformInstDecl :: InstDecl -> HsxM InstDecl
transformInstDecl d = case d of
InsDecl decl -> fmap InsDecl $ transformDecl decl
_ -> return d
transformClassDecl :: ClassDecl -> HsxM ClassDecl
transformClassDecl d = case d of
ClsDecl decl -> fmap ClsDecl $ transformDecl decl
_ -> return d
transformMatch :: Match -> HsxM Match
transformMatch (Match srcloc name pats mty rhs decls) = do
let (pats', rnpss) = unzip $ renameIrrPats pats
(pats'', attrGuards, guards, decls'') <- transformPatterns srcloc pats'
rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs
decls' <- case decls of
BDecls ds -> do ds' <- transformLetDecls ds
return $ BDecls $ decls'' ++ ds'
_ -> error "Cannot bind implicit parameters in the \
\ \'where\' clause of a function using regular patterns."
return $ Match srcloc name pats'' mty rhs' decls'
mkRhs :: SrcLoc -> [Guard] -> [(Name, Pat)] -> Rhs -> HsxM Rhs
mkRhs srcloc guards rnps (UnGuardedRhs rhs) = do
rhs' <- transformExpM $ addLetDecls srcloc rnps rhs
case guards of
[] -> return $ UnGuardedRhs rhs'
_ -> return $ GuardedRhss [GuardedRhs srcloc (map mkStmtGuard guards) rhs']
mkRhs _ guards rnps (GuardedRhss gdrhss) = fmap GuardedRhss $ mapM (mkGRhs guards rnps) gdrhss
where mkGRhs :: [Guard] -> [(Name, Pat)] -> GuardedRhs -> HsxM GuardedRhs
mkGRhs gs rnps (GuardedRhs s oldgs rhs) = do
rhs' <- transformExpM $ addLetDecls s rnps rhs
oldgs' <- fmap concat $ mapM (transformStmt GuardStmt) oldgs
return $ GuardedRhs s ((map mkStmtGuard gs) ++ oldgs') rhs'
addLetDecls :: SrcLoc -> [(Name, Pat)] -> Exp -> Exp
addLetDecls s [] e = e
addLetDecls s rnps e =
letE (map (mkDecl s) rnps) e
mkDecl :: SrcLoc -> (Name, Pat) -> Decl
mkDecl srcloc (n,p) = patBind srcloc 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 $ ExpTypeSig noLoc (strE pcdata) (TyCon (UnQual (Ident "String")))
XExpTag e -> do setXmlTransformed
e' <- transformExpM e
return $ paren $ metaAsChild e'
Lambda s pats rhs -> do
let
(ps, rnpss) = unzip $ renameRPats pats
(rns, rps) = unzip (concat rnpss)
alt1 = alt s (pTuple rps) rhs
texp = varTuple rns
e = if null rns then rhs else caseE texp [alt1]
rhs' <- transformExpM e
return $ Lambda s ps rhs'
Let (BDecls ds) e -> do
ds' <- transformLetDecls ds
e' <- transformExpM e
return $ letE ds' e'
Let (IPBinds is) e -> do
is' <- mapM transformIPBind is
e' <- transformExpM e
return $ Let (IPBinds is') e'
Case e alts -> do
e' <- transformExpM e
alts' <- mapM transformAlt alts
return $ Case e' alts'
Do stmts -> do
stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts
return $ Do stmts'
MDo stmts -> do
stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts
return $ MDo stmts'
ListComp e stmts -> do
e' <- transformExpM e
stmts' <- fmap concat $ mapM transformQualStmt stmts
return $ ListComp e' stmts'
ParComp e stmtss -> do
e' <- transformExpM e
stmtss' <- fmap (map concat) $ mapM (mapM transformQualStmt) stmtss
return $ ParComp e' stmtss'
Proc s pat rhs -> do
let
([p], [rnps]) = unzip $ renameRPats [pat]
(rns, rps) = unzip rnps
alt1 = alt s (pTuple rps) rhs
texp = varTuple rns
e = if null rns then rhs else caseE texp [alt1]
rhs' <- transformExpM e
return $ Proc s p rhs'
InfixApp e1 op e2 -> transform2exp e1 e2
(\e1 e2 -> InfixApp e1 op e2)
App e1 e2 -> transform2exp e1 e2 App
NegApp e -> fmap NegApp $ transformExpM e
If e1 e2 e3 -> transform3exp e1 e2 e3 If
Tuple es -> fmap Tuple $ mapM transformExpM es
List es -> fmap List $ mapM transformExpM es
Paren e -> fmap Paren $ transformExpM e
LeftSection e op -> do e' <- transformExpM e
return $ LeftSection e' op
RightSection op e -> fmap (RightSection op) $ transformExpM e
RecConstr n fus -> fmap (RecConstr n) $ mapM transformFieldUpdate fus
RecUpdate e fus -> do e' <- transformExpM e
fus' <- mapM transformFieldUpdate fus
return $ RecUpdate e' fus'
EnumFrom e -> fmap EnumFrom $ transformExpM e
EnumFromTo e1 e2 -> transform2exp e1 e2 EnumFromTo
EnumFromThen e1 e2 -> transform2exp e1 e2 EnumFromThen
EnumFromThenTo e1 e2 e3 -> transform3exp e1 e2 e3 EnumFromThenTo
ExpTypeSig s e t -> do e' <- transformExpM e
return $ ExpTypeSig s e' t
SpliceExp s -> fmap SpliceExp $ transformSplice s
LeftArrApp e1 e2 -> transform2exp e1 e2 LeftArrApp
RightArrApp e1 e2 -> transform2exp e1 e2 RightArrApp
LeftArrHighApp e1 e2 -> transform2exp e1 e2 LeftArrHighApp
RightArrHighApp e1 e2 -> transform2exp e1 e2 RightArrHighApp
CorePragma s e -> fmap (CorePragma s) $ transformExpM e
SCCPragma s e -> fmap (SCCPragma s) $ transformExpM e
GenPragma s a b e -> fmap (GenPragma 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 n e) =
fmap (FieldUpdate n) $ transformExpM e
transformFieldUpdate fup = return fup
transformSplice :: Splice -> HsxM Splice
transformSplice s = case s of
ParenSplice e -> fmap ParenSplice $ 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` (stringTypeSig e))
where
stringTypeSig e@(Lit (String _)) = ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))
stringTypeSig 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 srcloc pat mty rhs decls -> do
([pat'], ags, gs, ws, k', l') <- runTrFromTo k l (trPatterns srcloc [pat])
decls' <- case decls of
BDecls decls -> fmap BDecls $ transformLetDecls decls
IPBinds decls -> fmap IPBinds $ 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 srcloc [] [] rhs
ds' <- transformLDs k' l' ds
return $ (PatBind srcloc pat' mty rhs' decls') : ags' ++ gs' ++ ds'
d -> do d' <- transformDecl d
ds' <- transformLDs k l ds
return $ d':ds'
transformIPBind :: IPBind -> HsxM IPBind
transformIPBind (IPBind s n e) =
fmap (IPBind s 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 s [p']
let lt = case ds of
[] -> []
_ -> [letStmt ds]
gs' = map guardFun (ags ++ gs)
e' <- transformExpM $ addLetDecls s (concat rnpss) e
return $ Generator s p'' e':lt ++ gs'
where monadify :: Guard -> Stmt
monadify (s,p,e) = genStmt s p (metaReturn $ paren e)
Qualifier e -> fmap (\e -> [Qualifier $ e]) $ transformExpM e
LetStmt (BDecls ds) ->
fmap (\ds -> [letStmt ds]) $ transformLetDecls ds
LetStmt (IPBinds is) ->
fmap (\is -> [LetStmt (IPBinds is)]) $ mapM transformIPBind is
RecStmt stmts ->
fmap (return . RecStmt . concat) $ mapM (transformStmt t) stmts
transformQualStmt :: QualStmt -> HsxM [QualStmt]
transformQualStmt qs = case qs of
QualStmt s -> fmap (map QualStmt) $ transformStmt ListCompStmt s
ThenTrans e -> fmap (return . ThenTrans) $ transformExpM e
ThenBy e f -> fmap return $ transform2exp e f ThenBy
GroupBy e -> fmap (return . GroupBy) $ transformExpM e
GroupUsing f -> fmap (return . GroupUsing) $ transformExpM f
GroupByUsing e f -> fmap return $ transform2exp e f GroupByUsing
transformAlt :: Alt -> HsxM Alt
transformAlt (Alt srcloc pat rhs decls) = do
let ([pat'], rnpss) = unzip $ renameIrrPats [pat]
([pat''], attrGuards, guards, decls'') <- transformPatterns srcloc [pat']
rhs' <- mkGAlts srcloc (attrGuards ++ guards) (concat rnpss) rhs
decls' <- case decls of
BDecls ds -> do ds' <- mapM transformDecl ds
return $ BDecls $ decls'' ++ ds
_ -> error "Cannot bind implicit parameters in the \
\ \'where\' clause of a function using regular patterns."
return $ Alt srcloc pat'' rhs' decls'
where mkGAlts :: SrcLoc -> [Guard] -> [(Name, Pat)] -> GuardedAlts -> HsxM GuardedAlts
mkGAlts s guards rnps (UnGuardedAlt rhs) = do
rhs' <- transformExpM $ addLetDecls s rnps rhs
case guards of
[] -> return $ UnGuardedAlt rhs'
_ -> return $ GuardedAlts [GuardedAlt s (map mkStmtGuard guards) rhs']
mkGAlts s gs rnps (GuardedAlts galts) =
fmap GuardedAlts $ mapM (mkGAlt gs rnps) galts
where mkGAlt :: [Guard] -> [(Name, Pat)] -> GuardedAlt -> HsxM GuardedAlt
mkGAlt gs rnps (GuardedAlt s oldgs rhs) = do
rhs' <- transformExpM $ addLetDecls s rnps rhs
oldgs' <- fmap concat $ mapM (transformStmt GuardStmt) oldgs
return $ GuardedAlt s ((map mkStmtGuard gs) ++ oldgs') rhs'
type Guard = (SrcLoc, Pat, Exp)
mkStmtGuard :: Guard -> Stmt
mkStmtGuard (s, p, e) = genStmt s p e
mkDeclGuard :: Guard -> [Decl] -> Decl
mkDeclGuard (s, p, e) ds = patBindWhere s p e ds
newtype RN a = RN (RNState -> (a, RNState))
type RNState = Int
initRNState = 0
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 = (Name, Pat)
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
PNeg p -> rename1pat p PNeg renameRP
PInfixApp p1 n p2 -> rename2pat p1 p2
(\p1 p2 -> PInfixApp p1 n p2)
renameRP
PApp n ps -> renameNpat ps (PApp n) renameRP
PTuple ps -> renameNpat ps PTuple renameRP
PList ps -> renameNpat ps PList renameRP
PParen p -> rename1pat p PParen renameRP
PRec n pfs -> renameNpat pfs (PRec n) renameRPf
PAsPat n p -> rename1pat p (PAsPat n) renameRP
PIrrPat p -> rename1pat p PIrrPat renameRP
PXPatTag p -> rename1pat p PXPatTag renameRP
PatTypeSig s p t -> rename1pat p (\p -> PatTypeSig s p t) renameRP
_ -> return (p, [])
where renameRPf :: PatField -> RN (PatField, [NameBind])
renameRPf (PFieldPat n p) = rename1pat p (PFieldPat n) renameRP
renameRPf pf = return (pf, [])
renameAttr :: PXAttr -> RN (PXAttr, [NameBind])
renameAttr (PXAttr s p) = rename1pat p (PXAttr 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 (\(s,n,p) -> mkDecl s (n,p)) (concat smss)
in ds' ++ gs
where renameLetDecl :: Decl -> RN (Decl, [(SrcLoc, Name, Pat)])
renameLetDecl d = case d of
PatBind srcloc pat mty rhs decls -> do
(p, ms) <- renameRP pat
let sms = map (\(n,p) -> (srcloc, n, p)) ms
return $ (PatBind srcloc p mty 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 p -> do (q, ms) <- renameRP p
return $ (PIrrPat q, ms)
PNeg p -> rename1pat p PNeg renameIrrP
PInfixApp p1 n p2 -> rename2pat p1 p2
(\p1 p2 -> PInfixApp p1 n p2)
renameIrrP
PApp n ps -> renameNpat ps (PApp n) renameIrrP
PTuple ps -> renameNpat ps PTuple renameIrrP
PList ps -> renameNpat ps PList renameIrrP
PParen p -> rename1pat p PParen renameIrrP
PRec n pfs -> renameNpat pfs (PRec n) renameIrrPf
PAsPat n p -> rename1pat p (PAsPat n) renameIrrP
PatTypeSig s p t -> rename1pat p (\p -> PatTypeSig s p t) renameIrrP
PXTag s 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 s n attrs' mat') renameIrrP
return (q, concat nss ++ ns1 ++ ns)
PXETag s 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 s n as mat', concat nss ++ ns1)
PXPatTag p -> rename1pat p PXPatTag renameIrrP
_ -> return (p, [])
where renameIrrPf :: PatField -> RN (PatField, [NameBind])
renameIrrPf (PFieldPat n p) = rename1pat p (PFieldPat n) renameIrrP
renameIrrPf pf = return (pf, [])
renameIrrAttr :: PXAttr -> RN (PXAttr, [NameBind])
renameIrrAttr (PXAttr s p) = rename1pat p (PXAttr s) renameIrrP
transformPatterns :: SrcLoc -> [Pat] -> HsxM ([Pat], [Guard], [Guard], [Decl])
transformPatterns s ps = runTr (trPatterns s ps)
type State = (Int, Int, Int, [Guard], [Guard], [Decl])
newtype Tr a = Tr (State -> HsxM (a, State))
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 :: SrcLoc -> Pat -> Exp -> Tr ()
pushGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,(s,p,e):gs2,ds))
pushDecl :: Decl -> Tr ()
pushDecl d = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,gs2,d:ds))
pushAttrGuard :: SrcLoc -> Pat -> Exp -> Tr ()
pushAttrGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,(s,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 :: SrcLoc -> [Pat] -> Tr [Pat]
trPatterns s = mapM (trPattern s)
trPattern :: SrcLoc -> Pat -> Tr Pat
trPattern s p = case p of
PRPat rps -> do
n <- genPatName
(mname, vars, _) <- trRPat s True (RPSeq rps)
topmname <- mkTopDecl s mname vars
mkGuard s vars topmname n
setHarpTransformedT
return $ pvar n
PXTag s name attrs mattr cpats -> do
an <- case (mattr, attrs) of
(Just ap, []) -> return $ ap
(_, []) -> return wildcard
(_, _) -> do
n <- genAttrName
mkAttrGuards s n attrs mattr
return $ pvar n
cpat' <- case cpats of
(p@(PXRPats _)):[] -> trPattern s p
_ -> trPattern s (PList cpats)
setHarpTransformedT
let (dom, n) = xNameParts name
return $ metaTag dom n an cpat'
PXETag s name attrs mattr -> do
an <- case (mattr, attrs) of
(Just ap, []) -> return $ ap
(_, []) -> return wildcard
(_, _) -> do
n <- genAttrName
mkAttrGuards s 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 s p
PXRPats rps -> trPattern s $ PRPat rps
PViewPat e p -> do
e' <- liftTr $ transformExpM e
tr1pat p (PViewPat e') (trPattern s)
PVar _ -> return p
PLit _ -> return p
PNeg q -> tr1pat q PNeg (trPattern s)
PInfixApp p1 op p2 -> tr2pat p1 p2 (\p1 p2 -> PInfixApp p1 op p2) (trPattern s)
PApp n ps -> trNpat ps (PApp n) (trPattern s)
PTuple ps -> trNpat ps PTuple (trPattern s)
PList ps -> trNpat ps PList (trPattern s)
PParen p -> tr1pat p PParen (trPattern s)
PRec n pfs -> trNpat pfs (PRec n) (trPatternField s)
PAsPat n p -> tr1pat p (PAsPat n) (trPattern s)
PWildCard -> return p
PIrrPat p -> tr1pat p PIrrPat (trPattern s)
PatTypeSig s p t -> tr1pat p (\p -> PatTypeSig s p t) (trPattern s)
PExplTypeArg _ _ -> return p
PQuasiQuote _ _ -> return p
PBangPat p -> tr1pat p PBangPat (trPattern s)
PNPlusK _ _ -> return p
where
trPatternField :: SrcLoc -> PatField -> Tr PatField
trPatternField s (PFieldPat n p) =
tr1pat p (PFieldPat n) (trPattern s)
trPatternField _ p = return p
xNameParts :: XName -> (Maybe String, String)
xNameParts n = case n of
XName s -> (Nothing, s)
XDomName d s -> (Just d, s)
mkAttrGuards :: SrcLoc -> Name -> [PXAttr] -> Maybe Pat -> Tr ()
mkAttrGuards s attrs [PXAttr n q] mattr = do
let rhs = metaExtract n attrs
pat = metaPJust q
rml = case mattr of
Nothing -> wildcard
Just ap -> ap
pushAttrGuard s (pTuple [pat, rml]) rhs
mkAttrGuards s attrs ((PXAttr a q):xs) mattr = do
let rhs = metaExtract a attrs
pat = metaPJust q
newAttrs <- genAttrName
pushAttrGuard s (pTuple [pat, pvar newAttrs]) rhs
mkAttrGuards s newAttrs xs mattr
mkTopDecl :: SrcLoc -> Name -> [Name] -> Tr Name
mkTopDecl s mname vars =
do
n <- genMatchName
pushDecl $ topDecl s n mname vars
return n
topDecl :: SrcLoc -> Name -> Name -> [Name] -> Decl
topDecl s n mname vs =
let pat = pTuple [wildcard, pvarTuple vs]
g = var mname
a = genStmt s pat g
vars = map (\v -> app (var v) eList) vs
b = qualStmt $ metaReturn $ tuple vars
e = doE [a,b]
in nameBind s n e
mkGuard :: SrcLoc -> [Name] -> Name -> Name -> Tr ()
mkGuard s vars mname n = do
let tvs = pvarTuple vars
ge = appFun runMatchFun [var mname, var n]
pushGuard s (pApp just_name [tvs]) ge
data MType = S
| L MType
| E MType MType
| M MType
type MFunMetaInfo = (Name, [Name], MType)
trRPat :: SrcLoc -> Bool -> RPat -> Tr MFunMetaInfo
trRPat s linear rp = case rp of
RPPat p -> mkBaseDecl s linear p
where
mkBaseDecl :: SrcLoc -> Bool -> Pat -> Tr MFunMetaInfo
mkBaseDecl s linear p = case p of
PWildCard -> mkWCMatch s
PVar v -> mkVarMatch s linear v
PXPatTag q -> mkBaseDecl s linear q
p -> do
(name, vars, _) <- mkBasePat s linear p
newname <- mkBaseMatch s name
return (newname, vars, S)
mkBasePat :: SrcLoc -> Bool -> Pat -> Tr MFunMetaInfo
mkBasePat s b p =
do
n <- genMatchName
let vs = gatherPVars p
basePatDecl s b n vs p >>= pushDecl
return (n, vs, S)
basePatDecl :: SrcLoc -> Bool -> Name -> [Name] -> Pat -> Tr Decl
basePatDecl s linear f vs p = do
let a = Ident $ "harp_a"
rhs <- baseCaseE s linear p a vs
return $ simpleFun s f a rhs
where baseCaseE :: SrcLoc -> Bool -> Pat -> Name -> [Name] -> Tr Exp
baseCaseE s b p a vs = do
let alt1 = alt s p
(app (con just_name) $
tuple (map (retVar b) vs))
alt2 = alt s 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 s linear p gs
where mkGuardDecl :: SrcLoc -> Bool -> Pat -> [Stmt] -> Tr MFunMetaInfo
mkGuardDecl s linear p gs = case p of
PXPatTag q -> mkGuardDecl s linear q gs
p -> do
(name, vars, _) <- mkGuardPat s linear p gs
newname <- mkBaseMatch s name
return (newname, vars, S)
mkGuardPat :: SrcLoc -> Bool -> Pat -> [Stmt] -> Tr MFunMetaInfo
mkGuardPat s b p gs =
do
n <- genMatchName
let vs = gatherPVars p ++ concatMap gatherStmtVars gs
guardPatDecl s b n vs p gs >>= pushDecl
return (n, vs, S)
guardPatDecl :: SrcLoc -> Bool -> Name -> [Name] -> Pat -> [Stmt] -> Tr Decl
guardPatDecl s linear f vs p gs = do
let a = Ident $ "harp_a"
rhs <- guardedCaseE s linear p gs a vs
return $ simpleFun s f a rhs
where guardedCaseE :: SrcLoc -> Bool -> Pat -> [Stmt] -> Name -> [Name] -> Tr Exp
guardedCaseE s b p gs a vs = do
let alt1 = altGW s p gs
(app (con just_name) $
tuple (map (retVar b) vs)) noBinds
alt2 = alt s 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 s linear) rps
mkSeqDecl s nvts
where
mkSeqDecl :: SrcLoc -> [MFunMetaInfo] -> Tr MFunMetaInfo
mkSeqDecl s nvts = do
name <- genMatchName
let
(gs, vals) = unzip $ mkGenExps s 0 nvts
vars = concatMap (\(_,vars,_) -> vars) nvts
fldecls = flattenVals s vals
ret = qualStmt $ metaReturn $
tuple [var retname, varTuple vars]
rhs = doE $ gs ++
[letStmt fldecls, ret]
pushDecl $ nameBind s name rhs
return (name, vars, L S)
flattenVals :: SrcLoc -> [(Name, MType)] -> [Decl]
flattenVals s nts =
let
(nns, ds) = unzip $ map (flVal s) nts
ret = nameBind s retname $ app
(paren $ app foldCompFun
(listE $ map var nns)) $ eList
in ds ++ [ret]
flVal :: SrcLoc -> (Name, MType) -> (Name, Decl)
flVal s (name, mt) =
let
newname = extendVar name "f"
f = flatten mt
in (newname, nameBind s 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 s linear rp
n <- mkCAsDecl s nvt
return (n, (v:vs), mt)
where
mkCAsDecl :: SrcLoc -> MFunMetaInfo -> Tr Name
mkCAsDecl = asDecl $ app consFun
RPAs v rp
| linear ->
do
nvt@(name, vs, mt) <- trRPat s linear rp
n <- mkAsDecl s 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 :: SrcLoc -> MFunMetaInfo -> Tr Name
mkAsDecl = asDecl metaConst
RPParen rp -> trRPat s linear rp
RPOp rp RPOpt->
do
nvt <- trRPat s False rp
mkOptDecl s False nvt
RPOp rp RPOptG ->
do
nvt <- trRPat s False rp
mkOptDecl s True nvt
RPEither rp1 rp2 ->
do
nvt1 <- trRPat s False rp1
nvt2 <- trRPat s False rp2
mkEitherDecl s nvt1 nvt2
where mkEitherDecl :: SrcLoc -> MFunMetaInfo -> MFunMetaInfo -> Tr MFunMetaInfo
mkEitherDecl s nvt1@(_, vs1, t1) nvt2@(_, vs2, t2) = do
n <- genMatchName
let
(g1, v1) = mkGenExp s nvt1
(g2, v2) = mkGenExp s 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 s 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 s False rp
mkStarDecl s False nvt
RPOp rp RPStarG->
do
nvt <- trRPat s False rp
mkStarDecl s True nvt
RPOp rp RPPlus ->
do
nvt <- trRPat s False rp
mkPlusDecl s False nvt
RPOp rp RPPlusG ->
do
nvt <- trRPat s False rp
mkPlusDecl s True nvt
where
mkVarMatch :: SrcLoc -> Bool -> Name -> Tr MFunMetaInfo
mkVarMatch s linear v = do
n <- genMatchName
let e = paren $ lamE s [pvar v] $
app (con just_name)
(paren $ retVar linear v)
pushDecl $ nameBind s 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 :: SrcLoc -> Tr MFunMetaInfo
mkWCMatch s = do
n <- genMatchName
let e = paren $ lamE s [wildcard] $
app (con just_name) unit_con
pushDecl $ nameBind s n $
app baseMatchFun e
return (n, [], S)
gatherPVars :: Pat -> [Name]
gatherPVars p = case p of
PVar v -> [v]
PNeg q -> gatherPVars q
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 :: SrcLoc -> Name -> Tr Name
mkBaseMatch s name =
do
n <- genMatchName
pushDecl $ baseMatchDecl s n name
return n
baseMatchDecl :: SrcLoc -> Name -> Name -> Decl
baseMatchDecl s newname oldname =
let e = app baseMatchFun (var oldname)
in nameBind s newname e
mkGenExps :: SrcLoc -> Int -> [MFunMetaInfo] -> [(Stmt, (Name, MType))]
mkGenExps _ _ [] = []
mkGenExps s k ((name, vars, t):nvs) =
let valname = mkValName k
pat = pTuple [pvar valname, pvarTuple vars]
g = var name
in (genStmt s pat g, (valname, t)) :
mkGenExps s (k+1) nvs
mkGenExp :: SrcLoc -> MFunMetaInfo -> (Stmt, Name)
mkGenExp s nvt = let [(g, (name, _t))] = mkGenExps s 0 [nvt]
in (g, name)
mkManyGen :: SrcLoc -> Bool -> Name -> Stmt
mkManyGen s greedy mname =
let mf = if greedy then gManyMatchFun else manyMatchFun
in genStmt s (pvar valsvarsname) $
app mf (var mname)
asDecl :: (Exp -> Exp) -> SrcLoc -> MFunMetaInfo -> Tr Name
asDecl mf s nvt@(_, vs, _) = do
n <- genMatchName
let
(g, val) = mkGenExp s nvt
vars = map var vs
ret = qualStmt $ metaReturn $ tuple
[var val, tuple $ mf (var val) : vars]
pushDecl $ nameBind s n $ doE [g, ret]
return n
mkOptDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
mkOptDecl s greedy nvt@(_, vs, t) = do
n <- genMatchName
let
(g, val) = mkGenExp s 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 s n rhs
return (n, vs, M t)
mkStarDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
mkStarDecl s greedy (mname, vs, t) = do
n <- genMatchName
let
g = mkManyGen s greedy mname
metaUnzipK = mkMetaUnzip s (length vs)
dec1 = patBind s (pvarTuple [valname, varsname])
(metaUnzip $ var valsvarsname)
dec2 = patBind s (pvarTuple vs)
(metaUnzipK $ var varsname)
retExps = map ((app foldCompFun) . var) vs
ret = metaReturn $ tuple $
[var valname, tuple retExps]
pushDecl $ nameBind s n $
doE [g, letStmt [dec1, dec2], qualStmt ret]
return (n, vs, L t)
mkPlusDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
mkPlusDecl s greedy nvt@(mname, vs, t) = do
n <- genMatchName
let k = length vs
(g1, val1) = mkGenExp s nvt
g2 = mkManyGen s greedy mname
metaUnzipK = mkMetaUnzip s k
dec1 = patBind s
(pvarTuple [valsname, varsname])
(metaUnzip $ var valsvarsname)
vlvars = genNames "harp_vl" k
dec2 = patBind s (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 s 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 :: SrcLoc -> Int -> Exp -> Exp
mkMetaUnzip s 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 s 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 s (pvarTuple lvs) rhs2
exp2 = letE [dec2] ret2
alt2 = alt s pat2 exp2
topexp = lamE s [pvar ys] $ caseE (var ys) [alt1, alt2]
topbind = nameBind s 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 n) s = Ident $ 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 strE d, 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 strE d, 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" [ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))]
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]
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 -> stringTypeSig (strE s)
XDomName d s -> tuple [stringTypeSig $ strE d, stringTypeSig $ strE s]
where
stringTypeSig e = ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))