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
}
-- NB: class instance declarations can contain derivings as
-- part of associated data type declarations
failIfErrsM -- If the addInsts stuff gave any errors, don't
- -- try the deriving stuff, becuase that may give
+ -- try the deriving stuff, because that may give
-- more errors still
- ; (deriv_inst_info, deriv_binds, deriv_dus)
+ ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts)
<- tcDeriving tycl_decls inst_decls deriv_decls
- ; gbl_env <- addInsts deriv_inst_info getGblEnv
- ; return ( addTcgDUs gbl_env deriv_dus,
+
+ -- Extend the global environment also with the generated datatypes for
+ -- the generic representation
+ ; gbl_env <- addFamInsts (map ATyCon deriv_ty_insts) $
+ tcExtendGlobalEnv (map ATyCon (deriv_tys ++ deriv_ty_insts)) $
+ addInsts deriv_inst_info getGblEnv
+-- ; traceTc "Generic deriving" (vcat (map pprInstInfo deriv_inst_info))
+ ; return ( addTcgDUs gbl_env deriv_dus,
generic_inst_info ++ deriv_inst_info ++ local_info,
aux_binds `plusHsValBinds` deriv_binds)
}}}
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]
- ; spec_info <- tcSpecInstPrags dfun_id ibinds
+ ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
-- Typecheck the methods
; (meth_ids, meth_binds)
main_bind = AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
, abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
- SpecPrags [] {- spec_inst_prags -})]
+ SpecPrags spec_inst_prags)]
, abs_ev_binds = emptyTcEvBinds
, 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
----------------------
tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+
+ -- JPM: This is probably not that simple...
+ tc_default sel_id (GenDefMeth dm_name) = tc_default sel_id (DefMeth dm_name)
+{-
tc_default sel_id GenDefMeth -- Derivable type classes stuff
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
; tc_body sel_id False {- Not generated code? -} meth_bind }
-
+-}
tc_default sel_id NoDefMeth -- No default method at all
= do { warnMissingMethod sel_id
; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
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
projects / ghc-hetmet.git / blobdiff