Do dependency analysis when kind-checking type declarations

[ghc-hetmet.git] / compiler / hsSyn / HsUtils.lhs

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index d2c5d0e..3ef4bff 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -1,3 +1,4 @@
+

 %
 % (c) The University of Glasgow, 1992-2006
 %
 %
 % (c) The University of Glasgow, 1992-2006
 %

@@ -13,26 +14,73 @@ which deal with the intantiated versions are located elsewhere:
    Id                  typecheck/TcHsSyn       
 
 \begin{code}
    Id                  typecheck/TcHsSyn       
 
 \begin{code}

-module HsUtils where
-
-#include "HsVersions.h"
+module HsUtils(
+  -- Terms
+  mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
+  mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
+  mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
+  mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
+  coiToHsWrapper, mkHsDictLet,
+  mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
+
+  nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
+  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
+  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
+
+  -- Bindigns
+  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, 
+
+  -- Literals
+  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, 
+
+  -- Patterns
+  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat,
+  nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat, 
+
+  -- Types
+  mkHsAppTy, userHsTyVarBndrs,
+  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, 
+
+  -- Stmts
+  mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt,
+  mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, 
+  emptyRecStmt, mkRecStmt, 
+
+  -- Template Haskell
+  unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote,
+
+  -- Flags
+  noRebindableInfo, 
+
+  -- Collecting binders
+  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
+  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
+  collectPatBinders, collectPatsBinders,
+  collectLStmtsBinders, collectStmtsBinders,
+  collectLStmtBinders, collectStmtBinders,
+  collectSigTysFromPats, collectSigTysFromPat,
+
+  hsTyClDeclBinders, hsTyClDeclsBinders, 
+  hsForeignDeclsBinders, hsGroupBinders
+  ) where

 
 

+import HsDecls

 import HsBinds
 import HsExpr
 import HsPat
 import HsTypes 
 import HsLit
 import HsBinds
 import HsExpr
 import HsPat
 import HsTypes 
 import HsLit

-import HsDecls

 
 import RdrName
 import Var
 
 import RdrName
 import Var

+import Coercion

 import Type
 import DataCon
 import Name
 import Type
 import DataCon
 import Name

+import NameSet

 import BasicTypes
 import SrcLoc
 import FastString
 import BasicTypes
 import SrcLoc
 import FastString

-import Outputable

 import Util
 import Bag
 \end{code}
 import Util
 import Bag
 \end{code}

@@ -81,7 +129,27 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 
 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e

-                | otherwise          = HsWrap co_fn e
+                | otherwise           = HsWrap co_fn e
+
+mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
+mkHsWrapCoI (IdCo _) e = e
+mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
+
+mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
+mkLHsWrapCoI (IdCo _) e         = e
+mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
+
+coiToHsWrapper :: CoercionI -> HsWrapper
+coiToHsWrapper (IdCo _) = idHsWrapper
+coiToHsWrapper (ACo co) = WpCast co
+
+mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
+mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
+                      | otherwise           = CoPat co_fn p ty
+
+mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
+mkHsWrapPatCoI (IdCo _) pat _  = pat
+mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty

 
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))

@@ -91,17 +159,11 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 mkMatchGroup :: [LMatch id] -> MatchGroup id
 mkMatchGroup matches = MatchGroup matches placeHolderType
 
 mkMatchGroup :: [LMatch id] -> MatchGroup id
 mkMatchGroup matches = MatchGroup matches placeHolderType
 

-mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
--- Used for the dictionary bindings gotten from TcSimplify
--- We make them recursive to be on the safe side
-mkHsDictLet binds expr 
-  | isEmptyLHsBinds binds = expr
-  | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
-                         where
-                           val_binds = ValBindsOut [(Recursive, binds)] []
+mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
+mkHsDictLet ev_binds expr = mkLHsWrap (WpLet ev_binds) expr

 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id

--- Used for constructing dictinoary terms etc, so no locations 
+-- Used for constructing dictionary terms etc, so no locations 

 mkHsConApp data_con tys args 
   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
   where
 mkHsConApp data_con tys args 
   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
   where

@@ -116,33 +178,91 @@ mkSimpleHsAlt pat expr
 -- These are the bits of syntax that contain rebindable names
 -- See RnEnv.lookupSyntaxName
 
 -- These are the bits of syntax that contain rebindable names
 -- See RnEnv.lookupSyntaxName
 

-mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
-mkHsFractional f       = HsFractional f  noSyntaxExpr
+mkHsIntegral   :: Integer -> PostTcType -> HsOverLit id
+mkHsFractional :: Rational -> PostTcType -> HsOverLit id
+mkHsIsString   :: FastString -> PostTcType -> HsOverLit id
+mkHsDo         :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
+
+mkNPat      :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
+mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
+
+mkTransformStmt   :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
+mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
+
+mkExprStmt :: LHsExpr idR -> StmtLR idL idR
+mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
+
+emptyRecStmt :: StmtLR idL idR
+mkRecStmt    :: [LStmtLR idL idR] -> StmtLR idL idR
+
+
+mkHsIntegral   i       = OverLit (HsIntegral   i)  noRebindableInfo noSyntaxExpr
+mkHsFractional f       = OverLit (HsFractional f)  noRebindableInfo noSyntaxExpr
+mkHsIsString   s       = OverLit (HsIsString   s)  noRebindableInfo noSyntaxExpr
+
+noRebindableInfo :: Bool
+noRebindableInfo = error "noRebindableInfo"    -- Just another placeholder; 
+

 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 

-mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
+mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
+mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
+
+mkNPat lit neg     = NPat lit neg noSyntaxExpr

 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 
 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 

+mkTransformStmt   stmts usingExpr        = TransformStmt stmts [] usingExpr Nothing
+mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
+
+mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL idR
+mkGroupByStmt      :: [LStmt idL] -> LHsExpr idR                -> StmtLR idL idR
+mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
+
+mkGroupUsingStmt   stmts usingExpr        = GroupStmt stmts [] Nothing       (Left usingExpr)    
+mkGroupByStmt      stmts byExpr           = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
+mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)    
+

 mkExprStmt expr            = ExprStmt expr noSyntaxExpr placeHolderType
 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 mkExprStmt expr            = ExprStmt expr noSyntaxExpr placeHolderType
 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr

-mkRecStmt stmts            = RecStmt stmts [] [] [] emptyLHsBinds
+
+emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
+                       , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
+                      , recS_bind_fn = noSyntaxExpr
+                       , recS_rec_rets = [] }
+
+mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }

 
 -------------------------------
 --- A useful function for building @OpApps@.  The operator is always a
 -- variable, and we don't know the fixity yet.
 
 -------------------------------
 --- A useful function for building @OpApps@.  The operator is always a
 -- variable, and we don't know the fixity yet.

+mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id

 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 
 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 

+mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName

 mkHsSplice e = HsSplice unqualSplice e
 
 mkHsSplice e = HsSplice unqualSplice e
 

-unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
+mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
+mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
+
+unqualSplice :: RdrName
+unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))

                -- A name (uniquified later) to
                -- identify the splice
 
                -- A name (uniquified later) to
                -- identify the splice
 

+mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
+mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
+
+unqualQuasiQuote :: RdrName
+unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
+               -- A name (uniquified later) to
+               -- identify the quasi-quote
+
+mkHsString :: String -> HsLit

 mkHsString s = HsString (mkFastString s)
 
 -------------
 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
 mkHsString s = HsString (mkFastString s)
 
 -------------
 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]

-userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
+userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]

 \end{code}
 
 
 \end{code}
 
 

@@ -168,6 +288,7 @@ nlLitPat l = noLoc (LitPat l)
 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 nlHsApp f x = noLoc (HsApp f x)
 
 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 nlHsApp f x = noLoc (HsApp f x)
 

+nlHsIntLit :: Integer -> LHsExpr id

 nlHsIntLit n = noLoc (HsLit (HsInt n))
 
 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 nlHsIntLit n = noLoc (HsLit (HsInt n))
 
 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id

