Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
fa3bd0a6 by Georgios Karachalias at 2025-11-29T18:36:05-05:00
Use OsPath in PkgDbRef and UnitDatabase, not FilePath
- - - - -
8 changed files:
- compiler/GHC/Data/OsPath.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC/Data/OsPath.hs
=====================================
@@ -11,6 +11,15 @@ module GHC.Data.OsPath
-- * Common utility functions
, ()
, (<.>)
+ , splitSearchPath
+ , isRelative
+ , dropTrailingPathSeparator
+ , takeDirectory
+ , isSuffixOf
+ , doesDirectoryExist
+ , doesFileExist
+ , getDirectoryContents
+ , createDirectoryIfMissing
)
where
@@ -20,6 +29,8 @@ import GHC.Utils.Misc (HasCallStack)
import GHC.Utils.Panic (panic)
import System.OsPath
+import System.OsString (isSuffixOf)
+import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing)
import System.Directory.Internal (os)
-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -441,7 +441,7 @@ addUnit u = do
Nothing -> panic "addUnit: called too early"
Just dbs ->
let newdb = UnitDatabase
- { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
+ { unitDatabasePath = unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -38,7 +38,7 @@ import GHC.Driver.LlvmConfigCache (LlvmConfigCache)
import GHC.Driver.Ppr
import GHC.Driver.Backend
-import GHC.Data.OsPath
+import GHC.Data.OsPath qualified as OsPath
import qualified GHC.Data.ShortText as ST
import GHC.Data.Stream ( liftIO )
import qualified GHC.Data.Stream as Stream
@@ -61,8 +61,6 @@ import GHC.Types.ForeignStubs
import GHC.Types.Unique.DSM
import GHC.Types.Unique.Supply ( UniqueTag(..) )
-import System.Directory
-import System.FilePath
import System.IO
import Data.Set (Set)
import qualified Data.Set as Set
@@ -321,10 +319,9 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
stub_h_file_exists <-
case mkStubPaths (initFinderOpts dflags) (moduleName mod) location of
Nothing -> pure False
- Just path -> do
- let stub_h = unsafeDecodeUtf path
- createDirectoryIfMissing True (takeDirectory stub_h)
- outputForeignStubs_help stub_h stub_h_output_w
+ Just stub_h -> do
+ OsPath.createDirectoryIfMissing True (OsPath.takeDirectory stub_h)
+ outputForeignStubs_help (OsPath.unsafeDecodeUtf stub_h) stub_h_output_w
("#include \n" ++ cplusplus_hdr) cplusplus_ftr
putDumpFileMaybe logger Opt_D_dump_foreign
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -101,6 +101,7 @@ import GHC.Core.Unfold
import GHC.Data.Bool
import GHC.Data.EnumSet (EnumSet)
import GHC.Data.Maybe
+import GHC.Data.OsPath ( OsPath )
import GHC.Builtin.Names ( mAIN_NAME )
import GHC.Driver.Backend
import GHC.Driver.Flags
@@ -953,7 +954,7 @@ setDynamicNow dflags0 =
data PkgDbRef
= GlobalPkgDb
| UserPkgDb
- | PkgDbPath FilePath
+ | PkgDbPath OsPath
deriving Eq
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -300,6 +300,8 @@ import qualified Data.Set as Set
import GHC.Types.Unique.Set
import Data.Word
import System.FilePath
+import qualified GHC.Data.OsPath as OsPath
+
import Text.ParserCombinators.ReadP hiding (char)
import Text.ParserCombinators.ReadP as R
@@ -2071,7 +2073,7 @@ package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]
package_flags_deps = [
------- Packages ----------------------------------------------------
make_ord_flag defFlag "package-db"
- (HasArg (addPkgDbRef . PkgDbPath))
+ (HasArg (addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf))
, make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb)
, make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb)
, make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb)
@@ -2081,7 +2083,7 @@ package_flags_deps = [
(NoArg (addPkgDbRef UserPkgDb))
-- backwards compat with GHC<=7.4 :
, make_dep_flag defFlag "package-conf"
- (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"
+ (HasArg $ addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf) "Use -package-db instead"
, make_dep_flag defFlag "no-user-package-conf"
(NoArg removeUserPkgDb) "Use -no-user-package-db instead"
, make_ord_flag defGhcFlag "package-name" (HasArg $ \name ->
@@ -3307,7 +3309,7 @@ parseEnvFile :: FilePath -> String -> DynP ()
parseEnvFile envfile = mapM_ parseEntry . lines
where
parseEntry str = case words str of
- ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir db))
+ ("package-db": _) -> addPkgDbRef (PkgDbPath (OsPath.unsafeEncodeUtf (envdir db)))
-- relative package dbs are interpreted relative to the env file
where envdir = takeDirectory envfile
db = drop 11 str
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -63,7 +63,6 @@ import GHC.Types.SourceFile
import GHC.Fingerprint
import Data.IORef
-import System.Directory.OsPath
import Control.Applicative ((<|>))
import Control.Monad
import Data.Time
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -101,6 +101,8 @@ import GHC.Data.Maybe
import System.Environment ( getEnv )
import GHC.Data.FastString
+import GHC.Data.OsPath ( OsPath )
+import qualified GHC.Data.OsPath as OsPath
import qualified GHC.Data.ShortText as ST
import GHC.Utils.Logger
import GHC.Utils.Error
@@ -111,7 +113,7 @@ import System.FilePath as FilePath
import Control.Monad
import Data.Graph (stronglyConnComp, SCC(..))
import Data.Char ( toUpper )
-import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn )
+import Data.List ( intersperse, partition, sortBy, sortOn )
import Data.Set (Set)
import Data.Monoid (First(..))
import qualified Data.Semigroup as Semigroup
@@ -407,7 +409,7 @@ initUnitConfig dflags cached_dbs home_units =
where
offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag
- offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset p))
+ offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath. p))
offsetPackageDb _ p = p
@@ -502,12 +504,12 @@ emptyUnitState = UnitState {
-- | Unit database
data UnitDatabase unit = UnitDatabase
- { unitDatabasePath :: FilePath
+ { unitDatabasePath :: OsPath
, unitDatabaseUnits :: [GenUnitInfo unit]
}
instance Outputable u => Outputable (UnitDatabase u) where
- ppr (UnitDatabase fp _u) = text "DB:" <+> text fp
+ ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp
type UnitInfoMap = UniqMap UnitId UnitInfo
@@ -722,9 +724,9 @@ getUnitDbRefs cfg = do
Left _ -> system_conf_refs
Right path
| Just (xs, x) <- snocView path, isSearchPathSeparator x
- -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs
+ -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs
| otherwise
- -> map PkgDbPath (splitSearchPath path)
+ -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path))
-- Apply the package DB-related flags from the command line to get the
-- final list of package DBs.
@@ -753,24 +755,24 @@ getUnitDbRefs cfg = do
-- NB: This logic is reimplemented in Cabal, so if you change it,
-- make sure you update Cabal. (Or, better yet, dump it in the
-- compiler info so Cabal can use the info.)
-resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath)
-resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg)
+resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath)
+resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg
resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg)
let pkgconf = dir unitConfigDBName cfg
exist <- tryMaybeT $ doesDirectoryExist pkgconf
- if exist then return pkgconf else mzero
+ if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
-readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
+readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId)
readUnitDatabase logger cfg conf_file = do
- isdir <- doesDirectoryExist conf_file
+ isdir <- OsPath.doesDirectoryExist conf_file
proto_pkg_configs <-
if isdir
then readDirStyleUnitInfo conf_file
else do
- isfile <- doesFileExist conf_file
+ isfile <- OsPath.doesFileExist conf_file
if isfile
then do
mpkgs <- tryReadOldFileStyleUnitInfo
@@ -778,48 +780,49 @@ readUnitDatabase logger cfg conf_file = do
Just pkgs -> return pkgs
Nothing -> throwGhcExceptionIO $ InstallationError $
"ghc no longer supports single-file style package " ++
- "databases (" ++ conf_file ++
+ "databases (" ++ show conf_file ++
") use 'ghc-pkg init' to create the database with " ++
"the correct format."
else throwGhcExceptionIO $ InstallationError $
- "can't find a package database at " ++ conf_file
+ "can't find a package database at " ++ show conf_file
let
-- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
- conf_file' = dropTrailingPathSeparator conf_file
- top_dir = unitConfigGHCDir cfg
- pkgroot = takeDirectory conf_file'
+ conf_file' = OsPath.dropTrailingPathSeparator conf_file
+ top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg)
+ pkgroot = OsPath.takeDirectory conf_file'
pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
proto_pkg_configs
--
return $ UnitDatabase conf_file' pkg_configs1
where
+ readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
readDirStyleUnitInfo conf_dir = do
- let filename = conf_dir "package.cache"
- cache_exists <- doesFileExist filename
+ let filename = conf_dir OsPath. (OsPath.unsafeEncodeUtf "package.cache")
+ cache_exists <- OsPath.doesFileExist filename
if cache_exists
then do
- debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename
- readPackageDbForGhc filename
+ debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename
+ readPackageDbForGhc (OsPath.unsafeDecodeUtf filename)
else do
-- If there is no package.cache file, we check if the database is not
-- empty by inspecting if the directory contains any .conf file. If it
-- does, something is wrong and we fail. Otherwise we assume that the
-- database is empty.
debugTraceMsg logger 2 $ text "There is no package.cache in"
- <+> text conf_dir
+ <+> ppr conf_dir
<> text ", checking if the database is empty"
- db_empty <- all (not . isSuffixOf ".conf")
- <$> getDirectoryContents conf_dir
+ db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf"))
+ <$> OsPath.getDirectoryContents conf_dir
if db_empty
then do
debugTraceMsg logger 3 $ text "There are no .conf files in"
- <+> text conf_dir <> text ", treating"
+ <+> ppr conf_dir <> text ", treating"
<+> text "package database as empty"
return []
else
throwGhcExceptionIO $ InstallationError $
- "there is no package.cache in " ++ conf_dir ++
+ "there is no package.cache in " ++ show conf_dir ++
" even though package database is not empty"
@@ -832,13 +835,13 @@ readUnitDatabase logger cfg conf_file = do
-- assumes it's a file and tries to overwrite with 'writeFile'.
-- ghc-pkg also cooperates with this workaround.
tryReadOldFileStyleUnitInfo = do
- content <- readFile conf_file `catchIO` \_ -> return ""
+ content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return ""
if take 2 content == "[]"
then do
- let conf_dir = conf_file <.> "d"
- direxists <- doesDirectoryExist conf_dir
+ let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d"
+ direxists <- OsPath.doesDirectoryExist conf_dir
if direxists
- then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
+ then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir)
liftM Just (readDirStyleUnitInfo conf_dir)
else return (Just []) -- ghc-pkg will create it when it's updated
else return Nothing
@@ -848,11 +851,11 @@ distrustAllUnits pkgs = map distrust pkgs
where
distrust pkg = pkg{ unitIsTrusted = False }
-mungeUnitInfo :: FilePath -> FilePath
+mungeUnitInfo :: OsPath -> OsPath
-> UnitInfo -> UnitInfo
mungeUnitInfo top_dir pkgroot =
mungeDynLibFields
- . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot)
+ . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot))
mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields pkg =
@@ -1373,7 +1376,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..]
where
merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
debugTraceMsg logger 2 $
- text "loading package database" <+> text db_path
+ text "loading package database" <+> ppr db_path
forM_ (Set.toList override_set) $ \pkg ->
debugTraceMsg logger 2 $
text "package" <+> ppr pkg <+>
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -149,6 +149,7 @@ import Data.String
import Data.Word
import System.IO ( Handle )
import System.FilePath
+import System.OsPath (OsPath, decodeUtf)
import Text.Printf
import Numeric (showFFloat)
import Numeric.Natural (Natural)
@@ -1101,6 +1102,8 @@ instance Outputable Extension where
instance Outputable ModuleName where
ppr = pprModuleName
+instance Outputable OsPath where
+ ppr p = text $ either show id (decodeUtf p)
pprModuleName :: IsLine doc => ModuleName -> doc
pprModuleName (ModuleName nm) =
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa3bd0a67eea13701d1b50053636f964...
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa3bd0a67eea13701d1b50053636f964...
You're receiving this email because of your account on gitlab.haskell.org.
