X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnTypes.lhs;h=c5620e7360e5d93530de58687063803bde8d1aaa;hb=2b57ddc3e802a5d93b30a21e198077b016e2e008;hp=10f6d44d36e5a2226c0f9bb3ad09b15cfee82df2;hpb=c4d85183321cb88070d5e6a76dbc4594ebaf2f48;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 10f6d44..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,18 +23,21 @@ 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, + Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc, LIE, emptyLIE, unitLIE, plusLIE, consLIE, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, @@ -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} %************************************************************************ %* * @@ -235,6 +291,7 @@ data TopEnv -- Built once at top level then does not change -- 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 @@ -273,15 +330,20 @@ data TcGblEnv -- (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. @@ -291,7 +353,10 @@ data TcGblEnv 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 @@ -327,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 @@ -341,21 +407,25 @@ 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 -topLevel = 1 -- Things dedined at top level of this module +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 -- -- For example: @@ -363,17 +433,62 @@ 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. -- 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 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} @@ -449,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 @@ -582,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 @@ -661,13 +783,19 @@ data Inst 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 @@ -739,7 +867,10 @@ It appears in TcMonad because there are a couple of error-message-generation 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 @@ -765,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 @@ -794,7 +926,7 @@ data InstOrigin \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) @@ -823,6 +955,8 @@ pprInstLoc (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)