Skip to content

GitLab

Commit ecd5cb36 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-16 10:05:00 by sewardj] 

Mostly typechecker stuff.
parent 9adbdb31
Hide whitespace changes
Inline Side-by-side
ghc/compiler/ghci/CmCompile.lhs
View file @ ecd5cb36
......@@ -99,24 +99,10 @@ type HomeInterfaceTable = ModuleEnv ModIFace
A @ModDetails@ summarises everything we know about a compiled module
\begin{code}
data ModDetails
= ModDetails {
moduleExports :: Avails, -- What it exports
moduleEnv :: GlobalRdrEnv, -- Its top level environment
fixityEnv :: NameEnv Fixity,
deprecEnv :: NameEnv DeprecTxt,
typeEnv :: NameEnv TcEnv.TyThing,
instEnv :: InstEnv,
ruleEnv :: IdEnv [CoreRule] -- Domain includes Ids from other modules
}
\end{code}
Auxiliary definitions
\begin{code}
{- I DONT think this should be here -- should be in HscTypes
type DeprecationEnv = NameEnv DeprecTxt -- Give reason for deprecation
type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes
......@@ -136,6 +122,7 @@ type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contain
type AvailInfo = GenAvailInfo Name
type RdrAvailInfo = GenAvailInfo OccName
type Avails = [AvailInfo]
-}
\end{code}
......
ghc/compiler/main/HscTypes.lhs
View file @ ecd5cb36
......@@ -36,7 +36,7 @@ import UniqFM ( UniqFM )
import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
import Bag ( Bag )
import Id ( Id )
import VarEnv ( IdEnv )
import VarEnv ( IdEnv, emptyVarEnv )
import BasicTypes ( Version, Fixity, defaultFixity )
import TyCon ( TyCon )
import ErrUtils ( ErrMsg, WarnMsg )
......@@ -49,8 +49,6 @@ import CoreSyn ( CoreRule )
import NameSet ( NameSet )
import Type ( Type )
import VarSet ( TyVarSet )
import {-# SOURCE #-}
TcInstUtil ( emptyInstEnv )
import Panic ( panic )
\end{code}
......@@ -65,29 +63,29 @@ A @ModDetails@ summarises everything we know about a compiled module.
\begin{code}
data ModDetails
= ModDetails {
moduleId :: Module,
moduleExports :: Avails, -- What it exports
mdVersion :: VersionInfo,
moduleEnv :: GlobalRdrEnv, -- Its top level environment
md_id :: Module,
md_exports :: Avails, -- What it exports
md_version :: VersionInfo,
md_globals :: GlobalRdrEnv, -- Its top level environment
fixityEnv :: NameEnv Fixity,
deprecEnv :: NameEnv DeprecTxt,
typeEnv :: TypeEnv,
md_fixities :: NameEnv Fixity,
md_deprecs :: NameEnv DeprecTxt,
md_types :: TypeEnv,
mdInsts :: [DFunId], -- Dfun-ids for the instances in this module
mdRules :: RuleEnv -- Domain may include Id from other modules
md_insts :: [DFunId], -- Dfun-ids for the instances in this module
md_rules :: RuleEnv -- Domain may include Id from other modules
}
emptyModDetails :: Module -> ModDetails
emptyModDetails mod
= ModDetails { moduleId = mod,
moduleExports = [],
moduleEnv = emptyRdrEnv,
fixityEnv = emptyNameEnv,
deprecEnv = emptyNameEnv,
typeEnv = emptyNameEnv,
mdInsts = [],
mdRules = emptyRuleEnv
= ModDetails { md_id = mod,
md_exports = [],
md_globals = emptyRdrEnv,
md_fixities = emptyNameEnv,
md_deprecs = emptyNameEnv,
md_types = emptyNameEnv,
md_insts = [],
md_rules = emptyRuleEnv
}
\end{code}
......@@ -108,7 +106,7 @@ lookupFixityEnv :: SymbolTable -> Name -> Maybe Fixity
lookupFixityEnv tbl name
= case lookupModuleEnv tbl (nameModule name) of
Nothing -> Nothing
Just details -> lookupNameEnv (fixityEnv details) name
Just details -> lookupNameEnv (md_fixities details) name
\end{code}
......@@ -136,7 +134,7 @@ instance NamedThing TyThing where
lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing
lookupTypeEnv tbl name
= case lookupModuleEnv tbl (nameModule name) of
Just details -> lookupNameEnv (typeEnv details) name
Just details -> lookupNameEnv (md_types details) name
Nothing -> Nothing
......@@ -163,8 +161,8 @@ extendTypeEnv tbl things
where
new_details
= case lookupModuleEnv tbl mod of
Nothing -> (emptyModDetails mod) {typeEnv = type_env}
Just details -> details {typeEnv = typeEnv details
Nothing -> (emptyModDetails mod) {md_types = type_env}
Just details -> details {md_types = md_types details
`plusNameEnv` type_env}
\end{code}
......
ghc/compiler/rename/RnEnv.lhs
View file @ ecd5cb36
......@@ -20,14 +20,14 @@ import HscTypes ( pprNameProvenance )
import RnMonad
import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
ImportReason(..), getSrcLoc,
mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName,
mkLocalName, mkImportedLocalName, mkGlobalName,
mkIPName, hasBetterProv, isLocallyDefined,
nameOccName, setNameModule, nameModule,
extendNameEnv_C, plusNameEnv_C, nameEnvElts
)
import NameSet
import OccName ( OccName, occNameUserString, occNameFlavour )
import Module ( ModuleName, moduleName, mkVanillaModule, pprModuleName )
import Module ( ModuleName, moduleName, mkVanillaModule )
import FiniteMap
import Unique ( Unique )
import UniqSupply
......@@ -36,6 +36,7 @@ import Outputable
import ListSetOps ( removeDups, equivClasses )
import Util ( thenCmp, sortLt )
import List ( nub )
import PrelNames ( mkUnboundName )
\end{code}
......@@ -682,7 +683,7 @@ warnUnusedModules mods
| not opt_WarnUnusedImports = returnRn ()
| otherwise = mapRn_ (addWarnRn . unused_mod . moduleName) mods
where
unused_mod m = vcat [ptext SLIT("Module") <+> quotes (pprModuleName m) <+>
unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
text "is imported, but nothing from it is used",
parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
quotes (pprModuleName m))]
......
ghc/compiler/rename/RnMonad.lhs
View file @ ecd5cb36
......@@ -110,8 +110,8 @@ type RnMG r = RnM () r -- Getting global names etc
-- Common part
data RnDown
= RnDown {
rn_mod :: Module, -- This module
rn_loc :: SrcLoc, -- Current locn
rn_mod :: Module, -- This module
rn_loc :: SrcLoc, -- Current locn
rn_finder :: Finder,
rn_dflags :: DynFlags,
......
ghc/compiler/typecheck/Inst.lhs
View file @ ecd5cb36
......@@ -43,9 +43,8 @@ import TcHsSyn ( TcExpr, TcId,
mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
)
import TcMonad
import TcEnv ( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
tcLookupGlobalId
)
import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupGlobalId )
import TcInstUtil ( InstLookupResult(..), lookupInstEnv )
import TcType ( TcThetaType,
TcType, TcTauType, TcTyVarSet,
zonkTcTyVars, zonkTcType, zonkTcTypes,
......@@ -75,7 +74,7 @@ import TysWiredIn ( isIntTy,
doubleDataCon, isDoubleTy,
isIntegerTy, voidTy
)
import PrelNames( Unique, hasKey, fromIntClassOpKey, fromIntegerClassOpKey )
import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey )
import Maybe ( catMaybes )
import Util ( thenCmp, zipWithEqual, mapAccumL )
import Outputable
......@@ -663,7 +662,7 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
-- (i.e. no funny business with user-defined
-- packages of numeric classes)
= -- So we can use the Prelude fromInt
tcLookupGlobalId fromIntClassOpName `thenNF_Tc` \ from_int ->
tcLookupGlobalId fromIntName `thenNF_Tc` \ from_int ->
newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
......
ghc/compiler/typecheck/TcEnv.lhs
View file @ ecd5cb36
\begin{code}
module TcEnv(
TcId, TcIdSet,
TyThing(..), TyThingDetails(..),
TyThing(..), TyThingDetails(..), TcTyThing(..),
-- Getting stuff from the environment
TcEnv, initTcEnv,
tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds,
tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
-- Instance environment
tcGetInstEnv, tcSetInstEnv,
......
ghc/compiler/typecheck/TcImprove.lhs
View file @ ecd5cb36
......@@ -7,7 +7,8 @@ import Name ( Name )
import Class ( Class, FunDep, className )
import Unify ( unifyTyListsX )
import Subst ( mkSubst, emptyInScopeSet, substTy )
import TcEnv ( tcGetInstEnv, classInstEnv )
import TcEnv ( tcGetInstEnv )
import TcInstUtil ( classInstEnv )
import TcMonad
import TcType ( TcType, TcTyVarSet, zonkTcType )
import TcUnify ( unifyTauTyLists )
......
ghc/compiler/typecheck/TcInstDcls.lhs
View file @ ecd5cb36
......@@ -193,7 +193,7 @@ tcInstDecls1 pcs hst unf_env this_mod decls mod
generic_inst_info = concat generic_inst_infos -- All local
imported_dfuns = map (tcAddImportedIdInfo unf_env . instInfoDFun) imported_inst_info
hst_dfuns = foldModuleEnv ((++) . mdInsts) [] hst
hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst
in
addInstDFuns (pcsInsts pcs) imported_dfuns `thenNF_Tc` \ inst_env1 ->
addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 ->
......
ghc/compiler/typecheck/TcInstUtil.lhs
View file @ ecd5cb36
......@@ -21,21 +21,27 @@ module TcInstUtil (
import RnHsSyn ( RenamedMonoBinds, RenamedSig )
import HsTypes ( toHsType )
import CmdLineOpts ( opt_AllowOverlappingInstances )
import CmdLineOpts ( dopt_AllowOverlappingInstances )
import TcMonad
--import TcEnv ( InstEnv, emptyInstEnv, addToInstEnv )
import Bag ( bagToList, Bag )
import Class ( Class )
import Var ( TyVar, Id, idName )
import Maybes ( MaybeErr(..) )
import VarSet ( unionVarSet, mkVarSet )
import VarEnv ( TyVarSubstEnv )
import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
import Name ( getSrcLoc, nameModule, isLocallyDefined, toRdrName )
import SrcLoc ( SrcLoc )
import Type ( Type, ThetaType, splitTyConApp_maybe, mkSigmaTy, mkDictTy )
import Type ( Type, ThetaType, splitTyConApp_maybe,
mkSigmaTy, mkDictTy, tyVarsOfTypes )
import PprType ( pprConstraint )
import Class ( classTyCon )
import DataCon ( DataCon )
import TyCon ( TyCon, tyConDataCons )
import Outputable
import HscTypes ( InstEnv, ClsInstEnv )
import Unify ( matchTys, unifyTyListsX )
import UniqFM ( lookupWithDefaultUFM, addToUFM, emptyUFM )
\end{code}
......
ghc/compiler/typecheck/TcMonad.lhs
View file @ ecd5cb36
......@@ -27,6 +27,7 @@ module TcMonad(
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
tcGetUnique, tcGetUniques, tcGetDFunUniq,
doptsTc,
tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
tcAddErrCtxtM, tcSetErrCtxtM,
......@@ -49,7 +50,7 @@ import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverL
import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
)
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
import CmdLineOpts ( opt_PprStyle_Debug )
import CmdLineOpts ( DynFlags, opt_PprStyle_Debug )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
......@@ -123,12 +124,24 @@ type TcRef a = IORef a
\end{code}
\begin{code}
<<<<<<< TcMonad.lhs
-- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
initTc :: DynFlags
-> UniqSupply
-> (TcRef (UniqFM a) -> TcEnv)
=======
initTc :: TcEnv
-> SrcLoc
>>>>>>> 1.44
-> TcM r
-> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
<<<<<<< TcMonad.lhs
initTc dflags us initenv do_this
=======
initTc tc_env src_loc do_this
>>>>>>> 1.44
= do {
us <- mkSplitUniqSupply 'a' ;
us_var <- newIORef us ;
......@@ -137,8 +150,13 @@ initTc tc_env src_loc do_this
tvs_var <- newIORef emptyUFM ;
let
<<<<<<< TcMonad.lhs
init_down = TcDown dflags [] us_var dfun_var
noSrcLoc
=======
init_down = TcDown [] us_var dfun_var
src_loc
>>>>>>> 1.44
[] errs_var
;
......@@ -252,7 +270,7 @@ We throw away any error messages!
\begin{code}
forkNF_Tc :: NF_TcM r -> NF_TcM r
forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env
forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env
= do
-- Get a fresh unique supply
us <- readIORef u_var
......@@ -263,7 +281,7 @@ forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env
us_var' <- newIORef us2 ;
err_var' <- newIORef (emptyBag,emptyBag) ;
tv_var' <- newIORef emptyUFM ;
let { down' = TcDown deflts us_var' df_var src_loc err_cxt err_var' } ;
let { down' = TcDown dflags deflts us_var' df_var src_loc err_cxt err_var' } ;
m down' env
-- ToDo: optionally dump any error messages
})
......@@ -583,15 +601,18 @@ tcGetDFunUniq key down env
\begin{code}
data TcDown
= TcDown
[Type] -- Types used for defaulting
= TcDown {
tc_dflags :: DynFlags,
tc_def :: [Type], -- Types used for defaulting
(TcRef UniqSupply) -- Unique supply
(TcRef DFunNameSupply) -- Name supply for dictionary function names
tc_us :: (TcRef UniqSupply), -- Unique supply
tc_ds :: (TcRef DFunNameSupply), -- Name supply for
-- dictionary function names
SrcLoc -- Source location
ErrCtxt -- Error context
(TcRef (Bag WarnMsg, Bag ErrMsg))
tc_loc :: SrcLoc, -- Source location
tc_ctxt :: ErrCtxt, -- Error context
tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
}
type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
-- Innermost first. Monadic so that we have a chance
......@@ -615,21 +636,25 @@ type DFunNameSupply = FiniteMap String Int
-- These selectors are *local* to TcMonad.lhs
\begin{code}
getTcErrs (TcDown def us ds loc ctxt errs) = errs
setTcErrs (TcDown def us ds loc ctxt _ ) errs = TcDown def us ds loc ctxt errs
getTcErrs (TcDown{tc_errs=errs}) = errs
setTcErrs down errs = down{tc_errs=errs}
getDefaultTys (TcDown{tc_def=def}) = def
setDefaultTys down def = down{tc_def=def}
getDefaultTys (TcDown def us ds loc ctxt errs) = def
setDefaultTys (TcDown _ us ds loc ctxt errs) def = TcDown def us ds loc ctxt errs
getLoc (TcDown{tc_loc=loc}) = loc
setLoc down loc = down{tc_loc=loc}
getLoc (TcDown def us ds loc ctxt errs) = loc
setLoc (TcDown def us ds _ ctxt errs) loc = TcDown def us ds loc ctxt errs
getUniqSupplyVar (TcDown{tc_us=us}) = us
getDFunSupplyVar (TcDown{tc_ds=ds}) = ds
getUniqSupplyVar (TcDown def us ds loc ctxt errs) = us
getDFunSupplyVar (TcDown def us ds loc ctxt errs) = ds
getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
setErrCtxt down msg = down{tc_ctxt=[msg]}
addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
setErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc [msg] errs
addErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc (msg:ctxt) errs
getErrCtxt (TcDown def us ds loc ctxt errs) = ctxt
doptsTc :: (DynFlags -> Bool) -> TcM Bool
doptsTc dopt (TcDown{tc_dflags=dflags}) env_down
= return (dopt dflags)
\end{code}
......
ghc/compiler/typecheck/TcMonoType.lhs
View file @ ecd5cb36
......@@ -25,10 +25,10 @@ import TcHsSyn ( TcId )
import TcMonad
import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv,
tcLookup, tcLookupGlobal,
tcGetEnv, tcEnvTyVars, tcEnvTcIds,
--tcLookup, tcLookupGlobal,
tcEnvTcIds, tcEnvTyVars,
tcGetGlobalTyVars,
TyThing(..)
TyThing(..), TcTyThing(..)
)
import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
newKindVar, tcInstSigVar,
......@@ -65,7 +65,7 @@ import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc )
import Util ( mapAccumL, isSingleton )
import Outputable
import HscTypes ( TyThing(..) )
\end{code}
......
ghc/compiler/typecheck/TcSimplify.lhs
View file @ ecd5cb36
......@@ -123,7 +123,7 @@ module TcSimplify (
#include "HsVersions.h"
import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults )
import CmdLineOpts ( opt_MaxContextReductionDepth, dopt_GlasgowExts, opt_WarnTypeDefaults )
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
......@@ -143,9 +143,9 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
lieToList
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv,
lookupInstEnv, InstLookupResult(..)
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
import TcInstUtil ( lookupInstEnv, InstLookupResult(..) )
import TcType ( TcTyVarSet )
import TcUnify ( unifyTauTy )
import Id ( idType )
......@@ -161,7 +161,6 @@ import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
import VarSet
import FiniteMap
import CmdLineOpts ( opt_GlasgowExts )
import Outputable
import ListSetOps ( equivClasses )
import Util ( zipEqual, mapAccumL )
......@@ -849,17 +848,18 @@ tcSimplifyThetas :: ClassContext -- Wanted
-> TcM ClassContext -- Needed
tcSimplifyThetas wanteds
= reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
= doptsTc dopt_GlasgowExts `thenNF_Tc` \ glaExts ->
reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
let
-- For multi-param Haskell, check that the returned dictionaries
-- don't have any of the form (C Int Bool) for which
-- we expect an instance here
-- For Haskell 98, check that all the constraints are of the form C a,
-- where a is a type variable
bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
isEmptyVarSet (tyVarsOfTypes tys)]
| otherwise = [ct | ct@(clas,tys) <- irreds,
not (all isTyVarTy tys)]
bad_guys | glaExts = [ct | ct@(clas,tys) <- irreds,
isEmptyVarSet (tyVarsOfTypes tys)]
| otherwise = [ct | ct@(clas,tys) <- irreds,
not (all isTyVarTy tys)]
in
if null bad_guys then
returnTc irreds
......
ghc/compiler/types/Type.lhs
View file @ ecd5cb36
......@@ -694,7 +694,7 @@ splitDictTy (NoteTy _ ty) = splitDictTy ty
splitDictTy (PredTy (Class clas tys)) = (clas, tys)
splitDictTy_maybe :: Type -> Maybe (Class, [Type])
splitDictTy_maybe (NoteTy _ ty) = splitDictTy ty
splitDictTy_maybe (NoteTy _ ty) = Just (splitDictTy ty)
splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
splitDictTy_maybe other = Nothing
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment