X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnTypes.lhs;h=62281b56a171f16f75d18660bde8cd8a62958f70;hp=3d1329fed717440d032889e43c547a816c83733b;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hpb=dd313897eb9a14bcc7b81f97e4f2292c30039efd diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 3d1329f..62281b5 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -20,12 +20,16 @@ module TcRnTypes( WhereFrom(..), mkModDeps, -- Typechecker types - TcTyThing(..), pprTcTyThingCategory, GadtRefinement, + TcTyThing(..), pprTcTyThingCategory, + GadtRefinement, -- Template Haskell ThStage(..), topStage, topSpliceStage, ThLevel, impLevel, topLevel, + -- Arrows + ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, + -- Insts Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc, instLocSrcSpan, @@ -39,14 +43,15 @@ module TcRnTypes( #include "HsVersions.h" import HsSyn ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl, - ArithSeqInfo, DictBinds, LHsBinds, HsGroup ) + 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 ( Instance, InstEnv ) import IOEnv @@ -58,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 ) @@ -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 @@ -209,6 +218,8 @@ data TcGblEnv -- 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 @@ -291,6 +302,7 @@ data TcLclEnv -- Changes as we move inside an expression tcl_errs :: TcRef Messages, -- Place to accumulate errors tcl_th_ctxt :: ThStage, -- Template Haskell context + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context tcl_rdr :: LocalRdrEnv, -- Local name envt -- Maintained during renaming, of course, but also during @@ -312,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] ~~~~~~~~~~~~~~~~~~ @@ -367,37 +373,76 @@ topStage, topSpliceStage :: ThStage topStage = Comp topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice +--------------------------- +-- 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. 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 -- 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) = text "Identifier" <> - ifPprDebug (brackets (ppr g <> comma <> ppr tl)) - 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} @@ -440,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), @@ -633,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) @@ -670,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} @@ -690,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