-----------------------------------------------------------------------------
-- |
-- 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 es          -> fmap Tuple $ mapM transformExpM es
    List es           -> fmap List $ mapM transformExpM es
    Paren e           -> fmap Paren $ transformExpM e
    LeftSection e op  -> do e' <- transformExpM e
                            return $ LeftSection e' op
    RightSection op e -> fmap (RightSection op) $ transformExpM e
    RecConstr n fus   -> fmap (RecConstr n) $ mapM transformFieldUpdate fus
    RecUpdate e fus   -> do e'   <- transformExpM e
                            fus' <- mapM transformFieldUpdate fus
                            return $ RecUpdate e' fus'
    EnumFrom e        -> fmap EnumFrom $ transformExpM e
    EnumFromTo e1 e2  -> transform2exp e1 e2 EnumFromTo
    EnumFromThen e1 e2      -> transform2exp e1 e2 EnumFromThen
    EnumFromThenTo e1 e2 e3 -> transform3exp e1 e2 e3 EnumFromThenTo
    ExpTypeSig s e t  -> do e' <- transformExpM e
                            return $ ExpTypeSig s e' t
    SpliceExp s       -> fmap SpliceExp $ transformSplice s
    LeftArrApp e1 e2        -> transform2exp e1 e2 LeftArrApp
    RightArrApp e1 e2       -> transform2exp e1 e2 RightArrApp
    LeftArrHighApp e1 e2    -> transform2exp e1 e2 LeftArrHighApp
    RightArrHighApp e1 e2   -> transform2exp e1 e2 RightArrHighApp

    CorePragma s e      -> fmap (CorePragma s) $ transformExpM e
    SCCPragma  s e      -> fmap (SCCPragma  s) $ transformExpM e
    GenPragma  s a b e  -> fmap (GenPragma  s a b) $ transformExpM e
    _           -> return e     -- Warning - will not work inside TH brackets!
  where
    -- | Transform expressions appearing in child position of an xml tag.
    -- Expressions are first transformed, then wrapped in a call to
    -- @toXml@.
    transformChild :: Exp -> HsxM Exp
    transformChild e = do
        -- Transform the expression
        te <- transformExpM e
        -- ... and apply the overloaded toXMLs to it
        return $ metaAsChild te

transformFieldUpdate :: FieldUpdate -> HsxM FieldUpdate
transformFieldUpdate (FieldUpdate n e) =
        fmap (FieldUpdate n) $ transformExpM e
transformFieldUpdate fup = return fup

transformSplice :: Splice -> HsxM Splice
transformSplice s = case s of
    ParenSplice e       -> fmap ParenSplice $ transformExpM e
    _                   -> return s

transform2exp :: Exp -> Exp -> (Exp -> Exp -> a) -> HsxM a
transform2exp e1 e2 f = do e1' <- transformExpM e1
                           e2' <- transformExpM e2
                           return $ f e1' e2'

transform3exp :: Exp -> Exp -> Exp -> (Exp -> Exp -> Exp -> a) -> HsxM a
transform3exp e1 e2 e3 f = do e1' <- transformExpM e1
                              e2' <- transformExpM e2
                              e3' <- transformExpM e3
                              return $ f e1' e2' e3'

mkAttr :: XAttr -> Exp
mkAttr (XAttr name e) =
    paren (metaMkName name `metaAssign` (stringTypeSig e))
    where
      stringTypeSig e@(Lit (String _)) = ExpTypeSig noLoc e (TyCon (UnQual (Ident "String")))
      stringTypeSig e                  = e

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

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


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

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

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

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


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

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

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

    return $ Alt srcloc pat'' rhs' decls'

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

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

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

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

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

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

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

type RNState = Int

initRNState = 0

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

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


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

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

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

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


type NameBind = (Name, Pat)

-- Some generic functions on monads for traversing subterms

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

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

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




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

