From: simonpj Date: Thu, 12 Oct 2000 13:44:59 +0000 (+0000) Subject: [project @ 2000-10-12 13:44:59 by simonpj] X-Git-Tag: Approximately_9120_patches~3616 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=40dfb7ac2b32f5ed38249f77c416e413b358df1c;p=ghc-hetmet.git [project @ 2000-10-12 13:44:59 by simonpj] Simons work, mainly on the type checker --- diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index aeb12b2..b0c64d2 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -92,7 +92,6 @@ hscMain flags core_cmds stg_cmds summary maybe_old_iface -- UniqueSupplies for later use (these are the only lower case uniques) mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer - mkSplitUniqSupply 'a' >>= \ tc_uniqs -> -- typechecker mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 64e2a6b..34e37a1 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -37,13 +37,41 @@ data ModDetails Symbol tables map modules to ModDetails: \begin{code} -type HomeSymbolTable = ModuleEnv ModDetails -- Domain = modules in the home package -type PackageSymbolTable = ModuleEnv ModDetails -- Domain = modules in the some other package -type GlobalSymbolTable = ModuleEnv ModDetails -- Domain = all modules +type SymbolTable = ModuleEnv ModDetails +type HomeSymbolTable = SymbolTable -- Domain = modules in the home package +type PackageSymbolTable = SymbolTable -- Domain = modules in the some other package +type GlobalSymbolTable = SymbolTable -- Domain = all modules \end{code} -Auxiliary definitions +Simple lookups in the symbol table + +\begin{code} +lookupFixityEnv :: SymbolTable -> Name -> Fixity + -- Returns defaultFixity if there isn't an explicit fixity +lookupFixityEnv tbl name + = case lookupModuleEnv tbl (nameModule name) of + Nothing -> defaultFixity + Just details -> case lookupNameEnv (fixityEnv details) name of + Just fixity -> fixity + Nothing -> defaultFixity + +lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing +lookupTypeEnv tbl name + = case lookupModuleEnv tbl (nameModule name) of + Just details -> lookupNameEnv (typeEnv details) name + Nothing -> Nothing +\end{code} + + +%************************************************************************ +%* * +\subsection{Auxiliary types} +%* * +%************************************************************************ + +These types are defined here because they are mentioned in ModDetails, +but they are mostly elaborated elsewhere \begin{code} data TyThing = AnId Id @@ -56,6 +84,16 @@ type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name c -- These only get reported on lookup, -- not on construction +type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class +type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class +\end{code} + + +\begin{code} +type Avails = [AvailInfo] +type AvailInfo = GenAvailInfo Name +type RdrAvailInfo = GenAvailInfo OccName + data GenAvailInfo name = Avail name -- An ordinary identifier | AvailTC name -- The name of the type or class [name] -- The available pieces of type/class. @@ -66,9 +104,6 @@ data GenAvailInfo name = Avail name -- An ordinary identifier -- Equality used when deciding if the interface has changed type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it -type AvailInfo = GenAvailInfo Name -type RdrAvailInfo = GenAvailInfo OccName -type Avails = [AvailInfo] \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index f5d4641..d80dd25 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -329,7 +329,6 @@ initRn :: DynFlags -> Finder -> GlobalSymbolTable -> Module -> SrcLoc initRn dflags finder gst prs mod loc do_rn = do - himaps <- mkModuleHiMaps dirs names_var <- newIORef (prsNS pcs) errs_var <- newIORef (emptyBag,emptyBag) iface_var <- newIORef (initIfaces prs) @@ -408,11 +407,11 @@ once you must either split it, or install a fresh unique supply. \begin{code} renameSourceCode :: DynFlags -> Module - -> RnNameSupply + -> PersistentRenamerState -> RnMS r -> r -renameSourceCode dflags mod name_supply m +renameSourceCode dflags mod prs m = unsafePerformIO ( -- It's not really unsafe! When renaming source code we -- only do any I/O if we need to read in a fixity declaration; diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 020d139..3eaca26 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -44,7 +44,7 @@ import TcHsSyn ( TcExpr, TcId, ) import TcMonad import TcEnv ( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..), - tcLookupValue, tcLookupGlobalValue + tcLookupGlobalId ) import TcType ( TcThetaType, TcType, TcTauType, TcTyVarSet, @@ -685,7 +685,7 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit) | otherwise - = tcLookupGlobalValue from_rat_name `thenNF_Tc` \ from_rational -> + = tcLookupGlobalId from_rat_name `thenNF_Tc` \ from_rational -> newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> let rational_ty = funArgTy (idType method_id) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 9c36b6a..324038c 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -26,7 +26,7 @@ import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) import TcEnv ( TcId, ValueEnv, TyThing(..), TyThingDetails(..), tcAddImportedIdInfo, - tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, + tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName ) import TcBinds ( tcBindWithSigs, tcSpecSigs ) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 05781fa..75f8d34 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -183,14 +183,13 @@ context to the instance decl. The "offending classes" are %************************************************************************ \begin{code} -tcDeriving :: Module -- name of module under scrutiny - -> FixityEnv -- for the deriving code (Show/Read.) - -> RnNameSupply -- for "renaming" bits of generated code +tcDeriving :: PersistentRenamerState + -> Module -- name of module under scrutiny -> Bag InstInfo -- What we already know about instances -> TcM (Bag InstInfo, -- The generated "instance decls". RenamedHsBinds) -- Extra generated bindings -tcDeriving mod fixs rn_name_supply inst_decl_infos_in +tcDeriving prs mod inst_decl_infos_in = recoverTc (returnTc (emptyBag, EmptyBinds)) $ -- Fish the "deriving"-related information out of the TcEnv @@ -214,17 +213,18 @@ tcDeriving mod fixs rn_name_supply inst_decl_infos_in gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc -> + tcGetEnv `thenNF_Tc` \ env -> let extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list - method_binds_s = map (gen_bind fixs) new_inst_infos + method_binds_s = map (gen_bind (tcGST env)) new_inst_infos mbinders = collectLocatedMonoBinders extra_mbinds -- Rename to get RenamedBinds. -- The only tricky bit is that the extra_binds must scope over the -- method bindings for the instances. (rn_method_binds_s, rn_extra_binds) - = renameSourceCode mod rn_name_supply ( + = renameSourceCode mod prs ( bindLocatedLocalsRn (ptext (SLIT("deriving"))) mbinders $ \ _ -> rnTopMonoBinds extra_mbinds [] `thenRn` \ (rn_extra_binds, _) -> mapRn rn_meths method_binds_s `thenRn` \ rn_method_binds_s -> @@ -547,7 +547,7 @@ the renamer. What a great hack! -- Generate the method bindings for the required instance -- (paired with class name, as we need that when generating dict -- names.) -gen_bind :: FixityEnv -> InstInfo -> RdrNameMonoBinds +gen_bind :: GlobalSymbolTable -> InstInfo -> RdrNameMonoBinds gen_bind fixities inst | not (isLocallyDefined tycon) = EmptyMonoBinds | clas `hasKey` showClassKey = gen_Show_binds fixities tycon diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 19b0ef9..61f1437 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -1,82 +1,73 @@ \begin{code} module TcEnv( - TcId, TcIdSet, tcInstId, - - TcEnv, TyThing(..), TyThingDetails(..), - - initEnv, + TcId, TcIdSet, + TyThing(..), TyThingDetails(..), -- Getting stuff from the environment + TcEnv, initTcEnv, tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, + -- Instance environment + tcGetInstEnv, tcSetInstEnv, + -- Global environment + tcExtendGlobalEnv, tcExtendGlobalValEnv, tcLookupTy, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, -- Local environment - tcExtendKindEnv, tcExtendTyVarEnv, - tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars, + tcExtendKindEnv, + tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, + tcExtendLocalValEnv, -- Global type variables tcGetGlobalTyVars, tcExtendGlobalTyVars, - tcExtendGlobalValEnv, tcExtendLocalValEnv, - tcGetValueEnv, tcSetValueEnv, - tcAddImportedIdInfo, - - tcLookupValue, tcLookupValueMaybe, - explicitLookupValue, + -- Random useful things + tcAddImportedIdInfo, tcInstId, + -- New Ids newLocalId, newSpecPragmaId, - newDefaultMethodName, newDFunName, - - InstEnv, emptyInstEnv, addToInstEnv, - lookupInstEnv, InstLookupResult(..), - tcGetInstEnv, tcSetInstEnv, classInstEnv, - - badCon, badPrimOp + newDefaultMethodName, newDFunName ) where #include "HsVersions.h" +import TcMonad +import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType, + tcInstTyVars, zonkTcTyVars, + ) import Id ( mkUserLocal, isDataConWrapId_maybe ) +import IdInfo ( vanillaIdInfo ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, setVarName, idType, lazySetIdInfo, idInfo, tyVarKind, UVar, ) -import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType, - tcInstTyVars, zonkTcTyVars, - TcKind, - ) import VarSet +import VarEnv ( TyVarSubstEnv ) import Type ( Kind, Type, superKind, tyVarsOfType, tyVarsOfTypes, splitForAllTys, splitRhoTy, splitFunTys, splitAlgTyConApp_maybe, getTyVar, getDFunTyKey ) -import Subst ( substTy ) -import UsageSPUtils ( unannotTy ) import DataCon ( DataCon ) import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon ) import Class ( Class, ClassOpItem, ClassContext, classTyCon ) - -import TcMonad - -import IdInfo ( vanillaIdInfo ) -import Name ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..), - nameOccName, nameModule, getSrcLoc, mkGlobalName, - maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined, - NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts, - extendNameEnv, extendNameEnvList - ) -import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) -import Module ( Module ) -import Unify ( unifyTyListsX, matchTys ) -import Unique ( pprUnique10, Unique, Uniquable(..) ) +import Subst ( substTy ) +import Name ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..), + nameOccName, nameModule, getSrcLoc, mkGlobalName, + maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined, + NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts, + extendNameEnv, extendNameEnvList + ) +import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) +import Module ( Module ) +import Unify ( unifyTyListsX, matchTys ) +import HscTypes ( ModDetails(..), lookupTypeEnv ) +import Unique ( pprUnique10, Unique, Uniquable(..) ) import UniqFM -import Unique ( Uniquable(..) ) -import Util ( zipEqual, zipWith3Equal, mapAccumL ) -import VarEnv ( TyVarSubstEnv ) -import SrcLoc ( SrcLoc ) +import Unique ( Uniquable(..) ) +import Util ( zipEqual, zipWith3Equal, mapAccumL ) +import SrcLoc ( SrcLoc ) import FastString ( FastString ) import Maybes import Outputable @@ -89,6 +80,9 @@ import Outputable %************************************************************************ \begin{code} +type TcId = Id -- Type may be a TcType +type TcIdSet = IdSet + data TcEnv = TcEnv { tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation @@ -144,15 +138,15 @@ data TcTyThing -- 3. Then we zonk the kind variable. -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment -initEnv :: GlobalSymbolTable -> InstEnv -> NF_TcM TcEnv -initEnv gst inst_env - = tcNewMutVar emptyVarSet `thenNF_Tc` \ gtv_var -> - returnTc (TcEnv { tcGST = gst, - tcGEnv = emptyNameEnv, - tcInst = inst_env, - tcLEnv = emptyNameEnv, - tcTyVars = gtv_var - }) +initTcEnv :: GlobalSymbolTable -> InstEnv -> IO TcEnv +initTcEnv gst inst_env + = do { gtv_var <- newIORef emptyVarSet + return (TcEnv { tcGST = gst, + tcGEnv = emptyNameEnv, + tcInst = inst_env, + tcLEnv = emptyNameEnv, + tcTyVars = gtv_var + })} tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)] tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)] @@ -176,39 +170,36 @@ data TyThingDetails = SynTyDetails Type \begin{code} lookup_global :: TcEnv -> Name -> Maybe TyThing + -- Try the global envt and then the global symbol table lookup_global env name - = -- Try the global envt - case lookupNameEnv (tcGEnv env) name of { + = case lookupNameEnv (tcGEnv env) name of { Just thing -> Just thing ; - Nothing -> - - -- Try the global symbol table - case lookupModuleEnv (tcGST env) of { - Nothing -> Nothing ; - Just genv -> lookupNameEnv genv name - }} + Nothing -> lookupTypeEnv (tcGST env) name lookup_local :: TcEnv -> Name -> Maybe TcTyThing + -- Try the local envt and then try the global lookup_local env name = case lookupNameEnv (tcLEnv env) name of Just thing -> Just thing ; Nothing -> case lookup_global env name of Just thing -> AGlobal thing Nothing -> Nothing + +explicitLookupId :: TcEnv -> Name -> Maybe Id +explicitLookupId env name = case lookup_global env name of + Just (AnId id) -> Just id + other -> Nothing \end{code} %************************************************************************ %* * -\subsection{TcId} +\subsection{Random useful functions} %* * %************************************************************************ \begin{code} -type TcId = Id -- Type may be a TcType -type TcIdSet = IdSet - -- A useful function that takes an occurrence of a global thing -- and instantiates its type with fresh type variables tcInstId :: Id @@ -225,6 +216,63 @@ tcInstId id (theta', tau') = splitRhoTy rho' in returnNF_Tc (tyvars', theta', tau') + +tcAddImportedIdInfo :: TcEnv -> Id -> Id +tcAddImportedIdInfo unf_env id + | isLocallyDefined id -- Don't look up locally defined Ids, because they + -- have explicit local definitions, so we get a black hole! + = id + | otherwise + = id `lazySetIdInfo` new_info + -- The Id must be returned without a data dependency on maybe_id + where + new_info = case explicitLookupId unf_env (getName id) of + Nothing -> vanillaIdInfo + Just imported_id -> idInfo imported_id + -- ToDo: could check that types are the same +\end{code} + + +%************************************************************************ +%* * +\subsection{Making new Ids} +%* * +%************************************************************************ + +Constructing new Ids + +\begin{code} +newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId +newLocalId name ty loc + = tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkUserLocal name uniq ty loc) + +newSpecPragmaId :: Name -> TcType -> NF_TcM TcId +newSpecPragmaId name ty + = tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name)) +\end{code} + +Make a name for the dict fun for an instance decl + +\begin{code} +newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name +newDFunName mod clas (ty:_) loc + = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq -> + tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkGlobalName uniq mod + (mkDFunOcc dfun_string inst_uniq) + (LocalDef loc Exported)) + where + -- Any string that is somewhat unique will do + dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) + +newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name +newDefaultMethodName op_name loc + = tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkGlobalName uniq (nameModule op_name) + (mkDefaultMethodOcc (getOccName op_name)) + (LocalDef loc Exported)) \end{code} @@ -303,6 +351,22 @@ tcLookupTyCon name %************************************************************************ \begin{code} +tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing) +tcLookup_maybe name + = tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (lookup_local env name) + +tcLookup :: Name -> NF_TcM TcTyThing +tcLookup name + = tcLookup_maybe name `thenNF_Tc` \ maybe_thing -> + case maybe_thing of + Just thing -> returnNF_Tc thing + other -> notFound "tcLookup:" name + -- Extract the IdInfo from an IfaceSig imported from an interface file +\end{code} + + +\begin{code} tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r tcExtendKindEnv pairs thing_inside = tcGetEnv `thenNF_Tc` \ env -> @@ -314,10 +378,10 @@ tcExtendKindEnv pairs thing_inside tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tyvars thing_inside - = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = (in_scope_tvs, gtvs)}) -> + = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) -> let - le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars] - new_tv_set = mkVarSet tyvars + le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars] + new_tv_set = mkVarSet tyvars in -- It's important to add the in-scope tyvars to the global tyvar set -- as well. Consider @@ -398,369 +462,22 @@ tcGetGlobalTyVars %************************************************************************ %* * -\subsection{The local environment} -%* * -%************************************************************************ - -\begin{code} -tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing) -tcLookup_maybe name - = tcGetEnv `thenNF_Tc` \ env -> - returnNF_Tc (lookup_local env name) - -tcLookup :: Name -> NF_TcM TcTyThing -tcLookup name - = tcLookup_maybe name `thenNF_Tc` \ maybe_thing -> - case maybe_thing of - Just thing -> returnNF_Tc thing - other -> notFound "tcLookup:" name - - - -tcGetValueEnv :: NF_TcM ValueEnv -tcGetValueEnv - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - returnNF_Tc ve - - -tcSetValueEnv :: ValueEnv -> TcM a -> TcM a -tcSetValueEnv ve thing_inside - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ ie gtvs) -> - tcSetEnv (TcEnv ue te ve ie gtvs) thing_inside - -explicitLookupValue :: ValueEnv -> Name -> Maybe Id -explicitLookupValue ve name - = case maybeWiredInIdName name of - Just id -> Just id - Nothing -> lookupNameEnv ve name - - -- Extract the IdInfo from an IfaceSig imported from an interface file -tcAddImportedIdInfo :: ValueEnv -> Id -> Id -tcAddImportedIdInfo unf_env id - | isLocallyDefined id -- Don't look up locally defined Ids, because they - -- have explicit local definitions, so we get a black hole! - = id - | otherwise - = id `lazySetIdInfo` new_info - -- The Id must be returned without a data dependency on maybe_id - where - new_info = case explicitLookupValue unf_env (getName id) of - Nothing -> vanillaIdInfo - Just imported_id -> idInfo imported_id - -- ToDo: could check that types are the same -\end{code} - - -%************************************************************************ -%* * -\subsection{The instance environment} -%* * -%************************************************************************ - -Constructing new Ids - -\begin{code} -newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId -newLocalId name ty loc - = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkUserLocal name uniq ty loc) - -newSpecPragmaId :: Name -> TcType -> NF_TcM TcId -newSpecPragmaId name ty - = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name)) -\end{code} - -Make a name for the dict fun for an instance decl - -\begin{code} -newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name -newDFunName mod clas (ty:_) loc - = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq -> - tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkGlobalName uniq mod - (mkDFunOcc dfun_string inst_uniq) - (LocalDef loc Exported)) - where - -- Any string that is somewhat unique will do - dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) - -newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name -newDefaultMethodName op_name loc - = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkGlobalName uniq (nameModule op_name) - (mkDefaultMethodOcc (getOccName op_name)) - (LocalDef loc Exported)) -\end{code} - - -%************************************************************************ -%* * \subsection{The instance environment} %* * %************************************************************************ \begin{code} tcGetInstEnv :: NF_TcM InstEnv -tcGetInstEnv = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) -> - returnNF_Tc ie +tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (tcInst env) tcSetInstEnv :: InstEnv -> TcM a -> TcM a tcSetInstEnv ie thing_inside - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) -> - tcSetEnv (TcEnv ue te ve ie gtvs) thing_inside + = tcGetEnv `thenNF_Tc` \ env -> + tcSetEnv (env {tcInst = ie}) thing_inside \end{code} -\begin{code} -type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class -type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class - -classInstEnv :: InstEnv -> Class -> ClsInstEnv -classInstEnv env cls = lookupWithDefaultUFM env [] cls -\end{code} - -A @ClsInstEnv@ lives inside a class, and identifies all the instances -of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for -that instance. - -If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then - - forall a b, C t1 t2 t3 can be constructed by dfun - -or, to put it another way, we have - - instance (...) => C t1 t2 t3, witnessed by dfun - -There is an important consistency constraint in the elements of a ClsInstEnv: - - * [a,b] must be a superset of the free vars of [t1,t2,t3] - - * The dfun must itself be quantified over [a,b] - -Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: - [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] -The "a" in the pattern must be one of the forall'd variables in -the dfun type. - - - -Notes on overlapping instances -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify. - -In others, overlap is permitted, but only in such a way that one can make -a unique choice when looking up. That is, overlap is only permitted if -one template matches the other, or vice versa. So this is ok: - - [a] [Int] - -but this is not - - (Int,a) (b,Int) - -If overlap is permitted, the list is kept most specific first, so that -the first lookup is the right choice. - - -For now we just use association lists. - -\subsection{Avoiding a problem with overlapping} - -Consider this little program: - -\begin{pseudocode} - class C a where c :: a - class C a => D a where d :: a - - instance C Int where c = 17 - instance D Int where d = 13 - - instance C a => C [a] where c = [c] - instance ({- C [a], -} D a) => D [a] where d = c - - instance C [Int] where c = [37] - - main = print (d :: [Int]) -\end{pseudocode} - -What do you think `main' prints (assuming we have overlapping instances, and -all that turned on)? Well, the instance for `D' at type `[a]' is defined to -be `c' at the same type, and we've got an instance of `C' at `[Int]', so the -answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because -the `C [Int]' instance is more specific). - -Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That -was easy ;-) Let's just consult hugs for good measure. Wait - if I use old -hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it -doesn't even compile! What's going on!? - -What hugs complains about is the `D [a]' instance decl. - -\begin{pseudocode} - ERROR "mj.hs" (line 10): Cannot build superclass instance - *** Instance : D [a] - *** Context supplied : D a - *** Required superclass : C [a] -\end{pseudocode} - -You might wonder what hugs is complaining about. It's saying that you -need to add `C [a]' to the context of the `D [a]' instance (as appears -in comments). But there's that `C [a]' instance decl one line above -that says that I can reduce the need for a `C [a]' instance to the -need for a `C a' instance, and in this case, I already have the -necessary `C a' instance (since we have `D a' explicitly in the -context, and `C' is a superclass of `D'). - -Unfortunately, the above reasoning indicates a premature commitment to the -generic `C [a]' instance. I.e., it prematurely rules out the more specific -instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to -add the context that hugs suggests (uncomment the `C [a]'), effectively -deferring the decision about which instance to use. - -Now, interestingly enough, 4.04 has this same bug, but it's covered up -in this case by a little known `optimization' that was disabled in -4.06. Ghc-4.04 silently inserts any missing superclass context into -an instance declaration. In this case, it silently inserts the `C -[a]', and everything happens to work out. - -(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for -`Mark Jones', although Mark claims no credit for the `optimization' in -question, and would rather it stopped being called the `Mark Jones -optimization' ;-) - -So, what's the fix? I think hugs has it right. Here's why. Let's try -something else out with ghc-4.04. Let's add the following line: - - d' :: D a => [a] - d' = c - -Everyone raise their hand who thinks that `d :: [Int]' should give a -different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The -`optimization' only applies to instance decls, not to regular -bindings, giving inconsistent behavior. - -Old hugs had this same bug. Here's how we fixed it: like GHC, the -list of instances for a given class is ordered, so that more specific -instances come before more generic ones. For example, the instance -list for C might contain: - ..., C Int, ..., C a, ... -When we go to look for a `C Int' instance we'll get that one first. -But what if we go looking for a `C b' (`b' is unconstrained)? We'll -pass the `C Int' instance, and keep going. But if `b' is -unconstrained, then we don't know yet if the more specific instance -will eventually apply. GHC keeps going, and matches on the generic `C -a'. The fix is to, at each step, check to see if there's a reverse -match, and if so, abort the search. This prevents hugs from -prematurely chosing a generic instance when a more specific one -exists. - ---Jeff - -\begin{code} -emptyInstEnv :: InstEnv -emptyInstEnv = emptyUFM -\end{code} - -@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since -the env is kept ordered, the first match must be the only one. The -thing we are looking up can have an arbitrary "flexi" part. - -\begin{code} -lookupInstEnv :: InstEnv -- The envt - -> Class -> [Type] -- Key - -> InstLookupResult - -data InstLookupResult - = FoundInst -- There is a (template,substitution) pair - -- that makes the template match the key, - -- and no template is an instance of the key - TyVarSubstEnv Id - - | NoMatch Bool -- Boolean is true iff there is at least one - -- template that matches the key. - -- (but there are other template(s) that are - -- instances of the key, so we don't report - -- FoundInst) - -- The NoMatch True case happens when we look up - -- Foo [a] - -- in an InstEnv that has entries for - -- Foo [Int] - -- Foo [b] - -- Then which we choose would depend on the way in which 'a' - -- is instantiated. So we say there is no match, but identify - -- it as ambiguous case in the hope of giving a better error msg. - -- See the notes above from Jeff Lewis - -lookupInstEnv env key_cls key_tys - = find (classInstEnv env key_cls) - where - key_vars = tyVarsOfTypes key_tys - - find [] = NoMatch False - find ((tpl_tyvars, tpl, val) : rest) - = case matchTys tpl_tyvars tpl key_tys of - Nothing -> - case matchTys key_vars key_tys tpl of - Nothing -> find rest - Just (_, _) -> NoMatch (any_match rest) - Just (subst, leftovers) -> ASSERT( null leftovers ) - FoundInst subst val - - any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys) - | (tvs,tpl,_) <- rest - ] -\end{code} - -@addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps. - -A boolean flag controls overlap reporting. - -True => overlap is permitted, but only if one template matches the other; - not if they unify but neither is - -\begin{code} -addToInstEnv :: Bool -- True <=> overlap permitted - -> InstEnv -- Envt - -> Class -> [TyVar] -> [Type] -> Id -- New item - -> MaybeErr InstEnv -- Success... - ([Type], Id) -- Failure: Offending overlap - -addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value - = case insert_into (classInstEnv inst_env clas) of - Failed stuff -> Failed stuff - Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env) - - where - ins_tv_set = mkVarSet ins_tvs - ins_item = (ins_tv_set, ins_tys, value) - - insert_into [] = returnMaB [ins_item] - insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest) - - -- FAIL if: - -- (a) they are the same, or - -- (b) they unify, and any sort of overlap is prohibited, - -- (c) they unify but neither is more specific than t'other - | identical - || (unifiable && not overlap_ok) - || (unifiable && not (ins_item_more_specific || cur_item_more_specific)) - = failMaB (tpl_tys, val) - - -- New item is an instance of current item, so drop it here - | ins_item_more_specific = returnMaB (ins_item : env) - - -- Otherwise carry on - | otherwise = insert_into rest `thenMaB` \ rest' -> - returnMaB (cur_item : rest') - where - unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys) - ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys) - cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys) - identical = ins_item_more_specific && cur_item_more_specific -\end{code} - - %************************************************************************ %* * \subsection{Errors} @@ -769,8 +486,7 @@ addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value \begin{code} badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor") -badPrimOp op = quotes (ppr op) <+> ptext SLIT("is not a primop") -notFound where name - = failWithTc (text where <> colon <+> quotes (ppr name) <+> ptext SLIT("is not in scope")) +notFound where name = failWithTc (text where <> colon <+> quotes (ppr name) <+> + ptext SLIT("is not in scope")) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 72587b7..cb7f9e0 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -26,9 +26,9 @@ import Inst ( InstOrigin(..), ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcInstId, - tcLookupValue, tcLookupClass, tcLookupGlobalId, - tcLookupTyCon, tcLookupDataCon, - tcExtendGlobalTyVars, tcLookupValueMaybe, + tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe, + tcLookupTyCon, tcLookupDataCon, tcLookup, + tcExtendGlobalTyVars ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index b073070..bf828e4 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -33,7 +33,6 @@ import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), ) import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) import RdrName ( RdrName, mkUnqual ) -import RnMonad ( FixityEnv, lookupFixity ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) , maxPrecedence , Boxity(..) @@ -774,7 +773,7 @@ gen_Ix_binds tycon \begin{code} gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Read_binds fixity_env tycon +gen_Read_binds gst tycon = reads_prec `AndMonoBinds` read_list where tycon_loc = getSrcLoc tycon @@ -902,7 +901,7 @@ gen_Read_binds fixity_env tycon then d_Expr else HsVar (last bs_needed)] Boxed - [lp,rp] = getLRPrecs is_infix fixity_env dc_nm + [lp,rp] = getLRPrecs is_infix gst dc_nm quals | is_infix = let (h:t) = field_quals in (h:con_qual:t) @@ -915,7 +914,7 @@ gen_Read_binds fixity_env tycon -} paren_prec_limit | not is_infix = fromInt maxPrecedence - | otherwise = getFixity fixity_env dc_nm + | otherwise = getFixity gst dc_nm read_paren_arg -- parens depend on precedence... | nullary_con = false_Expr -- it's optional. @@ -929,9 +928,9 @@ gen_Read_binds fixity_env tycon %************************************************************************ \begin{code} -gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds +gen_Show_binds :: GlobalSymbolTable -> TyCon -> RdrNameMonoBinds -gen_Show_binds fixity_env tycon +gen_Show_binds gst tycon = shows_prec `AndMonoBinds` show_list where tycon_loc = getSrcLoc tycon @@ -1002,7 +1001,7 @@ gen_Show_binds fixity_env tycon mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str)) - prec_cons = getLRPrecs is_infix fixity_env dc_nm + prec_cons = getLRPrecs is_infix gst dc_nm real_show_thingies | is_infix = @@ -1028,20 +1027,20 @@ gen_Show_binds fixity_env tycon -} paren_prec_limit | not is_infix = fromInt maxPrecedence + 1 - | otherwise = getFixity fixity_env dc_nm + 1 + | otherwise = getFixity gst dc_nm + 1 \end{code} \begin{code} -getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer] -getLRPrecs is_infix fixity_env nm = [lp, rp] +getLRPrecs :: Bool -> GlobalSymbolTable -> Name -> [Integer] +getLRPrecs is_infix gst nm = [lp, rp] where {- Figuring out the fixities of the arguments to a constructor, cf. Figures 16-18 in Haskell 1.1 report. -} - (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env nm - paren_con_prec = getFixity fixity_env nm + (con_left_assoc, con_right_assoc) = isLRAssoc gst nm + paren_con_prec = getFixity gst nm maxPrec = fromInt maxPrecedence lp @@ -1054,9 +1053,9 @@ getLRPrecs is_infix fixity_env nm = [lp, rp] | con_right_assoc = paren_con_prec | otherwise = paren_con_prec + 1 -getFixity :: FixityEnv -> Name -> Integer -getFixity fixity_env nm = case lookupFixity fixity_env nm of - Fixity x _ -> fromInt x +getFixity :: GobalSymbolTable -> Name -> Integer +getFixity gst nm = case lookupFixityEnv gst nm of + Fixity x _ -> fromInt x isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) isLRAssoc fixs_assoc nm = diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 41ca4f7..1bcdd73 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -41,8 +41,8 @@ import HsSyn -- oodles of it -- others: import Id ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id ) import DataCon ( dataConWrapId ) -import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv, - ValueEnv, TcId, tcInstId +import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, tcGetEnv, + TcEnv, TcId, tcInstId ) import TcMonad @@ -182,12 +182,12 @@ zonkIdOcc id \begin{code} -zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, ValueEnv) +zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv) zonkTopBinds binds -- Top level is implicitly recursive = fixNF_Tc (\ ~(_, new_ids) -> tcExtendGlobalValEnv (bagToList new_ids) $ zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) -> - tcGetValueEnv `thenNF_Tc` \ env -> + tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc ((binds', env), new_ids) ) `thenNF_Tc` \ (stuff, _) -> returnNF_Tc stuff diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 5e1e281..afdf82f 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -15,10 +15,9 @@ import TcMonoType ( tcHsType ) -- so tcHsType will do the Right Thing without -- having to mess about with zonking -import TcEnv ( ValueEnv, tcExtendTyVarEnv, - tcExtendGlobalValEnv, tcSetValueEnv, - tcLookupValueMaybe, - explicitLookupValue, valueEnvIds +import TcEnv ( TcEnv, tcExtendTyVarEnv, + tcExtendGlobalValEnv, tcSetEnv, + tcLookupGlobal_maybe, explicitLookupId, valueEnvIds ) import RnHsSyn ( RenamedHsDecl ) @@ -53,7 +52,7 @@ As always, we do not have to worry about user-pragmas in interface signatures. \begin{code} -tcInterfaceSigs :: ValueEnv -- Envt to use when checking unfoldings +tcInterfaceSigs :: TcEnv -- Envt to use when checking unfoldings -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls -> TcM [Id] @@ -110,7 +109,7 @@ tcWorkerInfo unf_env ty info worker_name = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn -> let -- Watch out! We can't pull on unf_env too eagerly! - info' = case explicitLookupValue unf_env worker_name of + info' = case explicitLookupId unf_env worker_name of Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id) `setWorkerInfo` HasWorker worker_id arity @@ -144,11 +143,11 @@ tcPragExpr unf_env name in_scope_vars expr where doc = text "unfolding of" <+> ppr name -tcDelay :: ValueEnv -> SDoc -> TcM a -> NF_TcM (Maybe a) +tcDelay :: TcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a) tcDelay unf_env doc thing_inside = forkNF_Tc ( recoverNF_Tc bad_value ( - tcSetValueEnv unf_env thing_inside `thenTc` \ r -> + tcSetEnv unf_env thing_inside `thenTc` \ r -> returnTc (Just r) )) where @@ -169,7 +168,7 @@ Variables in unfoldings \begin{code} tcVar :: Name -> TcM Id tcVar name - = tcLookupGlobalMaybe name `thenNF_Tc` \ maybe_id -> + = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id -> case maybe_id of { Just (AnId id) -> returnTc id; Nothing -> failWithTc (noDecl name) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index da5d874..bf2382c 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -30,7 +30,7 @@ import Inst ( InstOrigin(..), import TcDeriv ( tcDeriving ) import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, TyThing (..), - tcAddImportedIdInfo, tcInstId, tcLookupTy, + tcAddImportedIdInfo, tcInstId, tcLookupClass, newDFunName, tcExtendTyVarEnv ) import TcInstUtil ( InstInfo(..), pprInstInfo, classDataCon, simpleInstInfoTyCon, simpleInstInfoTy ) @@ -163,7 +163,8 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. Gather up the instance declarations from their various sources \begin{code} -tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids +tcInstDecls1 :: PersistentRenamerState + -> TcEnv -- Contains IdInfo for dfun ids -> [RenamedHsDecl] -> Module -- Module for deriving -> FixityEnv -- For derivings @@ -171,7 +172,7 @@ tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids -> TcM (Bag InstInfo, RenamedHsBinds) -tcInstDecls1 unf_env decls mod fixs rn_name_supply +tcInstDecls1 prs unf_env decls mod = -- (1) Do the ordinary instance declarations mapNF_Tc (tcInstDecl1 mod unf_env) [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags -> @@ -181,7 +182,7 @@ tcInstDecls1 unf_env decls mod fixs rn_name_supply -- (2) Instances from "deriving" clauses; note that we only do derivings -- for things in this module; we ignore deriving decls from -- interfaces! - tcDeriving mod fixs rn_name_supply decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds) -> + tcDeriving prs mod decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds) -> -- (3) Instances from generic class declarations mapTc (getGenericInstances mod) diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 0a0bc85..2e00a8a 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -7,10 +7,13 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module TcInstUtil ( - InstInfo(..), - buildInstanceEnv, - instInfoClass, simpleInstInfoTy, simpleInstInfoTyCon, classDataCon, - pprInstInfo + InstInfo(..), pprInstInfo, + instInfoClass, simpleInstInfoTy, simpleInstInfoTyCon, + + -- Instance environment + InstEnv, emptyInstEnv, buildInstanceEnv, + lookupInstEnv, InstLookupResult(..), + classInstEnv, classDataCon ) where #include "HsVersions.h" @@ -35,6 +38,16 @@ import TyCon ( TyCon, tyConDataCons ) import Outputable \end{code} + + +%************************************************************************ +%* * +\subsection{The InstInfo type} +%* * +%************************************************************************ + +The InstInfo type summarises the information in an instance declaration + instance c => k (t tvs) where b \begin{code} @@ -70,12 +83,6 @@ simpleInstInfoTyCon inst \end{code} -%************************************************************************ -%* * -\subsection{Creating instance related Ids} -%* * -%************************************************************************ - A tiny function which doesn't belong anywhere else. It makes a nasty mutual-recursion knot if you put it in Class. @@ -134,3 +141,258 @@ dupInstErr clas info1@(tys1, dfun1) info2@(tys2, dfun2) | isLocallyDefined dfun = ptext SLIT("defined at") <+> ppr (getSrcLoc dfun) | otherwise = ptext SLIT("imported from module") <+> quotes (ppr (nameModule (idName dfun))) \end{code} + + +%************************************************************************ +%* * +\subsection{Instance environments: InstEnv and ClsInstEnv} +%* * +%************************************************************************ + +The actual type declarations are in HscTypes. + +\begin{code} +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUFM + +classInstEnv :: InstEnv -> Class -> ClsInstEnv +classInstEnv env cls = lookupWithDefaultUFM env [] cls +\end{code} + +A @ClsInstEnv@ lives inside a class, and identifies all the instances +of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for +that instance. + +If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then + + forall a b, C t1 t2 t3 can be constructed by dfun + +or, to put it another way, we have + + instance (...) => C t1 t2 t3, witnessed by dfun + +There is an important consistency constraint in the elements of a ClsInstEnv: + + * [a,b] must be a superset of the free vars of [t1,t2,t3] + + * The dfun must itself be quantified over [a,b] + +Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: + [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] +The "a" in the pattern must be one of the forall'd variables in +the dfun type. + + + +Notes on overlapping instances +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify. + +In others, overlap is permitted, but only in such a way that one can make +a unique choice when looking up. That is, overlap is only permitted if +one template matches the other, or vice versa. So this is ok: + + [a] [Int] + +but this is not + + (Int,a) (b,Int) + +If overlap is permitted, the list is kept most specific first, so that +the first lookup is the right choice. + + +For now we just use association lists. + +\subsection{Avoiding a problem with overlapping} + +Consider this little program: + +\begin{pseudocode} + class C a where c :: a + class C a => D a where d :: a + + instance C Int where c = 17 + instance D Int where d = 13 + + instance C a => C [a] where c = [c] + instance ({- C [a], -} D a) => D [a] where d = c + + instance C [Int] where c = [37] + + main = print (d :: [Int]) +\end{pseudocode} + +What do you think `main' prints (assuming we have overlapping instances, and +all that turned on)? Well, the instance for `D' at type `[a]' is defined to +be `c' at the same type, and we've got an instance of `C' at `[Int]', so the +answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because +the `C [Int]' instance is more specific). + +Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That +was easy ;-) Let's just consult hugs for good measure. Wait - if I use old +hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it +doesn't even compile! What's going on!? + +What hugs complains about is the `D [a]' instance decl. + +\begin{pseudocode} + ERROR "mj.hs" (line 10): Cannot build superclass instance + *** Instance : D [a] + *** Context supplied : D a + *** Required superclass : C [a] +\end{pseudocode} + +You might wonder what hugs is complaining about. It's saying that you +need to add `C [a]' to the context of the `D [a]' instance (as appears +in comments). But there's that `C [a]' instance decl one line above +that says that I can reduce the need for a `C [a]' instance to the +need for a `C a' instance, and in this case, I already have the +necessary `C a' instance (since we have `D a' explicitly in the +context, and `C' is a superclass of `D'). + +Unfortunately, the above reasoning indicates a premature commitment to the +generic `C [a]' instance. I.e., it prematurely rules out the more specific +instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to +add the context that hugs suggests (uncomment the `C [a]'), effectively +deferring the decision about which instance to use. + +Now, interestingly enough, 4.04 has this same bug, but it's covered up +in this case by a little known `optimization' that was disabled in +4.06. Ghc-4.04 silently inserts any missing superclass context into +an instance declaration. In this case, it silently inserts the `C +[a]', and everything happens to work out. + +(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for +`Mark Jones', although Mark claims no credit for the `optimization' in +question, and would rather it stopped being called the `Mark Jones +optimization' ;-) + +So, what's the fix? I think hugs has it right. Here's why. Let's try +something else out with ghc-4.04. Let's add the following line: + + d' :: D a => [a] + d' = c + +Everyone raise their hand who thinks that `d :: [Int]' should give a +different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The +`optimization' only applies to instance decls, not to regular +bindings, giving inconsistent behavior. + +Old hugs had this same bug. Here's how we fixed it: like GHC, the +list of instances for a given class is ordered, so that more specific +instances come before more generic ones. For example, the instance +list for C might contain: + ..., C Int, ..., C a, ... +When we go to look for a `C Int' instance we'll get that one first. +But what if we go looking for a `C b' (`b' is unconstrained)? We'll +pass the `C Int' instance, and keep going. But if `b' is +unconstrained, then we don't know yet if the more specific instance +will eventually apply. GHC keeps going, and matches on the generic `C +a'. The fix is to, at each step, check to see if there's a reverse +match, and if so, abort the search. This prevents hugs from +prematurely chosing a generic instance when a more specific one +exists. + +--Jeff + + +@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since +the env is kept ordered, the first match must be the only one. The +thing we are looking up can have an arbitrary "flexi" part. + +\begin{code} +lookupInstEnv :: InstEnv -- The envt + -> Class -> [Type] -- Key + -> InstLookupResult + +data InstLookupResult + = FoundInst -- There is a (template,substitution) pair + -- that makes the template match the key, + -- and no template is an instance of the key + TyVarSubstEnv Id + + | NoMatch Bool -- Boolean is true iff there is at least one + -- template that matches the key. + -- (but there are other template(s) that are + -- instances of the key, so we don't report + -- FoundInst) + -- The NoMatch True case happens when we look up + -- Foo [a] + -- in an InstEnv that has entries for + -- Foo [Int] + -- Foo [b] + -- Then which we choose would depend on the way in which 'a' + -- is instantiated. So we say there is no match, but identify + -- it as ambiguous case in the hope of giving a better error msg. + -- See the notes above from Jeff Lewis + +lookupInstEnv env key_cls key_tys + = find (classInstEnv env key_cls) + where + key_vars = tyVarsOfTypes key_tys + + find [] = NoMatch False + find ((tpl_tyvars, tpl, val) : rest) + = case matchTys tpl_tyvars tpl key_tys of + Nothing -> + case matchTys key_vars key_tys tpl of + Nothing -> find rest + Just (_, _) -> NoMatch (any_match rest) + Just (subst, leftovers) -> ASSERT( null leftovers ) + FoundInst subst val + + any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys) + | (tvs,tpl,_) <- rest + ] +\end{code} + +@addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps. + +A boolean flag controls overlap reporting. + +True => overlap is permitted, but only if one template matches the other; + not if they unify but neither is + +\begin{code} +addToInstEnv :: Bool -- True <=> overlap permitted + -> InstEnv -- Envt + -> Class -> [TyVar] -> [Type] -> Id -- New item + -> MaybeErr InstEnv -- Success... + ([Type], Id) -- Failure: Offending overlap + +addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value + = case insert_into (classInstEnv inst_env clas) of + Failed stuff -> Failed stuff + Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env) + + where + ins_tv_set = mkVarSet ins_tvs + ins_item = (ins_tv_set, ins_tys, value) + + insert_into [] = returnMaB [ins_item] + insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest) + + -- FAIL if: + -- (a) they are the same, or + -- (b) they unify, and any sort of overlap is prohibited, + -- (c) they unify but neither is more specific than t'other + | identical + || (unifiable && not overlap_ok) + || (unifiable && not (ins_item_more_specific || cur_item_more_specific)) + = failMaB (tpl_tys, val) + + -- New item is an instance of current item, so drop it here + | ins_item_more_specific = returnMaB (ins_item : env) + + -- Otherwise carry on + | otherwise = insert_into rest `thenMaB` \ rest' -> + returnMaB (cur_item : rest') + where + unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys) + ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys) + cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys) + identical = ins_item_more_specific && cur_item_more_specific +\end{code} + + diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 935a19b..2be87cf 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -25,10 +25,9 @@ import Inst ( emptyLIE, plusLIE ) import TcBinds ( tcTopBindsAndThen ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, +import TcEnv ( tcExtendGlobalValEnv, tcLookupGlobal_maybe, tcEnvTyCons, tcEnvClasses, - tcSetValueEnv, tcSetInstEnv, initEnv, - ValueEnv, + tcSetEnv, tcSetInstEnv, initEnv ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) @@ -45,7 +44,7 @@ import RnMonad ( RnNameSupply, FixityEnv ) import Bag ( isEmptyBag ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet ) import Id ( idType, idName, idUnfolding ) -import Module ( pprModuleName, mkThisModule ) +import Module ( pprModuleName, mkThisModule, plusModuleEnv ) import Name ( nameOccName, isLocallyDefined, isGlobalName, toRdrName, nameEnvElts, ) @@ -80,39 +79,42 @@ data TcResults --------------- typecheckModule - :: UniqSupply - -> RnNameSupply - -> FixityEnv + :: PersistentCompilerState + -> HomeSymbolTable -> RenamedHsModule -> IO (Maybe TcResults) -typecheckModule us rn_name_supply fixity_env mod - = initTc us initEnv (tcModule rn_name_supply fixity_env mod) >>= \ (maybe_result, warns, errs) -> +typecheckModule pcs hst mod + = do { us <- mkSplitUniqSupply 'a' ; + + env <- initTcEnv gst inst_env ; + + (maybe_result, warns, errs) <- initTc us env (tcModule (pcsPRS pcs) mod) - printErrorsAndWarnings errs warns >> + printErrorsAndWarnings errs warns ; - (case maybe_result of - Nothing -> return () - Just results -> dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) >> - dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) - ) >> + (case maybe_result of + Nothing -> return () + Just results -> do { dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) + dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) + }) ; - return (if isEmptyBag errs then - maybe_result - else - Nothing) - + return (if isEmptyBag errs then + maybe_result + else + Nothing) + } + where + global_symbol_table = pcsPST pcs `plusModuleEnv` hst \end{code} The internal monster: \begin{code} -tcModule :: RnNameSupply -- for renaming derivings - -> FixityEnv -- needed for Show/Read derivings. +tcModule :: PersistentRenamerState -> RenamedHsModule -- input -> TcM TcResults -- output -tcModule rn_name_supply fixities - (HsModule mod_name _ _ _ decls _ src_loc) +tcModule prs (HsModule mod_name _ _ _ decls _ src_loc) = tcAddSrcLoc src_loc $ -- record where we're starting fixTc (\ ~(unf_env ,_) -> @@ -128,9 +130,8 @@ tcModule rn_name_supply fixities tcSetEnv env $ -- Typecheck the instance decls, includes deriving - tcInstDecls1 unf_env decls - (mkThisModule mod_name) - fixities rn_name_supply `thenTc` \ (inst_info, deriv_binds) -> + tcInstDecls1 prs unf_env decls + (mkThisModule mod_name) `thenTc` \ (inst_info, deriv_binds) -> buildInstanceEnv inst_info `thenNF_Tc` \ inst_env -> @@ -243,7 +244,7 @@ tcModule rn_name_supply fixities foe_binds in zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) -> - tcSetValueEnv really_final_env $ + tcSetEnv really_final_env $ zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' -> zonkRules rules `thenNF_Tc` \ rules' -> diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index e7b8512..40a5937 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -77,8 +77,12 @@ infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` \end{code} -Types -~~~~~ +%************************************************************************ +%* * +\subsection{Types} +%* * +%************************************************************************ + \begin{code} type TcTyVar = TyVar -- Might be a mutable tyvar type TcTyVarSet = TyVarSet @@ -97,8 +101,11 @@ type TcKind = TcType \end{code} -\section{TcM, NF_TcM: the type checker monads} -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{The main monads: TcM, NF_TcM} +%* * +%************************************************************************ \begin{code} type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError @@ -432,8 +439,14 @@ discardErrsTc main down env main (setTcErrs down new_errs_var) env \end{code} -Mutable variables -~~~~~~~~~~~~~~~~~ + + +%************************************************************************ +%* * +\subsection{Mutable variables} +%* * +%************************************************************************ + \begin{code} tcNewMutVar :: a -> NF_TcM (TcRef a) tcNewMutVar val down env = newIORef val @@ -458,8 +471,12 @@ tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val \end{code} -Environment -~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{The environment} +%* * +%************************************************************************ + \begin{code} tcGetEnv :: NF_TcM TcEnv tcGetEnv down env = return env @@ -469,8 +486,12 @@ tcSetEnv new_env m down old_env = m down new_env \end{code} -Source location -~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{Source location} +%* * +%************************************************************************ + \begin{code} tcGetDefaultTys :: NF_TcM [Type] tcGetDefaultTys down env = return (getDefaultTys down) @@ -499,8 +520,12 @@ tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg) \end{code} -Unique supply -~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{Unique supply} +%* * +%************************************************************************ + \begin{code} tcGetUnique :: NF_TcM Unique tcGetUnique down env @@ -533,8 +558,6 @@ uniqSMToTcM m down env \end{code} -\section{Dictionary function name supply -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} tcGetDFunUniq :: String -> NF_TcM Int tcGetDFunUniq key down env @@ -550,8 +573,11 @@ tcGetDFunUniq key down env \end{code} -\section{TcDown} -%~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{TcDown} +%* * +%************************************************************************ \begin{code} data TcDown @@ -607,8 +633,11 @@ getErrCtxt (TcDown def us ds loc ctxt errs) = ctxt -TypeChecking Errors -~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +\subsection{TypeChecking Errors} +%* * +%************************************************************************ \begin{code} type TcError = Message diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index cc2f96a..38e4cbf 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -24,7 +24,8 @@ import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig ) import TcHsSyn ( TcId ) import TcMonad -import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, tcLookupTy, +import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, + tcLookup, tcLookupGlobal, tcGetEnv, tcEnvTyVars, tcEnvTcIds, tcGetGlobalTyVars, TyThing(..) @@ -240,18 +241,6 @@ kcHsType (HsForAllTy (Just tv_names) context ty) returnTc boxedTypeKind --------------------------- -kcTyVar name -- Could be a tyvar or a tycon - = tcLookup name `thenTc` \ thing -> - case thing of { - ATyVar tv -> returnTc (tyVarKind tv) ; - AThing k -> returnTc k ; - AGlobal (ATyCon tc) -> returnTc (tyConKind tc) ; - other -> - - failWithTc (wrongThingErr "type" thing name) - }} - ---------------------------- kcFunResType :: RenamedHsType -> TcM TcKind -- The only place an unboxed tuple type is allowed -- is at the right hand end of an arrow @@ -283,13 +272,25 @@ kcHsPred pred@(HsPIParam name ty) kcHsPred pred@(HsPClass cls tys) = tcAddErrCtxt (appKindCtxt (ppr pred)) $ - tcLookupTy cls `thenNF_Tc` \ thing -> - (case thing of - AClass cls -> returnTc (tyConKind (classTyCon cls)) - AThing kind -> returnTc kind - other -> failWithTc (wrongThingErr "class" (pp_thing thing) cls)) `thenTc` \ kind -> - mapTc kcHsType tys `thenTc` \ arg_kinds -> + kcClass cls `thenTc` \ kind -> + mapTc kcHsType tys `thenTc` \ arg_kinds -> unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) + +--------------------------- +kcTyVar name -- Could be a tyvar or a tycon + = tcLookup name `thenTc` \ thing -> + case thing of + AThing kind -> returnTc kind + ATyVar tv -> returnTc (tyVarKind tv) + AGlobal (ATyCon tc) -> returnTc (tyConKind tc) + other -> failWithTc (wrongThingErr "type" thing name) + +kcClass cls -- Must be a class + = tcLookup cls `thenNF_Tc` \ thing -> + case thing of + AThing kind -> returnTc kind + AGlobal (AClass cls) -> returnTc (tyConKind (classTyCon cls)) + other -> failWithTc (wrongThingErr "class" thing cls) \end{code} %************************************************************************ @@ -454,16 +455,17 @@ tc_app ty tys -- hence the rather strange functionality. tc_fun_type name arg_tys - = tcLookupGlobal name `thenTc` \ thing -> + = tcLookup name `thenTc` \ thing -> case thing of ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys) - ATyCon tc | isSynTyCon tc -> checkTc arity_ok err_msg `thenTc_` - returnTc (mkAppTys (mkSynTy tc (take arity arg_tys)) + AGlobal (ATyCon tc) + | isSynTyCon tc -> checkTc arity_ok err_msg `thenTc_` + returnTc (mkAppTys (mkSynTy tc (take arity arg_tys)) (drop arity arg_tys)) - | otherwise -> returnTc (mkTyConApp tc arg_tys) - where + | otherwise -> returnTc (mkTyConApp tc arg_tys) + where arity_ok = arity <= n_args arity = tyConArity tc @@ -474,7 +476,7 @@ tc_fun_type name arg_tys err_msg = arityErr "Type synonym" name arity n_args n_args = length arg_tys - other -> failWithTc (wrongThingErr "type constructor" (pp_thing thing) name) + other -> failWithTc (wrongThingErr "type constructor" thing name) \end{code} @@ -493,7 +495,7 @@ tcContext context = mapTc (tcClassAssertion False) context tcClassAssertion ccall_ok assn@(HsPClass class_name tys) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ mapTc tcHsType tys `thenTc` \ arg_tys -> - tcLookupTy class_name `thenTc` \ thing -> + tcLookupGlobal class_name `thenTc` \ thing -> case thing of AClass clas -> checkTc (arity == n_tys) err `thenTc_` returnTc (Class clas arg_tys) @@ -502,7 +504,7 @@ tcClassAssertion ccall_ok assn@(HsPClass class_name tys) n_tys = length tys err = arityErr "Class" class_name arity n_tys - other -> failWithTc (wrongThingErr "class" (ppr_thing thing) class_name) + other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name) tcClassAssertion ccall_ok assn@(HsPIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ @@ -888,15 +890,14 @@ appKindCtxt :: SDoc -> Message appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp wrongThingErr expected thing name - = thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected - -pp_ty_thing (ATyCon _) = ptext SLIT("Type constructor") -pp_ty_thing (AClass _) = ptext SLIT("Class") -pp_ty_thing (AnId _) = ptext SLIT("Identifier") - -pp_tc_ty_thing (ATyVar _) = ptext SLIT("Type variable") -pp_tc_ty_thing (ATcId _) = ptext SLIT("Local identifier") -pp_tc_ty_thing (AThing _) = ptext SLIT("Utterly bogus") + = pp_thing thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected + where + pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor") + pp_thing (AGlobal (AClass _)) = ptext SLIT("Class") + pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier") + pp_thing (ATyVar _) = ptext SLIT("Type variable") + pp_thing (ATcId _) = ptext SLIT("Local identifier") + pp_thing (AThing _) = ptext SLIT("Utterly bogus") ambigErr pred ty = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred), diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 89e6bfe..736f619 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -21,7 +21,7 @@ import BasicTypes ( RecFlag(..), NewOrData(..) ) import TcMonad import TcEnv ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind, - tcExtendTypeEnv, tcExtendKindEnv, tcLookupTy + tcExtendTypeEnv, tcExtendKindEnv, tcLookupGlobal ) import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep ) import TcClassDcl ( tcClassDecl1 ) @@ -249,9 +249,9 @@ kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its t -- the kind of the tycon/class. Give it to the thing inside, and -- check the result kind matches kcTyClDeclBody tc_name hs_tyvars thing_inside - = tcLookupTy tc_name `thenNF_Tc` \ tc -> + = tcLookupGlobal tc_name `thenNF_Tc` \ thing -> let - kind = case tc of + kind = case thing of ATyCon tc -> tyConKind tc AClass cl -> tyConKind (classTyCon cl) -- For some odd reason, a class doesn't include its kind diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 8765a50..694d07c 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -23,7 +23,10 @@ import BasicTypes ( NewOrData(..) ) import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClassContext, kcHsContext, kcHsSigType ) -import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcLookupGlobalId, TyThing(..), TyThingDetails(..) ) +import TcEnv ( tcExtendTyVarEnv, + tcLookupTyCon, tcLookupClass, tcLookupGlobalId, + TyThing(..), TyThingDetails(..) + ) import TcMonad import Class ( ClassContext ) @@ -58,7 +61,7 @@ import ListSetOps ( equivClasses ) \begin{code} tcTyDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails) tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc) - = tcLookupTy tycon_name `thenNF_Tc` \ (ATyCon tycon) -> + = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> tcExtendTyVarEnv (tyConTyVars tycon) $ tcHsType rhs `thenTc` \ rhs_ty -> -- Note tcHsType not tcHsSigType; we allow type synonyms @@ -76,7 +79,7 @@ tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc) returnTc (tycon_name, SynTyDetails rhs_ty) tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc name1 name2) - = tcLookupTy tycon_name `thenNF_Tc` \ (ATyCon tycon) -> + = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> let tyvars = tyConTyVars tycon in @@ -90,10 +93,7 @@ tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_l returnTc (tycon_name, DataTyDetails ctxt data_cons derived_classes) where tc_derivs Nothing = returnTc [] - tc_derivs (Just ds) = mapTc tc_deriv ds - - tc_deriv name = tcLookupTy name `thenTc` \ (AClass clas) -> - returnTc clas + tc_derivs (Just ds) = mapTc tcLookupClass ds \end{code} \begin{code}