Torsten Schmits pushed to branch wip/torsten.schmits/worker-debug at Glasgow Haskell Compiler / GHC Commits: 19695614 by Torsten Schmits at 2025-06-24T17:01:05+02:00 use OsPath for PkgDbPath and UnitDatabase - - - - - 4 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Unit/State.hs Changes: ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -91,6 +91,7 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set import GHC.Types.Error (mkUnknownDiagnostic) +import System.OsPath (unsafeEncodeUtf) -- | Entry point to compile a Backpack file. doBackpack :: [FilePath] -> Ghc () @@ -433,7 +434,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/DynFlags.hs ===================================== @@ -134,6 +134,7 @@ import System.IO.Error (catchIOError) import System.Environment (lookupEnv) import System.FilePath (normalise, ()) import System.Directory +import System.OsPath (OsPath) import GHC.Foreign (withCString, peekCString) import qualified Data.Set as Set @@ -948,7 +949,7 @@ setDynamicNow dflags0 = data PkgDbRef = GlobalPkgDb | UserPkgDb - | PkgDbPath FilePath + | PkgDbPath OsPath deriving Eq -- | Used to differentiate the scope an include needs to apply to. ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -278,6 +278,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Data.Word import System.FilePath +import System.OsPath (unsafeEncodeUtf) import Text.ParserCombinators.ReadP hiding (char) import Text.ParserCombinators.ReadP as R @@ -1962,7 +1963,7 @@ package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] package_flags_deps = [ ------- Packages ---------------------------------------------------- make_ord_flag defFlag "package-db" - (HasArg (addPkgDbRef . PkgDbPath)) + (HasArg (addPkgDbRef . PkgDbPath . 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) @@ -1972,7 +1973,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 . 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 -> @@ -3377,7 +3378,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 (unsafeEncodeUtf (envdir db))) -- relative package dbs are interpreted relative to the env file where envdir = takeDirectory envfile db = drop 11 str ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -109,6 +109,8 @@ import GHC.Utils.Exception import System.Directory import System.FilePath as FilePath +import System.OsPath (OsPath, decodeUtf, unsafeEncodeUtf) +import qualified System.OsPath as OsPath import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper ) @@ -405,7 +407,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 @@ -500,12 +502,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:" <+> text (fromMaybe "invalid path" (decodeUtf fp)) type UnitInfoMap = UniqMap UnitId UnitInfo @@ -720,9 +722,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 . unsafeEncodeUtf) (splitSearchPath xs) ++ system_conf_refs | otherwise - -> map PkgDbPath (splitSearchPath path) + -> map (PkgDbPath . unsafeEncodeUtf) (splitSearchPath path) -- Apply the package DB-related flags from the command line to get the -- final list of package DBs. @@ -758,7 +760,7 @@ resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do let pkgconf = dir unitConfigDBName cfg exist <- tryMaybeT $ doesDirectoryExist pkgconf if exist then return pkgconf else mzero -resolveUnitDatabase _ (PkgDbPath name) = return $ Just name +resolveUnitDatabase _ (PkgDbPath name) = return $ Just (fromMaybe undefined (decodeUtf name)) readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId) readUnitDatabase logger cfg conf_file = do @@ -790,7 +792,7 @@ readUnitDatabase logger cfg conf_file = do pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) proto_pkg_configs -- - return $ UnitDatabase conf_file' pkg_configs1 + return $ UnitDatabase (unsafeEncodeUtf conf_file') pkg_configs1 where readDirStyleUnitInfo conf_dir = do let filename = conf_dir "package.cache" @@ -1388,7 +1390,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" <+> text (fromMaybe "invalid path" (decodeUtf db_path)) forM_ (Set.toList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19695614f23007e171aaab6943f58400... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19695614f23007e171aaab6943f58400... You're receiving this email because of your account on gitlab.haskell.org.