@@ -194,29 +315,57 @@ nlWildConPat :: DataCon -> LPat RdrName
 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                                   (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 
 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                                   (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 

-nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
+nlWildPat :: LPat id

 nlWildPat  = noLoc (WildPat placeHolderType)   -- Pre-typechecking
 
 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 
 nlWildPat  = noLoc (WildPat placeHolderType)   -- Pre-typechecking
 
 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
 nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
 

+nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id

 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 
 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 

+nlHsLam  :: LMatch id -> LHsExpr id
+nlHsPar  :: LHsExpr id -> LHsExpr id
+nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
+nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
+nlList   :: [LHsExpr id] -> LHsExpr id
+

 nlHsLam        match           = noLoc (HsLam (mkMatchGroup [match]))
 nlHsPar e              = noLoc (HsPar e)
 nlHsLam        match           = noLoc (HsLam (mkMatchGroup [match]))
 nlHsPar e              = noLoc (HsPar e)

-nlHsIf cond true false = noLoc (HsIf cond true false)
+nlHsIf cond true false = noLoc (mkHsIf cond true false)

 nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup matches))
 nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup matches))

-nlTuple exprs box      = noLoc (ExplicitTuple exprs box)

 nlList exprs           = noLoc (ExplicitList placeHolderType exprs)
 
 nlList exprs           = noLoc (ExplicitList placeHolderType exprs)
 

+nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
+nlHsTyVar :: name                         -> LHsType name
+nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
+

 nlHsAppTy f t          = noLoc (HsAppTy f t)
 nlHsTyVar x            = noLoc (HsTyVar x)
 nlHsFunTy a b          = noLoc (HsFunTy a b)
 
 nlHsAppTy f t          = noLoc (HsAppTy f t)
 nlHsTyVar x            = noLoc (HsTyVar x)
 nlHsFunTy a b          = noLoc (HsFunTy a b)
 

+nlHsTyConApp :: name -> [LHsType name] -> LHsType name

 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 \end{code}
 
 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 \end{code}
 

+Tuples.  All these functions are *pre-typechecker* because they lack
+types on the tuple.

 
 

+\begin{code}
+mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
+-- Makes a pre-typechecker boxed tuple, deals with 1 case
+mkLHsTupleExpr [e] = e
+mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map Present es) Boxed
+
+mkLHsVarTuple :: [a] -> LHsExpr a
+mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
+
+nlTuplePat :: [LPat id] -> Boxity -> LPat id
+nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
+
+missingTupArg :: HsTupArg a
+missingTupArg = Missing placeHolderType
+\end{code}

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -232,42 +381,34 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc
                            fun_tick = Nothing }
 
 
                            fun_tick = Nothing }
 
 

-mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
+mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+
+mkVarBind :: id -> LHsExpr id -> LHsBind id
+mkVarBind var rhs = L (getLoc rhs) $
+                   VarBind { var_id = var, var_rhs = rhs, var_inline = False }

 
 ------------
 
 ------------

-mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-               -> LHsExpr RdrName -> LHsBind RdrName
+mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
+               -> LHsExpr id -> LHsBind id

 
 mk_easy_FunBind loc fun pats expr
   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 
 ------------
 
 mk_easy_FunBind loc fun pats expr
   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 
 ------------

-mk_FunBind :: SrcSpan -> RdrName
-          -> [([LPat RdrName], LHsExpr RdrName)]
-          -> LHsBind RdrName
-
-mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
-mk_FunBind loc fun pats_and_exprs
-  = L loc $ mkFunBind (L loc fun) matches
-  where
-    matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
-
-------------

 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 mkMatch pats expr binds
   = noLoc (Match (map paren pats) Nothing 
                 (GRHSs (unguardedRHS expr) binds))
   where
 mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 mkMatch pats expr binds
   = noLoc (Match (map paren pats) Nothing 
                 (GRHSs (unguardedRHS expr) binds))
   where

-    paren p = case p of
-               L _ (VarPat _) -> p
-               L l _          -> L l (ParPat p)
+    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) 
+                    | otherwise          = lp

 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *

-       Collecting binders from HsBindGroups and HsBinds
+       Collecting binders

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

@@ -281,122 +422,118 @@ where
 
 it should return [x, y, f, a, b] (remember, order important).
 
 
 it should return [x, y, f, a, b] (remember, order important).
 

+Note [Collect binders only after renaming]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+These functions should only be used on HsSyn *after* the renamer,
+to return a [Name] or [Id].  Before renaming the record punning
+and wild-card mechanism makes it hard to know what is bound.
+So these functions should not be applied to (HsSyn RdrName)
+

 \begin{code}
 \begin{code}

-collectLocalBinders :: HsLocalBinds name -> [Located name]
+----------------- Bindings --------------------------
+collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]

 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 collectLocalBinders (HsIPBinds _)   = []
 collectLocalBinders EmptyLocalBinds = []
 
 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 collectLocalBinders (HsIPBinds _)   = []
 collectLocalBinders EmptyLocalBinds = []
 

-collectHsValBinders :: HsValBinds name -> [Located name]
-collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
-collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
+collectHsValBinders :: HsValBindsLR idL idR -> [idL]
+collectHsValBinders (ValBindsIn  binds _) = collectHsBindsBinders binds
+collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds

   where
   where

-   collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
-
-collectAcc :: HsBind name -> [Located name] -> [Located name]
-collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
-collectAcc (FunBind { fun_id = f })  acc    = f : acc
-collectAcc (VarBind { var_id = f })  acc    = noLoc f : acc
-collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
-  = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
-       -- ++ foldr collectAcc acc binds
+   collect_one (_,binds) acc = collect_binds binds acc
+
+collectHsBindBinders :: HsBindLR idL idR -> [idL]
+collectHsBindBinders b = collect_bind b []
+
+collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
+collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
+collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
+collect_bind (VarBind { var_id = f })     acc = f : acc
+collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
+  = [dp | (_,dp,_,_) <- dbinds] ++ acc 
+       -- ++ foldr collect_bind acc binds

        -- I don't think we want the binders from the nested binds
        -- The only time we collect binders from a typechecked 
        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 
        -- I don't think we want the binders from the nested binds
        -- The only time we collect binders from a typechecked 
        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 

-collectHsBindBinders :: LHsBinds name -> [name]
-collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
+collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
+collectHsBindsBinders binds = collect_binds binds []

 
 

-collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
-collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
-\end{code}
+collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
+collectHsBindListBinders = foldr (collect_bind . unLoc) []

 
 

+collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
+collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds

 
 

-%************************************************************************
-%*                                                                     *
-       Getting binders from statements
-%*                                                                     *
-%************************************************************************
+collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
+-- Used exclusively for the bindings of an instance decl which are all FunBinds
+collectMethodBinders binds = foldrBag get [] binds
+  where
+    get (L _ (FunBind { fun_id = f })) fs = f : fs
+    get _                              fs = fs 
+       -- Someone else complains about non-FunBinds

 
 

-\begin{code}
-collectLStmtsBinders :: [LStmt id] -> [Located id]
+----------------- Statements --------------------------
+collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]

 collectLStmtsBinders = concatMap collectLStmtBinders
 
 collectLStmtsBinders = concatMap collectLStmtBinders
 

-collectStmtsBinders :: [Stmt id] -> [Located id]
+collectStmtsBinders :: [StmtLR idL idR] -> [idL]

 collectStmtsBinders = concatMap collectStmtBinders
 
 collectStmtsBinders = concatMap collectStmtBinders
 

-collectLStmtBinders :: LStmt id -> [Located id]
+collectLStmtBinders :: LStmtLR idL idR -> [idL]

 collectLStmtBinders = collectStmtBinders . unLoc
 
 collectLStmtBinders = collectStmtBinders . unLoc
 

-collectStmtBinders :: Stmt id -> [Located id]
+collectStmtBinders :: StmtLR idL idR -> [idL]

   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?

-collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
+collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat

 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds

-collectStmtBinders (ExprStmt _ _ _)    = []
-collectStmtBinders (RecStmt ss _ _ _ _)        = collectLStmtsBinders ss
-collectStmtBinders other               = panic "collectStmtBinders"
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-%*     Gathering stuff out of patterns
-%*                                                                     *
-%************************************************************************
-
-This function @collectPatBinders@ works with the ``collectBinders''
-functions for @HsBinds@, etc.  The order in which the binders are
-collected is important; see @HsBinds.lhs@.
+collectStmtBinders (ExprStmt _ _ _)     = []
+collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
+                                        $ concatMap fst xs
+collectStmtBinders (TransformStmt stmts _ _ _)   = collectLStmtsBinders stmts
+collectStmtBinders (GroupStmt     stmts _ _ _)   = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss

 
 

-It collects the bounds *value* variables in renamed patterns; type variables
-are *not* collected.

 
 

-\begin{code}
+----------------- Patterns --------------------------

 collectPatBinders :: LPat a -> [a]
 collectPatBinders :: LPat a -> [a]

-collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
-
-collectLocatedPatBinders :: LPat a -> [Located a]
-collectLocatedPatBinders pat = collectl pat []
+collectPatBinders pat = collect_lpat pat []

 
 collectPatsBinders :: [LPat a] -> [a]
 
 collectPatsBinders :: [LPat a] -> [a]

-collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
+collectPatsBinders pats = foldr collect_lpat [] pats

 
 

-collectLocatedPatsBinders :: [LPat a] -> [Located a]
-collectLocatedPatsBinders pats = foldr collectl [] pats
-
----------------------
-collectl (L l pat) bndrs
+-------------
+collect_lpat :: LPat name -> [name] -> [name]
+collect_lpat (L _ pat) bndrs

   = go pat
   where
   = go pat
   where

-    go (VarPat var)              = L l var : bndrs
-    go (VarPatOut var bs)        = L l var : collectHsBindLocatedBinders bs 
-                                   ++ bndrs
+    go (VarPat var)              = var : bndrs

     go (WildPat _)               = bndrs
     go (WildPat _)               = bndrs

-    go (LazyPat pat)             = collectl pat bndrs
-    go (BangPat pat)             = collectl pat bndrs
-    go (AsPat a pat)             = a : collectl pat bndrs
-    go (ParPat  pat)             = collectl pat bndrs
+    go (LazyPat pat)             = collect_lpat pat bndrs
+    go (BangPat pat)             = collect_lpat pat bndrs
+    go (AsPat (L _ a) pat)               = a : collect_lpat pat bndrs
+    go (ViewPat _ pat _)          = collect_lpat pat bndrs
+    go (ParPat  pat)             = collect_lpat pat bndrs

                                  
                                  

-    go (ListPat pats _)          = foldr collectl bndrs pats
-    go (PArrPat pats _)          = foldr collectl bndrs pats
-    go (TuplePat pats _ _)       = foldr collectl bndrs pats
+    go (ListPat pats _)          = foldr collect_lpat bndrs pats
+    go (PArrPat pats _)          = foldr collect_lpat bndrs pats
+    go (TuplePat pats _ _)       = foldr collect_lpat bndrs pats

                                  
                                  

-    go (ConPatIn c ps)           = foldr collectl bndrs (hsConArgs ps)
-    go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConArgs ps)
+    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
+    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)

        -- See Note [Dictionary binders in ConPatOut]
     go (LitPat _)                = bndrs
        -- See Note [Dictionary binders in ConPatOut]
     go (LitPat _)                = bndrs

-    go (NPat _ _ _ _)            = bndrs
-    go (NPlusKPat n _ _ _)        = n : bndrs
+    go (NPat _ _ _)              = bndrs
+    go (NPlusKPat (L _ n) _ _ _)  = n : bndrs

                                  
                                  

-    go (SigPatIn pat _)                  = collectl pat bndrs
-    go (SigPatOut pat _)         = collectl pat bndrs
-    go (TypePat ty)               = bndrs
-    go (DictPat ids1 ids2)        = map noLoc ids1 ++ map noLoc ids2
-                                   ++ bndrs
-    go (CoPat _ pat ty)           = collectl (noLoc pat) bndrs
+    go (SigPatIn pat _)                  = collect_lpat pat bndrs
+    go (SigPatOut pat _)         = collect_lpat pat bndrs
+    go (QuasiQuotePat _)          = bndrs
+    go (TypePat _)                = bndrs
+    go (CoPat _ pat _)            = go pat

 \end{code}
 
 \end{code}
 

-Note [Dictionary binders in ConPatOut]
+Note [Dictionary binders in ConPatOut] See also same Note in DsArrows

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
 of a ConPatOut pattern.  For most calls it doesn't matter, because
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Do *not* gather (a) dictionary and (b) dictionary bindings as binders
 of a ConPatOut pattern.  For most calls it doesn't matter, because

@@ -406,25 +543,102 @@ collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 we want to generate bindings for x,y but not for dictionaries bound by
 C.  (The type checker ensures they would not be used.)
 
 we want to generate bindings for x,y but not for dictionaries bound by
 C.  (The type checker ensures they would not be used.)
 

+Desugaring of arrow case expressions needs these bindings (see DsArrows
+and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
+own pat-binder-collector:
+
+Here's the problem.  Consider
+
+data T a where
+   C :: Num a => a -> Int -> T a
+
+f ~(C (n+1) m) = (n,m)
+
+Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
+and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
+variables bound by the lazy pattern are n,m, *not* the dictionary d.
+So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
+
+\begin{code}
+hsGroupBinders :: HsGroup Name -> [Name]
+hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
+                          hs_instds = inst_decls, hs_fords = foreign_decls })
+-- Collect the binders of a Group
+  =  collectHsValBinders val_decls
+  ++ hsTyClDeclsBinders tycl_decls inst_decls
+  ++ hsForeignDeclsBinders foreign_decls
+
+hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
+hsForeignDeclsBinders foreign_decls
+  = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
+
+hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
+hsTyClDeclsBinders tycl_decls inst_decls
+  = [n | d <- instDeclATs inst_decls ++ concat tycl_decls
+       , L _ n <- hsTyClDeclBinders d]
+
+hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
+-- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
+-- The first one is guaranteed to be the name of the decl. For record fields
+-- mentioned in multiple constructors, the SrcLoc will be from the first
+-- occurence.  We use the equality to filter out duplicate field names
+
+hsTyClDeclBinders (L _ (TyFamily    {tcdLName = name})) = [name]
+hsTyClDeclBinders (L _ (TySynonym   {tcdLName = name})) = [name]
+hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
+
+hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
+  = cls_name : 
+    concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs]
+
+hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons}))
+  = tc_name : hsConDeclsBinders cons
+
+hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
+  -- See hsTyClDeclBinders for what this does
+  -- The function is boringly complicated because of the records
+  -- And since we only have equality, we have to be a little careful
+hsConDeclsBinders cons
+  = snd (foldl do_one ([], []) cons)
+  where
+    do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
+       = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
+       where
+         new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
+                              (map cd_fld_name flds)
+
+    do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
+       = (flds_seen, lname:acc)
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+       Collecting type signatures from patterns
+%*                                                                     *
+%************************************************************************
+

 \begin{code}
 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 \begin{code}
 collectSigTysFromPats :: [InPat name] -> [LHsType name]

-collectSigTysFromPats pats = foldr collect_lpat [] pats
+collectSigTysFromPats pats = foldr collect_sig_lpat [] pats

 
 collectSigTysFromPat :: InPat name -> [LHsType name]
 
 collectSigTysFromPat :: InPat name -> [LHsType name]

-collectSigTysFromPat pat = collect_lpat pat []
-
-collect_lpat pat acc = collect_pat (unLoc pat) acc
-
-collect_pat (SigPatIn pat ty)          acc = collect_lpat pat (ty:acc)
-collect_pat (TypePat ty)               acc = ty:acc
-
-collect_pat (LazyPat pat)              acc = collect_lpat pat acc
-collect_pat (BangPat pat)              acc = collect_lpat pat acc
-collect_pat (AsPat a pat)              acc = collect_lpat pat acc
-collect_pat (ParPat  pat)              acc = collect_lpat pat acc
-collect_pat (ListPat pats _)           acc = foldr collect_lpat acc pats
-collect_pat (PArrPat pats _)           acc = foldr collect_lpat acc pats
-collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
-collect_pat (ConPatIn c ps)     acc = foldr collect_lpat acc (hsConArgs ps)
-collect_pat other              acc = acc       -- Literals, vars, wildcard
+collectSigTysFromPat pat = collect_sig_lpat pat []
+
+collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name]
+collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc
+
+collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
+collect_sig_pat (SigPatIn pat ty)      acc = collect_sig_lpat pat (ty:acc)
+collect_sig_pat (TypePat ty)           acc = ty:acc
+
+collect_sig_pat (LazyPat pat)       acc = collect_sig_lpat pat acc
+collect_sig_pat (BangPat pat)       acc = collect_sig_lpat pat acc
+collect_sig_pat (AsPat _ pat)       acc = collect_sig_lpat pat acc
+collect_sig_pat (ParPat  pat)       acc = collect_sig_lpat pat acc
+collect_sig_pat (ListPat pats _)    acc = foldr collect_sig_lpat acc pats
+collect_sig_pat (PArrPat pats _)    acc = foldr collect_sig_lpat acc pats
+collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats
+collect_sig_pat (ConPatIn _ ps)     acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
+collect_sig_pat _                   acc = acc       -- Literals, vars, wildcard

 \end{code}
 \end{code}