- -----------------------
- -- 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>)
- -- 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
-
- make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
- | Just co_con <- newTyConCo_maybe nt_tycon
- , let co = mkSymCoercion (mkTyConApp co_con tc_args)
- = WpCo (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co]))
- | otherwise -- The newtype is transparent; no need for a cast
- = idHsWrapper
-
- -----------------------
- -- (make_body C tys scs coreced_rep_dict)
- -- returns
- -- (case coerced_rep_dict of { C _ ops -> C scs ops })
- -- But if there are no superclasses, it returns just coerced_rep_dict
- -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
-
- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
- | null sc_dicts -- Case (a)
- = return coerced_rep_dict
- | otherwise -- Case (b)
- = do { op_ids <- newSysLocalIds FSLIT("op") op_tys
- ; dummy_sc_dict_ids <- newSysLocalIds FSLIT("sc") (map idType sc_dict_ids)
- ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
- pat_dicts = dummy_sc_dict_ids,
- pat_binds = emptyLHsBinds,
- pat_args = PrefixCon (map nlVarPat op_ids),
- pat_ty = pat_ty}
- the_match = mkSimpleMatch [noLoc the_pat] the_rhs
- the_rhs = mkHsConApp cls_data_con cls_inst_tys $
- map HsVar (sc_dict_ids ++ op_ids)
-
- -- Warning: this HsCase scrutinises a value with a PredTy, which is
- -- never otherwise seen in Haskell source code. It'd be
- -- nicer to generate Core directly!
- ; return (HsCase (noLoc coerced_rep_dict) $
- MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
- where
- sc_dict_ids = map instToId sc_dicts
- pat_ty = mkTyConApp cls_tycon cls_inst_tys
- cls_data_con = head (tyConDataCons cls_tycon)
- cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
- op_tys = dropList sc_dict_ids cls_arg_tys
-
-------------------------
--- Ordinary instances
-
-tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
- = let
- dfun_id = instanceDFunId ispec
- rigid_info = InstSkol
- inst_ty = idType dfun_id
- loc = srcLocSpan (getSrcLoc dfun_id)
- in
- -- Prime error recovery
- recoverM (returnM emptyLHsBinds) $
- setSrcSpan loc $
- 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
- (eq_sc_theta',dict_sc_theta') = partition isEqPred sc_theta'
- origin = SigOrigin rigid_info
- (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
- in
- -- Create dictionary Ids from the specified instance contexts.
- getInstLoc InstScOrigin `thenM` \ sc_loc ->
- newDictBndrs sc_loc dict_sc_theta' `thenM` \ sc_dicts ->
- getInstLoc origin `thenM` \ inst_loc ->
- mkMetaCoVars eq_sc_theta' `thenM` \ sc_covars ->
- mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars) `thenM` \ wanted_sc_eqs ->
- mkCoVars eq_dfun_theta' `thenM` \ dfun_covars ->
- mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars) `thenM` \ dfun_eqs ->
- newDictBndrs inst_loc dict_dfun_theta' `thenM` \ dfun_dicts ->
- newDictBndr inst_loc (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?
- dfun_insts = dfun_eqs ++ dfun_dicts
- wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
- given_sc_eqs = map (updateEqInstCoercion (mkGivenCo . TyVarTy . fromWantedCo "tcInstDecl2") ) wanted_sc_eqs
- given_sc_insts = given_sc_eqs ++ sc_dicts
- avail_insts = [this_dict] ++ dfun_insts ++ given_sc_insts
- 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
- -- wanted_sc_insts get bound by just selecting from this_dict!!
- addErrCtxt superClassCtxt
- (tcSimplifySuperClasses inst_loc
- dfun_insts wanted_sc_insts) `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 uprags) `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_insts = []
- | otherwise = [L loc (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' ++ mkTyVarTys sc_covars) (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' ++ dfun_covars)
- (map instToId dfun_dicts)
- [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
- all_binds
- in
- showLIE (text "instance") `thenM_`
- returnM (unitBag main_bind)
-
-mkCoVars :: [PredType] -> TcM [TyVar]
-mkCoVars [] = return []
-mkCoVars (pred:preds) =
- do { uniq <- newUnique
- ; let name = mkSysTvName uniq FSLIT("mkCoVars")
- ; let tv = mkCoVar name (PredTy pred)
- ; tvs <- mkCoVars preds
- ; return (tv:tvs)
- }
-
-mkMetaCoVars :: [PredType] -> TcM [TyVar]
-mkMetaCoVars [] = return []
-mkMetaCoVars (EqPred ty1 ty2:preds) =
- do { tv <- newMetaTyVar TauTv (mkCoKind ty1 ty2)
- ; tvs <- mkMetaCoVars preds
- ; return (tv:tvs)
- }
-
-
-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)
+ loc = getSrcSpan dfun_id
+
+ inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
+ Just (init_inst_tys, _) = snocView inst_tys
+ rep_ty = fst (coercionKind co) -- [p]
+ rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
+
+ -- co : [p] ~ T p
+ 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
+ -- Base the local_meth_name on the selector name, becuase
+ -- type errors from tcInstanceMethodBody come from here
+
+ ; 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") ]
+
+-- Too voluminous
+-- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
+
+warnMissingMethod :: Id -> TcM ()
+warnMissingMethod sel_id
+ = do { warn <- doptM Opt_WarnMissingMethods
+ ; warnTc (warn -- Warn only if -fwarn-missing-methods
+ && not (startsWithUnderscore (getOccName sel_id)))
+ -- Don't warn about _foo methods
+ (ptext (sLit "No explicit method nor default method for")
+ <+> quotes (ppr sel_id)) }