Improve environment handling in TcBinds
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 24 Mar 2015 12:52:29 +0000 (12:52 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 24 Mar 2015 12:58:08 +0000 (12:58 +0000)
This is a minor refactoring, but it simplifies the code quite a bit

* Decrease the number of variants of tcExtend in TcEnv
* Remove "not_actually_free" from TcEnv.tc_extend_local_env2
* Simplify plumbingof the "closed" flag
* Remove redundant scoping of wild-card variables

compiler/typecheck/TcBinds.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnTypes.hs
testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr
testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr
testsuite/tests/partial-sigs/should_fail/Trac10045.stderr

index 7b988da..17f6078 100644 (file)
@@ -301,16 +301,17 @@ tcValBinds :: TopLevelFlag
 
 tcValBinds top_lvl binds sigs thing_inside
   = do  {  -- Typecheck the signature
-        ; (poly_ids, sig_fn, nwc_tvs) <- tcExtendKindEnv2 patsyn_placeholder_kinds $
+        ; (poly_ids, sig_fn) <- tcExtendKindEnv2 patsyn_placeholder_kinds $
                                          -- See Note [Placeholder PatSyn kinds]
-                                         tcTySigs sigs
+                                tcTySigs sigs
 
         ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
 
-                -- Extend the envt right away with all
-                -- the Ids declared with type signatures
-                -- Use tcExtendIdEnv3 to avoid extending the TcIdBinder stack
-        ; tcExtendIdEnv3 [(idName id, id) | id <- poly_ids] (mkVarSet nwc_tvs) $ do
+                -- Extend the envt right away with all the Ids
+                -- declared with complete type signatures
+                -- Do not extend the TcIdBinderStack; instead
+                -- we extend it on a per-rhs basis in tcExtendForRhs
+        ; tcExtendLetEnvIds top_lvl [(idName id, id) | id <- poly_ids] $ do
             { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
                    { thing <- thing_inside
                      -- See Note [Pattern synonym builders don't yield dependencies]
@@ -319,8 +320,7 @@ tcValBinds top_lvl binds sigs thing_inside
                    ; return (extra_binds, thing) }
              ; return (binds' ++ extra_binds', thing) }}
   where
-    patsyns
-      = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds]
+    patsyns = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds]
     patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds]
       = [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ]
     placeholder_patsyn_tything
@@ -386,8 +386,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
     sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
 
     go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
-    go (scc:sccs) = do  { (binds1, ids1, closed) <- tc_scc scc
-                        ; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1 $
+    go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc
+                        ; (binds2, thing) <- tcExtendLetEnv top_lvl ids1 $
                                              go sccs
                         ; return (binds1 `unionBags` binds2, thing) }
     go []         = do  { thing <- thing_inside; return (emptyBag, thing) }
@@ -424,10 +424,10 @@ tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name }
         Just                  _  -> panic "tc_single"
 
 tc_single top_lvl sig_fn prag_fn lbind thing_inside
-  = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn
-                                    NonRecursive NonRecursive
-                                    [lbind]
-       ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
+  = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
+                                      NonRecursive NonRecursive
+                                      [lbind]
+       ; thing <- tcExtendLetEnv top_lvl ids thing_inside
        ; return (binds1, thing) }
 
 -- | No signature or a partial signature
@@ -461,7 +461,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
             -> RecFlag         -- Whether it's recursive after breaking
                                -- dependencies based on type signatures
             -> [LHsBind Name]  -- None are PatSynBind
-            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
+            -> TcM (LHsBinds TcId, [TcId])
 
 -- Typechecks a single bunch of values bindings all together,
 -- and generalises them.  The bunch may be only part of a recursive
@@ -486,10 +486,10 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
     ; let plan = decideGeneralisationPlan dflags type_env
                          binder_names bind_list sig_fn
     ; traceTc "Generalisation plan" (ppr plan)
-    ; result@(tc_binds, poly_ids, _) <- case plan of
-         NoGen               -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
-         InferGen mn cl      -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list
-         CheckGen lbind sig  -> tcPolyCheck rec_tc prag_fn sig lbind
+    ; result@(tc_binds, poly_ids) <- case plan of
+         NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
+         InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
+         CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind
 
         -- Check whether strict bindings are ok
         -- These must be non-recursive etc, and are not generalised
@@ -513,14 +513,14 @@ tcPolyNoGen     -- No generalisation whatsoever
                    -- dependencies based on type signatures
   -> PragFun -> TcSigFun
   -> [LHsBind Name]
-  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
+  -> TcM (LHsBinds TcId, [TcId])
 
 tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
   = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
                                              (LetGblBndr prag_fn)
                                              bind_list
        ; mono_ids' <- mapM tc_mono_info mono_infos
