X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=59b0510cd88f77bceee7db72d82fd6dbbe064bb6;hb=904f158f9fe208b8154029dff655a6eab4b2828e;hp=c895f1814e81a947907ddf77995465a7c06dab62;hpb=0554dc08d9e05e812d264a682679b798fce1ff78;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index c895f18..59b0510 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -10,8 +10,9 @@ module Name ( -- The Name type Name, -- Abstract - mkLocalName, mkSysLocalName, mkTopName, - mkDerivedName, mkGlobalName, + mkLocalName, mkImportedLocalName, mkSysLocalName, + mkTopName, + mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInIdName, mkWiredInTyConName, maybeWiredInIdName, maybeWiredInTyConName, isWiredInName, @@ -20,20 +21,19 @@ module Name ( tidyTopName, nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, - isExportedName, nameSrcLoc, + isUserExportedName, nameSrcLoc, isLocallyDefinedName, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, - + -- Provenance Provenance(..), ImportReason(..), pprProvenance, ExportFlag(..), PrintUnqualified, - pprNameProvenance, systemProvenance, + pprNameProvenance, systemProvenance, hasBetterProv, -- Class NamedThing and overloaded friends NamedThing(..), - isExported, getSrcLoc, isLocallyDefined, getOccString ) where @@ -43,8 +43,8 @@ import {-# SOURCE #-} Var ( Id, setIdName ) import {-# SOURCE #-} TyCon ( TyCon, setTyConName ) import OccName -- All of it -import Module -import RdrName ( RdrName, mkRdrQual, mkRdrUnqual ) +import Module ( Module, moduleName, pprModule, mkVanillaModule ) +import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) @@ -93,11 +93,27 @@ mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) +mkImportedLocalName :: Unique -> OccName -> SrcLoc -> Name + -- Just the same as mkLocalName, except the provenance is different + -- Reason: this flags the name as one that came in from an interface file. + -- This is useful when trying to decide which of two type variables + -- should 'win' when unifying them. + -- NB: this is only for non-top-level names, so we use ImplicitImport +mkImportedLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, + n_prov = NonLocalDef ImplicitImport True } + + mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod, n_occ = occ, n_prov = prov } +mkKnownKeyGlobal :: (RdrName, Unique) -> Name +mkKnownKeyGlobal (rdr_name, uniq) + = mkGlobalName uniq (mkVanillaModule (rdrNameModule rdr_name)) + (rdrNameOcc rdr_name) + systemProvenance + mkSysLocalName :: Unique -> FAST_STRING -> Name mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = Local, n_occ = mkSrcVarOcc fs, n_prov = SystemProv } @@ -202,9 +218,7 @@ are exported. But also: \begin{code} tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name) tidyTopName mod env name - | isExported name = (env, name) -- Don't fiddle with an exported name - -- It should be in the TidyOccEnv already - | otherwise = (env', name') + = (env', name') where (env', occ') = tidyOccName env (n_occ name) @@ -354,7 +368,7 @@ nameOccName :: Name -> OccName nameModule :: Name -> Module nameSrcLoc :: Name -> SrcLoc isLocallyDefinedName :: Name -> Bool -isExportedName :: Name -> Bool +isUserExportedName :: Name -> Bool isWiredInName :: Name -> Bool isLocalName :: Name -> Bool isGlobalName :: Name -> Bool @@ -376,16 +390,16 @@ nameSortModule (WiredInTyCon mod _) = mod nameRdrName :: Name -> RdrName nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ -nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (nameSortModule sort) occ +nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ -isExportedName (Name { n_prov = LocalDef _ Exported }) = True -isExportedName other = False +isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True +isUserExportedName other = False nameSrcLoc name = provSrcLoc (n_prov name) provSrcLoc (LocalDef loc _) = loc provSrcLoc (NonLocalDef (UserImport _ loc _) _) = loc -provSrcLoc SystemProv = noSrcLoc +provSrcLoc other = noSrcLoc isLocallyDefinedName (Name {n_sort = Local}) = True -- Local (might have SystemProv) isLocallyDefinedName (Name {n_prov = LocalDef _ _}) = True -- Global, but defined here @@ -419,6 +433,15 @@ isGlobalName other = True -- does not mean visible at the source level (that's isExported). isExternallyVisibleName name = isGlobalName name +hasBetterProv :: Name -> Name -> Bool +hasBetterProv name1 name2 + = case n_prov name1 of + LocalDef _ _ -> True + SystemProv -> False + NonLocalDef _ _ -> case n_prov name2 of + LocalDef _ _ -> False + other -> True + isSystemName (Name {n_prov = SystemProv}) = True isSystemName other = False \end{code} @@ -440,8 +463,8 @@ instance Eq Name where a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord Name where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } compare a b = cmpName a b @@ -497,7 +520,7 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ, n_prov = prov}) pp_mod_dot sty = case prov of - SystemProv -> pp_qual mod pp_sep user_sty + SystemProv -> pp_qual mod user_sty -- Hack alert! Omit the qualifier on SystemProv things in user style -- I claim such SystemProv things will also be WiredIn things. -- We can't get the omit flag right @@ -505,24 +528,20 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ, n_prov = prov}) -- and hope that leaving it out isn't too consfusing. -- (e.g. if the programmer hides Bool and redefines it. If so, use -dppr-debug.) - LocalDef _ _ -> pp_qual mod dot (user_sty || iface_sty) + LocalDef _ _ -> pp_qual mod (user_sty || iface_sty) NonLocalDef (UserImport imp_mod _ _) omit - | user_sty -> pp_qual imp_mod pp_sep omit - | otherwise -> pp_qual mod pp_sep False - NonLocalDef ImplicitImport omit -> pp_qual mod pp_sep (user_sty && omit) + | user_sty -> pp_qual imp_mod omit + | otherwise -> pp_qual mod False + NonLocalDef ImplicitImport omit -> pp_qual mod (user_sty && omit) where user_sty = userStyle sty iface_sty = ifaceStyle sty - pp_qual mod sep omit_qual + pp_qual mod omit_qual | omit_qual = empty - | otherwise = pprModule mod <> sep + | otherwise = pprModule mod <> dot - pp_sep | bootFlavour (moduleIfaceFlavour mod) = text "!" -- M!t indicates a name imported - -- from a .hi-boot interface - | otherwise = dot -- Vanilla case - pp_global_debug sty uniq prov | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p prov, text "-}"] | otherwise = empty @@ -556,10 +575,8 @@ class NamedThing a where \begin{code} getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool -isExported :: NamedThing a => a -> Bool getOccString :: NamedThing a => a -> String -isExported = isExportedName . getName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName getOccString x = occNameString (getOccName x)