-- 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
TcTyThing(..),
-- Template Haskell
- Stage(..), topStage, topSpliceStage,
- Level, impLevel, topLevel,
+ ThStage(..), topStage, topSpliceStage,
+ ThLevel, impLevel, topLevel,
+
+ -- Arrows
+ ArrowCtxt(..), topArrowCtxt, ProcLevel, topProcLevel,
-- Insts
Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc,
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 )
+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 ListSetOps ( unionLists )
-import Panic ( tryMost )
+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
+#elif __GLASGOW_HASKELL__ == 502
+ tc_errors e@(UserError _) = Just e
+#else
+ tc_errors e@(IOException ioe) | 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}
%************************************************************************
%* *
= TcLclEnv {
tcl_ctxt :: ErrCtxt, -- Error context
- tcl_level :: Stage, -- Template Haskell context
+ tcl_th_ctxt :: ThStage, -- Template Haskell context
+ tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context
tcl_env :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
-- defined in this module
tcl_lie :: TcRef LIE -- Place to accumulate type constraints
}
-type Level = Int
+---------------------------
+-- Template Haskell levels
+---------------------------
+
+type ThLevel = Int -- Always >= 0
-data Stage
+data ThStage
= Comp -- Ordinary compiling, at level topLevel
- | Splice Level -- Inside a splice
- | Brack Level -- Inside brackets;
+ | Splice ThLevel -- Inside a splice
+ | Brack ThLevel -- Inside brackets;
(TcRef [PendingSplice]) -- accumulate pending splices here
(TcRef LIE) -- and type constraints here
-topStage, topSpliceStage :: Stage
+topStage, topSpliceStage :: ThStage
topStage = Comp
topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice
-impLevel, topLevel :: Level
+impLevel, topLevel :: ThLevel
topLevel = 1 -- Things defined at top level of this module
impLevel = 0 -- Imported things; they can be used inside a top level splice
--
-- g1 = $(map ...) is OK
-- g2 = $(f ...) is not OK; because we havn't compiled f yet
+
+---------------------------
+-- Arrow-notation stages
+---------------------------
+
+-- In arrow notation, a variable bound by a proc (or enclosed let/kappa)
+-- is not in scope to the left of an arrow tail (-<). For example
+--
+-- proc x -> (e1 -< e2)
+--
+-- Here, x is not in scope in e1, but it is in scope in e2. This can get
+-- a bit complicated:
+--
+-- let x = 3 in
+-- prox y -> (proc z -> e1) -< e2
+--
+-- Here, x and z are in scope in e1, but y is not. Here's how we track this:
+-- a) Assign an "proc level" to each proc, being the number of
+-- lexically-enclosing procs + 1.
+-- b) Assign to each local variable the proc-level of its lexically
+-- enclosing proc.
+-- c) Keep a list of out-of-scope procs. When moving to the left of
+-- an arrow-tail, add the proc-level of the immediately enclosing
+-- proc to the list.
+-- d) When looking up a variable, complain if its proc-level is in
+-- the banned list
+
+type ProcLevel = Int -- Always >= 0
+topProcLevel = 0 -- Not inside any proc
+
+data ArrowCtxt = ArrCtxt { proc_level :: ProcLevel, -- Current level
+ proc_banned :: [ProcLevel] } -- Out of scope proc-levels
+
+topArrowCtxt = ArrCtxt { proc_level = topProcLevel, proc_banned = [] }
+
+---------------------------
+-- TcTyThing
+---------------------------
+
data TcTyThing
- = AGlobal TyThing -- Used only in the return type of a lookup
- | ATcId TcId Level -- Ids defined in this module; may not be fully zonked
- | ATyVar TyVar -- Type variables
- | AThing TcKind -- Used temporarily, during kind checking
+ = AGlobal TyThing -- Used only in the return type of a lookup
+ | ATcId TcId ThLevel ProcLevel -- Ids defined in this module; may not be fully zonked
+ | ATyVar TyVar -- Type variables
+ | AThing TcKind -- Used temporarily, during kind checking
-- Here's an example of how the AThing guy is used
-- Suppose we are checking (forall a. T a Int):
-- 1. We first bind (a -> AThink kv), where kv is a 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
+ ppr (AGlobal g) = text "AGlobal" <+> ppr g
+ ppr (ATcId g tl pl) = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl
+ 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
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
-- of a rank-2 typed function
| DoOrigin -- The monad for a do expression
+ | ProcOrigin -- A proc expression
| ClassDeclOrigin -- Manufactured during a class decl
= ptext SLIT("a function with an overloaded argument type")
pp_orig (DoOrigin)
= ptext SLIT("a do statement")
+ pp_orig (ProcOrigin)
+ = ptext SLIT("a proc expression")
pp_orig (ClassDeclOrigin)
= ptext SLIT("a class declaration")
pp_orig (InstanceSpecOrigin clas ty)
projects / ghc-hetmet.git / blobdiff