-       ; return (binds', mono_ids', NotTopLevel) }
+       ; return (binds', mono_ids') }
   where
     tc_mono_info (name, _, mono_id)
       = do { mono_ty' <- zonkTcType (idType mono_id)
@@ -539,7 +539,7 @@ tcPolyCheck :: RecFlag       -- Whether it's recursive after breaking
             -> PragFun
             -> TcSigInfo
             -> LHsBind Name
-            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
+            -> TcM (LHsBinds TcId, [TcId])
 -- There is just one binding,
 --   it binds a single variable,
 --   it has a complete type signature,
@@ -573,9 +573,7 @@ tcPolyCheck rec_tc prag_fn
                         { abs_tvs = tvs
                         , abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds]
                         , abs_exports = [export], abs_binds = binds' }
-             closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
-                    | otherwise                                     = NotTopLevel
-       ; return (unitBag abs_bind, [poly_id], closed) }
+       ; return (unitBag abs_bind, [poly_id]) }
 
 tcPolyCheck _rec_tc _prag_fn sig _bind
   = pprPanic "tcPolyCheck" (ppr sig)
@@ -586,35 +584,31 @@ tcPolyInfer
                    -- dependencies based on type signatures
   -> PragFun -> TcSigFun
   -> Bool         -- True <=> apply the monomorphism restriction
-  -> Bool         -- True <=> free vars have closed types
   -> [LHsBind Name]
-  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
+  -> TcM (LHsBinds TcId, [TcId])
+tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
   = do { ((binds', mono_infos), tclvl, wanted)
              <- pushLevelAndCaptureConstraints  $
                 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
 
        ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
        ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
-       ; (qtvs, givens, mr_bites, ev_binds)
+       ; (qtvs, givens, _mr_bites, ev_binds)
                  <- simplifyInfer tclvl mono name_taus wanted
 
        ; let inferred_theta = map evVarPred givens
-       ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs inferred_theta)
-                                       mono_infos
+       ; exports <- checkNoErrs $
+                    mapM (mkExport prag_fn qtvs inferred_theta) mono_infos
 
        ; loc <- getSrcSpanM
        ; let poly_ids = map abe_poly exports
-             final_closed | closed && not mr_bites = TopLevel
-                          | otherwise              = NotTopLevel
              abs_bind = L loc $
                         AbsBinds { abs_tvs = qtvs
                                  , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
                                  , abs_exports = exports, abs_binds = binds' }
 
-       ; traceTc "Binding:" (ppr final_closed $$
-                             ppr (poly_ids `zip` map idType poly_ids))
-       ; return (unitBag abs_bind, poly_ids, final_closed) }
+       ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
+       ; return (unitBag abs_bind, poly_ids) }
          -- poly_ids are guaranteed zonked by mkExport
 
 --------------
@@ -638,13 +632,15 @@ mkExport :: PragFun
 mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id)
   = do  { mono_ty <- zonkTcType (idType mono_id)
 
-        ; poly_id <- case mb_sig of
-              Nothing -> mkInferredPolyId poly_name qtvs inferred_theta mono_ty
-              Just (TcPatSynInfo _) -> panic "mkExport"
-              Just sig | Just id <- sig_poly_id sig
-                       -> return id
-              Just sig -> do { final_theta <- completeTheta inferred_theta sig
-                             ; mkInferredPolyId poly_name qtvs final_theta mono_ty }
+        ; (poly_id, inferred) <- case mb_sig of
+              Nothing  -> do { poly_id <- mkInferredPolyId poly_name qtvs inferred_theta mono_ty
+                             ; return (poly_id, True) }
+              Just sig | Just poly_id <- completeSigPolyId_maybe sig
+                       -> return (poly_id, False)
+                       | otherwise
+                       -> do { final_theta <- completeTheta inferred_theta sig
+                             ; poly_id <- mkInferredPolyId poly_name qtvs final_theta mono_ty
+                             ; return (poly_id, True) }
 
         -- NB: poly_id has a zonked type
         ; poly_id <- addInlinePrags poly_id prag_sigs
@@ -670,9 +666,8 @@ mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id)
         ; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap
                       , abe_poly = poly_id
                       , abe_mono = mono_id
-                      , abe_prags = SpecPrags spec_prags }) }
+                      , abe_prags = SpecPrags spec_prags}) }
   where
-    inferred = isNothing mb_sig
     prag_sigs = prag_fn poly_name
     sig_ctxt  = InfSigCtxt poly_name
 
@@ -839,12 +834,11 @@ where F is a non-injective type function.
 -- If typechecking the binds fails, then return with each
 -- signature-less binder given type (forall a.a), to minimise
 -- subsequent error messages
-recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
+recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])
 recoveryCode binder_names sig_fn
   = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
         ; let poly_ids = map mk_dummy binder_names
-        ; return (emptyBag, poly_ids, if all is_closed poly_ids
-                                      then TopLevel else NotTopLevel) }
+        ; return (emptyBag, poly_ids) }
   where
     mk_dummy name
       | Just (TcSigInfo { sig_poly_id = Just poly_id }) <- sig_fn name
@@ -852,8 +846,6 @@ recoveryCode binder_names sig_fn
       | otherwise
       = mkLocalId name forall_a_a
 
-    is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))
-
 forall_a_a :: TcType
 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
 
@@ -1310,7 +1302,7 @@ tcMonoBinds _ sig_fn no_gen binds
 
         ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
                                        | (n,id) <- rhs_id_env]
-        ; binds' <- tcExtendIdEnv2 rhs_id_env $
+        ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
                     mapM (wrapLocM tcRhs) tc_binds
         ; return (listToBag binds', mono_info) }
 
@@ -1342,7 +1334,7 @@ tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
   | Just sig <- sig_fn name
   = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False }
-           , ppr name )  
+           , ppr name )
        -- { f :: ty; f x = e } is always done via CheckGen (full signature)
        --                                      or InferGen (partial signature)
        --               see Note [Partial type signatures and generalisation]
@@ -1358,7 +1350,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matc
         ; mono_id <- newNoSigLetBndr no_gen name mono_ty
         ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
 
--- TODOT: emit Hole Constraints for wildcards
+-- TODO: emit Hole Constraints for wildcards
 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
   = do  { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
                               mapM lookup_info (collectPatBinders pat)
@@ -1379,14 +1371,9 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
 
 -------------------
 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
--- When we are doing pattern bindings, or multiple function bindings at a time
--- we *don't* bring any scoped type variables into scope
--- Wny not?  They are not completely rigid.
--- That's why we have the special case for a single FunBind in tcMonoBinds
-tcRhs (TcFunBind (_, mb_sig, mono_id) loc inf matches)
-  = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
-    tcExtendTyVarEnv2 tvsAndNwcs $
-            -- NotTopLevel: it's a monomorphic binding
+tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc inf matches)
+  = tcExtendForRhs [info]                           $
+    tcExtendTyVarEnv2 (lexically_scoped_tvs mb_sig) $
     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
         ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
                                             matches (idType mono_id)
@@ -1396,12 +1383,17 @@ tcRhs (TcFunBind (_, mb_sig, mono_id) loc inf matches)
                           , bind_fvs = placeHolderNamesTc
                           , fun_tick = [] }) }
     where
-      tvsAndNwcs = maybe [] (\sig -> [(n, tv) | (Just n, tv) <- sig_tvs sig]
-                                     ++ sig_nwcs sig) mb_sig
+      lexically_scoped_tvs :: Maybe TcSigInfo -> [(Name, TcTyVar)]
+      lexically_scoped_tvs (Just (TcSigInfo { sig_tvs = user_tvs, sig_nwcs = hole_tvs }))
+         = [(n, tv) | (Just n, tv) <- user_tvs] ++ hole_tvs
+      lexically_scoped_tvs _ = []
 
 tcRhs (TcPatBind infos pat' grhss pat_ty)
-  = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel | (_,_,mono_id) <- infos ] $
-            -- NotTopLevel: it's a monomorphic binding
+  = -- When we are doing pattern bindings we *don't* bring any scoped
+    -- type variables into scope unlike function bindings
+    -- Wny not?  They are not completely rigid.
+    -- That's why we have the special case for a single FunBind in tcMonoBinds
+    tcExtendForRhs infos        $
     do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
                     tcGRHSsPat grhss pat_ty
@@ -1409,6 +1401,21 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
                           , bind_fvs = placeHolderNamesTc
                           , pat_ticks = ([],[]) }) }
 
+tcExtendForRhs :: [MonoBindInfo] -> TcM a -> TcM a
+-- Extend the TcIdBinderStack for the RHS of the binding, with
+-- the monomorphic Id.  That way, if we have, say
+--     f = \x -> blah
+-- and something goes wrong in 'blah', we get a "relevant binding"
+-- looking like  f :: alpha -> beta
+-- This applies if 'f' has a type signature too:
+--    f :: forall a. [a] -> [a]
+--    f x = True
+-- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
+-- If we had the *polymorphic* version of f in the TcIdBinderStack, it
+-- would not be reported as relevant, because its type is closed
+tcExtendForRhs infos thing_inside
+  = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel | (_, _, mono_id) <- infos] thing_inside
+    -- NotTopLevel: it's a monomorphic binding
 
 ---------------------
 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
@@ -1503,22 +1510,22 @@ is wrong (eg at the top level of the module),
 which is over-conservative
 -}
 
-tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun, [TcTyVar])
+tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
 tcTySigs hs_sigs
   = checkNoErrs $   -- See Note [Fail eagerly on bad signatures]
-    do { (ty_sigs_s, tyvarsl) <- unzip <$> mapAndRecoverM tcTySig hs_sigs
-       ; let ty_sigs = concat ty_sigs_s
-             poly_ids = [id | TcSigInfo { sig_poly_id = Just id } <- ty_sigs]
-             -- The returned [TcId] are the ones for which we have a
-             -- *complete* type signatures.
-             -- See Note [Complete and partial type signatures]
+    do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs
+       ; let ty_sigs  = concat ty_sigs_s
+             poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
+                        -- The returned [TcId] are the ones for which we have
+                        -- a complete type signature.
+                        -- See Note [Complete and partial type signatures]
              env = mkNameEnv [(getName sig, sig) | sig <- ty_sigs]
-       ; return (poly_ids, lookupNameEnv env, concat tyvarsl) }
+       ; return (poly_ids, lookupNameEnv env) }
 
-tcTySig :: LSig Name -> TcM ([TcSigInfo], [TcTyVar])
+tcTySig :: LSig Name -> TcM [TcSigInfo]
 tcTySig (L _ (IdSig id))
   = do { sig <- instTcTySigFromId id
-       ; return ([sig], []) }
+       ; return [sig] }
 tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
   = setSrcSpan loc $
     pushTcLevelM_  $  -- When instantiating the signature, do so "one level in"
@@ -1528,9 +1535,8 @@ tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
 
        ; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1 False) hs_ty
 
-       ; sigs <- mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs))
-                      (map unLoc names)
-       ; return (sigs, nwc_tvs) }
+       ; mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs))
+              (map unLoc names) }
   where
      extra_cts (L _ (HsForAllTy _ extra _ _ _)) = extra
      extra_cts _ = Nothing
@@ -1557,8 +1563,9 @@ tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty))
                           patsig_univ = univ_tvs,
                           patsig_prov = prov',
                           patsig_req = req' }
-       ; return ([TcPatSynInfo tpsi], []) }}
-tcTySig _ = return ([], [])
+       ; return [TcPatSynInfo tpsi] }}
+
+tcTySig _ = return []
 
 instTcTySigFromId :: Id -> TcM TcSigInfo
 instTcTySigFromId id
@@ -1603,8 +1610,6 @@ data GeneralisationPlan
 
   | InferGen            -- Implicit generalisation; there is an AbsBinds
        Bool             --   True <=> apply the MR; generalise only unconstrained type vars
-       Bool             --   True <=> bindings mention only variables with closed types
-                        --            See Note [Bindings with closed types] in TcRnTypes
 
   | CheckGen (LHsBind Name) TcSigInfo
                         -- One binding with a signature
@@ -1615,7 +1620,7 @@ data GeneralisationPlan
 
 instance Outputable GeneralisationPlan where
   ppr NoGen          = ptext (sLit "NoGen")
-  ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c
+  ppr (InferGen b)   = ptext (sLit "InferGen") <+> ppr b
   ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s
 
 decideGeneralisationPlan
@@ -1630,7 +1635,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
   | mono_local_binds                          = NoGen
   | otherwise                                 = infer_plan
   where
-    infer_plan = InferGen mono_restriction closed_flag
+    infer_plan = InferGen mono_restriction
     bndr_set = mkNameSet bndr_names
     binds = map unLoc lbinds
 
@@ -1664,18 +1669,18 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
         -- These won't be in the local type env.
         -- Ditto class method etc from the current module
 
-    closed_flag = foldr (is_closed_ns . bind_fvs) True binds
-
     mono_local_binds = xopt Opt_MonoLocalBinds dflags
                     && not closed_flag
 
+    closed_flag = foldr (is_closed_ns . bind_fvs) True binds
+
     no_sig n = noCompleteSig (sig_fn n)
 
     -- With OutsideIn, all nested bindings are monomorphic
     -- except a single function binding with a signature
-    one_funbind_with_sig 
+    one_funbind_with_sig
       | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
-      , Just sig <- sig_fn (unLoc v) 
+      , Just sig <- sig_fn (unLoc v)
       = Just (lbind, sig)
       | otherwise
       = Nothing
@@ -1730,7 +1735,7 @@ checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
         ; checkTc (not any_pat_looks_lazy)
                   (unliftedMustBeBang orig_binds) }
   | otherwise
