hsx2hs 0.13.5 → 0.14.0

raw patch · 4 files changed

+1930/−1976 lines, 4 filesdep ~haskell-src-extsdep ~haskell-src-metaPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-src-exts, haskell-src-meta

API changes (from Hackage documentation)

Files

• hsx2hs.cabal +3/−3
• src/Language/Haskell/HSX/QQ.hs +4/−7
• src/Language/Haskell/HSX/Transform.hs +1919/−1960
• src/hsx2hs.hs +4/−6

@@ -1,5 +1,5 @@ Name:                   hsx2hs-Version:                0.13.5+Version:                0.14.0 License:                BSD3 License-File:           LICENSE Author:                 Niklas Broberg, Joel Bjornson@@ -42,8 +42,8 @@  Library   Build-depends:	mtl              >= 2.0  && < 2.3,-                        haskell-src-exts >= 1.16 && < 1.18,-                        haskell-src-meta >= 0.6  && < 0.7,+                        haskell-src-exts >= 1.18 && < 1.19,+                        haskell-src-meta >= 0.7  && < 0.8,                         template-haskell >= 2.7  && < 2.12,                         bytestring,                         utf8-string      >= 0.3  && < 1.1

@@ -59,17 +59,14 @@ parseHsxExp :: String -> ExpQ parseHsxExp = either (error . show) (return . toExp . transformExp) . parseHsExp -parseExp :: String -> Either String Exp+-- parseExp :: String -> Either String Exp parseExp = either Left (Right . toExp . transformExp) . parseHsExp -parseHsExp :: String -> Either String Hs.Exp-parseHsExp = either Left (Right . transformExp) . parseResultToEither . parseExpWithMode parseMode+-- parseHsExp :: String -> Either String (Hs.Exp SrcSpanInfo)+parseHsExp = either Left (Right . transformExp) . fmap (fmap $ const ()) . parseResultToEither . parseExpWithMode parseMode  parseMode :: ParseMode-parseMode = ParseMode "" Haskell2010 allExtensions False True (Just baseFixities)-#if MIN_VERSION_haskell_src_exts(1,17,0)-                      False-#endif+parseMode = ParseMode "" Haskell2010 allExtensions False True (Just baseFixities) False  allExtensions :: [Extension] allExtensions = map EnableExtension

