Commit c6485d5e authored by Simon Peyton Jones's avatar Simon Peyton Jones

Simplify AbsBinds wrapping

In poking Trac #11414 I found myself sinking into the abe_inst_wrap
swamp.  What is this strange thing?  (It turned out that #11414 was
breaking because of it.)

Thrillingly, I found a way to sweep it away again, putting the deep
instantation into tcMonoBinds instead of mkExport; and it turned out
that the fun_co_fn field of FunBind was already there ready to receive
exactly this wrapper. Hooray.  Result

* Death to abe_inst_wrap
* Death to mbi_orig
* Death to the plumbing in tcPolyInfer that did the
  deep instantiation

I did find that I had to re-engineer the treatment of instance type
signatures (again), but the result looks more modular and robust to
me.

And #11414 is fixed.
parent f3b9db31
......@@ -160,39 +160,37 @@ dsHsBind dflags
(AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds })
| ABE { abe_inst_wrap = inst_wrap, abe_wrap = wrap, abe_poly = global
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
, not (xopt LangExt.Strict dflags) -- handle strict binds
, not (anyBag (isBangedPatBind . unLoc) binds) -- in the next case
= -- push type constraints deeper for pattern match check
-- See Note [AbsBinds wrappers] in HsBinds
, not (xopt LangExt.Strict dflags) -- Handle strict binds
, not (anyBag (isBangedPatBind . unLoc) binds) -- in the next case
= -- See Note [AbsBinds wrappers] in HsBinds
addDictsDs (toTcTypeBag (listToBag dicts)) $
do { (_, bind_prs) <- ds_lhs_binds binds
; let core_bind = Rec bind_prs
; ds_binds <- dsTcEvBinds_s ev_binds
; inner_rhs <- dsHsWrapper inst_wrap $
Let core_bind $
Var local
; rhs <- dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
inner_rhs
-- addDictsDs: push type constraints deeper for pattern match check
do { (_, bind_prs) <- ds_lhs_binds binds
; let core_bind = Rec bind_prs
; ds_binds <- dsTcEvBinds_s ev_binds
; rhs <- dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
Var local
; (spec_binds, rules) <- dsSpecs rhs prags
; (spec_binds, rules) <- dsSpecs rhs prags
; let global' = addIdSpecialisations global rules
main_bind = makeCorePair dflags global' (isDefaultMethod prags)
(dictArity dicts) rhs
; let global' = addIdSpecialisations global rules
main_bind = makeCorePair dflags global' (isDefaultMethod prags)
(dictArity dicts) rhs
; return ([], main_bind : fromOL spec_binds) }
; return ([], main_bind : fromOL spec_binds) }
dsHsBind dflags
(AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports, abs_ev_binds = ev_binds
, abs_binds = binds })
-- See Note [Desugaring AbsBinds]
= -- push type constraints deeper for pattern match check
addDictsDs (toTcTypeBag (listToBag dicts)) $
= addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
do { (local_force_vars, bind_prs) <- ds_lhs_binds binds
; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
| (lcl_id, rhs) <- bind_prs ]
......@@ -215,17 +213,15 @@ dsHsBind dflags
-- Note [Desugar Strict binds]
; (exported_force_vars, extra_exports) <- get_exports local_force_vars
; let mk_bind (ABE { abe_inst_wrap = inst_wrap, abe_wrap = wrap
; let mk_bind (ABE { abe_wrap = wrap
, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
-- See Note [AbsBinds wrappers] in HsBinds
= do { tup_id <- newSysLocalDs tup_ty
; inner_rhs <- dsHsWrapper inst_wrap $
mkTupleSelector all_locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
; rhs <- dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
inner_rhs
mkTupleSelector all_locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
; let global' = (global `setInlinePragma` defaultInlinePragma)
......@@ -284,10 +280,9 @@ dsHsBind dflags
return (ABE {abe_poly = global
,abe_mono = local
,abe_wrap = WpHole
,abe_inst_wrap = WpHole
,abe_prags = SpecPrags []})
-- this is a combination of AbsBinds and FunBind
-- AbsBindsSig is a combination of AbsBinds and FunBind
dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_sig_export = global
, abs_sig_prags = prags
......@@ -298,6 +293,7 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
, fun_tick = tick } <- bind
= putSrcSpanDs bind_loc $
addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
do { (args, body) <- matchWrapper (FunRhs (idName global)) Nothing matches
; let body' = mkOptTickBox tick body
; fun_rhs <- dsHsWrapper co_fn $
......
......@@ -246,10 +246,8 @@ deriving instance (DataId idL, DataId idR)
data ABExport id
= ABE { abe_poly :: id -- ^ Any INLINE pragmas is attached to this Id
, abe_mono :: id
, abe_inst_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers]
-- ^ Shape: abe_mono ~ abe_insted
, abe_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_insted) ~ abe_poly
, abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
, abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
} deriving (Data, Typeable)
......@@ -367,9 +365,8 @@ bindings only when
lacks a user type signature
* The group forms a strongly connected component
Note [AbsBinds wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~
Note [ABExport wrapper]
~~~~~~~~~~~~~~~~~~~~~~~
Consider
(f,g) = (\x.x, \y.y)
This ultimately desugars to something like this:
......@@ -385,27 +382,6 @@ The abe_wrap field deals with impedance-matching between
and the thing we really want, which may have fewer type
variables. The action happens in TcBinds.mkExport.
For abe_inst_wrap, consider this:
x = (*)
The abe_mono type will be forall a. Num a => a -> a -> a
because no instantiation happens during typechecking. Before inferring
a final type, we must instantiate this. See Note [Instantiate when inferring
a type] in TcBinds. The abe_inst_wrap takes the uninstantiated abe_mono type
to a proper instantiated type. In this case, the "abe_insted" is
(b -> b -> b). Note that the value of "abe_insted" isn't important; it's
just an intermediate form as we're going from abe_mono to abe_poly. See also
the desugaring code in DsBinds.
It's conceivable that we could combine the two wrappers, but note that there
is a gap: neither wrapper tacks on the tvs and dicts from the outer AbsBinds.
These bits are added manually in desugaring. (See DsBinds.dsHsBind.) A problem
that would arise in combining them is that zonking becomes more challenging:
we want to zonk the tvs and dicts in the AbsBinds, but then we end up re-zonking
when we zonk the ABExport. And -- worse -- the combined wrapper would have
the tvs and dicts in binding positions, so they would shadow the original
tvs and dicts. This is all resolvable with some plumbing, but it seems simpler
just to keep the two wrappers distinct.
Note [Bind free vars]
~~~~~~~~~~~~~~~~~~~~~
The bind_fvs field of FunBind and PatBind records the free variables
......@@ -592,12 +568,10 @@ ppr_monobind (AbsBindsSig { abs_tvs = tyvars
ppr bind
instance (OutputableBndr id) => Outputable (ABExport id) where
ppr (ABE { abe_wrap = wrap, abe_inst_wrap = inst_wrap
, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> text "<=" <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (ppr wrap)
, nest 2 (ppr inst_wrap)]
, nest 2 (text "wrap:" <+> ppr wrap)]
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
......
......@@ -617,54 +617,6 @@ tcPolyCheck _rec_tc _prag_fn sig _bind
= pprPanic "tcPolyCheck" (ppr sig)
------------------
{-
Note [Instantiate when inferring a type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f = (*)
As there is no incentive to instantiate the RHS, tcMonoBinds will
produce a type of forall a. Num a => a -> a -> a for `f`. This will then go
through simplifyInfer and such, remaining unchanged.
There are two problems with this:
1) If the definition were `g _ = (*)`, we get a very unusual type of
`forall {a}. a -> forall b. Num b => b -> b -> b` for `g`. This is
surely confusing for users.
2) The monomorphism restriction can't work. The MR is dealt with in
simplifyInfer, and simplifyInfer has no way of instantiating. This
could perhaps be worked around, but it may be hard to know even
when instantiation should happen.
There is an easy solution to all three problems: instantiate (deeply) when
inferring a type. So that's what we do. Note that this decision is
user-facing.
Here are the details:
* tcMonoBinds produces the "monomorphic" ids to be put in the AbsBinds.
It is inconvenient to instantiate in this function or below. So the
monomorphic ids will be uninstantiated (and hence actually polymorphic,
but that doesn't ruin anyone's day).
* In the same captureConstraints as the tcMonoBinds, we instantiate all
the types of the monomorphic ids. Instantiating will produce constraints
to solve and instantiated types. These constraints and the instantiated
types go into simplifyInfer. HsWrappers are produced that go from
the "mono" types to the instantiated ones.
* simplifyInfer does its magic, figuring out how to regeneralize.
* mkExport then does the impedence matching and needs to connect the
monomorphic ids to the polymorphic types as decided by simplifyInfer.
Because the instantiation happens before simplifyInfer, we also pass in
the HsWrappers obtained via instantiating so that mkExport can connect
all the pieces.
* We produce an AbsBinds with the right (instantiated and then, perhaps,
regeneralized) polytypes and the not-yet-instantiated "monomorphic" ids,
using the built HsWrappers to connect. Done!
-}
tcPolyInfer
:: RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
......@@ -673,26 +625,12 @@ tcPolyInfer
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
= do { (tclvl, wanted, (binds', mono_infos, wrappers, insted_tys))
= do { (tclvl, wanted, (binds', mono_infos))
<- pushLevelAndCaptureConstraints $
do { (binds', mono_infos)
<- tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
-- See Note [Instantiate when inferring a type]
; traceTc "Note [Instantiate when inferring a type]" $
vcat (map (pprBndr LetBind . mbi_mono_id) mono_infos)
; (wrappers, insted_tys)
<- tcExtendIdBndrs
[ TcIdBndr mono_id NotTopLevel
| MBI { mbi_mono_id = mono_id } <- mono_infos ] $
mapAndUnzipM deeply_instantiate mono_infos
-- during instantiation, we might encounter an error
-- whose message will want to list these binders as
-- relevant.
; return (binds', mono_infos, wrappers, insted_tys) }
; let name_taus = [ (mbi_poly_name info, tau)
| (info, tau) <- zip mono_infos insted_tys]
tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info))
| info <- mono_infos ]
sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
......@@ -701,8 +639,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
; let inferred_theta = map evVarPred givens
; exports <- checkNoErrs $
zipWith3M (mkExport prag_fn qtvs inferred_theta)
mono_infos wrappers insted_tys
mapM (mkExport prag_fn qtvs inferred_theta) mono_infos
; loc <- getSrcSpanM
; let poly_ids = map abe_poly exports
......@@ -715,21 +652,10 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
; return (unitBag abs_bind, poly_ids) }
-- poly_ids are guaranteed zonked by mkExport
where
deeply_instantiate :: MonoBindInfo -> TcM (HsWrapper, TcRhoType)
deeply_instantiate (MBI { mbi_mono_id = mono_id, mbi_orig = orig })
= do { mono_ty <- zonkTcType (idType mono_id)
-- NB: zonk to uncover any foralls
; addErrCtxtM (instErrCtxt mono_id mono_ty) $
deeplyInstantiate orig mono_ty }
--------------
mkExport :: TcPragEnv
-> [TyVar] -> TcThetaType -- Both already zonked
-> MonoBindInfo
-> HsWrapper -- the instantiation wrapper;
-- see Note [Instantiate when inferring a type]
-> TcTauType -- the instantiated type
-> TcM (ABExport Id)
-- Only called for generalisation plan InferGen, not by CheckGen or NoGen
--
......@@ -748,15 +674,13 @@ mkExport prag_fn qtvs theta
mono_info@(MBI { mbi_poly_name = poly_name
, mbi_sig = mb_sig
, mbi_mono_id = mono_id })
inst_wrap inst_ty
= do { inst_ty <- zonkTcType inst_ty
= do { mono_ty <- zonkTcType (idType mono_id)
; poly_id <- case mb_sig of
Just sig | Just poly_id <- completeIdSigPolyId_maybe sig
-> return poly_id
_other -> checkNoErrs $
mkInferredPolyId qtvs theta
poly_name mb_sig inst_ty
poly_name mb_sig mono_ty
-- The checkNoErrs ensures that if the type is ambiguous
-- we don't carry on to the impedence matching, and generate
-- a duplicate ambiguity error. There is a similar
......@@ -770,7 +694,7 @@ mkExport prag_fn qtvs theta
-- See Note [Impedence matching]
-- NB: we have already done checkValidType, including an ambiguity check,
-- on the type; either when we checked the sig or in mkInferredPolyId
; let sel_poly_ty = mkInvSigmaTy qtvs theta inst_ty
; let sel_poly_ty = mkInvSigmaTy qtvs theta mono_ty
-- this type is just going into tcSubType, so Inv vs. Spec doesn't
-- matter
......@@ -786,8 +710,7 @@ mkExport prag_fn qtvs theta
; when warn_missing_sigs $ localSigWarn poly_id mb_sig
; return (ABE { abe_wrap = wrap
-- abe_wrap :: idType poly_id ~ (forall qtvs. theta => inst_ty)
, abe_inst_wrap = inst_wrap
-- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = SpecPrags spec_prags}) }
......@@ -1452,6 +1375,36 @@ Note that
should not typecheck because
case id of { (f :: forall a. a->a) -> f }
will not typecheck.
Note [Instantiate when inferring a type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f = (*)
As there is no incentive to instantiate the RHS, tcMonoBinds will
produce a type of forall a. Num a => a -> a -> a for `f`. This will then go
through simplifyInfer and such, remaining unchanged.
There are two problems with this:
1) If the definition were `g _ = (*)`, we get a very unusual type of
`forall {a}. a -> forall b. Num b => b -> b -> b` for `g`. This is
surely confusing for users.
2) The monomorphism restriction can't work. The MR is dealt with in
simplifyInfer, and simplifyInfer has no way of instantiating. This
could perhaps be worked around, but it may be hard to know even
when instantiation should happen.
There is an easy solution to both problems: instantiate (deeply) when
inferring a type. So that's what we do. Note that this decision is
user-facing.
We do this deep instantiation in tcMonoBinds, in the FunBind case
only, and only when we do not have a type signature. Conveniently,
the fun_co_fn field of FunBind gives a place to record the coercion.
We do not need to do this
* for PatBinds, because we don't have a function type
* for FunBinds where we have a signature, bucause we aren't doing inference
-}
tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes
......@@ -1460,7 +1413,6 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur
-> TcSigFun -> LetBndrSpec
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [MonoBindInfo])
tcMonoBinds is_rec sig_fn no_gen
[ L b_loc (FunBind { fun_id = L nm_loc name,
fun_matches = matches, bind_fvs = fvs })]
......@@ -1480,28 +1432,33 @@ tcMonoBinds is_rec sig_fn no_gen
-- function so that in type error messages we show the
-- type of the thing whose rhs we are type checking
tcMatchesFun name matches rhs_ty
; rhs_ty <- readExpType rhs_ty
; mono_id <- newNoSigLetBndr no_gen name rhs_ty
-- Deeply instantiate the inferred type
-- See Note [Instantiate when inferring a type]
; let orig = matchesCtOrigin matches
; rhs_ty <- zonkTcType rhs_ty -- NB: zonk to uncover any foralls
; (inst_wrap, rhs_ty) <- addErrCtxtM (instErrCtxt name rhs_ty) $
deeplyInstantiate orig rhs_ty
; mono_id <- newNoSigLetBndr no_gen name rhs_ty
; return (unitBag $ L b_loc $
FunBind { fun_id = L nm_loc mono_id,
fun_matches = matches', bind_fvs = fvs,
fun_co_fn = co_fn, fun_tick = [] },
fun_co_fn = inst_wrap <.> co_fn, fun_tick = [] },
[MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id
, mbi_orig = matchesCtOrigin matches }]) }
, mbi_mono_id = mono_id }]) }
tcMonoBinds _ sig_fn no_gen binds
= do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
-- Bring the monomorphic Ids, into scope for the RHSs
; let mono_info = getMonoBindInfo tc_binds
; let mono_infos = getMonoBindInfo tc_binds
rhs_id_env = [(name, mono_id) | MBI { mbi_poly_name = name
, mbi_sig = mb_sig
, mbi_mono_id = mono_id }
<- mono_info
<- mono_infos
, case mb_sig of
Just sig -> isPartialSig sig
Nothing -> True ]
......@@ -1510,9 +1467,9 @@ tcMonoBinds _ sig_fn no_gen binds
; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
| (n,id) <- rhs_id_env]
; (binds', mono_infos') <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
mapAndUnzipM (wrapLocFstM tcRhs) tc_binds
; return (listToBag binds', concat mono_infos') }
; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
mapM (wrapLocM tcRhs) tc_binds
; return (listToBag binds', mono_infos) }
------------------------
-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
......@@ -1536,9 +1493,7 @@ data TcMonoBind -- Half completed; LHS done, RHS not done
data MonoBindInfo = MBI { mbi_poly_name :: Name
, mbi_sig :: Maybe TcIdSigInfo
, mbi_mono_id :: TcId
, mbi_orig :: CtOrigin }
-- origin associated with RHS
, mbi_mono_id :: TcId }
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
......@@ -1554,9 +1509,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
; let mono_id = mkLocalIdOrCoVar mono_name tau
; return (TcFunBind (MBI { mbi_poly_name = name
, mbi_sig = Just sig
, mbi_mono_id = mono_id
, mbi_orig =
Shouldn'tHappenOrigin "FunBind sig" })
, mbi_mono_id = mono_id })
nm_loc matches) }
| otherwise
......@@ -1564,9 +1517,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
; mono_id <- newNoSigLetBndr no_gen name mono_ty
; return (TcFunBind (MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id
, mbi_orig =
Shouldn'tHappenOrigin "FunBind nosig" })
, mbi_mono_id = mono_id })
nm_loc matches) }
tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
......@@ -1583,9 +1534,7 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
_ -> Nothing
; return (MBI { mbi_poly_name = name
, mbi_sig = mb_sig
, mbi_mono_id = mono_id
, mbi_orig =
Shouldn'tHappenOrigin "PatBind" }) }
, mbi_mono_id = mono_id }) }
; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
tcInfer tc_pat
......@@ -1596,7 +1545,7 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
-- AbsBind, VarBind impossible
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId, [MonoBindInfo]) -- fills in the mbi_orig
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
loc matches)
= tcExtendIdBinderStackForRhs [info] $
......@@ -1608,8 +1557,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
, fun_matches = matches'
, fun_co_fn = co_fn
, bind_fvs = placeHolderNamesTc
, fun_tick = [] }
, [info { mbi_orig = matchesCtOrigin matches }] ) }
, fun_tick = [] } ) }
-- TODO: emit Hole Constraints for wildcards
tcRhs (TcPatBind infos pat' grhss pat_ty)
......@@ -1621,13 +1569,10 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
tcGRHSsPat grhss pat_ty
; let orig = grhssCtOrigin grhss
infos' = [ info { mbi_orig = orig } | info <- infos ]
; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
, pat_rhs_ty = pat_ty
, bind_fvs = placeHolderNamesTc
, pat_ticks = ([],[]) }
, infos' ) }
, pat_ticks = ([],[]) } )}
tcExtendTyVarEnvForRhs :: Maybe TcIdSigInfo -> TcM a -> TcM a
tcExtendTyVarEnvForRhs Nothing thing_inside
......@@ -1919,7 +1864,7 @@ data GeneralisationPlan
Bool -- True <=> apply the MR; generalise only unconstrained type vars
| CheckGen (LHsBind Name) TcIdSigInfo
-- One binding with a signature
-- One FunBind with a signature
-- Explicit generalisation; there is an AbsBindsSig
-- A consequence of the no-AbsBinds choice (NoGen) is that there is
......@@ -2136,10 +2081,10 @@ typeSigCtxt ctxt (PartialSig { sig_hs_ty = hs_ty })
typeSigCtxt ctxt (CompleteSig id)
= pprSigCtxt ctxt empty (ppr (idType id))
instErrCtxt :: TcId -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
instErrCtxt id ty env
instErrCtxt :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
instErrCtxt name ty env
= do { let (env', ty') = tidyOpenType env ty
; return (env', hang (text "When instantiating" <+> quotes (ppr id) <>
; return (env', hang (text "When instantiating" <+> quotes (ppr name) <>
text ", initially inferred to have" $$
text "this overly-general type:")
2 (ppr ty') $$
......
......@@ -253,7 +253,6 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
-- completeSigPolyId
, abe_mono = completeIdSigPolyId local_dm_sig
, abe_wrap = idHsWrapper
, abe_inst_wrap = idHsWrapper
, abe_prags = IsDefaultMethod }
full_bind = AbsBinds { abs_tvs = tyvars
, abs_ev_vars = [this_dict]
......
......@@ -438,14 +438,13 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abs_ev_binds = new_ev_binds
, abs_exports = new_exports, abs_binds = new_val_bind }) }
where
zonkExport env (ABE{ abe_wrap = wrap, abe_inst_wrap = inst_wrap
zonkExport env (ABE{ abe_wrap = wrap
, abe_poly = poly_id
, abe_mono = mono_id, abe_prags = prags })
= do new_poly_id <- zonkIdBndr env poly_id
(_, new_wrap) <- zonkCoFn env wrap
(_, new_inst_wrap) <- zonkCoFn env inst_wrap
new_prags <- zonkSpecPrags env prags
return (ABE{ abe_wrap = new_wrap, abe_inst_wrap = new_inst_wrap
return (ABE{ abe_wrap = new_wrap
, abe_poly = new_poly_id
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
......
......@@ -866,7 +866,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
| otherwise
= SpecPrags spec_inst_prags
export = ABE { abe_wrap = idHsWrapper, abe_inst_wrap = idHsWrapper
export = ABE { abe_wrap = idHsWrapper
, abe_poly = dfun_id
, abe_mono = self_dict, abe_prags = dfun_spec_prags }
-- NB: see Note [SPECIALISE instance pragmas]
......@@ -982,10 +982,9 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t
; let sc_top_ty = mkInvForAllTys tyvars (mkPiTypes dfun_evs sc_pred)
sc_top_id = mkLocalId sc_top_name sc_top_ty
export = ABE { abe_wrap = idHsWrapper
, abe_inst_wrap = idHsWrapper
, abe_poly = sc_top_id
, abe_mono = sc_ev_id
, abe_prags = SpecPrags [] }
, abe_prags = noSpecPrags }
local_ev_binds = TcEvBinds ev_binds_var
bind = AbsBinds { abs_tvs = tyvars
, abs_ev_vars = dfun_evs
......@@ -1311,7 +1310,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
-- Copy the inline pragma (if any) from the default
-- method to this version. Note [INLINE and default methods]
export = ABE { abe_wrap = idHsWrapper, abe_inst_wrap = idHsWrapper
export = ABE { abe_wrap = idHsWrapper
, abe_poly = meth_id1
, abe_mono = local_meth_id
, abe_prags = mk_meth_spec_prags meth_id1 spec_inst_prags [] }
......@@ -1347,61 +1346,28 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
sel_id (L bind_loc meth_bind) bndr_loc
= add_meth_ctxt $
do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id))
; (global_meth_id, local_meth_id) -- NB: type of local_meth_id is wrong
-- if there is an instance sig
<- setSrcSpan bndr_loc $
mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
; let prags = lookupPragEnv prag_fn sel_name
lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
; let prags = lookupPragEnv prag_fn (idName sel_id)
lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
; global_meth_id <- addInlinePrags global_meth_id prags
; spec_prags <- tcSpecPrags global_meth_id prags
-- taking instance signature into account might change the type of
-- the local_meth_id
; (meth_implic, ev_binds_var, (tc_bind, hs_wrap, local_meth_id))
<- checkInstConstraints $
do { (local_meth_sig, hs_wrap)
<- case lookupHsSig sig_fn sel_name of
{ Just lhs_ty -- There is a signature in the instance
-- See Note [Instance method signatures]
-> setSrcSpan (getLoc (hsSigType lhs_ty)) $
do { inst_sigs <- xoptM LangExt.InstanceSigs
; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty)
; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) lhs_ty
; let ctxt = FunSigCtxt sel_name True