-  = traceTc "csb2" (ppr poly_ids) >>
+  = traceTc "csb2" (ppr [(id, idType id) | id <- poly_ids]) >>
     return ()
   where
     unlifted_bndrs     = any is_unlifted poly_ids
index 26c6a01..bc1bac2 100644 (file)
@@ -227,7 +227,7 @@ tcDefMeth clas tyvars this_dict binds_in
 
        ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
        ; let local_dm_sig' = local_dm_sig { sig_warn_redundant = warn_redundant }
-        ; (ev_binds, (tc_bind, _, _))
+        ; (ev_binds, (tc_bind, _))
                <- checkConstraints (ClsSkol clas) tyvars [this_dict] $
                   tcPolyCheck NonRecursive no_prag_fn local_dm_sig'
                               (L bind_loc lm_bind)
index e66eaea..e31ce86 100644 (file)
@@ -23,8 +23,8 @@ module TcEnv(
         -- Local environment
         tcExtendKindEnv, tcExtendKindEnv2,
         tcExtendTyVarEnv, tcExtendTyVarEnv2,
-        tcExtendLetEnv,
-        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendIdEnv3,
+        tcExtendLetEnv, tcExtendLetEnvIds,
+        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
         tcExtendIdBndrs, tcExtendGhciIdEnv,
 
         tcLookup, tcLookupLocated, tcLookupLocalIds,
@@ -45,7 +45,7 @@ module TcEnv(
         tcGetDefaultTys,
 
         -- Global type variables
-        tcGetGlobalTyVars, zapLclTypeEnv,
+        tcGetGlobalTyVars,
 
         -- Template Haskell stuff
         checkWellStaged, tcMetaTy, thLevel,
@@ -370,8 +370,7 @@ tcExtendTyVarEnv tvs thing_inside
 
 tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
 tcExtendTyVarEnv2 binds thing_inside
-  = do { stage <- getStage
-       ; tc_extend_local_env (NotTopLevel, thLevel stage)
+  = do { tc_extend_local_env NotTopLevel
                     [(name, ATyVar name tv) | (name, tv) <- binds] $
          do { env <- getLclEnv
             ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) }
@@ -435,71 +434,68 @@ Note especially that
        will be found in the global envt
 -}
 
+isClosedLetBndr :: Id -> TopLevelFlag
+-- See Note [Bindings with closed types] in TcRnTypes
+-- Note that we decided if a let-bound variable is closed by
+-- looking at its type, which is slightly more liberal, and a whole
+-- lot easier to implement, than looking at its free variables
+isClosedLetBndr id
+  | isEmptyVarSet (tyVarsOfType (idType id)) = TopLevel
+  | otherwise                                = NotTopLevel
+
 tcExtendGhciIdEnv :: [TyThing] -> TcM a -> TcM a
 -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
 -- See Note [Initialising the type environment for GHCi]
 tcExtendGhciIdEnv ids thing_inside
-  = do { lcl_env <- tcExtendLocalTypeEnv tc_ty_things emptyVarSet
+  = do { lcl_env <- tcExtendLocalTypeEnv tc_ty_things
        ; setLclEnv lcl_env thing_inside }
   where
     tc_ty_things =  [ (name, ATcId { tct_id     = id
-                                   , tct_closed = is_top id })
+                                   , tct_closed = isClosedLetBndr id })
                     | AnId id <- ids
                     , let name = idName id
                     , isInternalName name ]
-    is_top id | isEmptyVarSet (tyVarsOfType (idType id)) = TopLevel
-              | otherwise                                = NotTopLevel
 
-tcExtendLetEnv :: TopLevelFlag -> TopLevelFlag -> [TcId] -> TcM a -> TcM a
+tcExtendLetEnv :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
+-- Used for both top-level value bindings and and nested let/where-bindings
+-- Adds to the TcIdBinderStack too
+tcExtendLetEnv top_lvl ids thing_inside
+  = tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $
+    tcExtendLetEnvIds top_lvl [(idName id, id) | id <- ids] thing_inside
+
+tcExtendLetEnvIds :: TopLevelFlag -> [(Name,TcId)] -> TcM a -> TcM a
 -- Used for both top-level value bindings and and nested let/where-bindings
-tcExtendLetEnv top_lvl closed ids thing_inside
-  = do  { stage <- getStage
-        ; tc_extend_local_env (top_lvl, thLevel stage)
-                              [ (idName id, ATcId { tct_id = id
-                                                  , tct_closed = closed })
-                              | id <- ids] $
-          tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] thing_inside }
+-- Does not extend the TcIdBinderStack
+tcExtendLetEnvIds top_lvl pairs thing_inside
+  = tc_extend_local_env top_lvl [ (name, ATcId { tct_id = id
+                                               , tct_closed = isClosedLetBndr id })
+                                | (name,id) <- pairs ] $
+    thing_inside
 
 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