@@ -22,1964 +22,1923 @@  import Language.Haskell.Exts.Syntax import Language.Haskell.Exts.Build-import Language.Haskell.Exts.SrcLoc (noLoc)-import Control.Applicative (Applicative(pure, (<*>)))-import Control.Monad       (ap)-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 Applicative HsxM where-  pure  = return-  (<*>) = ap--instance Monad HsxM where- return x = MkHsxM (\s -> (x,s))- (MkHsxM f) >>= k = MkHsxM (\s -> let (a, s') = f s-                                      (MkHsxM f') = k a-                                   in f' s')--getHsxState :: HsxM HsxState-getHsxState = MkHsxM (\s -> (s, s))--setHsxState :: HsxState -> HsxM ()-setHsxState s = MkHsxM (\_ -> ((),s))--instance Functor HsxM where- fmap f hma = do a <- hma-                 return $ f a---------type HsxState = (Bool, Bool)--initHsxState :: HsxState-initHsxState = (False, False)--setHarpTransformed :: HsxM ()-setHarpTransformed =-    do (_,x) <- getHsxState-       setHsxState (True,x)--setXmlTransformed :: HsxM ()-setXmlTransformed =-    do (h,_) <- getHsxState-       setHsxState (h,True)--runHsxM :: HsxM a -> (a, (Bool, Bool))-runHsxM (MkHsxM f) = f initHsxState---------------------------------------------------------------------------------- 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 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 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-#if MIN_VERSION_haskell_src_exts(1,17,0)-               Nothing -> return Nothing-               Just (BDecls ds)-                         -> do ds' <- transformLetDecls ds-                               return $ Just $ BDecls $ decls'' ++ ds'-#else-               BDecls ds -> do ds' <- transformLetDecls ds-                               return $ BDecls $ decls'' ++ ds'-#endif-               _           -> error "Cannot bind implicit parameters in the \-                        \ \'where\' clause of a function using regular patterns."-        return $ PatBind srcloc pat'' 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 mo tvbs c n ts idecls ->-        fmap (InstDecl s mo tvbs 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-#if MIN_VERSION_haskell_src_exts(1,17,0)-           Nothing -> return Nothing-           Just (BDecls ds)-                     -> do ds' <- transformLetDecls ds-                           return $ Just $ BDecls $ decls'' ++ ds'-#else-           BDecls ds -> do ds' <- transformLetDecls ds-                           return $ BDecls $ decls'' ++ ds'-#endif-           _           -> 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 $ metaFromStringLit $ strE pcdata---                            return $ ExpTypeSig noLoc (strE pcdata) (TyCon (UnQual (Ident "Text")))-    -- 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 bx es       -> fmap (Tuple bx) $ 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` (textTypeSig e))-    where-      textTypeSig e@(Lit (String _)) = metaFromStringLit e---      textTypeSig e@(Lit (String _)) = ExpTypeSig noLoc e (TyCon (UnQual (Ident "Text")))-      textTypeSig 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 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...-#if MIN_VERSION_haskell_src_exts(1,17,0)-                        Nothing -> return Nothing-                        Just (BDecls decls) -> fmap (Just . BDecls) $ transformLetDecls decls-#else-                        BDecls decls -> fmap BDecls $ transformLetDecls decls-#endif-                        -- If they are implicit parameter bindings we simply transform-                        -- them as such.-#if MIN_VERSION_haskell_src_exts(1,17,0)-                        Just (IPBinds decls) -> fmap (Just . IPBinds) $ mapM transformIPBind decls-#else-                        IPBinds decls -> fmap IPBinds $ mapM transformIPBind decls-#endif-                    -- 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' 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' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs-    -- Transform declarations in the where clause, adding any generated-    -- declarations to it.-    decls' <- case decls of-#if MIN_VERSION_haskell_src_exts(1,17,0)-           Nothing -> return Nothing-           Just (BDecls ds) -> do ds' <- mapM transformDecl ds-                                  return $ Just $ BDecls $ decls'' ++ ds-#else-           BDecls ds -> do ds' <- mapM transformDecl ds-                           return $ BDecls $ decls'' ++ ds-#endif-           _           -> error "Cannot bind implicit parameters in the \-                     \ \'where\' clause of a function using regular patterns."--    return $ Alt srcloc pat'' rhs' decls'--------------------------------------------------------------------------------------- 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 Applicative RN where-  pure  = return-  (<*>) = ap--instance Monad RN where- return a = RN $ \s -> (a,s)- (RN f) >>= k = RN $ \s -> let (a,s') = f s-                               (RN g) = k a-                            in g s'--instance Functor RN where- fmap f rna = do a <- rna-                 return $ f a---runRename :: RN a -> a-runRename (RN f) = let (a,_) = f initRNState-                    in a--getRNState :: RN RNState-getRNState = RN $ \s -> (s,s)--setRNState :: RNState -> RN ()-setRNState s = RN $ \_ -> ((), s)--genVarName :: RN Name-genVarName = do-    k <- getRNState-    setRNState $ k+1-    return $ name $ "harp_rnvar" ++ show k---type NameBind = (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.-    PInfixApp p1 n p2 -> rename2pat p1 p2-                                (\p1 p2 -> PInfixApp p1 n p2)-                                renameRP-    PApp n ps         -> renameNpat ps (PApp n) renameRP-    PTuple bx ps      -> renameNpat ps (PTuple bx) 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 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 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.-    PInfixApp p1 n p2 -> rename2pat p1 p2-                                (\p1 p2 -> PInfixApp p1 n p2)-                                renameIrrP-    PApp n ps         -> renameNpat ps (PApp n) renameIrrP-    PTuple bx ps      -> renameNpat ps (PTuple bx) 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 Applicative Tr where-  pure  = return-  (<*>) = ap--instance Monad Tr where- return a = Tr $ \s -> return (a, s)- (Tr f) >>= k = Tr $ \s ->-          do (a, s') <- f s-             let (Tr f') = k a-             f' s'--instance Functor Tr where- fmap f tra = tra >>= (return . f)--liftTr :: HsxM a -> Tr a-liftTr hma = Tr $ \s -> do a <- hma-                           return (a, s)--initState = initStateFrom 0 0--initStateFrom k l = (0, k, l, [], [], [])--runTr :: Tr a -> HsxM (a, [Guard], [Guard], [Decl])-runTr (Tr f) = do (a, (_,_,_,gs1,gs2,ds)) <- f initState-                  return (a, reverse gs1, reverse gs2, reverse ds)---runTrFromTo :: Int -> Int -> Tr a -> HsxM (a, [Guard], [Guard], [Decl], Int, Int)-runTrFromTo k l (Tr f) = do (a, (_,k',l',gs1,gs2,ds)) <- f $ initStateFrom k l-                            return (a, reverse gs1, reverse gs2, reverse ds, k', l')----- 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-    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 bx ps       -> trNpat ps (PTuple bx) (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)-    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) $-#if MIN_VERSION_haskell_src_exts(1,17,0)-                                     tuple (map (retVar b) vs)) (binds [])-#else-                                     tuple (map (retVar b) vs)) noBinds-#endif-                            -- .. 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]-            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 (metaFromStringLit . strE) d, metaFromStringLit $ strE n]-        m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat-        attrs = m $ listE $ map metaAsAttr ats-     in metaFunction "genElement" [ne, attrs, listE cs]---- | 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 (metaFromStringLit . strE) d, metaFromStringLit $ strE n]-        m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat-        attrs = m $ listE $ map metaAsAttr ats-     in metaFunction "genEElement" [ne, attrs]---- | Create an attribute by applying the overloaded @asAttr@-metaAsAttr :: Exp -> Exp-metaAsAttr e@(Lit (String _)) = metaFunction "asAttr" [metaFromStringLit e] -- [ExpTypeSig noLoc e (TyCon (UnQual (Ident "Text")))]-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]---- | convert a 'String' literal to lazy 'Text' by calling a function named 'fromStringLit'-metaFromStringLit :: Exp -> Exp-metaFromStringLit e = metaFunction "fromStringLit" [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      -> metaFromStringLit (strE s)-    XDomName d s -> tuple [metaFromStringLit $ strE d, metaFromStringLit $ strE s]----    XName s      -> textTypeSig (strE s)---    XDomName d s -> tuple [textTypeSig $ strE d, textTypeSig $ strE s]---    where---      textTypeSig e = ExpTypeSig noLoc e (TyCon (UnQual (Ident "Text")))+import Control.Applicative (Applicative(pure, (<*>)))+import Control.Monad       (ap)+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 Applicative HsxM where+  pure  = return+  (<*>) = ap++instance Monad HsxM where+ return x = MkHsxM (\s -> (x,s))+ (MkHsxM f) >>= k = MkHsxM (\s -> let (a, s') = f s+                                      (MkHsxM f') = k a+                                   in f' s')++getHsxState :: HsxM HsxState+getHsxState = MkHsxM (\s -> (s, s))++setHsxState :: HsxState -> HsxM ()+setHsxState s = MkHsxM (\_ -> ((),s))++instance Functor HsxM where+ fmap f hma = do a <- hma+                 return $ f a++-----++type HsxState = (Bool, Bool)++initHsxState :: HsxState+initHsxState = (False, False)++setHarpTransformed :: HsxM ()+setHarpTransformed =+    do (_,x) <- getHsxState+       setHsxState (True,x)++setXmlTransformed :: HsxM ()+setXmlTransformed =+    do (h,_) <- getHsxState+       setHsxState (h,True)++runHsxM :: HsxM a -> (a, (Bool, Bool))+runHsxM (MkHsxM f) = f initHsxState++-----------------------------------------------------------------------------+-- Traversing and transforming the syntax tree+++-- | Transform away occurences of regular patterns from an abstract+-- Haskell module, preserving semantics.+transform :: Module () -> Module ()+transform (Module l m pragmas 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 () match_mod True False 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 l m pragmas (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 l 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 [pat']+        -- Transform the right-hand side, and add any generated guards+        -- and let expressions to it+        rhs' <- mkRhs (attrGuards ++ guards) (concat rnpss) rhs+        -- Transform declarations in the where clause, adding any generated+        -- declarations to it+        decls' <- case decls of+               Nothing -> return Nothing+               Just (BDecls l ds)+                         -> do ds' <- transformLetDecls ds+                               return $ Just $ BDecls l $ decls'' ++ ds'+               _           -> error "Cannot bind implicit parameters in the \+                        \ \'where\' clause of a function using regular patterns."+        return $ PatBind l pat'' rhs' decls'++    -- Function binds can contain regular patterns in their matches+    FunBind l ms -> fmap (FunBind l) $ mapM transformMatch ms+    -- Instance declarations can contain regular patterns in the+    -- declarations of functions inside it+    InstDecl l mo irule Nothing -> pure d+    InstDecl l mo irule (Just idecls) ->+      fmap (InstDecl l mo irule . Just) $ mapM transformInstDecl idecls+    -- Class declarations can contain regular patterns in the+    -- declarations of automatically instantiated functions+    ClassDecl l c dh fd Nothing -> pure d+    ClassDecl l c dh fd (Just cdecls) ->+        fmap (ClassDecl l c dh fd . Just) $ mapM transformClassDecl cdecls+    -- TH splices are expressions and can contain regular patterns+    SpliceDecl l e ->+        fmap (SpliceDecl l) $ 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 l decl -> fmap (InsDecl l) $ transformDecl decl+    _ -> return d+++transformClassDecl :: ClassDecl () -> HsxM (ClassDecl ())+transformClassDecl d = case d of+    ClsDecl l decl -> fmap (ClsDecl l) $ transformDecl decl+    _ -> return d++-- | 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 l name pats 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 pats'+    -- Transform the right-hand side, and add any generated guards+    -- and let expressions to it+    rhs' <- mkRhs (attrGuards ++ guards) (concat rnpss) rhs+    -- Transform declarations in the where clause, adding any generated+    -- declarations to it+    decls' <- case decls of+           Nothing -> return Nothing+           Just (BDecls l ds)+                     -> do ds' <- transformLetDecls ds+                           return $ Just $ BDecls l $ decls'' ++ ds'+           _           -> error "Cannot bind implicit parameters in the \+                     \ \'where\' clause of a function using regular patterns."++    return $ Match l name pats'' rhs' decls'+++-- | 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 :: [Guard ()] -> [(Name (), Pat ())] -> Rhs () -> HsxM (Rhs ())+mkRhs guards rnps (UnGuardedRhs l 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 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 l rhs'+     -- There are guards to add. These should be added as pattern+     -- guards, i.e. as statements.+     _  -> return $ GuardedRhss l [GuardedRhs l (map mkStmtGuard guards) rhs']+mkRhs guards rnps (GuardedRhss l gdrhss) = fmap (GuardedRhss l) $ mapM (mkGRhs guards rnps) gdrhss+  where mkGRhs :: [Guard ()] -> [(Name (), Pat ())] -> GuardedRhs () -> HsxM (GuardedRhs ())+        mkGRhs gs rnps (GuardedRhs l oldgs rhs) = do+            -- 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 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 l ((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 :: [(Name (), Pat ())] -> Exp () -> Exp ()+addLetDecls []   e = e    -- no declarations to add+addLetDecls rnps e =+    -- Place all postponed patterns in the same let-expression+    letE (map mkDecl rnps) e++-- | Make pattern binds from postponed regular patterns+mkDecl :: (Name (), Pat ()) -> Decl ()+mkDecl (n,p) = patBind 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 $ metaFromStringLit $ strE pcdata+--                            return $ ExpTypeSig noLoc (strE pcdata) (TyCon (UnQual (Ident "Text")))+    -- 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 l 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 (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 l 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 l (IPBinds l' is) e -> do+        is' <- mapM transformIPBind is+        e'  <- transformExpM e+        return $ Let l (IPBinds l' 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 l e alts -> do+        e'    <- transformExpM e+        alts' <- mapM transformAlt alts+        return $ Case l e' alts'+    -- A do expression can contain regular patterns in its statements.+    Do l stmts -> do+        stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts+        return $ Do l stmts'+    MDo l stmts -> do+        stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts+        return $ MDo l stmts'+    -- A list comprehension can contain regular patterns in the result+    -- expression, or in any of its statements.+    ListComp l e stmts  -> do+        e'     <- transformExpM e+        stmts' <- fmap concat $ mapM transformQualStmt stmts+        return $ ListComp l e' stmts'+    ParComp l e stmtss  -> do+        e'      <- transformExpM e+        stmtss' <- fmap (map concat) $ mapM (mapM transformQualStmt) stmtss+        return $ ParComp l e' stmtss'+    Proc l pat rhs          -> do+        let -- First rename regular patterns+            ([p], [rnps])  = unzip $ renameRPats [pat]+            -- ... group them up to one big tuple+            (rns, rps) = unzip rnps+            alt1 = alt (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 l p rhs'++    -- All other expressions simply transform their immediate subterms.+    InfixApp l e1 op e2 -> transform2exp e1 e2+                                (\e1 e2 -> InfixApp l e1 op e2)+    App l e1 e2         -> transform2exp e1 e2 (App l)+    NegApp l e          -> fmap (NegApp l) $ transformExpM e+    If l e1 e2 e3       -> transform3exp e1 e2 e3 (If l)+    Tuple l bx es       -> fmap (Tuple l bx) $ mapM transformExpM es+    List l es           -> fmap (List l) $ mapM transformExpM es+    Paren l e           -> fmap (Paren l) $ transformExpM e+    LeftSection l e op  -> do e' <- transformExpM e+                              return $ LeftSection l e' op+    RightSection l op e -> fmap (RightSection l op) $ transformExpM e+    RecConstr l n fus   -> fmap (RecConstr l n) $ mapM transformFieldUpdate fus+    RecUpdate l e fus   -> do e'   <- transformExpM e+                              fus' <- mapM transformFieldUpdate fus+                              return $ RecUpdate l e' fus'+    EnumFrom l e        -> fmap (EnumFrom l) $ transformExpM e+    EnumFromTo l e1 e2  -> transform2exp e1 e2 (EnumFromTo l)+    EnumFromThen l e1 e2      -> transform2exp e1 e2 (EnumFromThen l)+    EnumFromThenTo l e1 e2 e3 -> transform3exp e1 e2 e3 (EnumFromThenTo l)+    ExpTypeSig l e t  -> do e' <- transformExpM e+                            return $ ExpTypeSig l e' t+    SpliceExp l s       -> fmap (SpliceExp l) $ transformSplice s+    LeftArrApp l e1 e2        -> transform2exp e1 e2 (LeftArrApp l)+    RightArrApp l e1 e2       -> transform2exp e1 e2 (RightArrApp l)+    LeftArrHighApp l e1 e2    -> transform2exp e1 e2 (LeftArrHighApp l)+    RightArrHighApp l e1 e2   -> transform2exp e1 e2 (RightArrHighApp l)+    CorePragma l s e      -> fmap (CorePragma l s) $ transformExpM e+    SCCPragma  l s e      -> fmap (SCCPragma  l s) $ transformExpM e+    GenPragma  l s a b e  -> fmap (GenPragma  l s a b) $ transformExpM e+    _           -> return e     -- 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 l n e) =+        fmap (FieldUpdate l n) $ transformExpM e+transformFieldUpdate fup = return fup++transformSplice :: Splice () -> HsxM (Splice ())+transformSplice s = case s of+    ParenSplice l e     -> fmap (ParenSplice l) $ transformExpM e+    _                   -> return s++transform2exp :: Exp () -> Exp () -> (Exp () -> Exp () -> a) -> HsxM a+transform2exp e1 e2 f = do e1' <- transformExpM e1+                           e2' <- transformExpM e2+                           return $ f e1' e2'++transform3exp :: Exp () -> Exp () -> Exp () -> (Exp () -> Exp () -> Exp () -> a) -> HsxM a+transform3exp e1 e2 e3 f = do e1' <- transformExpM e1+                              e2' <- transformExpM e2+                              e3' <- transformExpM e3+                              return $ f e1' e2' e3'++mkAttr :: XAttr () -> Exp ()+mkAttr (XAttr _ name e) =+    paren (metaMkName name `metaAssign` (textTypeSig e))+    where+      textTypeSig e@(Lit _ (String _ _ _)) = metaFromStringLit e+--      textTypeSig e@(Lit (String _)) = ExpTypeSig noLoc e (TyCon (UnQual (Ident "Text")))+      textTypeSig 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 l'' pat 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 [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...+                        Nothing -> return Nothing+                        Just (BDecls l'' decls) -> fmap (Just . BDecls l'') $ transformLetDecls decls+                        -- If they are implicit parameter bindings we simply transform+                        -- them as such.+                        Just (IPBinds l'' decls) -> fmap (Just . IPBinds l'') $ 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 [] [] 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 l'' pat' 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 l n e) =+    fmap (IPBind l 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 [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 (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 (p,e) = genStmt p (metaReturn $ paren e)+    -- Qualifiers are simply wrapped expressions and are treated as such.+    Qualifier l e -> fmap (\e -> [Qualifier l $ 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 l (IPBinds l' is) ->+        fmap (\is -> [LetStmt l (IPBinds l' is)]) $ mapM transformIPBind is+    RecStmt l stmts   ->+        fmap (return . RecStmt l . concat) $ mapM (transformStmt t) stmts++transformQualStmt :: QualStmt () -> HsxM [QualStmt ()]+transformQualStmt qs = case qs of+    -- For qual statments in list comprehensions we just pass on the baton+    QualStmt     l s      -> fmap (map (QualStmt l)) $ transformStmt ListCompStmt s+    ThenTrans    l e      -> fmap (return . ThenTrans l) $ transformExpM e+    ThenBy       l e f    -> fmap return $ transform2exp e f (ThenBy l)+    GroupBy      l e      -> fmap (return . GroupBy l) $ transformExpM e+    GroupUsing   l f      -> fmap (return . GroupUsing l) $ transformExpM f+    GroupByUsing l e f    -> fmap return $ transform2exp e f (GroupByUsing l)++------------------------------------------------------------------------------------------+-- Case alternatives++-- | Transform alternatives in a @case@-expression. Patterns are+-- transformed, while other subterms are traversed further.+transformAlt :: Alt () -> HsxM (Alt ())+transformAlt (Alt l 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 [pat']+    -- Transform the right-hand side, and add any generated guards+    -- and let expressions to it.+    rhs' <- mkRhs (attrGuards ++ guards) (concat rnpss) rhs+    -- Transform declarations in the where clause, adding any generated+    -- declarations to it.+    decls' <- case decls of+           Nothing -> return Nothing+           Just (BDecls l' ds) -> do ds' <- mapM transformDecl ds+                                     return $ Just $ BDecls l' $ decls'' ++ ds+           _           -> error "Cannot bind implicit parameters in the \+                     \ \'where\' clause of a function using regular patterns."++    return $ Alt l pat'' rhs' decls'++----------------------------------------------------------------------------------+-- 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 l = (Pat l, Exp l)++mkStmtGuard :: Guard () -> Stmt ()+mkStmtGuard (p, e) = genStmt p e++mkDeclGuard :: Guard () -> [Decl ()] -> Decl ()+mkDeclGuard (p, e) ds = patBindWhere p e ds++----------------------------------------------------------------------------------+-- Rewriting expressions before transformation.+-- Done in a monad for gensym capability.++newtype RN a = RN (RNState -> (a, RNState))++type RNState = Int++initRNState = 0++instance Applicative RN where+  pure  = return+  (<*>) = ap++instance Monad RN where+ return a = RN $ \s -> (a,s)+ (RN f) >>= k = RN $ \s -> let (a,s') = f s+                               (RN g) = k a+                            in g s'++instance Functor RN where+ fmap f rna = do a <- rna+                 return $ f a+++runRename :: RN a -> a+runRename (RN f) = let (a,_) = f initRNState+                    in a++getRNState :: RN RNState+getRNState = RN $ \s -> (s,s)++setRNState :: RNState -> RN ()+setRNState s = RN $ \_ -> ((), s)++genVarName :: RN (Name ())+genVarName = do+    k <- getRNState+    setRNState $ k+1+    return $ name $ "harp_rnvar" ++ show k+++type NameBind l = (Name l, Pat l)++-- 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.+    PInfixApp l p1 n p2 -> rename2pat p1 p2+                                (\p1 p2 -> PInfixApp l p1 n p2)+                                renameRP+    PApp l n ps         -> renameNpat ps (PApp l n) renameRP+    PTuple l bx ps      -> renameNpat ps (PTuple l bx) renameRP+    PList l ps          -> renameNpat ps (PList l) renameRP+    PParen l p          -> rename1pat p (PParen l) renameRP+    PRec l n pfs        -> renameNpat pfs (PRec l n) renameRPf+    PAsPat l n p        -> rename1pat p (PAsPat l n) renameRP+    PIrrPat l p         -> rename1pat p (PIrrPat l) renameRP+    PXPatTag l p        -> rename1pat p (PXPatTag l) renameRP+    PatTypeSig l p t  -> rename1pat p (\p -> PatTypeSig l p t) renameRP+    _                   -> return (p, [])+  where renameRPf :: PatField () -> RN (PatField (), [NameBind ()])+        renameRPf (PFieldPat l n p) = rename1pat p (PFieldPat l n) renameRP+        renameRPf pf              = return (pf, [])++        renameAttr :: PXAttr () -> RN (PXAttr (), [NameBind ()])+        renameAttr (PXAttr l s p) = rename1pat p (PXAttr l s) renameRP++        rename :: Pat () -> RN (Pat (), [NameBind ()])+        rename p = do -- 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 (\(n,p) -> mkDecl (n,p)) (concat smss)+        -- ... which should be added to the original list of declarations.+     in ds' ++ gs++  where renameLetDecl :: Decl () -> RN (Decl (), [(Name (), Pat ())])+        renameLetDecl d = case d of+            -- We need only bother about pattern bindings.+            PatBind l pat rhs decls -> do+                -- Rename any regular patterns that appear in the+                -- pattern being bound.+                (p, ms) <- renameRP pat+                let sms = map (\(n,p) -> (n, p)) ms+                return $ (PatBind l p 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 l p     -> do (q, ms) <- renameRP p+                          return $ (PIrrPat l q, ms)+    -- The rest of the rules simply try to rename regular patterns in+    -- irrefutable patterns in their immediate subpatterns.+    PInfixApp l p1 n p2 -> rename2pat p1 p2+                                (\p1 p2 -> PInfixApp l p1 n p2)+                                renameIrrP+    PApp l n ps         -> renameNpat ps (PApp l n) renameIrrP+    PTuple l bx ps      -> renameNpat ps (PTuple l bx) renameIrrP+    PList l ps          -> renameNpat ps (PList l) renameIrrP+    PParen l p          -> rename1pat p (PParen l) renameIrrP+    PRec l n pfs        -> renameNpat pfs (PRec l n) renameIrrPf+    PAsPat l n p        -> rename1pat p (PAsPat l n) renameIrrP+    PatTypeSig l p t  -> rename1pat p (\p -> PatTypeSig l p t) renameIrrP+    -- Hsx+    PXTag l n attrs mat ps -> do (attrs', nss) <- fmap unzip $ mapM renameIrrAttr attrs+                                 (mat', ns1) <- case mat of+                                                   Nothing -> return (Nothing, [])+                                                   Just at -> do (at', ns) <- renameIrrP at+                                                                 return (Just at', ns)+                                 (q, ns) <- renameNpat ps (PXTag l n attrs' mat') renameIrrP+                                 return (q, concat nss ++ ns1 ++ ns)+    PXETag l n attrs mat  -> do (as, nss) <- fmap unzip $ mapM renameIrrAttr attrs+                                (mat', ns1) <- case mat of+                                                  Nothing -> return (Nothing, [])+                                                  Just at -> do (at', ns) <- renameIrrP at+                                                                return (Just at', ns)+                                return $ (PXETag l n as mat', concat nss ++ ns1)+    PXPatTag l p            -> rename1pat p (PXPatTag l) renameIrrP+    -- End Hsx++    _                       -> return (p, [])++  where renameIrrPf :: PatField () -> RN (PatField (), [NameBind ()])+        renameIrrPf (PFieldPat l n p) = rename1pat p (PFieldPat l n) renameIrrP+        renameIrrPf pf = return (pf, [])++        renameIrrAttr :: PXAttr () -> RN (PXAttr (), [NameBind ()])+        renameIrrAttr (PXAttr l s p) = rename1pat p (PXAttr l s) renameIrrP++-----------------------------------------------------------------------------------+-- Transforming Patterns: the real stuff++-- | Transform several patterns in the same context, thereby+-- generating any code for matching regular patterns.+transformPatterns :: [Pat ()] -> HsxM ([Pat ()], [Guard ()], [Guard ()], [Decl ()])+transformPatterns ps = runTr (trPatterns ps)++---------------------------------------------------+-- The transformation monad++type State = (Int, Int, Int, [Guard ()], [Guard ()], [Decl ()])++newtype Tr a = Tr (State -> HsxM (a, State))++instance Applicative Tr where+  pure  = return+  (<*>) = ap++instance Monad Tr where+ return a = Tr $ \s -> return (a, s)+ (Tr f) >>= k = Tr $ \s ->+          do (a, s') <- f s+             let (Tr f') = k a+             f' s'++instance Functor Tr where+ fmap f tra = tra >>= (return . f)++liftTr :: HsxM a -> Tr a+liftTr hma = Tr $ \s -> do a <- hma+                           return (a, s)++initState = initStateFrom 0 0++initStateFrom k l = (0, k, l, [], [], [])++runTr :: Tr a -> HsxM (a, [Guard ()], [Guard ()], [Decl ()])+runTr (Tr f) = do (a, (_,_,_,gs1,gs2,ds)) <- f initState+                  return (a, reverse gs1, reverse gs2, reverse ds)+++runTrFromTo :: Int -> Int -> Tr a -> HsxM (a, [Guard ()], [Guard ()], [Decl ()], Int, Int)+runTrFromTo k l (Tr f) = do (a, (_,k',l',gs1,gs2,ds)) <- f $ initStateFrom k l+                            return (a, reverse gs1, reverse gs2, reverse ds, k', l')+++-- 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 :: Pat () -> Exp () -> Tr ()+pushGuard p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,(p,e):gs2,ds))++pushDecl :: Decl () -> Tr ()+pushDecl d = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,gs2,d:ds))++pushAttrGuard :: Pat () -> Exp () -> Tr ()+pushAttrGuard p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,(p,e):gs1,gs2,ds))++genMatchName :: Tr (Name ())+genMatchName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (n,(n+1,m,a,gs1,gs2,ds))+                  return $ Ident () $ "harp_match" ++ show k++genPatName :: Tr (Name ())+genPatName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m+1,a,gs1,gs2,ds))+                return $ Ident () $ "harp_pat" ++ show k++genAttrName :: Tr (Name ())+genAttrName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m,a+1,gs1,gs2,ds))+                 return $ Ident ()  $ "hsx_attrs" ++ show k+++setHarpTransformedT, setXmlTransformedT :: Tr ()+setHarpTransformedT = liftTr setHarpTransformed+setXmlTransformedT  = liftTr setXmlTransformed+++-------------------------------------------------------------------+-- 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 :: [Pat ()] -> Tr [Pat ()]+trPatterns = mapM trPattern++-- | Transform a pattern by traversing the syntax tree.+-- A regular pattern is translated, other patterns are+-- simply left as is.+trPattern :: Pat () -> Tr (Pat ())+trPattern 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 True (RPSeq () rps)+        -- Generate a top level declaration.+        topmname <- mkTopDecl 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 vars topmname n+        -- And indeed, we have made a transformation!+        setHarpTransformedT+        -- Return the placeholder pattern.+        return $ pvar n+    -- Tag patterns should be transformed+    PXTag _ 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 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 p+                  -- ... it's an ordinary list, so we first wrap it up as such+                  _                    -> trPattern (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 _ 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 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 p+    -- Regular expression patterns over children should be translated+    -- just like PRPat.++    PXRPats l rps -> trPattern $ PRPat l rps+    -- Transforming any other patterns simply means transforming+    -- their subparts.+    PViewPat l e p       -> do+        e' <- liftTr $ transformExpM e+        tr1pat p (PViewPat l e') trPattern+    PVar _ _             -> return p+    PLit _ _ _           -> return p+    PInfixApp l p1 op p2 -> tr2pat p1 p2 (\p1 p2 -> PInfixApp l p1 op p2) trPattern+    PApp l n ps          -> trNpat ps (PApp l n) trPattern+    PTuple l bx ps       -> trNpat ps (PTuple l bx) trPattern+    PList l ps           -> trNpat ps (PList l) trPattern+    PParen l p           -> tr1pat p (PParen l) trPattern+    PRec l n pfs         -> trNpat pfs (PRec l n) trPatternField+    PAsPat l n p         -> tr1pat p (PAsPat l n) trPattern+    PWildCard l          -> return p+    PIrrPat l p          -> tr1pat p (PIrrPat l) trPattern+    PatTypeSig l p t   -> tr1pat p (\p -> PatTypeSig l p t) trPattern+    PQuasiQuote _ _ _    -> return p+    PBangPat l p         -> tr1pat p (PBangPat l) trPattern+    PNPlusK _ _ _        -> return p++  where -- Transform a pattern field.+    trPatternField :: PatField () -> Tr (PatField ())+    trPatternField (PFieldPat l n p) =+        tr1pat p (PFieldPat l n) trPattern+    trPatternField p = return p++    -- | Generate a guard for looking up xml attributes.+    mkAttrGuards :: Name () -> [PXAttr ()] -> Maybe (Pat ()) -> Tr ()+    mkAttrGuards 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 (pTuple [pat, rml]) rhs++    mkAttrGuards 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 (pTuple [pat, pvar newAttrs]) rhs+        -- ... and finally recurse+        mkAttrGuards newAttrs xs mattr++    -- | Generate a declaration at top level that will finalise all+    -- variable continuations, and then return all bound variables.+    mkTopDecl :: Name () -> [Name ()] -> Tr (Name ())+    mkTopDecl mname vars =+        do -- Give the match function a name+           n <- genMatchName+           -- Create the declaration and add it to the store.+           pushDecl $ topDecl n mname vars+           -- Return the name of the match function so that the+           -- guard that will be generated can call it.+           return n++    topDecl :: Name () -> Name () -> [Name ()] -> Decl ()+    topDecl n mname vs =+        let pat  = pTuple [wildcard, pvarTuple vs]      -- (_, (foo, bar, ...))+            g    = var mname                            -- harp_matchX+            a    = genStmt 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 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 :: [Name ()] -> Name () -> Name () -> Tr ()+    mkGuard vars mname n = do+        let tvs = pvarTuple vars                        -- (foo, bar, ...)+            ge  = appFun runMatchFun [var mname, var n] -- runMatch harp_matchX harp_patY+        pushGuard (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 l = (Name l, [Name l], MType)+++-- | Transform away a regular pattern, generating code+-- to replace it.+trRPat :: Bool -> RPat () -> Tr (MFunMetaInfo ())+trRPat 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 linear p++      where+        -- | Generate declarations for matching ordinary Haskell patterns+        mkBaseDecl :: Bool -> Pat () -> Tr (MFunMetaInfo ())+        mkBaseDecl linear p = case p of+            -- We can simplify a lot if the pattern is a wildcard or a variable+            PWildCard _ -> mkWCMatch+            PVar _ v    -> mkVarMatch linear v+            -- ... and if it is an embedded pattern tag, we can just skip it+            PXPatTag _ q -> mkBaseDecl 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 linear p+                              -- ... apply baseMatch to the case matcher to+                              -- lift it into the matcher monad.+                              newname <- mkBaseMatch 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 :: Bool -> Pat () -> Tr (MFunMetaInfo ())+        mkBasePat 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 b n vs p >>= pushDecl+           return (n, vs, S)++        -- | Generate a basic casing function for a given pattern.+        basePatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> Tr (Decl ())+        basePatDecl 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 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 f a rhs+           where baseCaseE :: Bool -> Pat () -> Name () -> [Name ()] -> Tr (Exp ())+                 baseCaseE b p a vs = do+                    -- First the alternative if we actually+                    -- match the given pattern+                    let alt1 = alt 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 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 linear p gs++     where mkGuardDecl :: Bool -> Pat () -> [Stmt ()] -> Tr (MFunMetaInfo ())+           mkGuardDecl linear p gs = case p of+                -- If it is an embedded pattern tag, we want to skip it+                PXPatTag _ q -> mkGuardDecl 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 linear p gs+                      -- ... apply baseMatch to the case matcher to+                      -- lift it into the matcher monad.+                      newname <- mkBaseMatch 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 :: Bool -> Pat () -> [Stmt ()] -> Tr (MFunMetaInfo ())+           mkGuardPat 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 b n vs p gs >>= pushDecl+                   return (n, vs, S)++           -- | Generate a basic casing function for a given pattern.+           guardPatDecl :: Bool -> Name () -> [Name ()] -> Pat () -> [Stmt ()] -> Tr (Decl ())+           guardPatDecl 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 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 f a rhs+              where guardedCaseE :: Bool -> Pat () -> [Stmt ()] -> Name () -> [Name ()] -> Tr (Exp ())+                    guardedCaseE b p gs a vs = do+                        -- First the alternative if we actually+                        -- match the given pattern+                        let alt1 = altGW p gs                 -- foo -> Just (mf foo)+                                    (app (con just_name) $+                                    tuple (map (retVar b) vs)) (binds [])+                            -- .. and finally an alternative for not matching the pattern.+                            alt2 = alt 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 linear) rps+        mkSeqDecl nvts++      where+        -- | Generate a match function for a sequence of regular patterns,+        -- flattening any special sub-patterns into normal elements of the list+        mkSeqDecl :: [MFunMetaInfo ()] -> Tr (MFunMetaInfo ())+        mkSeqDecl 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 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 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 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 :: [(Name (), MType)] -> [Decl ()]+        flattenVals nts =+            let -- Flatten the values of all sub-patterns to+                -- lists of elements+                (nns, ds) = unzip $ map flVal nts+                -- ... and concatenate their results.+                ret       = nameBind retname $ app+                              (paren $ app foldCompFun+                                (listE $ map var nns)) $ eList+             in ds ++ [ret]++        flVal :: (Name (), MType) -> (Name (), Decl ())+        flVal (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 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 linear rp+        -- ... and create a declaration to bind its value.+        n <- mkCAsDecl nvt+        -- The type of the value is unchanged.+        return (n, (v:vs), mt)++      where+        -- | Generate a declaration for a \@: binding.+        mkCAsDecl :: 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 linear rp+                -- ... and create a declaration to bind its value+                n <- mkAsDecl 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 :: 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 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 False rp+           -- ... and create a declaration that can optionally match it.+           mkOptDecl False nvt+    -- ... similarly for the non-greedy version.+    RPOp _ rp (RPOptG _) ->+        do -- Transform the subpattern+           nvt <- trRPat False rp+           -- ... and create a declaration that can optionally match it.+           mkOptDecl 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 False rp1+           nvt2 <- trRPat False rp2+           -- ... and create a declaration that can choose between them.+           mkEitherDecl nvt1 nvt2+        -- Generate declarations for either patterns, i.e. ( | )+      where mkEitherDecl :: MFunMetaInfo () -> MFunMetaInfo () -> Tr (MFunMetaInfo ())+            mkEitherDecl nvt1@(_, vs1, t1) nvt2@(_, vs2, t2) = do+                -- Eine namen, bitte!+                n <- genMatchName+                let -- Generate generators for the subpatterns+                    (g1, v1) = mkGenExp nvt1+                    (g2, v2) = mkGenExp 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 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 False rp+           -- ... and create a declaration that can match it many times.+           mkStarDecl False nvt+    -- ... and similarly for the non-greedy version.++    RPOp _ rp (RPStarG _) ->+        do -- Transform the subpattern+           nvt <- trRPat False rp+           -- ... and create a declaration that can match it many times.+           mkStarDecl 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 False rp+           -- ... and create a declaration that can match it one or more times.+           mkPlusDecl False nvt++    -- ... and similarly for the non-greedy version.+    RPOp _ rp (RPPlusG _) ->+        do -- Transform the subpattern+           nvt <- trRPat False rp+           -- ... and create a declaration that can match it one or more times.+           mkPlusDecl 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 :: Bool -> Name () -> Tr (MFunMetaInfo ())+    mkVarMatch 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 [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 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 :: Tr (MFunMetaInfo ())+    mkWCMatch = do+            -- First we need a name...+            n <- genMatchName+            -- ... and then a function that always matches, discarding the result+            let e = paren $ lamE [wildcard] $     -- (\_ -> Just ())+                                app (con just_name) (unit_con ())+            -- ... which we lift, bind, and add to the store.+            pushDecl $ nameBind 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]+            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 :: Name () -> Tr (Name ())+    mkBaseMatch name =+            do -- First we need a name...+               n <- genMatchName+               -- ... to which we bind the lifting function+               pushDecl $ baseMatchDecl 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 :: Name () -> Name () -> Decl ()+    baseMatchDecl 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 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 :: Int -> [MFunMetaInfo ()] -> [(Stmt (), (Name (), MType))]+    mkGenExps _ [] = []+    mkGenExps 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 pat g, (valname, t)) :               -- (harp_valX, (foo, ...)) <- harp_matchY+                mkGenExps (k+1) nvs++    -- | Create a single generator.+    mkGenExp :: MFunMetaInfo () -> (Stmt (), Name ())+    mkGenExp nvt = let [(g, (name, _t))] = mkGenExps 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 :: Bool -> Name () -> Stmt ()+    mkManyGen 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 (pvar valsvarsname) $+            app mf (var mname)++    -- | Generate declarations for @: and @ bindings.+    asDecl :: (Exp () -> Exp ()) -> MFunMetaInfo () -> Tr (Name ())+    asDecl mf nvt@(_, vs, _) = do+        -- A name, if you would+        n <- genMatchName                                -- harp_matchX+        let -- Generate a generator for matching the subpattern+            (g, val) = mkGenExp 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 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 :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())+    mkOptDecl 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 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 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 :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())+    mkStarDecl 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 greedy mname+            -- ... and unzip the result, choosing the proper unzip+            -- function depending on the number of variables returned.+            metaUnzipK = mkMetaUnzip (length vs)+            -- ... first unzip values from variables+            dec1    = patBind (pvarTuple [valname, varsname])+                    (metaUnzip $ var valsvarsname)+            -- ... and then unzip the variables+            dec2    = patBind (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 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 :: Bool -> MFunMetaInfo () -> Tr (MFunMetaInfo ())+    mkPlusDecl 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 nvt                       -- (harp_valX, (foo, ...)) <- harpMatchY+            -- ... and then one that matches it many times.+            g2         = mkManyGen greedy mname             -- harp_vvs <- manyMatch harpMatchY+            -- ... we want to unzip the result, using+            -- the proper unzip function+            metaUnzipK = mkMetaUnzip k+            -- ... first unzip values from variables+            dec1    = patBind                               -- (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 (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 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 :: Int -> Exp () -> Exp ()+mkMetaUnzip k | k <= 7 = let n = "unzip" ++ show k+                          in (\e -> matchFunction n [e])+              | otherwise =+                   let vs      = genNames "x" k+                       lvs     = genNames "xs" k+                       uz      = name $ "unzip" ++ show k+                       ys      = name "ys"+                       xs      = name "xs"+                       alt1    = alt peList $ tuple $ replicate k eList   -- [] -> ([], [], ...)+                       pat2    = (pvarTuple vs) `metaPCons` (pvar xs)       -- (x1, x2, ...)+                       ret2    = tuple $ map appCons $ zip vs lvs           -- (x1:xs1, x2:xs2, ...)+                       rhs2    = app (var uz) (var xs)                      -- unzipK xs+                       dec2    = patBind (pvarTuple lvs) rhs2             -- (xs1, xs2, ...) = unzipK xs+                       exp2    = letE [dec2] ret2+                       alt2    = alt pat2 exp2+                       topexp  = lamE [pvar ys] $ caseE (var ys) [alt1, alt2]+                       topbind = nameBind uz topexp+                    in app (paren $ letE [topbind] (var uz))+  where appCons :: (Name (), Name ()) -> Exp ()+        appCons (x, xs) = metaCons (var x) (var xs)++matchFunction :: String -> [Exp ()] -> Exp ()+matchFunction s es = mf s (reverse es)+  where mf s []     = match_qual $ Ident () s+        mf s (e:es) = app (mf s es) e++-- | 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 l n) s = Ident l $ n ++ s+extendVar n _ = n++xNameParts :: XName () -> (Maybe String, String)+xNameParts n = case n of+                XName _ s      -> (Nothing, s)+                XDomName _ d s -> (Just d, s)++---------------------------------------------------------+-- 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 (metaFromStringLit . strE) d, metaFromStringLit $ strE n]+        m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat+        attrs = m $ listE $ map metaAsAttr ats+     in metaFunction "genElement" [ne, attrs, listE cs]++-- | 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 (metaFromStringLit . strE) d, metaFromStringLit $ strE n]+        m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat+        attrs = m $ listE $ map metaAsAttr ats+     in metaFunction "genEElement" [ne, attrs]++-- | Create an attribute by applying the overloaded @asAttr@+metaAsAttr :: Exp () -> Exp ()+metaAsAttr e@(Lit _ (String _ _ _)) = metaFunction "asAttr" [metaFromStringLit e] -- [ExpTypeSig noLoc e (TyCon (UnQual (Ident "Text")))]+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]++-- | convert a 'String' literal to lazy 'Text' by calling a function named 'fromStringLit'+metaFromStringLit :: Exp () -> Exp ()+metaFromStringLit e = metaFunction "fromStringLit" [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      -> metaFromStringLit (strE s)+    XDomName _ d s -> tuple [metaFromStringLit $ strE d, metaFromStringLit $ strE s]++--    XName s      -> textTypeSig (strE s)+--    XDomName d s -> tuple [textTypeSig $ strE d, textTypeSig $ strE s]+--    where+--      textTypeSig e = ExpTypeSig noLoc e (TyCon (UnQual (Ident "Text")))+ 

@@ -81,12 +81,10 @@ process fp fc = prettyPrintWithMode (defaultMode {linePragmas=True}) $                  transform $ checkParse $ parse fp fc -parse :: String -> String -> ParseResult Module-parse fn fc = parseModuleWithMode (ParseMode fn Haskell2010 allExtensions False True (Just baseFixities)-#if MIN_VERSION_haskell_src_exts(1,17,0)-                                             False-#endif-                                             ) fcuc+parse :: String -> String -> ParseResult (Module ())+parse fn fc = fmap (fmap $ const ()) $ parseModuleWithMode (ParseMode fn Haskell2010 allExtensions False True (Just baseFixities)+                                                    False+                                                   ) fcuc   where fcuc= unlines $ filter (not . isPrefixOf "#") $ lines fc  usageString :: String