tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
TyVarDetails(..)
)
-import Inst ( InstOrigin(..), newMethod, newMethodAtLoc,
- newDicts, instToId, showLIE )
+import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId, showLIE )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv,
tcLookupClass, tcExtendTyVarEnv2,
import Class ( Class, classBigSig )
import Var ( idName, idType )
import NameSet
-import Id ( setIdLocalExported )
import MkId ( mkDictFunId, rUNTIME_ERROR_ID )
import FunDeps ( checkInstFDs )
import Generics ( validGenericInstanceType )
in
checkValidTheta InstThetaCtxt theta `thenM_`
checkAmbiguity tyvars theta (tyVarsOfType tau) `thenM_`
- checkValidInstHead tau `thenM` \ (clas,inst_tys) ->
+ checkValidInstHead tau `thenM` \ (clas,inst_tys) ->
checkTc (checkInstFDs theta clas inst_tys)
(instTypeErr (pprClassPred clas inst_tys) msg) `thenM_`
newDFunName clas inst_tys src_loc `thenM` \ dfun_name ->
addSrcLoc (getSrcLoc dfun_id) $
addErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $
let
- inst_ty = idType dfun_id
+ inst_ty = idType dfun_id
(inst_tyvars, _) = tcSplitForAllTys inst_ty
-- The tyvars of the instance decl scope over the 'where' part
-- Those tyvars are inside the dfun_id's type, which is a bit
-- Create the result bindings
let
- local_dfun_id = setIdLocalExported dfun_id
- -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
-
dict_constr = classDataCon clas
scs_and_meths = map instToId sc_dicts ++ meth_ids
this_dict_id = instToId this_dict
main_bind = AbsBinds
zonked_inst_tyvars
(map instToId dfun_arg_dicts)
- [(inst_tyvars', local_dfun_id, this_dict_id)]
+ [(inst_tyvars', dfun_id, this_dict_id)]
inlines all_binds
in
- showLIE "instance" `thenM_`
+ showLIE (text "instance") `thenM_`
returnM (main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer)
mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_`
-- Make the method bindings
- mapAndUnzipM do_one op_items `thenM` \ (meth_ids, meth_binds_s) ->
+ let
+ mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds
+ in
+ mapAndUnzipM mk_method_bind op_items `thenM` \ (meth_insts, meth_infos) ->
+
+ -- And type check them
+ -- It's really worth making meth_insts available to the tcMethodBind
+ -- Consider instance Monad (ST s) where
+ -- {-# INLINE (>>) #-}
+ -- (>>) = ...(>>=)...
+ -- If we don't include meth_insts, we end up with bindings like this:
+ -- rec { dict = MkD then bind ...
+ -- then = inline_me (... (GHC.Base.>>= dict) ...)
+ -- bind = ... }
+ -- The trouble is that (a) 'then' and 'dict' are mutually recursive,
+ -- and (b) the inline_me prevents us inlining the >>= selector, which
+ -- would unravel the loop. Result: (>>) ends up as a loop breaker, and
+ -- is not inlined across modules. Rather ironic since this does not
+ -- happen without the INLINE pragma!
+ --
+ -- Solution: make meth_insts available, so that 'then' refers directly
+ -- to the local 'bind' rather than going via the dictionary.
+ --
+ -- BUT WATCH OUT! If the method type mentions the class variable, then
+ -- this optimisation is not right. Consider
+ -- class C a where
+ -- op :: Eq a => a
+ --
+ -- instance C Int where
+ -- op = op
+ -- The occurrence of 'op' on the rhs gives rise to a constraint
+ -- op at Int
+ -- The trouble is that the 'meth_inst' for op, which is 'available', also
+ -- looks like 'op at Int'. But they are not the same.
+ let
+ all_insts = avail_insts ++ catMaybes meth_insts
+ xtve = inst_tyvars `zip` inst_tyvars'
+ tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags
+ in
+ mapM tc_method_bind meth_infos `thenM` \ meth_binds_s ->
- returnM (meth_ids, andMonoBindList meth_binds_s)
+ returnM ([meth_id | (_,meth_id,_) <- meth_infos],
+ andMonoBindList meth_binds_s)
- where
- xtve = inst_tyvars `zip` inst_tyvars'
- do_one op_item
- = mkMethodBind InstanceDeclOrigin clas
- inst_tys' monobinds op_item `thenM` \ (meth_inst, meth_info) ->
- tcMethodBind xtve inst_tyvars' dfun_theta'
- avail_insts uprags meth_info `thenM` \ meth_bind ->
- -- Could add meth_insts to avail_insts, but not worth the bother
- returnM (instToId meth_inst, meth_bind)
-- Derived newtype instances
tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
avail_insts op_items (NewTypeDerived rep_tys)
- = getInstLoc InstanceDeclOrigin `thenM` \ inst_loc ->
- getLIE (mapAndUnzipM (do_one inst_loc) op_items) `thenM` \ ((meth_ids, meth_binds), lie) ->
+ = getInstLoc InstanceDeclOrigin `thenM` \ inst_loc ->
+ mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) ->
tcSimplifyCheck
(ptext SLIT("newtype derived instance"))
- inst_tyvars' avail_insts lie `thenM` \ lie_binds ->
+ inst_tyvars' avail_insts rhs_insts `thenM` \ lie_binds ->
-- I don't think we have to do the checkSigTyVars thing
where
do_one inst_loc (sel_id, _)
- = newMethodAtLoc inst_loc sel_id inst_tys' `thenM` \ meth_inst ->
- -- Like in mkMethodBind
- newMethod InstanceDeclOrigin sel_id rep_tys' `thenM` \ rhs_id ->
- -- The binding is like "op @ NewTy = op @ RepTy"
+ = -- The binding is like "op @ NewTy = op @ RepTy"
+ -- Make the *binder*, like in mkMethodBind
+ tcInstClassOp inst_loc sel_id inst_tys' `thenM` \ meth_inst ->
+
+ -- Make the *occurrence on the rhs*
+ tcInstClassOp inst_loc sel_id rep_tys' `thenM` \ rhs_inst ->
let
meth_id = instToId meth_inst
in
- return (meth_id, VarMonoBind meth_id (HsVar rhs_id))
+ return (meth_id, VarMonoBind meth_id (HsVar (instToId rhs_inst)), rhs_inst)
-- Instantiate rep_tys with the relevant type variables
rep_tys' = map (substTy subst) rep_tys
projects / ghc-hetmet.git / blobdiff