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]
, 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)
; (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