[Git][ghc/ghc][master] Minor refactoring of Unit display
Marge Bot
gitlab at gitlab.haskell.org
Thu Jul 23 00:23:06 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7f44df1e by Sylvain Henry at 2020-07-22T20:23:00-04:00
Minor refactoring of Unit display
* for consistency, try to always use UnitPprInfo to display units to
users
* remove some uses of `unitPackageIdString` as it doesn't show the
component name and it uses String
- - - - -
7 changed files:
- compiler/GHC/Runtime/Linker.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/Ppr.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/State.hs-boot
- compiler/GHC/Unit/Types.hs
- testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.stderr
Changes:
=====================================
compiler/GHC/Runtime/Linker.hs
=====================================
@@ -1323,8 +1323,8 @@ linkPackage hsc_env pkg
all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
- maybePutStr dflags
- ("Loading package " ++ unitPackageIdString pkg ++ " ... ")
+ maybePutSDoc dflags
+ (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ")
-- See comments with partOfGHCi
#if defined(CAN_LOAD_DLL)
@@ -1354,9 +1354,9 @@ linkPackage hsc_env pkg
if succeeded ok
then maybePutStrLn dflags "done."
- else let errmsg = "unable to load package `"
- ++ unitPackageIdString pkg ++ "'"
- in throwGhcExceptionIO (InstallationError errmsg)
+ else let errmsg = text "unable to load unit `"
+ <> pprUnitInfoForUser pkg <> text "'"
+ in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))
{-
Note [Crash early load_dyn and locateLib]
@@ -1731,14 +1731,17 @@ loadFramework hsc_env extraPaths rootname
********************************************************************* -}
-maybePutStr :: DynFlags -> String -> IO ()
-maybePutStr dflags s
+maybePutSDoc :: DynFlags -> SDoc -> IO ()
+maybePutSDoc dflags s
= when (verbosity dflags > 1) $
putLogMsg dflags
NoReason
SevInteractive
noSrcSpan
- $ withPprStyle defaultUserStyle (text s)
+ $ withPprStyle defaultUserStyle s
+
+maybePutStr :: DynFlags -> String -> IO ()
+maybePutStr dflags s = maybePutSDoc dflags (text s)
maybePutStrLn :: DynFlags -> String -> IO ()
maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
=====================================
compiler/GHC/Unit/Info.hs
=====================================
@@ -168,8 +168,9 @@ mkUnit p
| otherwise = RealUnit (Definite (unitId p))
-- | Create a UnitPprInfo from a UnitInfo
-mkUnitPprInfo :: GenUnitInfo u -> UnitPprInfo
-mkUnitPprInfo i = UnitPprInfo
+mkUnitPprInfo :: (u -> FastString) -> GenUnitInfo u -> UnitPprInfo
+mkUnitPprInfo ufs i = UnitPprInfo
+ (ufs (unitId i))
(unitPackageNameString i)
(unitPackageVersion i)
((unpackFS . unPackageName) <$> unitComponentName i)
=====================================
compiler/GHC/Unit/Ppr.hs
=====================================
@@ -5,6 +5,7 @@ module GHC.Unit.Ppr
where
import GHC.Prelude
+import GHC.Data.FastString
import GHC.Utils.Outputable
import Data.Version
@@ -14,18 +15,22 @@ import Data.Version
-- package-version:componentname
--
data UnitPprInfo = UnitPprInfo
- { unitPprPackageName :: String -- ^ Source package name
+ { unitPprId :: FastString -- ^ Identifier
+ , unitPprPackageName :: String -- ^ Source package name
, unitPprPackageVersion :: Version -- ^ Source package version
, unitPprComponentName :: Maybe String -- ^ Component name
}
instance Outputable UnitPprInfo where
- ppr pprinfo = text $ mconcat
- [ unitPprPackageName pprinfo
- , case unitPprPackageVersion pprinfo of
- Version [] [] -> ""
- version -> "-" ++ showVersion version
- , case unitPprComponentName pprinfo of
- Nothing -> ""
- Just cname -> ":" ++ cname
- ]
+ ppr pprinfo = getPprDebug $ \debug ->
+ if debug
+ then ftext (unitPprId pprinfo)
+ else text $ mconcat
+ [ unitPprPackageName pprinfo
+ , case unitPprPackageVersion pprinfo of
+ Version [] [] -> ""
+ version -> "-" ++ showVersion version
+ , case unitPprComponentName pprinfo of
+ Nothing -> ""
+ Just cname -> ":" ++ cname
+ ]
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -28,7 +28,6 @@ module GHC.Unit.State (
lookupPackageName,
improveUnit,
searchPackageId,
- displayUnitId,
listVisibleModuleNames,
lookupModuleInAllUnits,
lookupModuleWithSuggestions,
@@ -61,14 +60,18 @@ module GHC.Unit.State (
instUnitToUnit,
instModuleToModule,
- -- * Utils
- mkIndefUnitId,
- updateIndefUnitId,
- unwireUnit,
+ -- * Pretty-printing
pprFlag,
pprUnits,
pprUnitsSimple,
+ pprUnitIdForUser,
+ pprUnitInfoForUser,
pprModuleMap,
+
+ -- * Utils
+ mkIndefUnitId,
+ updateIndefUnitId,
+ unwireUnit,
homeUnitIsIndefinite,
homeUnitIsDefinite,
)
@@ -81,6 +84,7 @@ import GHC.Prelude
import GHC.Platform
import GHC.Unit.Database
import GHC.Unit.Info
+import GHC.Unit.Ppr
import GHC.Unit.Types
import GHC.Unit.Module
import GHC.Driver.Session
@@ -887,7 +891,7 @@ findPackages prec_map pkg_map closure arg pkgs unusable
else Right (sortByPreference prec_map ps)
where
finder (PackageArg str) p
- = if str == unitPackageIdString p || str == unitPackageNameString p
+ = if matchingStr str p
then Just p
else Nothing
finder (UnitIdArg uid) p
@@ -2100,6 +2104,8 @@ add_unit pkg_map ps (p, mb_parent)
-- -----------------------------------------------------------------------------
+-- | Pretty-print a UnitId for the user.
+--
-- Cabal packages may contain several components (programs, libraries, etc.).
-- As far as GHC is concerned, installed package components ("units") are
-- identified by an opaque IndefUnitId string provided by Cabal. As the string
@@ -2111,26 +2117,30 @@ add_unit pkg_map ps (p, mb_parent)
--
-- Component name is only displayed if it isn't the default library
--
--- To do this we need to query the database (cached in DynFlags). We cache
--- these details in the IndefUnitId itself because we don't want to query
--- DynFlags each time we pretty-print the IndefUnitId
---
+-- To do this we need to query a unit database.
+pprUnitIdForUser :: UnitState -> UnitId -> SDoc
+pprUnitIdForUser state uid@(UnitId fs) =
+ case lookupUnitPprInfo state uid of
+ Nothing -> ftext fs -- we didn't find the unit at all
+ Just i -> ppr i
+
+pprUnitInfoForUser :: UnitInfo -> SDoc
+pprUnitInfoForUser info = ppr (mkUnitPprInfo unitIdFS info)
+
+lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo
+lookupUnitPprInfo state uid = fmap (mkUnitPprInfo unitIdFS) (lookupUnitId state uid)
+
+-- | Create a IndefUnitId.
mkIndefUnitId :: UnitState -> FastString -> IndefUnitId
-mkIndefUnitId pkgstate raw =
+mkIndefUnitId state raw =
let uid = UnitId raw
- in case lookupUnitId pkgstate uid of
- Nothing -> Indefinite uid Nothing -- we didn't find the unit at all
- Just c -> Indefinite uid $ Just $ mkUnitPprInfo c
+ in Indefinite uid $! lookupUnitPprInfo state uid
-- | Update component ID details from the database
updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId
updateIndefUnitId pkgstate uid = mkIndefUnitId pkgstate (unitIdFS (indefUnit uid))
-displayUnitId :: UnitState -> UnitId -> Maybe String
-displayUnitId pkgstate uid =
- fmap unitPackageIdString (lookupUnitId pkgstate uid)
-
-- -----------------------------------------------------------------------------
-- Displaying packages
=====================================
compiler/GHC/Unit/State.hs-boot
=====================================
@@ -1,7 +1,7 @@
module GHC.Unit.State where
-import GHC.Prelude
import GHC.Data.FastString
+import {-# SOURCE #-} GHC.Utils.Outputable
import {-# SOURCE #-} GHC.Unit.Types (IndefUnitId, UnitId)
data UnitState
@@ -9,5 +9,5 @@ data UnitDatabase unit
emptyUnitState :: UnitState
mkIndefUnitId :: UnitState -> FastString -> IndefUnitId
-displayUnitId :: UnitState -> UnitId -> Maybe String
+pprUnitIdForUser :: UnitState -> UnitId -> SDoc
updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -103,7 +103,7 @@ import Data.Bifunctor
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
-import {-# SOURCE #-} GHC.Unit.State (UnitState,displayUnitId)
+import {-# SOURCE #-} GHC.Unit.State (pprUnitIdForUser)
import {-# SOURCE #-} GHC.Driver.Session (unitState)
---------------------------------------------------------------------
@@ -508,19 +508,7 @@ instance Uniquable UnitId where
getUnique = getUnique . unitIdFS
instance Outputable UnitId where
- ppr uid = sdocWithDynFlags $ \dflags -> pprUnitId (unitState dflags) uid
-
--- | Pretty-print a UnitId
---
--- In non-debug mode, query the given database to try to print
--- "package-version:component" instead of the raw UnitId
-pprUnitId :: UnitState -> UnitId -> SDoc
-pprUnitId state uid@(UnitId fs) = getPprDebug $ \debug ->
- if debug
- then ftext fs
- else case displayUnitId state uid of
- Just str -> text str
- _ -> ftext fs
+ ppr uid = sdocWithDynFlags $ \dflags -> pprUnitIdForUser (unitState dflags) uid
-- | A 'DefUnitId' is an 'UnitId' with the invariant that
-- it only refers to a definite library; i.e., one we have generated
=====================================
testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.stderr
=====================================
@@ -1,4 +1,4 @@
sig/P.hsig:1:1: error:
- • ‘p’ is exported by the hsig file, but not exported by the implementing module ‘bkpcabal06-0.1.0.0:P’
- • while checking that bkpcabal06-0.1.0.0:P implements signature P in bkpcabal06-0.1.0.0:sig[P=bkpcabal06-0.1.0.0:P]
+ • ‘p’ is exported by the hsig file, but not exported by the implementing module ‘bkpcabal06-0.1.0.0:impl:P’
+ • while checking that bkpcabal06-0.1.0.0:impl:P implements signature P in bkpcabal06-0.1.0.0:sig[P=bkpcabal06-0.1.0.0:impl:P]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f44df1ec6df2b02be83e41cec4dc3b5f7f540f0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f44df1ec6df2b02be83e41cec4dc3b5f7f540f0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200722/58281011/attachment-0001.html>
More information about the ghc-commits
mailing list