- let -- These insts are in scope; quite a few, eh?
- dfun_insts = dfun_eqs ++ dfun_dicts
- wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
- this_dict_id = instToId this_dict
- sc_dict_ids = map instToId sc_dicts
- dfun_dict_ids = map instToId dfun_dicts
- prag_fn = mkPragFun uprags
- tc_meth = tcInstanceMethod loc clas inst_tyvars'
- (dfun_covars ++ dfun_dict_ids)
- dfun_theta' inst_tys'
- this_dict_id
- monobinds prag_fn
- (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items
-
- -- 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!!
- sc_binds <- addErrCtxt superClassCtxt
- (tcSimplifySuperClasses inst_loc dfun_insts wanted_sc_insts)
-
- -- It's possible that the superclass stuff might unified one
- -- of the inst_tyavars' with something in the envt
- checkSigTyVars inst_tyvars'
-
- -- Deal with 'SPECIALISE instance' pragmas
- prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
-
- -- Create the result bindings
- let
- dict_constr = classDataCon clas
- 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 sc_dict_ids ++ meth_exprs)
- -- 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)
-
- main_bind = noLoc $ AbsBinds
- (inst_tyvars' ++ dfun_covars)
- dfun_dict_ids
- [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
- (dict_bind `consBag` sc_binds)
-
- showLIE (text "instance")
- return (main_bind `consBag` unionManyBags meth_binds)
-
-mkCoVars :: [PredType] -> TcM [TyVar]
-mkCoVars = newCoVars . map unEqPred
- where
- unEqPred (EqPred ty1 ty2) = (ty1, ty2)
- unEqPred _ = panic "TcInstDcls.mkCoVars"
-
-mkMetaCoVars :: [PredType] -> TcM [TyVar]
-mkMetaCoVars = mapM eqPredToCoVar
- where
- eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
- eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
+ ; let this_dict_id = instToId this_dict
+ dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
+ prag_fn = mkPragFun uprags
+ loc = getSrcSpan dfun_id
+ tc_meth = tcInstanceMethod loc clas inst_tyvars'
+ dfun_dicts
+ dfun_theta' inst_tys'
+ this_dict dfun_id
+ prag_fn monobinds
+ ; (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $
+ mapAndUnzipM tc_meth op_items
+
+ -- 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!!
+ ; sc_binds <- addErrCtxt superClassCtxt $
+ tcSimplifySuperClasses inst_loc this_dict dfun_dicts sc_dicts
+ -- Note [Recursive superclasses]
+
+ -- It's possible that the superclass stuff might unified something
+ -- in the envt with one of the inst_tyvars'
+ ; checkSigTyVars inst_tyvars'
+
+ -- Deal with 'SPECIALISE instance' pragmas
+ ; prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
+
+ -- Create the result bindings
+ ; let dict_constr = classDataCon clas
+ inline_prag | null dfun_dicts = []
+ | otherwise = [L loc (InlinePrag (alwaysInlineSpec FunLike))]
+ -- 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
+
+ sc_dict_vars = map instToVar sc_dicts
+ dict_bind = L loc (VarBind this_dict_id dict_rhs)
+ dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs
+ inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys')
+ (dataConWrapId dict_constr)
+ -- 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.
+
+
+ main_bind = noLoc $ AbsBinds
+ inst_tyvars'
+ dfun_lam_vars
+ [(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)]
+ (dict_bind `consBag` sc_binds)
+
+ ; showLIE (text "instance")
+ ; return (main_bind `consBag` unionManyBags meth_binds) }