[project @ 2005-08-10 11:05:06 by simonpj]

It turned out that doing all binding dependency analysis in the typechecker
meant that the renamer's unused-binding error messages got worse.  So now
I've put the first dep anal back into the renamer, while the second (which
is specific to type checking) remains in the type checker.

I've also made the pretty printer sort the decls back into source order
before printing them (except with -dppr-debug).

Fixes rn041.

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 2e21538..75d46a1 100644 (file)
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -83,7 +83,7 @@ dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
 
 -------------------------
 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
 
 -------------------------
 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr

-dsValBinds (ValBindsOut binds) body = foldrDs ds_val_bind body binds
+dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds

 
 -------------------------
 dsIPBinds (IPBinds ip_binds dict_binds) body
 
 -------------------------
 dsIPBinds (IPBinds ip_binds dict_binds) body

@@ -680,7 +680,7 @@ dsMDo tbl stmts body result_ty
        go (new_bind_stmt : let_stmt : stmts)
       where
         new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
        go (new_bind_stmt : let_stmt : stmts)
       where
         new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app

-       let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)]))
+       let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))

 
        
                -- Remove the later_ids that appear (without fancy coercions) 
 
        
                -- Remove the later_ids that appear (without fancy coercions) 

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 0646b23..15f25f2 100644 (file)
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -20,9 +20,10 @@ import Name          ( Name )
 import NameSet         ( NameSet, elemNameSet )
 import BasicTypes      ( IPName, RecFlag(..), Activation(..), Fixity )
 import Outputable      
 import NameSet         ( NameSet, elemNameSet )
 import BasicTypes      ( IPName, RecFlag(..), Activation(..), Fixity )
 import Outputable      

-import SrcLoc          ( Located(..), unLoc )
+import SrcLoc          ( Located(..), SrcSpan, unLoc )
+import Util            ( sortLe )

 import Var             ( TyVar, DictId, Id )
 import Var             ( TyVar, DictId, Id )

-import Bag             ( Bag, emptyBag, isEmptyBag, bagToList, unionBags )
+import Bag             ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )

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

@@ -45,9 +46,9 @@ data HsValBinds id    -- Value bindings (not implicit parameters)
        (LHsBinds id) [LSig id]         -- Not dependency analysed
                                        -- Recursive by default
 
        (LHsBinds id) [LSig id]         -- Not dependency analysed
                                        -- Recursive by default
 

-  | ValBindsOut                                -- After typechecking
+  | ValBindsOut                                -- After renaming

        [(RecFlag, LHsBinds id)]        -- Dependency analysed
        [(RecFlag, LHsBinds id)]        -- Dependency analysed

-
+       [LSig Name]

 
 type LHsBinds id  = Bag (LHsBind id)
 type DictBinds id = LHsBinds id                -- Used for dictionary or method bindings
 
 type LHsBinds id  = Bag (LHsBind id)
 type DictBinds id = LHsBinds id                -- Used for dictionary or method bindings

@@ -115,17 +116,32 @@ instance OutputableBndr id => Outputable (HsLocalBinds id) where
 
 instance OutputableBndr id => Outputable (HsValBinds id) where
   ppr (ValBindsIn binds sigs)
 
 instance OutputableBndr id => Outputable (HsValBinds id) where
   ppr (ValBindsIn binds sigs)

-   = vcat [vcat (map ppr sigs),
-          vcat (map ppr (bagToList binds))
-               --  *not* pprLHsBinds because we don't want braces; 'let' and
-               -- 'where' include a list of HsBindGroups and we don't want
-               -- several groups of bindings each with braces around.
-       ]
-  ppr (ValBindsOut sccs) = vcat (map ppr_scc sccs)
-     where
-       ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
-       pp_rec Recursive    = ptext SLIT("rec")
-       pp_rec NonRecursive = ptext SLIT("nonrec")
+   = pprValBindsForUser binds sigs
+
+  ppr (ValBindsOut sccs sigs) 
+    = getPprStyle $ \ sty ->
+      if debugStyle sty then   -- Print with sccs showing
+       vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
+     else
+       pprValBindsForUser (unionManyBags (map snd sccs)) sigs
+   where
+     ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
+     pp_rec Recursive    = ptext SLIT("rec")
+     pp_rec NonRecursive = ptext SLIT("nonrec")
+
+--  *not* pprLHsBinds because we don't want braces; 'let' and
+-- 'where' include a list of HsBindGroups and we don't want
+-- several groups of bindings each with braces around.
+-- Sort by location before printing
+pprValBindsForUser binds sigs
+  = vcat (map snd (sort_by_loc decls))
+  where
+
+    decls :: [(SrcSpan, SDoc)]
+    decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
+           [(loc, ppr bind) | L loc bind <- bagToList binds]
+
+    sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls

 
 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
 pprLHsBinds binds 
 
 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
 pprLHsBinds binds 

@@ -142,12 +158,12 @@ isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 isEmptyLocalBinds EmptyLocalBinds = True
 
 isEmptyValBinds :: HsValBinds a -> Bool
 isEmptyLocalBinds EmptyLocalBinds = True
 
 isEmptyValBinds :: HsValBinds a -> Bool

-isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
-isEmptyValBinds (ValBindsOut ds)     = null ds
+isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
+isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs

 
 emptyValBindsIn, emptyValBindsOut :: HsValBinds a
 emptyValBindsIn  = ValBindsIn emptyBag []
 
 emptyValBindsIn, emptyValBindsOut :: HsValBinds a
 emptyValBindsIn  = ValBindsIn emptyBag []

-emptyValBindsOut = ValBindsOut []
+emptyValBindsOut = ValBindsOut []      []

 
 emptyLHsBinds :: LHsBinds id
 emptyLHsBinds = emptyBag
 
 emptyLHsBinds :: LHsBinds id
 emptyLHsBinds = emptyBag

@@ -159,8 +175,8 @@ isEmptyLHsBinds = isEmptyBag
 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)

-plusHsValBinds (ValBindsOut ds1) (ValBindsOut ds2)
-  = ValBindsOut (ds1 ++ ds2)
+plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
+  = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)

 \end{code}
 
 What AbsBinds means
 \end{code}
 
 What AbsBinds means

diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs
index 2e33d4e..ec6ca99 100644 (file)
--- a/ghc/compiler/hsSyn/HsUtils.lhs
+++ b/ghc/compiler/hsSyn/HsUtils.lhs
@@ -100,7 +100,7 @@ mkHsDictLet binds expr
   | isEmptyLHsBinds binds = expr
   | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
                          where
   | isEmptyLHsBinds binds = expr
   | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
                          where

-                           val_binds = ValBindsOut [(Recursive, binds)]
+                           val_binds = ValBindsOut [(Recursive, binds)] []

 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictinoary terms etc, so no locations 
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictinoary terms etc, so no locations 

@@ -279,8 +279,8 @@ collectLocalBinders (HsIPBinds _)   = []
 collectLocalBinders EmptyLocalBinds = []
 
 collectHsValBinders :: HsValBinds name -> [Located name]
 collectLocalBinders EmptyLocalBinds = []
 
 collectHsValBinders :: HsValBinds name -> [Located name]

-collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
-collectHsValBinders (ValBindsOut binds)     = foldr collect_one [] binds
+collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
+collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds

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

@@ -312,8 +312,8 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 Get all the pattern type signatures out of a bunch of bindings
 
 \begin{code}
 Get all the pattern type signatures out of a bunch of bindings
 
 \begin{code}

-collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
-collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
+collectSigTysFromHsBinds :: LHsBinds name -> [LHsType name]
+collectSigTysFromHsBinds binds = concatMap collectSigTysFromHsBind (bagToList binds)

 
 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
 collectSigTysFromHsBind bind
 
 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
 collectSigTysFromHsBind bind

diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 7fa9611..1b46454 100644 (file)
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -21,7 +21,6 @@ module RnBinds (
 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
 
 import HsSyn
 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
 
 import HsSyn

-import HsBinds         ( hsSigDoc, eqHsSig )

 import RdrHsSyn
 import RnHsSyn
 import TcRnMonad
 import RdrHsSyn
 import RnHsSyn
 import TcRnMonad

@@ -41,9 +40,11 @@ import PrelNames     ( isUnboundName )
 import RdrName         ( RdrName, rdrNameOcc )
 import SrcLoc          ( mkSrcSpan, Located(..), unLoc )
 import ListSetOps      ( findDupsEq )
 import RdrName         ( RdrName, rdrNameOcc )
 import SrcLoc          ( mkSrcSpan, Located(..), unLoc )
 import ListSetOps      ( findDupsEq )

+import BasicTypes      ( RecFlag(..) )
+import Digraph         ( SCC(..), stronglyConnComp )

 import Bag
 import Outputable
 import Bag
 import Outputable

-import Maybes          ( orElse )
+import Maybes          ( orElse, fromJust, isJust )

 import Monad           ( foldM )
 \end{code}
 
 import Monad           ( foldM )
 \end{code}
 

@@ -177,7 +178,7 @@ rnTopBindsBoot (ValBindsIn mbinds sigs)
 
 rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses)
 rnTopBindsSrc binds@(ValBindsIn mbinds _)
 
 rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses)
 rnTopBindsSrc binds@(ValBindsIn mbinds _)

-  = bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ -> 
+  = bindPatSigTyVars (collectSigTysFromHsBinds mbinds) $ \ _ -> 

        -- Hmm; by analogy with Ids, this doesn't look right
        -- Top-level bound type vars should really scope over 
        -- everything, but we only scope them over the other bindings
        -- Hmm; by analogy with Ids, this doesn't look right
        -- Top-level bound type vars should really scope over 
        -- everything, but we only scope them over the other bindings

@@ -185,7 +186,7 @@ rnTopBindsSrc binds@(ValBindsIn mbinds _)
     do { (binds', dus) <- rnValBinds noTrim binds
 
                -- Warn about missing signatures, 
     do { (binds', dus) <- rnValBinds noTrim binds
 
                -- Warn about missing signatures, 

-       ; let   { ValBindsIn _ sigs' = binds'
+       ; let   { ValBindsOut _ sigs' = binds'

                ; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs']
                ; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars }
 
                ; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs']
                ; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars }
 

@@ -253,7 +254,7 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside
        -- current scope, inventing new names for the new binders
        -- This also checks that the names form a set
     bindLocatedLocalsRn doc mbinders_w_srclocs                 $ \ bndrs ->
        -- current scope, inventing new names for the new binders
        -- This also checks that the names form a set
     bindLocatedLocalsRn doc mbinders_w_srclocs                 $ \ bndrs ->

-    bindPatSigTyVarsFV (collectSigTysFromHsBinds (bagToList mbinds))   $ 
+    bindPatSigTyVarsFV (collectSigTysFromHsBinds mbinds)       $ 

 
        -- Then install local fixity declarations
        -- Notice that they scope over thing_inside too
 
        -- Then install local fixity declarations
        -- Notice that they scope over thing_inside too

@@ -267,12 +268,7 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside
 
        -- Final error checking
     let
 
        -- Final error checking
     let

-       all_uses     = duUses bind_dus `plusFV` result_fvs
-       unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)]
-    in
-    warnUnusedLocalBinds unused_bndrs  `thenM_`
-
-    returnM (result, delListFromNameSet all_uses bndrs)
+       all_uses = duUses bind_dus `plusFV` result_fvs

        -- duUses: It's important to return all the uses, not the 'real uses' 
        -- used for warning about unused bindings.  Otherwise consider:
        --      x = 3
        -- duUses: It's important to return all the uses, not the 'real uses' 
        -- used for warning about unused bindings.  Otherwise consider:
        --      x = 3

@@ -280,6 +276,12 @@ rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside
        -- If we don't "see" the dependency of 'y' on 'x', we may put the
        -- bindings in the wrong order, and the type checker will complain
        -- that x isn't in scope
        -- If we don't "see" the dependency of 'y' on 'x', we may put the
        -- bindings in the wrong order, and the type checker will complain
        -- that x isn't in scope

+
+       unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)]
+    in
+    warnUnusedLocalBinds unused_bndrs  `thenM_`
+
+    returnM (result, delListFromNameSet all_uses bndrs)

   where
     mbinders_w_srclocs = collectHsBindLocatedBinders mbinds
     doc = text "In the binding group for:"
   where
     mbinders_w_srclocs = collectHsBindLocatedBinders mbinds
     doc = text "In the binding group for:"

@@ -294,21 +296,46 @@ rnValBinds :: (FreeVars -> FreeVars)
 rnValBinds trim (ValBindsIn mbinds sigs)
   = do { sigs' <- rename_sigs sigs
 
 rnValBinds trim (ValBindsIn mbinds sigs)
   = do { sigs' <- rename_sigs sigs
 

-       ; let { rn_bind = wrapLocFstM (rnBind sig_fn trim) 
-             ; sig_fn = mkSigTvFn sigs' }
+       ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds

 
 

-       ; (mbinds', du_bag) <- mapAndUnzipBagM rn_bind mbinds
+       ; let (binds', bind_dus) = depAnalBinds binds_w_dus

 
 

-       ; let defs, uses :: NameSet
-             (defs, uses) = foldrBag plus (emptyNameSet, emptyNameSet) du_bag
-             plus (ds1,us1) (ds2,us2) = (ds1 `unionNameSets` ds2, 
-                                         us1 `unionNameSets` us2)
+       ; check_sigs (okBindSig (duDefs bind_dus)) sigs'

 
 

-       ; check_sigs (okBindSig defs) sigs'
+       ; return (ValBindsOut binds' sigs', 
+                 usesOnly (hsSigsFVs sigs') `plusDU` bind_dus) }
+
+
+---------------------
+depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
+            -> ([(RecFlag, LHsBinds Name)], DefUses)
+-- Dependency analysis; this is important so that unused-binding
+-- reporting is accurate
+depAnalBinds binds_w_dus
+  = (map get_binds sccs, map get_du sccs)
+  where
+    sccs = stronglyConnComp edges
+
+    keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..]
+
+    edges = [ (node, key, [fromJust mb_key | n <- nameSetToList uses,
+                          let mb_key = lookupNameEnv key_map n,
+                          isJust mb_key ])
+           | (node@(_,_,uses), key) <- keyd_nodes ]
+
+    key_map :: NameEnv Int     -- Which binding it comes from
+    key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes
+                                    , bndr <- bndrs ]
+
+    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
+    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,d,u) <- binds_w_dus])
+
+    get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
+    get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)
+       where
+         defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
+         uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus]

 
 

-       ; traceRn (text "rnValBind" <+> (ppr defs $$ ppr uses))
-       ; return (ValBindsIn mbinds' sigs', 
-                 [(Just defs, uses `plusFV` hsSigsFVs sigs')]) }

 
 ---------------------
 -- Bind the top-level forall'd type variables in the sigs.
 
 ---------------------
 -- Bind the top-level forall'd type variables in the sigs.

@@ -348,31 +375,30 @@ trimWith bndrs = intersectNameSet (mkNameSet bndrs)
 ---------------------
 rnBind :: (Name -> [Name])             -- Signature tyvar function
        -> (FreeVars -> FreeVars)       -- Trimming function for rhs free vars
 ---------------------
 rnBind :: (Name -> [Name])             -- Signature tyvar function
        -> (FreeVars -> FreeVars)       -- Trimming function for rhs free vars

-       -> HsBind RdrName
-       -> RnM (HsBind Name, (Defs, Uses))
-rnBind sig_fn trim (PatBind pat grhss ty _)
-  = do { (pat', pat_fvs) <- rnLPat pat
+       -> LHsBind RdrName
+       -> RnM (LHsBind Name, [Name], Uses)
+rnBind sig_fn trim (L loc (PatBind pat grhss ty _))
+  = setSrcSpan loc $ 
+    do { (pat', pat_fvs) <- rnLPat pat

 
        ; let bndrs = collectPatBinders pat'
 
        ; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $
                           rnGRHSs PatBindRhs grhss
 
 
        ; let bndrs = collectPatBinders pat'
 
        ; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $
                           rnGRHSs PatBindRhs grhss
 

-       ; return (PatBind pat' grhss' ty (trim fvs),
-                 (mkNameSet bndrs, pat_fvs `plusFV` fvs)) }
+       ; return (L loc (PatBind pat' grhss' ty (trim fvs)), bndrs, pat_fvs `plusFV` fvs) }

 
 

-rnBind sig_fn trim (FunBind name inf matches _)
-  = do { new_name <- lookupLocatedBndrRn name
-       ; let { plain_name = unLoc new_name
-             ; bndrs      = unitNameSet plain_name }
+rnBind sig_fn trim (L loc (FunBind name inf matches _))
+  = setSrcSpan loc $ 
+    do { new_name <- lookupLocatedBndrRn name
+       ; let plain_name = unLoc new_name

 
        ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
                             rnMatchGroup (FunRhs plain_name) matches
 
        ; checkPrecMatch inf plain_name matches'
 
 
        ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
                             rnMatchGroup (FunRhs plain_name) matches
 
        ; checkPrecMatch inf plain_name matches'
 

-       ; return (FunBind new_name inf matches' (trim fvs),
-                 (bndrs, fvs))
+       ; return (L loc (FunBind new_name inf matches' (trim fvs)), [plain_name], fvs)

       }
 \end{code}
 
       }
 \end{code}
 

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 858512a..ec6e0e8 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -20,7 +20,7 @@ import HsSyn          ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
                          LSig, Match(..), IPBind(..), Prag(..),
                          HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, 
                          isVanillaLSig, sigName, placeHolderNames, isPragLSig,
                          LSig, Match(..), IPBind(..), Prag(..),
                          HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, 
                          isVanillaLSig, sigName, placeHolderNames, isPragLSig,

-                         LPat, GRHSs, MatchGroup(..), isEmptyLHsBinds,
+                         LPat, GRHSs, MatchGroup(..), isEmptyLHsBinds, pprLHsBinds,

                          collectHsBindBinders, collectPatBinders, pprPatBind
                        )
 import TcHsSyn         ( zonkId, (<$>) )
                          collectHsBindBinders, collectPatBinders, pprPatBind
                        )
 import TcHsSyn         ( zonkId, (<$>) )

@@ -59,8 +59,8 @@ import VarSet
 import SrcLoc          ( Located(..), unLoc, getLoc )
 import Bag
 import ErrUtils                ( Message )
 import SrcLoc          ( Located(..), unLoc, getLoc )
 import Bag
 import ErrUtils                ( Message )

-import Digraph         ( SCC(..), stronglyConnComp, flattenSCC )
-import Maybes          ( fromJust, isJust, orElse, catMaybes )
+import Digraph         ( SCC(..), stronglyConnComp )
+import Maybes          ( fromJust, isJust, isNothing, orElse, catMaybes )

 import Util            ( singleton )
 import BasicTypes      ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
                          RecFlag(..), isNonRec )
 import Util            ( singleton )
 import BasicTypes      ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
                          RecFlag(..), isNonRec )

@@ -105,7 +105,7 @@ tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv)
        --       want.  The bit we care about is the local bindings
        --       and the free type variables thereof
 tcTopBinds binds
        --       want.  The bit we care about is the local bindings
        --       and the free type variables thereof
 tcTopBinds binds

-  = do { (ValBindsOut prs, env) <- tcValBinds TopLevel binds getLclEnv
+  = do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv

        ; return (foldr (unionBags . snd) emptyBag prs, env) }
        -- The top level bindings are flattened into a giant 
        -- implicitly-mutually-recursive LHsBinds
        ; return (foldr (unionBags . snd) emptyBag prs, env) }
        -- The top level bindings are flattened into a giant 
        -- implicitly-mutually-recursive LHsBinds

@@ -157,39 +157,11 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
        returnM (ip_inst, (IPBind ip' expr'))
 
 ------------------------
        returnM (ip_inst, (IPBind ip' expr'))
 
 ------------------------

-mkEdges :: (Name -> Bool) -> [LHsBind Name]
-       -> [(LHsBind Name, BKey, [BKey])]
-
-type BKey  = Int -- Just number off the bindings
-
-mkEdges exclude_fn binds
-  = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)),
-                                    let mb_key = lookupNameEnv key_map n,
-                                    isJust mb_key,
-                                    not (exclude_fn n) ])
-    | (bind, key) <- keyd_binds
-    ]
-  where
-    keyd_binds = binds `zip` [0::BKey ..]
-
-    bind_fvs (FunBind _ _ _ fvs) = fvs
-    bind_fvs (PatBind _ _ _ fvs) = fvs
-    bind_fvs bind = pprPanic "mkEdges" (ppr bind)
-
-    key_map :: NameEnv BKey    -- Which binding it comes from
-    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
-                                    , bndr <- bindersOfHsBind bind ]
-
-bindersOfHsBind :: HsBind Name -> [Name]
-bindersOfHsBind (PatBind pat _ _ _)     = collectPatBinders pat
-bindersOfHsBind (FunBind (L _ f) _ _ _) = [f]
-
-------------------------

 tcValBinds :: TopLevelFlag 
           -> HsValBinds Name -> TcM thing
           -> TcM (HsValBinds TcId, thing) 
 
 tcValBinds :: TopLevelFlag 
           -> HsValBinds Name -> TcM thing
           -> TcM (HsValBinds TcId, thing) 
 

-tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
+tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside

   = tcAddLetBoundTyVars binds  $
       -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
           -- Notice that they scope over 
   = tcAddLetBoundTyVars binds  $
       -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
           -- Notice that they scope over 

@@ -199,11 +171,7 @@ tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
  
     do         {       -- Typecheck the signature
          tc_ty_sigs <- recoverM (returnM []) (tcTySigs sigs)
  
     do         {       -- Typecheck the signature
          tc_ty_sigs <- recoverM (returnM []) (tcTySigs sigs)

-
-               -- Do the basic strongly-connected component thing
-       ; let { sccs :: [SCC (LHsBind Name)]
-             ; sccs = stronglyConnComp (mkEdges (\n -> False) (bagToList binds))
-             ; prag_fn = mkPragFun sigs
+       ; let { prag_fn = mkPragFun sigs

              ; sig_fn  = lookupSig tc_ty_sigs
              ; sig_ids = map sig_id tc_ty_sigs }
 
              ; sig_fn  = lookupSig tc_ty_sigs
              ; sig_ids = map sig_id tc_ty_sigs }
 

@@ -211,13 +179,13 @@ tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
                -- the Ids declared with type signatures
        ; (binds', thing) <- tcExtendIdEnv sig_ids $
                             tc_val_binds top_lvl sig_fn prag_fn 
                -- the Ids declared with type signatures
        ; (binds', thing) <- tcExtendIdEnv sig_ids $
                             tc_val_binds top_lvl sig_fn prag_fn 

-                                         sccs thing_inside
+                                         binds thing_inside

 
 

-       ; return (ValBindsOut binds', thing) }
+       ; return (ValBindsOut binds' sigs, thing) }

 
 ------------------------
 tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun
 
 ------------------------
 tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun

-            -> [SCC (LHsBind Name)] -> TcM thing
+            -> [(RecFlag, LHsBinds Name)] -> TcM thing

             -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 -- Typecheck a whole lot of value bindings,
 -- one strongly-connected component at a time
             -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 -- Typecheck a whole lot of value bindings,
 -- one strongly-connected component at a time

@@ -226,62 +194,94 @@ tc_val_binds top_lvl sig_fn prag_fn [] thing_inside
   = do { thing <- thing_inside
        ; return ([], thing) }
 
   = do { thing <- thing_inside
        ; return ([], thing) }
 

-tc_val_binds top_lvl sig_fn prag_fn (scc : sccs) thing_inside
+tc_val_binds top_lvl sig_fn prag_fn (group : groups) thing_inside

   = do { (group', (groups', thing))
   = do { (group', (groups', thing))

-               <- tc_group top_lvl sig_fn prag_fn scc $ 
-                  tc_val_binds top_lvl sig_fn prag_fn sccs thing_inside
+               <- tc_group top_lvl sig_fn prag_fn group $ 
+                  tc_val_binds top_lvl sig_fn prag_fn groups thing_inside

        ; return (group' ++ groups', thing) }
 
 ------------------------
 tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun
        ; return (group' ++ groups', thing) }
 
 ------------------------
 tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun

-        -> SCC (LHsBind Name) -> TcM thing
+        -> (RecFlag, LHsBinds Name) -> TcM thing

         -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 
 -- Typecheck one strongly-connected component of the original program.
 -- We get a list of groups back, because there may 
 -- be specialisations etc as well
 
         -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 
 -- Typecheck one strongly-connected component of the original program.
 -- We get a list of groups back, because there may 
 -- be specialisations etc as well
 

-tc_group top_lvl sig_fn prag_fn scc@(AcyclicSCC bind) thing_inside
+tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside

   =    -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
         -- so that we desugar unlifted bindings correctly
   =    -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
         -- so that we desugar unlifted bindings correctly

-    do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive 
-                                       sig_fn prag_fn scc thing_inside
+    do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive NonRecursive
+                                       sig_fn prag_fn binds thing_inside

        ; return ([(NonRecursive, b) | b <- binds], thing) }
 
        ; return ([(NonRecursive, b) | b <- binds], thing) }
 

-tc_group top_lvl sig_fn prag_fn scc@(CyclicSCC binds) thing_inside
+tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside

   =    -- A recursive strongly-connected component
        -- To maximise polymorphism (with -fglasgow-exts), we do a new 
        -- strongly-connected  component analysis, this time omitting 
        -- any references to variables with type signatures.
        --
        -- Then we bring into scope all the variables with type signatures
   =    -- A recursive strongly-connected component
        -- To maximise polymorphism (with -fglasgow-exts), we do a new 
        -- strongly-connected  component analysis, this time omitting 
        -- any references to variables with type signatures.
        --
        -- Then we bring into scope all the variables with type signatures

-    do { traceTc (text "tc_group rec" <+> vcat [ppr b $$ text "--and--" | b <- binds])
+    do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)

        ; gla_exts     <- doptM Opt_GlasgowExts
        ; (binds,thing) <- if gla_exts 
                           then go new_sccs
        ; gla_exts     <- doptM Opt_GlasgowExts
        ; (binds,thing) <- if gla_exts 
                           then go new_sccs

-                          else go1 scc thing_inside
+                          else tc_binds Recursive binds thing_inside

        ; return ([(Recursive, unionManyBags binds)], thing) }
                -- Rec them all together
   where
     new_sccs :: [SCC (LHsBind Name)]
        ; return ([(Recursive, unionManyBags binds)], thing) }
                -- Rec them all together
   where
     new_sccs :: [SCC (LHsBind Name)]