renameRP :: Pat -> RN (Pat, [NameBind])
renameRP p = case p of
    -- We must rename regular patterns and Tag expressions
    PRPat _           -> rename p
    PXTag _ _ _ _ _   -> rename p
    PXETag _ _ _ _    -> rename p
    -- The rest of the rules simply try to rename regular patterns in
    -- their immediate subpatterns.
    PNeg p            -> rename1pat p PNeg renameRP
    PInfixApp p1 n p2 -> rename2pat p1 p2
                                (\p1 p2 -> PInfixApp p1 n p2)
                                renameRP
    PApp n ps         -> renameNpat ps (PApp n) renameRP
    PTuple ps         -> renameNpat ps PTuple renameRP
    PList ps          -> renameNpat ps PList renameRP
    PParen p          -> rename1pat p PParen renameRP
    PRec n pfs        -> renameNpat pfs (PRec n) renameRPf
    PAsPat n p        -> rename1pat p (PAsPat n) renameRP
    PIrrPat p         -> rename1pat p PIrrPat renameRP
    PXPatTag p        -> rename1pat p PXPatTag renameRP
    PatTypeSig s p t  -> rename1pat p (\p -> PatTypeSig s p t) renameRP
    _                   -> return (p, [])

  where renameRPf :: PatField -> RN (PatField, [NameBind])
        renameRPf (PFieldPat n p) = rename1pat p (PFieldPat n) renameRP
        renameRPf pf              = return (pf, [])

        renameAttr :: PXAttr -> RN (PXAttr, [NameBind])
        renameAttr (PXAttr s p) = rename1pat p (PXAttr s) renameRP

        rename :: Pat -> RN (Pat, [NameBind])
        rename p = do -- Generate a fresh variable
              n <- genVarName
              -- ... and return that, along with the association of
              -- the variable with the old pattern
              return (pvar n, [(n,p)])

