----------------------------------------------------------------------------- -- | -- Module : HSX.Tranform -- Copyright : (c) Niklas Broberg 2004, -- License : BSD-style (see the file LICENSE.txt) -- -- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se -- 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 HSX.Transform ( transform -- :: HsModule -> HsModule ) where import Language.Haskell.Exts.Syntax import Language.Haskell.Exts.Build 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 -- Type signatures, type, newtype or data declarations, infix declarations -- and default declarations; none can contain regular patterns _ -> 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' <- transformExp $ 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' <- transformExp $ 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 -> HsxM Exp transformExp 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' 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 <- transformExp e -- ... and apply the overloaded toXMLs to it return $ metaAsChild te -- 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 -- PCDATA should be lifted as a string into the XML datatype. XPcdata pcdata -> do setXmlTransformed return $ strE pcdata -- Escaped expressions should be treated as just expressions. XExpTag e -> do setXmlTransformed e' <- transformExp 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' <- transformExp 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' <- transformExp 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' <- transformExp 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' <- transformExp 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' <- transformExp e stmts' <- fmap concat $ mapM transformQualStmt stmts return $ ListComp e' stmts' ParComp e stmtss -> do e' <- transformExp e stmtss' <- fmap (map concat) $ mapM (mapM transformQualStmt) stmtss return $ ParComp e' stmtss' {- Proc p e -> 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' -} -- 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 $ transformExp e If e1 e2 e3 -> transform3exp e1 e2 e3 If Tuple es -> fmap Tuple $ mapM transformExp es List es -> fmap List $ mapM transformExp es Paren e -> fmap Paren $ transformExp e LeftSection e op -> do e' <- transformExp e return $ LeftSection e' op RightSection op e -> fmap (RightSection op) $ transformExp e RecConstr n fus -> fmap (RecConstr n) $ mapM transformFieldUpdate fus RecUpdate e fus -> do e' <- transformExp e fus' <- mapM transformFieldUpdate fus return $ RecUpdate e' fus' EnumFrom e -> fmap EnumFrom $ transformExp 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' <- transformExp 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 _ -> return e -- Warning - will not work inside TH pattern splices! transformFieldUpdate :: FieldUpdate -> HsxM FieldUpdate transformFieldUpdate (FieldUpdate n e) = fmap (FieldUpdate n) $ transformExp e transformSplice :: Splice -> HsxM Splice transformSplice s = case s of ParenSplice e -> fmap ParenSplice $ transformExp e _ -> return s transform2exp :: Exp -> Exp -> (Exp -> Exp -> a) -> HsxM a transform2exp e1 e2 f = do e1' <- transformExp e1 e2' <- transformExp e2 return $ f e1' e2' transform3exp :: Exp -> Exp -> Exp -> (Exp -> Exp -> Exp -> a) -> HsxM a transform3exp e1 e2 e3 f = do e1' <- transformExp e1 e2' <- transformExp e2 e3' <- transformExp e3 return $ f e1' e2' e3' mkAttr :: XAttr -> Exp mkAttr (XAttr name e) = paren (metaMkName name `metaAssign` 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) $ transformExp 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' <- transformExp $ 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]) $ transformExp 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 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) $ transformExp e ThenBy e f -> fmap return $ transform2exp e f ThenBy GroupBy e -> fmap (return . GroupBy) $ transformExp e GroupUsing f -> fmap (return . GroupUsing) $ transformExp 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' <- transformExp $ 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' <- transformExp $ 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 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 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. 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) where -- Transform a pattern field. trPatternField :: SrcLoc -> PatField -> Tr PatField trPatternField s (PFieldPat n p) = tr1pat p (PFieldPat n) (trPattern s) -- 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 (var just_name) $ tuple (map (retVar b) vs)) -- .. and finally an alternative for not matching the pattern. alt2 = alt s wildcard (var 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 (var just_name) $ tuple (map (retVar b) vs)) noBinds -- .. and finally an alternative for not matching the pattern. alt2 = alt s wildcard (var 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 (var left_name) (var v1), tuple vals1] ret2 = metaReturn $ tuple -- return (Right harp_val2, (id, bar, ...)) [app (var 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 (var 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 (var 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 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</