X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=d0c2f1332e52711c55637c379af1a96b864ae6f9;hb=b78e736684ec530ee363ac44f88b328820592481;hp=66f936faf8c4bc73df471c332abf2f68a692be78;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 66f936f..d0c2f13 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -4,13 +4,6 @@ \section[HscTypes]{Types for the per-module compiler} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings --- for details - module HscTypes ( -- * Sessions and compilation state Session(..), withSession, modifySession, @@ -85,9 +78,7 @@ import ByteCodeAsm ( CompiledByteCode ) import {-# SOURCE #-} InteractiveEval ( Resume ) #endif -import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, GlobalRdrElt(..), - mkRdrUnqual, ImpDeclSpec(..), Provenance(..), - ImportSpec(..), lookupGlobalRdrEnv, lookupGRE_RdrName ) +import RdrName import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet @@ -108,7 +99,7 @@ import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon import DataCon ( DataCon, dataConImplicitIds ) import PrelNames ( gHC_PRIM ) -import Packages ( PackageId ) +import Packages hiding ( Version(..) ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( Version, initialVersion, IPName, @@ -239,6 +230,7 @@ pprTarget (Target id _) = pprTargetId id instance Outputable Target where ppr = pprTarget +pprTargetId :: TargetId -> SDoc pprTargetId (TargetModule m) = ppr m pprTargetId (TargetFile f _) = text f @@ -251,7 +243,10 @@ type HomePackageTable = ModuleNameEnv HomeModInfo type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported packages +emptyHomePackageTable :: HomePackageTable emptyHomePackageTable = emptyUFM + +emptyPackageIfaceTable :: PackageIfaceTable emptyPackageIfaceTable = emptyModuleEnv data HomeModInfo @@ -499,16 +494,15 @@ data ModDetails md_insts :: ![Instance], -- Dfun-ids for the instances in this module md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- Domain may include Ids from other modules - md_modBreaks :: !ModBreaks, -- Breakpoint information for this module md_vect_info :: !VectInfo -- Vectorisation information } +emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_exports = [], md_insts = [], md_rules = [], md_fam_insts = [], - md_modBreaks = emptyModBreaks, md_vect_info = noVectInfo } @@ -591,7 +585,8 @@ data CgGuts cg_foreign :: !ForeignStubs, cg_dep_pkgs :: ![PackageId], -- Used to generate #includes for C code gen - cg_hpc_info :: !HpcInfo -- info about coverage tick boxes + cg_hpc_info :: !HpcInfo, -- info about coverage tick boxes + cg_modBreaks :: !ModBreaks } ----------------------------------- @@ -681,6 +676,7 @@ data InteractiveContext } +emptyInteractiveContext :: InteractiveContext emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], ic_exports = [], @@ -692,8 +688,8 @@ emptyInteractiveContext #endif } -icPrintUnqual :: InteractiveContext -> PrintUnqualified -icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt) +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt) extendInteractiveContext @@ -730,20 +726,44 @@ substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst = %* * %************************************************************************ +Deciding how to print names is pretty tricky. We are given a name +P:M.T, where P is the package name, M is the defining module, and T is +the occurrence name, and we have to decide in which form to display +the name given a GlobalRdrEnv describing the current scope. + +Ideally we want to display the name in the form in which it is in +scope. However, the name might not be in scope at all, and that's +where it gets tricky. Here are the cases: + + 1. T uniquely maps to P:M.T ---> "T" + 2. there is an X for which X.T uniquely maps to P:M.T ---> "X.T" + 3. there is no binding for "M.T" ---> "M.T" + 4. otherwise ---> "P:M.T" + +3 and 4 apply when P:M.T is not in scope. In these cases we want to +refer to the name as "M.T", but "M.T" might mean something else in the +current scope (e.g. if there's an "import X as M"), so to avoid +confusion we avoid using "M.T" if there's already a binding for it. + +There's one further subtlety: if the module M cannot be imported +because it is not exposed by any package, then we must refer to it as +"P:M". This is handled by the qual_mod component of PrintUnqualified. + \begin{code} -mkPrintUnqualified :: GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified env = (qual_name, qual_mod) +mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified dflags env = (qual_name, qual_mod) where qual_name mod occ -- The (mod,occ) pair is the original name of the thing - | [gre] <- unqual_gres, right_name gre = Nothing + | [gre] <- unqual_gres, right_name gre = NameUnqual -- If there's a unique entity that's in scope unqualified with 'occ' -- AND that entity is the right one, then we can use the unqualified name - | [gre] <- qual_gres = Just (get_qual_mod (gre_prov gre)) + | [gre] <- qual_gres = NameQual (get_qual_mod (gre_prov gre)) - | null qual_gres = Just (moduleName mod) - -- it isn't in scope at all, this probably shouldn't happen, - -- but we'll qualify it by the original module anyway. + | null qual_gres = + if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + then NameNotInScope1 + else NameNotInScope2 | otherwise = panic "mkPrintUnqualified" where @@ -755,7 +775,22 @@ mkPrintUnqualified env = (qual_name, qual_mod) get_qual_mod LocalDef = moduleName mod get_qual_mod (Imported is) = ASSERT( not (null is) ) is_as (is_decl (head is)) - qual_mod mod = Nothing -- For now, we never qualify module names with their packages + -- we can mention a module P:M without the P: qualifier iff + -- "import M" would resolve unambiguously to P:M. (if P is the + -- current package we can just assume it is unqualified). + + qual_mod mod + | modulePackageId mod == thisPackage dflags = False + + | [pkgconfig] <- [pkg | (pkg,exposed_module) <- lookup, + exposed pkg && exposed_module], + packageConfigId pkgconfig == modulePackageId mod + -- this says: we are given a module P:M, is there just one exposed package + -- that exposes a module M, and is it package P? + = False + + | otherwise = True + where lookup = lookupModuleInAllPackages dflags (moduleName mod) \end{code} @@ -769,7 +804,7 @@ mkPrintUnqualified env = (qual_name, qual_mod) implicitTyThings :: TyThing -> [TyThing] -- If you change this, make sure you change LoadIface.ifaceDeclSubBndrs in sync -implicitTyThings (AnId id) = [] +implicitTyThings (AnId _) = [] -- For type constructors, add the data cons (and their extras), -- and the selectors and generic-programming Ids too @@ -803,10 +838,12 @@ isImplicitTyThing (AClass _) = False isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc -- For newtypes and indexed data types, add the implicit coercion tycon +implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc = map ATyCon . catMaybes $ [newTyConCo_maybe tc, tyConFamilyCoercion_maybe tc] +extras_plus :: TyThing -> [TyThing] extras_plus thing = thing : implicitTyThings thing extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv @@ -870,17 +907,21 @@ lookupType dflags hpt pte name \end{code} \begin{code} +tyThingTyCon :: TyThing -> TyCon tyThingTyCon (ATyCon tc) = tc -tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) +tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other) +tyThingClass :: TyThing -> Class tyThingClass (AClass cls) = cls -tyThingClass other = pprPanic "tyThingClass" (ppr other) +tyThingClass other = pprPanic "tyThingClass" (pprTyThing other) +tyThingDataCon :: TyThing -> DataCon tyThingDataCon (ADataCon dc) = dc -tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) +tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other) +tyThingId :: TyThing -> Id tyThingId (AnId id) = id -tyThingId other = pprPanic "tyThingId" (ppr other) +tyThingId other = pprPanic "tyThingId" (pprTyThing other) \end{code} %************************************************************************ @@ -906,7 +947,7 @@ mkIfaceVerCache pairs add_imp bndr env = extendOccEnv env bndr (decl_name, v) emptyIfaceVerCache :: OccName -> Maybe (OccName, Version) -emptyIfaceVerCache occ = Nothing +emptyIfaceVerCache _occ = Nothing ------------------ Deprecations ------------------------- data Deprecs a @@ -924,18 +965,18 @@ type Deprecations = Deprecs (NameEnv (OccName,DeprecTxt)) -- deprecation appears. mkIfaceDepCache:: IfaceDeprecs -> Name -> Maybe DeprecTxt -mkIfaceDepCache NoDeprecs = \n -> Nothing -mkIfaceDepCache (DeprecAll t) = \n -> Just t +mkIfaceDepCache NoDeprecs = \_ -> Nothing +mkIfaceDepCache (DeprecAll t) = \_ -> Just t mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName emptyIfaceDepCache :: Name -> Maybe DeprecTxt -emptyIfaceDepCache n = Nothing +emptyIfaceDepCache _ = Nothing plusDeprecs :: Deprecations -> Deprecations -> Deprecations plusDeprecs d NoDeprecs = d plusDeprecs NoDeprecs d = d -plusDeprecs d (DeprecAll t) = DeprecAll t -plusDeprecs (DeprecAll t) d = DeprecAll t +plusDeprecs _ (DeprecAll t) = DeprecAll t +plusDeprecs (DeprecAll t) _ = DeprecAll t plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2) \end{code} @@ -971,7 +1012,7 @@ availName (AvailTC n _) = n availNames :: GenAvailInfo name -> [name] availNames (Avail n) = [n] -availNames (AvailTC n ns) = ns +availNames (AvailTC _ ns) = ns instance Outputable n => Outputable (GenAvailInfo n) where ppr = pprAvail @@ -989,7 +1030,7 @@ mkIfaceFixCache pairs env = mkOccEnv pairs emptyIfaceFixCache :: OccName -> Fixity -emptyIfaceFixCache n = defaultFixity +emptyIfaceFixCache _ = defaultFixity -- This fixity environment is for source code only type FixityEnv = NameEnv FixItem @@ -1386,10 +1427,10 @@ data Unlinked = DotO FilePath | DotA FilePath | DotDLL FilePath - | BCOs CompiledByteCode + | BCOs CompiledByteCode ModBreaks #ifndef GHCI -data CompiledByteCode = NoByteCode +data CompiledByteCode #endif instance Outputable Unlinked where @@ -1397,25 +1438,29 @@ instance Outputable Unlinked where ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path #ifdef GHCI - ppr (BCOs bcos) = text "BCOs" <+> ppr bcos + ppr (BCOs bcos _) = text "BCOs" <+> ppr bcos #else - ppr (BCOs bcos) = text "No byte code" + ppr (BCOs _ _) = text "No byte code" #endif +isObject :: Unlinked -> Bool isObject (DotO _) = True isObject (DotA _) = True isObject (DotDLL _) = True isObject _ = False +isInterpretable :: Unlinked -> Bool isInterpretable = not . isObject +nameOfObject :: Unlinked -> FilePath nameOfObject (DotO fn) = fn nameOfObject (DotA fn) = fn nameOfObject (DotDLL fn) = fn nameOfObject other = pprPanic "nameOfObject" (ppr other) -byteCodeOfObject (BCOs bc) = bc -byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) +byteCodeOfObject :: Unlinked -> CompiledByteCode +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) \end{code} %************************************************************************