Commit 138b885a authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Basic set up for global family instance environment

Mon Sep 18 19:52:34 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Basic set up for global family instance environment
  Fri Sep 15 15:20:44 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Basic set up for global family instance environment
parent a835e9fa
......@@ -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)
......
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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"),
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment