X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnTypes.lhs;h=c5620e7360e5d93530de58687063803bde8d1aaa;hb=90810d119e4442dceca8bd75a3f52acec3261e5c;hp=1e58eddafc4d8c997900ef85f21b85146331a0b4;hpb=3355c9d53b220ccb110e5a3c81a1a8b2c9c41555;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 1e58edd..c5620e7 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -11,7 +11,7 @@ module TcRnTypes( -- 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(..), @@ -23,15 +23,18 @@ module TcRnTypes( 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, @@ -46,13 +49,14 @@ module TcRnTypes( 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 @@ -74,10 +78,11 @@ import Outputable 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} @@ -157,7 +162,17 @@ Error recovery \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 @@ -201,6 +216,47 @@ updEnv :: (Env m -> Env n) -> TcRn n a -> TcRn m a 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} %************************************************************************ %* * @@ -336,7 +392,8 @@ data TcLclEnv = 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 @@ -350,20 +407,24 @@ data TcLclEnv 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 -- @@ -372,11 +433,50 @@ 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. @@ -385,10 +485,10 @@ data TcTyThing -- 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} @@ -464,10 +564,11 @@ emptyUsages = emptyNameSet 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 @@ -597,7 +698,13 @@ unitAvailEnv a = unitNameEnv (availName a) a 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 @@ -789,6 +896,7 @@ data InstOrigin -- of a rank-2 typed function | DoOrigin -- The monad for a do expression + | ProcOrigin -- A proc expression | ClassDeclOrigin -- Manufactured during a class decl @@ -847,6 +955,8 @@ pprInstLoc (InstLoc orig locn ctxt) = 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)