-- 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
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
-- 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.
-- 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}
-> 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)
\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;
)
import TcMonad
import TcEnv ( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
- tcLookupValue, tcLookupGlobalValue
+ tcLookupGlobalId
)
import TcType ( TcThetaType,
TcType, TcTauType, TcTyVarSet,
| 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)
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 )
%************************************************************************
\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
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 ->
-- 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
\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
%************************************************************************
\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
-- 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)]
\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
(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}
%************************************************************************
\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 ->
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
%************************************************************************
%* *
-\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}
\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}
)
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 )
)
import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
import RdrName ( RdrName, mkUnqual )
-import RnMonad ( FixityEnv, lookupFixity )
import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
, maxPrecedence
, Boxity(..)
\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
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)
-}
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.
%************************************************************************
\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
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 =
-}
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
| 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 =
-- 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
\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
-- 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 )
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]
= 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
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
\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)
import TcDeriv ( tcDeriving )
import TcEnv ( ValueEnv, tcExtendGlobalValEnv,
tcExtendTyVarEnvForMeths, TyThing (..),
- tcAddImportedIdInfo, tcInstId, tcLookupTy,
+ tcAddImportedIdInfo, tcInstId, tcLookupClass,
newDFunName, tcExtendTyVarEnv
)
import TcInstUtil ( InstInfo(..), pprInstInfo, classDataCon, simpleInstInfoTyCon, simpleInstInfoTy )
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
-> 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 ->
-- (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)
\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"
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}
\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.
| 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}
+
+
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 )
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,
)
---------------
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 ,_) ->
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 ->
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' ->
\end{code}
-Types
-~~~~~
+%************************************************************************
+%* *
+\subsection{Types}
+%* *
+%************************************************************************
+
\begin{code}
type TcTyVar = TyVar -- Might be a mutable tyvar
type TcTyVarSet = TyVarSet
\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
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
\end{code}
-Environment
-~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{The environment}
+%* *
+%************************************************************************
+
\begin{code}
tcGetEnv :: NF_TcM TcEnv
tcGetEnv down env = return env
\end{code}
-Source location
-~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{Source location}
+%* *
+%************************************************************************
+
\begin{code}
tcGetDefaultTys :: NF_TcM [Type]
tcGetDefaultTys down env = return (getDefaultTys down)
\end{code}
-Unique supply
-~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{Unique supply}
+%* *
+%************************************************************************
+
\begin{code}
tcGetUnique :: NF_TcM Unique
tcGetUnique down env
\end{code}
-\section{Dictionary function name supply
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
tcGetDFunUniq :: String -> NF_TcM Int
tcGetDFunUniq key down env
\end{code}
-\section{TcDown}
-%~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{TcDown}
+%* *
+%************************************************************************
\begin{code}
data TcDown
-TypeChecking Errors
-~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{TypeChecking Errors}
+%* *
+%************************************************************************
\begin{code}
type TcError = Message
import TcHsSyn ( TcId )
import TcMonad
-import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, tcLookupTy,
+import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv,
+ tcLookup, tcLookupGlobal,
tcGetEnv, tcEnvTyVars, tcEnvTcIds,
tcGetGlobalTyVars,
TyThing(..)
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
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}
%************************************************************************
-- 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
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}
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)
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)) $
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),
import TcMonad
import TcEnv ( ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind,
- tcExtendTypeEnv, tcExtendKindEnv, tcLookupTy
+ tcExtendTypeEnv, tcExtendKindEnv, tcLookupGlobal
)
import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep )
import TcClassDcl ( tcClassDecl1 )
-- 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
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 )
\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
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
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}
projects / ghc-hetmet.git / commitdiff