X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnTypes.lhs;h=62281b56a171f16f75d18660bde8cd8a62958f70;hp=f9f92755e1305ea92ab0675af8ecad2680d70a38;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hpb=d551dbfef0b710f5ede21ee0c54ee7e80dd53b64 diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index f9f9275..62281b5 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -20,14 +20,15 @@ module TcRnTypes( WhereFrom(..), mkModDeps, -- Typechecker types - TcTyThing(..), pprTcTyThingCategory, GadtRefinement, + TcTyThing(..), pprTcTyThingCategory, + GadtRefinement, -- Template Haskell ThStage(..), topStage, topSpliceStage, ThLevel, impLevel, topLevel, -- Arrows - ArrowCtxt(..), topArrowCtxt, ProcLevel, topProcLevel, + ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, -- Insts Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, @@ -42,16 +43,17 @@ module TcRnTypes( #include "HsVersions.h" import HsSyn ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl, - ArithSeqInfo, DictBinds, LHsBinds ) + ArithSeqInfo, DictBinds, LHsBinds, LImportDecl, HsGroup, + IE ) import HscTypes ( FixityEnv, HscEnv, TypeEnv, TyThing, GenAvailInfo(..), AvailInfo, HscSource(..), availName, IsBootInterface, Deprecations ) -import Packages ( PackageId ) -import Type ( Type, TvSubstEnv, pprParendType, pprTyThingCategory ) -import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo, +import Packages ( PackageId, HomeModules ) +import Type ( Type, pprTyThingCategory ) +import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo ) -import InstEnv ( DFunId, InstEnv ) +import InstEnv ( Instance, InstEnv ) import IOEnv import RdrName ( GlobalRdrEnv, LocalRdrEnv ) import Name ( Name ) @@ -61,7 +63,7 @@ import OccName ( OccEnv ) import Var ( Id, TyVar ) import VarEnv ( TidyEnv ) import Module -import SrcLoc ( SrcSpan, SrcLoc, srcSpanStart ) +import SrcLoc ( SrcSpan, SrcLoc, Located, srcSpanStart ) import VarSet ( IdSet ) import ErrUtils ( Messages, Message ) import UniqSupply ( UniqSupply ) @@ -162,6 +164,10 @@ data TcGblEnv -- from where, including things bound -- in this module + tcg_home_mods :: HomeModules, + -- Calculated from ImportAvails, allows us to + -- call Packages.isHomeModule + tcg_dus :: DefUses, -- What is defined in this module and what is used. -- The latter is used to generate -- (a) version tracking; no need to recompile if these @@ -196,12 +202,30 @@ data TcGblEnv -- tcg_inst_uses; the reference is implicit rather than explicit, -- so we have to zap a mutable variable. + tcg_dfun_n :: TcRef Int, -- Allows us to number off the names of DFuns + -- It's convenient to allocate an External Name for a DFun, with + -- a permanently-fixed unique, just like other top-level functions + -- defined in this module. But that means we need a canonical + -- occurrence name, distinct from all other dfuns in this module, + -- and this name supply serves that purpose (df1, df2, etc). + -- 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 + + -- 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_rn_imports :: Maybe [LImportDecl Name], + tcg_rn_exports :: Maybe [Located (IE Name)], + tcg_rn_decls :: Maybe (HsGroup Name), -- renamed decls, maybe + -- Nothing <=> Don't retain renamed decls + tcg_binds :: LHsBinds Id, -- Value bindings in this module tcg_deprecs :: Deprecations, -- ...Deprecations - tcg_insts :: [DFunId], -- ...Instances + tcg_insts :: [Instance], -- ...Instances tcg_rules :: [LRuleDecl Id], -- ...Rules tcg_fords :: [LForeignDecl Id] -- ...Foreign import & exports } @@ -300,16 +324,10 @@ data TcLclEnv -- Changes as we move inside an expression -- plus the tyvars mentioned in the types of Ids bound in tcl_lenv -- Why mutable? see notes with tcGetGlobalTyVars - tcl_lie :: TcRef LIE, -- Place to accumulate type constraints - tcl_gadt :: GadtRefinement -- The current type refinement for GADTs - ------------------------------------------------------------ --- Not yet; it's a new complication and I want to see whether it bites --- tcl_given :: [Inst] -- Insts available in the current context (see Note [Given Insts]) ------------------------------------------------------------ + tcl_lie :: TcRef LIE -- Place to accumulate type constraints } -type GadtRefinement = TvSubstEnv -- Binds rigid type variables to their refinements +type GadtRefinement = TvSubst {- Note [Given Insts] ~~~~~~~~~~~~~~~~~~ @@ -355,73 +373,76 @@ topStage, topSpliceStage :: ThStage topStage = Comp topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice - --------------------------- --- Arrow-notation stages +-- Arrow-notation context --------------------------- --- In arrow notation, a variable bound by a proc (or enclosed let/kappa) --- is not in scope to the left of an arrow tail (-<) or the head of (|..|). --- 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 --- proc 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, and increment the proc-level so that variables --- bound inside the expression are in scope. --- 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 = [] } +{- +In arrow notation, a variable bound by a proc (or enclosed let/kappa) +is not in scope to the left of an arrow tail (-<) or the head of (|..|). +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 + proc y -> (proc z -> e1) -< e2 + +Here, x and z are in scope in e1, but y is not. We implement this by +recording the environment when passing a proc (using newArrowScope), +and returning to that (using escapeArrowScope) on the left of -< and the +head of (|..|). +-} + +data ArrowCtxt + = NoArrowCtxt + | ArrowCtxt (Env TcGblEnv TcLclEnv) + +-- Record the current environment (outside a proc) +newArrowScope :: TcM a -> TcM a +newArrowScope + = updEnv $ \env -> + env { env_lcl = (env_lcl env) { tcl_arrow_ctxt = ArrowCtxt env } } + +-- Return to the stored environment (from the enclosing proc) +escapeArrowScope :: TcM a -> TcM a +escapeArrowScope + = updEnv $ \ env -> case tcl_arrow_ctxt (env_lcl env) of + NoArrowCtxt -> env + ArrowCtxt env' -> env' --------------------------- -- TcTyThing --------------------------- data TcTyThing - = AGlobal TyThing -- Used only in the return type of a lookup + = 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 + | ATcId TcId -- Ids defined in this module; may not be fully zonked + ThLevel + Bool -- True <=> apply the type refinement to me - | ATyVar Name TcType -- Type variables; tv -> type. It can't just be a TyVar - -- that is mutated to point to the type it is bound to, - -- because that would make it a wobbly type, and we - -- want pattern-bound lexically-scoped type variables to - -- be able to stand for rigid types + | ATyVar Name TcType -- The type to which the lexically scoped type vaiable + -- is currently refined. We only need the Name + -- for error-message purposes - | AThing TcKind -- Used temporarily, during kind checking, for the - -- tycons and clases in this recursive group + | AThing TcKind -- Used temporarily, during kind checking, for the + -- tycons and clases in this recursive group instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = ppr g - ppr (ATcId g tl pl) = text "Identifier" <> - ifPprDebug (brackets (ppr g <> comma <> ppr tl <> comma <> ppr pl)) - ppr (ATyVar tv ty) = text "Type variable" <+> quotes (ppr tv) <+> pprParendType ty + ppr (ATcId g tl rig) = text "Identifier" <> + ifPprDebug (brackets (ppr g <> comma <> ppr tl <+> ppr rig)) + ppr (ATyVar tv _) = text "Type variable" <+> quotes (ppr tv) ppr (AThing k) = text "AThing" <+> ppr k pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing -pprTcTyThingCategory (ATyVar _ _) = ptext SLIT("Type variable") -pprTcTyThingCategory (ATcId _ _ _) = ptext SLIT("Local identifier") -pprTcTyThingCategory (AThing _) = ptext SLIT("Kinded thing") +pprTcTyThingCategory (ATyVar {}) = ptext SLIT("Type variable") +pprTcTyThingCategory (ATcId {}) = ptext SLIT("Local identifier") +pprTcTyThingCategory (AThing {}) = ptext SLIT("Kinded thing") \end{code} \begin{code} @@ -464,22 +485,18 @@ data ImportAvails -- So the starting point is all things that are in scope as 'M.x', -- which is what this field tells us. - imp_mods :: ModuleEnv (Module, Maybe Bool, SrcSpan), + imp_mods :: ModuleEnv (Module, Bool, SrcSpan), -- Domain is all directly-imported modules - -- Maybe value answers the question "is the import restricted?" - -- Nothing => unrestricted import (e.g., "import Foo") - -- Just True => restricted import, at least one entity (e.g., "import Foo(x)") - -- Just False => fully restricted import (e.g., "import Foo ()") - -- - -- A distinction is made between the first and the third in order - -- to more precisely emit warnings about unused imports. + -- Bool means: + -- True => import was "import Foo ()" + -- False => import was some other form -- -- We need the Module in the range because we can't get -- the keys of a ModuleEnv -- Used -- (a) to help construct the usage information in - -- the interface file; if we import everything we - -- need to recompile if the module version changes + -- the interface file; if we import somethign we + -- need to recompile if the export version changes -- (b) to specify what child modules to initialise imp_dep_mods :: ModuleEnv (Module, IsBootInterface), @@ -657,8 +674,6 @@ data Inst TcThetaType -- The (types of the) dictionaries to which the function -- must be applied to get the method - TcTauType -- The tau-type of the method - InstLoc -- INVARIANT 1: in (Method u f tys theta tau loc) @@ -694,16 +709,16 @@ instance Eq Inst where EQ -> True other -> False -cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2 -cmpInst (Dict _ _ _) other = LT +cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2 +cmpInst (Dict _ _ _) other = LT -cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT -cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2) -cmpInst (Method _ _ _ _ _ _) other = LT +cmpInst (Method _ _ _ _ _) (Dict _ _ _) = GT +cmpInst (Method _ id1 tys1 _ _) (Method _ id2 tys2 _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2) +cmpInst (Method _ _ _ _ _) other = LT -cmpInst (LitInst _ _ _ _) (Dict _ _ _) = GT -cmpInst (LitInst _ _ _ _) (Method _ _ _ _ _ _) = GT -cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2) +cmpInst (LitInst _ _ _ _) (Dict _ _ _) = GT +cmpInst (LitInst _ _ _ _) (Method _ _ _ _ _) = GT +cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2) \end{code} @@ -714,6 +729,7 @@ cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit %************************************************************************ \begin{code} +-- FIXME: Rename this. It clashes with (Located (IE ...)) type LIE = Bag Inst isEmptyLIE = isEmptyBag