-- Non-standard operations
runTcRn, fixM, tryM, ioToTcRn,
newMutVar, readMutVar, writeMutVar,
- getEnv, setEnv, updEnv, unsafeInterleaveM,
+ getEnv, setEnv, updEnv, unsafeInterleaveM, zapEnv,
-- The environment types
Env(..), TopEnv(..), TcGblEnv(..),
ImportAvails(..), emptyImportAvails, plusImportAvails,
plusAvail, pruneAvails,
AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv,
- mkAvailEnv, lookupAvailEnv, availEnvElts, addAvail,
+ mkAvailEnv, lookupAvailEnv, lookupAvailEnv_maybe, availEnvElts, addAvail,
WhereFrom(..),
-- Typechecker types
Level, impLevel, topLevel,
-- Insts
- Inst(..), InstOrigin(..), InstLoc, pprInstLoc,
+ Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc,
LIE, emptyLIE, unitLIE, plusLIE, consLIE,
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
import HsSyn ( PendingSplice, HsOverLit, MonoBinds, RuleDecl, ForeignDecl )
import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo )
-import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable, NameCache,
- GlobalRdrEnv, LocalRdrEnv, FixityEnv, TypeEnv, TyThing,
- Avails, GenAvailInfo(..), AvailInfo, availName,
- IsBootInterface, Deprecations, WhetherHasOrphans )
+import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable,
+ NameCache, GlobalRdrEnv, LocalRdrEnv, FixityEnv,
+ TypeEnv, TyThing, Avails, GenAvailInfo(..), AvailInfo,
+ availName, IsBootInterface, Deprecations,
+ ExternalPackageState(..), emptyExternalPackageState )
import Packages ( PackageName )
-import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, TcPredType, TcKind,
- tcCmpPred, tcCmpType, tcCmpTypes )
+import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType,
+ TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes )
import InstEnv ( DFunId, InstEnv )
import Name ( Name )
import NameEnv
import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
import UNSAFE_IO ( unsafeInterleaveIO )
import FIX_IO ( fixIO )
-import EXCEPTION ( Exception )
+import EXCEPTION ( Exception(..) )
+import IO ( isUserError )
import Maybe ( mapMaybe )
-import List ( nub )
-import Panic ( tryMost )
+import ListSetOps ( unionLists )
+import Panic ( tryJust )
\end{code}
\begin{code}
tryM :: TcRn m r -> TcRn m (Either Exception r)
-- Reflect exception into TcRn monad
-tryM (TcRn thing) = TcRn (\ env -> tryMost (thing env))
+tryM (TcRn thing) = TcRn (\ env -> tryJust tc_errors (thing env))
+ where
+#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500
+ tc_errors e@(IOException ioe) | isUserError ioe = Just e
+#else
+ tc_errors e | isUserError e = Just e
+#endif
+ tc_errors _other = Nothing
+ -- type checker failures show up as UserErrors only
\end{code}
Lazy interleave
updEnv upd (TcRn m) = TcRn (\ env -> m (upd env))
\end{code}
+\begin{code}
+zapEnv :: TcRn m a -> TcRn m a
+zapEnv act = TcRn $ \env@Env{ env_top=top, env_gbl=gbl, env_lcl=lcl } ->
+ case top of {
+ TopEnv{
+ top_mode = mode,
+ top_dflags = dflags,
+ top_hpt = hpt,
+ top_eps = eps,
+ top_us = us
+ } -> do
+
+ eps_snap <- readIORef eps
+ ref <- newIORef $! emptyExternalPackageState{ eps_PTE = eps_PTE eps_snap }
+
+ let
+ top' = TopEnv {
+ top_mode = mode,
+ top_dflags = dflags,
+ top_hpt = hpt,
+ top_eps = ref,
+ top_us = us
+ }
+
+ type_env = tcg_type_env gbl
+ mod = tcg_mod gbl
+ gbl' = TcGblEnv {
+ tcg_mod = mod,
+ tcg_type_env = type_env
+ }
+
+ env' = Env {
+ env_top = top',
+ env_gbl = gbl',
+ env_lcl = lcl
+ -- leave the rest empty
+ }
+
+ case act of { TcRn f -> f env' }
+ }
+\end{code}
%************************************************************************
%* *
-- PIT, ImportedModuleInfo
-- DeclsMap, IfaceRules, IfaceInsts, InstGates
-- TypeEnv, InstEnv, RuleBase
+ -- Mutable, because we demand-load declarations that extend the state
top_hpt :: HomePackageTable,
-- The home package table that we've accumulated while
-- (Ids defined in this module start in the local envt,
-- though they move to the global envt during zonking)
- -- Cached things
- tcg_ist :: Name -> Maybe TyThing, -- Imported symbol table
- -- Global type env: a combination of tcg_eps, tcg_hpt
- -- (but *not* tcg_type_env; no deep reason)
- -- When the PCS changes this must be refreshed,
- -- notably after running some compile-time code
-
- tcg_inst_env :: InstEnv, -- Global instance env: a combination of
+ tcg_inst_env :: TcRef InstEnv, -- Global instance env: a combination of
-- tc_pcs, tc_hpt, *and* tc_insts
+ -- This field is mutable so that it can be updated inside a
+ -- Template Haskell splice, which might suck in some new
+ -- instance declarations. This is a slightly different strategy
+ -- than for the type envt, where we look up first in tcg_type_env
+ -- and then in the mutable EPS, because the InstEnv for this module
+ -- is constructed (in principle at least) only from the modules
+ -- 'below' this one, so it's this-module-specific
+ --
+ -- On the other hand, a declaration quote [d| ... |] may introduce
+ -- some new instance declarations that we *don't* want to persist
+ -- outside the quote, so we tiresomely need to revert the InstEnv
+ -- after finishing the quote (see TcSplice.tcBracket)
-- Now a bunch of things about this module that are simply
-- accumulated, but never consulted until the end.
tcg_imports :: ImportAvails, -- Information about what was imported
-- from where, including things bound
-- in this module
- -- The next fields are always fully zonked
+
+ -- The next fields accumulate the payload of the module
+ -- The binds, rules and foreign-decl fiels are collected
+ -- initially in un-zonked form and are finally zonked in tcRnSrcDecls
tcg_binds :: MonoBinds Id, -- Value bindings in this module
tcg_deprecs :: Deprecations, -- ...Deprecations
tcg_insts :: [DFunId], -- ...Instances
impLevel, topLevel :: Level
-topLevel = 1 -- Things dedined at top level of this module
+topLevel = 1 -- Things defined at top level of this module
impLevel = 0 -- Imported things; they can be used inside a top level splice
--
-- For example:
-- 2. Then we kind-check the (T a Int) part.
-- 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
+
+instance Outputable TcTyThing where -- Debugging only
+ ppr (AGlobal g) = text "AGlobal" <+> ppr g
+ ppr (ATcId g l) = text "ATcId" <+> ppr g <+> ppr l
+ ppr (ATyVar t) = text "ATyVar" <+> ppr t
+ ppr (AThing k) = text "AThing" <+> ppr k
\end{code}
\begin{code}
ImportAvails summarises what was imported from where, irrespective
of whether the imported htings are actually used or not
-It is used * when porcessing the export list
+It is used * when processing the export list
* when constructing usage info for the inteface file
* to identify the list of directly imported modules
for initialisation purposes
+ * when figuring out what things are really unused
\begin{code}
data ImportAvails
-- i.e. *excluding* class ops and constructors
-- (which appear inside their parent AvailTC)
- imp_unqual :: ModuleEnv AvailEnv,
+ imp_qual :: ModuleEnv AvailEnv,
-- Used to figure out "module M" export specifiers
- -- Domain is only modules with *unqualified* imports
- -- (see 1.4 Report Section 5.1.1)
+ -- (see 1.4 Report Section 5.1.1). Ultimately, we want to find
+ -- everything that is unambiguously in scope as 'M.x'
+ -- and where plain 'x' is (perhaps ambiguously) in scope.
+ -- So the starting point is all things that are in scope as 'M.x',
+ -- which is what this field tells us.
+ --
+ -- Domain is the *module qualifier* for imports.
+ -- e.g. import List as Foo
+ -- would add a binding Foo |-> ...stuff from List...
+ -- to imp_qual.
-- We keep the stuff as an AvailEnv so that it's easy to
-- combine stuff coming from different (unqualified)
-- imports of the same module
-- need to recompile if the module version changes
-- (b) to specify what child modules to initialise
- dep_mods :: ModuleEnv (ModuleName, WhetherHasOrphans, IsBootInterface),
- -- For a given import or set of imports,
- -- there's an entry here for
- -- (a) modules below the one being compiled, in the current package
- -- (b) orphan modules below the one being compiled, regardless of package
+ imp_dep_mods :: ModuleEnv (ModuleName, IsBootInterface),
+ -- Home-package modules needed by the module being compiled
--
-- It doesn't matter whether any of these dependencies are actually
-- *used* when compiling the module; they are listed if they are below
-- compiling M might not need to consult X.hi, but X is still listed
-- in M's dependencies.
- dep_pkgs :: [PackageName]
+ imp_dep_pkgs :: [PackageName],
-- Packages needed by the module being compiled, whether
-- directly, or via other modules in this package, or via
-- modules imported from other packages.
+
+ imp_orphs :: [ModuleName]
+ -- Orphan modules below us in the import tree
}
emptyImportAvails :: ImportAvails
-emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv,
- imp_unqual = emptyModuleEnv,
- imp_mods = emptyModuleEnv,
- dep_mods = emptyModuleEnv,
- dep_pkgs = [] }
+emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv,
+ imp_qual = emptyModuleEnv,
+ imp_mods = emptyModuleEnv,
+ imp_dep_mods = emptyModuleEnv,
+ imp_dep_pkgs = [],
+ imp_orphs = [] }
plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails
plusImportAvails
- (ImportAvails { imp_env = env1, imp_unqual = unqual1, imp_mods = mods1,
- dep_mods = dmods1, dep_pkgs = dpkgs1 })
- (ImportAvails { imp_env = env2, imp_unqual = unqual2, imp_mods = mods2,
- dep_mods = dmods2, dep_pkgs = dpkgs2 })
- = ImportAvails { imp_env = env1 `plusAvailEnv` env2,
- imp_unqual = plusModuleEnv_C plusAvailEnv unqual1 unqual2,
- imp_mods = mods1 `plusModuleEnv` mods2,
- dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2,
- dep_pkgs = nub (dpkgs1 ++ dpkgs2) }
+ (ImportAvails { imp_env = env1, imp_qual = unqual1, imp_mods = mods1,
+ imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_orphs = orphs1 })
+ (ImportAvails { imp_env = env2, imp_qual = unqual2, imp_mods = mods2,
+ imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2 })
+ = ImportAvails { imp_env = env1 `plusAvailEnv` env2,
+ imp_qual = plusModuleEnv_C plusAvailEnv unqual1 unqual2,
+ imp_mods = mods1 `plusModuleEnv` mods2,
+ imp_dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2,
+ imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
+ imp_orphs = orphs1 `unionLists` orphs2 }
where
- plus_mod_dep (m1, orphan1, boot1) (m2, orphan2, boot2)
- = WARN( not (m1 == m2 && (boot1 || boot2 || orphan1 == orphan2)),
- (ppr m1 <+> ppr m2) $$ (ppr orphan1 <+> ppr orphan2) $$ (ppr boot1 <+> ppr boot2) )
- -- Check mod-names match, and orphan-hood matches; but a boot interface
- -- might not know about orphan hood, so only check the orphan match
- -- if both are non-boot interfaces
- (m1, orphan1 || orphan2, boot1 && boot2)
- -- If either side can "see" a non-hi-boot interface, use that
- -- Similarly orphan-hood (see note about about why orphan1 and 2 might differ)
+ plus_mod_dep (m1, boot1) (m2, boot2)
+ = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
+ -- Check mod-names match
+ (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that
\end{code}
%************************************************************************
\begin{code}
plusAvail (Avail n1) (Avail n2) = Avail n1
-plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
+plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (ns1 `unionLists` ns2)
-- Added SOF 4/97
#ifdef DEBUG
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
plusAvailEnv = plusNameEnv_C plusAvail
-lookupAvailEnv = lookupNameEnv
+lookupAvailEnv_maybe :: AvailEnv -> Name -> Maybe AvailInfo
+lookupAvailEnv_maybe = lookupNameEnv
+
+lookupAvailEnv :: AvailEnv -> Name -> AvailInfo
+lookupAvailEnv env n = case lookupNameEnv env n of
+ Just avail -> avail
+ Nothing -> pprPanic "lookupAvailEnv" (ppr n)
availEnvElts = nameEnvElts
TcThetaType -- The (types of the) dictionaries to which the function
-- must be applied to get the method
- TcTauType -- The type of the method
+ TcTauType -- The tau-type of the method
InstLoc
- -- INVARIANT: in (Method u f tys theta tau loc)
+ -- INVARIANT 1: in (Method u f tys theta tau loc)
-- type of (f tys dicts(from theta)) = tau
+ -- INVARIANT 2: tau must not be of form (Pred -> Tau)
+ -- Reason: two methods are considerd equal if the
+ -- base Id matches, and the instantiating types
+ -- match. The TcThetaType should then match too.
+ -- This only bites in the call to tcInstClassOp in TcClassDcl.mkMethodBind
+
| LitInst
Id
HsOverLit -- The literal from the occurrence site
functions that deal with it.
\begin{code}
-type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
+data InstLoc = InstLoc InstOrigin SrcLoc ErrCtxt
+
+instLocSrcLoc :: InstLoc -> SrcLoc
+instLocSrcLoc (InstLoc _ src_loc _) = src_loc
data InstOrigin
= OccurrenceOf Name -- Occurrence of an overloaded identifier
\begin{code}
pprInstLoc :: InstLoc -> SDoc
-pprInstLoc (orig, locn, ctxt)
+pprInstLoc (InstLoc orig locn ctxt)
= hsep [text "arising from", pp_orig orig, text "at", ppr locn]
where
pp_orig (OccurrenceOf name)
projects / ghc-hetmet.git / blobdiff