New syntax for GADT-style record declarations, and associated refactoring

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

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index bd1fc21..db9460e 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -15,8 +15,6 @@ which deal with the intantiated versions are located elsewhere:
 \begin{code}
 module HsUtils where
 
 \begin{code}
 module HsUtils where
 

-#include "HsVersions.h"
-

 import HsBinds
 import HsExpr
 import HsPat
 import HsBinds
 import HsExpr
 import HsPat

@@ -25,6 +23,7 @@ import HsLit
 
 import RdrName
 import Var
 
 import RdrName
 import Var

+import Coercion

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

@@ -80,7 +79,15 @@ 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
+
+coiToHsWrapper :: CoercionI -> HsWrapper
+coiToHsWrapper IdCo     = idHsWrapper
+coiToHsWrapper (ACo co) = WpCast co

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

@@ -100,7 +107,7 @@ mkHsDictLet binds expr
                            val_binds = ValBindsOut [(Recursive, binds)] []
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
                            val_binds = ValBindsOut [(Recursive, binds)] []
 
 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

@@ -115,14 +122,45 @@ 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
-mkHsIsString   s       = HsIsString   s  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
+
+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
+
+mkExprStmt :: LHsExpr idR -> StmtLR idL idR
+mkBindStmt :: LPat idL -> LHsExpr idR -> 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
+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   stmts usingExpr        = GroupStmt (stmts, []) (GroupByNothing usingExpr)
+mkGroupByStmt      stmts byExpr           = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr)
+mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr)
+

 mkExprStmt expr            = ExprStmt expr noSyntaxExpr placeHolderType
 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 mkRecStmt stmts            = RecStmt stmts [] [] [] emptyLHsBinds
 mkExprStmt expr            = ExprStmt expr noSyntaxExpr placeHolderType
 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 mkRecStmt stmts            = RecStmt stmts [] [] [] emptyLHsBinds

@@ -130,14 +168,26 @@ mkRecStmt stmts       = RecStmt stmts [] [] [] emptyLHsBinds
 -------------------------------
 --- 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"))
+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 unqualQuasiQuote 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)
 
 -------------
 mkHsString s = HsString (mkFastString s)
 
 -------------

@@ -168,6 +218,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,14 +245,25 @@ 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 :: [LPat id] -> Boxity -> LPat id

 nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
 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
+nlTuple  :: [LHsExpr id] -> Boxity -> LHsExpr id
+nlList   :: [LHsExpr id] -> LHsExpr id
+

 nlHsLam        match           = noLoc (HsLam (mkMatchGroup [match]))
 nlHsPar e              = noLoc (HsPar e)
 nlHsIf cond true false = noLoc (HsIf cond true false)
 nlHsLam        match           = noLoc (HsLam (mkMatchGroup [match]))
 nlHsPar e              = noLoc (HsPar e)
 nlHsIf cond true false = noLoc (HsIf cond true false)

@@ -209,10 +271,15 @@ nlHsCase expr matches     = noLoc (HsCase expr (mkMatchGroup matches))
 nlTuple exprs box      = noLoc (ExplicitTuple exprs box)
 nlList exprs           = noLoc (ExplicitList placeHolderType exprs)
 
 nlTuple exprs box      = noLoc (ExplicitTuple exprs box)
 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}
 

@@ -232,22 +299,22 @@ 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 :: SrcSpan -> id -> LHsExpr id -> LHsBind id

 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 ------------
 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 ------------

-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 :: SrcSpan -> id
+          -> [([LPat id], LHsExpr id)]
+          -> LHsBind id

 
 

-mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
+mk_FunBind _   _   [] = panic "TcGenDeriv:mk_FunBind"

 mk_FunBind loc fun pats_and_exprs
   = L loc $ mkFunBind (L loc fun) matches
   where
 mk_FunBind loc fun pats_and_exprs
   = L loc $ mkFunBind (L loc fun) matches
   where

@@ -282,32 +349,32 @@ where
 it should return [x, y, f, a, b] (remember, order important).
 
 \begin{code}
 it should return [x, y, f, a, b] (remember, order important).
 
 \begin{code}

-collectLocalBinders :: HsLocalBinds name -> [Located name]
+collectLocalBinders :: HsLocalBindsLR idL idR -> [Located 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 -> [Located idL]
+collectHsValBinders (ValBindsIn  binds _) = collectHsBindLocatedBinders binds
+collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds

   where
    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 
   where
    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 

-collectAcc :: HsBind name -> [Located name] -> [Located name]
+collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL]

 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 (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
+collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc

   = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
        -- ++ foldr collectAcc 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
 
   = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
        -- ++ foldr collectAcc 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
 

-collectHsBindBinders :: LHsBinds name -> [name]
+collectHsBindBinders :: LHsBindsLR idL idR -> [idL]

 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 
 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 

-collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
+collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL]

 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 \end{code}
 
 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 \end{code}
 