-    new_sccs = stronglyConnComp (mkEdges has_sig binds)
+    new_sccs = stronglyConnComp (mkEdges sig_fn binds)

 
 --  go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing)
     go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs)
                        ; return (binds1 ++ binds2, thing) }
     go []        = do  { thing <- thing_inside; return ([], thing) }
 
 
 --  go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing)
     go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs)
                        ; return (binds1 ++ binds2, thing) }
     go []        = do  { thing <- thing_inside; return ([], thing) }
 

-    go1 scc thing_inside = tcPolyBinds top_lvl Recursive 
-                               sig_fn prag_fn scc thing_inside
+    go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind)
+    go1 (CyclicSCC binds) = tc_binds Recursive    (listToBag binds)

 
 

-    has_sig :: Name -> Bool
-    has_sig n = isJust (sig_fn n)
+    tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds
+
+------------------------
+mkEdges :: TcSigFun -> LHsBinds Name
+       -> [(LHsBind Name, BKey, [BKey])]
+
+type BKey  = Int -- Just number off the bindings
+
+mkEdges sig_fn binds
+  = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)),
+                                    let mb_key = lookupNameEnv key_map n,
+                                    isJust mb_key,
+                                    no_sig n ])
+    | (bind, key) <- keyd_binds
+    ]
+  where
+    no_sig :: Name -> Bool
+    no_sig n = isNothing (sig_fn n)
+
+    keyd_binds = bagToList binds `zip` [0::BKey ..]
+
+    bind_fvs (FunBind _ _ _ fvs) = fvs
+    bind_fvs (PatBind _ _ _ fvs) = fvs
+    bind_fvs bind = pprPanic "mkEdges" (ppr bind)
+
+    key_map :: NameEnv BKey    -- Which binding it comes from
+    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
+                                    , bndr <- bindersOfHsBind bind ]
+
+bindersOfHsBind :: HsBind Name -> [Name]
+bindersOfHsBind (PatBind pat _ _ _)     = collectPatBinders pat
+bindersOfHsBind (FunBind (L _ f) _ _ _) = [f]

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

-tcPolyBinds :: TopLevelFlag -> RecFlag
+tcPolyBinds :: TopLevelFlag 
+           -> RecFlag                  -- Whether the group is really recursive
+           -> RecFlag                  -- Whether it's recursive for typechecking purposes

            -> TcSigFun -> TcPragFun
            -> TcSigFun -> TcPragFun

-           -> SCC (LHsBind Name)
+           -> LHsBinds Name

            -> TcM thing
            -> TcM ([LHsBinds TcId], thing)
 
            -> TcM thing
            -> TcM ([LHsBinds TcId], thing)
 

@@ -295,14 +295,14 @@ tcPolyBinds :: TopLevelFlag -> RecFlag
 -- in which case the dependency order of the resulting bindings is
 -- important.  
 
 -- in which case the dependency order of the resulting bindings is
 -- important.  
 

-tcPolyBinds top_lvl is_rec sig_fn prag_fn scc thing_inside
+tcPolyBinds top_lvl rec_group rec_tc sig_fn prag_fn scc thing_inside

   =    -- NB: polymorphic recursion means that a function
        -- may use an instance of itself, we must look at the LIE arising
        -- from the function's own right hand side.  Hence the getLIE
   =    -- NB: polymorphic recursion means that a function
        -- may use an instance of itself, we must look at the LIE arising
        -- from the function's own right hand side.  Hence the getLIE

-       -- encloses the tc_poly_binds.
-     do        { traceTc (text "tcPolyBinds" <+> ppr scc)
+       -- encloses the tc_poly_binds. 
+    do { traceTc (text "tcPolyBinds" <+> ppr scc)

        ; ((binds1, poly_ids, thing), lie) <- getLIE $ 
        ; ((binds1, poly_ids, thing), lie) <- getLIE $ 

-               do { (binds1, poly_ids) <- tc_poly_binds top_lvl is_rec 
+               do { (binds1, poly_ids) <- tc_poly_binds top_lvl rec_group rec_tc

                                                         sig_fn prag_fn scc
                   ; thing <- tcExtendIdEnv poly_ids thing_inside
                   ; return (binds1, poly_ids, thing) }
                                                         sig_fn prag_fn scc
                   ; thing <- tcExtendIdEnv poly_ids thing_inside
                   ; return (binds1, poly_ids, thing) }

@@ -320,20 +320,20 @@ tcPolyBinds top_lvl is_rec sig_fn prag_fn scc thing_inside
                ; return (binds1 ++ [lie_binds], thing) }}
 
 ------------------------
                ; return (binds1 ++ [lie_binds], thing) }}
 
 ------------------------