+-- For lambda-bound and case-bound Ids
+-- Extends the the TcIdBinderStack as well
 tcExtendIdEnv ids thing_inside
-  = tcExtendIdEnv2 [(idName id, id) | id <- ids] $
-    tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids]
-    thing_inside
+  = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
 
 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
+-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
 tcExtendIdEnv1 name id thing_inside
-  = tcExtendIdEnv2 [(name,id)] $
-    tcExtendIdBndrs [TcIdBndr id NotTopLevel]
-    thing_inside
+  = tcExtendIdEnv2 [(name,id)] thing_inside
 
 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
--- Do *not* extend the tcl_bndrs stack
--- The tct_closed flag really doesn't matter
--- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
 tcExtendIdEnv2 names_w_ids thing_inside
-  = tcExtendIdEnv3 names_w_ids emptyVarSet thing_inside
-
--- | 'tcExtendIdEnv2', but don't bind the 'TcId's in the 'TyVarSet' argument.
-tcExtendIdEnv3 :: [(Name,TcId)] -> TyVarSet -> TcM a -> TcM a
--- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
-tcExtendIdEnv3 names_w_ids not_actually_free thing_inside
-  = do  { stage <- getStage
-        ; tc_extend_local_env2 (NotTopLevel, thLevel stage)
+  = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
+                    | (_,mono_id) <- names_w_ids ] $
+    do  { tc_extend_local_env NotTopLevel
                               [ (name, ATcId { tct_id = id
                                              , tct_closed = NotTopLevel })
-                              | (name,id) <- names_w_ids] not_actually_free $
+                              | (name,id) <- names_w_ids] $
           thing_inside }
 
-tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a
-tcExtendIdBndrs bndrs = updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
-
-tc_extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcM a -> TcM a
-tc_extend_local_env thlvl extra_env thing_inside =
-  tc_extend_local_env2 thlvl extra_env emptyVarSet thing_inside
-
-tc_extend_local_env2 :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)]
-                     -> TyVarSet -> TcM a -> TcM a
-tc_extend_local_env2 thlvl extra_env not_actually_free thing_inside
+tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)]
+                    -> TcM a -> TcM a
+tc_extend_local_env top_lvl extra_env thing_inside
 -- Precondition: the argument list extra_env has TcTyThings
 --               that ATcId or ATyVar, but nothing else
 --
@@ -514,8 +510,9 @@ tc_extend_local_env2 thlvl extra_env not_actually_free thing_inside
 -- that are bound together with extra_env and should not be regarded
 -- as free in the types of extra_env.
   = do  { traceTc "env2" (ppr extra_env)
-        ; env1 <- tcExtendLocalTypeEnv extra_env not_actually_free
-        ; let env2 = extend_local_env thlvl extra_env env1
+        ; env1 <- tcExtendLocalTypeEnv extra_env
+        ; stage <- getStage
+        ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1
         ; setLclEnv env2 thing_inside }
   where
     extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
@@ -531,8 +528,8 @@ tc_extend_local_env2 thlvl extra_env not_actually_free thing_inside
             , tcl_th_bndrs = extendNameEnvList th_bndrs  -- We only track Ids in tcl_th_bndrs
                                  [(n, thlvl) | (n, ATcId {}) <- pairs] }
 
-tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TyVarSet -> TcM TcLclEnv
-tcExtendLocalTypeEnv tc_ty_things not_actually_free
+tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcM TcLclEnv
+tcExtendLocalTypeEnv tc_ty_things
   | isEmptyVarSet extra_tvs
   = do { lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) <- getLclEnv
        ; return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }
