From 138b885a335734039daf7debb0a7dfc3dc947c00 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:50:19 +0000 Subject: [PATCH] Basic set up for global family instance environment Mon Sep 18 19:52:34 EDT 2006 Manuel M T Chakravarty * Basic set up for global family instance environment Fri Sep 15 15:20:44 EDT 2006 Manuel M T Chakravarty * Basic set up for global family instance environment --- compiler/typecheck/TcInstDcls.lhs | 64 +++++++++++++++++------------------ compiler/typecheck/TcRnMonad.lhs | 2 ++ compiler/typecheck/TcRnTypes.lhs | 11 ++++-- compiler/typecheck/TcTyClsDecls.lhs | 16 ++++----- compiler/typecheck/TcType.lhs | 10 ++++-- 5 files changed, 56 insertions(+), 47 deletions(-) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index e186b36..6135ca2 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -22,6 +22,8 @@ import TcType ( TcType, mkClassPred, tcSplitSigmaTy, import Inst ( newDictBndr, newDictBndrs, instToId, showLIE, getOverlapFlag, tcExtendLocalInstEnv ) import InstEnv ( mkLocalInstance, instanceDFunId ) +import FamInst ( tcExtendLocalFamInstEnv ) +import FamInstEnv ( extractFamInsts ) import TcDeriv ( tcDeriving ) import TcEnv ( InstInfo(..), InstBindings(..), newDFunName, tcExtendIdEnv, tcExtendGlobalEnv @@ -160,22 +162,19 @@ tcInstDecls1 tycl_decls inst_decls -- types ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls } ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls - ; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls + ; idx_tycons <- mappM tcIdxTyInstDeclTL idxty_decls ; let { (local_infos, - local_tycons) = unzip local_info_tycons - ; (idxty_infos, - idxty_tycons) = unzip idxty_info_tycons - ; local_idxty_info = concat local_infos ++ catMaybes idxty_infos - ; local_idxty_tycon = concat local_tycons ++ - catMaybes idxty_tycons - ; clas_decls = filter (isClassDecl.unLoc) tycl_decls - ; implicit_things = concatMap implicitTyThings local_idxty_tycon + at_tycons) = unzip local_info_tycons + ; local_info = concat local_infos + ; at_idx_tycon = concat at_tycons ++ catMaybes idx_tycons + ; clas_decls = filter (isClassDecl.unLoc) tycl_decls + ; implicit_things = concatMap implicitTyThings at_idx_tycon } - -- (2) Add the tycons of associated types and their implicit + -- (2) Add the tycons of indexed types and their implicit -- tythings to the global environment - ; tcExtendGlobalEnv (local_idxty_tycon ++ implicit_things) $ do { + ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do { -- (3) Instances from generic class declarations ; generic_inst_info <- getGenericInstances clas_decls @@ -184,8 +183,10 @@ tcInstDecls1 tycl_decls inst_decls -- of -- a) local instance decls -- b) generic instances - ; addInsts local_idxty_info $ do { - ; addInsts generic_inst_info $ do { + -- c) local family instance decls + ; addInsts local_info $ do { + ; addInsts generic_inst_info $ do { + ; addFamInsts at_idx_tycon $ do { -- (4) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance @@ -195,19 +196,19 @@ tcInstDecls1 tycl_decls inst_decls ; gbl_env <- getGblEnv ; returnM (gbl_env, - generic_inst_info ++ deriv_inst_info ++ local_idxty_info, + generic_inst_info ++ deriv_inst_info ++ local_info, deriv_binds) - }}}}} + }}}}}} where -- Make sure that toplevel type instance are not for associated types. - -- !!!TODO: Need to perform this check for the InstInfo structures of type - -- functions, too. + -- !!!TODO: Need to perform this check for the TyThing of type functions, + -- too. tcIdxTyInstDeclTL ldecl@(L loc decl) = - do { (info, tything) <- tcIdxTyInstDecl ldecl + do { tything <- tcIdxTyInstDecl ldecl ; setSrcSpan loc $ when (isAssocFamily tything) $ addErr $ assocInClassErr (tcdName decl) - ; return (info, tything) + ; return tything } isAssocFamily (Just (ATyCon tycon)) = case tyConFamInst_maybe tycon of @@ -223,6 +224,10 @@ assocInClassErr name = addInsts :: [InstInfo] -> TcM a -> TcM a addInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside + +addFamInsts :: [TyThing] -> TcM a -> TcM a +addFamInsts tycons thing_inside + = tcExtendLocalFamInstEnv (extractFamInsts tycons) thing_inside \end{code} \begin{code} @@ -249,13 +254,13 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty' -- Next, process any associated types. - ; idxty_info_tycons <- mappM tcIdxTyInstDecl ats + ; idx_tycons <- mappM tcIdxTyInstDecl ats -- Now, check the validity of the instance. ; (clas, inst_tys) <- checkValidInstHead tau ; checkValidInstance tyvars theta clas inst_tys ; checkValidAndMissingATs clas (tyvars, inst_tys) - (zip ats idxty_info_tycons) + (zip ats idx_tycons) -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) @@ -263,13 +268,10 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; overlap_flag <- getOverlapFlag ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys ispec = mkLocalInstance dfun overlap_flag - (idxty_infos, - idxty_tycons) = unzip idxty_info_tycons ; return ([InstInfo { iSpec = ispec, - iBinds = VanillaInst binds uprags }] ++ - catMaybes idxty_infos, - catMaybes idxty_tycons) + iBinds = VanillaInst binds uprags }], + catMaybes idx_tycons) } where -- We pass in the source form and the type checked form of the ATs. We @@ -278,8 +280,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) checkValidAndMissingATs :: Class -> ([TyVar], [TcType]) -- instance types -> [(LTyClDecl Name, -- source form of AT - (Maybe InstInfo, -- Core form for type - Maybe TyThing))] -- Core form for data + Maybe TyThing)] -- Core form of AT -> TcM () checkValidAndMissingATs clas inst_tys ats = do { -- Issue a warning for each class AT that is not defined in this @@ -297,11 +298,10 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; mapM_ (checkIndexes clas inst_tys) ats } - checkIndexes _ _ (hsAT, (Nothing, Nothing)) = + checkIndexes _ _ (hsAT, Nothing) = return () -- skip, we already had an error here - checkIndexes clas inst_tys (hsAT, (Just _ , Nothing )) = - panic "do impl for AT syns" -- !!!TODO: also call checkIndexes' - checkIndexes clas inst_tys (hsAT, (Nothing , Just (ATyCon tycon))) = + checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = +-- !!!TODO: check that this does the Right Thing for indexed synonyms, too! checkIndexes' clas inst_tys hsAT (tyConTyVars tycon, snd . fromJust . tyConFamInst_maybe $ tycon) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index abe8745..9da9dc9 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -35,6 +35,7 @@ import Type ( Type ) import TcType ( tcIsTyVarTy, tcGetTyVar ) import NameEnv ( extendNameEnvList, nameEnvElts ) import InstEnv ( emptyInstEnv ) +import FamInstEnv ( emptyFamInstEnv ) import Var ( setTyVarName ) import VarSet ( emptyVarSet ) @@ -102,6 +103,7 @@ initTc hsc_env hsc_src mod do_this tcg_type_env = hsc_global_type_env hsc_env, tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, tcg_inst_uses = dfuns_var, tcg_th_used = th_var, tcg_exports = emptyNameSet, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index f66abdc..30c922d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -51,8 +51,10 @@ import HscTypes ( FixityEnv, import Packages ( PackageId ) import Type ( Type, pprTyThingCategory ) import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst, - TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo ) + TcPredType, TcKind, tcCmpPred, tcCmpType, + tcCmpTypes, pprSkolInfo ) import InstEnv ( Instance, InstEnv ) +import FamInstEnv ( FamInst, FamInstEnv ) import IOEnv import RdrName ( GlobalRdrEnv, LocalRdrEnv ) import Name ( Name ) @@ -153,8 +155,11 @@ data TcGblEnv -- bound in this module when dealing with hi-boot recursions -- Updated at intervals (e.g. after dealing with types and classes) - tcg_inst_env :: InstEnv, -- Instance envt for *home-package* modules - -- Includes the dfuns in tcg_insts + tcg_inst_env :: InstEnv, -- Instance envt for *home-package* + -- modules; Includes the dfuns in + -- tcg_insts + tcg_fam_inst_env :: FamInstEnv, -- Ditto for family instances + -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. -- Nevertheless, it's convenient to accumulate them along diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 0c0c93a..3c25a7f 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -27,8 +27,7 @@ import TcEnv ( TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, newFamInstTyConName, - tcExtendRecEnv, tcLookupTyVar, InstInfo, - tcLookupLocatedTyCon ) + tcExtendRecEnv, tcLookupTyVar, tcLookupLocatedTyCon ) import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, @@ -260,11 +259,10 @@ they share a lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcIdxTyInstDecl :: LTyClDecl Name - -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error +tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error tcIdxTyInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (returnM (Nothing, Nothing)) $ + recoverM (returnM Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ do { -- indexed data types require -findexed-types and can't be in an @@ -278,8 +276,7 @@ tcIdxTyInstDecl (L loc decl) ; tcIdxTyInstDecl1 decl } -tcIdxTyInstDecl1 :: TyClDecl Name - -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error +tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> @@ -295,9 +292,8 @@ tcIdxTyInstDecl1 (decl@TySynonym {}) ; t_typats <- mappM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs - -- construct type rewrite rule -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs - ; return (Nothing, Nothing) -- !!!TODO: need InstInfo for eq axioms + ; return Nothing -- !!!TODO: need TyThing for indexed synonym }} tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, @@ -350,7 +346,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, }) -- construct result - ; return (Nothing, Just (ATyCon tycon)) + ; return $ Just (ATyCon tycon) }} where h98_syntax = case cons of -- All constructors have same shape diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index a53c9ed..94ea3f9 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -344,6 +344,7 @@ data SkolemInfo -- The rest are for non-scoped skolems | ClsSkol Class -- Bound at a class decl | InstSkol Id -- Bound at an instance decl + | FamInstSkol TyCon -- Bound at a family instance decl | PatSkol DataCon -- An existential type variable bound by a pattern for SrcSpan -- a data constructor with an existential type. E.g. -- data T = forall a. Eq a => MkT a @@ -486,8 +487,13 @@ pprSkolTvBinding tv pprSkolInfo :: SkolemInfo -> SDoc pprSkolInfo (SigSkol ctxt) = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt pprSkolInfo (ClsSkol cls) = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls) -pprSkolInfo (InstSkol df) = ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df) -pprSkolInfo (ArrowSkol loc) = ptext SLIT("is bound by the arrow form at") <+> ppr loc +pprSkolInfo (InstSkol df) = + ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df) +pprSkolInfo (FamInstSkol tc) = + ptext SLIT("is bound by the family instance declaration at") <+> + ppr (getSrcLoc tc) +pprSkolInfo (ArrowSkol loc) = + ptext SLIT("is bound by the arrow form at") <+> ppr loc pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc), nest 2 (ptext SLIT("at") <+> ppr loc)] pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"), -- 1.7.10.4