import TcTyClsDecls
import TcClassDcl
import TcPat( addInlinePrags )
-import TcSimplify( simplifyTop )
import TcRnMonad
import TcMType
import TcType
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
- ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
+ ; clas_decls = filter (isClassDecl . unLoc) tycl_decls
; implicit_things = concatMap implicitTyThings at_idx_tycons
; aux_binds = mkRecSelBinds at_idx_tycons
}
setSrcSpan loc $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do { -- Instantiate the instance decl with skolem constants
- ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id)
+ ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
; orig_ev_vars <- newEvVars orig_theta
; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
- ; (sc_binds, sc_dicts, sc_args)
- <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
+ ; (sc_dicts, sc_args)
+ <- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
-- Check that any superclasses gotten from a silent arguemnt
-- can be deduced from the originally-specified dfun arguments
; ct_loc <- getCtLoc ScOrigin
; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
- emitConstraints $ listToBag $
- [ WcEvVar (WantedEvVar sc ct_loc)
- | sc <- sc_dicts, isSilentEvVar sc ]
+ emitFlats $ listToBag $
+ [ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ]
-- Deal with 'SPECIALISE instance' pragmas
-- See Note [SPECIALISE instance pragmas]
op_items ibinds
-- Create the result bindings
- ; let dict_constr = classDataCon clas
- dict_bind = mkVarBind self_dict dict_rhs
- dict_rhs = foldl mk_app inst_constr $
- map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
- inst_constr = L loc $ wrapId (mkWpTyApps inst_tys)
- (dataConWrapId dict_constr)
+ ; self_dict <- newEvVar (ClassP clas inst_tys)
+ ; let class_tc = classTyCon clas
+ [dict_constr] = tyConDataCons class_tc
+ dict_bind = mkVarBind self_dict dict_rhs
+ dict_rhs = foldl mk_app inst_constr $
+ map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
+ inst_constr = L loc $ wrapId (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
-- member) are dealt with by the common MkId.mkDataConWrapId
-- code rather than needing to be repeated here.
- mk_app :: LHsExpr Id -> Id -> LHsExpr Id
- mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
- arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
+ mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id
+ mk_app fun arg = L loc (HsApp fun (L loc arg))
+
+ arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)
-- Do not inline the dfun; instead give it a magic DFunFunfolding
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
- dfun_id_w_fun = dfun_id
- `setIdUnfolding` mkDFunUnfolding inst_ty (map Var dict_and_meth_ids)
- -- Not right for equality superclasses
- `setInlinePragma` dfunInlinePragma
+ dfun_id_w_fun
+ | isNewTyCon class_tc
+ = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
+ | otherwise
+ = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args)
+ `setInlinePragma` dfunInlinePragma
+ meth_args = map (DFunPolyArg . Var) meth_ids
main_bind = AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
, abs_binds = unitBag dict_bind }
; return (unitBag (L loc main_bind) `unionBags`
- unionManyBags sc_binds `unionBags`
listToBag meth_binds)
}
where
loc = getSrcSpan dfun_id
------------------------------
-tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr)
+tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr)
+-- All superclasses should be either
+-- (a) be one of the arguments to the dfun, of
+-- (b) be a constant, soluble at top level
tcSuperClass n_ty_args ev_vars pred
| Just (ev, i) <- find n_ty_args ev_vars
- = return (emptyBag, ev, DFunLamArg i)
+ = return (ev, DFunLamArg i)
| otherwise
- = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)
- do { sc_dict <- newWantedEvVar pred
- ; loc <- getCtLoc ScOrigin
- ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc)))
- ; let ev_wrap = WpLet (EvBinds ev_binds)
- sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict))
- ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) }
- -- It's very important to solve the superclass constraint *in isolation*
- -- so that it isn't generated by superclass selection from something else
- -- We then generate the (also rather degenerate) top-level binding:
- -- sc_dict = let sc_dict = <blah> in sc_dict
- -- where <blah> is generated by solving the implication constraint
+ = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) -- Constant!
+ do { sc_dict <- emitWanted ScOrigin pred
+ ; return (sc_dict, DFunConstArg (Var sc_dict)) }
where
find _ [] = Nothing
find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
Although this looks wrong (assume D [a] to prove D [a]), it is only a
more extreme case of what happens with recursive dictionaries.
- ; uniq <- newUnique
- ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict)
- sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
- (getName sc_sel)
- sc_op_id = mkLocalId sc_op_name sc_op_ty
- sc_op_bind = VarBind { var_id = sc_op_id, var_inline = False
- , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict }
- sc_wrapper = mkWpTyLams tyvars
- <.> mkWpLams dicts
- <.> mkWpLet ev_binds
+To implement the dfun we must generate code for the superclass C [a],
+which we can get by superclass selection from the supplied argument!
+So we’d generate:
+ dfun :: forall a. D [a] -> D [a]
+ dfun = \d::D [a] -> MkD (scsel d) ..
However this means that if we later encounter a situation where
we have a [Wanted] dw::D [a] we could solve it thus:
; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
- ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
+ ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
(idType dfun_id) spec_dfun_ty
; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
where
instDeclCtxt2 dfun_ty
= inst_decl_ctxt (ppr (mkClassPred cls tys))
where
- (_,cls,tys) = tcSplitDFunTy dfun_ty
+ (_,_,cls,tys) = tcSplitDFunTy dfun_ty
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc