Mostly typechecker stuff.
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
type AvailInfo = GenAvailInfo Name
type RdrAvailInfo = GenAvailInfo OccName
type Avails = [AvailInfo]
+-}
\end{code}
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 )
import NameSet ( NameSet )
import Type ( Type )
import VarSet ( TyVarSet )
-import {-# SOURCE #-}
- TcInstUtil ( emptyInstEnv )
import Panic ( panic )
\end{code}
\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}
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}
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
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}
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
import ListSetOps ( removeDups, equivClasses )
import Util ( thenCmp, sortLt )
import List ( nub )
+import PrelNames ( mkUnboundName )
\end{code}
| 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))]
-- 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,
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,
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
-- (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))
\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,
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 )
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 ->
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}
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
tcGetUnique, tcGetUniques, tcGetDFunUniq,
+ doptsTc,
tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
tcAddErrCtxtM, tcSetErrCtxtM,
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 )
\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 ;
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
;
\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
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
})
\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
-- 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}
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,
import SrcLoc ( SrcLoc )
import Util ( mapAccumL, isSingleton )
import Outputable
-
+import HscTypes ( TyThing(..) )
\end{code}
#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
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 )
import TysWiredIn ( unitTy )
import VarSet
import FiniteMap
-import CmdLineOpts ( opt_GlasgowExts )
import Outputable
import ListSetOps ( equivClasses )
import Util ( zipEqual, mapAccumL )
-> 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
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
projects / ghc-hetmet.git / commitdiff