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

module Language.Haskell.Hsx.Transform (
	transform		-- :: HsModule -> HsModule
	) where

import Language.Haskell.Hsx.Syntax
import Language.Haskell.Hsx.Build
import Data.List (union)

import Debug.Trace (trace)

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

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

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

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

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

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

-----

type HsxState = (Bool, Bool)

initHsxState :: HsxState
initHsxState = (False, False)

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

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

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

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


-- | Transform away occurences of regular patterns from an abstract
-- Haskell module, preserving semantics.
transform :: HsModule -> HsModule
transform (HsModule s m 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 (:) $ HsImportDecl s match_mod True
			  	 (Just match_qual_mod)
			  	 Nothing
		     else id
	    imps2 = {- if hsx
	    	     then (:) $ HsImportDecl s hsx_data_mod False
	    	     		 Nothing
	    	     		 Nothing
	    	     else -} id		-- we no longer want to import HSP.Data
	 in HsModule s m mes (imps1 $ imps2 is) decls'

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

-- | Transform a declaration by transforming subterms that could
-- contain regular patterns.
transformDecl :: HsDecl -> HsxM HsDecl
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
	HsPatBind 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 [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
			   HsBDecls ds -> do ds' <- transformLetDecls ds
					     return $ HsBDecls $ decls'' ++ ds'
			   _           -> error "Cannot bind implicit parameters in the \
					    \ \'where\' clause of a function using regular patterns."
		return $ HsPatBind srcloc pat'' rhs' decls'

	-- Function binds can contain regular patterns in their matches
	HsFunBind ms -> fmap HsFunBind $ mapM transformMatch ms
	-- Instance declarations can contain regular patterns in the
	-- declarations of functions inside it
	HsInstDecl s c n ts decls ->
		fmap (HsInstDecl s c n ts) $ mapM transformDecl decls
	-- Class declarations can contain regular patterns in the
	-- declarations of automatically instantiated functions
	HsClassDecl s c n ns ds decls ->
		fmap (HsClassDecl s c n ns ds) $ mapM transformDecl decls
	-- Type signatures, type, newtype or data declarations, infix declarations
	-- and default declarations; none can contain regular patterns
	_ -> 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 :: HsMatch -> HsxM HsMatch
transformMatch (HsMatch srcloc name pats rhs decls) = do
	-- Preserve semantics of irrefutable regular patterns by postponing
	-- their evaluation to a let-expression on the right-hand side
  	let (pats', rnpss) = unzip $ renameIrrPats pats
  	-- Transform the patterns that stand as arguments to the function
  	(pats'', attrGuards, guards, decls'') <- transformPatterns pats'
	-- Transform the right-hand side, and add any generated guards
	-- and let expressions to it
  	rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs
	-- Transform declarations in the where clause, adding any generated
	-- declarations to it
  	decls' <- case decls of
  		   HsBDecls ds -> do ds' <- transformLetDecls ds
			  	     return $ HsBDecls $ decls'' ++ ds'
  		   _           -> error "Cannot bind implicit parameters in the \
  		  		     \ \'where\' clause of a function using regular patterns."

	return $ HsMatch srcloc name pats'' rhs' decls'
-- | Transform and update guards and right-hand side of a function or
-- pattern binding. The supplied list of guards is prepended to the 
-- original guards, and subterms are traversed and transformed.
mkRhs :: SrcLoc -> [Guard] -> [(HsName, HsPat)] -> HsRhs -> HsxM HsRhs
mkRhs srcloc guards rnps (HsUnGuardedRhs rhs) = do
	-- Add the postponed patterns to the right-hand side by placing
	-- them in a let-expression to make them lazily evaluated.
	-- Then transform the whole right-hand side as an expression.
	rhs' <- transformExp $ addLetDecls srcloc rnps rhs
	case guards of 
	 -- There were no guards before, and none should be added,
	 -- so we still have an unguarded right-hand side
	 [] -> return $ HsUnGuardedRhs rhs'
	 -- There are guards to add. These should be added as pattern
	 -- guards, i.e. as statements.
	 _  -> return $ HsGuardedRhss [HsGuardedRhs srcloc (map mkStmtGuard guards) rhs']
mkRhs _ guards rnps (HsGuardedRhss gdrhss) = fmap HsGuardedRhss $ mapM (mkGRhs guards rnps) gdrhss
  where mkGRhs :: [Guard] -> [(HsName, HsPat)] -> HsGuardedRhs -> HsxM HsGuardedRhs
	mkGRhs gs rnps (HsGuardedRhs s oldgs rhs) = do
		-- Add the postponed patterns to the right-hand side by placing
		-- them in a let-expression to make them lazily evaluated.
		-- Then transform the whole right-hand side as an expression.
		rhs' <- transformExp $ addLetDecls s rnps rhs
		-- Now there are guards, so first we need to transform those
		oldgs' <- fmap concat $ mapM (transformStmt Guard) oldgs
		-- ... and then prepend the newly generated ones, as statements
		return $ HsGuardedRhs 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 -> [(HsName, HsPat)] -> HsExp -> HsExp
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 -> (HsName, HsPat) -> HsDecl
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 :: HsExp -> HsxM HsExp
transformExp e = case e of
	-- A standard xml tag should be transformed into an element of the
	-- XML datatype. Attributes should be made into a set of mappings, 
	-- and children should be transformed.
	HsXTag _ 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 $ metaMkTag name as mattr cs'

	  where	-- | Transform expressions appearing in child position of an xml tag.
		-- Expressions are first transformed, then wrapped in a call to
		-- @toXml@.
		transformChild :: HsExp -> HsxM HsExp
		transformChild e = do
			-- Transform the expression
			te <- transformExp e
			-- ... and apply the overloaded toXMLs to it
			return $ metaToXmls te
		    
	-- An empty xml tag should be transformed just as a standard tag,
	-- only that there are no children,
	HsXETag _ 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 $ metaMkETag name as mattr
	-- PCDATA should be lifted as a string into the XML datatype.
	HsXPcdata pcdata	-> do setXmlTransformed
				      return $ metaMkPcdata pcdata
	-- Escaped expressions should be treated as just expressions.
	HsXExpTag e		-> do setXmlTransformed
				      transformExp 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.
	HsLambda s pats rhs -> do
		let -- First rename regular patterns
		    (ps, rnpss)  = unzip $ renameRPats pats
		    -- ... group them up to one big tuple
		    (rns, rps) = unzip (concat rnpss)
		    alt1 = alt s (pTuple rps) rhs
		    texp = varTuple rns
		    -- ... and put it all in a case expression, which
		    -- can then be transformed in the normal way.
                    e = if null rns then rhs else caseE texp [alt1]
		rhs' <- transformExp e
		return $ HsLambda 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.
	HsLet (HsBDecls ds) e -> do
		-- Declarations appearing in a let expression must be transformed
		-- in a special way due to scoping, see later documentation.
		-- The body is transformed as a normal expression.
		ds' <- transformLetDecls ds
		e'  <- transformExp e
		return $ letE ds' e'
	-- Bindings of implicit parameters can appear either in ordinary let
	-- expressions (GHC), in dlet expressions (Hugs) or in a with clause
	-- (both). Such bindings are transformed in a special way. The body 
	-- is transformed as a normal expression in all cases.
	HsLet (HsIPBinds is) e -> do
		is' <- mapM transformIPBind is
		e'  <- transformExp e
		return $ HsLet (HsIPBinds is') e'
	HsDLet ipbs e -> do
		ipbs' <- mapM transformIPBind ipbs
		e'    <- transformExp e
		return $ HsDLet ipbs' e'
	HsWith e ipbs -> do
		ipbs' <- mapM transformIPBind ipbs
		e'    <- transformExp e
		return $ HsWith e' ipbs'
	-- A case expression can contain regular patterns in the expression
	-- that is the subject of the casing, or in either of the alternatives.
	HsCase e alts -> do
		e'    <- transformExp e
		alts' <- mapM transformAlt alts
		return $ HsCase e' alts'
	-- A do expression can contain regular patterns in its statements.
	HsDo stmts -> do
		stmts' <- fmap concat $ mapM (transformStmt Do) stmts
		return $ HsDo stmts'
	HsMDo stmts -> do
		stmts' <- fmap concat $ mapM (transformStmt Do) stmts
		return $ HsMDo stmts'
	-- A list comprehension can contain regular patterns in the result 
	-- expression, or in any of its statements.
	HsListComp e stmts	-> do
		e'     <- transformExp e
		stmts' <- fmap concat $ mapM (transformStmt ListComp) stmts
		return $ HsListComp e' stmts'
	-- All other expressions simply transform their immediate subterms.
	HsInfixApp e1 op e2	-> transform2exp e1 e2 
					(\e1 e2 -> HsInfixApp e1 op e2)
	HsApp e1 e2         	-> transform2exp e1 e2 HsApp
	HsNegApp e 	    	-> fmap HsNegApp $ transformExp e
	HsIf e1 e2 e3 	    	-> transform3exp e1 e2 e3 HsIf
	HsTuple es	    	-> fmap HsTuple $ mapM transformExp es
	HsList es	    	-> fmap HsList $ mapM transformExp es
	HsParen e	    	-> fmap HsParen $ transformExp e
	HsLeftSection e op  	-> do e' <- transformExp e
				      return $ HsLeftSection e' op
	HsRightSection op e 	-> fmap (HsRightSection op) $ transformExp e
	HsRecConstr n fus   	-> fmap (HsRecConstr n) $ mapM transformFieldUpdate fus
	HsRecUpdate e fus   	-> do e'   <- transformExp e
				      fus' <- mapM transformFieldUpdate fus
				      return $ HsRecUpdate e' fus'
	HsEnumFrom e	    	-> fmap HsEnumFrom $ transformExp e
	HsEnumFromTo e1 e2  	-> transform2exp e1 e2 HsEnumFromTo
	HsEnumFromThen e1 e2 	-> transform2exp e1 e2 HsEnumFromThen
	HsEnumFromThenTo e1 e2 e3 -> transform3exp e1 e2 e3 HsEnumFromThenTo
	HsExpTypeSig s e t	-> do e' <- transformExp e
				      return $ HsExpTypeSig s e' t
	_			-> return e	-- Warning! Does not work with TH bracketed expressions ([| ... |])

  where transformFieldUpdate :: HsFieldUpdate -> HsxM HsFieldUpdate
	transformFieldUpdate (HsFieldUpdate n e) =
		fmap (HsFieldUpdate n) $ transformExp e
		
	transform2exp :: HsExp -> HsExp -> (HsExp -> HsExp -> HsExp) -> HsxM HsExp
	transform2exp e1 e2 f = do e1' <- transformExp e1
				   e2' <- transformExp e2
				   return $ f e1' e2'
	
	transform3exp :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> HsExp) -> HsxM HsExp
	transform3exp e1 e2 e3 f = do e1' <- transformExp e1
				      e2' <- transformExp e2
				      e3' <- transformExp e3
				      return $ f e1' e2' e3'

	mkAttr :: HsXAttr -> HsExp
	mkAttr (HsXAttr name e) = 
		paren (metaMkName name `metaAssign` e)


-- | Transform pattern bind declarations inside a @let@-expression by transforming 
-- subterms that could appear as regular patterns, as well as transforming the bound
-- pattern itself. The reason we need to do this in a special way is scoping, i.e.
-- in the expression @let a | Just b <- match a = list in b@ the variable b will not
-- be in scope after the @in@. And besides, we would be on thin ice even if it was in
-- scope since we are referring to the pattern being bound in the guard that will
-- decide if the pattern will be bound... yikes, why does Haskell allow guards on 
-- pattern binds to refer to the patterns being bound, could that ever lead to anything
-- but an infinite loop??
transformLetDecls :: [HsDecl] -> HsxM [HsDecl]
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 -> [HsDecl] -> HsxM [HsDecl]
  	transformLDs k l ds = case ds of
  	    []     -> return []
  	    (d:ds) -> case d of
  		HsPatBind srcloc pat rhs decls -> do
			-- We need to transform all pattern bindings in a set of
		  	-- declarations in the same context w.r.t. generating fresh
		  	-- variable names, since they will all be in scope at the same time.
		  	([pat'], ags, gs, ws, k', l') <- runTrFromTo k l (trPatterns [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...
			    HsBDecls decls -> fmap HsBDecls $ transformLetDecls decls
			    -- If they are implicit parameter bindings we simply transform
			    -- them as such.
			    HsIPBinds decls -> fmap HsIPBinds $ 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 $ (HsPatBind srcloc pat' rhs' decls') : ags' ++ gs' ++ ds'

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


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

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

-- | A simple annotation datatype for statement contexts.
data StmtType = Do | Guard | ListComp

-- | 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 -> HsStmt -> HsxM [HsStmt]
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.
	HsGenerator s p e -> do
		let -- We need to treat generated guards differently depending
		    -- on the context of the statement.
		    guardFun = case t of
				Do	 -> monadify
				ListComp -> monadify
				Guard	 -> mkStmtGuard
		    -- Preserve semantics of irrefutable regular patterns by postponing
		    -- their evaluation to a let-expression on the right-hand side
		    ([p'], rnpss) = unzip $ renameIrrPats [p]
		-- Transform the pattern itself
		([p''], ags, gs, ds) <- transformPatterns [p']
		-- Put the generated declarations in a let-statement
		let lt  = case ds of
			   [] -> []
			   _  -> [letStmt ds]
		    -- Perform the designated trick on the generated guards.
		    gs' = map guardFun (ags ++ gs)
		-- Add the postponed patterns to the right-hand side by placing
		-- them in a let-expression to make them lazily evaluated.
		-- Then transform the whole right-hand side as an expression.
		e' <- transformExp $ addLetDecls s (concat rnpss) e
		return $ HsGenerator s p'' e':lt ++ gs'
	  where monadify :: Guard -> HsStmt
	  	-- 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.
	HsQualifier e -> fmap (\e -> [HsQualifier $ e]) $ transformExp e
	-- Let statements suffer from the same problem as let expressions, so
	-- the declarations should be treated in the same special way.
	HsLetStmt (HsBDecls ds)  -> 
		fmap (\ds -> [letStmt ds]) $ transformLetDecls ds
	-- If the bindings are of implicit parameters we simply transform them as such.
	HsLetStmt (HsIPBinds is) -> 
		fmap (\is -> [HsLetStmt (HsIPBinds is)]) $ mapM transformIPBind is


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

-- | Transform alternatives in a @case@-expression. Patterns are
-- transformed, while other subterms are traversed further.
transformAlt :: HsAlt -> HsxM HsAlt
transformAlt (HsAlt 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 [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
  		   HsBDecls ds -> do ds' <- mapM transformDecl ds
  		   		     return $ HsBDecls $ decls'' ++ ds
  		   _ 	       -> error "Cannot bind implicit parameters in the \
  		  		     \ \'where\' clause of a function using regular patterns."

	return $ HsAlt 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] -> [(HsName, HsPat)] -> HsGuardedAlts -> HsxM HsGuardedAlts
	mkGAlts s guards rnps (HsUnGuardedAlt rhs) = do
		-- Add the postponed patterns to the right-hand side by placing
		-- them in a let-expression to make them lazily evaluated.
		-- Then transform the whole right-hand side as an expression.
		rhs' <- transformExp $ addLetDecls s rnps rhs
		case guards of
		 -- There were no guards before, and none should be added,
		 -- so we still have an unguarded right-hand side
		 [] -> return $ HsUnGuardedAlt rhs'
		 -- There are guards to add. These should be added as pattern
		 -- guards, i.e. as statements.
		 _  -> return $ HsGuardedAlts [HsGuardedAlt s (map mkStmtGuard guards) rhs']
	mkGAlts s gs rnps (HsGuardedAlts galts) =
		fmap HsGuardedAlts $ mapM (mkGAlt gs rnps) galts
	  where mkGAlt :: [Guard] -> [(HsName, HsPat)] -> HsGuardedAlt -> HsxM HsGuardedAlt
		mkGAlt gs rnps (HsGuardedAlt 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.
			do rhs'   <- transformExp $ addLetDecls s rnps rhs
			    -- Now there are guards, so first we need to transform those
			   oldgs' <- fmap concat $ mapM (transformStmt Guard) oldgs
			    -- ... and then prepend the newly generated ones, as statements
			   return $ HsGuardedAlt 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, HsPat, HsExp)

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

mkDeclGuard :: Guard -> [HsDecl] -> HsDecl
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 HsName
genVarName = do 
	k <- getRNState
	setRNState $ k+1
	return $ name $ "harp_rnvar" ++ show k


type NameBind = (HsName, HsPat)

-- 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 :: [HsPat] -> [(HsPat, [NameBind])]
renameRPats ps = runRename $ mapM renameRP ps

renameRP :: HsPat -> RN (HsPat, [NameBind])
renameRP p = case p of
	-- We must rename regular patterns and Tag expressions
	HsPRPat _ _ 	    -> rename p
	HsPXTag _ _ _ _ _   -> rename p
	HsPXETag _ _ _ _    -> rename p
	-- The rest of the rules simply try to rename regular patterns in
	-- their immediate subpatterns.
	HsPNeg p    	    -> rename1pat p HsPNeg renameRP
	HsPInfixApp p1 n p2 -> rename2pat p1 p2
				(\p1 p2 -> HsPInfixApp p1 n p2)
				renameRP
	HsPApp n ps	    -> renameNpat ps (HsPApp n) renameRP
	HsPTuple ps	    -> renameNpat ps HsPTuple renameRP
	HsPList ps	    -> renameNpat ps HsPList renameRP
	HsPParen p	    -> rename1pat p HsPParen renameRP
	HsPRec n pfs	    -> renameNpat pfs (HsPRec n) renameRPf
	HsPAsPat n p	    -> rename1pat p (HsPAsPat n) renameRP
	HsPIrrPat p	    -> rename1pat p HsPIrrPat renameRP
	HsPXPatTag p	    -> rename1pat p HsPXPatTag renameRP
	HsPatTypeSig s p t  -> rename1pat p (\p -> HsPatTypeSig s p t) renameRP	
	_		    -> return (p, [])

  where renameRPf :: HsPatField -> RN (HsPatField, [NameBind])
  	renameRPf (HsPFieldPat n p) = rename1pat p (HsPFieldPat n) renameRP
  	
  	renameAttr :: HsPXAttr -> RN (HsPXAttr, [NameBind])
  	renameAttr (HsPXAttr s p) = rename1pat p (HsPXAttr s) renameRP
  	
  	rename :: HsPat -> RN (HsPat, [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 :: [HsDecl] -> [HsDecl]
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 :: HsDecl -> RN (HsDecl, [(SrcLoc, HsName, HsPat)])
	renameLetDecl d = case d of
		-- We need only bother about pattern bindings.
		HsPatBind srcloc pat rhs decls -> do
			-- Rename any regular patterns that appear in the
			-- pattern being bound.
			(p, ms) <- renameRP pat
			let sms = map (\(n,p) -> (srcloc, n, p)) ms
			return $ (HsPatBind srcloc p rhs decls, sms)
		_ -> return (d, [])


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

renameIrrP :: HsPat -> RN (HsPat, [(HsName, HsPat)])
renameIrrP p = case p of
	-- We should rename any regular pattern appearing
	-- inside an irrefutable pattern.
	HsPIrrPat p	    -> do (q, ms) <- renameRP p
				  return $ (HsPIrrPat q, ms)
	-- The rest of the rules simply try to rename regular patterns in
	-- irrefutable patterns in their immediate subpatterns.
	HsPNeg p    	    -> rename1pat p HsPNeg renameIrrP
	HsPInfixApp p1 n p2 -> rename2pat p1 p2
				(\p1 p2 -> HsPInfixApp p1 n p2)
				renameIrrP
	HsPApp n ps	    -> renameNpat ps (HsPApp n) renameIrrP
	HsPTuple ps	    -> renameNpat ps HsPTuple renameIrrP
	HsPList ps	    -> renameNpat ps HsPList renameIrrP
	HsPParen p	    -> rename1pat p HsPParen renameIrrP
	HsPRec n pfs	    -> renameNpat pfs (HsPRec n) renameIrrPf
	HsPAsPat n p	    -> rename1pat p (HsPAsPat n) renameIrrP
	HsPatTypeSig s p t  -> rename1pat p (\p -> HsPatTypeSig s p t) renameIrrP	

	-- Hsx
	HsPXTag s n attrs mat p -> 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) <- rename1pat p (HsPXTag s n attrs' mat') renameIrrP
				      return (q, concat nss ++ ns1 ++ ns)
	HsPXETag 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 $ (HsPXETag s n as mat', concat nss ++ ns1)
	HsPXPatTag p	    	-> rename1pat p HsPXPatTag renameIrrP
	-- End Hsx

	_		    -> return (p, [])
	
  where renameIrrPf :: HsPatField -> RN (HsPatField, [NameBind])
  	renameIrrPf (HsPFieldPat n p) = rename1pat p (HsPFieldPat n) renameIrrP
  	
  	renameIrrAttr :: HsPXAttr -> RN (HsPXAttr, [NameBind])
  	renameIrrAttr (HsPXAttr s p) = rename1pat p (HsPXAttr s) renameIrrP
-----------------------------------------------------------------------------------
-- Transforming Patterns: the real stuff

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

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

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

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], [HsDecl])
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], [HsDecl], 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 -> HsPat -> HsExp -> Tr ()
pushGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,(s,p,e):gs2,ds))
		 
pushDecl :: HsDecl -> Tr ()
pushDecl d = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,gs2,d:ds))

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

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

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

genAttrName :: Tr HsName
genAttrName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m,a+1,gs1,gs2,ds))
		 return $ HsIdent $ "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 :: [HsPat] -> Tr [HsPat]
trPatterns = mapM trPattern

-- | Transform a pattern by traversing the syntax tree.
-- A regular pattern is translated, other patterns are 
-- simply left as is.
trPattern :: HsPat -> Tr HsPat
trPattern p = case p of
	-- This is where the fun starts. =)
	-- Regular patterns must be transformed of course.
	HsPRPat s 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 (HsRPSeq 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
	HsPXTag s name attrs mattr cpat -> 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' <- trPattern cpat
		-- ...  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
	HsPXETag 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.
	HsPXPcdata s -> setHarpTransformedT >> (return $ metaPcdata s)
	-- XML comments are likewise just treated as strings.
	HsPXPatTag p -> setHarpTransformedT >> trPattern p

	-- Transforming any other patterns simply means transforming
	-- their subparts.
	HsPVar _	     -> return p
	HsPLit _	     -> return p
	HsPNeg q	     -> tr1pat q HsPNeg trPattern
	HsPInfixApp p1 op p2 -> tr2pat p1 p2 (\p1 p2 -> HsPInfixApp p1 op p2) trPattern
	HsPApp n ps	     -> trNpat ps (HsPApp n) trPattern
	HsPTuple ps	     -> trNpat ps HsPTuple trPattern
	HsPList ps	     -> trNpat ps HsPList trPattern
	HsPParen p	     -> tr1pat p HsPParen trPattern
	HsPRec n pfs	     -> trNpat pfs (HsPRec n) trPatternField
	HsPAsPat n p	     -> tr1pat p (HsPAsPat n) trPattern
	HsPWildCard	     -> return p
	HsPIrrPat p	     -> tr1pat p HsPIrrPat trPattern
	HsPatTypeSig s p t   -> tr1pat p (\p -> HsPatTypeSig s p t) trPattern

  where	-- Transform a pattern field.
  	trPatternField :: HsPatField -> Tr HsPatField
  	trPatternField (HsPFieldPat n p) = 
  		tr1pat p (HsPFieldPat n) trPattern
 
	-- Deconstruct an xml tag name into its parts.
	xNameParts :: HsXName -> (Maybe String, String)
	xNameParts n = case n of
			HsXName s      -> (Nothing, s)
			HsXDomName d s -> (Just d, s)

	-- | Generate a guard for looking up xml attributes.
	mkAttrGuards :: SrcLoc -> HsName -> [HsPXAttr] -> Maybe HsPat -> Tr ()
	mkAttrGuards s attrs [HsPXAttr 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 ((HsPXAttr 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 -> HsName -> [HsName] -> Tr HsName
	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 -> HsName -> HsName -> [HsName] -> HsDecl
	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 -> [HsName] -> HsName -> HsName -> 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 = (HsName, [HsName], MType)


-- | Transform away a regular pattern, generating code
-- to replace it.
trRPat :: SrcLoc -> Bool -> HsRPat -> 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.
    HsRPPat p -> do mkBaseDecl s linear p
  
      where -- | Generate declarations for matching ordinary Haskell patterns
	    mkBaseDecl :: SrcLoc -> Bool -> HsPat -> Tr MFunMetaInfo
	    mkBaseDecl s linear p = case p of
		-- We can simplify a lot if the pattern is a wildcard or a variable
		HsPWildCard -> mkWCMatch s
		HsPVar v    -> mkVarMatch s linear v
		-- ... and if it is an embedded pattern tag, we can just skip it
		HsPXPatTag 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 declaration for matching a variable.
	    mkVarMatch :: SrcLoc -> Bool -> HsName -> Tr MFunMetaInfo
	    mkVarMatch s linear v = do
		-- First we need a name for the new match function.
		n <- genMatchName
		-- Then we need a basic matching function that always matches,
		-- and that binds the value matched to the variable in question.
		let e = paren $ lamE s [pvar v] $		-- (\v -> Just (mf v))
				  app (var just_name) 
				  (paren $ retVar linear v)
		-- Lift the function into the matcher monad, and bind it to its name,
		-- then add it the declaration to the store.
		pushDecl $ nameBind s n $
			      app baseMatchFun e	-- harp_matchX = baseMatch (\v -> Just (mf v))
		return (n, [v], S)			-- always binds v and only v

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

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

	    -- | 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 -> HsPat -> 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)

	      where -- | Gather up the names of all variables in a pattern,
		    -- using a simple fold over the syntax structure.
		    gatherPVars :: HsPat -> [HsName]
		    gatherPVars p = case p of
			HsPVar v	     -> [v]
			HsPNeg q	     -> gatherPVars q
			HsPInfixApp p1 _ p2  -> gatherPVars p1 ++
						 gatherPVars p2
			HsPApp _ ps	     -> concatMap gatherPVars ps 
			HsPTuple ps	     -> concatMap gatherPVars ps 
			HsPList ps	     -> concatMap gatherPVars ps 
			HsPParen p	     -> gatherPVars p
			HsPRec _ pfs	     -> concatMap help pfs
				where help (HsPFieldPat _ p) = gatherPVars p
			HsPAsPat n p	     -> n : gatherPVars p
			HsPWildCard	     -> []
			HsPIrrPat p	     -> gatherPVars p
			HsPatTypeSig _ p _   -> gatherPVars p
			HsPRPat _ rps	     -> concatMap gatherRPVars rps
			HsPXTag _ _ attrs mattr cp -> 
				concatMap gatherAttrVars attrs ++ gatherPVars cp ++
					case mattr of
					 Nothing -> []
					 Just ap -> gatherPVars ap
			HsPXETag _ _ attrs mattr -> 
				concatMap gatherAttrVars attrs ++ 
					case mattr of
					 Nothing -> []
					 Just ap -> gatherPVars ap
			HsPXPatTag p	     -> gatherPVars p
			_		     -> []

		    gatherRPVars :: HsRPat -> [HsName]
		    gatherRPVars rp = case rp of
			HsRPStar rq	   -> gatherRPVars rq
			HsRPStarG rq	   -> gatherRPVars rq
			HsRPPlus rq 	   -> gatherRPVars rq
			HsRPPlusG rq	   -> gatherRPVars rq
			HsRPOpt rq	   -> gatherRPVars rq
			HsRPOptG rq	   -> gatherRPVars rq
			HsRPEither rq1 rq2 -> gatherRPVars rq1 ++ gatherRPVars rq2
			HsRPSeq rqs	   -> concatMap gatherRPVars rqs
			HsRPCAs n rq	   -> n : gatherRPVars rq
			HsRPAs n rq	   -> n : gatherRPVars rq
			HsRPParen rq	   -> gatherRPVars rq
			HsRPPat q	   -> gatherPVars q
		
		    gatherAttrVars :: HsPXAttr -> [HsName]
		    gatherAttrVars (HsPXAttr _ p) = gatherPVars p

	    -- | Generate a basic casing function for a given pattern.	
	    basePatDecl :: SrcLoc -> Bool -> HsName -> [HsName] -> HsPat -> Tr HsDecl
	    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 = HsIdent $ "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 -> HsPat -> HsName -> [HsName] -> Tr HsExp
		    baseCaseE s b p a vs = do
			-- First the alternative if we actually 
			-- match the given pattern
			let alt1 = alt s p 				    -- foo -> Just (mf foo)
				    (app (var just_name) $ 
				     tuple (map (retVar b) vs))
			    -- .. and finally an alternative for not matching the pattern.
			    alt2 = alt s wildcard (var nothing_name)	    -- _ -> Nothing
			-- ... and that pattern could itself contain regular patterns
			-- so we must transform away these.
			alt1' <- liftTr $ transformAlt alt1
			return $ caseE (var a) [alt1', alt2]
		    retVar :: Bool -> HsName -> HsExp
		    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 match function that lift the result of the
	    -- basic casing function into the matcher monad.
	    mkBaseMatch :: SrcLoc -> HsName -> Tr HsName
	    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 -> HsName -> HsName -> HsDecl
	    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


    -- For a sequence of regular patterns, we should transform all
    -- sub-patterns and then generate a function for sequencing them.
    HsRPSeq 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 -> [(HsName, MType)] -> [HsDecl]
	    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 -> (HsName, MType) -> (HsName, HsDecl)
	    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 -> HsExp
	    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.
    HsRPCAs 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 HsName
	    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.
    HsRPAs 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
		    	HsIdent 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 HsName
	    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.
    HsRPParen 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...
    HsRPOpt rp -> 
    	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.
    HsRPOptG rp -> 
    	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.
    HsRPEither rp1 rp2 -> 
    	do -- Transform the subpatterns
    	   nvt1 <- trRPat s False rp1
	   nvt2 <- trRPat s False rp2
	   -- ... and create a declaration that can choose between them.
	   mkEitherDecl s nvt1 nvt2
  	-- | Generate declarations for either patterns, i.e. ( | )
      where mkEitherDecl :: SrcLoc -> MFunMetaInfo -> MFunMetaInfo -> Tr MFunMetaInfo
            mkEitherDecl s nvt1@(_, vs1, t1) nvt2@(_, vs2, t2) = do
                -- Eine namen, bitte!
  		n <- genMatchName
  		let -- Generate generators for the subpatterns
  		    (g1, v1) = mkGenExp s nvt1
  		    (g2, v2) = mkGenExp s nvt2			-- (harp_valX, (foo, bar, ...)) <- harp_matchY
  		    -- ... gather all variables from both sides
  		    allvs = vs1 `union` vs2
  		    -- ... some may be bound on both sides, so we
  		    -- need to check which ones are bound on each,
  		    -- supplying empty value for those that are not
  		    vals1 = map (varOrId vs1) allvs		
  		    vals2 = map (varOrId vs2) allvs
  		    -- ... apply either Left or Right to the returned value
  		    ret1  = metaReturn $ tuple			-- return (Left harp_val1, (foo, id, ...))
  		    		[app (var left_name)
  		    		 (var v1), tuple vals1]
  		    ret2  = metaReturn $ tuple			-- return (Right harp_val2, (id, bar, ...))
  		    		[app (var right_name)
  		    		 (var v2), tuple vals2]
  		    -- ... and do all these things in do-expressions
  		    exp1  = doE [g1, qualStmt ret1]
  		    exp2  = doE [g2, qualStmt ret2]
  		    -- ... and choose between them using the choice (+++) operator.
  		    rhs   = (paren exp1) `metaChoice`		-- (do ...) +++ 
  		    		(paren exp2)			--  (do ...)
  		-- Finally we create a declaration for this function and
  		-- add it to the store.
  		pushDecl $ nameBind s n rhs			-- harp_matchZ = (do ...) ...
  		-- The type of the returned value is Either the type of the first
  		-- or the second subpattern.
  		return (n, allvs, E t1 t2)
  		 
	    varOrId :: [HsName] -> HsName -> HsExp
	    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.
    HsRPStar rp	-> 
    	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.
    HsRPStarG rp -> 
    	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.
    HsRPPlus rp	-> 
	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.
    HsRPPlusG rp -> 
	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 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] -> [(HsStmt, (HsName, 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 -> (HsStmt, HsName)
	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 -> HsName -> HsStmt
	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 :: (HsExp -> HsExp) -> SrcLoc -> MFunMetaInfo -> Tr HsName
	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 (var 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, ...))
  		    		[var 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 :: (HsName, HsName) -> HsExp
	  	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 :: HsExp
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 :: HsName
runMatch_name = HsIdent "runMatch"
baseMatch_name = HsIdent "baseMatch"
manyMatch_name = HsIdent "manyMatch"
gManyMatch_name = HsIdent "gManyMatch"

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

match_qual :: HsName -> HsExp
match_qual = qvar match_qual_mod

choiceOp :: HsQOp
choiceOp = HsQVarOp $ Qual match_qual_mod choice

appendOp :: HsQOp
appendOp = HsQVarOp $ UnQual append

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

mkMetaUnzip :: SrcLoc -> Int -> HsExp -> HsExp
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 :: (HsName, HsName) -> HsExp
  	appCons (x, xs) = metaCons (var x) (var xs)

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

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

varsname :: HsName
varsname = name "harp_vars"

valname :: HsName
valname = name "harp_val"

valsname :: HsName
valsname = name "harp_vals"

valsvarsname :: HsName
valsvarsname = name "harp_vvs"

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

extendVar :: HsName -> String -> HsName
extendVar (HsIdent n) s = HsIdent $ n ++ s
extendVar n _ = n

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

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

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

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

metaConcat :: [HsExp] -> HsExp
metaConcat es = metaFunction "concat" [listE es]

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

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

metaPCons :: HsPat -> HsPat -> HsPat
metaPCons p1 p2 = HsPInfixApp p1 cons p2

metaCons, metaComp :: HsExp -> HsExp -> HsExp
metaCons e1 e2 = infixApp e1 (HsQConOp cons) e2
metaComp e1 e2 = infixApp e1 (op fcomp) e2

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

metaPNothing :: HsPat
metaPNothing = pvar nothing_name

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

metaJust :: HsExp -> HsExp
metaJust e = app (var just_name) e

metaNothing :: HsExp
metaNothing = var nothing_name

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

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

cons :: HsQName
cons = Special HsCons

fcomp, choice, append :: HsName
fcomp = HsSymbol "."
choice = HsSymbol "+++"
append = HsSymbol "++"

just_name, nothing_name, left_name, right_name :: HsName
just_name = HsIdent "Just"
nothing_name = HsIdent "Nothing"
left_name = HsIdent "Left"
right_name = HsIdent "Right"

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

hsx_data_mod :: Module
hsx_data_mod = Module "HSP.Data"

-- | Create an xml PCDATA value
metaMkPcdata :: String -> HsExp
metaMkPcdata s = metaFunction "pcdata" [strE s]

-- | Create an xml tag, given its domain, name, attributes and
-- children.
metaMkTag :: HsXName -> [HsExp] -> Maybe HsExp -> [HsExp] -> HsExp
metaMkTag 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 $ metaToAttribute x)) mat
	    attrs = m $ listE $ map metaToAttribute ats
	 in metaFunction "genTag" [ne, attrs, listE cs]

-- | Create an empty xml tag, given its domain, name and attributes.
metaMkETag :: HsXName -> [HsExp] -> Maybe HsExp -> HsExp
metaMkETag 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 $ metaToAttribute x)) mat
	    attrs = m $ listE $ map metaToAttribute ats
	 in metaFunction "genETag" [ne, attrs]

-- | Create an attribute by applying the overloaded @toAttribute@
metaToAttribute :: HsExp -> HsExp
metaToAttribute e = metaFunction "toAttribute" [e]

-- | Create a property from an attribute and a value.
metaAssign :: HsExp -> HsExp -> HsExp
metaAssign e1 e2 = infixApp e1 assignOp e2
  where assignOp = HsQVarOp $ UnQual $ HsSymbol ":="

-- | Make xml out of some expression by applying the overloaded function
-- @toXml@.
metaToXmls :: HsExp -> HsExp
metaToXmls e = metaFunction "toXMLs" [paren e]

-- | Lookup an attribute in the set of attributes.
metaExtract :: HsXName -> HsName -> HsExp
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 -> HsPat -> HsPat -> HsPat
metaTag dom name ats cpat =
	let d = metaPMkMaybe $ fmap strP dom
	    n = pTuple [d, strP name]
	 in metaConPat "Tag" [n, ats, cpat]
	 
-- | Generate a pattern under the PCDATA data constructor.
metaPcdata :: String -> HsPat
metaPcdata s = metaConPat "PCDATA" [strP s]

metaMkName :: HsXName -> HsExp
metaMkName n = case n of
	HsXName s      -> strE s
	HsXDomName d s -> tuple [strE d, strE s]