@@ -543,7 +540,7 @@ tcExtendLocalTypeEnv tc_ty_things not_actually_free
        ; return (lcl_env { tcl_tyvars = new_g_var
                          , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }
   where
-    extra_tvs = foldr get_tvs emptyVarSet tc_ty_things `minusVarSet` not_actually_free
+    extra_tvs = foldr get_tvs emptyVarSet tc_ty_things
 
     get_tvs (_, ATcId { tct_id = id, tct_closed = closed }) tvs
       = case closed of
@@ -570,13 +567,15 @@ tcExtendLocalTypeEnv tc_ty_things not_actually_free
         --
         -- Nor must we generalise g over any kind variables free in r's kind
 
-zapLclTypeEnv :: TcM a -> TcM a
-zapLclTypeEnv thing_inside
-  = do { tvs_var <- newTcRef emptyVarSet
-       ; let upd env = env { tcl_env = emptyNameEnv
-                           , tcl_rdr = emptyLocalRdrEnv
-                           , tcl_tyvars = tvs_var }
-       ; updLclEnv upd thing_inside }
+-------------------------------------------------------------
+-- Extending the TcIdBinderStack, used only for error messages
+
+tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a
+tcExtendIdBndrs bndrs thing_inside
+  = do { traceTc "tcExtendIdBndrs" (ppr bndrs)
+       ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
+                   thing_inside }
+
 
 {-
 ************************************************************************
index 2dc2117..de9840b 100644 (file)
@@ -787,7 +787,7 @@ tcInstDecls2 tycl_decls inst_decls
         ; let dm_ids = collectHsBindsBinders dm_binds
               -- Add the default method Ids (again)
               -- See Note [Default methods and instances]
-        ; inst_binds_s <- tcExtendLetEnv TopLevel TopLevel dm_ids $
+        ; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids $
                           mapM tcInstDecl2 inst_decls
 
           -- Done
@@ -1447,7 +1447,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
 
        ; global_meth_id <- addInlinePrags global_meth_id prags
        ; spec_prags     <- tcSpecPrags global_meth_id prags
-       ; (meth_implic, (tc_bind, _, _))
+       ; (meth_implic, (tc_bind, _))
                <- checkInstConstraints $ \ _ev_binds ->
                   tcPolyCheck NonRecursive no_prag_fn local_meth_sig
                               (L bind_loc lm_bind)
index 9f37a56..54d88cf 100644 (file)
@@ -10,7 +10,8 @@ TcPat: Typechecking patterns
 
 module TcPat ( tcLetPat, TcSigFun, TcPragFun
              , TcSigInfo(..), TcPatSynInfo(..)
-             , findScopedTyVars, isPartialSig, completeSigPolyId
+             , findScopedTyVars, isPartialSig
+             , completeSigPolyId, completeSigPolyId_maybe
              , LetBndrSpec(..), addInlinePrags, warnPrags
              , tcPat, tcPats, newNoSigLetBndr
              , addDataConStupidTheta, badFieldCon, polyPatSig ) where
@@ -140,10 +141,10 @@ data TcSigInfo
                               -- sig_id = Just id, then sig_name = idName id.
 
         sig_poly_id :: Maybe TcId,
-             -- Just f <=> the type signature had no wildcards, so the precise, 
+             -- Just f <=> the type signature had no wildcards, so the precise,
              --            complete polymorphic type is known.  In that case,
              --            f is the polymorphic Id, with that type
-           
+
              -- Nothing <=> the type signature is partial (i.e. includes one or more
              --             wildcards). In this case it doesn't make sense to give
              --             the polymorphic Id, because we are going to /infer/ its
@@ -160,7 +161,7 @@ data TcSigInfo
                            -- Instantiated wildcard variables
                            -- If sig_poly_id = Just f, then sig_nwcs must be empty
 
-        sig_extra_cts :: Maybe SrcSpan, 
+        sig_extra_cts :: Maybe SrcSpan,
                            -- Just loc <=> An extra-constraints wildcard was present
                            --              at location loc
                            --   e.g.   f :: (Eq a, _) => a -> a
@@ -239,6 +240,10 @@ completeSigPolyId :: TcSigInfo -> TcId
 completeSigPolyId (TcSigInfo { sig_poly_id = Just id }) = id
 completeSigPolyId _ = panic "completeSigPolyId"
 
+completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
+completeSigPolyId_maybe (TcSigInfo { sig_poly_id = mb_id }) = mb_id
+completeSigPolyId_maybe (TcPatSynInfo {})                   = Nothing
+
 {-
 Note [Binding scoped type variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index e7220db..dc470b4 100644 (file)
@@ -372,7 +372,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
        ; sig <- instTcTySigFromId builder_id
                 -- See Note [Redundant constraints for builder]
 
-       ; (builder_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
+       ; (builder_binds, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
        ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
        ; return builder_binds }
   where
index cce1705..da8e1c7 100644 (file)
@@ -33,7 +33,8 @@ module TcRnTypes(
         WhereFrom(..), mkModDeps,
 
         -- Typechecker types
-        TcTypeEnv, TcIdBinder(..), TcTyThing(..), PromotionErr(..),
+        TcTypeEnv, TcIdBinderStack, TcIdBinder(..),
+        TcTyThing(..), PromotionErr(..),
         pprTcTyThingCategory, pprPECategory,
 
         -- Desugaring types
@@ -629,8 +630,7 @@ data TcLclEnv           -- Changes as we move inside an expression
         tcl_env  :: TcTypeEnv,    -- The local type environment:
                                   -- Ids and TyVars defined in this module
 
-        tcl_bndrs :: [TcIdBinder],   -- Stack of locally-bound Ids, innermost on top
-                                     -- Used only for error reporting
+        tcl_bndrs :: TcIdBinderStack,   -- Used for reporting relevant bindings
 
         tcl_tidy :: TidyEnv,      -- Used for tidying types; contains all
                                   -- in-scope type variables (but not term variables)
@@ -656,13 +656,6 @@ type ThBindEnv = NameEnv (TopLevelFlag, ThLevel)
    -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being
    -- bound at top level!  See Note [Template Haskell levels] in TcSplice
 
-data TcIdBinder
-  = TcIdBndr
-       TcId
-       TopLevelFlag    -- Tells whether the bindind is syntactically top-level
-                       -- (The monomorphic Ids for a recursive group count
-                       --  as not-top-level for this purpose.)
-
 {- Note [Given Insts]
    ~~~~~~~~~~~~~~~~~~
 Because of GADTs, we have to pass inwards the Insts provided by type signatures
@@ -686,6 +679,24 @@ type TcId        = Id
 type TcIdSet     = IdSet
 
 ---------------------------
+-- The TcIdBinderStack
+---------------------------
+
+type TcIdBinderStack = [TcIdBinder]
+   -- This is a stack of locally-bound ids, innermost on top
+   -- Used ony in error reporting (relevantBindings in TcError)
+
+data TcIdBinder
+  = TcIdBndr
+       TcId
+       TopLevelFlag    -- Tells whether the bindind is syntactically top-level
+                       -- (The monomorphic Ids for a recursive group count
+                       --  as not-top-level for this purpose.)
+
+instance Outputable TcIdBinder where
+   ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl)
+
+---------------------------
 -- Template Haskell stages and levels
 ---------------------------
 
@@ -847,9 +858,8 @@ pprPECategory FamDataConPE = ptext (sLit "Data constructor")
 pprPECategory RecDataConPE = ptext (sLit "Data constructor")
 pprPECategory NoDataKinds  = ptext (sLit "Data constructor")
 
-{-
-Note [Bindings with closed types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Bindings with closed types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
 
   f x = let g ys = map not ys
@@ -861,10 +871,9 @@ have no free type variables, and it is the type variables in the
 environment that makes things tricky for OutsideIn generalisation.
 
 Definition:
-
    A variable is "closed", and has tct_closed set to TopLevel,
-      iff
-   a) all its free variables are imported, or are themselves closed
+iff
+   a) all its free variables are imported, or are let-bound with closed types
    b) generalisation is not restricted by the monomorphism restriction
 
 Under OutsideIn we are free to generalise a closed let-binding.
@@ -874,7 +883,7 @@ anyway -- the MR can make a top-level binding with a free type
 variable.)
 
 Note that:
-  * A top-level binding may not be closed, if it suffer from the MR
+  * A top-level binding may not be closed, if it suffers from the MR
 
   * A nested binding may be closed (eg 'g' in the example we started with)
     Indeed, that's the point; whether a function is defined at top level
@@ -1825,7 +1834,7 @@ data CtLoc = CtLoc { ctl_origin :: CtOrigin
   -- The TcLclEnv includes particularly
   --    source location:  tcl_loc   :: RealSrcSpan
   --    context:          tcl_ctxt  :: [ErrCtxt]
-  --    binder stack:     tcl_bndrs :: [TcIdBinders]
+  --    binder stack:     tcl_bndrs :: TcIdBinderStack
   --    level:            tcl_tclvl :: TcLevel
 
 mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc
index 8692475..560fe79 100644 (file)
@@ -1,6 +1,6 @@
 
 Defaulting1MROff.hs:6:1:
     No instance for (Num w_)
-    When checking that ‘alpha’ has the specified type
+    When checking that ‘alpha’ has the inferred type
       alpha :: forall w_. w_
     Probable cause: the inferred type is ambiguous
index f0549a5..43d559c 100644 (file)
@@ -1,6 +1,6 @@
 
 ExtraConstraintsWildcardNotPresent.hs:6:1:
     No instance for (Show a)
-    When checking that ‘show'’ has the specified type
+    When checking that ‘show'’ has the inferred type
       show' :: forall a. a -> String
     Probable cause: the inferred type is ambiguous
index 8c8e42f..76c088f 100644 (file)
@@ -29,7 +29,7 @@ Trac10045.hs:6:17:
 
 Trac10045.hs:7:9:
     No instance for (Num a)
-    When checking that ‘copy’ has the specified type
+    When checking that ‘copy’ has the inferred type
       copy :: forall t t1 a. t -> a -> t1
     Probable cause: the inferred type is ambiguous
     In the expression: