X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=0b4f8b028520291f6638a36698bc094a12ab0a88;hb=2a8cdc3aee5997374273e27365f92c161aca8453;hp=1be9ffc8b8c8b80e9768d0632cb010306f109f0f;hpb=171d4582f4b9a8e0f11f8738079accbb22bafdcb;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 1be9ffc..0b4f8b0 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -24,7 +24,7 @@ import Inst ( newDictBndr, newDictBndrs, instToId, showLIE, getOverlapFlag, tcExtendLocalInstEnv ) import InstEnv ( mkLocalInstance, instanceDFunId ) import FamInst ( tcExtendLocalFamInstEnv ) -import FamInstEnv ( extractFamInsts ) +import FamInstEnv ( mkLocalFamInst ) import TcDeriv ( tcDeriving ) import TcEnv ( InstInfo(..), InstBindings(..), newDFunName, tcExtendIdEnv, tcExtendGlobalEnv @@ -37,7 +37,7 @@ import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy, substTys, emptyTvSubst, extendTvSubst ) import Coercion ( mkSymCoercion ) import TyCon ( TyCon, tyConName, newTyConCo_maybe, tyConTyVars, - isTyConAssoc, tyConFamInst_maybe, + isTyConAssoc, tyConFamInst_maybe, tyConDataCons, assocTyConArgPoss_maybe ) import DataCon ( classDataCon, dataConInstArgTys ) import Class ( Class, classTyCon, classBigSig, classATs ) @@ -146,12 +146,13 @@ Gather up the instance declarations from their various sources tcInstDecls1 -- Deal with both source-code and imported instance decls :: [LTyClDecl Name] -- For deriving stuff -> [LInstDecl Name] -- Source code instance decls + -> [LDerivDecl Name] -- Source code stand-alone deriving decls -> TcM (TcGblEnv, -- The full inst env [InstInfo], -- Source-code instance decls to process; -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances -tcInstDecls1 tycl_decls inst_decls +tcInstDecls1 tycl_decls inst_decls deriv_decls = checkNoErrs $ do { -- Stop if addInstInfos etc discovers any errors -- (they recover, so that we get more than one error each @@ -190,7 +191,7 @@ tcInstDecls1 tycl_decls inst_decls -- (4) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance -- decl, so it needs to know about all the instances possible - ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls + ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls deriv_decls ; addInsts deriv_inst_info $ do { ; gbl_env <- getGblEnv @@ -226,7 +227,11 @@ addInsts infos thing_inside addFamInsts :: [TyThing] -> TcM a -> TcM a addFamInsts tycons thing_inside - = tcExtendLocalFamInstEnv (extractFamInsts tycons) thing_inside + = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside + where + mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon + mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts" + (ppr tything) \end{code} \begin{code} @@ -469,7 +474,7 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) -- Returns a binding for the dfun ------------------------ --- Derived newtype instances +-- Derived newtype instances; surprisingly tricky! -- -- In the case of a newtype, things are rather easy -- class Show a => Foo a b where ... @@ -496,19 +501,20 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) -- inst_head_ty is a PredType ; inst_loc <- getInstLoc origin - ; (rep_dict_id : sc_dict_ids, wrap_fn) + ; (rep_dict_id : sc_dict_ids, wrap_fn, sc_binds) <- make_wrapper inst_loc tvs theta mb_preds -- Here, we are relying on the order of dictionary -- arguments built by NewTypeDerived in TcDeriv; -- namely, that the rep_dict_id comes first ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty - the_coercion = make_coercion cls cls_inst_tys - coerced_rep_dict = mkHsCoerce the_coercion (HsVar rep_dict_id) + cls_tycon = classTyCon cls + the_coercion = make_coercion cls_tycon cls_inst_tys + coerced_rep_dict = mkHsWrap the_coercion (HsVar rep_dict_id) - ; body <- make_body cls cls_inst_tys inst_head_ty sc_dict_ids coerced_rep_dict + ; body <- make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict - ; return (unitBag (noLoc $ VarBind dfun_id $ noLoc $ mkHsCoerce wrap_fn body)) } + ; return (sc_binds `snocBag` (noLoc $ VarBind dfun_id $ noLoc $ mkHsWrap wrap_fn body)) } where ----------------------- @@ -523,12 +529,15 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) make_wrapper inst_loc tvs theta (Just preds) -- Case (a) = ASSERT( null tvs && null theta ) do { dicts <- newDictBndrs inst_loc preds - ; extendLIEs dicts - ; return (map instToId dicts, idCoercion) } + ; sc_binds <- addErrCtxt superClassCtxt (tcSimplifySuperClasses [] [] dicts) + -- Use tcSimplifySuperClasses to avoid creating loops, for the + -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify + ; return (map instToId dicts, idHsWrapper, sc_binds) } + make_wrapper inst_loc tvs theta Nothing -- Case (b) = do { dicts <- newDictBndrs inst_loc theta ; let dict_ids = map instToId dicts - ; return (dict_ids, mkCoTyLams tvs <.> mkCoLams dict_ids) } + ; return (dict_ids, mkWpTyLams tvs <.> mkWpLams dict_ids, emptyBag) } ----------------------- -- make_coercion @@ -539,16 +548,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) -- So we just replace T with CoT, and insert a 'sym' -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced - make_coercion cls cls_inst_tys + make_coercion cls_tycon cls_inst_tys | Just (all_tys_but_last, last_ty) <- snocView cls_inst_tys , (tycon, tc_args) <- tcSplitTyConApp last_ty -- Should not fail , Just co_con <- newTyConCo_maybe tycon , let co = mkSymCoercion (mkTyConApp co_con tc_args) - = ExprCoFn (mkTyConApp cls_tycon (all_tys_but_last ++ [co])) + = WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co])) | otherwise -- The newtype is transparent; no need for a cast - = idCoercion - where - cls_tycon = classTyCon cls + = idHsWrapper ----------------------- -- make_body @@ -556,7 +563,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) -- (a) no superclasses; then we can just use the coerced dict -- (b) one or more superclasses; then new need to do the unpack/repack - make_body cls cls_inst_tys inst_head_ty sc_dict_ids coerced_rep_dict + make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict | null sc_dict_ids -- Case (a) = return coerced_rep_dict | otherwise -- Case (b) @@ -566,7 +573,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) pat_dicts = dummy_sc_dict_ids, pat_binds = emptyLHsBinds, pat_args = PrefixCon (map nlVarPat op_ids), - pat_ty = inst_head_ty} + pat_ty = pat_ty} the_match = mkSimpleMatch [noLoc the_pat] the_rhs the_rhs = mkHsConApp cls_data_con cls_inst_tys $ map HsVar (sc_dict_ids ++ op_ids) @@ -575,9 +582,10 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) -- never otherwise seen in Haskell source code. It'd be -- nicer to generate Core directly! ; return (HsCase (noLoc coerced_rep_dict) $ - MatchGroup [the_match] (mkFunTy inst_head_ty inst_head_ty)) } + MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) } where - cls_data_con = classDataCon cls + pat_ty = mkTyConApp cls_tycon cls_inst_tys + cls_data_con = head (tyConDataCons cls_tycon) cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys op_tys = dropList sc_dict_ids cls_arg_tys