X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=0ffc466e53f74b28b7832270a8df148bf2227d9f;hp=f84f3d52d46a4b8ea48c1a340e87fa8d3b99c795;hb=2a26efb65343e31957b043f63c43caf24d5eeb30;hpb=3e0a7b9fbc16e432efa562df027d189fa274943a diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index f84f3d5..0ffc466 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -13,7 +13,6 @@ import TcBinds import TcTyClsDecls import TcClassDcl import TcPat( addInlinePrags ) -import TcSimplify( simplifyTop ) import TcRnMonad import TcMType import TcType @@ -371,7 +370,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; 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 } @@ -398,12 +397,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- 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) }}} @@ -621,7 +626,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) 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 @@ -633,20 +638,19 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; 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) @@ -693,12 +697,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) 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 @@ -708,23 +711,17 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) 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 = in sc_dict - -- where 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) @@ -863,7 +860,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty) ; (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 @@ -926,10 +923,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ---------------------- 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