    -----------------------------------------------------------------------------
    -- |
    -- Module      :  HSX.Tranform
    -- Copyright   :  (c) Niklas Broberg 2004-2009
    -- License     :  BSD-style (see the file LICENSE.txt)
    --
    -- Maintainer  :  Niklas Broberg, niklas.broberg@chalmers.se
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- Functions for transforming abstract Haskell code extended with regular
    -- patterns into semantically equivalent normal abstract Haskell code. In
    -- other words, we transform away regular patterns.
    -----------------------------------------------------------------------------

    module HSX.Transform (
          transform       -- :: HsModule -> HsModule
        , transformExp
        ) where

    import Language.Haskell.Exts.Syntax
    import Language.Haskell.Exts.Build
    import Language.Haskell.Exts.SrcLoc (noLoc)
    import Data.List (union)

    import Debug.Trace (trace)

    -----------------------------------------------------------------------------
    -- A monad for threading a boolean value through the boilerplate code,
    -- to signal whether a transformation has taken place or not.

    newtype HsxM a = MkHsxM (HsxState -> (a, HsxState))

    instance Monad HsxM where
     return x = MkHsxM (\s -> (x,s))
     (MkHsxM f) >>= k = MkHsxM (\s -> let (a, s') = f s
                                          (MkHsxM f') = k a
                                       in f' s')

    getHsxState :: HsxM HsxState
    getHsxState = MkHsxM (\s -> (s, s))

    setHsxState :: HsxState -> HsxM ()
    setHsxState s = MkHsxM (\_ -> ((),s))

    instance Functor HsxM where
     fmap f hma = do a <- hma
                     return $ f a

    -----

    type HsxState = (Bool, Bool)

    initHsxState :: HsxState
    initHsxState = (False, False)

    setHarpTransformed :: HsxM ()
    setHarpTransformed =
        do (_,x) <- getHsxState
           setHsxState (True,x)

    setXmlTransformed :: HsxM ()
    setXmlTransformed =
        do (h,_) <- getHsxState
           setHsxState (h,True)

    runHsxM :: HsxM a -> (a, (Bool, Bool))
    runHsxM (MkHsxM f) = f initHsxState

    -----------------------------------------------------------------------------
    -- Traversing and transforming the syntax tree

    -- | Transform away occurences of regular patterns from an abstract
    -- Haskell module, preserving semantics.
    transform :: Module -> Module
    transform (Module s m pragmas warn mes is decls) =
        let (decls', (harp, hsx)) = runHsxM $ mapM transformDecl decls
            -- We may need to add an import for Match.hs that defines the matcher monad
            imps1 = if harp
                 then (:) $ ImportDecl s match_mod True False Nothing
                                (Just match_qual_mod)
                                Nothing
                 else id
            imps2 = {- if hsx
                     then (:) $ ImportDecl s hsx_data_mod False
                             Nothing
                             Nothing
                     else -} id     -- we no longer want to import HSP.Data
         in Module s m pragmas warn mes (imps1 $ imps2 is) decls'

    -----------------------------------------------------------------------------
    -- Declarations

    -- | Transform a declaration by transforming subterms that could
    -- contain regular patterns.
    transformDecl :: Decl -> HsxM Decl
    transformDecl d = case d of
        -- Pattern binds can contain regular patterns in the pattern being bound
        -- as well as on the right-hand side and in declarations in a where clause
        PatBind srcloc pat mty rhs decls -> do
            -- Preserve semantics of irrefutable regular patterns by postponing
            -- their evaluation to a let-expression on the right-hand side
            let ([pat'], rnpss) = unzip $ renameIrrPats [pat]
            -- Transform the pattern itself
            ([pat''], attrGuards, guards, decls'') <- transformPatterns srcloc [pat']
            -- Transform the right-hand side, and add any generated guards
            -- and let expressions to it
            rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs
            -- Transform declarations in the where clause, adding any generated
            -- declarations to it
            decls' <- case decls of
                   BDecls ds -> do ds' <- transformLetDecls ds
                                   return $ BDecls $ decls'' ++ ds'
                   _           -> error "Cannot bind implicit parameters in the \
                            \ \'where\' clause of a function using regular patterns."
            return $ PatBind srcloc pat'' mty rhs' decls'

        -- Function binds can contain regular patterns in their matches
        FunBind ms -> fmap FunBind $ mapM transformMatch ms
        -- Instance declarations can contain regular patterns in the
        -- declarations of functions inside it
        InstDecl s c n ts idecls ->
            fmap (InstDecl s c n ts) $ mapM transformInstDecl idecls
        -- Class declarations can contain regular patterns in the
        -- declarations of automatically instantiated functions
        ClassDecl s c n ns ds cdecls ->
            fmap (ClassDecl s c n ns ds) $ mapM transformClassDecl cdecls
        -- TH splices are expressions and can contain regular patterns
        SpliceDecl srcloc e ->
            fmap (SpliceDecl srcloc) $ transformExpM e
        -- Type signatures, type, newtype or data declarations, infix declarations,
        -- type and data families and instances, foreign imports and exports,
        -- and default declarations; none can contain regular patterns.
        -- Note that we don't transform inside rules pragmas!
        _ -> return d

    transformInstDecl :: InstDecl -> HsxM InstDecl
    transformInstDecl d = case d of
        InsDecl decl -> fmap InsDecl $ transformDecl decl
        _ -> return d

    transformClassDecl :: ClassDecl -> HsxM ClassDecl
    transformClassDecl d = case d of
        ClsDecl decl -> fmap ClsDecl $ transformDecl decl
        _ -> return d

    -- | Transform a function "match" by generating pattern guards and
    -- declarations representing regular patterns in the argument list.
    -- Subterms, such as guards and the right-hand side, are also traversed
    -- transformed.
    transformMatch :: Match -> HsxM Match
    transformMatch (Match srcloc name pats mty rhs decls) = do
        -- Preserve semantics of irrefutable regular patterns by postponing
        -- their evaluation to a let-expression on the right-hand side
        let (pats', rnpss) = unzip $ renameIrrPats pats
        -- Transform the patterns that stand as arguments to the function
        (pats'', attrGuards, guards, decls'') <- transformPatterns srcloc pats'
        -- Transform the right-hand side, and add any generated guards
        -- and let expressions to it
        rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs
        -- Transform declarations in the where clause, adding any generated
        -- declarations to it
        decls' <- case decls of
               BDecls ds -> do ds' <- transformLetDecls ds
                               return $ BDecls $ decls'' ++ ds'
               _           -> error "Cannot bind implicit parameters in the \
                         \ \'where\' clause of a function using regular patterns."

        return $ Match srcloc name pats'' mty rhs' decls'
    -- | Transform and update guards and right-hand side of a function or
    -- pattern binding. The supplied list of guards is prepended to the
    -- original guards, and subterms are traversed and transformed.
    mkRhs :: SrcLoc -> [Guard] -> [(Name, Pat)] -> Rhs -> HsxM Rhs
    mkRhs srcloc guards rnps (UnGuardedRhs rhs) = do
        -- Add the postponed patterns to the right-hand side by placing
        -- them in a let-expression to make them lazily evaluated.
        -- Then transform the whole right-hand side as an expression.
        rhs' <- transformExpM $ addLetDecls srcloc rnps rhs
        case guards of
         -- There were no guards before, and none should be added,
         -- so we still have an unguarded right-hand side
         [] -> return $ UnGuardedRhs rhs'
         -- There are guards to add. These should be added as pattern
         -- guards, i.e. as statements.
         _  -> return $ GuardedRhss [GuardedRhs srcloc (map mkStmtGuard guards) rhs']
    mkRhs _ guards rnps (GuardedRhss gdrhss) = fmap GuardedRhss $ mapM (mkGRhs guards rnps) gdrhss
      where mkGRhs :: [Guard] -> [(Name, Pat)] -> GuardedRhs -> HsxM GuardedRhs
            mkGRhs gs rnps (GuardedRhs s oldgs rhs) = do
                -- Add the postponed patterns to the right-hand side by placing
                -- them in a let-expression to make them lazily evaluated.
                -- Then transform the whole right-hand side as an expression.
                rhs' <- transformExpM $ addLetDecls s rnps rhs
                -- Now there are guards, so first we need to transform those
                oldgs' <- fmap concat $ mapM (transformStmt GuardStmt) oldgs
                -- ... and then prepend the newly generated ones, as statements
                return $ GuardedRhs s ((map mkStmtGuard gs) ++ oldgs') rhs'

    -- | Place declarations of postponed regular patterns in a let-expression to
    -- make them lazy, in order to make them behave as irrefutable patterns.
    addLetDecls :: SrcLoc -> [(Name, Pat)] -> Exp -> Exp
    addLetDecls s []   e = e    -- no declarations to add
    addLetDecls s rnps e =
        -- Place all postponed patterns in the same let-expression
        letE (map (mkDecl s) rnps) e

    -- | Make pattern binds from postponed regular patterns
    mkDecl :: SrcLoc -> (Name, Pat) -> Decl
    mkDecl srcloc (n,p) = patBind srcloc p (var n)

    ------------------------------------------------------------------------------------
    -- Expressions

    -- | Transform expressions by traversing subterms.
    -- Of special interest are expressions that contain patterns as subterms,
    -- i.e. @let@, @case@ and lambda expressions, and also list comprehensions
    -- and @do@-expressions. All other expressions simply transform their
    -- sub-expressions, if any.
    -- Of special interest are of course also any xml expressions.
    transformExp :: Exp -> Exp
    transformExp e =
        let (e', _) = runHsxM $ transformExpM e
        in e'

    -- | Transform expressions by traversing subterms.
    -- Of special interest are expressions that contain patterns as subterms,
    -- i.e. @let@, @case@ and lambda expressions, and also list comprehensions
    -- and @do@-expressions. All other expressions simply transform their
    -- sub-expressions, if any.
    -- Of special interest are of course also any xml expressions.
    transformExpM :: Exp -> HsxM Exp
    transformExpM e = case e of
        -- A standard xml tag should be transformed into an element of the
        -- XML datatype. Attributes should be made into a set of mappings,
        -- and children should be transformed.
        XTag _ name attrs mattr cs -> do
            -- Hey Pluto, look, we have XML in our syntax tree!
            setXmlTransformed
            let -- ... make tuples of the attributes
                as = map mkAttr attrs
            -- ... transform the children
            cs' <- mapM transformChild cs
            -- ... and lift the values into the XML datatype.
            return $ paren $ metaGenElement name as mattr cs'

        -- An empty xml tag should be transformed just as a standard tag,
        -- only that there are no children,
        XETag _ name attrs mattr -> do
            -- ... 'tis the season to be jolly, falalalalaaaa....
            setXmlTransformed
            let -- ... make tuples of the attributes
                as = map mkAttr attrs
                -- ... and lift the values into the XML datatype.
            return $ paren $ metaGenEElement name as mattr

        -- A child tag should be transformed into an application
        -- of asChild to a list of children.
        XChildTag _ cs  -> do
            -- After all, it IS christmas!
            setXmlTransformed
            -- ... transform the children
            cs' <- mapM transformChild cs
            -- ... and make them into a list
            return $ paren $ metaAsChild $ listE cs'

        -- PCDATA should be lifted as a string into the XML datatype.
        XPcdata pcdata    -> do setXmlTransformed
                                return $ ExpTypeSig noLoc (strE pcdata) (TyCon (UnQual (Ident "String")))
        -- Escaped expressions should be treated as just expressions.
        XExpTag e     -> do setXmlTransformed
                            e' <- transformExpM e
                            return $ paren $ metaAsChild e'

        -- Patterns as arguments to a lambda expression could be regular,
        -- but we cannot put the evaluation here since a lambda expression
        -- can have neither guards nor a where clause. Thus we must postpone
        -- them to a case expressions on the right-hand side.
        Lambda s pats rhs -> do
            let -- First rename regular patterns
                (ps, rnpss)  = unzip $ renameRPats pats
                -- ... group them up to one big tuple
                (rns, rps) = unzip (concat rnpss)
                alt1 = alt s (pTuple rps) rhs
                texp = varTuple rns
                -- ... and put it all in a case expression, which
                -- can then be transformed in the normal way.
                e = if null rns then rhs else caseE texp [alt1]
            rhs' <- transformExpM e
            return $ Lambda s ps rhs'
        -- A let expression can contain regular patterns in the declarations,
        -- or in the expression that makes up the body of the let.
        Let (BDecls ds) e -> do
            -- Declarations appearing in a let expression must be transformed
            -- in a special way due to scoping, see later documentation.
            -- The body is transformed as a normal expression.
            ds' <- transformLetDecls ds
            e'  <- transformExpM e
            return $ letE ds' e'
        -- Bindings of implicit parameters can appear either in ordinary let
        -- expressions (GHC), in dlet expressions (Hugs) or in a with clause
        -- (both). Such bindings are transformed in a special way. The body
        -- is transformed as a normal expression in all cases.
        Let (IPBinds is) e -> do
            is' <- mapM transformIPBind is
            e'  <- transformExpM e
            return $ Let (IPBinds is') e'
        -- A case expression can contain regular patterns in the expression
        -- that is the subject of the casing, or in either of the alternatives.
        Case e alts -> do
            e'    <- transformExpM e
            alts' <- mapM transformAlt alts
            return $ Case e' alts'
        -- A do expression can contain regular patterns in its statements.
        Do stmts -> do
            stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts
            return $ Do stmts'
        MDo stmts -> do
            stmts' <- fmap concat $ mapM (transformStmt DoStmt) stmts
            return $ MDo stmts'
        -- A list comprehension can contain regular patterns in the result
        -- expression, or in any of its statements.
        ListComp e stmts  -> do
            e'     <- transformExpM e
            stmts' <- fmap concat $ mapM transformQualStmt stmts
            return $ ListComp e' stmts'
        ParComp e stmtss  -> do
            e'      <- transformExpM e
            stmtss' <- fmap (map concat) $ mapM (mapM transformQualStmt) stmtss
            return $ ParComp e' stmtss'
        Proc s pat rhs          -> do
            let -- First rename regular patterns
                ([p], [rnps])  = unzip $ renameRPats [pat]
                -- ... group them up to one big tuple
                (rns, rps) = unzip rnps
                alt1 = alt s (pTuple rps) rhs
                texp = varTuple rns
                -- ... and put it all in a case expression, which
                -- can then be transformed in the normal way.
                e = if null rns then rhs else caseE texp [alt1]
            rhs' <- transformExpM e
            return $ Proc s p rhs'

        -- All other expressions simply transform their immediate subterms.
        InfixApp e1 op e2 -> transform2exp e1 e2
                                    (\e1 e2 -> InfixApp e1 op e2)
        App e1 e2         -> transform2exp e1 e2 App
        NegApp e          -> fmap NegApp $ transformExpM e
        If e1 e2 e3       -> transform3exp e1 e2 e3 If
        Tuple 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` (stringTypeSig e))
        where
          stringTypeSig e@(Lit (String _)) = ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))
          stringTypeSig e                  = e

    -- | Transform pattern bind declarations inside a @let@-expression by transforming
    -- subterms that could appear as regular patterns, as well as transforming the bound
    -- pattern itself. The reason we need to do this in a special way is scoping, i.e.
    -- in the expression @let a | Just b <- match a = list in b@ the variable b will not
    -- be in scope after the @in@. And besides, we would be on thin ice even if it was in
    -- scope since we are referring to the pattern being bound in the guard that will
    -- decide if the pattern will be bound... yikes, why does Haskell allow guards on
    -- pattern binds to refer to the patterns being bound, could that ever lead to anything
    -- but an infinite loop??
    transformLetDecls :: [Decl] -> HsxM [Decl]
    transformLetDecls ds = do
        -- We need to rename regular patterns in pattern bindings, since we need to
        -- separate the generated declaration sets. This since we need to add them not
        -- to the actual binding but rather to the declaration that will be the guard
        -- of the binding.
        let ds' = renameLetDecls ds
        transformLDs 0 0 ds'
      where transformLDs :: Int -> Int -> [Decl] -> HsxM [Decl]
            transformLDs k l ds = case ds of
                []     -> return []
                (d:ds) -> case d of
                    PatBind srcloc pat mty rhs decls -> do
                        -- We need to transform all pattern bindings in a set of
                        -- declarations in the same context w.r.t. generating fresh
                        -- variable names, since they will all be in scope at the same time.
                        ([pat'], ags, gs, ws, k', l') <- runTrFromTo k l (trPatterns srcloc [pat])
                        decls' <- case decls of
                            -- Any declarations already in place should be left where they
                            -- are since they probably refer to the generating right-hand
                            -- side of the pattern bind. If they don't, we're in trouble...
                            BDecls decls -> fmap BDecls $ transformLetDecls decls
                            -- If they are implicit parameter bindings we simply transform
                            -- them as such.
                            IPBinds decls -> fmap IPBinds $ mapM transformIPBind decls
                        -- The generated guard, if any, should be a declaration, and the
                        -- generated declarations should be associated with it.
                        let gs' = case gs of
                               []  -> []
                               [g] -> [mkDeclGuard g ws]
                               _   -> error "This should not happen since we have called renameLetDecls already!"
                            -- Generated attribute guards should also be added as declarations,
                            -- but with no where clauses.
                            ags' = map (flip mkDeclGuard $ []) ags
                        -- We must transform the right-hand side as well, but there are
                        -- no new guards, nor any postponed patterns, to supply at this time.
                        rhs' <- mkRhs srcloc [] [] rhs
                        -- ... and then we should recurse with the new gensym argument.
                        ds' <- transformLDs k' l' ds
                        -- The generated guards, which should be at most one, should be
                        -- added as declarations rather than as guards due to the
                        -- scoping issue described above.
                        return $ (PatBind srcloc pat' mty rhs' decls') : ags' ++ gs' ++ ds'

                        -- We only need to treat pattern binds separately, other declarations
                        -- can be transformed normally.
                    d -> do d'  <- transformDecl d
                            ds' <- transformLDs k l ds
                            return $ d':ds'

    -- | Transform binding of implicit parameters by transforming the expression on the
    -- right-hand side. The left-hand side can only be an implicit parameter, so no
    -- regular patterns there...
    transformIPBind :: IPBind -> HsxM IPBind
    transformIPBind (IPBind s n e) =
        fmap (IPBind s n) $ transformExpM e

    ------------------------------------------------------------------------------------
    -- Statements of various kinds

    -- | A simple annotation datatype for statement contexts.
    data StmtType = DoStmt | GuardStmt | ListCompStmt

    -- | Transform statements by traversing and transforming subterms.
    -- Since generator statements have slightly different semantics
    -- depending on their context, statements are annotated with their
    -- context to ensure that the semantics of the resulting statement
    -- sequence is correct. The return type is a list since generated
    -- guards will be added as statements on the same level as the
    -- statement to be transformed.
    transformStmt :: StmtType -> Stmt -> HsxM [Stmt]
    transformStmt t s = case s of
        -- Generators can have regular patterns in the result pattern on the
        -- left-hand side and in the generating expression.
        Generator s p e -> do
            let -- We need to treat generated guards differently depending
                -- on the context of the statement.
                guardFun = case t of
                    DoStmt       -> monadify
                    ListCompStmt -> monadify
                    GuardStmt    -> mkStmtGuard
                -- Preserve semantics of irrefutable regular patterns by postponing
                -- their evaluation to a let-expression on the right-hand side
                ([p'], rnpss) = unzip $ renameIrrPats [p]
            -- Transform the pattern itself
            ([p''], ags, gs, ds) <- transformPatterns s [p']
            -- Put the generated declarations in a let-statement
            let lt  = case ds of
                   [] -> []
                   _  -> [letStmt ds]
                -- Perform the designated trick on the generated guards.
                gs' = map guardFun (ags ++ gs)
            -- Add the postponed patterns to the right-hand side by placing
            -- them in a let-expression to make them lazily evaluated.
            -- Then transform the whole right-hand side as an expression.
            e' <- transformExpM $ addLetDecls s (concat rnpss) e
            return $ Generator s p'' e':lt ++ gs'
          where monadify :: Guard -> Stmt
                -- To monadify is to create a statement guard, only that the
                -- generation must take place in a monad, so we need to "return"
                -- the value gotten from the guard.
                monadify (s,p,e) = genStmt s p (metaReturn $ paren e)
        -- Qualifiers are simply wrapped expressions and are treated as such.
        Qualifier e -> fmap (\e -> [Qualifier $ e]) $ transformExpM e
        -- Let statements suffer from the same problem as let expressions, so
        -- the declarations should be treated in the same special way.
        LetStmt (BDecls ds)  ->
            fmap (\ds -> [letStmt ds]) $ transformLetDecls ds
        -- If the bindings are of implicit parameters we simply transform them as such.
        LetStmt (IPBinds is) ->
            fmap (\is -> [LetStmt (IPBinds is)]) $ mapM transformIPBind is
        RecStmt stmts   ->
            fmap (return . RecStmt . concat) $ mapM (transformStmt t) stmts

    transformQualStmt :: QualStmt -> HsxM [QualStmt]
    transformQualStmt qs = case qs of
        -- For qual statments in list comprehensions we just pass on the baton
        QualStmt     s      -> fmap (map QualStmt) $ transformStmt ListCompStmt s
        ThenTrans    e      -> fmap (return . ThenTrans) $ transformExpM e
        ThenBy       e f    -> fmap return $ transform2exp e f ThenBy
        GroupBy      e      -> fmap (return . GroupBy) $ transformExpM e
        GroupUsing   f      -> fmap (return . GroupUsing) $ transformExpM f
        GroupByUsing e f    -> fmap return $ transform2exp e f GroupByUsing

    ------------------------------------------------------------------------------------------
    -- Case alternatives

    -- | Transform alternatives in a @case@-expression. Patterns are
    -- transformed, while other subterms are traversed further.
    transformAlt :: Alt -> HsxM Alt
    transformAlt (Alt srcloc pat rhs decls) = do
        -- Preserve semantics of irrefutable regular patterns by postponing
        -- their evaluation to a let-expression on the right-hand side
        let ([pat'], rnpss) = unzip $ renameIrrPats [pat]
        -- Transform the pattern itself
        ([pat''], attrGuards, guards, decls'') <- transformPatterns srcloc [pat']
        -- Transform the right-hand side, and add any generated guards
        -- and let expressions to it.
        rhs' <- mkGAlts srcloc (attrGuards ++ guards) (concat rnpss) rhs
        -- Transform declarations in the where clause, adding any generated
        -- declarations to it.
        decls' <- case decls of
               BDecls ds -> do ds' <- mapM transformDecl ds
                               return $ BDecls $ decls'' ++ ds
               _           -> error "Cannot bind implicit parameters in the \
                         \ \'where\' clause of a function using regular patterns."

        return $ Alt srcloc pat'' rhs' decls'

        -- Transform and update guards and right-hand side of a case-expression.
        -- The supplied list of guards is prepended to the original guards, and
        -- subterms are traversed and transformed.
      where mkGAlts :: SrcLoc -> [Guard] -> [(Name, Pat)] -> GuardedAlts -> HsxM GuardedAlts
            mkGAlts s guards rnps (UnGuardedAlt rhs) = do
                -- Add the postponed patterns to the right-hand side by placing
                -- them in a let-expression to make them lazily evaluated.
                -- Then transform the whole right-hand side as an expression.
                rhs' <- transformExpM $ addLetDecls s rnps rhs
                case guards of
                 -- There were no guards before, and none should be added,
                 -- so we still have an unguarded right-hand side
                 [] -> return $ UnGuardedAlt rhs'
                 -- There are guards to add. These should be added as pattern
                 -- guards, i.e. as statements.
                 _  -> return $ GuardedAlts [GuardedAlt s (map mkStmtGuard guards) rhs']
            mkGAlts s gs rnps (GuardedAlts galts) =
                fmap GuardedAlts $ mapM (mkGAlt gs rnps) galts
              where mkGAlt :: [Guard] -> [(Name, Pat)] -> GuardedAlt -> HsxM GuardedAlt
                    mkGAlt gs rnps (GuardedAlt s oldgs rhs) = do
                        -- Add the postponed patterns to the right-hand side by placing
                        -- them in a let-expression to make them lazily evaluated.
                        -- Then transform the whole right-hand side as an expression.
                        rhs'   <- transformExpM $ addLetDecls s rnps rhs
                        -- Now there are guards, so first we need to transform those
                        oldgs' <- fmap concat $ mapM (transformStmt GuardStmt) oldgs
                        -- ... and then prepend the newly generated ones, as statements
                        return $ GuardedAlt s ((map mkStmtGuard gs) ++ oldgs') rhs'

    ----------------------------------------------------------------------------------
    -- Guards

    -- In some places, a guard will be a declaration instead of the
    -- normal statement, so we represent it in a generic fashion.
    type Guard = (SrcLoc, Pat, Exp)

    mkStmtGuard :: Guard -> Stmt
    mkStmtGuard (s, p, e) = genStmt s p e

    mkDeclGuard :: Guard -> [Decl] -> Decl
    mkDeclGuard (s, p, e) ds = patBindWhere s p e ds

    ----------------------------------------------------------------------------------
    -- Rewriting expressions before transformation.
    -- Done in a monad for gensym capability.

    newtype RN a = RN (RNState -> (a, RNState))

    type RNState = Int

    initRNState = 0

    instance Monad RN where
     return a = RN $ \s -> (a,s)
     (RN f) >>= k = RN $ \s -> let (a,s') = f s
                                   (RN g) = k a
                                in g s'

    instance Functor RN where
     fmap f rna = do a <- rna
                     return $ f a

    runRename :: RN a -> a
    runRename (RN f) = let (a,_) = f initRNState
                        in a

    getRNState :: RN RNState
    getRNState = RN $ \s -> (s,s)

    setRNState :: RNState -> RN ()
    setRNState s = RN $ \_ -> ((), s)

    genVarName :: RN Name
    genVarName = do
        k <- getRNState
        setRNState $ k+1
        return $ name $ "harp_rnvar" ++ show k

    type NameBind = (Name, Pat)

    -- Some generic functions on monads for traversing subterms

    rename1pat :: a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
    rename1pat p f rn = do (q, ms) <- rn p
                           return (f q, ms)

    rename2pat :: a -> a -> (b -> b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
    rename2pat p1 p2 f rn = do (q1, ms1) <- rn p1
                               (q2, ms2) <- rn p2
                               return $ (f q1 q2, ms1 ++ ms2)

    renameNpat :: [a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])
    renameNpat ps f rn = do (qs, mss) <- fmap unzip $ mapM rn ps
                            return (f qs, concat mss)

    -- | Generate variables as placeholders for any regular patterns, in order
    -- to place their evaluation elsewhere. We must likewise move the evaluation
    -- of Tags because attribute lookups are force evaluation.
    renameRPats :: [Pat] -> [(Pat, [NameBind])]
    renameRPats ps = runRename $ mapM renameRP ps

    renameRP :: Pat -> RN (Pat, [NameBind])
    renameRP p = case p of
        -- We must rename regular patterns and Tag expressions
        PRPat _           -> rename p
        PXTag _ _ _ _ _   -> rename p
        PXETag _ _ _ _    -> rename p
        -- The rest of the rules simply try to rename regular patterns in
        -- their immediate subpatterns.
        PNeg p            -> rename1pat p PNeg renameRP
        PInfixApp p1 n p2 -> rename2pat p1 p2
                                    (\p1 p2 -> PInfixApp p1 n p2)
                                    renameRP
        PApp n ps         -> renameNpat ps (PApp n) renameRP
        PTuple 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 mty rhs decls -> do
                    -- Rename any regular patterns that appear in the
                    -- pattern being bound.
                    (p, ms) <- renameRP pat
                    let sms = map (\(n,p) -> (srcloc, n, p)) ms
                    return $ (PatBind srcloc p mty rhs decls, sms)
                _ -> return (d, [])

    -- | Move irrefutable regular patterns into a @let@-expression instead,
    -- to make sure that the semantics of @~@ are preserved.
    renameIrrPats :: [Pat] -> [(Pat, [NameBind])]
    renameIrrPats ps = runRename (mapM renameIrrP ps)

    renameIrrP :: Pat -> RN (Pat, [(Name, Pat)])
    renameIrrP p = case p of
        -- We should rename any regular pattern appearing
        -- inside an irrefutable pattern.
        PIrrPat p     -> do (q, ms) <- renameRP p
                            return $ (PIrrPat q, ms)
        -- The rest of the rules simply try to rename regular patterns in
        -- irrefutable patterns in their immediate subpatterns.
        PNeg p            -> rename1pat p PNeg renameIrrP
        PInfixApp p1 n p2 -> rename2pat p1 p2
                                    (\p1 p2 -> PInfixApp p1 n p2)
                                    renameIrrP
        PApp n ps         -> renameNpat ps (PApp n) renameIrrP
        PTuple 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 Monad Tr where
     return a = Tr $ \s -> return (a, s)
     (Tr f) >>= k = Tr $ \s ->
              do (a, s') <- f s
                 let (Tr f') = k a
                 f' s'

    instance Functor Tr where
     fmap f tra = tra >>= (return . f)

    liftTr :: HsxM a -> Tr a
    liftTr hma = Tr $ \s -> do a <- hma
                               return (a, s)

    initState = initStateFrom 0 0

    initStateFrom k l = (0, k, l, [], [], [])

    runTr :: Tr a -> HsxM (a, [Guard], [Guard], [Decl])
    runTr (Tr f) = do (a, (_,_,_,gs1,gs2,ds)) <- f initState
                      return (a, reverse gs1, reverse gs2, reverse ds)

    runTrFromTo :: Int -> Int -> Tr a -> HsxM (a, [Guard], [Guard], [Decl], Int, Int)
    runTrFromTo k l (Tr f) = do (a, (_,k',l',gs1,gs2,ds)) <- f $ initStateFrom k l
                                return (a, reverse gs1, reverse gs2, reverse ds, k', l')

    -- manipulating the state
    getState :: Tr State
    getState = Tr $ \s -> return (s,s)

    setState :: State -> Tr ()
    setState s = Tr $ \_ -> return ((),s)

    updateState :: (State -> (a,State)) -> Tr a
    updateState f = do s <- getState
                       let (a,s') = f s
                       setState s'
                       return a

    -- specific state manipulating functions
    pushGuard :: SrcLoc -> Pat -> Exp -> Tr ()
    pushGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,(s,p,e):gs2,ds))

    pushDecl :: Decl -> Tr ()
    pushDecl d = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,gs2,d:ds))

    pushAttrGuard :: SrcLoc -> Pat -> Exp -> Tr ()
    pushAttrGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,(s,p,e):gs1,gs2,ds))

    genMatchName :: Tr Name
    genMatchName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (n,(n+1,m,a,gs1,gs2,ds))
                      return $ Ident $ "harp_match" ++ show k

    genPatName :: Tr Name
    genPatName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m+1,a,gs1,gs2,ds))
                    return $ Ident $ "harp_pat" ++ show k

    genAttrName :: Tr Name
    genAttrName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m,a+1,gs1,gs2,ds))
                     return $ Ident $ "hsx_attrs" ++ show k

    setHarpTransformedT, setXmlTransformedT :: Tr ()
    setHarpTransformedT = liftTr setHarpTransformed
    setXmlTransformedT  = liftTr setXmlTransformed

    -------------------------------------------------------------------
    -- Some generic functions for computations in the Tr monad. Could
    -- be made even more general, but there's really no point right now...

    tr1pat :: a -> (b -> c) -> (a -> Tr b) -> Tr c
    tr1pat p f tr = do q <- tr p
                       return $ f q

    tr2pat :: a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c
    tr2pat p1 p2 f tr = do q1 <- tr p1
                           q2 <- tr p2
                           return $ f q1 q2

    trNpat :: [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c
    trNpat ps f tr = do qs <- mapM tr ps
                        return $ f qs

    -----------------------------------------------------------------------------
    -- The *real* transformations
    -- Transforming patterns

    -- | Transform several patterns in the same context
    trPatterns :: SrcLoc -> [Pat] -> Tr [Pat]
    trPatterns s = mapM (trPattern s)

    -- | Transform a pattern by traversing the syntax tree.
    -- A regular pattern is translated, other patterns are
    -- simply left as is.
    trPattern :: SrcLoc -> Pat -> Tr Pat
    trPattern s p = case p of
        -- This is where the fun starts. =)
        -- Regular patterns must be transformed of course.
        PRPat rps -> do
            -- First we need a name for the placeholder pattern.
            n <- genPatName
            -- A top-level regular pattern is a sequence in linear
            -- context, so we can simply translate it as if it was one.
            (mname, vars, _) <- trRPat s True (RPSeq rps)
            -- Generate a top level declaration.
            topmname <- mkTopDecl s mname vars
            -- Generate a pattern guard for this regular pattern,
            -- that will match the generated declaration to the
            -- value of the placeholder, and bind all variables.
            mkGuard s vars topmname n
            -- And indeed, we have made a transformation!
            setHarpTransformedT
            -- Return the placeholder pattern.
            return $ pvar n
        -- Tag patterns should be transformed
        PXTag s name attrs mattr cpats -> do
            -- We need a name for the attribute list, if there are lookups
            an <- case (mattr, attrs) of
                    -- ... if there is one already, and there are no lookups
                    -- we can just return that
                    (Just ap, []) -> return $ ap
                          -- ... if there are none, we dont' care
                    (_, []) -> return wildcard
                    (_, _)  -> do -- ... but if there are, we want a name for that list
                                  n <- genAttrName
                                  -- ... we must turn attribute lookups into guards
                                  mkAttrGuards s n attrs mattr
                                  -- ... and we return the pattern
                                  return $ pvar n
            -- ... the pattern representing children should be transformed
            cpat' <- case cpats of
                      -- ... it's a regular pattern, so we can just go ahead and transform it
                      (p@(PXRPats _)):[] -> trPattern s p
                      -- ... it's an ordinary list, so we first wrap it up as such
                      _                    -> trPattern s (PList cpats)
            -- ...  we have made a transformation and should report that
            setHarpTransformedT
            -- ... and we return a Tag pattern.
            let (dom, n) = xNameParts name
            return $ metaTag dom n an cpat'
        -- ... as should empty Tag patterns
        PXETag s name attrs mattr -> do
            -- We need a name for the attribute list, if there are lookups
            an <- case (mattr, attrs) of
                    -- ... if there is a pattern already, and there are no lookups
                    -- we can just return that
                    (Just ap, []) -> return $ ap
                          -- ... if there are none, we dont' care
                    (_, []) -> return wildcard
                    (_, _)  -> do -- ... but if there are, we want a name for that list
                                  n <- genAttrName
                                  -- ... we must turn attribute lookups into guards
                                  mkAttrGuards s n attrs mattr
                                  -- ... and we return the pattern
                                  return $ pvar n
            -- ...  we have made a transformation and should report that
            setHarpTransformedT
            -- ... and we return an ETag pattern.
            let (dom, n) = xNameParts name
            return $ metaTag dom n an peList
        -- PCDATA patterns are strings in the xml datatype.
        PXPcdata st -> setHarpTransformedT >> (return $ metaPcdata st)
        -- XML comments are likewise just treated as strings.
        PXPatTag p -> setHarpTransformedT >> trPattern s p
        -- Regular expression patterns over children should be translated
        -- just like PRPat.
        PXRPats rps -> trPattern s $ PRPat rps

        -- Transforming any other patterns simply means transforming
        -- their subparts.
        PViewPat e p       -> do
            e' <- liftTr $ transformExpM e
            tr1pat p (PViewPat e') (trPattern s)
        PVar _             -> return p
        PLit _             -> return p
        PNeg q             -> tr1pat q PNeg (trPattern s)
        PInfixApp p1 op p2 -> tr2pat p1 p2 (\p1 p2 -> PInfixApp p1 op p2) (trPattern s)
        PApp n ps          -> trNpat ps (PApp n) (trPattern s)
        PTuple 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)
        PExplTypeArg _ _   -> return p
        PQuasiQuote _ _    -> return p
        PBangPat p         -> tr1pat p PBangPat (trPattern s)
        PNPlusK _ _        -> return p

      where -- Transform a pattern field.
        trPatternField :: SrcLoc -> PatField -> Tr PatField
        trPatternField s (PFieldPat n p) =
            tr1pat p (PFieldPat n) (trPattern s)
        trPatternField _ p = return p

        -- Deconstruct an xml tag name into its parts.
        xNameParts :: XName -> (Maybe String, String)
        xNameParts n = case n of
                        XName s      -> (Nothing, s)
                        XDomName d s -> (Just d, s)

        -- | Generate a guard for looking up xml attributes.
        mkAttrGuards :: SrcLoc -> Name -> [PXAttr] -> Maybe Pat -> Tr ()
        mkAttrGuards s attrs [PXAttr n q] mattr = do
            -- Apply lookupAttr to the attribute name and
            -- attribute set
            let rhs = metaExtract n attrs
                -- ... catch the result
                pat = metaPJust q
                -- ... catch the remainder list
                rml = case mattr of
                       Nothing -> wildcard
                       Just ap -> ap
            -- ... and add the generated guard to the store.
            pushAttrGuard s (pTuple [pat, rml]) rhs

        mkAttrGuards s attrs ((PXAttr a q):xs) mattr = do
            -- Apply lookupAttr to the attribute name and
            -- attribute set
            let rhs = metaExtract a attrs
                -- ... catch the result
                pat = metaPJust q
            -- ... catch the remainder list
            newAttrs <- genAttrName
            -- ... and add the generated guard to the store.
            pushAttrGuard s (pTuple [pat, pvar newAttrs]) rhs
            -- ... and finally recurse
            mkAttrGuards s newAttrs xs mattr

        -- | Generate a declaration at top level that will finalise all
        -- variable continuations, and then return all bound variables.
        mkTopDecl :: SrcLoc -> Name -> [Name] -> Tr Name
        mkTopDecl s mname vars =
            do -- Give the match function a name
               n <- genMatchName
               -- Create the declaration and add it to the store.
               pushDecl $ topDecl s n mname vars
               -- Return the name of the match function so that the
               -- guard that will be generated can call it.
               return n

        topDecl :: SrcLoc -> Name -> Name -> [Name] -> Decl
        topDecl s n mname vs =
            let pat  = pTuple [wildcard, pvarTuple vs]      -- (_, (foo, bar, ...))
                g    = var mname                            -- harp_matchX
                a    = genStmt s pat g                      -- (_, (foo, ...)) <- harp_matchX
                vars = map (\v -> app (var v) eList) vs     -- (foo [], bar [], ...)
                b    = qualStmt $ metaReturn $ tuple vars   -- return (foo [], bar [], ...)
                e    = doE [a,b]                            -- do (...) <- harp_matchX
                                                            --    return (foo [], bar [], ...)
             in nameBind s n e                              -- harp_matchY = do ....

        -- | Generate a pattern guard that will apply the @runMatch@
        -- function on the top-level match function and the input list,
        -- thereby binding all variables.
        mkGuard :: SrcLoc -> [Name] -> Name -> Name -> Tr ()
        mkGuard s vars mname n = do
            let tvs = pvarTuple vars                        -- (foo, bar, ...)
                ge  = appFun runMatchFun [var mname, var n] -- runMatch harp_matchX harp_patY
            pushGuard s (pApp just_name [tvs]) ge           -- Just (foo, bar, ...) , runMatch ...

    --------------------------------------------------------------------------------
    -- Transforming regular patterns

    -- | A simple datatype to annotate return values from sub-patterns
    data MType = S         -- Single element
               | L MType       -- List of ... , (/  /), *, +
               | E MType MType -- Either ... or ... , (  |  )
               | M MType       -- Maybe ... , ?

    -- When transforming a regular sub-pattern, we need to know the
    -- name of the function generated to match it, the names of all
    -- variables it binds, and the type of its returned value.
    type MFunMetaInfo = (Name, [Name], MType)

    -- | Transform away a regular pattern, generating code
    -- to replace it.
    trRPat :: SrcLoc -> Bool -> RPat -> Tr MFunMetaInfo
    trRPat s linear rp = case rp of
        -- For an ordinary Haskell pattern we need to generate a
        -- base match function for the pattern, and a declaration
        -- that lifts that function into the matcher monad.
        RPPat p -> mkBaseDecl s linear p

          where
            -- | Generate declarations for matching ordinary Haskell patterns
            mkBaseDecl :: SrcLoc -> Bool -> Pat -> Tr MFunMetaInfo
            mkBaseDecl s linear p = case p of
                -- We can simplify a lot if the pattern is a wildcard or a variable
                PWildCard -> mkWCMatch s
                PVar v    -> mkVarMatch s linear v
                -- ... and if it is an embedded pattern tag, we can just skip it
                PXPatTag q -> mkBaseDecl s linear q

                -- ... otherwise we'll have to take the long way...
                p           -> do -- First do a case match on a single element
                                  (name, vars, _) <- mkBasePat s linear p
                                  -- ... apply baseMatch to the case matcher to
                                  -- lift it into the matcher monad.
                                  newname <- mkBaseMatch s name
                                  -- ... and return the meta-info gathered.
                                  return (newname, vars, S)

            -- | Generate a basic function that cases on a single element,
            -- returning Just (all bound variables) on a match, and
            -- Nothing on a mismatch.
            mkBasePat :: SrcLoc -> Bool -> Pat -> Tr MFunMetaInfo
            mkBasePat s b p =
             do -- First we need a name...
               n <- genMatchName
               -- ... and then we need to know what variables that
               -- will be bound by this match.
               let vs = gatherPVars p
               -- ... and then we can create and store away a casing function.
               basePatDecl s b n vs p >>= pushDecl
               return (n, vs, S)

            -- | Generate a basic casing function for a given pattern.
            basePatDecl :: SrcLoc -> Bool -> Name -> [Name] -> Pat -> Tr Decl
            basePatDecl s linear f vs p = do
             -- We can use the magic variable harp_a since nothing else needs to
             -- be in scope at this time (we could use just a, or foo, or whatever)
             let a = Ident $ "harp_a"
             -- ... and we should case on that variable on the right-hand side.
             rhs <- baseCaseE s linear p a vs    -- case harp_a of ...
             -- The result is a simple function with one paramenter and
             -- the right-hand side we just generated.
             return $ simpleFun s f a rhs
               where baseCaseE :: SrcLoc -> Bool -> Pat -> Name -> [Name] -> Tr Exp
                     baseCaseE s b p a vs = do
                        -- First the alternative if we actually
                        -- match the given pattern
                        let alt1 = alt s p                  -- foo -> Just (mf foo)
                                    (app (con just_name) $
                                     tuple (map (retVar b) vs))
                            -- .. and finally an alternative for not matching the pattern.
                            alt2 = alt s wildcard (con nothing_name)        -- _ -> Nothing
                            -- ... and that pattern could itself contain regular patterns
                            -- so we must transform away these.
                        alt1' <- liftTr $ transformAlt alt1
                        return $ caseE (var a) [alt1', alt2]
                     retVar :: Bool -> Name -> Exp
                     retVar linear v
                        -- if bound in linear context, apply const
                        | linear    = metaConst (var v)
                        -- if bound in non-linear context, apply (:)
                        | otherwise = app consFun (var v)

        -- For guarded base patterns, we want to do the same as for unguarded base patterns,
        -- only with guards (doh).
        RPGuard p gs -> mkGuardDecl s linear p gs

         where mkGuardDecl :: SrcLoc -> Bool -> Pat -> [Stmt] -> Tr MFunMetaInfo
               mkGuardDecl s linear p gs = case p of
                    -- If it is an embedded pattern tag, we want to skip it
                    PXPatTag q -> mkGuardDecl s linear q gs

                    -- ... otherwise we'll want to make a base pattern
                    p           -> do -- First do a case match on a single element
                          (name, vars, _) <- mkGuardPat s linear p gs
                          -- ... apply baseMatch to the case matcher to
                          -- lift it into the matcher monad.
                          newname <- mkBaseMatch s name
                          -- ... and return the meta-info gathered.
                          return (newname, vars, S)

               -- | Generate a basic function that cases on a single element,
               -- returning Just (all bound variables) on a match, and
               -- Nothing on a mismatch.
               mkGuardPat :: SrcLoc -> Bool -> Pat -> [Stmt] -> Tr MFunMetaInfo
               mkGuardPat s b p gs =
                    do -- First we need a name...
                       n <- genMatchName
                       -- ... and then we need to know what variables that
                       -- will be bound by this match.
                       let vs = gatherPVars p ++ concatMap gatherStmtVars gs
                       -- ... and then we can create and store away a casing function.
                       guardPatDecl s b n vs p gs >>= pushDecl
                       return (n, vs, S)

               -- | Generate a basic casing function for a given pattern.
               guardPatDecl :: SrcLoc -> Bool -> Name -> [Name] -> Pat -> [Stmt] -> Tr Decl
               guardPatDecl s linear f vs p gs = do
                    -- We can use the magic variable harp_a since nothing else needs to
                    -- be in scope at this time (we could use just a, or foo, or whatever)
                    let a = Ident $ "harp_a"
                    -- ... and we should case on that variable on the right-hand side.
                    rhs <- guardedCaseE s linear p gs a vs  -- case harp_a of ...
                    -- The result is a simple function with one parameter and
                    -- the right-hand side we just generated.
                    return $ simpleFun s f a rhs
                  where guardedCaseE :: SrcLoc -> Bool -> Pat -> [Stmt] -> Name -> [Name] -> Tr Exp
                        guardedCaseE s b p gs a vs = do
                            -- First the alternative if we actually
                            -- match the given pattern
                            let alt1 = altGW s p gs                 -- foo -> Just (mf foo)
                                        (app (con just_name) $
                                         tuple (map (retVar b) vs)) noBinds
                                -- .. and finally an alternative for not matching the pattern.
                                alt2 = alt s wildcard (con nothing_name)        -- _ -> Nothing
                                -- ... and that pattern could itself contain regular patterns
                                -- so we must transform away these.
                            alt1' <- liftTr $ transformAlt alt1
                            return $ caseE (var a) [alt1', alt2]
                        retVar :: Bool -> Name -> Exp
                        retVar linear v
                            -- if bound in linear context, apply const
                            | linear    = metaConst (var v)
                            -- if bound in non-linear context, apply (:)
                            | otherwise = app consFun (var v)

        -- For a sequence of regular patterns, we should transform all
        -- sub-patterns and then generate a function for sequencing them.
        RPSeq rps -> do
            nvts <- mapM (trRPat s linear) rps
            mkSeqDecl s nvts

          where
            -- | Generate a match function for a sequence of regular patterns,
            -- flattening any special sub-patterns into normal elements of the list
            mkSeqDecl :: SrcLoc -> [MFunMetaInfo] -> Tr MFunMetaInfo
            mkSeqDecl s nvts = do
                -- First, as always, we need a name...
                name <- genMatchName
                let -- We need a generating statement for each sub-pattern.
                    (gs, vals) = unzip $ mkGenExps s 0 nvts     -- (harp_valX, (foo, ...)) <- harp_matchY
                    -- Gather up all variables from all sub-patterns.
                    vars    = concatMap (\(_,vars,_) -> vars) nvts
                    -- ... flatten all values to simple lists, and concatenate
                    -- the lists to a new return value
                    fldecls = flattenVals s vals                -- harp_valXf = $flatten harp_valX
                                                                -- harp_ret = foldComp [harp_val1f, ...]
                    -- ... return the value along with all variables
                    ret     = qualStmt $ metaReturn $           -- return (harp_ret, (foo, .....))
                                tuple [var retname, varTuple vars]
                    -- ... do all these steps in a do expression
                    rhs     = doE $ gs ++                       -- do (harp_valX, (foo, ...)) <- harpMatchY
                                [letStmt fldecls, ret]          --    let harp_valXf = $flatten harp_valX
                                                                --    return (harp_ret, (foo, .....))
                -- ... bind it to its name, and add the declaration
                -- to the store.
                pushDecl $ nameBind s name rhs                  -- harp_matchZ = do ....
                -- The return value of a sequence is always a list of elements.
                return (name, vars, L S)

            -- | Flatten values of all sub-patterns into normal elements of the list
            flattenVals :: SrcLoc -> [(Name, MType)] -> [Decl]
            flattenVals s nts =
                let -- Flatten the values of all sub-patterns to
                    -- lists of elements
                    (nns, ds) = unzip $ map (flVal s) nts
                    -- ... and concatenate their results.
                    ret       = nameBind s retname $ app
                                  (paren $ app foldCompFun
                                    (listE $ map var nns)) $ eList
                 in ds ++ [ret]

            flVal :: SrcLoc -> (Name, MType) -> (Name, Decl)
            flVal s (name, mt) =
                let -- We reuse the old names, we just extend them a bit.
                    newname = extendVar name "f"    -- harp_valXf
                    -- Create the appropriate flattening function depending
                    -- on the type of the value
                    f       = flatten mt
                    -- ... apply it to the value and bind it to its new name.
                 in (newname, nameBind s newname $  -- harp_valXf = $flatten harp_valX
                        app f (var name))

            -- | Generate a flattening function for a given type structure.
            flatten :: MType -> Exp
            flatten S = consFun                         -- (:)
            flatten (L mt) =
                let f = flatten mt
                    r = paren $ metaMap [f]
                 in paren $ foldCompFun `metaComp` r    -- (foldComp . (map $flatten))
            flatten (E mt1 mt2) =
                let f1 = flatten mt1
                    f2 = flatten mt2
                 in paren $ metaEither f1 f2            -- (either $flatten $flatten)
            flatten (M mt) =
                let f = flatten mt
                 in paren $ metaMaybe idFun f           -- (maybe id $flatten)

        -- For accumulating as-patterns we should transform the subpattern, and then generate
        -- a declaration that supplies the value to be bound to the variable in question.
        -- The variable should be bound non-linearly.
        RPCAs v rp -> do
            -- Transform the subpattern
            nvt@(name, vs, mt) <- trRPat s linear rp
            -- ... and create a declaration to bind its value.
            n <- mkCAsDecl s nvt
            -- The type of the value is unchanged.
            return (n, (v:vs), mt)

          where
            -- | Generate a declaration for a \@: binding.
            mkCAsDecl :: SrcLoc -> MFunMetaInfo -> Tr Name
            mkCAsDecl = asDecl $ app consFun    -- should become lists when applied to []

        -- For ordinary as-patterns we should transform the subpattern, and then generate
        -- a declaration that supplies the value to be bound to the variable in question.
        -- The variable should be bound linearly.
        RPAs v rp
            | linear ->
                 do -- Transform the subpattern
                    nvt@(name, vs, mt) <- trRPat s linear rp
                    -- ... and create a declaration to bind its value
                    n <- mkAsDecl s nvt
                    -- The type of the value is unchanged.
                    return (n, (v:vs), mt)
            -- We may not use an @ bind in non-linear context
            | otherwise -> case v of
                    Ident n -> fail $ "Attempting to bind variable "++n++
                          " inside the context of a numerable regular pattern"
                    _         -> fail $ "This should never ever ever happen... how the #% did you do it??!?"

          where
            -- | Generate a declaration for a \@ binding.
            mkAsDecl :: SrcLoc -> MFunMetaInfo -> Tr Name
            mkAsDecl = asDecl metaConst     -- should be constant when applied to []

        -- For regular patterns, parentheses have no real meaning
        -- so at this point we can just skip them.
        RPParen rp -> trRPat s linear rp

        -- For (possibly non-greedy) optional regular patterns we need to
        -- transform the subpattern, and the generate a function that can
        -- choose to match or not to match, that is the question...
        RPOp rp RPOpt->
            do -- Transform the subpattern
               nvt <- trRPat s False rp
               -- ... and create a declaration that can optionally match it.
               mkOptDecl s False nvt
        -- ... similarly for the non-greedy version.
        RPOp rp RPOptG ->
            do -- Transform the subpattern
               nvt <- trRPat s False rp
               -- ... and create a declaration that can optionally match it.
               mkOptDecl s True nvt

        -- For union patterns, we should transform both subexpressions,
        -- and generate a function that chooses between them.
        RPEither rp1 rp2 ->
            do -- Transform the subpatterns
               nvt1 <- trRPat s False rp1
               nvt2 <- trRPat s False rp2
               -- ... and create a declaration that can choose between them.
               mkEitherDecl s nvt1 nvt2
            -- Generate declarations for either patterns, i.e. ( | )
          where mkEitherDecl :: SrcLoc -> MFunMetaInfo -> MFunMetaInfo -> Tr MFunMetaInfo
                mkEitherDecl s nvt1@(_, vs1, t1) nvt2@(_, vs2, t2) = do
                    -- Eine namen, bitte!
                    n <- genMatchName
                    let -- Generate generators for the subpatterns
                        (g1, v1) = mkGenExp s nvt1
                        (g2, v2) = mkGenExp s nvt2          -- (harp_valX, (foo, bar, ...)) <- harp_matchY
                        -- ... gather all variables from both sides
                        allvs = vs1 `union` vs2
                        -- ... some may be bound on both sides, so we
                        -- need to check which ones are bound on each,
                        -- supplying empty value for those that are not
                        vals1 = map (varOrId vs1) allvs
                        vals2 = map (varOrId vs2) allvs
                        -- ... apply either Left or Right to the returned value
                        ret1  = metaReturn $ tuple          -- return (Left harp_val1, (foo, id, ...))
                                    [app (con left_name)
                                     (var v1), tuple vals1]
                        ret2  = metaReturn $ tuple          -- return (Right harp_val2, (id, bar, ...))
                                    [app (con right_name)
                                     (var v2), tuple vals2]
                        -- ... and do all these things in do-expressions
                        exp1  = doE [g1, qualStmt ret1]
                        exp2  = doE [g2, qualStmt ret2]
                        -- ... and choose between them using the choice (+++) operator.
                        rhs   = (paren exp1) `metaChoice`       -- (do ...) +++
                                (paren exp2)            --  (do ...)
                    -- Finally we create a declaration for this function and
                    -- add it to the store.
                    pushDecl $ nameBind s n rhs         -- harp_matchZ = (do ...) ...
                    -- The type of the returned value is Either the type of the first
                    -- or the second subpattern.
                    return (n, allvs, E t1 t2)

                varOrId :: [Name] -> Name -> Exp
                varOrId vs v = if v `elem` vs   -- the variable is indeed bound in this branch
                                then var v      -- ... so it should be added to the result
                                else idFun      -- ... else it should be empty.

        -- For (possibly non-greedy) repeating regular patterns we need to transform the subpattern,
        -- and then generate a function to handle many matches of it.
        RPOp rp RPStar ->
            do -- Transform the subpattern
               nvt <- trRPat s False rp
               -- ... and create a declaration that can match it many times.
               mkStarDecl s False nvt
        -- ... and similarly for the non-greedy version.
        RPOp rp RPStarG->
            do -- Transform the subpattern
               nvt <- trRPat s False rp
               -- ... and create a declaration that can match it many times.
               mkStarDecl s True nvt

        -- For (possibly non-greedy) non-empty repeating patterns we need to transform the subpattern,
        -- and then generate a function to handle one or more matches of it.
        RPOp rp RPPlus ->
            do -- Transform the subpattern
               nvt <- trRPat s False rp
               -- ... and create a declaration that can match it one or more times.
               mkPlusDecl s False nvt
        -- ... and similarly for the non-greedy version.
        RPOp rp RPPlusG ->
            do -- Transform the subpattern
               nvt <- trRPat s False rp
               -- ... and create a declaration that can match it one or more times.
               mkPlusDecl s True nvt

      where -- These are the functions that must be in scope for more than one case alternative above.

        -- | Generate a declaration for matching a variable.
        mkVarMatch :: SrcLoc -> Bool -> Name -> Tr MFunMetaInfo
        mkVarMatch s linear v = do
                -- First we need a name for the new match function.
                n <- genMatchName
                -- Then we need a basic matching function that always matches,
                -- and that binds the value matched to the variable in question.
                let e = paren $ lamE s [pvar v] $       -- (\v -> Just (mf v))
                                  app (con just_name)
                                  (paren $ retVar linear v)
                -- Lift the function into the matcher monad, and bind it to its name,
                -- then add it the declaration to the store.
                pushDecl $ nameBind s n $
                              app baseMatchFun e    -- harp_matchX = baseMatch (\v -> Just (mf v))
                return (n, [v], S)          -- always binds v and only v

              where retVar :: Bool -> Name -> Exp
                    retVar linear v
                        -- if bound in linear context, apply const
                        | linear    = metaConst (var v)
                        -- if bound in non-linear context, apply (:)
                        | otherwise = app consFun (var v)

        -- | Generate a declaration for matching a wildcard
        mkWCMatch :: SrcLoc -> Tr MFunMetaInfo
        mkWCMatch s = do
                -- First we need a name...
                n <- genMatchName
                -- ... and then a function that always matches, discarding the result
                let e = paren $ lamE s [wildcard] $     -- (\_ -> Just ())
                                    app (con just_name) unit_con
                -- ... which we lift, bind, and add to the store.
                pushDecl $ nameBind s n $       -- harp_matchX = baseMatch (\_ -> Just ())
                             app baseMatchFun e
                return (n, [], S)   -- no variables bound, hence []

        -- | Gather up the names of all variables in a pattern,
        -- using a simple fold over the syntax structure.
        gatherPVars :: Pat -> [Name]
        gatherPVars p = case p of
                PVar v             -> [v]
                PNeg q             -> gatherPVars q
                PInfixApp p1 _ p2  -> gatherPVars p1 ++
                                             gatherPVars p2
                PApp _ ps          -> concatMap gatherPVars ps
                PTuple  _ ps       -> concatMap gatherPVars ps
                PList ps           -> concatMap gatherPVars ps
                PParen p           -> gatherPVars p
                PRec _ pfs         -> concatMap help pfs
                    where help (PFieldPat _ p) = gatherPVars p
                          help _               = []
                PAsPat n p         -> n : gatherPVars p
                PWildCard          -> []
                PIrrPat p          -> gatherPVars p
                PatTypeSig _ p _   -> gatherPVars p
                PRPat rps          -> concatMap gatherRPVars rps
                PXTag _ _ attrs mattr cps ->
                    concatMap gatherAttrVars attrs ++ concatMap gatherPVars cps ++
                        case mattr of
                         Nothing -> []
                         Just ap -> gatherPVars ap
                PXETag _ _ attrs mattr ->
                    concatMap gatherAttrVars attrs ++
                        case mattr of
                         Nothing -> []
                         Just ap -> gatherPVars ap
                PXPatTag p         -> gatherPVars p
                _                -> []

        gatherRPVars :: RPat -> [Name]
        gatherRPVars rp = case rp of
                RPOp rq _        -> gatherRPVars rq
                RPEither rq1 rq2 -> gatherRPVars rq1 ++ gatherRPVars rq2
                RPSeq rqs        -> concatMap gatherRPVars rqs
                RPCAs n rq       -> n : gatherRPVars rq
                RPAs n rq        -> n : gatherRPVars rq
                RPParen rq       -> gatherRPVars rq
                RPGuard q gs     -> gatherPVars q ++ concatMap gatherStmtVars gs
                RPPat q          -> gatherPVars q

        gatherAttrVars :: PXAttr -> [Name]
        gatherAttrVars (PXAttr _ p) = gatherPVars p

        gatherStmtVars :: Stmt -> [Name]
        gatherStmtVars gs = case gs of
                Generator _ p _ -> gatherPVars p
                _                 -> []

        -- | Generate a match function that lift the result of the
        -- basic casing function into the matcher monad.
        mkBaseMatch :: SrcLoc -> Name -> Tr Name
        mkBaseMatch s name =
                do -- First we need a name...
                   n <- genMatchName
                   -- ... to which we bind the lifting function
                   pushDecl $ baseMatchDecl s n name
                   -- and then return for others to use.
                   return n

        -- | Generate a declaration for the function that lifts a simple
        -- casing function into the matcher monad.
        baseMatchDecl :: SrcLoc -> Name -> Name -> Decl
        baseMatchDecl s newname oldname =
                -- Apply the lifting function "baseMatch" to the casing function
                let e = app baseMatchFun (var oldname)
                    -- ... and bind it to the new name.
                 in nameBind s newname e        -- harp_matchX = baseMatch harp_matchY

        -- | Generate the generators that call sub-matching functions, and
        -- annotate names with types for future flattening of values.
        -- Iterate to enable gensym-like behavior.
        mkGenExps :: SrcLoc -> Int -> [MFunMetaInfo] -> [(Stmt, (Name, MType))]
        mkGenExps _ _ [] = []
        mkGenExps s k ((name, vars, t):nvs) =
            let valname = mkValName k                           -- harp_valX
                pat     = pTuple [pvar valname, pvarTuple vars] -- (harp_valX, (foo, bar, ...))
                g       = var name
             in (genStmt s pat g, (valname, t)) :               -- (harp_valX, (foo, ...)) <- harp_matchY
                    mkGenExps s (k+1) nvs

        -- | Create a single generator.
        mkGenExp :: SrcLoc -> MFunMetaInfo -> (Stmt, Name)
        mkGenExp s nvt = let [(g, (name, _t))] = mkGenExps s 0 [nvt]
                          in (g, name)

        -- | Generate a single generator with a call to (ng)manyMatch,
        -- and an extra variable name to use after unzipping.
        mkManyGen :: SrcLoc -> Bool -> Name -> Stmt
        mkManyGen s greedy mname =
            -- Choose which repeater function to use, determined by greed
            let mf  = if greedy then gManyMatchFun else manyMatchFun
             -- ... and create a generator that applies it to the
             -- matching function in question.
             in genStmt s (pvar valsvarsname) $
                app mf (var mname)

        -- | Generate declarations for @: and @ bindings.
        asDecl :: (Exp -> Exp) -> SrcLoc -> MFunMetaInfo -> Tr Name
        asDecl mf s nvt@(_, vs, _) = do
            -- A name, if you would
            n <- genMatchName                                -- harp_matchX
            let -- Generate a generator for matching the subpattern
                (g, val) = mkGenExp s nvt                    -- (harp_valY, (foo, ...)) <- harp_matchZ
                -- ... fix the old variables
                vars     = map var vs                        -- (apa, bepa, ...)
                -- ... and return the generated value, along with the
                -- new set of variables which is the old set prepended
                -- by the variable currently being bound.
                ret = qualStmt $ metaReturn $ tuple          -- return (harp_valY, ($mf harp_valY, apa, ...))
                    [var val, tuple $ mf (var val) : vars]   -- mf in the line above is what separates
                                                             -- @: ((:)) from @ (const)
            -- Finally we create a declaration for this function and
            -- add it to the store.
            pushDecl $ nameBind s n $ doE [g, ret]           -- harp_matchX = do ...
            return n

        -- | Generate declarations for optional patterns, ? and #?.
        -- (Unfortunally we must place this function here since both variations
        -- of transformations of optional patterns should be able to call it...)
        mkOptDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
        mkOptDecl s greedy nvt@(_, vs, t) = do
            -- Un nome, s'il vouz plaît.
            n <- genMatchName
            let -- Generate a generator for matching the subpattern
                (g, val) = mkGenExp s nvt               -- (harp_valX, (foo, bar, ...)) <- harp_matchY
                -- ... and apply a Just to its value
                ret1 = metaReturn $ tuple               -- return (Just harp_val1, (foo, bar, ...))
                        [app (con just_name)
                         (var val), varTuple vs]
                -- ... and do those two steps in a do-expression
                exp1 = doE [g, qualStmt ret1]           -- do ....
                -- For the non-matching branch, all the variables should be empty
                ids  = map (const idFun) vs             -- (id, id, ...)
                -- ... and the value should be Nothing.
                ret2 = metaReturn $ tuple               -- return (Nothing, (id, id, ...))
                        [con nothing_name, tuple ids]   -- i.e. no vars were bound
                -- The order of the arguments to the choice (+++) operator
                -- is determined by greed...
                mc   = if greedy
                        then metaChoice        -- standard order
                        else (flip metaChoice) -- reversed order
                -- ... and then apply it to the branches.
                rhs  = (paren exp1) `mc`                -- (do ....) +++
                        (paren ret2)                    --  (return (Nothing, .....))
            -- Finally we create a declaration for this function and
            -- add it to the store.
            pushDecl $ nameBind s n rhs                 -- harp_matchZ = (do ....) +++ (return ....)
            -- The type of the returned value will be Maybe the type
            -- of the value of the subpattern.
            return (n, vs, M t)

        -- | Generate declarations for star patterns, * and #*
        -- (Unfortunally we must place this function here since both variations
        -- of transformations of repeating patterns should be able to call it...)
        mkStarDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
        mkStarDecl s greedy (mname, vs, t) = do
            -- Ett namn, tack!
            n <- genMatchName
            let -- Create a generator that matches the subpattern
                -- many times, either greedily or non-greedily
                g = mkManyGen s greedy mname
                -- ... and unzip the result, choosing the proper unzip
                -- function depending on the number of variables returned.
                metaUnzipK = mkMetaUnzip s (length vs)
                -- ... first unzip values from variables
                dec1    = patBind s (pvarTuple [valname, varsname])
                        (metaUnzip $ var valsvarsname)
                -- ... and then unzip the variables
                dec2    = patBind s (pvarTuple vs)
                        (metaUnzipK $ var varsname)
                -- ... fold all the values for variables
                retExps = map ((app foldCompFun) . var) vs
                -- ... and return value and variables
                ret     = metaReturn $ tuple $
                        [var valname, tuple retExps]
            -- Finally we need to generate a function that does all this,
            -- using a let-statement for the non-monadic stuff and a
            -- do-expression to wrap it all in.
            pushDecl $ nameBind s n $
                doE [g, letStmt [dec1, dec2], qualStmt ret]
            -- The type of the returned value is a list ([]) of the
            -- type of the subpattern.
            return (n, vs, L t)

        -- | Generate declarations for plus patterns, + and #+
        -- (Unfortunally we must place this function here since both variations
        -- of transformations of non-empty repeating patterns should be able to call it...)
        mkPlusDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo
        mkPlusDecl s greedy nvt@(mname, vs, t) = do
            -- and now I've run out of languages...
            n <- genMatchName
            let k = length vs
                -- First we want a generator to match the
                -- subpattern exactly one time
                (g1, val1) = mkGenExp s nvt                     -- (harp_valX, (foo, ...)) <- harpMatchY
                -- ... and then one that matches it many times.
                g2         = mkManyGen s greedy mname           -- harp_vvs <- manyMatch harpMatchY
                -- ... we want to unzip the result, using
                -- the proper unzip function
                metaUnzipK = mkMetaUnzip s k
                -- ... first unzip values from variables
                dec1    = patBind s                             -- (harp_vals, harp_vars) = unzip harp_vvs
                            (pvarTuple [valsname, varsname])
                            (metaUnzip $ var valsvarsname)
                -- .. now we need new fresh names for variables
                -- since the ordinary ones are already taken.
                vlvars  = genNames "harp_vl" k
                -- ... and then we can unzip the variables
                dec2    = patBind s (pvarTuple vlvars)          -- (harp_vl1, ...) = unzipK harp_vars
                            (metaUnzipK $ var varsname)
                -- .. and do the unzipping in a let-statement
                letSt   = letStmt [dec1, dec2]
                -- ... fold variables from the many-match,
                -- prepending the variables from the single match
                retExps = map mkRetFormat $ zip vs vlvars       -- foo . (foldComp harp_vl1), ...
                -- ... prepend values from the single match to
                -- those of the many-match.
                retVal  = (var val1) `metaCons`
                            (var valsname)                      -- harp_valX : harp_vals
                -- ... return all values and variables
                ret     = metaReturn $ tuple $                  -- return (harp_valX:harpVals,
                            [retVal, tuple retExps]             --   (foo . (...), ...))
                -- ... and wrap all of it in a do-expression.
                rhs     = doE [g1, g2, letSt, qualStmt ret]
            -- Finally we create a declaration for this function and
            -- add it to the store.
            pushDecl $ nameBind s n rhs
            -- The type of the returned value is a list ([]) of the
            -- type of the subpattern.
            return (n, vs, L t)

          where mkRetFormat :: (Name, Name) -> Exp
                mkRetFormat (v, vl) =
                    -- Prepend variables using function composition.
                    (var v) `metaComp`
                      (paren $ (app foldCompFun) $ var vl)

    --------------------------------------------------------------------------
    -- HaRP-specific functions and ids

    -- | Functions and ids from the @Match@ module,
    -- used in the generated matching functions
    runMatchFun, baseMatchFun, manyMatchFun, gManyMatchFun :: Exp
    runMatchFun = match_qual runMatch_name
    baseMatchFun = match_qual baseMatch_name
    manyMatchFun = match_qual manyMatch_name
    gManyMatchFun = match_qual gManyMatch_name

    runMatch_name, baseMatch_name, manyMatch_name, gManyMatch_name :: Name
    runMatch_name = Ident "runMatch"
    baseMatch_name = Ident "baseMatch"
    manyMatch_name = Ident "manyMatch"
    gManyMatch_name = Ident "gManyMatch"

    match_mod, match_qual_mod :: ModuleName
    match_mod = ModuleName "Harp.Match"
    match_qual_mod = ModuleName "HaRPMatch"

    match_qual :: Name -> Exp
    match_qual = qvar match_qual_mod

    choiceOp :: QOp
    choiceOp = QVarOp $ Qual match_qual_mod choice

    appendOp :: QOp
    appendOp = QVarOp $ UnQual append

    -- foldComp = foldl (.) id, i.e. fold by composing
    foldCompFun :: Exp
    foldCompFun = match_qual $ Ident "foldComp"

    mkMetaUnzip :: SrcLoc -> Int -> Exp -> Exp
    mkMetaUnzip s k | k <= 7 = let n = "unzip" ++ show k
                                in (\e -> matchFunction n [e])
                    | otherwise =
                       let vs      = genNames "x" k
                           lvs     = genNames "xs" k
                           uz      = name $ "unzip" ++ show k
                           ys      = name "ys"
                           xs      = name "xs"
                           alt1    = alt s peList $ tuple $ replicate k eList   -- [] -> ([], [], ...)
                           pat2    = (pvarTuple vs) `metaPCons` (pvar xs)       -- (x1, x2, ...)
                           ret2    = tuple $ map appCons $ zip vs lvs           -- (x1:xs1, x2:xs2, ...)
                           rhs2    = app (var uz) (var xs)                      -- unzipK xs
                           dec2    = patBind s (pvarTuple lvs) rhs2             -- (xs1, xs2, ...) = unzipK xs
                           exp2    = letE [dec2] ret2
                           alt2    = alt s pat2 exp2
                           topexp  = lamE s [pvar ys] $ caseE (var ys) [alt1, alt2]
                           topbind = nameBind s uz topexp
                        in app (paren $ letE [topbind] (var uz))
      where appCons :: (Name, Name) -> Exp
            appCons (x, xs) = metaCons (var x) (var xs)

    matchFunction :: String -> [Exp] -> Exp
    matchFunction s es = mf s (reverse es)
      where mf s []     = match_qual $ Ident s
            mf s (e:es) = app (mf s es) e

    -- | Some 'magic' gensym-like functions, and functions
    -- with related functionality.
    retname :: Name
    retname = name "harp_ret"

    varsname :: Name
    varsname = name "harp_vars"

    valname :: Name
    valname = name "harp_val"

    valsname :: Name
    valsname = name "harp_vals"

    valsvarsname :: Name
    valsvarsname = name "harp_vvs"

    mkValName :: Int -> Name
    mkValName k = name $ "harp_val" ++ show k

    extendVar :: Name -> String -> Name
    extendVar (Ident n) s = Ident $ n ++ s
    extendVar n _ = n

    xNameParts :: XName -> (Maybe String, String)
    xNameParts n = case n of
                    XName s      -> (Nothing, s)
                    XDomName d s -> (Just d, s)

    ---------------------------------------------------------
    -- meta-level functions, i.e. functions that represent functions,
    -- and that take arguments representing arguments... whew!

    metaReturn, metaConst, metaUnzip :: Exp -> Exp
    metaReturn e = metaFunction "return" [e]
    metaConst e  = metaFunction "const" [e]
    metaUnzip e  = metaFunction "unzip" [e]

    metaEither, metaMaybe :: Exp -> Exp -> Exp
    metaEither e1 e2 = metaFunction "either" [e1,e2]
    metaMaybe e1 e2 = metaFunction "maybe" [e1,e2]

    metaConcat, metaMap :: [Exp] -> Exp
    metaConcat es = metaFunction "concat" [listE es]
    metaMap       = metaFunction "map"

    metaAppend :: Exp -> Exp -> Exp
    metaAppend l1 l2 = infixApp l1 appendOp l2

    -- the +++ choice operator
    metaChoice :: Exp -> Exp -> Exp
    metaChoice e1 e2 = infixApp e1 choiceOp e2

    metaPCons :: Pat -> Pat -> Pat
    metaPCons p1 p2 = PInfixApp p1 cons p2

    metaCons, metaComp :: Exp -> Exp -> Exp
    metaCons e1 e2 = infixApp e1 (QConOp cons) e2
    metaComp e1 e2 = infixApp e1 (op fcomp) e2

    metaPJust :: Pat -> Pat
    metaPJust p = pApp just_name [p]

    metaPNothing :: Pat
    metaPNothing = pvar nothing_name

    metaPMkMaybe :: Maybe Pat -> Pat
    metaPMkMaybe mp = case mp of
        Nothing -> metaPNothing
        Just p  -> pParen $ metaPJust p

    metaJust :: Exp -> Exp
    metaJust e = app (con just_name) e

    metaNothing :: Exp
    metaNothing = con nothing_name

    metaMkMaybe :: Maybe Exp -> Exp
    metaMkMaybe me = case me of
        Nothing -> metaNothing
        Just e  -> paren $ metaJust e

    ---------------------------------------------------
    -- some other useful functions at abstract level
    consFun, idFun :: Exp
    consFun = Con cons
    idFun = function "id"

    con :: Name -> Exp
    con = Con . UnQual

    cons :: QName
    cons = Special Cons

    fcomp, choice, append :: Name
    fcomp = Symbol "."
    choice = Symbol "+++"
    append = Symbol "++"

    just_name, nothing_name, left_name, right_name :: Name
    just_name    = Ident "Just"
    nothing_name = Ident "Nothing"
    left_name    = Ident "Left"
    right_name   = Ident "Right"

    ------------------------------------------------------------------------
    -- Help functions for meta programming xml

    {- No longer used.
    hsx_data_mod :: ModuleName
    hsx_data_mod = ModuleName "HSP.Data"

    -- Also no longer used, literal PCDATA should be considered a string.
    -- | Create an xml PCDATA value
    metaMkPcdata :: String -> Exp
    metaMkPcdata s = metaFunction "pcdata" [strE s]
    -}

    -- | Create an xml tag, given its domain, name, attributes and
    -- children.
    metaGenElement :: XName -> [Exp] -> Maybe Exp -> [Exp] -> Exp
    metaGenElement name ats mat cs =
        let (d,n) = xNameParts name
            ne    = tuple [metaMkMaybe $ fmap strE d, strE n]
            m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat
            attrs = m $ listE $ map metaAsAttr ats
         in metaFunction "genElement" [ne, attrs, listE cs]

    -- | Create an empty xml tag, given its domain, name and attributes.
    metaGenEElement :: XName -> [Exp] -> Maybe Exp -> Exp
    metaGenEElement name ats mat =
        let (d,n) = xNameParts name
            ne    = tuple [metaMkMaybe $ fmap strE d, strE n]
            m = maybe id (\x y -> paren $ y `metaAppend` (metaMap [argAsAttr, x])) mat
            attrs = m $ listE $ map metaAsAttr ats
         in metaFunction "genEElement" [ne, attrs]

    -- | Create an attribute by applying the overloaded @asAttr@
    metaAsAttr :: Exp -> Exp
    metaAsAttr e@(Lit (String _)) = metaFunction "asAttr" [ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))]
    metaAsAttr e = metaFunction "asAttr" [e]

    argAsAttr :: Exp
    argAsAttr = var $ name "asAttr"

    -- | Create a property from an attribute and a value.
    metaAssign :: Exp -> Exp -> Exp
    metaAssign e1 e2 = infixApp e1 assignOp e2
      where assignOp = QConOp $ UnQual $ Symbol ":="

    -- | Make xml out of some expression by applying the overloaded function
    -- @asChild@.
    metaAsChild :: Exp -> Exp
    metaAsChild e = metaFunction "asChild" [paren e]

    -- TODO: We need to fix the stuff below so pattern matching on XML could also be overloaded.
    -- Right now it only works on HSP XML, or anything that is syntactically identical to it.

    -- | Lookup an attribute in the set of attributes.
    metaExtract :: XName -> Name -> Exp
    metaExtract name attrs =
        let (d,n) = xNameParts name
            np    = tuple [metaMkMaybe $ fmap strE d, strE n]
         in metaFunction "extract" [np, var attrs]

    -- | Generate a pattern under the Tag data constructor.
    metaTag :: (Maybe String) -> String -> Pat -> Pat -> Pat
    metaTag dom name ats cpat =
        let d = metaPMkMaybe $ fmap strP dom
            n = pTuple [d, strP name]
         in metaConPat "Element" [n, ats, cpat]

    -- | Generate a pattern under the PCDATA data constructor.
    metaPcdata :: String -> Pat
    metaPcdata s = metaConPat "CDATA" [strP s]

    metaMkName :: XName -> Exp
    metaMkName n = case n of
        XName s      -> stringTypeSig (strE s)
        XDomName d s -> tuple [stringTypeSig $ strE d, stringTypeSig $ strE s]
        where
          stringTypeSig e = ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))