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,
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 ->
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.
+ let
+ all_insts = avail_insts ++ 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 (map instToId meth_insts, 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