X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnTypes.lhs;h=62281b56a171f16f75d18660bde8cd8a62958f70;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=055a2dd185f642ddbcff1b0069ba389537f8cf5d;hpb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 055a2dd..62281b5 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -9,10 +9,10 @@ module TcRnTypes( -- The environment types Env(..), TcGblEnv(..), TcLclEnv(..), - IfGblEnv(..), IfLclEnv(..), + IfGblEnv(..), IfLclEnv(..), -- Ranamer types - EntityUsage, emptyUsages, ErrCtxt, + ErrCtxt, ImportAvails(..), emptyImportAvails, plusImportAvails, plusAvail, pruneAvails, AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv, @@ -20,14 +20,15 @@ module TcRnTypes( WhereFrom(..), mkModDeps, -- Typechecker types - TcTyThing(..), 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,26 +43,27 @@ 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, + GenAvailInfo(..), AvailInfo, HscSource(..), availName, IsBootInterface, Deprecations ) -import Packages ( PackageId ) -import Type ( Type, TvSubstEnv ) -import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo, - TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes ) -import InstEnv ( DFunId, InstEnv ) +import Packages ( PackageId, HomeModules ) +import Type ( Type, pprTyThingCategory ) +import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst, + TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo ) +import InstEnv ( Instance, InstEnv ) import IOEnv import RdrName ( GlobalRdrEnv, LocalRdrEnv ) import Name ( Name ) import NameEnv -import NameSet ( NameSet, emptyNameSet, DefUses ) +import NameSet ( NameSet, unionNameSets, DefUses ) 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 ) @@ -129,6 +131,9 @@ data Env gbl lcl -- Changes as we move into an expression data TcGblEnv = TcGblEnv { tcg_mod :: Module, -- Module being compiled + tcg_src :: HscSource, -- What kind of module + -- (regular Haskell, hs-boot, ext-core) + tcg_rdr_env :: GlobalRdrEnv, -- Top level envt; used during renaming tcg_default :: Maybe [Type], -- Types used for defaulting -- Nothing => no 'default' decl @@ -159,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 @@ -193,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 } @@ -232,6 +259,13 @@ data IfLclEnv -- it means M.f = \x -> x, where M is the if_mod if_mod :: Module, + -- The field is used only for error reporting + -- if (say) there's a Lint error in it + if_loc :: SDoc, + -- Where the interface came from: + -- .hi file, or GHCi state, or ext core + -- plus which bit is currently being examined + if_tv_env :: OccEnv TyVar, -- Nested tyvar bindings if_id_env :: OccEnv Id -- Nested id binding } @@ -290,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] ~~~~~~~~~~~~~~~~~~ @@ -345,57 +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 (-<). 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 +{- +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 -type ProcLevel = Int -- Always >= 0 -topProcLevel = 0 -- Not inside any proc +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) -data ArrowCtxt = ArrCtxt { proc_level :: ProcLevel, -- Current level - proc_banned :: [ProcLevel] } -- Out of scope proc-levels +-- 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 } } -topArrowCtxt = ArrCtxt { proc_level = topProcLevel, proc_banned = [] } +-- 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 - | 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, for the - -- tycons and clases in this recursive group + = AGlobal TyThing -- Used only in the return type of a lookup + + | ATcId TcId -- Ids defined in this module; may not be fully zonked + ThLevel + Bool -- True <=> apply the type refinement to me + + | 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 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 (AGlobal g) = ppr g + 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") \end{code} \begin{code} @@ -408,32 +455,6 @@ type ErrCtxt = [TidyEnv -> TcM (TidyEnv, Message)] %************************************************************************ %* * - EntityUsage -%* * -%************************************************************************ - -EntityUsage tells what things are actually need in order to compile this -module. It is used for generating the usage-version field of the ModIface. - -Note that we do not record version info for entities from -other (non-home) packages. If the package changes, GHC doesn't help. - -\begin{code} -type EntityUsage = NameSet - -- The Names are all the (a) home-package - -- (b) "big" (i.e. no data cons, class ops) - -- (c) non-locally-defined - -- (d) non-wired-in - -- names that have been slurped in so far. - -- This is used to generate the "usage" information for this module. - -emptyUsages :: EntityUsage -emptyUsages = emptyNameSet -\end{code} - - -%************************************************************************ -%* * Operations over ImportAvails %* * %************************************************************************ @@ -449,44 +470,33 @@ It is used * when processing the export list \begin{code} data ImportAvails = ImportAvails { - imp_env :: AvailEnv, - -- All the things that are available from the import - -- Its domain is all the "main" things; - -- i.e. *excluding* class ops and constructors - -- (which appear inside their parent AvailTC) - - imp_qual :: ModuleEnv AvailEnv, - -- Used to figure out "module M" export specifiers + imp_env :: ModuleEnv NameSet, + -- All the things imported, classified by + -- the *module qualifier* for its import + -- e.g. import List as Foo + -- would add a binding Foo |-> ...stuff from List... + -- to imp_env. + -- + -- We need to classify them like this so that we can figure out + -- "module M" export specifiers in an export list -- (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 - 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), @@ -515,8 +525,7 @@ mkModDeps deps = foldl add emptyModuleEnv deps add env elt@(m,_) = extendModuleEnv env m elt emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv, - imp_qual = emptyModuleEnv, +emptyImportAvails = ImportAvails { imp_env = emptyModuleEnv, imp_mods = emptyModuleEnv, imp_dep_mods = emptyModuleEnv, imp_dep_pkgs = [], @@ -524,12 +533,11 @@ emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv, plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails - (ImportAvails { imp_env = env1, imp_qual = unqual1, imp_mods = mods1, + (ImportAvails { imp_env = env1, imp_mods = mods1, imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_orphs = orphs1 }) - (ImportAvails { imp_env = env2, imp_qual = unqual2, imp_mods = mods2, + (ImportAvails { imp_env = env2, 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, + = ImportAvails { imp_env = plusModuleEnv_C unionNameSets env1 env2, imp_mods = mods1 `plusModuleEnv` mods2, imp_dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2, imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, @@ -666,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) @@ -681,10 +687,11 @@ data Inst | LitInst Name - HsOverLit -- The literal from the occurrence site - -- INVARIANT: never a rebindable-syntax literal - -- Reason: tcSyntaxName does unification, and we - -- don't want to deal with that during tcSimplify + (HsOverLit Name) -- The literal from the occurrence site + -- INVARIANT: never a rebindable-syntax literal + -- Reason: tcSyntaxName does unification, and we + -- don't want to deal with that during tcSimplify, + -- when resolving LitInsts TcType -- The type at which the literal is used InstLoc \end{code} @@ -702,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} @@ -722,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 @@ -772,7 +780,7 @@ data InstOrigin | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter - | LiteralOrigin HsOverLit -- Occurrence of a literal + | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc | PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:] @@ -790,8 +798,6 @@ data InstOrigin \begin{code} pprInstLoc :: InstLoc -> SDoc -pprInstLoc (InstLoc (SigOrigin info) locn _) - = text "arising from" <+> ppr info -- I don't think this happens much, if at all pprInstLoc (InstLoc orig locn _) = hsep [text "arising from", pp_orig orig, text "at", ppr locn] where @@ -802,11 +808,11 @@ pprInstLoc (InstLoc orig locn _) pp_orig (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)] pp_orig (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)] pp_orig (PArrSeqOrigin seq) = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)] - pp_orig InstSigOrigin = ptext SLIT("instantiating a type signature") - pp_orig InstScOrigin = ptext SLIT("the superclasses of an instance declaration") + pp_orig InstSigOrigin = ptext SLIT("instantiating a type signature") + pp_orig InstScOrigin = ptext SLIT("the superclasses of an instance declaration") pp_orig DerivOrigin = ptext SLIT("the 'deriving' clause of a data type declaration") pp_orig DefaultOrigin = ptext SLIT("a 'default' declaration") - pp_orig DoOrigin = ptext SLIT("a do statement") - pp_orig ProcOrigin = ptext SLIT("a proc expression") - pp_orig (SigOrigin info) = ppr info + pp_orig DoOrigin = ptext SLIT("a do statement") + pp_orig ProcOrigin = ptext SLIT("a proc expression") + pp_orig (SigOrigin info) = pprSkolInfo info \end{code}