--- So all need is to generate a binding looking like
--- dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a)
--- dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
--- case df `cast` (Foo Int (CoT a)) of
--- Foo _ op1 .. opn -> Foo ds op1 .. opn
-
-tcInstDecl2 (InstInfo { iSpec = ispec,
- iBinds = NewTypeDerived tycon rep_tys })
- = do { let dfun_id = instanceDFunId ispec
- rigid_info = InstSkol dfun_id
- origin = SigOrigin rigid_info
- inst_ty = idType dfun_id
- maybe_co_con = newTyConCo tycon
- ; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
- ; dicts <- newDicts origin theta
- ; uniqs <- newUniqueSupply
- ; let (rep_dict_id:sc_dict_ids) = map instToId dicts
- -- (Here, wee are relying on the order of dictionary
- -- arguments built by NewTypeDerived in TcDeriv.)
-
- wrap_fn = CoTyLams tvs <.> CoLams dict_ids
-
- coerced_rep_dict = mkHsCoerce co_fn (HsVar rep_dict_id)
-
- body | null sc_dicts = coerced_rep_dict
- | otherwise = HsCase coerced_rep_dict $
- MatchGroup [the_match] inst_head
- the_match = mkSimpleMatch [the_pat] the_rhs
- op_ids = zipWith (mkSysLocal FSLIT("op"))
- (uniqsFromSupply uniqs) op_tys
- the_pat = ConPatOut { pat_con = cls_data_con, pat_tvs = [],
- pat_dicts = map (WildPat . idType) sc_dict_ids,
- pat_binds = emptyDictBinds,
- pat_args = PrefixCon (map VarPat op_ids),
- pat_ty = <type of pattern> }
- the_rhs = mkHsApps (dataConWrapId cls_data_con) types sc_dict_ids (map HsVar op_ids)
-
- ; return (unitBag (VarBind dfun_id (mkHsCoerce wrap_fn body))) }
- where
- co_fn :: ExprCoFn
- co_fn | Just co_con <- newTyConCo tycon
- = ExprCoFn (mkAppCoercion (mkAppsCoercion tycon rep_tys)
- (mkTyConApp co_con tvs))
- | otherwise
- = idCoerecion
-
-tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
- avail_insts op_items (NewTypeDerived rep_tys)
- = getInstLoc origin `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 rhs_insts `thenM` \ lie_binds ->
-
- -- I don't think we have to do the checkSigTyVars thing
-
- returnM (meth_ids, lie_binds `unionBags` listToBag meth_binds)
-
- where
- do_one inst_loc (sel_id, _)
- = -- 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, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst)
-
- -- Instantiate rep_tys with the relevant type variables
- -- This looks a bit odd, because inst_tyvars' are the skolemised version
- -- of the type variables in the instance declaration; but rep_tys doesn't
- -- have the skolemised version, so we substitute them in here
- rep_tys' = substTys subst rep_tys
- subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars')
-
-
-
-tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
- = let
- dfun_id = instanceDFunId ispec
- rigid_info = InstSkol dfun_id
- inst_ty = idType dfun_id
- in
- -- Prime error recovery
- recoverM (returnM emptyLHsBinds) $
- setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $
- addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
-
- -- Instantiate the instance decl with skolem constants
- tcSkolSigType rigid_info inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
- -- These inst_tyvars' scope over the 'where' part
- -- Those tyvars are inside the dfun_id's type, which is a bit
- -- bizarre, but OK so long as you realise it!
- let
- (clas, inst_tys') = tcSplitDFunHead inst_head'
- (class_tyvars, sc_theta, _, op_items) = classBigSig clas
-
- -- Instantiate the super-class context with inst_tys
- sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
- origin = SigOrigin rigid_info
- in
- -- Create dictionary Ids from the specified instance contexts.
- newDicts InstScOrigin sc_theta' `thenM` \ sc_dicts ->
- newDicts origin dfun_theta' `thenM` \ dfun_arg_dicts ->
- newDicts origin [mkClassPred clas inst_tys'] `thenM` \ [this_dict] ->
- -- 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?
- avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
- in
- tcMethods origin clas inst_tyvars'
- dfun_theta' inst_tys' avail_insts
- op_items monobinds uprags `thenM` \ (meth_ids, meth_binds) ->
-
- -- Figure out bindings for the superclass context
- -- Don't include this_dict in the 'givens', else
- -- sc_dicts get bound by just selecting from this_dict!!
- addErrCtxt superClassCtxt
- (tcSimplifySuperClasses inst_tyvars'
- dfun_arg_dicts
- sc_dicts) `thenM` \ sc_binds ->
-
- -- It's possible that the superclass stuff might unified one
- -- of the inst_tyavars' with something in the envt
- checkSigTyVars inst_tyvars' `thenM_`
-
- -- Deal with 'SPECIALISE instance' pragmas
- tcPrags dfun_id (filter isSpecInstLSig prags) `thenM` \ prags ->
-
- -- Create the result bindings
- let
- dict_constr = classDataCon clas
- scs_and_meths = map instToId sc_dicts ++ meth_ids
- this_dict_id = instToId this_dict
- inline_prag | null dfun_arg_dicts = []
- | otherwise = [InlinePrag (Inline AlwaysActive True)]
- -- Always inline the dfun; this is an experimental decision
- -- because it makes a big performance difference sometimes.
- -- Often it means we can do the method selection, and then
- -- inline the method as well. Marcin's idea; see comments below.
- --
- -- BUT: don't inline it if it's a constant dictionary;
- -- we'll get all the benefit without inlining, and we get
- -- a **lot** of code duplication if we inline it
- --
- -- See Note [Inline dfuns] below
-
- dict_rhs
- = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
- -- 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
- -- it means that the special cases (e.g. dictionary with only one
- -- 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)
- all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
-
- main_bind = noLoc $ AbsBinds
- inst_tyvars'
- (map instToId dfun_arg_dicts)
- [(inst_tyvars', dfun_id, this_dict_id,
- inline_prag ++ prags)]
- all_binds
- in
- showLIE (text "instance") `thenM_`
- returnM (unitBag main_bind)
-
-
-tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
- avail_insts op_items monobinds uprags
- = -- Check that all the method bindings come from this class
- let
- sel_names = [idName sel_id | (sel_id, _) <- op_items]
- bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
- in
- mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_`
-
- -- Make the method bindings
- let
- mk_method_bind = mkMethodBind origin 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
- prag_fn = mkPragFun uprags
- all_insts = avail_insts ++ catMaybes meth_insts
- sig_fn n = Just [] -- No scoped type variables, but every method has
- -- a type signature, in effect, so that we check
- -- the method has the right type
- tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts sig_fn prag_fn
- meth_ids = [meth_id | (_,meth_id,_) <- meth_infos]
- in
-
- mapM tc_method_bind meth_infos `thenM` \ meth_binds_s ->
-
- returnM (meth_ids, unionManyBags meth_binds_s)
-v v v v v v v
-*************
-
-
--- Derived newtype instances
-tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
- avail_insts op_items (NewTypeDerived maybe_co rep_tys)
- = getInstLoc origin `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 rhs_insts `thenM` \ lie_binds ->
-
- -- I don't think we have to do the checkSigTyVars thing
-
- returnM (meth_ids, lie_binds `unionBags` listToBag meth_binds)