Commit 8eaa70a6 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve environment handling in TcBinds

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
parent 6cf0c796
This diff is collapsed.
......@@ -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)
......
......@@ -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 }
{-
************************************************************************
......
......@@ -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)
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
......
......@@ -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
......@@ -685,6 +678,24 @@ type TcRef a = IORef a
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
......
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
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
......@@ -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:
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment