diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-06-04 19:13:56 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-07-22 20:23:00 -0400 |
commit | 7f44df1ec6df2b02be83e41cec4dc3b5f7f540f0 (patch) | |
tree | cf061835b5622e41cd40f3b44a4d04019de51628 | |
parent | 02f40b0da2eadbf8a0e2930b95d4cef686acd92f (diff) | |
download | haskell-7f44df1ec6df2b02be83e41cec4dc3b5f7f540f0.tar.gz |
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
-rw-r--r-- | compiler/GHC/Runtime/Linker.hs | 19 | ||||
-rw-r--r-- | compiler/GHC/Unit/Info.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Unit/Ppr.hs | 25 | ||||
-rw-r--r-- | compiler/GHC/Unit/State.hs | 46 | ||||
-rw-r--r-- | compiler/GHC/Unit/State.hs-boot | 4 | ||||
-rw-r--r-- | compiler/GHC/Unit/Types.hs | 16 | ||||
-rw-r--r-- | testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.stderr | 4 |
7 files changed, 63 insertions, 56 deletions
diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index 5b7b79c999..530fb767c3 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/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") diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs index ee51086e13..002fb1b6a9 100644 --- a/compiler/GHC/Unit/Info.hs +++ b/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) diff --git a/compiler/GHC/Unit/Ppr.hs b/compiler/GHC/Unit/Ppr.hs index 6c11dae34e..be969ea0f9 100644 --- a/compiler/GHC/Unit/Ppr.hs +++ b/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 + ] diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index 2efd9626e6..6406e79e07 100644 --- a/compiler/GHC/Unit/State.hs +++ b/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 diff --git a/compiler/GHC/Unit/State.hs-boot b/compiler/GHC/Unit/State.hs-boot index cc77d2b478..f03c12fac3 100644 --- a/compiler/GHC/Unit/State.hs-boot +++ b/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 diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index 49a59cd9b5..c8847c8215 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/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 diff --git a/testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.stderr b/testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.stderr index 937ec2f055..a266829205 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal06/bkpcabal06.stderr +++ b/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] |