Commit 4f597914 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Fix up the instance-declaration re-engineering story

This patch deals with a rather complicated situation involving
overlapping instances.  It's all explained in the commments
   Note [Subtle interaction of recursion and overlap]

The absence of this case make DoCon and regex-base fail with
an error about overlapping instances.  Now they work properly 
again.
parent 85cdcb79
...@@ -94,18 +94,27 @@ Running example: ...@@ -94,18 +94,27 @@ Running example:
-- Here op1_i, op2_i are the "instance method Ids" -- Here op1_i, op2_i are the "instance method Ids"
{-# INLINE [2] op1_i #-} -- From the instance decl bindings {-# INLINE [2] op1_i #-} -- From the instance decl bindings
op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
op1_i = <rhs> -- Source code; run the type checker on this op1_i = /\a. \(d:C a).
-- NB: Type variable 'a' (but not 'b') is in scope in <rhs> let local_op1 :: forall a. (C a, C [a])
-- Note [Tricky type variable scoping] => forall b. Ix b => [a] -> b -> b
-- Note [Subtle interaction of recursion and overlap]
local_op1 = <rhs>
-- Source code; run the type checker on this
-- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
-- Note [Tricky type variable scoping]
in local_op1 a d (df_i a d)
op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
-- The dictionary function itself -- The dictionary function itself
{-# INLINE df_i #-} -- Always inline dictionary functions {-# INLINE df_i #-} -- Always inline dictionary functions
df_i :: forall a. C a -> C [a] df_i :: forall a. C a -> C [a]
df_i = /\a. \d:C a. MkC (op1_i a d) ($dmop2 a d) df_i = /\a. \d:C a. letrec d' = MkC (op1_i a d)
($dmop2 [a] d')
in d'
-- But see Note [Default methods in instances] -- But see Note [Default methods in instances]
-- We can't apply the type checker to the default-nmethod call -- We can't apply the type checker to the default-method call
* The dictionary function itself is inlined as vigorously as we * The dictionary function itself is inlined as vigorously as we
possibly can, so that we expose that dictionary constructor to possibly can, so that we expose that dictionary constructor to
...@@ -130,6 +139,47 @@ Running example: ...@@ -130,6 +139,47 @@ Running example:
inlined. We need to fix this somehow -- perhaps allowing inlining inlined. We need to fix this somehow -- perhaps allowing inlining
of INLINE funcitons inside other INLINE functions. of INLINE funcitons inside other INLINE functions.
Note [Subtle interaction of recursion and overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
class C a where { op1,op2 :: a -> a }
instance C a => C [a] where
op1 x = op2 x ++ op2 x
op2 x = ...
intance C [Int] where
...
When type-checking the C [a] instance, we need a C [a] dictionary (for
the call of op2). If we look up in the instance environment, we find
an overlap. And in *general* the right thing is to complain (see Note
[Overlapping instances] in InstEnv). But in *this* case it's wrong to
complain, because we just want to delegate to the op2 of this same
instance.
Why is this justified? Because we generate a (C [a]) constraint in
a context in which 'a' cannot be instantiated to anything that matches
other overlapping instances, or else we would not be excecuting this
version of op1 in the first place.
It might even be a bit disguised:
nullFail :: C [a] => [a] -> [a]
nullFail x = op2 x ++ op2 x
instance C a => C [a] where
op1 x = nullFail x
Precisely this is used in package 'regex-base', module Context.hs.
See the overlapping instances for RegexContext, and the fact that they
call 'nullFail' just like the example above. The DoCon package also
does the same thing; it shows up in module Fraction.hs
Conclusion: when typechecking the methods in a C [a] instance, we want
to have C [a] available. That is why we have the strange local let in
the definition of op1_i in the example above. We can typecheck the
defintion of local_op1, and then supply the "this" argument via an
explicit call to the dfun (which in turn will be inlined).
Note [Tricky type variable scoping] Note [Tricky type variable scoping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In our example In our example
...@@ -478,7 +528,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ...@@ -478,7 +528,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
%************************************************************************ %************************************************************************
%* * %* *
\subsection{Type-checking instance declarations, pass 2} Type-checking instance declarations, pass 2
%* * %* *
%************************************************************************ %************************************************************************
...@@ -565,7 +615,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) ...@@ -565,7 +615,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
; sc_binds <- addErrCtxt superClassCtxt $ ; sc_binds <- addErrCtxt superClassCtxt $
tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts) tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict)) ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict)
; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body) ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
...@@ -679,15 +729,17 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) ...@@ -679,15 +729,17 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
tc_meth = tcInstanceMethod loc clas inst_tyvars' tc_meth = tcInstanceMethod loc clas inst_tyvars'
(dfun_covars ++ dfun_dict_ids) (dfun_covars ++ dfun_dict_ids)
dfun_theta' inst_tys' dfun_theta' inst_tys'
this_dict_id this_dict_id dfun_id
monobinds prag_fn prag_fn monobinds
(meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items
-- Figure out bindings for the superclass context -- Figure out bindings for the superclass context
-- Don't include this_dict in the 'givens', else -- Don't include this_dict in the 'givens', else
-- wanted_sc_insts get bound by just selecting from this_dict!! -- wanted_sc_insts get bound by just selecting from this_dict!!
sc_binds <- addErrCtxt superClassCtxt sc_binds <- addErrCtxt superClassCtxt $
(tcSimplifySuperClasses inst_loc dfun_insts wanted_sc_insts) tcSimplifySuperClasses inst_loc dfun_insts
wanted_sc_insts
-- Note [Recursive superclasses]
-- It's possible that the superclass stuff might unified one -- It's possible that the superclass stuff might unified one
-- of the inst_tyavars' with something in the envt -- of the inst_tyavars' with something in the envt
...@@ -745,7 +797,20 @@ mkMetaCoVars = mapM eqPredToCoVar ...@@ -745,7 +797,20 @@ mkMetaCoVars = mapM eqPredToCoVar
eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars" eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
\end{code} \end{code}
Note [Recursive superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #1470 for why we would *like* to add "this_dict" to the
available instances here. But we can't do so because then the superclases
get satisfied by selection from this_dict, and that leads to an immediate
loop. What we need is to add this_dict to Avails without adding its
superclasses, and we currently have no way to do that.
%************************************************************************
%* *
Type-checking an instance method
%* *
%************************************************************************
tcInstanceMethod tcInstanceMethod
- Make the method bindings, as a [(NonRec, HsBinds)], one per method - Make the method bindings, as a [(NonRec, HsBinds)], one per method
...@@ -757,50 +822,41 @@ tcInstanceMethod ...@@ -757,50 +822,41 @@ tcInstanceMethod
\begin{code} \begin{code}
tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var] tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var]
-> TcThetaType -> [TcType] -> Id -> TcThetaType -> [TcType]
-> LHsBinds Name -> TcPragFun -> Id -> Id
-> TcPragFun -> LHsBinds Name
-> (Id, DefMeth) -> (Id, DefMeth)
-> TcM (HsExpr Id, LHsBinds Id) -> TcM (HsExpr Id, LHsBinds Id)
-- The returned inst_meth_ids all have types starting -- The returned inst_meth_ids all have types starting
-- forall tvs. theta => ... -- forall tvs. theta => ...
tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys
binds_in prag_fn (sel_id, dm_info) this_dict_id dfun_id
prag_fn binds_in (sel_id, dm_info)
= do { uniq <- newUnique = do { uniq <- newUnique
; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) ; let local_meth_name = mkInternalName uniq sel_occ loc -- Same OccName
rho_ty = ASSERT( length sel_tyvars == length inst_tys ) tc_body = tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
substTyWith sel_tyvars inst_tys sel_rho this_dict_id dfun_id sel_id
(first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty prags local_meth_name
`orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
-- The first predicate should be of form (C a b)
-- where C is the class in question
meth_ty = mkSigmaTy tyvars theta meth_tau
meth_name = mkInternalName uniq sel_occ loc -- Same OccName
meth_id = mkLocalId meth_name meth_ty
; MASSERT( case getClassPredTys_maybe first_pred of
{ Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
; case (findMethodBind sel_name meth_name binds_in, dm_info) of
-- There is a user-supplied method binding, so use it -- There is a user-supplied method binding, so use it
(Just user_bind, _) -> typecheck_meth meth_id user_bind (Just user_bind, _) -> tc_body user_bind
-- The user didn't supply a method binding, so we have to make -- The user didn't supply a method binding, so we have to make
-- up a default binding, in a way depending on the default-method info -- up a default binding, in a way depending on the default-method info
(Nothing, GenDefMeth) -> do -- Derivable type classes stuff (Nothing, GenDefMeth) -> do -- Derivable type classes stuff
{ meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
; typecheck_meth meth_id meth_bind } ; tc_body meth_bind }
(Nothing, NoDefMeth) -> do -- No default method in the class (Nothing, NoDefMeth) -> do -- No default method in the class
{ warn <- doptM Opt_WarnMissingMethods { warn <- doptM Opt_WarnMissingMethods
; warnTc (warn -- Warn only if -fwarn-missing-methods ; warnTc (warn -- Warn only if -fwarn-missing-methods
&& reportIfUnused (getOccName sel_id)) && reportIfUnused (getOccName sel_id))
-- Don't warn about _foo methods -- Don't warn about _foo methods
(omittedMethodWarn sel_id) omitted_meth_warn
; return (mk_error_rhs meth_tau, emptyBag) } ; return (error_rhs, emptyBag) }
(Nothing, DefMeth) -> do -- An polymorphic default method (Nothing, DefMeth) -> do -- An polymorphic default method
{ -- Build the typechecked version directly, { -- Build the typechecked version directly,
...@@ -809,30 +865,73 @@ tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id ...@@ -809,30 +865,73 @@ tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id
dm_name <- lookupImportedName (mkDefMethRdrName sel_name) dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
-- Might not be imported, but will be an OrigName -- Might not be imported, but will be an OrigName
; dm_id <- tcLookupId dm_name ; dm_id <- tcLookupId dm_name
; return (wrap dm_wrapper dm_id, emptyBag) } } ; return (wrapId dm_wrapper dm_id, emptyBag) } }
where where
sel_name = idName sel_id sel_name = idName sel_id
sel_occ = nameOccName sel_name sel_occ = nameOccName sel_name
tv_names = map tyVarName tyvars
prags = prag_fn sel_name prags = prag_fn sel_name
typecheck_meth :: Id -> LHsBind Name -> TcM (HsExpr Id, LHsBinds Id) error_rhs = HsApp (mkLHsWrap (WpTyApp meth_tau) error_id) error_msg
typecheck_meth meth_id bind meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
= do { tc_binds <- tcMethodBind tv_names prags meth_id bind
; return (wrap meth_wrapper meth_id, tc_binds) }
mk_error_rhs tau = HsApp (mkLHsWrap (WpTyApp tau) error_id) error_msg
error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID) error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
wrap wrapper id = mkHsWrap wrapper (HsVar id) dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys
meth_wrapper = mkWpApps dfun_lam_vars `WpCompose` mkWpTyApps (mkTyVarTys tyvars)
dm_wrapper = WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys omitted_meth_warn :: SDoc
omitted_meth_warn = ptext (sLit "No explicit method nor default method for")
<+> quotes (ppr sel_id)
---------------
tcInstanceMethodBody :: Class -> [TcTyVar] -> [Var]
-> TcThetaType -> [TcType]
-> Id -> Id -> Id
-> [LSig Name] -> Name -> LHsBind Name
-> TcM (HsExpr Id, LHsBinds Id)
tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
this_dict_id dfun_id sel_id
prags local_meth_name bind@(L loc _)
= do { uniq <- newUnique
; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
rho_ty = ASSERT( length sel_tyvars == length inst_tys )
substTyWith sel_tyvars inst_tys sel_rho
(first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty
`orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
meth_name = mkInternalName uniq (getOccName local_meth_name) loc
meth_ty = mkSigmaTy tyvars theta meth_tau
meth_id = mkLocalId meth_name meth_ty
local_meth_ty = mkSigmaTy tyvars (theta ++ [first_pred]) meth_tau
local_meth_id = mkLocalId local_meth_name local_meth_ty
tv_names = map tyVarName tyvars
-- The first predicate should be of form (C a b)
-- where C is the class in question
; MASSERT( case getClassPredTys_maybe first_pred of
{ Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
; local_meth_bind <- tcMethodBind tv_names prags local_meth_id bind
; let full_bind = unitBag $ L loc $
VarBind meth_id $ L loc $
mkHsWrap (mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars) $
HsLet (HsValBinds (ValBindsOut [(NonRecursive, local_meth_bind)] [])) $ L loc $
mkHsWrap (WpLet this_dict_bind <.> WpApp this_dict_id) $
wrapId meth_wrapper local_meth_id
this_dict_bind = unitBag $ L loc $
VarBind this_dict_id $ L loc $
wrapId meth_wrapper dfun_id
; return (wrapId meth_wrapper meth_id, full_bind) }
where
meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
omittedMethodWarn :: Id -> SDoc wrapId :: HsWrapper -> id -> HsExpr id
omittedMethodWarn sel_id wrapId wrapper id = mkHsWrap wrapper (HsVar id)
= ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)
\end{code} \end{code}
Note [Default methods in instances] Note [Default methods in instances]
......
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