-tc_poly_binds :: TopLevelFlag -> RecFlag
+tc_poly_binds :: TopLevelFlag          -- See comments on tcPolyBinds
+             -> RecFlag -> RecFlag

              -> TcSigFun -> TcPragFun
              -> TcSigFun -> TcPragFun

-             -> SCC (LHsBind Name)
+             -> LHsBinds Name

              -> TcM ([LHsBinds TcId], [TcId])
 -- Typechecks the bindings themselves
 -- Knows nothing about the scope of the bindings
 
              -> TcM ([LHsBinds TcId], [TcId])
 -- Typechecks the bindings themselves
 -- Knows nothing about the scope of the bindings
 

-tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
+tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds

   = let 
   = let 

-       non_rec      = case bind_scc of { AcyclicSCC _ -> True; CyclicSCC _ -> False }
-       binds        = flattenSCC bind_scc
-        binder_names = collectHsBindBinders (listToBag binds)
+        binder_names = collectHsBindBinders binds
+       bind_list    = bagToList binds

 
 

-       loc = getLoc (head binds)
+       loc = getLoc (head bind_list)

                -- TODO: location a bit awkward, but the mbinds have been
                --       dependency analysed and may no longer be adjacent
     in
                -- TODO: location a bit awkward, but the mbinds have been
                --       dependency analysed and may no longer be adjacent
     in

@@ -346,7 +346,7 @@ tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
 
        -- TYPECHECK THE BINDINGS
   ; ((binds', mono_bind_infos), lie_req) 
 
        -- TYPECHECK THE BINDINGS
   ; ((binds', mono_bind_infos), lie_req) 

-       <- getLIE (tcMonoBinds binds sig_fn non_rec)
+       <- getLIE (tcMonoBinds bind_list sig_fn rec_tc)

 
        -- CHECK FOR UNLIFTED BINDINGS
        -- These must be non-recursive etc, and are not generalised
 
        -- CHECK FOR UNLIFTED BINDINGS
        -- These must be non-recursive etc, and are not generalised

@@ -354,7 +354,7 @@ tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
   ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
   ; if any isUnLiftedType zonked_mono_tys then
     do {       -- Unlifted bindings
   ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
   ; if any isUnLiftedType zonked_mono_tys then
     do {       -- Unlifted bindings

-         checkUnliftedBinds top_lvl is_rec binds' mono_bind_infos
+         checkUnliftedBinds top_lvl rec_group binds' mono_bind_infos

        ; extendLIEs lie_req
        ; let exports  = zipWith mk_export mono_bind_infos zonked_mono_tys
              mk_export (name, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
        ; extendLIEs lie_req
        ; let exports  = zipWith mk_export mono_bind_infos zonked_mono_tys
              mk_export (name, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])

@@ -365,7 +365,7 @@ tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
                   [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
 
     else do    -- The normal lifted case: GENERALISE
                   [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
 
     else do    -- The normal lifted case: GENERALISE

-  { is_unres <- isUnRestrictedGroup binds sig_fn
+  { is_unres <- isUnRestrictedGroup bind_list sig_fn

   ; (tyvars_to_gen, dict_binds, dict_ids)
        <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
           generalise top_lvl is_unres mono_bind_infos lie_req
   ; (tyvars_to_gen, dict_binds, dict_ids)
        <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
           generalise top_lvl is_unres mono_bind_infos lie_req

@@ -465,10 +465,10 @@ recoveryCode binder_names sig_fn
 
 checkUnliftedBinds :: TopLevelFlag -> RecFlag
                   -> LHsBinds TcId -> [MonoBindInfo] -> TcM ()
 
 checkUnliftedBinds :: TopLevelFlag -> RecFlag
                   -> LHsBinds TcId -> [MonoBindInfo] -> TcM ()

-checkUnliftedBinds top_lvl is_rec mbind infos
+checkUnliftedBinds top_lvl rec_group mbind infos

   = do         { checkTc (isNotTopLevel top_lvl)
                  (unliftedBindErr "Top-level" mbind)
   = do         { checkTc (isNotTopLevel top_lvl)
                  (unliftedBindErr "Top-level" mbind)

-       ; checkTc (isNonRec is_rec)
+       ; checkTc (isNonRec rec_group)

                  (unliftedBindErr "Recursive" mbind)
        ; checkTc (isSingletonBag mbind)
                  (unliftedBindErr "Multiple" mbind) 
                  (unliftedBindErr "Recursive" mbind)
        ; checkTc (isSingletonBag mbind)
                  (unliftedBindErr "Multiple" mbind) 

@@ -492,13 +492,14 @@ The signatures have been dealt with already.
 \begin{code}
 tcMonoBinds :: [LHsBind Name]
            -> TcSigFun
 \begin{code}
 tcMonoBinds :: [LHsBind Name]
            -> TcSigFun

-           -> Bool     -- True <=> either the binders are not mentioned
-                       --          in their RHSs or they have type sigs
+           -> RecFlag  -- True <=> the binding is recursive for typechecking purposes
+                       --          i.e. the binders are mentioned in their RHSs, and
+                       --               we are not resuced by a type signature

            -> TcM (LHsBinds TcId, [MonoBindInfo])
 
 tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)]
            sig_fn              -- Single function binding,
            -> TcM (LHsBinds TcId, [MonoBindInfo])
 
 tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)]
            sig_fn              -- Single function binding,

-           True                -- binder isn't mentioned in RHS,
+           NonRecursive        -- binder isn't mentioned in RHS,

   | Nothing <- sig_fn name     -- ...with no type signature
   =    -- In this very special case we infer the type of the
        -- right hand side first (it may have a higher-rank type)
   | Nothing <- sig_fn name     -- ...with no type signature
   =    -- In this very special case we infer the type of the
        -- right hand side first (it may have a higher-rank type)

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 22dc9b2..b562968 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -60,6 +60,7 @@ import ListSetOps     ( equivClassesByUniq, minusList )
 import SrcLoc          ( Located(..), srcSpanStart, unLoc, noLoc )
 import Maybes          ( seqMaybe, isJust, mapCatMaybes )
 import List            ( partition )
 import SrcLoc          ( Located(..), srcSpanStart, unLoc, noLoc )
 import Maybes          ( seqMaybe, isJust, mapCatMaybes )
 import List            ( partition )

+import BasicTypes      ( RecFlag(..) )

 import Bag
 import FastString
 \end{code}
 import Bag
 import FastString
 \end{code}

@@ -356,7 +357,7 @@ tcMethodBind inst_tyvars inst_theta avail_insts prag_fn
     tcExtendTyVarEnv inst_tyvars (
        addErrCtxt (methodCtxt sel_id)                  $
        getLIE                                          $
     tcExtendTyVarEnv inst_tyvars (
        addErrCtxt (methodCtxt sel_id)                  $
        getLIE                                          $

-       tcMonoBinds [meth_bind] lookup_sig True
+       tcMonoBinds [meth_bind] lookup_sig Recursive

     )                                  `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
 
        -- Now do context reduction.   We simplify wrt both the local tyvars
     )                                  `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
 
        -- Now do context reduction.   We simplify wrt both the local tyvars

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index ec51813..a5d3f64 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -278,9 +278,9 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
 zonkValBinds env bs@(ValBindsIn _ _) 
   = panic "zonkValBinds"       -- Not in typechecker output
 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
 zonkValBinds env bs@(ValBindsIn _ _) 
   = panic "zonkValBinds"       -- Not in typechecker output

-zonkValBinds env (ValBindsOut binds) 
+zonkValBinds env (ValBindsOut binds sigs) 

   = do         { (env1, new_binds) <- go env binds
   = do         { (env1, new_binds) <- go env binds

-       ; return (env1, ValBindsOut new_binds) }
+       ; return (env1, ValBindsOut new_binds sigs) }

   where
     go env []         = return (env, [])
     go env ((r,b):bs) = do { (env1, b')  <- zonkRecMonoBinds env b
   where
     go env []         = return (env, [])
     go env ((r,b):bs) = do { (env1, b')  <- zonkRecMonoBinds env b

diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs
index 800fc8d..5f186d1 100644 (file)
--- a/ghc/compiler/typecheck/TcHsType.lhs
+++ b/ghc/compiler/typecheck/TcHsType.lhs
@@ -55,7 +55,7 @@ import NameEnv
 import PrelNames       ( genUnitTyConName )
 import TysWiredIn      ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
 import Bag             ( bagToList )
 import PrelNames       ( genUnitTyConName )
 import TysWiredIn      ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
 import Bag             ( bagToList )

-import BasicTypes      ( Boxity(..) )
+import BasicTypes      ( Boxity(..), RecFlag )

 import SrcLoc          ( Located(..), unLoc, noLoc, srcSpanStart )
 import UniqSupply      ( uniqsFromSupply )
 import Outputable
 import SrcLoc          ( Located(..), unLoc, noLoc, srcSpanStart )
 import UniqSupply      ( uniqsFromSupply )
 import Outputable

@@ -762,11 +762,11 @@ tcHsPatSigType ctxt hs_ty
                ; return (tyvars, sig_ty) }
        }
 
                ; return (tyvars, sig_ty) }
        }
 

-tcAddLetBoundTyVars :: LHsBinds Name -> TcM a -> TcM a
+tcAddLetBoundTyVars :: [(RecFlag,LHsBinds Name)] -> TcM a -> TcM a

 -- Turgid funciton, used for type variables bound by the patterns of a let binding
 
 tcAddLetBoundTyVars binds thing_inside
 -- Turgid funciton, used for type variables bound by the patterns of a let binding
 
 tcAddLetBoundTyVars binds thing_inside

-  = go (collectSigTysFromHsBinds (bagToList binds)) thing_inside
+  = go (concatMap (collectSigTysFromHsBinds . snd) binds) thing_inside

   where
     go [] thing_inside = thing_inside
     go (hs_ty:hs_tys) thing_inside
   where
     go [] thing_inside = thing_inside
     go (hs_ty:hs_tys) thing_inside