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.