hsx2hs-0.11.0: src/Language/Haskell/HSX/Transform.hs
-----------------------------------------------------------------------------
-- |
-- Module : Language.Haskell.HSX.Tranform
-- Copyright : (c) Niklas Broberg 2004-2012
-- License : BSD-style (see the file LICENSE.txt)
--
-- Maintainer : Niklas Broberg, niklas.broberg@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- Functions for transforming abstract Haskell code extended with regular
-- patterns into semantically equivalent normal abstract Haskell code. In
-- other words, we transform away regular patterns.
-----------------------------------------------------------------------------
module Language.Haskell.HSX.Transform (
transform -- :: HsModule -> HsModule
, 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)
-----------------------------------------------------------------------------
-- A monad for threading a boolean value through the boilerplate code,
-- to signal whether a transformation has taken place or not.
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
-----------------------------------------------------------------------------
-- Traversing and transforming the syntax tree
-- | Transform away occurences of regular patterns from an abstract
-- Haskell module, preserving semantics.
transform :: Module -> Module
transform (Module s m pragmas warn mes is decls) =
let (decls', (harp, hsx)) = runHsxM $ mapM transformDecl decls
-- We may need to add an import for Match.hs that defines the matcher monad
imps1 = if harp
then (:) $ ImportDecl s match_mod True False Nothing
(Just match_qual_mod)
Nothing
else id
imps2 = {- if hsx
then (:) $ ImportDecl s hsx_data_mod False
Nothing
Nothing
else -} id -- we no longer want to import HSP.Data
in Module s m pragmas warn mes (imps1 $ imps2 is) decls'
-----------------------------------------------------------------------------
-- Declarations
-- | Transform a declaration by transforming subterms that could
-- contain regular patterns.
transformDecl :: Decl -> HsxM Decl
transformDecl d = case d of
-- Pattern binds can contain regular patterns in the pattern being bound
-- as well as on the right-hand side and in declarations in a where clause
PatBind srcloc pat mty rhs decls -> do
-- Preserve semantics of irrefutable regular patterns by postponing
-- their evaluation to a let-expression on the right-hand side
let ([pat'], rnpss) = unzip $ renameIrrPats [pat]
-- Transform the pattern itself
([pat''], attrGuards, guards, decls'') <- transformPatterns srcloc [pat']
-- Transform the right-hand side, and add any generated guards
-- and let expressions to it
rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs
-- Transform declarations in the where clause, adding any generated
-- declarations to it
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'
-- Function binds can contain regular patterns in their matches
FunBind ms -> fmap FunBind $ mapM transformMatch ms
-- Instance declarations can contain regular patterns in the
-- declarations of functions inside it
InstDecl s c n ts idecls ->
fmap (InstDecl s c n ts) $ mapM transformInstDecl idecls
-- Class declarations can contain regular patterns in the
-- declarations of automatically instantiated functions
ClassDecl s c n ns ds cdecls ->
fmap (ClassDecl s c n ns ds) $ mapM transformClassDecl cdecls
-- TH splices are expressions and can contain regular patterns
SpliceDecl srcloc e ->
fmap (SpliceDecl srcloc) $ transformExpM e
-- Type signatures, type, newtype or data declarations, infix declarations,
-- type and data families and instances, foreign imports and exports,
-- and default declarations; none can contain regular patterns.
-- Note that we don't transform inside rules pragmas!
_ -> 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
-- | Transform a function "match" by generating pattern guards and
-- declarations representing regular patterns in the argument list.
-- Subterms, such as guards and the right-hand side, are also traversed
-- transformed.
transformMatch :: Match -> HsxM Match
transformMatch (Match srcloc name pats mty rhs decls) = do
-- Preserve semantics of irrefutable regular patterns by postponing
-- their evaluation to a let-expression on the right-hand side
let (pats', rnpss) = unzip $ renameIrrPats pats
-- Transform the patterns that stand as arguments to the function
(pats'', attrGuards, guards, decls'') <- transformPatterns srcloc pats'
-- Transform the right-hand side, and add any generated guards
-- and let expressions to it
rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs
-- Transform declarations in the where clause, adding any generated
-- declarations to it
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'
-- | Transform and update guards and right-hand side of a function or
-- pattern binding. The supplied list of guards is prepended to the
-- original guards, and subterms are traversed and transformed.
mkRhs :: SrcLoc -> [Guard] -> [(Name, Pat)] -> Rhs -> HsxM Rhs
mkRhs srcloc guards rnps (UnGuardedRhs rhs) = do
-- Add the postponed patterns to the right-hand side by placing
-- them in a let-expression to make them lazily evaluated.
-- Then transform the whole right-hand side as an expression.
rhs' <- transformExpM $ addLetDecls srcloc rnps rhs
case guards of
-- There were no guards before, and none should be added,
-- so we still have an unguarded right-hand side
[] -> return $ UnGuardedRhs rhs'
-- There are guards to add. These should be added as pattern
-- guards, i.e. as statements.
_ -> 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
-- Add the postponed patterns to the right-hand side by placing
-- them in a let-expression to make them lazily evaluated.
-- Then transform the whole right-hand side as an expression.
rhs' <- transformExpM $ addLetDecls s rnps rhs
-- Now there are guards, so first we need to transform those
oldgs' <- fmap concat $ mapM (transformStmt GuardStmt) oldgs
-- ... and then prepend the newly generated ones, as statements
return $ GuardedRhs s ((map mkStmtGuard gs) ++ oldgs') rhs'
-- | Place declarations of postponed regular patterns in a let-expression to
-- make them lazy, in order to make them behave as irrefutable patterns.
addLetDecls :: SrcLoc -> [(Name, Pat)] -> Exp -> Exp
addLetDecls s [] e = e -- no declarations to add
addLetDecls s rnps e =
-- Place all postponed patterns in the same let-expression
letE (map (mkDecl s) rnps) e
-- | Make pattern binds from postponed regular patterns
mkDecl :: SrcLoc -> (Name, Pat) -> Decl
mkDecl srcloc (n,p) = patBind srcloc p (var n)
------------------------------------------------------------------------------------
-- Expressions
-- | Transform expressions by traversing subterms.
-- Of special interest are expressions that contain patterns as subterms,
-- i.e. @let@, @case@ and lambda expressions, and also list comprehensions
-- and @do@-expressions. All other expressions simply transform their
-- sub-expressions, if any.
-- Of special interest are of course also any xml expressions.
transformExp :: Exp -> Exp
transformExp e =
let (e', _) = runHsxM $ transformExpM e
in e'
-- | Transform expressions by traversing subterms.
-- Of special interest are expressions that contain patterns as subterms,
-- i.e. @let@, @case@ and lambda expressions, and also list comprehensions
-- and @do@-expressions. All other expressions simply transform their
-- sub-expressions, if any.
-- Of special interest are of course also any xml expressions.
transformExpM :: Exp -> HsxM Exp
transformExpM e = case e of
-- A standard xml tag should be transformed into an element of the
-- XML datatype. Attributes should be made into a set of mappings,
-- and children should be transformed.
XTag _ name attrs mattr cs -> do
-- Hey Pluto, look, we have XML in our syntax tree!
setXmlTransformed
let -- ... make tuples of the attributes
as = map mkAttr attrs
-- ... transform the children
cs' <- mapM transformChild cs
-- ... and lift the values into the XML datatype.
return $ paren $ metaGenElement name as mattr cs'
-- An empty xml tag should be transformed just as a standard tag,
-- only that there are no children,
XETag _ name attrs mattr -> do
-- ... 'tis the season to be jolly, falalalalaaaa....
setXmlTransformed
let -- ... make tuples of the attributes
as = map mkAttr attrs
-- ... and lift the values into the XML datatype.
return $ paren $ metaGenEElement name as mattr
-- A child tag should be transformed into an application
-- of asChild to a list of children.
XChildTag _ cs -> do
-- After all, it IS christmas!
setXmlTransformed
-- ... transform the children
cs' <- mapM transformChild cs
-- ... and make them into a list
return $ paren $ metaAsChild $ listE cs'
-- PCDATA should be lifted as a string into the XML datatype.
XPcdata pcdata -> do setXmlTransformed
return $ ExpTypeSig noLoc (strE pcdata) (TyCon (UnQual (Ident "String")))
-- Escaped expressions should be treated as just expressions.
XExpTag e -> do setXmlTransformed
e' <- transformExpM e
return $ paren $ metaAsChild e'
-- Patterns as arguments to a lambda expression could be regular,
-- but we cannot put the evaluation here since a lambda expression
-- can have neither guards nor a where clause. Thus we must postpone
-- them to a case expressions on the right-hand side.
Lambda s pats rhs -> do
let -- First rename regular patterns
(ps, rnpss) = unzip $ renameRPats pats
-- ... group them up to one big tuple
(rns, rps) = unzip (concat rnpss)
alt1 = alt s (pTuple rps) rhs
texp = varTuple rns
-- ... and put it all in a case expression, which
-- can then be transformed in the normal way.
e = if null rns then rhs else caseE texp [alt1]
rhs' <- transformExpM e
return $ Lambda s ps rhs'
-- A let expression can contain regular patterns in the declarations,
-- or in the expression that makes up the body of the let.
Let (BDecls ds) e -> do
-- Declarations appearing in a let expression must be transformed
-- in a special way due to scoping, see later documentation.
-- The body is transformed as a normal expression.
ds' <- transformLetDecls ds
e' <- transformExpM e
return $ letE ds' e'
-- Bindings of implicit parameters can appear either in ordinary let
-- expressions (GHC), in dlet expressions (Hugs) or in a with clause
-- (both). Such bindings are transformed in a special way. The body
-- is transformed as a normal expression in all cases.
Let (IPBinds is) e -> do
is' <- mapM transformIPBind is
e' <- transformExpM e
return $ Let (IPBinds is') e'
-- A case expression can contain regular patterns in the expression
-- that is the subject of the casing, or in either of the alternatives.
Case e alts -> do
e' <- transformExpM e
alts' <- mapM transformAlt alts
return $ Case e' alts'
-- A do expression can contain regular patterns in its statements.
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'
-- A list comprehension can contain regular patterns in the result
-- expression, or in any of its statements.
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 -- First rename regular patterns
([p], [rnps]) = unzip $ renameRPats [pat]
-- ... group them up to one big tuple
(rns, rps) = unzip rnps
alt1 = alt s (pTuple rps) rhs
texp = varTuple rns
-- ... and put it all in a case expression, which
-- can then be transformed in the normal way.
e = if null rns then rhs else caseE texp [alt1]
rhs' <- transformExpM e
return $ Proc s p rhs'
-- All other expressions simply transform their immediate subterms.
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 -- Warning - will not work inside TH brackets!
where
-- | Transform expressions appearing in child position of an xml tag.
-- Expressions are first transformed, then wrapped in a call to
-- @toXml@.
transformChild :: Exp -> HsxM Exp
transformChild e = do
-- Transform the expression
te <- transformExpM e
-- ... and apply the overloaded toXMLs to it
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
-- | Transform pattern bind declarations inside a @let@-expression by transforming
-- subterms that could appear as regular patterns, as well as transforming the bound
-- pattern itself. The reason we need to do this in a special way is scoping, i.e.
-- in the expression @let a | Just b <- match a = list in b@ the variable b will not
-- be in scope after the @in@. And besides, we would be on thin ice even if it was in
-- scope since we are referring to the pattern being bound in the guard that will
-- decide if the pattern will be bound... yikes, why does Haskell allow guards on
-- pattern binds to refer to the patterns being bound, could that ever lead to anything
-- but an infinite loop??
transformLetDecls :: [Decl] -> HsxM [Decl]
transformLetDecls ds = do
-- We need to rename regular patterns in pattern bindings, since we need to
-- separate the generated declaration sets. This since we need to add them not
-- to the actual binding but rather to the declaration that will be the guard
-- of the binding.
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
-- We need to transform all pattern bindings in a set of
-- declarations in the same context w.r.t. generating fresh
-- variable names, since they will all be in scope at the same time.
([pat'], ags, gs, ws, k', l') <- runTrFromTo k l (trPatterns srcloc [pat])
decls' <- case decls of
-- Any declarations already in place should be left where they
-- are since they probably refer to the generating right-hand
-- side of the pattern bind. If they don't, we're in trouble...
BDecls decls -> fmap BDecls $ transformLetDecls decls
-- If they are implicit parameter bindings we simply transform
-- them as such.
IPBinds decls -> fmap IPBinds $ mapM transformIPBind decls
-- The generated guard, if any, should be a declaration, and the
-- generated declarations should be associated with it.
let gs' = case gs of
[] -> []
[g] -> [mkDeclGuard g ws]
_ -> error "This should not happen since we have called renameLetDecls already!"
-- Generated attribute guards should also be added as declarations,
-- but with no where clauses.
ags' = map (flip mkDeclGuard $ []) ags
-- We must transform the right-hand side as well, but there are
-- no new guards, nor any postponed patterns, to supply at this time.
rhs' <- mkRhs srcloc [] [] rhs
-- ... and then we should recurse with the new gensym argument.
ds' <- transformLDs k' l' ds
-- The generated guards, which should be at most one, should be
-- added as declarations rather than as guards due to the
-- scoping issue described above.
return $ (PatBind srcloc pat' mty rhs' decls') : ags' ++ gs' ++ ds'
-- We only need to treat pattern binds separately, other declarations
-- can be transformed normally.
d -> do d' <- transformDecl d
ds' <- transformLDs k l ds
return $ d':ds'
-- | Transform binding of implicit parameters by transforming the expression on the
-- right-hand side. The left-hand side can only be an implicit parameter, so no
-- regular patterns there...
transformIPBind :: IPBind -> HsxM IPBind
transformIPBind (IPBind s n e) =
fmap (IPBind s n) $ transformExpM e
------------------------------------------------------------------------------------
-- Statements of various kinds
-- | A simple annotation datatype for statement contexts.
data StmtType = DoStmt | GuardStmt | ListCompStmt
-- | Transform statements by traversing and transforming subterms.
-- Since generator statements have slightly different semantics
-- depending on their context, statements are annotated with their
-- context to ensure that the semantics of the resulting statement
-- sequence is correct. The return type is a list since generated
-- guards will be added as statements on the same level as the
-- statement to be transformed.
transformStmt :: StmtType -> Stmt -> HsxM [Stmt]
transformStmt t s = case s of
-- Generators can have regular patterns in the result pattern on the
-- left-hand side and in the generating expression.
Generator s p e -> do
let -- We need to treat generated guards differently depending
-- on the context of the statement.
guardFun = case t of
DoStmt -> monadify
ListCompStmt -> monadify
GuardStmt -> mkStmtGuard
-- Preserve semantics of irrefutable regular patterns by postponing
-- their evaluation to a let-expression on the right-hand side
([p'], rnpss) = unzip $ renameIrrPats [p]
-- Transform the pattern itself
([p''], ags, gs, ds) <- transformPatterns s [p']
-- Put the generated declarations in a let-statement
let lt = case ds of
[] -> []
_ -> [letStmt ds]
-- Perform the designated trick on the generated guards.
gs' = map guardFun (ags ++ gs)
-- Add the postponed patterns to the right-hand side by placing
-- them in a let-expression to make them lazily evaluated.
-- Then transform the whole right-hand side as an expression.
e' <- transformExpM $ addLetDecls s (concat rnpss) e
return $ Generator s p'' e':lt ++ gs'
where monadify :: Guard -> Stmt
-- To monadify is to create a statement guard, only that the
-- generation must take place in a monad, so we need to "return"
-- the value gotten from the guard.
monadify (s,p,e) = genStmt s p (metaReturn $ paren e)
-- Qualifiers are simply wrapped expressions and are treated as such.
Qualifier e -> fmap (\e -> [Qualifier $ e]) $ transformExpM e
-- Let statements suffer from the same problem as let expressions, so
-- the declarations should be treated in the same special way.
LetStmt (BDecls ds) ->
fmap (\ds -> [letStmt ds]) $ transformLetDecls ds
-- If the bindings are of implicit parameters we simply transform them as such.
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
-- For qual statments in list comprehensions we just pass on the baton
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
------------------------------------------------------------------------------------------
-- Case alternatives
-- | Transform alternatives in a @case@-expression. Patterns are
-- transformed, while other subterms are traversed further.
transformAlt :: Alt -> HsxM Alt
transformAlt (Alt srcloc pat rhs decls) = do
-- Preserve semantics of irrefutable regular patterns by postponing
-- their evaluation to a let-expression on the right-hand side
let ([pat'], rnpss) = unzip $ renameIrrPats [pat]
-- Transform the pattern itself
([pat''], attrGuards, guards, decls'') <- transformPatterns srcloc [pat']
-- Transform the right-hand side, and add any generated guards
-- and let expressions to it.
rhs' <- mkGAlts srcloc (attrGuards ++ guards) (concat rnpss) rhs
-- Transform declarations in the where clause, adding any generated
-- declarations to it.
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'
-- Transform and update guards and right-hand side of a case-expression.
-- The supplied list of guards is prepended to the original guards, and
-- subterms are traversed and transformed.
where mkGAlts :: SrcLoc -> [Guard] -> [(Name, Pat)] -> GuardedAlts -> HsxM GuardedAlts
mkGAlts s guards rnps (UnGuardedAlt rhs) = do
-- Add the postponed patterns to the right-hand side by placing
-- them in a let-expression to make them lazily evaluated.
-- Then transform the whole right-hand side as an expression.
rhs' <- transformExpM $ addLetDecls s rnps rhs
case guards of
-- There were no guards before, and none should be added,
-- so we still have an unguarded right-hand side
[] -> return $ UnGuardedAlt rhs'
-- There are guards to add. These should be added as pattern
-- guards, i.e. as statements.
_ -> 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
-- Add the postponed patterns to the right-hand side by placing
-- them in a let-expression to make them lazily evaluated.
-- Then transform the whole right-hand side as an expression.
rhs' <- transformExpM $ addLetDecls s rnps rhs
-- Now there are guards, so first we need to transform those
oldgs' <- fmap concat $ mapM (transformStmt GuardStmt) oldgs
-- ... and then prepend the newly generated ones, as statements
return $ GuardedAlt s ((map mkStmtGuard gs) ++ oldgs') rhs'
----------------------------------------------------------------------------------
-- Guards
-- In some places, a guard will be a declaration instead of the
-- normal statement, so we represent it in a generic fashion.
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
----------------------------------------------------------------------------------
-- Rewriting expressions before transformation.
-- Done in a monad for gensym capability.
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)
-- Some generic functions on monads for traversing subterms
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)
-- | Generate variables as placeholders for any regular patterns, in order
-- to place their evaluation elsewhere. We must likewise move the evaluation
-- of Tags because attribute lookups are force evaluation.
renameRPats :: [Pat] -> [(Pat, [NameBind])]
renameRPats ps = runRename $ mapM renameRP ps
renameRP :: Pat -> RN (Pat, [NameBind])
renameRP p = case p of
-- We must rename regular patterns and Tag expressions
PRPat _ -> rename p
PXTag _ _ _ _ _ -> rename p
PXETag _ _ _ _ -> rename p
-- The rest of the rules simply try to rename regular patterns in
-- their immediate subpatterns.
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 -- Generate a fresh variable
n <- genVarName
-- ... and return that, along with the association of
-- the variable with the old pattern
return (pvar n, [(n,p)])
-- | Rename declarations appearing in @let@s or @where@ clauses.
renameLetDecls :: [Decl] -> [Decl]
renameLetDecls ds =
let -- Rename all regular patterns bound in pattern bindings.
(ds', smss) = unzip $ runRename $ mapM renameLetDecl ds
-- ... and then generate declarations for the associations
gs = map (\(s,n,p) -> mkDecl s (n,p)) (concat smss)
-- ... which should be added to the original list of declarations.
in ds' ++ gs
where renameLetDecl :: Decl -> RN (Decl, [(SrcLoc, Name, Pat)])
renameLetDecl d = case d of
-- We need only bother about pattern bindings.
PatBind srcloc pat mty rhs decls -> do
-- Rename any regular patterns that appear in the
-- pattern being bound.
(p, ms) <- renameRP pat
let sms = map (\(n,p) -> (srcloc, n, p)) ms
return $ (PatBind srcloc p mty rhs decls, sms)
_ -> return (d, [])
-- | Move irrefutable regular patterns into a @let@-expression instead,
-- to make sure that the semantics of @~@ are preserved.
renameIrrPats :: [Pat] -> [(Pat, [NameBind])]
renameIrrPats ps = runRename (mapM renameIrrP ps)
renameIrrP :: Pat -> RN (Pat, [(Name, Pat)])
renameIrrP p = case p of
-- We should rename any regular pattern appearing
-- inside an irrefutable pattern.
PIrrPat p -> do (q, ms) <- renameRP p
return $ (PIrrPat q, ms)
-- The rest of the rules simply try to rename regular patterns in
-- irrefutable patterns in their immediate subpatterns.
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
-- Hsx
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
-- End Hsx
_ -> 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
-----------------------------------------------------------------------------------
-- Transforming Patterns: the real stuff
-- | Transform several patterns in the same context, thereby
-- generating any code for matching regular patterns.
transformPatterns :: SrcLoc -> [Pat] -> HsxM ([Pat], [Guard], [Guard], [Decl])
transformPatterns s ps = runTr (trPatterns s ps)
---------------------------------------------------
-- The transformation monad
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')
-- manipulating the state
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
-- specific state manipulating functions
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
-------------------------------------------------------------------
-- Some generic functions for computations in the Tr monad. Could
-- be made even more general, but there's really no point right now...
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
-----------------------------------------------------------------------------
-- The *real* transformations
-- Transforming patterns
-- | Transform several patterns in the same context
trPatterns :: SrcLoc -> [Pat] -> Tr [Pat]
trPatterns s = mapM (trPattern s)
-- | Transform a pattern by traversing the syntax tree.
-- A regular pattern is translated, other patterns are
-- simply left as is.
trPattern :: SrcLoc -> Pat -> Tr Pat
trPattern s p = case p of
-- This is where the fun starts. =)
-- Regular patterns must be transformed of course.
PRPat rps -> do
-- First we need a name for the placeholder pattern.
n <- genPatName
-- A top-level regular pattern is a sequence in linear
-- context, so we can simply translate it as if it was one.
(mname, vars, _) <- trRPat s True (RPSeq rps)
-- Generate a top level declaration.
topmname <- mkTopDecl s mname vars
-- Generate a pattern guard for this regular pattern,
-- that will match the generated declaration to the
-- value of the placeholder, and bind all variables.
mkGuard s vars topmname n
-- And indeed, we have made a transformation!
setHarpTransformedT
-- Return the placeholder pattern.
return $ pvar n
-- Tag patterns should be transformed
PXTag s name attrs mattr cpats -> do
-- We need a name for the attribute list, if there are lookups
an <- case (mattr, attrs) of
-- ... if there is one already, and there are no lookups
-- we can just return that
(Just ap, []) -> return $ ap
-- ... if there are none, we dont' care
(_, []) -> return wildcard
(_, _) -> do -- ... but if there are, we want a name for that list
n <- genAttrName
-- ... we must turn attribute lookups into guards
mkAttrGuards s n attrs mattr
-- ... and we return the pattern
return $ pvar n
-- ... the pattern representing children should be transformed
cpat' <- case cpats of
-- ... it's a regular pattern, so we can just go ahead and transform it
(p@(PXRPats _)):[] -> trPattern s p
-- ... it's an ordinary list, so we first wrap it up as such
_ -> trPattern s (PList cpats)
-- ... we have made a transformation and should report that
setHarpTransformedT
-- ... and we return a Tag pattern.
let (dom, n) = xNameParts name
return $ metaTag dom n an cpat'
-- ... as should empty Tag patterns
PXETag s name attrs mattr -> do
-- We need a name for the attribute list, if there are lookups
an <- case (mattr, attrs) of
-- ... if there is a pattern already, and there are no lookups
-- we can just return that
(Just ap, []) -> return $ ap
-- ... if there are none, we dont' care
(_, []) -> return wildcard
(_, _) -> do -- ... but if there are, we want a name for that list
n <- genAttrName
-- ... we must turn attribute lookups into guards
mkAttrGuards s n attrs mattr
-- ... and we return the pattern
return $ pvar n
-- ... we have made a transformation and should report that
setHarpTransformedT
-- ... and we return an ETag pattern.
let (dom, n) = xNameParts name
return $ metaTag dom n an peList
-- PCDATA patterns are strings in the xml datatype.
PXPcdata st -> setHarpTransformedT >> (return $ metaPcdata st)
-- XML comments are likewise just treated as strings.
PXPatTag p -> setHarpTransformedT >> trPattern s p
-- Regular expression patterns over children should be translated
-- just like PRPat.
PXRPats rps -> trPattern s $ PRPat rps
-- Transforming any other patterns simply means transforming
-- their subparts.
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 -- Transform a pattern field.
trPatternField :: SrcLoc -> PatField -> Tr PatField
trPatternField s (PFieldPat n p) =
tr1pat p (PFieldPat n) (trPattern s)
trPatternField _ p = return p
-- Deconstruct an xml tag name into its parts.
xNameParts :: XName -> (Maybe String, String)
xNameParts n = case n of
XName s -> (Nothing, s)
XDomName d s -> (Just d, s)
-- | Generate a guard for looking up xml attributes.
mkAttrGuards :: SrcLoc -> Name -> [PXAttr] -> Maybe Pat -> Tr ()
mkAttrGuards s attrs [PXAttr n q] mattr = do
-- Apply lookupAttr to the attribute name and
-- attribute set
let rhs = metaExtract n attrs
-- ... catch the result
pat = metaPJust q
-- ... catch the remainder list
rml = case mattr of
Nothing -> wildcard
Just ap -> ap
-- ... and add the generated guard to the store.
pushAttrGuard s (pTuple [pat, rml]) rhs
mkAttrGuards s attrs ((PXAttr a q):xs) mattr = do
-- Apply lookupAttr to the attribute name and
-- attribute set
let rhs = metaExtract a attrs
-- ... catch the result
pat = metaPJust q
-- ... catch the remainder list
newAttrs <- genAttrName
-- ... and add the generated guard to the store.
pushAttrGuard s (pTuple [pat, pvar newAttrs]) rhs
-- ... and finally recurse
mkAttrGuards s newAttrs xs mattr
-- | Generate a declaration at top level that will finalise all
-- variable continuations, and then return all bound variables.
mkTopDecl :: SrcLoc -> Name -> [Name] -> Tr Name
mkTopDecl s mname vars =
do -- Give the match function a name
n <- genMatchName
-- Create the declaration and add it to the store.
pushDecl $ topDecl s n mname vars
-- Return the name of the match function so that the
-- guard that will be generated can call it.
return n
topDecl :: SrcLoc -> Name -> Name -> [Name] -> Decl
topDecl s n mname vs =
let pat = pTuple [wildcard, pvarTuple vs] -- (_, (foo, bar, ...))
g = var mname -- harp_matchX
a = genStmt s pat g -- (_, (foo, ...)) <- harp_matchX
vars = map (\v -> app (var v) eList) vs -- (foo [], bar [], ...)
b = qualStmt $ metaReturn $ tuple vars -- return (foo [], bar [], ...)
e = doE [a,b] -- do (...) <- harp_matchX
-- return (foo [], bar [], ...)
in nameBind s n e -- harp_matchY = do ....
-- | Generate a pattern guard that will apply the @runMatch@
-- function on the top-level match function and the input list,
-- thereby binding all variables.
mkGuard :: SrcLoc -> [Name] -> Name -> Name -> Tr ()
mkGuard s vars mname n = do
let tvs = pvarTuple vars -- (foo, bar, ...)
ge = appFun runMatchFun [var mname, var n] -- runMatch harp_matchX harp_patY
pushGuard s (pApp just_name [tvs]) ge -- Just (foo, bar, ...) , runMatch ...
--------------------------------------------------------------------------------
-- Transforming regular patterns
-- | A simple datatype to annotate return values from sub-patterns
data MType = S -- Single element
| L MType -- List of ... , (/ /), *, +
| E MType MType -- Either ... or ... , ( | )
| M MType -- Maybe ... , ?
-- When transforming a regular sub-pattern, we need to know the
-- name of the function generated to match it, the names of all
-- variables it binds, and the type of its returned value.
type MFunMetaInfo = (Name, [Name], MType)
-- | Transform away a regular pattern, generating code
-- to replace it.
trRPat :: SrcLoc -> Bool -> RPat -> Tr MFunMetaInfo
trRPat s linear rp = case rp of
-- For an ordinary Haskell pattern we need to generate a
-- base match function for the pattern, and a declaration
-- that lifts that function into the matcher monad.
RPPat p -> mkBaseDecl s linear p
where
-- | Generate declarations for matching ordinary Haskell patterns
mkBaseDecl :: SrcLoc -> Bool -> Pat -> Tr MFunMetaInfo
mkBaseDecl s linear p = case p of
-- We can simplify a lot if the pattern is a wildcard or a variable
PWildCard -> mkWCMatch s
PVar v -> mkVarMatch s linear v
-- ... and if it is an embedded pattern tag, we can just skip it
PXPatTag q -> mkBaseDecl s linear q
-- ... otherwise we'll have to take the long way...
p -> do -- First do a case match on a single element
(name, vars, _) <- mkBasePat s linear p
-- ... apply baseMatch to the case matcher to
-- lift it into the matcher monad.
newname <- mkBaseMatch s name
-- ... and return the meta-info gathered.
return (newname, vars, S)
-- | Generate a basic function that cases on a single element,
-- returning Just (all bound variables) on a match, and
-- Nothing on a mismatch.
mkBasePat :: SrcLoc -> Bool -> Pat -> Tr MFunMetaInfo
mkBasePat s b p =
do -- First we need a name...
n <- genMatchName
-- ... and then we need to know what variables that
-- will be bound by this match.
let vs = gatherPVars p
-- ... and then we can create and store away a casing function.
basePatDecl s b n vs p >>= pushDecl
return (n, vs, S)
-- | Generate a basic casing function for a given pattern.
basePatDecl :: SrcLoc -> Bool -> Name -> [Name] -> Pat -> Tr Decl
basePatDecl s linear f vs p = do
-- We can use the magic variable harp_a since nothing else needs to
-- be in scope at this time (we could use just a, or foo, or whatever)
let a = Ident $ "harp_a"
-- ... and we should case on that variable on the right-hand side.
rhs <- baseCaseE s linear p a vs -- case harp_a of ...
-- The result is a simple function with one paramenter and
-- the right-hand side we just generated.
return $ simpleFun s f a rhs
where baseCaseE :: SrcLoc -> Bool -> Pat -> Name -> [Name] -> Tr Exp
baseCaseE s b p a vs = do
-- First the alternative if we actually
-- match the given pattern
let alt1 = alt s p -- foo -> Just (mf foo)
(app (con just_name) $
tuple (map (retVar b) vs))
-- .. and finally an alternative for not matching the pattern.
alt2 = alt s wildcard (con nothing_name) -- _ -> Nothing
-- ... and that pattern could itself contain regular patterns
-- so we must transform away these.
alt1' <- liftTr $ transformAlt alt1
return $ caseE (var a) [alt1', alt2]
retVar :: Bool -> Name -> Exp
retVar linear v
-- if bound in linear context, apply const
| linear = metaConst (var v)
-- if bound in non-linear context, apply (:)
| otherwise = app consFun (var v)
-- For guarded base patterns, we want to do the same as for unguarded base patterns,
-- only with guards (doh).
RPGuard p gs -> mkGuardDecl s linear p gs
where mkGuardDecl :: SrcLoc -> Bool -> Pat -> [Stmt] -> Tr MFunMetaInfo
mkGuardDecl s linear p gs = case p of
-- If it is an embedded pattern tag, we want to skip it
PXPatTag q -> mkGuardDecl s linear q gs
-- ... otherwise we'll want to make a base pattern
p -> do -- First do a case match on a single element
(name, vars, _) <- mkGuardPat s linear p gs
-- ... apply baseMatch to the case matcher to
-- lift it into the matcher monad.
newname <- mkBaseMatch s name
-- ... and return the meta-info gathered.
return (newname, vars, S)
-- | Generate a basic function that cases on a single element,
-- returning Just (all bound variables) on a match, and
-- Nothing on a mismatch.
mkGuardPat :: SrcLoc -> Bool -> Pat -> [Stmt] -> Tr MFunMetaInfo
mkGuardPat s b p gs =
do -- First we need a name...
n <- genMatchName
-- ... and then we need to know what variables that
-- will be bound by this match.
let vs = gatherPVars p ++ concatMap gatherStmtVars gs
-- ... and then we can create and store away a casing function.
guardPatDecl s b n vs p gs >>= pushDecl
return (n, vs, S)
-- | Generate a basic casing function for a given pattern.
guardPatDecl :: SrcLoc -> Bool -> Name -> [Name] -> Pat -> [Stmt] -> Tr Decl
guardPatDecl s linear f vs p gs = do
-- We can use the magic variable harp_a since nothing else needs to
-- be in scope at this time (we could use just a, or foo, or whatever)
let a = Ident $ "harp_a"
-- ... and we should case on that variable on the right-hand side.
rhs <- guardedCaseE s linear p gs a vs -- case harp_a of ...
-- The result is a simple function with one parameter and
-- the right-hand side we just generated.
return $ simpleFun s f a rhs
where guardedCaseE :: SrcLoc -> Bool -> Pat -> [Stmt] -> Name -> [Name] -> Tr Exp
guardedCaseE s b p gs a vs = do
-- First the alternative if we actually
-- match the given pattern
let alt1 = altGW s p gs -- foo -> Just (mf foo)
(app (con just_name) $
tuple (map (retVar b) vs)) noBinds
-- .. and finally an alternative for not matching the pattern.
alt2 = alt s wildcard (con nothing_name) -- _ -> Nothing
-- ... and that pattern could itself contain regular patterns
-- so we must transform away these.
alt1' <- liftTr $ transformAlt alt1
return $ caseE (var a) [alt1', alt2]
retVar :: Bool -> Name -> Exp
retVar linear v
-- if bound in linear context, apply const
| linear = metaConst (var v)
-- if bound in non-linear context, apply (:)
| otherwise = app consFun (var v)
-- For a sequence of regular patterns, we should transform all
-- sub-patterns and then generate a function for sequencing them.
RPSeq rps -> do
nvts <- mapM (trRPat s linear) rps
mkSeqDecl s nvts
where
-- | Generate a match function for a sequence of regular patterns,
-- flattening any special sub-patterns into normal elements of the list
mkSeqDecl :: SrcLoc -> [MFunMetaInfo] -> Tr MFunMetaInfo
mkSeqDecl s nvts = do
-- First, as always, we need a name...
name <- genMatchName
let -- We need a generating statement for each sub-pattern.
(gs, vals) = unzip $ mkGenExps s 0 nvts -- (harp_valX, (foo, ...)) <- harp_matchY
-- Gather up all variables from all sub-patterns.
vars = concatMap (\(_,vars,_) -> vars) nvts
-- ... flatten all values to simple lists, and concatenate
-- the lists to a new return value
fldecls = flattenVals s vals -- harp_valXf = $flatten harp_valX
-- harp_ret = foldComp [harp_val1f, ...]
-- ... return the value along with all variables
ret = qualStmt $ metaReturn $ -- return (harp_ret, (foo, .....))
tuple [var retname, varTuple vars]
-- ... do all these steps in a do expression
rhs = doE $ gs ++ -- do (harp_valX, (foo, ...)) <- harpMatchY
[letStmt fldecls, ret] -- let harp_valXf = $flatten harp_valX
-- return (harp_ret, (foo, .....))
-- ... bind it to its name, and add the declaration
-- to the store.
pushDecl $ nameBind s name rhs -- harp_matchZ = do ....
-- The return value of a sequence is always a list of elements.
return (name, vars, L S)
-- | Flatten values of all sub-patterns into normal elements of the list
flattenVals :: SrcLoc -> [(Name, MType)] -> [Decl]
flattenVals s nts =
let -- Flatten the values of all sub-patterns to
-- lists of elements
(nns, ds) = unzip $ map (flVal s) nts
-- ... and concatenate their results.
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 -- We reuse the old names, we just extend them a bit.
newname = extendVar name "f" -- harp_valXf
-- Create the appropriate flattening function depending
-- on the type of the value
f = flatten mt
-- ... apply it to the value and bind it to its new name.
in (newname, nameBind s newname $ -- harp_valXf = $flatten harp_valX
app f (var name))
-- | Generate a flattening function for a given type structure.
flatten :: MType -> Exp
flatten S = consFun -- (:)
flatten (L mt) =
let f = flatten mt
r = paren $ metaMap [f]
in paren $ foldCompFun `metaComp` r -- (foldComp . (map $flatten))
flatten (E mt1 mt2) =
let f1 = flatten mt1
f2 = flatten mt2
in paren $ metaEither f1 f2 -- (either $flatten $flatten)
flatten (M mt) =
let f = flatten mt
in paren $ metaMaybe idFun f -- (maybe id $flatten)
-- For accumulating as-patterns we should transform the subpattern, and then generate
-- a declaration that supplies the value to be bound to the variable in question.
-- The variable should be bound non-linearly.
RPCAs v rp -> do
-- Transform the subpattern
nvt@(name, vs, mt) <- trRPat s linear rp
-- ... and create a declaration to bind its value.
n <- mkCAsDecl s nvt
-- The type of the value is unchanged.
return (n, (v:vs), mt)
where
-- | Generate a declaration for a \@: binding.
mkCAsDecl :: SrcLoc -> MFunMetaInfo -> Tr Name
mkCAsDecl = asDecl $ app consFun -- should become lists when applied to []
-- For ordinary as-patterns we should transform the subpattern, and then generate
-- a declaration that supplies the value to be bound to the variable in question.
-- The variable should be bound linearly.
RPAs v rp
| linear ->
do -- Transform the subpattern
nvt@(name, vs, mt) <- trRPat s linear rp
-- ... and create a declaration to bind its value
n <- mkAsDecl s nvt
-- The type of the value is unchanged.
return (n, (v:vs), mt)
-- We may not use an @ bind in non-linear context
| 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
-- | Generate a declaration for a \@ binding.
mkAsDecl :: SrcLoc -> MFunMetaInfo -> Tr Name
mkAsDecl = asDecl metaConst -- should be constant when applied to []
-- For regular patterns, parentheses have no real meaning
-- so at this point we can just skip them.
RPParen rp -> trRPat s linear rp
-- For (possibly non-greedy) optional regular patterns we need to
-- transform the subpattern, and the generate a function that can
-- choose to match or not to match, that is the question...
RPOp rp RPOpt->
do -- Transform the subpattern
nvt <- trRPat s False rp
-- ... and create a declaration that can optionally match it.
mkOptDecl s False nvt
-- ... similarly for the non-greedy version.
RPOp rp RPOptG ->
do -- Transform the subpattern
nvt <- trRPat s False rp
-- ... and create a declaration that can optionally match it.
mkOptDecl s True nvt
-- For union patterns, we should transform both subexpressions,
-- and generate a function that chooses between them.
RPEither rp1 rp2 ->
do -- Transform the subpatterns
nvt1 <- trRPat s False rp1
nvt2 <- trRPat s False rp2
-- ... and create a declaration that can choose between them.
mkEitherDecl s nvt1 nvt2
-- Generate declarations for either patterns, i.e. ( | )
where mkEitherDecl :: SrcLoc -> MFunMetaInfo -> MFunMetaInfo -> Tr MFunMetaInfo
mkEitherDecl s nvt1@(_, vs1, t1) nvt2@(_, vs2, t2) = do
-- Eine namen, bitte!
n <- genMatchName
let -- Generate generators for the subpatterns
(g1, v1) = mkGenExp s nvt1
(g2, v2) = mkGenExp s nvt2 -- (harp_valX, (foo, bar, ...)) <- harp_matchY
-- ... gather all variables from both sides
allvs = vs1 `union` vs2
-- ... some may be bound on both sides, so we
-- need to check which ones are bound on each,
-- supplying empty value for those that are not
vals1 = map (varOrId vs1) allvs
vals2 = map (varOrId vs2) allvs
-- ... apply either Left or Right to the returned value
ret1 = metaReturn $ tuple -- return (Left harp_val1, (foo, id, ...))
[app (con left_name)
(var v1), tuple vals1]
ret2 = metaReturn $ tuple -- return (Right harp_val2, (id, bar, ...))
[app (con right_name)
(var v2), tuple vals2]
-- ... and do all these things in do-expressions
exp1 = doE [g1, qualStmt ret1]
exp2 = doE [g2, qualStmt ret2]
-- ... and choose between them using the choice (+++) operator.
rhs = (paren exp1) `metaChoice` -- (do ...) +++
(paren exp2) -- (do ...)
-- Finally we create a declaration for this function and
-- add it to the store.
pushDecl $ nameBind s n rhs -- harp_matchZ = (do ...) ...
-- The type of the returned value is Either the type of the first
-- or the second subpattern.
return (n, allvs, E t1 t2)
varOrId :: [Name] -> Name -> Exp
varOrId vs v = if v `elem` vs -- the variable is indeed bound in this branch
then var v -- ... so it should be added to the result
else idFun -- ... else it should be empty.
-- For (possibly non-greedy) repeating regular patterns we need to transform the subpattern,
-- and then generate a function to handle many matches of it.
RPOp rp RPStar ->
do -- Transform the subpattern
nvt <- trRPat s False rp
-- ... and create a declaration that can match it many times.
mkStarDecl s False nvt
-- ... and similarly for the non-greedy version.
RPOp rp RPStarG->
do -- Transform the subpattern
nvt <- trRPat s False rp
-- ... and create a declaration that can match it many times.
mkStarDecl s True nvt
-- For (possibly non-greedy) non-empty repeating patterns we need to transform the subpattern,
-- and then generate a function to handle one or more matches of it.
RPOp rp RPPlus ->
do -- Transform the subpattern
nvt <- trRPat s False rp
-- ... and create a declaration that can match it one or more times.
mkPlusDecl s False nvt
-- ... and similarly for the non-greedy version.
RPOp rp RPPlusG ->
do -- Transform the subpattern
nvt <- trRPat s False rp
-- ... and create a declaration that can match it one or more times.
mkPlusDecl s True nvt
where -- These are the functions that must be in scope for more than one case alternative above.
-- | Generate a declaration for matching a variable.
mkVarMatch :: SrcLoc -> Bool -> Name -> Tr MFunMetaInfo
mkVarMatch s linear v = do
-- First we need a name for the new match function.
n <- genMatchName
-- Then we need a basic matching function that always matches,
-- and that binds the value matched to the variable in question.
let e = paren $ lamE s [pvar v] $ -- (\v -> Just (mf v))
app (con just_name)
(paren $ retVar linear v)
-- Lift the function into the matcher monad, and bind it to its name,
-- then add it the declaration to the store.
pushDecl $ nameBind s n $
app baseMatchFun e -- harp_matchX = baseMatch (\v -> Just (mf v))
return (n, [v], S) -- always binds v and only v
where retVar :: Bool -> Name -> Exp
retVar linear v
-- if bound in linear context, apply const
| linear = metaConst (var v)
-- if bound in non-linear context, apply (:)
| otherwise = app consFun (var v)
-- | Generate a declaration for matching a wildcard
mkWCMatch :: SrcLoc -> Tr MFunMetaInfo
mkWCMatch s = do
-- First we need a name...
n <- genMatchName
-- ... and then a function that always matches, discarding the result
let e = paren $ lamE s [wildcard] $ -- (\_ -> Just ())
app (con just_name) unit_con
-- ... which we lift, bind, and add to the store.
pushDecl $ nameBind s n $ -- harp_matchX = baseMatch (\_ -> Just ())
app baseMatchFun e
return (n, [], S) -- no variables bound, hence []
-- | Gather up the names of all variables in a pattern,
-- using a simple fold over the syntax structure.
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
_ -> []
-- | Generate a match function that lift the result of the
-- basic casing function into the matcher monad.
mkBaseMatch :: SrcLoc -> Name -> Tr Name
mkBaseMatch s name =
do -- First we need a name...
n <- genMatchName
-- ... to which we bind the lifting function
pushDecl $ baseMatchDecl s n name
-- and then return for others to use.
return n
-- | Generate a declaration for the function that lifts a simple
-- casing function into the matcher monad.
baseMatchDecl :: SrcLoc -> Name -> Name -> Decl
baseMatchDecl s newname oldname =
-- Apply the lifting function "baseMatch" to the casing function
let e = app baseMatchFun (var oldname)
-- ... and bind it to the new name.
in nameBind s newname e -- harp_matchX = baseMatch harp_matchY
-- | Generate the generators that call sub-matching functions, and
-- annotate names with types for future flattening of values.
-- Iterate to enable gensym-like behavior.
mkGenExps :: SrcLoc -> Int -> [MFunMetaInfo] -> [(Stmt, (Name, MType))]
mkGenExps _ _ [] = []
mkGenExps s k ((name, vars, t):nvs) =
let valname = mkValName k -- harp_valX
pat = pTuple [pvar valname, pvarTuple vars] -- (harp_valX, (foo, bar, ...))
g = var name
in (genStmt s pat g, (valname, t)) : -- (harp_valX, (foo, ...)) <- harp_matchY
mkGenExps s (k+1) nvs
-- | Create a single generator.
mkGenExp :: SrcLoc -> MFunMetaInfo -> (Stmt, Name)
mkGenExp s nvt = let [(g, (name, _t))] = mkGenExps s 0 [nvt]
in (g, name)
-- | Generate a single generator with a call to (ng)manyMatch,
-- and an extra variable name to use after unzipping.
mkManyGen :: SrcLoc -> Bool -> Name -> Stmt
mkManyGen s greedy mname =
-- Choose which repeater function to use, determined by greed
let mf = if greedy then gManyMatchFun else manyMatchFun
-- ... and create a generator that applies it to the
-- matching function in question.
in genStmt s (pvar valsvarsname) $
app mf (var mname)
-- | Generate declarations for @: and @ bindings.
asDecl :: (Exp -> Exp) -> SrcLoc -> MFunMetaInfo -> Tr Name
asDecl mf s nvt@(_, vs, _) = do
-- A name, if you would
n <- genMatchName -- harp_matchX
let -- Generate a generator for matching the subpattern
(g, val) = mkGenExp s nvt -- (harp_valY, (foo, ...)) <- harp_matchZ
-- ... fix the old variables
vars = map var vs -- (apa, bepa, ...)
-- ... and return the generated value, along with the
-- new set of variables which is the old set prepended
-- by the variable currently being bound.
ret = qualStmt $ metaReturn $ tuple -- return (harp_valY, ($mf harp_valY, apa, ...))
[var val, tuple $ mf (var val) : vars] -- mf in the line above is what separates
-- @: ((:)) from @ (const)
-- Finally we create a declaration for this function and
-- add it to the store.
pushDecl $ nameBind s n $ doE [g, ret] -- harp_matchX = do ...
return n
-- | Generate declarations for optional patterns, ? and #?.
-- (Unfortunally we must place this function here since both variations
-- of transformations of optional patterns should be able to call it...)
mkOptDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
mkOptDecl s greedy nvt@(_, vs, t) = do
-- Un nome, s'il vouz plaît.
n <- genMatchName
let -- Generate a generator for matching the subpattern
(g, val) = mkGenExp s nvt -- (harp_valX, (foo, bar, ...)) <- harp_matchY
-- ... and apply a Just to its value
ret1 = metaReturn $ tuple -- return (Just harp_val1, (foo, bar, ...))
[app (con just_name)
(var val), varTuple vs]
-- ... and do those two steps in a do-expression
exp1 = doE [g, qualStmt ret1] -- do ....
-- For the non-matching branch, all the variables should be empty
ids = map (const idFun) vs -- (id, id, ...)
-- ... and the value should be Nothing.
ret2 = metaReturn $ tuple -- return (Nothing, (id, id, ...))
[con nothing_name, tuple ids] -- i.e. no vars were bound
-- The order of the arguments to the choice (+++) operator
-- is determined by greed...
mc = if greedy
then metaChoice -- standard order
else (flip metaChoice) -- reversed order
-- ... and then apply it to the branches.
rhs = (paren exp1) `mc` -- (do ....) +++
(paren ret2) -- (return (Nothing, .....))
-- Finally we create a declaration for this function and
-- add it to the store.
pushDecl $ nameBind s n rhs -- harp_matchZ = (do ....) +++ (return ....)
-- The type of the returned value will be Maybe the type
-- of the value of the subpattern.
return (n, vs, M t)
-- | Generate declarations for star patterns, * and #*
-- (Unfortunally we must place this function here since both variations
-- of transformations of repeating patterns should be able to call it...)
mkStarDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
mkStarDecl s greedy (mname, vs, t) = do
-- Ett namn, tack!
n <- genMatchName
let -- Create a generator that matches the subpattern
-- many times, either greedily or non-greedily
g = mkManyGen s greedy mname
-- ... and unzip the result, choosing the proper unzip
-- function depending on the number of variables returned.
metaUnzipK = mkMetaUnzip s (length vs)
-- ... first unzip values from variables
dec1 = patBind s (pvarTuple [valname, varsname])
(metaUnzip $ var valsvarsname)
-- ... and then unzip the variables
dec2 = patBind s (pvarTuple vs)
(metaUnzipK $ var varsname)
-- ... fold all the values for variables
retExps = map ((app foldCompFun) . var) vs
-- ... and return value and variables
ret = metaReturn $ tuple $
[var valname, tuple retExps]
-- Finally we need to generate a function that does all this,
-- using a let-statement for the non-monadic stuff and a
-- do-expression to wrap it all in.
pushDecl $ nameBind s n $
doE [g, letStmt [dec1, dec2], qualStmt ret]
-- The type of the returned value is a list ([]) of the
-- type of the subpattern.
return (n, vs, L t)
-- | Generate declarations for plus patterns, + and #+
-- (Unfortunally we must place this function here since both variations
-- of transformations of non-empty repeating patterns should be able to call it...)
mkPlusDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
mkPlusDecl s greedy nvt@(mname, vs, t) = do
-- and now I've run out of languages...
n <- genMatchName
let k = length vs
-- First we want a generator to match the
-- subpattern exactly one time
(g1, val1) = mkGenExp s nvt -- (harp_valX, (foo, ...)) <- harpMatchY
-- ... and then one that matches it many times.
g2 = mkManyGen s greedy mname -- harp_vvs <- manyMatch harpMatchY
-- ... we want to unzip the result, using
-- the proper unzip function
metaUnzipK = mkMetaUnzip s k
-- ... first unzip values from variables
dec1 = patBind s -- (harp_vals, harp_vars) = unzip harp_vvs
(pvarTuple [valsname, varsname])
(metaUnzip $ var valsvarsname)
-- .. now we need new fresh names for variables
-- since the ordinary ones are already taken.
vlvars = genNames "harp_vl" k
-- ... and then we can unzip the variables
dec2 = patBind s (pvarTuple vlvars) -- (harp_vl1, ...) = unzipK harp_vars
(metaUnzipK $ var varsname)
-- .. and do the unzipping in a let-statement
letSt = letStmt [dec1, dec2]
-- ... fold variables from the many-match,
-- prepending the variables from the single match
retExps = map mkRetFormat $ zip vs vlvars -- foo . (foldComp harp_vl1), ...
-- ... prepend values from the single match to
-- those of the many-match.
retVal = (var val1) `metaCons`
(var valsname) -- harp_valX : harp_vals
-- ... return all values and variables
ret = metaReturn $ tuple $ -- return (harp_valX:harpVals,
[retVal, tuple retExps] -- (foo . (...), ...))
-- ... and wrap all of it in a do-expression.
rhs = doE [g1, g2, letSt, qualStmt ret]
-- Finally we create a declaration for this function and
-- add it to the store.
pushDecl $ nameBind s n rhs
-- The type of the returned value is a list ([]) of the
-- type of the subpattern.
return (n, vs, L t)
where mkRetFormat :: (Name, Name) -> Exp
mkRetFormat (v, vl) =
-- Prepend variables using function composition.
(var v) `metaComp`
(paren $ (app foldCompFun) $ var vl)
--------------------------------------------------------------------------
-- HaRP-specific functions and ids
-- | Functions and ids from the @Match@ module,
-- used in the generated matching functions
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
-- foldComp = foldl (.) id, i.e. fold by composing
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) -- (x1, x2, ...)
ret2 = tuple $ map appCons $ zip vs lvs -- (x1:xs1, x2:xs2, ...)
rhs2 = app (var uz) (var xs) -- unzipK xs
dec2 = patBind s (pvarTuple lvs) rhs2 -- (xs1, xs2, ...) = unzipK xs
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
-- | Some 'magic' gensym-like functions, and functions
-- with related functionality.
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)
---------------------------------------------------------
-- meta-level functions, i.e. functions that represent functions,
-- and that take arguments representing arguments... whew!
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
-- the +++ choice operator
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
---------------------------------------------------
-- some other useful functions at abstract level
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"
------------------------------------------------------------------------
-- Help functions for meta programming xml
{- No longer used.
hsx_data_mod :: ModuleName
hsx_data_mod = ModuleName "HSP.Data"
-- Also no longer used, literal PCDATA should be considered a string.
-- | Create an xml PCDATA value
metaMkPcdata :: String -> Exp
metaMkPcdata s = metaFunction "pcdata" [strE s]
-}
-- | Create an xml tag, given its domain, name, attributes and
-- children.
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]
-- | Create an empty xml tag, given its domain, name and attributes.
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]
-- | Create an attribute by applying the overloaded @asAttr@
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"
-- | Create a property from an attribute and a value.
metaAssign :: Exp -> Exp -> Exp
metaAssign e1 e2 = infixApp e1 assignOp e2
where assignOp = QConOp $ UnQual $ Symbol ":="
-- | Make xml out of some expression by applying the overloaded function
-- @asChild@.
metaAsChild :: Exp -> Exp
metaAsChild e = metaFunction "asChild" [paren e]
-- TODO: We need to fix the stuff below so pattern matching on XML could also be overloaded.
-- Right now it only works on HSP XML, or anything that is syntactically identical to it.
-- | Lookup an attribute in the set of attributes.
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]
-- | Generate a pattern under the Tag data constructor.
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]
-- | Generate a pattern under the PCDATA data constructor.
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")))