-- | Rename declarations appearing in @let@s or @where@ clauses.
renameLetDecls :: [Decl] -> [Decl]
renameLetDecls ds =
    let -- Rename all regular patterns bound in pattern bindings.
        (ds', smss) = unzip $ runRename $ mapM renameLetDecl ds
        -- ... and then generate declarations for the associations
        gs = map (\(s,n,p) -> mkDecl s (n,p)) (concat smss)
        -- ... which should be added to the original list of declarations.
     in ds' ++ gs

  where renameLetDecl :: Decl -> RN (Decl, [(SrcLoc, Name, Pat)])
        renameLetDecl d = case d of
            -- We need only bother about pattern bindings.
            PatBind srcloc pat mty rhs decls -> do
                -- Rename any regular patterns that appear in the
                -- pattern being bound.
                (p, ms) <- renameRP pat
                let sms = map (\(n,p) -> (srcloc, n, p)) ms
                return $ (PatBind srcloc p mty rhs decls, sms)
            _ -> return (d, [])


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

renameIrrP :: Pat -> RN (Pat, [(Name, Pat)])
renameIrrP p = case p of
    -- We should rename any regular pattern appearing
    -- inside an irrefutable pattern.
    PIrrPat p     -> do (q, ms) <- renameRP p
                        return $ (PIrrPat q, ms)
    -- The rest of the rules simply try to rename regular patterns in
    -- irrefutable patterns in their immediate subpatterns.
    PNeg p            -> rename1pat p PNeg renameIrrP
    PInfixApp p1 n p2 -> rename2pat p1 p2
                                (\p1 p2 -> PInfixApp p1 n p2)
                                renameIrrP
    PApp n ps         -> renameNpat ps (PApp n) renameIrrP
    PTuple ps         -> renameNpat ps PTuple renameIrrP
    PList ps          -> renameNpat ps PList renameIrrP
    PParen p          -> rename1pat p PParen renameIrrP
    PRec n pfs        -> renameNpat pfs (PRec n) renameIrrPf
    PAsPat n p        -> rename1pat p (PAsPat n) renameIrrP
    PatTypeSig s p t  -> rename1pat p (\p -> PatTypeSig s p t) renameIrrP

    -- Hsx
    PXTag s n attrs mat ps -> do (attrs', nss) <- fmap unzip $ mapM renameIrrAttr attrs
                                 (mat', ns1) <- case mat of
                                                   Nothing -> return (Nothing, [])
                                                   Just at -> do (at', ns) <- renameIrrP at
                                                                 return (Just at', ns)
                                 (q, ns) <- renameNpat ps (PXTag s n attrs' mat') renameIrrP
                                 return (q, concat nss ++ ns1 ++ ns)
    PXETag s n attrs mat  -> do (as, nss) <- fmap unzip $ mapM renameIrrAttr attrs
                                (mat', ns1) <- case mat of
                                                  Nothing -> return (Nothing, [])
                                                  Just at -> do (at', ns) <- renameIrrP at
                                                                return (Just at', ns)
                                return $ (PXETag s n as mat', concat nss ++ ns1)
    PXPatTag p            -> rename1pat p PXPatTag renameIrrP
    -- End Hsx

    _                       -> return (p, [])

  where renameIrrPf :: PatField -> RN (PatField, [NameBind])
        renameIrrPf (PFieldPat n p) = rename1pat p (PFieldPat n) renameIrrP
        renameIrrPf pf = return (pf, [])

        renameIrrAttr :: PXAttr -> RN (PXAttr, [NameBind])
        renameIrrAttr (PXAttr s p) = rename1pat p (PXAttr s) renameIrrP
-----------------------------------------------------------------------------------
-- Transforming Patterns: the real stuff

-- | Transform several patterns in the same context, thereby
-- generating any code for matching regular patterns.
transformPatterns :: SrcLoc -> [Pat] -> HsxM ([Pat], [Guard], [Guard], [Decl])
transformPatterns s ps = runTr (trPatterns s ps)

---------------------------------------------------
-- The transformation monad

type State = (Int, Int, Int, [Guard], [Guard], [Decl])

newtype Tr a = Tr (State -> HsxM (a, State))

instance Monad Tr where
 return a = Tr $ \s -> return (a, s)
 (Tr f) >>= k = Tr $ \s ->
          do (a, s') <- f s
             let (Tr f') = k a
             f' s'

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

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

initState = initStateFrom 0 0

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

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


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


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

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

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

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

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

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

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

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

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


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


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

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

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

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

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

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

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

    -- Transforming any other patterns simply means transforming
    -- their subparts.
    PViewPat e p       -> do
        e' <- liftTr $ transformExpM e
        tr1pat p (PViewPat e') (trPattern s)
    PVar _             -> return p
    PLit _             -> return p
    PNeg q             -> tr1pat q PNeg (trPattern s)
    PInfixApp p1 op p2 -> tr2pat p1 p2 (\p1 p2 -> PInfixApp p1 op p2) (trPattern s)
    PApp n ps          -> trNpat ps (PApp n) (trPattern s)
    PTuple ps          -> trNpat ps PTuple (trPattern s)
    PList ps           -> trNpat ps PList (trPattern s)
    PParen p           -> tr1pat p PParen (trPattern s)
    PRec n pfs         -> trNpat pfs (PRec n) (trPatternField s)
    PAsPat n p         -> tr1pat p (PAsPat n) (trPattern s)
    PWildCard          -> return p
    PIrrPat p          -> tr1pat p PIrrPat (trPattern s)
    PatTypeSig s p t   -> tr1pat p (\p -> PatTypeSig s p t) (trPattern s)
    PExplTypeArg _ _   -> return p
    PQuasiQuote _ _    -> return p
    PBangPat p         -> tr1pat p PBangPat (trPattern s)
    PNPlusK _ _        -> return p

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

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

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

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

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

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

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


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

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


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


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

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

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

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

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

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

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

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

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

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



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

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

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


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

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

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

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


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

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


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

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


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

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

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

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


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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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


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

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

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

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

match_qual :: Name -> Exp
match_qual = qvar match_qual_mod

choiceOp :: QOp
choiceOp = QVarOp $ Qual match_qual_mod choice

appendOp :: QOp
appendOp = QVarOp $ UnQual append

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

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

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

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

varsname :: Name
varsname = name "harp_vars"

valname :: Name
valname = name "harp_val"

valsname :: Name
valsname = name "harp_vals"

valsvarsname :: Name
valsvarsname = name "harp_vvs"

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

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

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

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

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

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

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

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

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

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

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

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

metaPNothing :: Pat
metaPNothing = pvar nothing_name

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

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

metaNothing :: Exp
metaNothing = con nothing_name

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

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

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

cons :: QName
cons = Special Cons

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

