Commit 2bfc6530 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor the treatment of lexically-scoped type variables for instance declarations

Previously the univerally-quantified variables of the DFun were also (bizarrely)
used as the lexically-scoped variables of the instance declaration.  So, for example,
the DFun's type could not be alpha-renamed.  This was an odd restriction, which has
bitten me several times.

This patch does the Right Thing, by adding an ib_tyvars field to the
InstBindings record, which captures the lexically scoped variables.
Easy, robust, nice.  (I think this record probably didn't exist originally,
hence the hack.)
parent 54f91886
......@@ -475,21 +475,19 @@ renameDeriv is_boot inst_infos bagBinds
inst_info@(InstInfo { iSpec = inst
, iBinds = InstBindings
{ ib_binds = binds
, ib_tyvars = tyvars
, ib_pragmas = sigs
, ib_extensions = exts -- only for type-checking
, ib_extensions = exts -- Only for type-checking
, ib_derived = sa } })
= -- Bring the right type variables into
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
bindLocalNamesFV (map Var.varName tyvars) $
= ASSERT( null sigs )
bindLocalNamesFV tyvars $
do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
; let binds' = InstBindings { ib_binds = rn_binds
, ib_pragmas = []
, ib_extensions = exts
, ib_derived = sa }
, ib_tyvars = tyvars
, ib_pragmas = []
, ib_extensions = exts
, ib_derived = sa }
; return (inst_info { iBinds = binds' }, fvs) }
where
(tyvars, _) = tcSplitForAllTys (idType (instanceDFunId inst))
\end{code}
Note [Newtype deriving and unused constructors]
......@@ -1995,6 +1993,7 @@ genInst comauxs
{ iSpec = inst_spec
, iBinds = InstBindings
{ ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty
, ib_tyvars = map Var.varName tvs -- Scope over bindings
, ib_pragmas = []
, ib_extensions = [ Opt_ImpredicativeTypes
, Opt_RankNTypes ]
......@@ -2012,6 +2011,7 @@ genInst comauxs
; let inst_info = InstInfo { iSpec = inst_spec
, iBinds = InstBindings
{ ib_binds = meth_binds
, ib_tyvars = map Var.varName tvs
, ib_pragmas = []
, ib_extensions = []
, ib_derived = True } }
......
......@@ -723,10 +723,15 @@ iDFunId info = instanceDFunId (iSpec info)
data InstBindings a
= InstBindings
{ ib_binds :: (LHsBinds a) -- Bindings for the instance methods
, ib_pragmas :: [LSig a] -- User pragmas recorded for generating
-- specialised instances
, ib_extensions :: [ExtensionFlag] -- any extra extensions that should
{ ib_tyvars :: [Name] -- Names of the tyvars from the instance head
-- that are lexically in scope in the bindings
, ib_binds :: (LHsBinds a) -- Bindings for the instance methods
, ib_pragmas :: [LSig a] -- User pragmas recorded for generating
-- specialised instances
, ib_extensions :: [ExtensionFlag] -- Any extra extensions that should
-- be enabled when type-checking this
-- instance; needed for
-- GeneralizedNewtypeDeriving
......
......@@ -135,6 +135,7 @@ metaTyConsToDerivStuff tc metaDts =
d_metaTycon = metaD metaDts
d_inst = mk_inst dClas d_metaTycon d_dfun_name
d_binds = InstBindings { ib_binds = dBinds
, ib_tyvars = []
, ib_pragmas = []
, ib_extensions = []
, ib_derived = True }
......@@ -145,6 +146,7 @@ metaTyConsToDerivStuff tc metaDts =
c_insts = [ mk_inst cClas c ds
| (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
c_binds = [ InstBindings { ib_binds = c
, ib_tyvars = []
, ib_pragmas = []
, ib_extensions = []
, ib_derived = True }
......@@ -157,6 +159,7 @@ metaTyConsToDerivStuff tc metaDts =
s_insts = map (map (\(s,ds) -> mk_inst sClas s ds))
(myZip2 s_metaTycons s_dfun_names)
s_binds = [ [ InstBindings { ib_binds = s
, ib_tyvars = []
, ib_pragmas = []
, ib_extensions = []
, ib_derived = True }
......
......@@ -542,6 +542,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
; let inst_info = InstInfo { iSpec = ispec
, iBinds = InstBindings
{ ib_binds = binds
, ib_tyvars = map Var.varName tyvars -- Scope over bindings
, ib_pragmas = uprags
, ib_extensions = []
, ib_derived = False } }
......@@ -812,7 +813,6 @@ So right here in tcInstDecls2 we must re-extend the type envt with
the default method Ids replete with their INLINE pragmas. Urk.
\begin{code}
tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
-- Returns a binding for the dfun
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
......@@ -838,11 +838,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
-- Typecheck the methods
; (meth_ids, meth_binds)
<- tcExtendTyVarEnv inst_tyvars $
-- The inst_tyvars scope over the 'where' part
-- Those tyvars are inside the dfun_id's type, which is a bit
-- bizarre, but OK so long as you realise it!
tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
<- tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
inst_tys spec_inst_info
op_items ibinds
......@@ -1175,10 +1171,13 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
(spec_inst_prags, prag_fn)
op_items (InstBindings { ib_binds = binds
, ib_tyvars = lexical_tvs
, ib_pragmas = sigs
, ib_extensions = exts
, ib_derived = is_derived })
= do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
= tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $
-- The lexical_tvs scope over the 'where' part
do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
; let hs_sig_fn = mkHsSigFun sigs
; checkMinimalDefinition
; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items }
......
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