import SrcLoc
import Util
import Outputable
-import Maybes
import Bag
import BasicTypes
import HscTypes
-- Here op1_i, op2_i are the "instance method Ids"
{-# 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 = <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]
+ op1_i = /\a. \(d:C a).
+ let this :: C [a]
+ this = df_i a d
+ -- Note [Subtle interaction of recursion and overlap]
+
+ local_op1 :: forall b. Ix b => [a] -> b -> b
+ 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
op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
-- The dictionary function itself
{-# INLINE df_i #-} -- Always inline dictionary functions
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]
- -- 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
possibly can, so that we expose that dictionary constructor to
inlined. We need to fix this somehow -- perhaps allowing inlining
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
+definition for 'this' in the definition of op1_i in the example above.
+We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck
+we supply 'this' as a given dictionary. Only needed, though, if there
+are some type variales involved; otherwise there can be no overlap and
+none of this arises.
+
Note [Tricky type variable scoping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In our example
%************************************************************************
%* *
-\subsection{Type-checking instance declarations, pass 2}
+ Type-checking instance declarations, pass 2
%* *
%************************************************************************
-- newtype N a = MkN (Tree [a]) deriving( Foo Int )
--
-- The newtype gives an FC axiom looking like
--- axiom CoN a :: N a :=: Tree [a]
+-- axiom CoN a :: N a ~ Tree [a]
-- (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
--
-- So all need is to generate a binding looking like:
rigid_info = InstSkol
origin = SigOrigin rigid_info
inst_ty = idType dfun_id
- ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
+ ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
-- inst_head_ty is a PredType
; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
-- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)
- ; inst_loc <- getInstLoc origin
; sc_loc <- getInstLoc InstScOrigin
- ; dfun_dicts <- newDictBndrs inst_loc theta
; sc_dicts <- newDictBndrs sc_loc sc_theta'
+ ; inst_loc <- getInstLoc origin
+ ; dfun_dicts <- newDictBndrs inst_loc theta
; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
; rep_dict <- newDictBndr inst_loc rep_pred
-- Figure out bindings for the superclass context from dfun_dicts
-- Don't include this_dict in the 'givens', else
- -- wanted_sc_insts get bound by just selecting from this_dict!!
+ -- sc_dicts get bound by just selecting from this_dict!!
; sc_binds <- addErrCtxt superClassCtxt $
- tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
+ tcSimplifySuperClasses inst_loc this_dict dfun_dicts
+ (rep_dict:sc_dicts)
- ; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict))
+ -- It's possible that the superclass stuff might unified something
+ -- in the envt with one of the clas_tyvars
+ ; checkSigTyVars inst_tvs'
+
+ ; let coerced_rep_dict = wrapId the_coercion (instToId 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)
; return (unitBag $ noLoc $
- AbsBinds tvs (map instToVar dfun_dicts)
- [(tvs, dfun_id, instToId this_dict, [])]
+ AbsBinds inst_tvs' (map instToVar dfun_dicts)
+ [(inst_tvs', dfun_id, instToId this_dict, [])]
(dict_bind `consBag` sc_binds)) }
where
-----------------------
-- make_coercion
-- The inst_head looks like (C s1 .. sm (T a1 .. ak))
-- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
- -- with kind (C s1 .. sm (T a1 .. ak) :=: C s1 .. sm <rep_ty>)
+ -- with kind (C s1 .. sm (T a1 .. ak) ~ C s1 .. sm <rep_ty>)
-- where rep_ty is the (eta-reduced) type rep of T
-- So we just replace T with CoT, and insert a 'sym'
-- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
-- Instantiate the super-class context with inst_tys
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
- (eq_sc_theta',dict_sc_theta') = partition isEqPred sc_theta'
origin = SigOrigin rigid_info
- (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
-- Create dictionary Ids from the specified instance contexts.
- sc_loc <- getInstLoc InstScOrigin
- sc_dicts <- newDictBndrs sc_loc dict_sc_theta'
- inst_loc <- getInstLoc origin
- sc_covars <- mkMetaCoVars eq_sc_theta'
- wanted_sc_eqs <- mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars)
- dfun_covars <- mkCoVars eq_dfun_theta'
- dfun_eqs <- mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars)
- dfun_dicts <- newDictBndrs inst_loc dict_dfun_theta'
- this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys')
+ sc_loc <- getInstLoc InstScOrigin
+ sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted
+ inst_loc <- getInstLoc origin
+ dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities
+ this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys')
-- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment.
-- Typecheck the methods
- let -- These insts are in scope; quite a few, eh?
- dfun_insts = dfun_eqs ++ dfun_dicts
- wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
- this_dict_id = instToId this_dict
- sc_dict_ids = map instToId sc_dicts
- dfun_dict_ids = map instToId dfun_dicts
- prag_fn = mkPragFun uprags
- tc_meth = tcInstanceMethod loc clas inst_tyvars'
- (dfun_covars ++ dfun_dict_ids)
- dfun_theta' inst_tys'
- this_dict_id
- monobinds prag_fn
- (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items
+ let this_dict_id = instToId this_dict
+ dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
+ prag_fn = mkPragFun uprags
+ tc_meth = tcInstanceMethod loc clas inst_tyvars'
+ dfun_dicts
+ dfun_theta' inst_tys'
+ this_dict dfun_id
+ prag_fn monobinds
+ (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $
+ mapAndUnzipM tc_meth op_items
-- Figure out bindings for the superclass context
-- Don't include this_dict in the 'givens', else
- -- wanted_sc_insts get bound by just selecting from this_dict!!
- sc_binds <- addErrCtxt superClassCtxt
- (tcSimplifySuperClasses inst_loc dfun_insts wanted_sc_insts)
+ -- sc_dicts get bound by just selecting from this_dict!!
+ sc_binds <- addErrCtxt superClassCtxt $
+ tcSimplifySuperClasses inst_loc this_dict dfun_dicts sc_dicts
+ -- Note [Recursive superclasses]
- -- It's possible that the superclass stuff might unified one
- -- of the inst_tyavars' with something in the envt
+ -- It's possible that the superclass stuff might unified something
+ -- in the envt with one of the inst_tyvars'
checkSigTyVars inst_tyvars'
-- Deal with 'SPECIALISE instance' pragmas
-- Create the result bindings
let
dict_constr = classDataCon clas
- inline_prag | null dfun_insts = []
+ inline_prag | null dfun_dicts = []
| otherwise = [L loc (InlinePrag (Inline AlwaysActive True))]
-- Always inline the dfun; this is an experimental decision
-- because it makes a big performance difference sometimes.
--
-- See Note [Inline dfuns] below
- dict_rhs = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)
- (map HsVar sc_dict_ids ++ meth_exprs)
+ sc_dict_vars = map instToVar sc_dicts
+ dict_bind = L loc (VarBind this_dict_id dict_rhs)
+ dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs
+ inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys')
+ (dataConWrapId dict_constr)
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- member) are dealt with by the common MkId.mkDataConWrapId code rather
-- than needing to be repeated here.
- dict_bind = noLoc (VarBind this_dict_id dict_rhs)
main_bind = noLoc $ AbsBinds
- (inst_tyvars' ++ dfun_covars)
- dfun_dict_ids
- [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
+ inst_tyvars'
+ dfun_lam_vars
+ [(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)]
(dict_bind `consBag` sc_binds)
showLIE (text "instance")
return (main_bind `consBag` unionManyBags meth_binds)
-
-mkCoVars :: [PredType] -> TcM [TyVar]
-mkCoVars = newCoVars . map unEqPred
- where
- unEqPred (EqPred ty1 ty2) = (ty1, ty2)
- unEqPred _ = panic "TcInstDcls.mkCoVars"
-
-mkMetaCoVars :: [PredType] -> TcM [TyVar]
-mkMetaCoVars = mapM eqPredToCoVar
- where
- eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
- eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
\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
- Make the method bindings, as a [(NonRec, HsBinds)], one per method
- Use tcValBinds to do the checking
\begin{code}
-tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var]
- -> TcThetaType -> [TcType] -> Id
- -> LHsBinds Name -> TcPragFun
+tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst]
+ -> TcThetaType -> [TcType]
+ -> Inst -> Id
+ -> TcPragFun -> LHsBinds Name
-> (Id, DefMeth)
-> TcM (HsExpr Id, LHsBinds Id)
-- The returned inst_meth_ids all have types starting
-- forall tvs. theta => ...
-tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id
- binds_in prag_fn (sel_id, dm_info)
- = 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)
-
- -- 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 meth_name binds_in, dm_info) of
+tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys
+ this_dict dfun_id prag_fn binds_in (sel_id, dm_info)
+ = do { cloned_this <- cloneDict this_dict
+ -- Need to clone the dict in case it is floated out, and
+ -- then clashes with its friends
+ ; uniq1 <- newUnique
+ ; let local_meth_name = mkInternalName uniq1 sel_occ loc -- Same OccName
+ this_dict_bind = L loc $ VarBind (instToId cloned_this) $
+ L loc $ wrapId meth_wrapper dfun_id
+ mb_this_bind | null tyvars = Nothing
+ | otherwise = Just (cloned_this, this_dict_bind)
+ -- Only need the this_dict stuff if there are type variables
+ -- involved; otherwise overlap is not possible
+ -- See Note [Subtle interaction of recursion and overlap]
+
+ tc_body rn_bind = do { (meth_id, tc_binds) <- tcInstanceMethodBody
+ InstSkol clas tyvars dfun_dicts theta inst_tys
+ mb_this_bind sel_id
+ local_meth_name
+ meth_sig_fn meth_prag_fn rn_bind
+ ; return (wrapId meth_wrapper meth_id, tc_binds) }
+
+ ; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
-- 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
-- up a default binding, in a way depending on the default-method info
(Nothing, GenDefMeth) -> do -- Derivable type classes stuff
- { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name
- ; typecheck_meth meth_id meth_bind }
+ { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
+ ; tc_body meth_bind }
(Nothing, NoDefMeth) -> do -- No default method in the class
{ warn <- doptM Opt_WarnMissingMethods
; warnTc (warn -- Warn only if -fwarn-missing-methods
&& reportIfUnused (getOccName sel_id))
-- Don't warn about _foo methods
- (omittedMethodWarn sel_id)
- ; return (mk_error_rhs meth_tau, emptyBag) }
+ omitted_meth_warn
+ ; return (error_rhs, emptyBag) }
(Nothing, DefMeth) -> do -- An polymorphic default method
{ -- Build the typechecked version directly,
dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
-- Might not be imported, but will be an OrigName
; dm_id <- tcLookupId dm_name
- ; return (wrap dm_wrapper dm_id, emptyBag) } }
+ ; return (wrapId dm_wrapper dm_id, emptyBag) } }
where
sel_name = idName sel_id
sel_occ = nameOccName sel_name
- tv_names = map tyVarName tyvars
- prags = prag_fn sel_name
-
- typecheck_meth :: Id -> LHsBind Name -> TcM (HsExpr Id, LHsBinds Id)
- typecheck_meth meth_id bind
- = 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)
+ this_dict_id = instToId this_dict
+
+ meth_prag_fn _ = prag_fn sel_name
+ meth_sig_fn _ = Just [] -- The 'Just' says "yes, there's a type sig"
+ -- But there are no scoped type variables from local_method_id
+ -- Only the ones from the instance decl itself, which are already
+ -- in scope. Example:
+ -- class C a where { op :: forall b. Eq b => ... }
+ -- instance C [c] where { op = <rhs> }
+ -- In <rhs>, 'c' is scope but 'b' is not!
+
+ error_rhs = HsApp error_fun error_msg
+ error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
+ meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
- wrap wrapper id = mkHsWrap wrapper (HsVar id)
- meth_wrapper = mkWpApps dfun_lam_vars `WpCompose` mkWpTyApps (mkTyVarTys tyvars)
- dm_wrapper = WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys
+ dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys
+
+ omitted_meth_warn :: SDoc
+ omitted_meth_warn = ptext (sLit "No explicit method nor default method for")
+ <+> quotes (ppr sel_id)
+
+ dfun_lam_vars = map instToVar dfun_dicts
+ meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
+
-omittedMethodWarn :: Id -> SDoc
-omittedMethodWarn sel_id
- = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)
+wrapId :: HsWrapper -> id -> HsExpr id
+wrapId wrapper id = mkHsWrap wrapper (HsVar id)
\end{code}
Note [Default methods in instances]
projects / ghc-hetmet.git / blobdiff