Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
ecd5cb36
Commit
ecd5cb36
authored
Oct 16, 2000
by
sewardj
Browse files
[project @ 2000-10-16 10:05:00 by sewardj]
Mostly typechecker stuff.
parent
9adbdb31
Changes
13
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 {
m
oduleId
:: Module,
m
oduleE
xports :: Avails, -- What it exports
md
V
ersion
:: VersionInfo,
m
oduleEnv
:: GlobalRdrEnv,
-- Its top level environment
m
d_id
:: Module,
m
d_e
xports
:: Avails, -- What it exports
md
_v
ersion :: VersionInfo,
m
d_globals
:: GlobalRdrEnv, -- Its top level environment
fixit
yEnv
:: NameEnv Fixity,
deprec
Env
:: NameEnv DeprecTxt,
type
Env
:: TypeEnv,
md_
fixit
ies
:: NameEnv Fixity,
md_
deprec
s
:: NameEnv DeprecTxt,
md_
type
s
:: TypeEnv,
md
I
nsts
:: [DFunId], -- Dfun-ids for the instances in this module
md
R
ules
:: RuleEnv -- Domain may include Id from other modules
md
_i
nsts :: [DFunId], -- Dfun-ids for the instances in this module
md
_r
ules :: RuleEnv
-- Domain may include Id from other modules
}
emptyModDetails :: Module -> ModDetails
emptyModDetails mod
= ModDetails { m
oduleId
= mod,
m
oduleE
xports = [],
m
oduleEnv
= emptyRdrEnv,
fixit
yEnv
= emptyNameEnv,
deprec
Env
= emptyNameEnv,
type
Env
= emptyNameEnv,
md
I
nsts
= [],
md
R
ules
= emptyRuleEnv
= ModDetails { m
d_id
= mod,
m
d_e
xports
= [],
m
d_globals
= emptyRdrEnv,
md_
fixit
ies
= emptyNameEnv,
md_
deprec
s
= emptyNameEnv,
md_
type
s
= emptyNameEnv,
md
_i
nsts = [],
md
_r
ules = 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 (fixit
yEnv
details) name
Just details -> lookupNameEnv (
md_
fixit
ies
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 (type
Env
details) name
Just details -> lookupNameEnv (
md_
type
s
details) name
Nothing -> Nothing
...
...
@@ -163,8 +161,8 @@ extendTypeEnv tbl things
where
new_details
= case lookupModuleEnv tbl mod of
Nothing -> (emptyModDetails mod) {type
Env
= type_env}
Just details -> details {type
Env =
type
Env
details
Nothing -> (emptyModDetails mod) {
md_
type
s
= type_env}
Just details -> details {
md_
type
s = md_
type
s
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 (ppr
ModuleName
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, fromInt
ClassOpKey
, fromIntegerClassOpKey )
import PrelNames( Unique, hasKey, fromInt
Name
, 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 fromInt
ClassOp
Name `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 ((++) . md
I
nsts) [] hst
hst_dfuns = foldModuleEnv ((++) . md
_i
nsts) [] 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 (
d
opt_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}
get
DefaultTys (TcDown def us ds loc ctxt errs) = def
set
DefaultTys (TcDown _ us ds loc ctxt errs) def = TcDown def us ds loc ctxt errs
get
Loc (TcDown{tc_loc=loc}) = loc
set
Loc down loc = down{tc_loc=loc}
get
Loc (TcDown def us ds loc ctxt errs) = loc
s
et
Loc (TcDown def us ds _ ctxt errs) loc = TcDown def us ds loc ctxt err
s
get
UniqSupplyVar (TcDown{tc_us=us}) = us
g
et
DFunSupplyVar (TcDown{tc_ds=ds}) = d
s
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,
tc
Get
Env, tcEnvTyVars,
tcEnvTcIds,
--
tcLookup, tcLookupGlobal,
tcEnv
TcIds
, 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,
d
opt_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_Glasgow
Exts = [ct | ct@(clas,tys) <- irreds,
isEmptyVarSet (tyVarsOfTypes tys)]
| otherwise
= [ct | ct@(clas,tys) <- irreds,
not (all isTyVarTy tys)]
bad_guys |
gla
Exts
= [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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment