[Git][ghc/ghc][master] Refactor UnitId pretty-printing
Marge Bot
gitlab at gitlab.haskell.org
Wed Aug 26 08:51:08 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
0b17fa18 by Sylvain Henry at 2020-08-26T04:50:58-04:00
Refactor UnitId pretty-printing
When we pretty-print a UnitId for the user, we try to map it back to its
origin package name, version and component to print
"package-version:component" instead of some hash.
The UnitId type doesn't carry these information, so we have to look into
a UnitState to find them. This is why the Outputable instance of
UnitId used `sdocWithDynFlags` in order to access the `unitState` field
of DynFlags.
This is wrong for several reasons:
1. The DynFlags are accessed when the message is printed, not when it is
generated. So we could imagine that the unitState may have changed
in-between. Especially if we want to allow unit unloading.
2. We want GHC to support several independent sessions at once, hence
several UnitState. The current approach supposes there is a unique
UnitState as a UnitId doesn't indicate which UnitState to use.
See the Note [Pretty-printing UnitId] in GHC.Unit for the new approach
implemented by this patch.
One step closer to remove `sdocDynFlags` field from `SDocContext`
(#10143).
Fix #18124.
Also fix some Backpack code to use SDoc instead of String.
- - - - -
24 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Finder.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Ppr.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Driver/Types.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit.hs
- compiler/GHC/Unit/Home.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/Parser.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Unit/State.hs-boot
- compiler/GHC/Unit/Types.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -1682,7 +1682,7 @@ interpretPackageEnv dflags = do
return dflags
Just envfile -> do
content <- readFile envfile
- compilationProgressMsg dflags ("Loaded package environment from " ++ envfile)
+ compilationProgressMsg dflags (text "Loaded package environment from " <> text envfile)
let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
return dflags'
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -88,7 +88,7 @@ doBackpack [src_filename] = do
-- OK, so we have an LHsUnit PackageName, but we want an
-- LHsUnit HsComponentId. So let's rename it.
let pkgstate = unitState dflags
- let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgstate pkgname_bkp) pkgname_bkp
+ let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgname_bkp) pkgname_bkp
initBkpM src_filename bkp $
forM_ (zip [1..] bkp) $ \(i, lunit) -> do
let comp_name = unLoc (hsunitName (unLoc lunit))
@@ -96,7 +96,7 @@ doBackpack [src_filename] = do
innerBkpM $ do
let (cid, insts) = computeUnitId lunit
if null insts
- then if cid == Indefinite (UnitId (fsLit "main")) Nothing
+ then if cid == Indefinite (UnitId (fsLit "main"))
then compileExe lunit
else compileUnit cid []
else typecheckUnit cid insts
@@ -209,7 +209,7 @@ withBkpSession cid insts deps session_type do_this = do
withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession deps do_this = do
- withBkpSession (Indefinite (UnitId (fsLit "main")) Nothing) [] deps ExeSession do_this
+ withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this
getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId)
getSource cid = do
@@ -491,9 +491,10 @@ initBkpM file bkp m = do
-- | Print a compilation progress message, but with indentation according
-- to @level@ (for nested compilation).
-backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
+backpackProgressMsg :: Int -> DynFlags -> SDoc -> IO ()
backpackProgressMsg level dflags msg =
- compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
+ compilationProgressMsg dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr
+ <> msg
-- | Creates a 'Messager' for Backpack compilation; this is basically
-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
@@ -503,17 +504,18 @@ mkBackpackMsg = do
level <- getBkpLevel
return $ \hsc_env mod_index recomp mod_summary ->
let dflags = hsc_dflags hsc_env
+ state = unitState dflags
showMsg msg reason =
- backpackProgressMsg level dflags $
- showModuleIndex mod_index ++
- msg ++ showModMsg dflags (recompileRequired recomp) mod_summary
- ++ reason
+ backpackProgressMsg level dflags $ pprWithUnitState state $
+ showModuleIndex mod_index <>
+ msg <> showModMsg dflags (recompileRequired recomp) mod_summary
+ <> reason
in case recomp of
- MustCompile -> showMsg "Compiling " ""
+ MustCompile -> showMsg (text "Compiling ") empty
UpToDate
- | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
+ | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
| otherwise -> return ()
- RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+ RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")
-- | 'PprStyle' for Backpack messages; here we usually want the module to
-- be qualified (so we can tell how it was instantiated.) But we try not
@@ -531,27 +533,29 @@ msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
dflags <- getDynFlags
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
- $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
+ $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn
-- | Message when we instantiate a Backpack unit.
msgUnitId :: Unit -> BkpM ()
msgUnitId pk = do
dflags <- getDynFlags
level <- getBkpLevel
+ let state = unitState dflags
liftIO . backpackProgressMsg level dflags
- $ "Instantiating " ++ renderWithContext
- (initSDocContext dflags backpackStyle)
- (ppr pk)
+ $ pprWithUnitState state
+ $ text "Instantiating "
+ <> withPprStyle backpackStyle (ppr pk)
-- | Message when we include a Backpack unit.
msgInclude :: (Int,Int) -> Unit -> BkpM ()
msgInclude (i,n) uid = do
dflags <- getDynFlags
level <- getBkpLevel
+ let state = unitState dflags
liftIO . backpackProgressMsg level dflags
- $ showModuleIndex (i, n) ++ "Including " ++
- renderWithContext (initSDocContext dflags backpackStyle)
- (ppr uid)
+ $ pprWithUnitState state
+ $ showModuleIndex (i, n) <> text "Including "
+ <> withPprStyle backpackStyle (ppr uid)
-- ----------------------------------------------------------------------------
-- Conversion from PackageName to HsComponentId
@@ -560,12 +564,12 @@ type PackageNameMap a = Map PackageName a
-- For now, something really simple, since we're not actually going
-- to use this for anything
-unitDefines :: UnitState -> LHsUnit PackageName -> (PackageName, HsComponentId)
-unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
- = (pn, HsComponentId pn (mkIndefUnitId pkgstate (UnitId fs)))
+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
+ = (pn, HsComponentId pn (Indefinite (UnitId fs)))
-bkpPackageNameMap :: UnitState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId
-bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units)
+bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
+bkpPackageNameMap units = Map.fromList (map unitDefines units)
renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
=====================================
compiler/GHC/Driver/Finder.hs
=====================================
@@ -620,11 +620,12 @@ findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
-- Error messages
cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
-cannotFindModule flags mod res =
+cannotFindModule dflags mod res = pprWithUnitState unit_state $
cantFindErr (sLit cannotFindMsg)
(sLit "Ambiguous module name")
- flags mod res
+ dflags mod res
where
+ unit_state = unitState dflags
cannotFindMsg =
case res of
NotFound { fr_mods_hidden = hidden_mods
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -887,25 +887,25 @@ oneShotMsg hsc_env recomp =
case recomp of
UpToDate ->
compilationProgressMsg (hsc_dflags hsc_env) $
- "compilation IS NOT required"
+ text "compilation IS NOT required"
_ ->
return ()
batchMsg :: Messager
batchMsg hsc_env mod_index recomp mod_summary =
case recomp of
- MustCompile -> showMsg "Compiling " ""
+ MustCompile -> showMsg (text "Compiling ") empty
UpToDate
- | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
+ | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
| otherwise -> return ()
- RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+ RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")
where
dflags = hsc_dflags hsc_env
showMsg msg reason =
compilationProgressMsg dflags $
- (showModuleIndex mod_index ++
- msg ++ showModMsg dflags (recompileRequired recomp) mod_summary)
- ++ reason
+ (showModuleIndex mod_index <>
+ msg <> showModMsg dflags (recompileRequired recomp) mod_summary)
+ <> reason
--------------------------------------------------------------
-- Safe Haskell
@@ -1174,7 +1174,8 @@ hscCheckSafe' m l = do
pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
- , text "The package (" <> ppr (moduleUnit m)
+ , text "The package ("
+ <> (pprWithUnitState state $ ppr (moduleUnit m))
<> text ") the module resides in isn't trusted."
]
modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $
@@ -1225,8 +1226,10 @@ checkPkgTrust pkgs = do
= acc
| otherwise
= (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state)
- $ text "The package (" <> ppr pkg <> text ") is required" <>
- text " to be trusted but it isn't!"
+ $ pprWithUnitState state
+ $ text "The package ("
+ <> ppr pkg
+ <> text ") is required to be trusted but it isn't!"
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
@@ -1940,9 +1943,9 @@ dumpIfaceStats hsc_env = do
%* *
%********************************************************************* -}
-showModuleIndex :: (Int, Int) -> String
-showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
+showModuleIndex :: (Int, Int) -> SDoc
+showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "
where
- n_str = show n
- i_str = show i
- padded = replicate (length n_str - length i_str) ' ' ++ i_str
+ -- compute the length of x > 0 in base 10
+ len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)
+ pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -474,7 +474,7 @@ link' dflags batch_attempt_linking hpt
return Succeeded
else do
- compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
+ compilationProgressMsg dflags (text "Linking " <> text exe_file <> text " ...")
-- Don't showPass in Batch mode; doLink will do that for us.
let link = case ghcLink dflags of
=====================================
compiler/GHC/Driver/Ppr.hs
=====================================
@@ -30,6 +30,7 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Ppr ( Mode(..) )
+import {-# SOURCE #-} GHC.Unit.State
import System.IO ( Handle )
import Control.Monad.IO.Class
@@ -46,7 +47,11 @@ showPprUnsafe a = showPpr unsafeGlobalDynFlags a
-- | Allows caller to specify the PrintUnqualified to use
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
-showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags (mkUserStyle unqual AllTheWay)) doc
+showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags sty) doc'
+ where
+ sty = mkUserStyle unqual AllTheWay
+ unit_state = unitState dflags
+ doc' = pprWithUnitState unit_state doc
showSDocDump :: DynFlags -> SDoc -> String
showSDocDump dflags d = renderWithContext (initSDocContext dflags defaultDumpStyle) d
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -5080,6 +5080,7 @@ initSDocContext dflags style = SDC
, sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags
, sdocLinearTypes = xopt LangExt.LinearTypes dflags
, sdocPrintTypeAbbreviations = True
+ , sdocUnitIdForUser = ftext
, sdocDynFlags = dflags
}
=====================================
compiler/GHC/Driver/Types.hs
=====================================
@@ -2995,8 +2995,8 @@ instance Outputable ModSummary where
char '}'
]
-showModMsg :: DynFlags -> Bool -> ModSummary -> String
-showModMsg dflags recomp mod_summary = showSDoc dflags $
+showModMsg :: DynFlags -> Bool -> ModSummary -> SDoc
+showModMsg dflags recomp mod_summary =
if gopt Opt_HideSourcePaths dflags
then text mod_str
else hsep $
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -1121,6 +1121,7 @@ For some background on this choice see trac #15269.
showIface :: HscEnv -> FilePath -> IO ()
showIface hsc_env filename = do
let dflags = hsc_dflags hsc_env
+ unit_state = unitState dflags
printer = putLogMsg dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle
-- skip the hi way check; we don't want to worry about profiled vs.
@@ -1136,7 +1137,9 @@ showIface hsc_env filename = do
neverQualifyModules
neverQualifyPackages
putLogMsg dflags NoReason SevDump noSrcSpan
- $ withPprStyle (mkDumpStyle print_unqual) (pprModIface iface)
+ $ withPprStyle (mkDumpStyle print_unqual)
+ $ pprWithUnitState unit_state
+ $ pprModIface iface
-- Show a ModIface but don't display details; suitable for ModIfaces stored in
-- the EPT.
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -123,7 +123,9 @@ mkFullIface hsc_env partial_iface mb_cg_infos = do
addFingerprints hsc_env partial_iface{ mi_decls = decls }
-- Debug printing
- dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)
+ let unit_state = unitState (hsc_dflags hsc_env)
+ dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText
+ (pprWithUnitState unit_state $ pprModIface full_iface)
return full_iface
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -1257,7 +1257,7 @@ showModule mod_summary =
withSession $ \hsc_env -> do
interpreted <- moduleIsBootOrNotObjectLinkable mod_summary
let dflags = hsc_dflags hsc_env
- return (showModMsg dflags interpreted mod_summary)
+ return (showSDoc dflags $ showModMsg dflags interpreted mod_summary)
moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -2866,11 +2866,12 @@ rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn)
tcDump :: TcGblEnv -> TcRn ()
tcDump env
= do { dflags <- getDynFlags ;
+ unit_state <- unitState <$> getDynFlags ;
-- Dump short output if -ddump-types or -ddump-tc
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
(dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types)
- "" FormatText short_dump) ;
+ "" FormatText (pprWithUnitState unit_state short_dump)) ;
-- Dump bindings if -ddump-tc
dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump;
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -234,16 +234,15 @@ check_inst sig_inst = do
-- | Return this list of requirement interfaces that need to be merged
-- to form @mod_name@, or @[]@ if this is not a requirement.
requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]
-requirementMerges pkgstate mod_name =
- fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))
+requirementMerges unit_state mod_name =
+ fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext unit_state))
where
-- update IndefUnitId ppr info as they may have changed since the
-- time the IndefUnitId was created
fixupModule (Module iud name) = Module iud' name
where
- iud' = iud { instUnitInstanceOf = cid' }
+ iud' = iud { instUnitInstanceOf = cid }
cid = instUnitInstanceOf iud
- cid' = updateIndefUnitId pkgstate cid
-- | For a module @modname@ of type 'HscSource', determine the list
-- of extra "imports" of other requirements which should be considered part of
@@ -276,8 +275,8 @@ findExtraSigImports' hsc_env HsigFile modname =
$ moduleFreeHolesPrecise (text "findExtraSigImports")
(mkModule (VirtUnit iuid) mod_name)))
where
- pkgstate = unitState (hsc_dflags hsc_env)
- reqs = requirementMerges pkgstate modname
+ unit_state = unitState (hsc_dflags hsc_env)
+ reqs = requirementMerges unit_state modname
findExtraSigImports' _ _ _ = return emptyUniqDSet
@@ -535,17 +534,17 @@ mergeSignatures
}) $ do
tcg_env <- getGblEnv
- let outer_mod = tcg_mod tcg_env
- inner_mod = tcg_semantic_mod tcg_env
- mod_name = moduleName (tcg_mod tcg_env)
- pkgstate = unitState dflags
- home_unit = mkHomeUnitFromFlags dflags
+ let outer_mod = tcg_mod tcg_env
+ inner_mod = tcg_semantic_mod tcg_env
+ mod_name = moduleName (tcg_mod tcg_env)
+ unit_state = unitState dflags
+ home_unit = mkHomeUnitFromFlags dflags
-- STEP 1: Figure out all of the external signature interfaces
-- we are going to merge in.
- let reqs = requirementMerges pkgstate mod_name
+ let reqs = requirementMerges unit_state mod_name
- addErrCtxt (merge_msg mod_name reqs) $ do
+ addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do
-- STEP 2: Read in the RAW forms of all of these interfaces
ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) ->
@@ -572,7 +571,7 @@ mergeSignatures
let insts = instUnitInsts iuid
isFromSignaturePackage =
let inst_uid = instUnitInstanceOf iuid
- pkg = unsafeLookupUnitId pkgstate (indefUnit inst_uid)
+ pkg = unsafeLookupUnitId unit_state (indefUnit inst_uid)
in null (unitExposedModules pkg)
-- 3(a). Rename the exports according to how the dependency
-- was instantiated. The resulting export list will be accurate
@@ -900,18 +899,21 @@ tcRnInstantiateSignature hsc_env this_mod real_loc =
exportOccs :: [AvailInfo] -> [OccName]
exportOccs = concatMap (map occName . availNames)
-impl_msg :: Module -> InstantiatedModule -> SDoc
-impl_msg impl_mod (Module req_uid req_mod_name) =
- text "while checking that" <+> ppr impl_mod <+>
- text "implements signature" <+> ppr req_mod_name <+>
- text "in" <+> ppr req_uid
+impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc
+impl_msg unit_state impl_mod (Module req_uid req_mod_name)
+ = pprWithUnitState unit_state $
+ text "while checking that" <+> ppr impl_mod <+>
+ text "implements signature" <+> ppr req_mod_name <+>
+ text "in" <+> ppr req_uid
-- | Check if module implements a signature. (The signature is
-- always un-hashed, which is why its components are specified
-- explicitly.)
checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv
-checkImplements impl_mod req_mod@(Module uid mod_name) =
- addErrCtxt (impl_msg impl_mod req_mod) $ do
+checkImplements impl_mod req_mod@(Module uid mod_name) = do
+ dflags <- getDynFlags
+ let unit_state = unitState dflags
+ addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do
let insts = instUnitInsts uid
-- STEP 1: Load the implementing interface, and make a RdrEnv
@@ -931,7 +933,6 @@ checkImplements impl_mod req_mod@(Module uid mod_name) =
loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
(dep_orphs (mi_deps impl_iface))
- dflags <- getDynFlags
let avails = calculateAvails dflags
impl_iface False{- safe -} NotBoot ImportedBySystem
fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
@@ -969,9 +970,8 @@ checkImplements impl_mod req_mod@(Module uid mod_name) =
forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
case lookupGlobalRdrEnv impl_gr occ of
[] -> addErr $ quotes (ppr occ)
- <+> text "is exported by the hsig file, but not"
- <+> text "exported by the implementing module"
- <+> quotes (ppr impl_mod)
+ <+> text "is exported by the hsig file, but not exported by the implementing module"
+ <+> quotes (pprWithUnitState unit_state $ ppr impl_mod)
_ -> return ()
failIfErrsM
@@ -1002,15 +1002,12 @@ instantiateSignature = do
let outer_mod = tcg_mod tcg_env
inner_mod = tcg_semantic_mod tcg_env
home_unit = mkHomeUnitFromFlags dflags
- unit_state = unitState dflags
-- TODO: setup the local RdrEnv so the error messages look a little better.
-- But this information isn't stored anywhere. Should we RETYPECHECK
-- the local one just to get the information? Hmm...
MASSERT( isHomeModule home_unit outer_mod )
MASSERT( isHomeUnitInstantiating home_unit)
- -- we need to fetch the most recent ppr infos from the unit
- -- database because we might have modified it
- let uid = mkIndefUnitId unit_state (homeUnitInstanceOf home_unit)
+ let uid = Indefinite (homeUnitInstanceOf home_unit)
inner_mod `checkImplements`
Module
(mkInstantiatedUnit uid (homeUnitInstantiations home_unit))
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -80,6 +80,7 @@ import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Types.Basic ( TypeOrKind(..) )
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Unit.State
import Data.List ( sortBy, mapAccumL )
import Control.Monad( unless )
@@ -972,9 +973,10 @@ dupInstErr ispec dup_ispec
[ispec, dup_ispec]
addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
-addClsInstsErr herald ispecs
- = setSrcSpan (getSrcSpan (head sorted)) $
- addErr (hang herald 2 (pprInstances sorted))
+addClsInstsErr herald ispecs = do
+ unit_state <- unitState <$> getDynFlags
+ setSrcSpan (getSrcSpan (head sorted)) $
+ addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted))
where
sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs
-- The sortBy just arranges that instances are displayed in order
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -977,13 +977,19 @@ mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
mkLongErrAt loc msg extra
= do { dflags <- getDynFlags ;
printer <- getPrintUnqualified dflags ;
- return $ mkLongErrMsg dflags loc printer msg extra }
+ unit_state <- unitState <$> getDynFlags ;
+ let msg' = pprWithUnitState unit_state msg in
+ return $ mkLongErrMsg dflags loc printer msg' extra }
mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
mkErrDocAt loc errDoc
= do { dflags <- getDynFlags ;
printer <- getPrintUnqualified dflags ;
- return $ mkErrDoc dflags loc printer errDoc }
+ unit_state <- unitState <$> getDynFlags ;
+ let f = pprWithUnitState unit_state
+ errDoc' = mapErrDoc f errDoc
+ in
+ return $ mkErrDoc dflags loc printer errDoc' }
addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
=====================================
compiler/GHC/Unit.hs
=====================================
@@ -272,39 +272,58 @@ themselves. It is a reminiscence of previous terminology (when "instanceOf" was
TODO: We should probably have `instanceOf :: Maybe IndefUnitId` instead.
-Pretty-printing UnitId
-----------------------
+Note [Pretty-printing UnitId]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When we pretty-print a UnitId for the user, we try to map it back to its origin
+package name, version and component to print "package-version:component" instead
+of some hash. How to retrieve these information from a UnitId?
+
+Solution 0: ask for a UnitState to be passed each time we want to pretty-print a
+SDoc so that the Outputable instance for UnitId could retrieve the information
+from it. That what we used in the past: a DynFlags was passed and the UnitState
+was retrieved from it. This is wrong for several reasons:
+
+ 1. The UnitState is accessed when the message is printed, not when it is
+ generated. So we could imagine that the UnitState could have changed
+ in-between. Especially if we want to allow unit unloading.
+
+ 2. We want GHC to support several independent sessions at once, hence
+ several UnitState. This approach supposes there is a unique UnitState
+ (the one given at printing-time), moreover a UnitId doesn't indicate
+ which UnitState it comes from (think about statically defined UnitId for
+ wired-in units).
+
+Solution 1: an obvious approach would be to store the required information in
+the UnitId itself. However it doesn't work because some UnitId are defined
+statically for wired-in units and the same UnitId can map to different units in
+different contexts. This solution would make wired-in units harder to deal with.
+
+Solution 2: another approach would be to thread the UnitState to all places
+where a UnitId is pretty-printed and to retrieve the information from the
+UnitState only when needed. It would mean that UnitId couldn't have an
+Outputable instance as it would need an additional UnitState parameter to be
+printed. It means that many other types couldn't have an Outputable instance
+either: Unit, Module, Name, InstEnv, etc. Too many to make this solution
+feasible.
+
+Solution 3: the approach we use is a compromise between solutions 0 and 2: the
+appropriate UnitState has to be threaded close enough to the function generating
+the SDoc so that the latter can use `pprWithUnitState` to set the UnitState to
+fetch information from. However the UnitState doesn't have to be threaded
+explicitly all the way down to the point where the UnitId itself is printed:
+instead the Outputable instance of UnitId fetches the "sdocUnitIdForUser"
+field in the SDocContext to pretty-print.
+
+ 1. We can still have Outputable instances for common types (Module, Unit,
+ Name, etc.)
+
+ 2. End-users don't have to pass a UnitState (via a DynFlags) to print a SDoc.
+
+ 3. By default "sdocUnitIdForUser" prints the UnitId hash. In case of a bug
+ (i.e. GHC doesn't correctly call `pprWithUnitState` before pretty-printing a
+ UnitId), that's what will be shown to the user so it's no big deal.
-GHC mostly deals with UnitIds which are some opaque strings. We could display
-them when we pretty-print a module origin, a name, etc. But it wouldn't be
-very friendly to the user because of the hash they usually contain. E.g.
-
- foo-4.18.1:thelib-XYZsomeUglyHashABC
-
-Instead when we want to pretty-print a 'UnitId' we query the database to
-get the 'UnitInfo' and print something nicer to the user:
-
- foo-4.18.1:thelib
-
-We do the same for wired-in units.
-
-Currently (2020-04-06), we don't thread the database into every function that
-pretty-prints a Name/Module/Unit. Instead querying the database is delayed
-until the `SDoc` is transformed into a `Doc` using the database that is
-active at this point in time. This is an issue because we want to be able to
-unload units from the database and we also want to support several
-independent databases loaded at the same time (see #14335). The alternatives
-we have are:
-
- * threading the database into every function that pretty-prints a UnitId
- for the user (directly or indirectly).
-
- * storing enough info to correctly display a UnitId into the UnitId
- datatype itself. This is done in the IndefUnitId wrapper (see
- 'UnitPprInfo' datatype) but not for every 'UnitId'. Statically defined
- 'UnitId' for wired-in units would have empty UnitPprInfo so we need to
- find some places to update them if we want to display wired-in UnitId
- correctly. This leads to a solution similar to the first one above.
Note [VirtUnit to RealUnit improvement]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Unit/Home.hs
=====================================
@@ -105,7 +105,7 @@ homeUnitInstanceOfMaybe _ = Nothing
-- produce any code object that rely on the unit id of this virtual unit.
homeUnitAsUnit :: HomeUnit -> Unit
homeUnitAsUnit (DefiniteHomeUnit u _) = RealUnit (Definite u)
-homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit (Indefinite u Nothing) is
+homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit (Indefinite u) is
-- | Map over the unit identifier for instantiating units
homeUnitMap :: IsUnitId v => (u -> v) -> GenHomeUnit u -> GenHomeUnit v
=====================================
compiler/GHC/Unit/Info.hs
=====================================
@@ -68,7 +68,7 @@ mkUnitKeyInfo = mapGenericUnitInfo
mkPackageName' = PackageName . mkFastStringByteString
mkUnitKey' = UnitKey . mkFastStringByteString
mkModuleName' = mkModuleNameFS . mkFastStringByteString
- mkIndefUnitKey' cid = Indefinite (mkUnitKey' cid) Nothing
+ mkIndefUnitKey' cid = Indefinite (mkUnitKey' cid)
mkVirtUnitKey' i = case i of
DbInstUnitId cid insts -> mkVirtUnit (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts)
DbUnitId uid -> RealUnit (Definite (mkUnitKey' uid))
=====================================
compiler/GHC/Unit/Parser.hs
=====================================
@@ -36,7 +36,7 @@ parseUnitId = do
parseIndefUnitId :: ReadP IndefUnitId
parseIndefUnitId = do
uid <- parseUnitId
- return (Indefinite uid Nothing)
+ return (Indefinite uid)
parseHoleyModule :: ReadP Module
parseHoleyModule = parseModuleVar <++ parseModule
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -68,10 +68,9 @@ module GHC.Unit.State (
pprUnitIdForUser,
pprUnitInfoForUser,
pprModuleMap,
+ pprWithUnitState,
-- * Utils
- mkIndefUnitId,
- updateIndefUnitId,
unwireUnit
)
where
@@ -2128,15 +2127,6 @@ 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 -> UnitId -> IndefUnitId
-mkIndefUnitId state uid = Indefinite uid $! lookupUnitPprInfo state uid
-
--- | Update component ID details from the database
-updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId
-updateIndefUnitId pkgstate uid = mkIndefUnitId pkgstate (indefUnit uid)
-
-
-- -----------------------------------------------------------------------------
-- Displaying packages
@@ -2270,3 +2260,8 @@ instModuleToModule :: UnitState -> InstantiatedModule -> Module
instModuleToModule pkgstate (Module iuid mod_name) =
mkModule (instUnitToUnit pkgstate iuid) mod_name
+-- | Print unit-ids with UnitInfo found in the given UnitState
+pprWithUnitState :: UnitState -> SDoc -> SDoc
+pprWithUnitState state = updSDocContext (\ctx -> ctx
+ { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)
+ })
=====================================
compiler/GHC/Unit/State.hs-boot
=====================================
@@ -1,12 +1,11 @@
module GHC.Unit.State where
import {-# SOURCE #-} GHC.Utils.Outputable
-import {-# SOURCE #-} GHC.Unit.Types (IndefUnitId, UnitId)
+import {-# SOURCE #-} GHC.Unit.Types (UnitId)
data UnitState
data UnitDatabase unit
emptyUnitState :: UnitState
-mkIndefUnitId :: UnitState -> UnitId -> IndefUnitId
pprUnitIdForUser :: UnitState -> UnitId -> SDoc
-updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId
+pprWithUnitState :: UnitState -> SDoc -> SDoc
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -2,6 +2,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Unit & Module types
--
@@ -87,7 +89,6 @@ where
import GHC.Prelude
import GHC.Types.Unique
import GHC.Types.Unique.DSet
-import GHC.Unit.Ppr
import GHC.Unit.Module.Name
import GHC.Utils.Binary
import GHC.Utils.Outputable
@@ -104,9 +105,6 @@ import Data.Bifunctor
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
-import {-# SOURCE #-} GHC.Unit.State (pprUnitIdForUser)
-import {-# SOURCE #-} GHC.Driver.Session (unitState)
-
---------------------------------------------------------------------
-- MODULES
---------------------------------------------------------------------
@@ -186,12 +184,6 @@ instance IsUnitId u => IsUnitId (GenUnit u) where
unitFS (RealUnit (Definite x)) = unitFS x
unitFS HoleUnit = holeFS
-instance IsUnitId u => IsUnitId (Definite u) where
- unitFS (Definite x) = unitFS x
-
-instance IsUnitId u => IsUnitId (Indefinite u) where
- unitFS (Indefinite x _) = unitFS x
-
pprModule :: Module -> SDoc
pprModule mod@(Module p n) = getPprStyle doc
where
@@ -365,12 +357,6 @@ instance Binary Unit where
1 -> fmap VirtUnit (get bh)
_ -> pure HoleUnit
-instance Binary unit => Binary (Indefinite unit) where
- put_ bh (Indefinite fs _) = put_ bh fs
- get bh = do { fs <- get bh; return (Indefinite fs Nothing) }
-
-
-
-- | Retrieve the set of free module holes of a 'Unit'.
unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName
unitFreeModuleHoles (VirtUnit x) = instUnitHoles x
@@ -524,7 +510,8 @@ instance Uniquable UnitId where
getUnique = getUnique . unitIdFS
instance Outputable UnitId where
- ppr uid = sdocWithDynFlags $ \dflags -> pprUnitIdForUser (unitState dflags) uid
+ ppr (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- see Note [Pretty-printing UnitId]
+ -- in "GHC.Unit"
-- | A 'DefUnitId' is an 'UnitId' with the invariant that
-- it only refers to a definite library; i.e., one we have generated
@@ -543,44 +530,16 @@ stringToUnitId = UnitId . mkFastString
-- | A definite unit (i.e. without any free module hole)
newtype Definite unit = Definite { unDefinite :: unit }
- deriving (Eq, Ord, Functor)
-
-instance Outputable unit => Outputable (Definite unit) where
- ppr (Definite uid) = ppr uid
-
-instance Binary unit => Binary (Definite unit) where
- put_ bh (Definite uid) = put_ bh uid
- get bh = do uid <- get bh; return (Definite uid)
-
+ deriving (Functor)
+ deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)
-- | An 'IndefUnitId' is an 'UnitId' with the invariant that it only
-- refers to an indefinite library; i.e., one that can be instantiated.
type IndefUnitId = Indefinite UnitId
-data Indefinite unit = Indefinite
- { indefUnit :: !unit -- ^ Unit identifier
- , indefUnitPprInfo :: Maybe UnitPprInfo -- ^ Cache for some unit info retrieved from the DB
- }
+newtype Indefinite unit = Indefinite { indefUnit :: unit }
deriving (Functor)
-
-instance Eq unit => Eq (Indefinite unit) where
- a == b = indefUnit a == indefUnit b
-
-instance Ord unit => Ord (Indefinite unit) where
- compare a b = compare (indefUnit a) (indefUnit b)
-
-
-instance Uniquable unit => Uniquable (Indefinite unit) where
- getUnique (Indefinite n _) = getUnique n
-
-instance Outputable unit => Outputable (Indefinite unit) where
- ppr (Indefinite uid Nothing) = ppr uid
- ppr (Indefinite uid (Just pprinfo)) =
- getPprDebug $ \debug ->
- if debug
- then ppr uid
- else ppr pprinfo
-
+ deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)
---------------------------------------------------------------------
-- WIRED-IN UNITS
=====================================
compiler/GHC/Utils/Error.hs
=====================================
@@ -18,6 +18,7 @@ module GHC.Utils.Error (
-- * Messages
ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
+ mapErrDoc,
WarnMsg, MsgDoc,
Messages, ErrorMessages, WarningMessages,
unionMessages,
@@ -162,6 +163,9 @@ data ErrDoc = ErrDoc {
errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
errDoc = ErrDoc
+mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc
+mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c)
+
type WarnMsg = ErrMsg
data Severity
@@ -635,11 +639,12 @@ fatalErrorMsg dflags msg =
fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
-compilationProgressMsg :: DynFlags -> String -> IO ()
+compilationProgressMsg :: DynFlags -> SDoc -> IO ()
compilationProgressMsg dflags msg = do
- traceEventIO $ "GHC progress: " ++ msg
+ let str = showSDoc dflags msg
+ traceEventIO $ "GHC progress: " ++ str
ifVerbose dflags 1 $
- logOutput dflags $ withPprStyle defaultUserStyle (text msg)
+ logOutput dflags $ withPprStyle defaultUserStyle msg
showPass :: DynFlags -> String -> IO ()
showPass dflags what
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -357,6 +357,20 @@ data SDocContext = SDC
, sdocLinearTypes :: !Bool
, sdocImpredicativeTypes :: !Bool
, sdocPrintTypeAbbreviations :: !Bool
+ , sdocUnitIdForUser :: !(FastString -> SDoc)
+ -- ^ Used to map UnitIds to more friendly "package-version:component"
+ -- strings while pretty-printing.
+ --
+ -- Use `GHC.Unit.State.pprWithUnitState` to set it. Users should never
+ -- have to set it to pretty-print SDocs emitted by GHC, otherwise it's a
+ -- bug. It's an internal field used to thread the UnitState so that the
+ -- Outputable instance of UnitId can use it.
+ --
+ -- See Note [Pretty-printing UnitId] in "GHC.Unit" for more details.
+ --
+ -- Note that we use `FastString` instead of `UnitId` to avoid boring
+ -- module inter-dependency issues.
+
, sdocDynFlags :: DynFlags -- TODO: remove
}
@@ -404,6 +418,7 @@ defaultSDocContext = SDC
, sdocImpredicativeTypes = False
, sdocLinearTypes = False
, sdocPrintTypeAbbreviations = True
+ , sdocUnitIdForUser = ftext
, sdocDynFlags = error "defaultSDocContext: DynFlags not available"
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0b17fa185aec793861364afd9a05aa4219fbc019
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0b17fa185aec793861364afd9a05aa4219fbc019
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/20200826/1609c28f/attachment-0001.html>
More information about the ghc-commits
mailing list