@@ -319,24 +386,25 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id]
+collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL]

 collectLStmtsBinders = concatMap collectLStmtBinders
 
 collectLStmtsBinders = concatMap collectLStmtBinders
 

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

 collectStmtsBinders = concatMap collectStmtBinders
 
 collectStmtsBinders = concatMap collectStmtBinders
 

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

 collectLStmtBinders = collectStmtBinders . unLoc
 
 collectLStmtBinders = collectStmtBinders . unLoc
 

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

   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 collectStmtBinders (ExprStmt _ _ _)     = []
 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
                                         $ concatMap fst xs
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 collectStmtBinders (ExprStmt _ _ _)     = []
 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
                                         $ concatMap fst xs

+collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
+collectStmtBinders (GroupStmt (stmts, _) _)     = collectLStmtsBinders stmts

 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss

-collectStmtBinders s                    = pprPanic "collectStmtBinders" (ppr s)

 \end{code}
 
 
 \end{code}
 
 

@@ -367,6 +435,7 @@ collectLocatedPatsBinders :: [LPat a] -> [Located a]
 collectLocatedPatsBinders pats = foldr collectl [] pats
 
 ---------------------
 collectLocatedPatsBinders pats = foldr collectl [] pats
 
 ---------------------

+collectl :: LPat name -> [Located name] -> [Located name]

 collectl (L l pat) bndrs
   = go pat
   where
 collectl (L l pat) bndrs
   = go pat
   where

@@ -377,25 +446,25 @@ collectl (L l pat) bndrs
     go (LazyPat pat)             = collectl pat bndrs
     go (BangPat pat)             = collectl pat bndrs
     go (AsPat a pat)             = a : collectl pat bndrs
     go (LazyPat pat)             = collectl pat bndrs
     go (BangPat pat)             = collectl pat bndrs
     go (AsPat a pat)             = a : collectl pat bndrs

+    go (ViewPat _ pat _)          = collectl pat bndrs

     go (ParPat  pat)             = collectl pat bndrs
                                  
     go (ListPat pats _)          = foldr collectl bndrs pats
     go (PArrPat pats _)          = foldr collectl bndrs pats
     go (TuplePat pats _ _)       = foldr collectl bndrs pats
                                  
     go (ParPat  pat)             = collectl pat bndrs
                                  
     go (ListPat pats _)          = foldr collectl bndrs pats
     go (PArrPat pats _)          = foldr collectl bndrs pats
     go (TuplePat pats _ _)       = foldr collectl 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 collectl bndrs (hsConPatArgs ps)
+    go (ConPatOut {pat_args=ps})  = foldr collectl 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 (NPat _ _ _)              = bndrs

     go (NPlusKPat n _ _ _)        = n : bndrs
                                  
     go (SigPatIn pat _)                  = collectl pat bndrs
     go (SigPatOut pat _)         = collectl pat bndrs
     go (NPlusKPat 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 (QuasiQuotePat _)          = bndrs
+    go (TypePat _)                = bndrs
+    go (CoPat _ pat _)            = collectl (noLoc pat) bndrs

 \end{code}
 
 Note [Dictionary binders in ConPatOut]
 \end{code}
 
 Note [Dictionary binders in ConPatOut]

@@ -408,6 +477,22 @@ 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}
 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 collectSigTysFromPats pats = foldr collect_lpat [] pats
 \begin{code}
 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 collectSigTysFromPats pats = foldr collect_lpat [] pats

@@ -415,18 +500,20 @@ collectSigTysFromPats pats = foldr collect_lpat [] pats
 collectSigTysFromPat :: InPat name -> [LHsType name]
 collectSigTysFromPat pat = collect_lpat pat []
 
 collectSigTysFromPat :: InPat name -> [LHsType name]
 collectSigTysFromPat pat = collect_lpat pat []
 

+collect_lpat :: InPat name -> [LHsType name] -> [LHsType name]

 collect_lpat pat acc = collect_pat (unLoc pat) acc
 
 collect_lpat pat acc = collect_pat (unLoc pat) acc
 

+collect_pat :: Pat name -> [LHsType name] -> [LHsType name]

 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 (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 (AsPat _ 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 (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
+collect_pat (ConPatIn _ ps)     acc = foldr collect_lpat acc (hsConPatArgs ps)
+collect_pat _                   acc = acc       -- Literals, vars, wildcard

 \end{code}
 \end{code}