.
%************************************************************************
%* *
\subsection{Extracting instance decls}
%* *
%************************************************************************
Gather up the instance declarations from their various sources
\begin{code}
tcInstDecls1
:: [LTyClDecl Name]
-> [LInstDecl Name]
-> [LDerivDecl Name]
-> TcM (TcGblEnv,
[InstInfo Name],
HsValBinds Name)
tcInstDecls1 tycl_decls inst_decls deriv_decls
= checkNoErrs $
do {
; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
filter (isFamInstDecl . unLoc) tycl_decls
; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
; clas_decls = filter (isClassDecl . unLoc) tycl_decls
; implicit_things = concatMap implicitTyThings at_idx_tycons
; aux_binds = mkRecSelBinds at_idx_tycons
}
; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
; generic_inst_info <- getGenericInstances clas_decls
; addInsts local_info $
addInsts generic_inst_info $
addFamInsts at_idx_tycons $ do {
failIfErrsM
; (deriv_inst_info, deriv_binds, deriv_dus)
<- tcDeriving tycl_decls inst_decls deriv_decls
; gbl_env <- addInsts deriv_inst_info getGblEnv
; return ( addTcgDUs gbl_env deriv_dus,
generic_inst_info ++ deriv_inst_info ++ local_info,
aux_binds `plusHsValBinds` deriv_binds)
}}}
addInsts :: [InstInfo Name] -> TcM a -> TcM a
addInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
addFamInsts :: [TyThing] -> TcM a -> TcM a
addFamInsts tycons thing_inside
= tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
where
mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
(ppr tything)
\end{code}
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
-> TcM (InstInfo Name, [TyThing])
tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
= setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
do { is_boot <- tcIsHsBoot
; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
badBootDeclErr
; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
; checkValidInstance poly_ty tyvars theta clas inst_tys
; idx_tycons <- recoverM (return []) $
do { idx_tycons <- checkNoErrs $
mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
; checkValidAndMissingATs clas (tyvars, inst_tys)
(zip ats idx_tycons)
; return idx_tycons }
; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
; overlap_flag <- getOverlapFlag
; let (eq_theta,dict_theta) = partition isEqPred theta
theta' = eq_theta ++ dict_theta
dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
ispec = mkLocalInstance dfun overlap_flag
; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False },
idx_tycons)
}
where
checkValidAndMissingATs :: Class
-> ([TyVar], [TcType])
-> [(LTyClDecl Name,
TyThing)]
-> TcM ()
checkValidAndMissingATs clas inst_tys ats
= do {
; let class_ats = map tyConName (classATs clas)
defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
omitted = filterOut (`elemNameSet` defined_ats) class_ats
; warn <- doptM Opt_WarnMissingMethods
; mapM_ (warnTc warn . omittedATWarn) omitted
; mapM_ (checkIndexes clas inst_tys) ats
}
checkIndexes clas inst_tys (hsAT, ATyCon tycon)
= checkIndexes' clas inst_tys hsAT
(tyConTyVars tycon,
snd . fromJust . tyConFamInst_maybe $ tycon)
checkIndexes _ _ _ = panic "checkIndexes"
checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
= let atName = tcdName . unLoc $ hsAT
in
setSrcSpan (getLoc hsAT) $
addErrCtxt (atInstCtxt atName) $
case find ((atName ==) . tyConName) (classATs clas) of
Nothing -> addErrTc $ badATErr clas atName
Just atycon ->
let poss :: [Int]
poss = catMaybes [ tv `elemIndex` classTyVars clas
| tv <- tyConTyVars atycon]
relevantInstTys = map (instTys !!) poss
instArgs = map Just relevantInstTys ++
repeat Nothing
renaming = substSameTyVar atTvs instTvs
in
zipWithM_ checkIndex (substTys renaming atTys) instArgs
checkIndex ty Nothing
| isTyVarTy ty = return ()
| otherwise = addErrTc $ mustBeVarArgErr ty
checkIndex ty (Just instTy)
| ty `tcEqType` instTy = return ()
| otherwise = addErrTc $ wrongATArgErr ty instTy
listToNameSet = addListToNameSet emptyNameSet
substSameTyVar [] _ = emptyTvSubst
substSameTyVar (tv:tvs) replacingTvs =
let replacement = case find (tv `sameLexeme`) replacingTvs of
Nothing -> mkTyVarTy tv
Just rtv -> mkTyVarTy rtv
tv1 `sameLexeme` tv2 =
nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
in
extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
\end{code}
%************************************************************************
%* *
Type-checking instance declarations, pass 2
%* *
%************************************************************************
\begin{code}
tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
-> TcM (LHsBinds Id)
tcInstDecls2 tycl_decls inst_decls
= do {
let class_decls = filter (isClassDecl . unLoc) tycl_decls
; dm_binds_s <- mapM tcClassDecl2 class_decls
; let dm_binds = unionManyBags dm_binds_s
; let dm_ids = collectHsBindsBinders dm_binds
; inst_binds_s <- tcExtendIdEnv dm_ids $
mapM tcInstDecl2 inst_decls
; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
\end{code}
See Note [Default methods and instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The default method Ids are already in the type environment (see Note
[Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
don't have their InlinePragmas yet. Usually that would not matter,
because the simplifier propagates information from binding site to
use. But, unusually, when compiling instance decls we *copy* the
INLINE pragma from the default method to the method for that
particular operation (see Note [INLINE and default methods] below).
So right here in tcInstDecl2 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)
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
= recoverM (return emptyLHsBinds) $
setSrcSpan loc $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do {
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
n_ty_args = length inst_tyvars
n_silent = dfunNSilent dfun_id
(silent_theta, orig_theta) = splitAt n_silent dfun_theta
; silent_ev_vars <- mapM newSilentGiven silent_theta
; orig_ev_vars <- newEvVars orig_theta
; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
; (sc_dicts, sc_args)
<- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
; ct_loc <- getCtLoc ScOrigin
; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
emitFlats $ listToBag $
[ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ]
; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
; (meth_ids, meth_binds)
<- tcExtendTyVarEnv inst_tyvars $
tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
inst_tys spec_info
op_items ibinds
; self_dict <- newEvVar (ClassP clas inst_tys)
; let dict_constr = classDataCon clas
dict_bind = mkVarBind self_dict dict_rhs
dict_rhs = foldl mk_app inst_constr $
map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
inst_constr = L loc $ wrapId (mkWpTyApps inst_tys)
(dataConWrapId dict_constr)
mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id
mk_app fun arg = L loc (HsApp fun (L loc arg))
arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)
dfun_id_w_fun = dfun_id
`setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args)
`setInlinePragma` dfunInlinePragma
meth_args = map (DFunPolyArg . Var) meth_ids
main_bind = AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
, abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
SpecPrags spec_inst_prags)]
, abs_ev_binds = emptyTcEvBinds
, abs_binds = unitBag dict_bind }
; return (unitBag (L loc main_bind) `unionBags`
listToBag meth_binds)
}
where
skol_info = InstSkol
dfun_ty = idType dfun_id
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr)
tcSuperClass n_ty_args ev_vars pred
| Just (ev, i) <- find n_ty_args ev_vars
= return (ev, DFunLamArg i)
| otherwise
= ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)
do { sc_dict <- emitWanted ScOrigin pred
; return (sc_dict, DFunConstArg (Var sc_dict)) }
where
find _ [] = Nothing
find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
| otherwise = find (i+1) evs
tcSpecInstPrags :: DFunId -> InstBindings Name
-> TcM ([Located TcSpecPrag], PragFun)
tcSpecInstPrags _ (NewTypeDerived {})
= return ([], \_ -> [])
tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
= do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
filter isSpecInstLSig uprags
; return (spec_inst_prags, mkPragFun uprags binds) }
\end{code}
Note [Silent Superclass Arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following (extreme) situation:
class C a => D a where ...
instance D [a] => D [a] where ...
Although this looks wrong (assume D [a] to prove D [a]), it is only a
more extreme case of what happens with recursive dictionaries.
To implement the dfun we must generate code for the superclass C [a],
which we can get by superclass selection from the supplied argument!
So we’d generate:
dfun :: forall a. D [a] -> D [a]
dfun = \d::D [a] -> MkD (scsel d) ..
However this means that if we later encounter a situation where
we have a [Wanted] dw::D [a] we could solve it thus:
dw := dfun dw
Although recursive, this binding would pass the TcSMonadisGoodRecEv
check because it appears as guarded. But in reality, it will make a
bottom superclass. The trouble is that isGoodRecEv can't "see" the
superclass-selection inside dfun.
Our solution to this problem is to change the way ‘dfuns’ are created
for instances, so that we pass as first arguments to the dfun some
``silent superclass arguments’’, which are the immediate superclasses
of the dictionary we are trying to construct. In our example:
dfun :: forall a. (C [a], D [a] -> D [a]
dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
This gives us:
-----------------------------------------------------------
DFun Superclass Invariant
~~~~~~~~~~~~~~~~~~~~~~~~
In the body of a DFun, every superclass argument to the
returned dictionary is
either * one of the arguments of the DFun,
or * constant, bound at top level
-----------------------------------------------------------
This means that no superclass is hidden inside a dfun application, so
the counting argument in isGoodRecEv (more dfun calls than superclass
selections) works correctly.
The extra arguments required to satisfy the DFun Superclass Invariant
always come first, and are called the "silent" arguments. DFun types
are built (only) by MkId.mkDictFunId, so that is where we decide
what silent arguments are to be added.
This net effect is that it is safe to treat a dfun application as
wrapping a dictionary constructor around its arguments (in particular,
a dfun never picks superclasses from the arguments under the dictionary
constructor).
In our example, if we had [Wanted] dw :: D [a] we would get via the instance:
dw := dfun d1 d2
[Wanted] (d1 :: C [a])
[Wanted] (d2 :: D [a])
[Derived] (d :: D [a])
[Derived] (scd :: C [a]) scd := scsel d
[Derived] (scd2 :: C [a]) scd2 := scsel d2
And now, though we *can* solve:
d2 := dw
we will get an isGoodRecEv failure when we try to solve:
d1 := scsel d
or
d1 := scsel d2
Test case SCLoop tests this fix.
Note [SPECIALISE instance pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
instance (Ix a, Ix b) => Ix (a,b) where
{-# SPECIALISE instance Ix (Int,Int) #-}
range (x,y) = ...
We do *not* want to make a specialised version of the dictionary
function. Rather, we want specialised versions of each method.
Thus we should generate something like this:
$dfIx :: (Ix a, Ix x) => Ix (a,b)
{- DFUN [$crange, ...] -}
$dfIx da db = Ix ($crange da db) (...other methods...)
$dfIxPair :: (Ix a, Ix x) => Ix (a,b)
{- DFUN [$crangePair, ...] -}
$dfIxPair = Ix ($crangePair da db) (...other methods...)
$crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
{-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
$crange da db =
{-# RULE range ($dfIx da db) = $crange da db #-}
Note that
* The RULE is unaffected by the specialisation. We don't want to
specialise $dfIx, because then it would need a specialised RULE
which is a pain. The single RULE works fine at all specialisations.
See Note [How instance declarations are translated] above
* Instead, we want to specialise the *method*, $crange
In practice, rather than faking up a SPECIALISE pragama for each
method (which is painful, since we'd have to figure out its
specialised type), we call tcSpecPrag *as if* were going to specialise
$dfIx -- you can see that in the call to tcSpecInst. That generates a
SpecPrag which, as it turns out, can be used unchanged for each method.
The "it turns out" bit is delicate, but it works fine!
\begin{code}
tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
= addErrCtxt (spec_ctxt prag) $
do { let name = idName dfun_id
; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
(idType dfun_id) spec_dfun_ty
; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
where
spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
tcSpecInst _ _ = panic "tcSpecInst"
\end{code}
%************************************************************************
%* *
Type-checking an instance method
%* *
%************************************************************************
tcInstanceMethod
- Make the method bindings, as a [(NonRec, HsBinds)], one per method
- Remembering to use fresh Name (the instance method Name) as the binder
- Bring the instance method Ids into scope, for the benefit of tcInstSig
- Use sig_fn mapping instance method Name -> instance tyvars
- Ditto prag_fn
- Use tcValBinds to do the checking
\begin{code}
tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
-> [EvVar]
-> [TcType]
-> ([Located TcSpecPrag], PragFun)
-> [(Id, DefMeth)]
-> InstBindings Name
-> TcM ([Id], [LHsBind Id])
tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
(spec_inst_prags, prag_fn)
op_items (VanillaInst binds _ standalone_deriv)
= mapAndUnzipM tc_item op_items
where
tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
tc_item (sel_id, dm_info)
= case findMethodBind (idName sel_id) binds of
Just user_bind -> tc_body sel_id standalone_deriv user_bind
Nothing -> tc_default sel_id dm_info
tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
tc_body sel_id generated_code rn_bind
= add_meth_ctxt sel_id generated_code rn_bind $
do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
; let prags = prag_fn (idName sel_id)
; meth_id1 <- addInlinePrags meth_id prags
; spec_prags <- tcSpecPrags meth_id1 prags
; bind <- tcInstanceMethodBody InstSkol
tyvars dfun_ev_vars
meth_id1 local_meth_id meth_sig_fn
(mk_meth_spec_prags meth_id1 spec_prags)
rn_bind
; return (meth_id1, bind) }
tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
tc_default sel_id GenDefMeth
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
; tc_body sel_id False meth_bind }
tc_default sel_id NoDefMeth
= do { warnMissingMethod sel_id
; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
; return (meth_id, mkVarBind meth_id $
mkLHsWrap lam_wrapper error_rhs) }
where
error_rhs = L loc $ 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 ])
lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
tc_default sel_id (DefMeth dm_name)
= do {
; self_dict <- newEvVar (ClassP clas inst_tys)
; let self_ev_bind = EvBind self_dict $
EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars
; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
; dm_id <- tcLookupId dm_name
; let dm_inline_prag = idInlinePragma dm_id
rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
HsVar dm_id
meth_bind = L loc $ VarBind { var_id = local_meth_id
, var_rhs = L loc rhs
, var_inline = False }
meth_id1 = meth_id `setInlinePragma` dm_inline_prag
bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [( tyvars, meth_id1, local_meth_id
, mk_meth_spec_prags meth_id1 [])]
, abs_ev_binds = EvBinds (unitBag self_ev_bind)
, abs_binds = unitBag meth_bind }
; return (meth_id1, L loc bind) }
mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags meth_id spec_prags_for_me
= SpecPrags (spec_prags_for_me ++
[ L loc (SpecPrag meth_id wrap inl)
| L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
loc = getSrcSpan dfun_id
meth_sig_fn _ = Just ([],loc)
add_meth_ctxt sel_id generated_code rn_bind thing
| generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
| otherwise = thing
tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
_ op_items (NewTypeDerived coi _)
= do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
emitWanted ScOrigin rep_pred
; mapAndUnzipM (tc_item rep_d_stuff) op_items }
where
loc = getSrcSpan dfun_id
inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
Just (init_inst_tys, _) = snocView inst_tys
rep_ty = fst (coercionKind co)
rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
co = substTyWith inst_tvs (mkTyVarTys tyvars) $
case coi of { IdCo ty -> ty ;
ACo co -> mkSymCoercion co }
tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
tc_item (rep_ev_binds, rep_d) (sel_id, _)
= do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
meth_bind = VarBind { var_id = local_meth_id
, var_rhs = L loc meth_rhs
, var_inline = False }
bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [(tyvars, meth_id,
local_meth_id, noSpecPrags)]
, abs_ev_binds = rep_ev_binds
, abs_binds = unitBag $ L loc meth_bind }
; return (meth_id, L loc bind) }
mk_op_wrapper :: Id -> EvVar -> HsWrapper
mk_op_wrapper sel_id rep_d
= WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
<.> WpEvApp (EvId rep_d)
<.> mkWpTyApps (init_inst_tys ++ [rep_ty])
where
(sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
(_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
`orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
= do { uniq <- newUnique
; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
; local_meth_name <- newLocalName sel_name
; let meth_id = mkLocalId meth_name meth_ty
local_meth_id = mkLocalId local_meth_name local_meth_ty
; return (meth_id, local_meth_id) }
where
local_meth_ty = instantiateMethod clas sel_id inst_tys
meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
sel_name = idName sel_id
wrapId :: HsWrapper -> id -> HsExpr id
wrapId wrapper id = mkHsWrap wrapper (HsVar id)
derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
derivBindCtxt sel_id clas tys _bind
= vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
, nest 2 (ptext (sLit "in a standalone derived instance for")
<+> quotes (pprClassPred clas tys) <> colon)
, nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
warnMissingMethod :: Id -> TcM ()
warnMissingMethod sel_id
= do { warn <- doptM Opt_WarnMissingMethods
; warnTc (warn
&& not (startsWithUnderscore (getOccName sel_id)))
(ptext (sLit "No explicit method nor default method for")
<+> quotes (ppr sel_id)) }
\end{code}
Note [Export helper functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We arrange to export the "helper functions" of an instance declaration,
so that they are not subject to preInlineUnconditionally, even if their
RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
the dict fun as Ids, not as CoreExprs, so we can't substitute a
non-variable for them.
We could change this by making DFunUnfoldings have CoreExprs, but it
seems a bit simpler this way.
Note [Default methods in instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
class Baz v x where
foo :: x -> x
foo y =
instance Baz Int Int
From the class decl we get
$dmfoo :: forall v x. Baz v x => x -> x
$dmfoo y =
Notice that the type is ambiguous. That's fine, though. The instance
decl generates
$dBazIntInt = MkBaz fooIntInt
fooIntInt = $dmfoo Int Int $dBazIntInt
BUT this does mean we must generate the dictionary translation of
fooIntInt directly, rather than generating source-code and
type-checking it. That was the bug in Trac #1061. In any case it's
less work to generate the translated version!
Note [INLINE and default methods]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Default methods need special case. They are supposed to behave rather like
macros. For exmample
class Foo a where
op1, op2 :: Bool -> a -> a
{-# INLINE op1 #-}
op1 b x = op2 (not b) x
instance Foo Int where
-- op1 via default method
op2 b x =
The instance declaration should behave
just as if 'op1' had been defined with the
code, and INLINE pragma, from its original
definition.
That is, just as if you'd written
instance Foo Int where
op2 b x =
{-# INLINE op1 #-}
op1 b x = op2 (not b) x
So for the above example we generate:
{-# INLINE $dmop1 #-}
-- $dmop1 has an InlineCompulsory unfolding
$dmop1 d b x = op2 d (not b) x
$fFooInt = MkD $cop1 $cop2
{-# INLINE $cop1 #-}
$cop1 = $dmop1 $fFooInt
$cop2 =
Note carefullly:
* We *copy* any INLINE pragma from the default method $dmop1 to the
instance $cop1. Otherwise we'll just inline the former in the
latter and stop, which isn't what the user expected
* Regardless of its pragma, we give the default method an
unfolding with an InlineCompulsory source. That means
that it'll be inlined at every use site, notably in
each instance declaration, such as $cop1. This inlining
must happen even though
a) $dmop1 is not saturated in $cop1
b) $cop1 itself has an INLINE pragma
It's vital that $dmop1 *is* inlined in this way, to allow the mutual
recursion between $fooInt and $cop1 to be broken
* To communicate the need for an InlineCompulsory to the desugarer
(which makes the Unfoldings), we use the IsDefaultMethod constructor
in TcSpecPrags.
%************************************************************************
%* *
\subsection{Error messages}
%* *
%************************************************************************
\begin{code}
instDeclCtxt1 :: LHsType Name -> SDoc
instDeclCtxt1 hs_inst_ty
= inst_decl_ctxt (case unLoc hs_inst_ty of
HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
HsPredTy pred -> ppr pred
_ -> ppr hs_inst_ty)
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 dfun_ty
= inst_decl_ctxt (ppr (mkClassPred cls tys))
where
(_,cls,tys) = tcSplitDFunTy dfun_ty
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
atInstCtxt :: Name -> SDoc
atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
quotes (ppr name)
mustBeVarArgErr :: Type -> SDoc
mustBeVarArgErr ty =
sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
ptext (sLit "must be variables")
, ptext (sLit "Instead of a variable, found") <+> ppr ty
]
wrongATArgErr :: Type -> Type -> SDoc
wrongATArgErr ty instTy =
sep [ ptext (sLit "Type indexes must match class instance head")
, ptext (sLit "Found") <+> quotes (ppr ty)
<+> ptext (sLit "but expected") <+> quotes (ppr instTy)
]
\end{code}