- -----------------------
- -- make_wrapper
- -- We distinguish two cases:
- -- (a) there is no tyvar abstraction in the dfun, so all dicts are constant,
- -- and the new dict can just be a constant
- -- (mb_preds = Just preds)
- -- (b) there are tyvars, so we must make a dict *fun*
- -- (mb_preds = Nothing)
- -- See the defn of NewTypeDerived for the meaning of mb_preds
- make_wrapper inst_loc tvs theta (Just preds) -- Case (a)
- = ASSERT( null tvs && null theta )
- do { dicts <- newDictBndrs inst_loc preds
- ; sc_binds <- addErrCtxt superClassCtxt $
- tcSimplifySuperClasses inst_loc [] dicts
- -- Use tcSimplifySuperClasses to avoid creating loops, for the
- -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify
- ; return (map instToId dicts, idHsWrapper, sc_binds) }
-
- make_wrapper inst_loc tvs theta Nothing -- Case (b)
- = do { dicts <- newDictBndrs inst_loc theta
- ; let dict_ids = map instToId dicts
- ; return (dict_ids, mkWpTyLams tvs <.> mkWpLams dict_ids, emptyBag) }
-
- -----------------------
- -- 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 cls_inst_tys
- | Just (all_tys_but_last, last_ty) <- snocView cls_inst_tys
- , (tycon, tc_args) <- tcSplitTyConApp last_ty -- Should not fail
- , Just co_con <- newTyConCo_maybe tycon
- , let co = mkSymCoercion (mkTyConApp co_con tc_args)
- = WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co]))
- | otherwise -- The newtype is transparent; no need for a cast
- = idHsWrapper
-
- -----------------------
- -- make_body
- -- Two cases; see Note [Newtype deriving superclasses] in TcDeriv.lhs
- -- (a) no superclasses; then we can just use the coerced dict
- -- (b) one or more superclasses; then new need to do the unpack/repack
-
- make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
- | null sc_dict_ids -- 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
- 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
- origin = SigOrigin rigid_info
- in
- -- Create dictionary Ids from the specified instance contexts.
- getInstLoc InstScOrigin `thenM` \ sc_loc ->
- newDictBndrs sc_loc sc_theta' `thenM` \ sc_dicts ->
- getInstLoc origin `thenM` \ inst_loc ->
- newDictBndrs inst_loc dfun_theta' `thenM` \ dfun_arg_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?
- 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_loc
- 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 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_arg_dicts = []
- | 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' (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 ->