[Git][ghc/ghc][wip/jeltsch/system-io-uncovering] Tighten the dependencies of `GHC.Internal.TH.Monad`
by Wolfgang Jeltsch (＠jeltsch) 24 Feb '26
by Wolfgang Jeltsch (＠jeltsch) 24 Feb '26
24 Feb '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/system-io-uncovering at Glasgow Haskell Compiler / GHC
Commits:
f2072ae1 by Wolfgang Jeltsch at 2026-02-24T20:56:23+02:00
Tighten the dependencies of `GHC.Internal.TH.Monad`
- - - - -
1 changed file:
- libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
Changes:
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
=====================================
@@ -32,7 +32,6 @@ import Control.Monad.Fix (MonadFix (..))
import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)
import Control.Exception.Base (FixIOException (..))
import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
-import System.IO ( hPutStrLn, stderr )
import qualified Data.Kind as Kind (Type)
import GHC.IO.Unsafe ( unsafeDupableInterleaveIO )
import GHC.Types (TYPE, RuntimeRep(..))
@@ -41,7 +40,6 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.Traversable
import GHC.Internal.IORef
-import GHC.Internal.System.IO
import GHC.Internal.Data.Foldable
import GHC.Internal.Data.Typeable
import GHC.Internal.Control.Monad.IO.Class
@@ -49,6 +47,10 @@ import GHC.Internal.Control.Monad.Fail
import GHC.Internal.Control.Monad.Fix
import GHC.Internal.Control.Exception
import GHC.Internal.Num
+import GHC.Internal.IO (FilePath)
+import GHC.Internal.IO.Handle.Text (hPutStr, hPutStrLn)
+import GHC.Internal.IO.IOMode (IOMode (WriteMode))
+import GHC.Internal.IO.StdHandles (stderr, withFile)
import GHC.Internal.IO.Unsafe
import GHC.Internal.MVar
import GHC.Internal.IO.Exception
@@ -875,6 +877,15 @@ addForeignSource lang src = do
path <- addTempFile suffix
runIO $ writeFile path src
addForeignFilePath lang path
+ where
+
+ {-
+ This is a copy of the implementation of 'System.IO.writeFile', which we
+ use to avoid forcing 'System.IO.writeFile' being implemented in
+ @ghc-internal@.
+ -}
+ writeFile :: FilePath -> String -> IO ()
+ writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt)
-- | Same as 'addForeignSource', but expects to receive a path pointing to the
-- foreign file instead of a 'String' of its contents. Consider using this in
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2072ae1ce05fd04cf710b11fa09c9e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2072ae1ce05fd04cf710b11fa09c9e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26930] ghc-internal: float Generics to top of module graph
by Teo Camarasu (＠teo) 24 Feb '26
by Teo Camarasu (＠teo) 24 Feb '26
24 Feb '26
Teo Camarasu pushed to branch wip/T26930 at Glasgow Haskell Compiler / GHC
Commits:
0db9d3e5 by Teo Camarasu at 2026-02-24T18:34:45+00:00
ghc-internal: float Generics to top of module graph
GHC.Internal.Generics currently exists in the middle of the ghc-internal module graph.
It defines the Generics typeclass. Stuff below it gets an instance in GHC.Internal.Generics whereas stuff above it gets instances in their own modules.
This splits the module graph in two and adds a lot of transitive dependencies to stuff above it.
It also leads to a hs-boot loop via ByteOrder
Resolves #26930
- - - - -
21 changed files:
- libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs
- − libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs-boot
- libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Monoid.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Semigroup/Internal.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs
- libraries/ghc-internal/src/GHC/Internal/Generics.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/Read.hs
- libraries/ghc-internal/src/GHC/Internal/Unicode/Bits.hs
- testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout
- testsuite/tests/ghci/scripts/T10963.stderr
- testsuite/tests/ghci/scripts/ghci064.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0db9d3e527d9b21ca791d7116442dc9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0db9d3e527d9b21ca791d7116442dc9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Teo Camarasu pushed to branch wip/T26925 at Glasgow Haskell Compiler / GHC
Commits:
48a97759 by Teo Camarasu at 2026-02-24T18:32:50+00:00
WIP
- - - - -
3 changed files:
- testsuite/tests/count-deps/Makefile
- testsuite/tests/count-deps/all.T
- utils/count-deps/Main.hs
Changes:
=====================================
testsuite/tests/count-deps/Makefile
=====================================
@@ -23,3 +23,8 @@ count-deps-parser:
count-deps-ast:
$(COUNT_DEPS) $(LIBDIR) "ghc" "Language.Haskell.Syntax" | tee out
cat out | tail -n +2 | wc -l > SIZE
+
+.PHONY: count-deps-critical-path-ghc-internal
+count-deps-critical-path-ghc-internal:
+ $(COUNT_DEPS) $(LIBDIR) "ghc-internal" | tee out
+ cat out | tail -n +2 | wc -l > SIZE
=====================================
testsuite/tests/count-deps/all.T
=====================================
@@ -1,2 +1,3 @@
test('CountDepsAst', [stat_from_file('deps', 100, 'SIZE'), req_hadrian_deps(["test:count-deps"])], makefile_test, ['count-deps-ast'])
test('CountDepsParser', [stat_from_file('deps', 100, 'SIZE'), req_hadrian_deps(["test:count-deps"])], makefile_test, ['count-deps-parser'])
+test('CountDepsGhcInternalCriticalPath', [stat_from_file('deps', 100, 'SIZE'), req_hadrian_deps(["test:count-deps"])], makefile_test, ['count-deps-critical-path-ghc-internal'])
=====================================
utils/count-deps/Main.hs
=====================================
@@ -14,9 +14,14 @@ import System.Environment
import GHC.Unit.Module.Deps
import GHC.Unit.State
import GHC.Unit.Info
+import GHC.Unit.Types
import GHC.Data.FastString
import Data.Map.Strict qualified as Map
+import Data.Map.Lazy qualified as Lazy.Map
import Data.Set qualified as Set
+import Data.Maybe
+import Data.List (maximumBy)
+import Data.Ord (comparing)
-- Example invocation:
-- inplace/bin/count-deps `inplace/bin/ghc-stage2 --print-libdir` ghc "GHC.Parser"
@@ -24,8 +29,13 @@ main :: IO ()
main = do
args <- getArgs
case args of
- [libdir, packageName, modName, "--dot"] -> printDeps libdir packageName modName True
- [libdir, packageName, modName] -> printDeps libdir packageName modName False
+ [libdir, packageName, "--dot"] -> printDeps libdir packageName Nothing True
+ [libdir, packageName, "--crit-path"] -> do
+ modgraph <- calcDeps Nothing packageName libdir
+ let modgraph' = Map.map (map gwib_mod . filter ((/=) IsBoot . gwib_isBoot)) modgraph
+ mapM_ putStrLn $ criticalPath modgraph'
+ [libdir, packageName, modName, "--dot"] -> printDeps libdir packageName (Just modName) True
+ [libdir, packageName, modName] -> printDeps libdir packageName (Just modName) False
_ -> fail "usage: count-deps libdir package module [--dot]"
dotSpec :: String -> Map.Map String [String] -> String
@@ -35,23 +45,23 @@ dotSpec name g =
where
f acc k ns = acc ++ concat [" " ++ show k ++ " -> " ++ show n ++ ";\n" | n <- ns]
-printDeps :: String -> String -> String -> Bool -> IO ()
+printDeps :: String -> String -> Maybe String -> Bool -> IO ()
printDeps libdir packageName modName dot = do
modGraph <-
- Map.map (map moduleNameString) .
- Map.mapKeys moduleNameString <$> calcDeps (Just modName) packageName libdir
+ Map.map (map (moduleNameString . gwib_mod)) .
+ Map.mapKeys (moduleNameString) <$> calcDeps modName packageName libdir
if not dot then
do
let modules = Map.keys modGraph
- putStrLn $ "Found " ++ modName ++ " module dependencies"
+ putStrLn $ "Found " ++ fromMaybe "" modName ++ " module dependencies"
forM_ modules putStrLn
else
-- * Copy the digraph output to a file ('deps.dot' say)
-- * To render it, use a command along the lines of
-- 'tred deps.dot > deps-tred.dot && dot -Tpdf -o deps.pdf deps-tred.dot'
- putStr $ dotSpec modName modGraph
+ putStr $ dotSpec (fromMaybe "" modName) modGraph
-calcDeps :: Maybe String -> String -> FilePath -> IO (Map.Map ModuleName [ModuleName])
+calcDeps :: Maybe String -> String -> FilePath -> IO (Map.Map ModuleName [ModuleNameWithIsBoot])
calcDeps mmodName packageName libdir =
defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
runGhc (Just libdir) $ do
@@ -75,7 +85,7 @@ calcDeps mmodName packageName libdir =
-- Source imports are only guaranteed to show up in the 'mi_deps'
-- of modules that import them directly and don’t propagate
-- transitively so we loop.
- loop :: UnitId -> HscEnv -> Map.Map ModuleName [ModuleName] -> [ModuleName] -> Ghc (Map.Map ModuleName [ModuleName])
+ loop :: UnitId -> HscEnv -> Map.Map ModuleName [ModuleNameWithIsBoot] -> [ModuleName] -> Ghc (Map.Map ModuleName [ModuleNameWithIsBoot])
loop unitId env modules (m : ms) =
if m `Map.member` modules
then loop unitId env modules ms
@@ -83,11 +93,36 @@ calcDeps mmodName packageName libdir =
mi <- liftIO $ hscGetModuleInterface env (mkModule unitId m)
let deps = modDeps mi
modules <- return $ Map.insert m [] modules
- loop unitId env (Map.insert m deps modules) $ ms ++ filter (not . (`Map.member` modules)) deps
+ loop unitId env (Map.insert m deps modules) $ ms ++ filter (not . (`Map.member` modules)) (map gwib_mod deps)
loop _ _ modules [] = return modules
mkModule :: UnitId -> ModuleName -> Module
mkModule unitId = Module (RealUnit $ Definite unitId)
- modDeps :: ModIface -> [ModuleName]
- modDeps mi = map (gwib_mod . (\(_, _, mn) -> mn)) $ Set.toList $ dep_direct_mods (mi_deps mi)
+ modDeps :: ModIface -> [ModuleNameWithIsBoot]
+ modDeps mi = map (\(_, _, mn) -> mn) $ Set.toList $ dep_direct_mods (mi_deps mi)
+
+criticalPath :: Map.Map ModuleName [ModuleName] -> [String]
+criticalPath modules = crit top
+ where
+ -- Calculate the rank of each module
+ -- The rank of a vertex v is the maximum rank of its children + 1
+ -- We crucially use laziness to give us a nice memoized construction.
+ rank :: Map.Map ModuleName Int
+ rank = Lazy.Map.fromList
+ [ (k, 1 + safeMax (mapMaybe (\d -> Map.lookup d rank) deps))
+ | (k, deps) <- Map.toList modules
+ ]
+ top = fst . maximumBy (comparing snd) $ Lazy.Map.toList rank
+ -- The critical path starts with the module of highest rank
+ -- and then we walk down the tree taking the module of maximum rank at each step.
+ crit x = case deps of
+ [] -> []
+ _ ->
+ let m = fst (maximumBy (comparing snd) depsRank)
+ in moduleNameString m:crit m
+ where
+ depsRank = map (\n -> (n, fromMaybe 0 (Map.lookup n rank))) deps
+ deps = fromMaybe [] $ Map.lookup x modules
+ safeMax [] = 0
+ safeMax xs = maximum xs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/48a9775994b7d9f30032930395617e5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/48a9775994b7d9f30032930395617e5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Teo Camarasu pushed to branch wip/T26925 at Glasgow Haskell Compiler / GHC
Commits:
15cd0aaa by Teo Camarasu at 2026-02-24T18:31:59+00:00
WIP
- - - - -
3 changed files:
- testsuite/tests/count-deps/Makefile
- testsuite/tests/count-deps/all.T
- utils/count-deps/Main.hs
Changes:
=====================================
testsuite/tests/count-deps/Makefile
=====================================
@@ -23,3 +23,8 @@ count-deps-parser:
count-deps-ast:
$(COUNT_DEPS) $(LIBDIR) "ghc" "Language.Haskell.Syntax" | tee out
cat out | tail -n +2 | wc -l > SIZE
+
+.PHONY: count-deps-critical-path-ghc-internal
+count-deps-critical-path-ghc-internal:
+ $(COUNT_DEPS) $(LIBDIR) "ghc-internal" | tee out
+ cat out | tail -n +2 | wc -l > SIZE
=====================================
testsuite/tests/count-deps/all.T
=====================================
@@ -1,2 +1,3 @@
test('CountDepsAst', [stat_from_file('deps', 100, 'SIZE'), req_hadrian_deps(["test:count-deps"])], makefile_test, ['count-deps-ast'])
test('CountDepsParser', [stat_from_file('deps', 100, 'SIZE'), req_hadrian_deps(["test:count-deps"])], makefile_test, ['count-deps-parser'])
+test('CountDepsGhcInternalCriticalPath', [stat_from_file('deps', 100, 'SIZE'), req_hadrian_deps(["test:count-deps"])], makefile_test, ['count-deps-critical-path-ghc-internal'])
=====================================
utils/count-deps/Main.hs
=====================================
@@ -14,9 +14,14 @@ import System.Environment
import GHC.Unit.Module.Deps
import GHC.Unit.State
import GHC.Unit.Info
+import GHC.Unit.Types
import GHC.Data.FastString
import Data.Map.Strict qualified as Map
+import Data.Map.Lazy qualified as Lazy.Map
import Data.Set qualified as Set
+import Data.Maybe
+import Data.List (maximumBy)
+import Data.Ord (comparing)
-- Example invocation:
-- inplace/bin/count-deps `inplace/bin/ghc-stage2 --print-libdir` ghc "GHC.Parser"
@@ -24,8 +29,13 @@ main :: IO ()
main = do
args <- getArgs
case args of
- [libdir, packageName, modName, "--dot"] -> printDeps libdir packageName modName True
- [libdir, packageName, modName] -> printDeps libdir packageName modName False
+ [libdir, packageName, "--dot"] -> printDep libdir packageName Nothing True
+ [libdir, packageName, "--crit-path"] -> do
+ modgraph <- calcDeps Nothing packageName libdir
+ let modgraph' = Map.map (map gwib_mod . filter ((/=) IsBoot . gwib_isBoot)) modgraph
+ mapM_ putStrLn $ criticalPath modgraph'
+ [libdir, packageName, modName, "--dot"] -> printDeps libdir packageName (Just modName) True
+ [libdir, packageName, modName] -> printDeps libdir packageName (Just modName) False
_ -> fail "usage: count-deps libdir package module [--dot]"
dotSpec :: String -> Map.Map String [String] -> String
@@ -35,23 +45,23 @@ dotSpec name g =
where
f acc k ns = acc ++ concat [" " ++ show k ++ " -> " ++ show n ++ ";\n" | n <- ns]
-printDeps :: String -> String -> String -> Bool -> IO ()
+printDeps :: String -> String -> Maybe String -> Bool -> IO ()
printDeps libdir packageName modName dot = do
modGraph <-
- Map.map (map moduleNameString) .
- Map.mapKeys moduleNameString <$> calcDeps (Just modName) packageName libdir
+ Map.map (map (moduleNameString . gwib_mod)) .
+ Map.mapKeys (moduleNameString) <$> calcDeps modName packageName libdir
if not dot then
do
let modules = Map.keys modGraph
- putStrLn $ "Found " ++ modName ++ " module dependencies"
+ putStrLn $ "Found " ++ fromMaybe "" modName ++ " module dependencies"
forM_ modules putStrLn
else
-- * Copy the digraph output to a file ('deps.dot' say)
-- * To render it, use a command along the lines of
-- 'tred deps.dot > deps-tred.dot && dot -Tpdf -o deps.pdf deps-tred.dot'
- putStr $ dotSpec modName modGraph
+ putStr $ dotSpec (fromMaybe "" modName) modGraph
-calcDeps :: Maybe String -> String -> FilePath -> IO (Map.Map ModuleName [ModuleName])
+calcDeps :: Maybe String -> String -> FilePath -> IO (Map.Map ModuleName [ModuleNameWithIsBoot])
calcDeps mmodName packageName libdir =
defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
runGhc (Just libdir) $ do
@@ -75,7 +85,7 @@ calcDeps mmodName packageName libdir =
-- Source imports are only guaranteed to show up in the 'mi_deps'
-- of modules that import them directly and don’t propagate
-- transitively so we loop.
- loop :: UnitId -> HscEnv -> Map.Map ModuleName [ModuleName] -> [ModuleName] -> Ghc (Map.Map ModuleName [ModuleName])
+ loop :: UnitId -> HscEnv -> Map.Map ModuleName [ModuleNameWithIsBoot] -> [ModuleName] -> Ghc (Map.Map ModuleName [ModuleNameWithIsBoot])
loop unitId env modules (m : ms) =
if m `Map.member` modules
then loop unitId env modules ms
@@ -83,11 +93,36 @@ calcDeps mmodName packageName libdir =
mi <- liftIO $ hscGetModuleInterface env (mkModule unitId m)
let deps = modDeps mi
modules <- return $ Map.insert m [] modules
- loop unitId env (Map.insert m deps modules) $ ms ++ filter (not . (`Map.member` modules)) deps
+ loop unitId env (Map.insert m deps modules) $ ms ++ filter (not . (`Map.member` modules)) (map gwib_mod deps)
loop _ _ modules [] = return modules
mkModule :: UnitId -> ModuleName -> Module
mkModule unitId = Module (RealUnit $ Definite unitId)
- modDeps :: ModIface -> [ModuleName]
- modDeps mi = map (gwib_mod . (\(_, _, mn) -> mn)) $ Set.toList $ dep_direct_mods (mi_deps mi)
+ modDeps :: ModIface -> [ModuleNameWithIsBoot]
+ modDeps mi = map (\(_, _, mn) -> mn) $ Set.toList $ dep_direct_mods (mi_deps mi)
+
+criticalPath :: Map.Map ModuleName [ModuleName] -> [String]
+criticalPath modules = crit top
+ where
+ -- Calculate the rank of each module
+ -- The rank of a vertex v is the maximum rank of its children + 1
+ -- We crucially use laziness to give us a nice memoized construction.
+ rank :: Map.Map ModuleName Int
+ rank = Lazy.Map.fromList
+ [ (k, 1 + safeMax (mapMaybe (\d -> Map.lookup d rank) deps))
+ | (k, deps) <- Map.toList modules
+ ]
+ top = fst . maximumBy (comparing snd) $ Lazy.Map.toList rank
+ -- The critical path starts with the module of highest rank
+ -- and then we walk down the tree taking the module of maximum rank at each step.
+ crit x = case deps of
+ [] -> []
+ _ ->
+ let m = fst (maximumBy (comparing snd) depsRank)
+ in moduleNameString m:crit m
+ where
+ depsRank = map (\n -> (n, fromMaybe 0 (Map.lookup n rank))) deps
+ deps = fromMaybe [] $ Map.lookup x modules
+ safeMax [] = 0
+ safeMax xs = maximum xs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15cd0aaa3464a49aa43183abf505335…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15cd0aaa3464a49aa43183abf505335…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghc-pkg-ospath] Migrate ghc-pkg to use OsPath only
by Hannes Siebenhandl (＠fendor) 24 Feb '26
by Hannes Siebenhandl (＠fendor) 24 Feb '26
24 Feb '26
Hannes Siebenhandl pushed to branch wip/fendor/ghc-pkg-ospath at Glasgow Haskell Compiler / GHC
Commits:
bb859c26 by Fendor at 2026-02-24T19:23:19+01:00
Migrate ghc-pkg to use OsPath only
- - - - -
5 changed files:
- compiler/GHC/Unit/State.hs
- libraries/ghc-boot/GHC/Unit/Database.hs
- libraries/ghc-boot/ghc-boot.cabal.in
- utils/ghc-pkg/Main.hs
- utils/ghc-pkg/ghc-pkg.cabal.in
Changes:
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -802,7 +802,7 @@ readUnitDatabase logger cfg conf_file = do
if cache_exists
then do
debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename
- readPackageDbForGhc (OsPath.unsafeDecodeUtf filename)
+ readPackageDbForGhc 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
=====================================
libraries/ghc-boot/GHC/Unit/Database.hs
=====================================
@@ -68,6 +68,7 @@ module GHC.Unit.Database
-- * Misc
, mkMungePathUrl
, mungeUnitInfoPaths
+ , writeFileAtomic
)
where
@@ -86,10 +87,10 @@ import Data.Binary.Get as Bin
import Data.List (intersperse)
import Control.Exception as Exception
import Control.Monad (when)
-import System.FilePath as FilePath
+import qualified System.FilePath as FilePath
#if !defined(mingw32_HOST_OS)
import Data.Bits ((.|.))
-import System.Posix.Files
+import System.Posix.Files.PosixString
import System.Posix.Types (FileMode)
#endif
import System.IO
@@ -97,7 +98,12 @@ import System.IO.Error
import GHC.IO.Exception (IOErrorType(InappropriateType))
import qualified GHC.Data.ShortText as ST
import GHC.IO.Handle.Lock
-import System.Directory
+import System.OsPath (OsPath)
+import System.OsString.Internal.Types (getOsString)
+import qualified System.OsPath as OsPath
+import qualified System.Directory.OsPath as OsPath
+import qualified System.Directory.Internal as OsPath.Internal
+import qualified System.File.OsPath as FileIO
-- | @ghc-boot@'s UnitInfo, serialized to the database.
type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule
@@ -314,13 +320,13 @@ data DbInstUnitId
newtype PackageDbLock = PackageDbLock Handle
-- | Acquire an exclusive lock related to package DB under given location.
-lockPackageDb :: FilePath -> IO PackageDbLock
+lockPackageDb :: OsPath -> IO PackageDbLock
-- | Release the lock related to package DB.
unlockPackageDb :: PackageDbLock -> IO ()
-- | Acquire a lock of given type related to package DB under given location.
-lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock
+lockPackageDbWith :: LockMode -> OsPath -> IO PackageDbLock
lockPackageDbWith mode file = do
-- We are trying to open the lock file and then lock it. Thus the lock file
-- needs to either exist or we need to be able to create it. Ideally we
@@ -350,10 +356,10 @@ lockPackageDbWith mode file = do
(lockFileOpenIn ReadWriteMode)
(const $ lockFileOpenIn ReadMode)
where
- lock = file <.> "lock"
+ lock = file OsPath.<.> OsPath.Internal.os "lock"
lockFileOpenIn io_mode = bracketOnError
- (openBinaryFile lock io_mode)
+ (FileIO.openBinaryFile lock io_mode)
hClose
-- If file locking support is not available, ignore the error and proceed
-- normally. Without it the only thing we lose on non-Windows platforms is
@@ -387,7 +393,7 @@ isDbOpenReadMode = \case
-- | Read the part of the package DB that GHC is interested in.
--
-readPackageDbForGhc :: FilePath -> IO [DbUnitInfo]
+readPackageDbForGhc :: OsPath -> IO [DbUnitInfo]
readPackageDbForGhc file =
decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
(pkgs, DbOpenReadOnly) -> return pkgs
@@ -409,7 +415,7 @@ readPackageDbForGhc file =
-- we additionally receive a PackageDbLock that represents a lock on the
-- database, so that we can safely update it later.
--
-readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t ->
+readPackageDbForGhcPkg :: Binary pkgs => OsPath -> DbOpenMode mode t ->
IO (pkgs, DbOpenMode mode PackageDbLock)
readPackageDbForGhcPkg file mode =
decodeFromFile file mode getDbForGhcPkg
@@ -425,7 +431,7 @@ readPackageDbForGhcPkg file mode =
-- | Write the whole of the package DB, both parts.
--
-writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO ()
+writePackageDb :: Binary pkgs => OsPath -> [DbUnitInfo] -> pkgs -> IO ()
writePackageDb file ghcPkgs ghcPkgPart = do
writeFileAtomic file (runPut putDbForGhcPkg)
#if !defined(mingw32_HOST_OS)
@@ -446,10 +452,10 @@ writePackageDb file ghcPkgs ghcPkgPart = do
ghcPart = encode ghcPkgs
#if !defined(mingw32_HOST_OS)
-addFileMode :: FilePath -> FileMode -> IO ()
+addFileMode :: OsPath -> FileMode -> IO ()
addFileMode file m = do
- o <- fileMode <$> getFileStatus file
- setFileMode file (m .|. o)
+ o <- fileMode <$> getFileStatus (getOsString file)
+ setFileMode (getOsString file) (m .|. o)
#endif
getHeader :: Get (Word32, Word32)
@@ -496,7 +502,7 @@ headerMagic = BS.Char8.pack "\0ghcpkg\0"
-- | Feed a 'Get' decoder with data chunks from a file.
--
-decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->
+decodeFromFile :: OsPath -> DbOpenMode mode t -> Get pkgs ->
IO (pkgs, DbOpenMode mode PackageDbLock)
decodeFromFile file mode decoder = case mode of
DbOpenReadOnly -> do
@@ -517,7 +523,7 @@ decodeFromFile file mode decoder = case mode of
bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do
(, DbOpenReadWrite lock) <$> decodeFileContents
where
- decodeFileContents = withBinaryFile file ReadMode $ \hnd ->
+ decodeFileContents = FileIO.withBinaryFile file ReadMode $ \hnd ->
feed hnd (runGetIncremental decoder)
feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize
@@ -527,21 +533,21 @@ decodeFromFile file mode decoder = case mode of
feed _ (Done _ _ res) = return res
feed _ (Fail _ _ msg) = ioError err
where
- err = mkIOError InappropriateType loc Nothing (Just file)
+ err = mkIOError InappropriateType loc Nothing (Just $ OsPath.Internal.so file)
`ioeSetErrorString` msg
loc = "GHC.Unit.Database.readPackageDb"
-- Copied from Cabal's Distribution.Simple.Utils.
-writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
+writeFileAtomic :: OsPath -> BS.Lazy.ByteString -> IO ()
writeFileAtomic targetPath content = do
- let (targetDir, targetFile) = splitFileName targetPath
+ let (targetDir, targetFile) = OsPath.splitFileName targetPath
Exception.bracketOnError
- (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
- (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
+ (FileIO.openBinaryTempFileWithDefaultPermissions targetDir $ targetFile OsPath.<.> OsPath.Internal.os "tmp")
+ (\(tmpPath, handle) -> hClose handle >> OsPath.removeFile tmpPath)
(\(tmpPath, handle) -> do
BS.Lazy.hPut handle content
hClose handle
- renameFile tmpPath targetPath)
+ OsPath.renameFile tmpPath targetPath)
instance Binary DbUnitInfo where
put (GenericUnitInfo
@@ -711,7 +717,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
-- rather than letting FilePath change it to use \ as the separator
stripVarPrefix var path = case ST.stripPrefix var path of
Just "" -> Just ""
- Just cs | isPathSeparator (ST.head cs) -> Just cs
+ Just cs | FilePath.isPathSeparator (ST.head cs) -> Just cs
_ -> Nothing
=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -81,6 +81,8 @@ Library
containers >= 0.5 && < 0.9,
directory >= 1.2 && < 1.4,
filepath >= 1.3 && < 1.6,
+ file-io,
+ os-string,
deepseq >= 1.4 && < 1.6,
ghc-platform >= 0.1,
ghc-toolchain >= 0.1
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -47,12 +47,19 @@ import Distribution.Types.UnqualComponentName
import Distribution.Types.LibraryName
import Distribution.Types.MungedPackageName
import Distribution.Types.MungedPackageId
-import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File)
+import Distribution.Simple.Utils (ignoreBOM, toUTF8BS, toUTF8LBS, fromUTF8LBS)
import qualified Data.Version as Version
-import System.FilePath as FilePath
+import System.OsPath as OsPath
+import qualified System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
-import System.Directory ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory,
- getModificationTime, XdgDirectory ( XdgData ) )
+import System.Directory.OsPath
+ ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory,
+ getModificationTime, XdgDirectory ( XdgData ),
+ doesDirectoryExist, getDirectoryContents,
+ doesFileExist, removeFile,
+ getCurrentDirectory )
+import System.Directory.Internal (os, so)
+import qualified System.File.OsPath as FileIO
import Text.Printf
import Prelude hiding (Foldable(..))
@@ -65,9 +72,6 @@ import Data.Bifunctor
import Data.Char ( toLower )
import Control.Monad
-import System.Directory ( doesDirectoryExist, getDirectoryContents,
- doesFileExist, removeFile,
- getCurrentDirectory )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
import System.IO
@@ -430,7 +434,7 @@ runit verbosity cli nonopts = do
glob filename >>= print
#endif
["init", filename] ->
- initPackageDB filename verbosity cli
+ initPackageDB (os filename) verbosity cli
["register", filename] ->
registerPackage filename verbosity cli
multi_instance
@@ -538,7 +542,7 @@ readPackageArg AsDefault str = Id <$> readGlobPkgId str
data PackageDB (mode :: GhcPkg.DbMode)
= PackageDB {
- location, locationAbsolute :: !FilePath,
+ location, locationAbsolute :: !OsPath,
-- We need both possibly-relative and definitely-absolute package
-- db locations. This is because the relative location is used as
-- an identifier for the db, so it is important we do not modify it.
@@ -570,14 +574,14 @@ allPackagesInStack = concatMap packages
-- specified package DB can depend on, since dependencies can only extend
-- down the stack, not up (e.g. global packages cannot depend on user
-- packages).
-stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack
+stackUpTo :: OsPath -> PackageDBStack -> PackageDBStack
stackUpTo to_modify = dropWhile ((/= to_modify) . location)
-readFromSettingsFile :: FilePath
- -> (FilePath -> RawSettings -> Either String b)
+readFromSettingsFile :: OsPath
+ -> (OsPath -> RawSettings -> Either String b)
-> IO (Either String b)
readFromSettingsFile settingsFile f = do
- settingsStr <- readFile settingsFile
+ settingsStr <- readUtf8File settingsFile
pure $ do
mySettings <- case maybeReadFuzzy settingsStr of
Just s -> pure $ Map.fromList s
@@ -586,11 +590,11 @@ readFromSettingsFile settingsFile f = do
Nothing -> Left $ "Can't parse settings file " ++ show settingsFile
f settingsFile mySettings
-readFromTargetFile :: FilePath
+readFromTargetFile :: OsPath
-> (Target -> b)
-> IO (Either String b)
readFromTargetFile targetFile f = do
- targetStr <- readFile targetFile
+ targetStr <- readUtf8File targetFile
pure $ do
target <- case maybeReadFuzzy targetStr of
Just t -> Right t
@@ -626,33 +630,33 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
case [ f | FlagGlobalConfig f <- my_flags ] of
-- See Note [Base Dir] for more information on the base dir / top dir.
[] -> do mb_dir <- getBaseDir
- case mb_dir of
+ case fmap os mb_dir of
Nothing -> die err_msg
Just dir -> do
-- Look for where it is given in the settings file, if marked there.
-- See Note [Settings file] about this file, and why we need GHC to share it with us.
- let settingsFile = dir </> "settings"
+ let settingsFile = dir </> os "settings"
exists_settings_file <- doesFileExist settingsFile
erel_db <-
if exists_settings_file
- then readFromSettingsFile settingsFile getGlobalPackageDb
- else pure (Left ("Settings file doesn't exist: " ++ settingsFile))
+ then readFromSettingsFile settingsFile (\ ospath -> getGlobalPackageDb (so ospath))
+ else pure (Left ("Settings file doesn't exist: " ++ show settingsFile))
case erel_db of
- Right rel_db -> return (dir, dir </> rel_db)
+ Right rel_db -> return (dir, dir </> os rel_db)
-- If the version of GHC doesn't have this field or the settings file
-- doesn't exist for some reason, look in the libdir.
Left err -> do
r <- lookForPackageDBIn dir
case r of
- Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ dir)])
+ Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ show dir)])
Just path -> return (dir, path)
fs -> do
-- The value of the $topdir variable used in some package descriptions
-- Note that the way we calculate this is slightly different to how it
-- is done in ghc itself. We rely on the convention that the global
-- package db lives in ghc's libdir.
- let pkg_db = last fs
+ let pkg_db = os $ last fs
top_dir <- absolutePath (takeDirectory pkg_db)
return (top_dir, pkg_db)
@@ -662,10 +666,10 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
-- getXdgDirectory can fail (e.g. if $HOME isn't set)
mb_user_conf <-
- case [ f | FlagUserConfig f <- my_flags ] of
+ case [ os f | FlagUserConfig f <- my_flags ] of
_ | no_user_db -> return Nothing
[] -> do
- let targetFile = top_dir </> "targets" </> "default.target"
+ let targetFile = top_dir </> os "targets" </> os "default.target"
exists_settings_file <- doesFileExist targetFile
targetArchOS <- case exists_settings_file of
False -> do
@@ -694,15 +698,15 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR
--
-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version
- m_appdir <- getFirstSuccess $ map (fmap (</> subdir))
- [ getAppUserDataDirectory "ghc" -- this is ~/.ghc/
- , getXdgDirectory XdgData "ghc" -- this is $XDG_DATA_HOME/
+ m_appdir <- getFirstSuccess $ map (fmap (</> os subdir))
+ [ getAppUserDataDirectory $ os "ghc" -- this is ~/.ghc/
+ , getXdgDirectory XdgData $ os "ghc" -- this is $XDG_DATA_HOME/
]
case m_appdir of
Nothing -> return Nothing
Just dir -> do
lookForPackageDBIn dir >>= \case
- Nothing -> return (Just (dir </> "package.conf.d", False))
+ Nothing -> return (Just (dir </> os "package.conf.d", False))
Just f -> return (Just (f, True))
fs -> return (Just (last fs, True))
@@ -716,11 +720,11 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
let env_stack =
- case e_pkg_path of
+ case fmap os e_pkg_path of
Left _ -> sys_databases
Right path
- | not (null path) && isSearchPathSeparator (last path)
- -> splitSearchPath (init path) ++ sys_databases
+ | hasTrailingPathSeparator path
+ -> splitSearchPath (dropTrailingPathSeparator path) <> sys_databases
| otherwise
-> splitSearchPath path
@@ -733,7 +737,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
| Just (user_conf, _user_exists) <- mb_user_conf
= Just user_conf
is_db_flag FlagGlobal = Just virt_global_conf
- is_db_flag (FlagConfig f) = Just f
+ is_db_flag (FlagConfig f) = Just $ os f
is_db_flag _ = Nothing
let flag_db_names | null db_flags = env_stack
@@ -748,7 +752,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
-- stack, unless any of them are present in the stack
-- already.
let final_stack = filter (`notElem` env_stack)
- [ f | FlagConfig f <- reverse my_flags ]
+ [ os f | FlagConfig f <- reverse my_flags ]
++ env_stack
top_db = if null db_flags
@@ -764,7 +768,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
when (verbosity > Normal) $ do
infoLn ("db stack: " ++ show (map location db_stack))
F.forM_ db_to_operate_on $ \db ->
- infoLn ("modifying: " ++ (location db))
+ infoLn ("modifying: " ++ show (location db))
infoLn ("flag db stack: " ++ show (map location flag_db_stack))
return (db_stack, db_to_operate_on, flag_db_stack)
@@ -843,12 +847,12 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
return (db_stack, GhcPkg.DbOpenReadWrite to_modify)
where
- couldntOpenDbForModification :: FilePath -> IOError -> IO a
+ couldntOpenDbForModification :: OsPath -> IOError -> IO a
couldntOpenDbForModification db_path e = die $ "Couldn't open database "
- ++ db_path ++ " for modification: " ++ show e
+ ++ show db_path ++ " for modification: " ++ show e
-- Parse package db in read-only mode.
- readDatabase :: FilePath -> IO (PackageDB 'GhcPkg.DbReadOnly)
+ readDatabase :: OsPath -> IO (PackageDB 'GhcPkg.DbReadOnly)
readDatabase db_path = do
db <- readParseDatabase verbosity mb_user_conf
GhcPkg.DbOpenReadOnly use_cache db_path
@@ -863,20 +867,20 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
(as, s'') <- stateSequence s' ms
return (a : as, s'')
-lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
+lookForPackageDBIn :: OsPath -> IO (Maybe OsPath)
lookForPackageDBIn dir = do
- let path_dir = dir </> "package.conf.d"
+ let path_dir = dir </> os "package.conf.d"
exists_dir <- doesDirectoryExist path_dir
if exists_dir then return (Just path_dir) else do
- let path_file = dir </> "package.conf"
+ let path_file = dir </> os "package.conf"
exists_file <- doesFileExist path_file
if exists_file then return (Just path_file) else return Nothing
readParseDatabase :: forall mode t. Verbosity
- -> Maybe (FilePath,Bool)
+ -> Maybe (OsPath,Bool)
-> GhcPkg.DbOpenMode mode t
-> Bool -- use cache
- -> FilePath
+ -> OsPath
-> IO (PackageDB mode)
readParseDatabase verbosity mb_user_conf mode use_cache path
-- the user database (only) is allowed to be non-existent
@@ -898,7 +902,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
Just db -> return db
Nothing ->
die $ "ghc no longer supports single-file style package "
- ++ "databases (" ++ path ++ ") use 'ghc-pkg init'"
+ ++ "databases (" ++ show path ++ ") use 'ghc-pkg init'"
++ "to create the database with the correct format."
| otherwise -> ioError err
@@ -914,7 +918,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
-- It's fine if the cache is not there as long as the
-- database is empty.
when (not $ null confs) $ do
- warn ("WARNING: cache does not exist: " ++ cache)
+ warn ("WARNING: cache does not exist: " ++ show cache)
warn ("ghc will fail to read this package db. " ++
recacheAdvice)
else do
@@ -923,7 +927,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
ignore_cache (const $ return ())
Right tcache -> do
when (verbosity >= Verbose) $ do
- warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
+ warn ("Timestamp " ++ show tcache ++ " for " ++ show cache)
-- If any of the .conf files is newer than package.cache, we
-- assume that cache is out of date.
cache_outdated <- (`anyM` confs) $ \conf ->
@@ -931,12 +935,12 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
if not cache_outdated
then do
when (verbosity > Normal) $
- infoLn ("using cache: " ++ cache)
+ infoLn ("using cache: " ++ show cache)
GhcPkg.readPackageDbForGhcPkg cache mode
>>= uncurry mkPackageDB
else do
whenReportCacheErrors $ do
- warn ("WARNING: cache is out of date: " ++ cache)
+ warn ("WARNING: cache is out of date: " ++ show cache)
warn ("ghc will see an old view of this " ++
"package db. " ++ recacheAdvice)
ignore_cache $ \file -> do
@@ -947,11 +951,11 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
GT -> " (older than cache)"
EQ -> " (same as cache)"
warn ("Timestamp " ++ show tFile
- ++ " for " ++ file ++ rel)
+ ++ " for " ++ show file ++ rel)
where
- confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs
+ confs = map (path </>) $ filter (os ".conf" `OsPath.isExtensionOf`) fs
- ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode)
+ ignore_cache :: (OsPath -> IO ()) -> IO (PackageDB mode)
ignore_cache checkTime = do
-- If we're opening for modification, we need to acquire a
-- lock even if we don't open the cache now, because we are
@@ -987,15 +991,16 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
packages = pkgs
}
-parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
+parseSingletonPackageConf :: Verbosity -> OsPath -> IO InstalledPackageInfo
parseSingletonPackageConf verbosity file = do
- when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
- BS.readFile file >>= fmap fst . parsePackageInfo
+ when (verbosity > Normal) $ infoLn ("reading package config: " ++ show file)
+ FileIO.readFile file >>= fmap fst . parsePackageInfo . BS.toStrict
-cachefilename :: FilePath
-cachefilename = "package.cache"
-mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode
+cachefilename :: OsPath
+cachefilename = os "package.cache"
+
+mungePackageDBPaths :: OsPath -> PackageDB mode -> PackageDB mode
mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
where
@@ -1012,7 +1017,7 @@ mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
-mungePackagePaths :: FilePath -> FilePath
+mungePackagePaths :: OsPath -> OsPath
-> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths top_dir pkgroot pkg =
-- TODO: similar code is duplicated in GHC.Unit.Database
@@ -1031,25 +1036,26 @@ mungePackagePaths top_dir pkgroot pkg =
munge_urls = map munge_url
(munge_path,munge_url) = mkMungePathUrl top_dir pkgroot
-mkMungePathUrl :: FilePath -> FilePath -> (FilePath -> FilePath, FilePath -> FilePath)
+mkMungePathUrl :: OsPath -> OsPath -> (FilePath -> FilePath, FilePath -> FilePath)
mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
where
munge_path p
- | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
- | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
+ | Just p' <- stripVarPrefix "${pkgroot}" p = so pkgroot ++ p'
+ | Just p' <- stripVarPrefix "$topdir" p = so top_dir ++ p'
| otherwise = p
munge_url p
- | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
- | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
+ | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath (so pkgroot) p'
+ | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath (so top_dir) p'
| otherwise = p
+ toUrlPath :: FilePath -> FilePath -> FilePath
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
++ FilePath.Posix.joinPath
(r : -- We need to drop a leading "/" or "\\"
-- if there is one:
- dropWhile (all isPathSeparator)
+ dropWhile (all FilePath.isPathSeparator)
(FilePath.splitDirectories p))
-- We could drop the separator here, and then use </> above. However,
@@ -1057,7 +1063,7 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
-- rather than letting FilePath change it to use \ as the separator
stripVarPrefix var path = case stripPrefix var path of
Just [] -> Just []
- Just cs@(c : _) | isPathSeparator c -> Just cs
+ Just cs@(c : _) | FilePath.isPathSeparator c -> Just cs
_ -> Nothing
-- -----------------------------------------------------------------------------
@@ -1074,18 +1080,18 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
-- ghc itself also cooperates in this workaround
-tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool)
- -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath
+tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (OsPath, Bool)
+ -> GhcPkg.DbOpenMode mode t -> Bool -> OsPath
-> IO (Maybe (PackageDB mode))
tryReadParseOldFileStyleDatabase verbosity mb_user_conf
mode use_cache path = do
-- assumes we've already established that path exists and is not a dir
- content <- readFile path `catchIO` \_ -> return ""
+ content <- readUtf8File path `catchIO` \_ -> return ""
if take 2 content == "[]"
then do
path_abs <- absolutePath path
let path_dir = adjustOldDatabasePath path
- warn $ "Warning: ignoring old file-style db and trying " ++ path_dir
+ warn $ "Warning: ignoring old file-style db and trying " ++ show path_dir
direxists <- doesDirectoryExist path_dir
if direxists
then do
@@ -1112,7 +1118,7 @@ tryReadParseOldFileStyleDatabase verbosity mb_user_conf
adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode)
adjustOldFileStylePackageDB db = do
-- assumes we have not yet established if it's an old style or not
- mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing
+ mcontent <- liftM Just (readUtf8File (location db)) `catchIO` \_ -> return Nothing
case fmap (take 2) mcontent of
-- it is an old style and empty db, so look for a dir kind in location.d/
Just "[]" -> return db {
@@ -1121,20 +1127,20 @@ adjustOldFileStylePackageDB db = do
}
-- it is old style but not empty, we have to bail
Just _ -> die $ "ghc no longer supports single-file style package "
- ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'"
+ ++ "databases (" ++ show (location db) ++ ") use 'ghc-pkg init'"
++ "to create the database with the correct format."
-- probably not old style, carry on as normal
Nothing -> return db
-adjustOldDatabasePath :: FilePath -> FilePath
-adjustOldDatabasePath = (<.> "d")
+adjustOldDatabasePath :: OsPath -> OsPath
+adjustOldDatabasePath = (<.> os "d")
-- -----------------------------------------------------------------------------
-- Creating a new package DB
-initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
+initPackageDB :: OsPath -> Verbosity -> [Flag] -> IO ()
initPackageDB filename verbosity _flags = do
- let eexist = die ("cannot create: " ++ filename ++ " already exists")
+ let eexist = die ("cannot create: " ++ show filename ++ " already exists")
b1 <- doesFileExist filename
when b1 eexist
b2 <- doesDirectoryExist filename
@@ -1148,7 +1154,7 @@ initPackageDB filename verbosity _flags = do
packageDbLock = GhcPkg.DbOpenReadWrite lock,
packages = []
}
- -- We can get away with passing an empty stack here, because the new DB is
+ -- We can get away with passing an empty stack here,FilePath because the new DB is
-- going to be initially empty, so no dependencies are going to be actually
-- looked up.
[]
@@ -1183,7 +1189,7 @@ registerPackage input verbosity my_flags multi_instance
f -> do
when (verbosity >= Normal) $
info ("Reading package info from " ++ show f ++ " ... ")
- readUTF8File f
+ readUtf8File $ os f
expanded <- if expand_env_vars then expandEnvVars s force
else return s
@@ -1274,13 +1280,13 @@ changeDBDir verbosity cmds db db_stack = do
updateDBCache verbosity db db_stack
where
do_cmd (RemovePackage p) = do
- let file = location db </> display (installedUnitId p) <.> "conf"
- when (verbosity > Normal) $ infoLn ("removing " ++ file)
+ let file = location db </> os (display (installedUnitId p)) <.> os "conf"
+ when (verbosity > Normal) $ infoLn ("removing " ++ show file)
removeFileSafe file
do_cmd (AddPackage p) = do
- let file = location db </> display (installedUnitId p) <.> "conf"
- when (verbosity > Normal) $ infoLn ("writing " ++ file)
- writeUTF8File file (showInstalledPackageInfo p)
+ let file = location db </> os (display (installedUnitId p)) <.> os "conf"
+ when (verbosity > Normal) $ infoLn ("writing " ++ show file)
+ writeUtf8File file (showInstalledPackageInfo p)
do_cmd (ModifyPackage p) =
do_cmd (AddPackage p)
@@ -1338,13 +1344,13 @@ updateDBCache verbosity db db_stack = do
warn $ " " ++ pkg
when (verbosity > Normal) $
- infoLn ("writing cache " ++ filename)
+ infoLn ("writing cache " ++ show filename)
let d = fmap (fromPackageCacheFormat . fst) pkgsGhcCacheFormat
GhcPkg.writePackageDb filename d pkgsCabalFormat
`catchIO` \e ->
if isPermissionError e
- then die $ filename ++ ": you don't have permission to modify this file"
+ then die $ show filename ++ ": you don't have permission to modify this file"
else ioError e
case packageDbLock db of
@@ -1583,7 +1589,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do
broken = map installedUnitId (brokenPackages pkg_map)
show_normal PackageDB{ location = db_name, packages = pkg_confs } =
- do hPutStrLn stdout db_name
+ do hPutStrLn stdout (show db_name)
if null pkg_confs
then hPutStrLn stdout " (no packages)"
else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs))
@@ -1610,7 +1616,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do
#else
let
show_colour PackageDB{ location = db_name, packages = pkg_confs } =
- do hPutStrLn stdout db_name
+ do hPutStrLn stdout (show db_name)
if null pkg_confs
then hPutStrLn stdout " (no packages)"
else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs))
@@ -1698,7 +1704,7 @@ dumpUnits verbosity my_flags expand_pkgroot = do
doDump expand_pkgroot [ (pkg, locationAbsolute db)
| db <- flag_db_stack, pkg <- packages db ]
-doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
+doDump :: Bool -> [(InstalledPackageInfo, OsPath)] -> IO ()
doDump expand_pkgroot pkgs = do
-- fix the encoding to UTF-8, since this is an interchange format
hSetEncoding stdout utf8
@@ -1731,7 +1737,7 @@ findPackagesByDB db_stack pkgarg
cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> IO a
cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg
- ++ maybe "" (\db -> " in " ++ location db) mdb
+ ++ maybe "" (\db -> " in " ++ show (location db)) mdb
where
pkg_msg (Id pkgid) = displayGlobPkgId pkgid
pkg_msg (IUId ipid) = display ipid
@@ -1944,7 +1950,7 @@ checkPackageConfig pkg verbosity db_stack
checkExposedModules db_stack pkg
checkOtherModules pkg
let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg)))
- when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg)
+ when has_code $ mapM_ (checkHSLib verbosity (fmap os $ libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg)
-- ToDo: check these somehow?
-- extra_libraries :: [String],
-- c_includes :: [String],
@@ -2011,20 +2017,20 @@ checkPath url_ok is_dir warn_only thisfield d
|| "https://" `isPrefixOf` d) = return ()
| url_ok
- , Just d' <- stripPrefix "file://" d
- = checkPath False is_dir warn_only thisfield d'
+ , Just f <- stripPrefix "file://" d
+ = checkPath False is_dir warn_only thisfield f
-- Note: we don't check for $topdir/${pkgroot} here. We rely on these
-- variables having been expanded already, see mungePackagePaths.
- | isRelative d = verror ForceFiles $
- thisfield ++ ": " ++ d ++ " is a relative path which "
+ | isRelative d' = verror ForceFiles $
+ thisfield ++ ": " ++ show d ++ " is a relative path which "
++ "makes no sense (as there is nothing for it to be "
++ "relative to). You can make paths relative to the "
++ "package database itself by using ${pkgroot}."
-- relative paths don't make any sense; #4134
| otherwise = do
- there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
+ there <- liftIO $ if is_dir then doesDirectoryExist d' else doesFileExist d'
when (not there) $
let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
++ if is_dir then "directory" else "file"
@@ -2032,6 +2038,8 @@ checkPath url_ok is_dir warn_only thisfield d
if warn_only
then vwarn msg
else verror ForceFiles msg
+ where
+ d' = os d
checkDep :: PackageDBStack -> UnitId -> Validate ()
checkDep db_stack pkgid
@@ -2050,24 +2058,25 @@ checkDuplicateDepends deps
where
dups = [ p | (p:_:_) <- group (sort deps) ]
-checkHSLib :: Verbosity -> [String] -> String -> Validate ()
+checkHSLib :: Verbosity -> [OsPath] -> String -> Validate ()
checkHSLib _verbosity dirs lib = do
- let filenames = ["lib" ++ lib ++ ".a",
- "lib" ++ lib ++ "_p.a",
- "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so",
- "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so",
- "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib",
- "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib",
- lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll",
- lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll",
- lib ++ ".bytecodelib"
- ]
+ let filenames = fmap os
+ [ "lib" ++ lib ++ ".a"
+ , "lib" ++ lib ++ "_p.a"
+ , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so"
+ , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so"
+ , "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib"
+ , "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib"
+ , lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll"
+ , lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll"
+ , lib ++ ".bytecodelib"
+ ]
b <- liftIO $ doesFileExistOnPath filenames dirs
when (not b) $
verror ForceFiles ("cannot find any of " ++ show filenames ++
" on library path")
-doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool
+doesFileExistOnPath :: [OsPath] -> [OsPath] -> IO Bool
doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames
where fullFilenames = [ path </> filename
| filename <- filenames
@@ -2096,9 +2105,9 @@ checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate ()
checkModuleFile pkg modl =
-- there's no interface file for GHC.Prim
unless (modl == ModuleName.fromString "GHC.Prim") $ do
- let files = [ ModuleName.toFilePath modl <.> extension
+ let files = [ os (ModuleName.toFilePath modl) <.> os extension
| extension <- ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ]
- b <- liftIO $ doesFileExistOnPath files (importDirs pkg)
+ b <- liftIO $ doesFileExistOnPath files (fmap os $ importDirs pkg)
when (not b) $
verror ForceFiles ("cannot find any of " ++ show files)
@@ -2280,12 +2289,18 @@ tryIO :: IO a -> IO (Either Exception.IOException a)
tryIO = Exception.try
-- removeFileSave doesn't throw an exceptions, if the file is already deleted
-removeFileSafe :: FilePath -> IO ()
+removeFileSafe :: OsPath -> IO ()
removeFileSafe fn =
removeFile fn `catchIO` \ e ->
when (not $ isDoesNotExistError e) $ ioError e
-- | Turn a path relative to the current directory into a (normalised)
-- absolute path.
-absolutePath :: FilePath -> IO FilePath
+absolutePath :: OsPath -> IO OsPath
absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
+
+writeUtf8File :: OsPath -> String -> IO ()
+writeUtf8File file contents = writeFileAtomic file (toUTF8LBS contents)
+
+readUtf8File :: OsPath -> IO String
+readUtf8File file = (ignoreBOM . fromUTF8LBS) <$> FileIO.readFile file
=====================================
utils/ghc-pkg/ghc-pkg.cabal.in
=====================================
@@ -25,6 +25,7 @@ Executable ghc-pkg
process >= 1 && < 1.7,
containers,
filepath,
+ file-io,
Cabal,
Cabal-syntax,
binary,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb859c262b84f5337c00f4bd98add2e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb859c262b84f5337c00f4bd98add2e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Teo Camarasu pushed new branch wip/T26925 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26925
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/fendor/ghc-pkg-ospath
by Hannes Siebenhandl (＠fendor) 24 Feb '26
by Hannes Siebenhandl (＠fendor) 24 Feb '26
24 Feb '26
Hannes Siebenhandl pushed new branch wip/fendor/ghc-pkg-ospath at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/ghc-pkg-ospath
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26868] Wibble order of kind variables
by Simon Peyton Jones (＠simonpj) 24 Feb '26
by Simon Peyton Jones (＠simonpj) 24 Feb '26
24 Feb '26
Simon Peyton Jones pushed to branch wip/T26868 at Glasgow Haskell Compiler / GHC
Commits:
3d06fd06 by Simon Peyton Jones at 2026-02-24T17:37:13+00:00
Wibble order of kind variables
- - - - -
1 changed file:
- compiler/GHC/Core/TyCo/FVs.hs
Changes:
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -258,8 +258,10 @@ deepUnitFV fvs_of_kind v
do_it :: BoundVars -> TyCoVarSet -> TyCoVarSet
do_it bvs acc | v `elemVarSet` bvs = acc
| v `elemVarSet` acc = acc
- | otherwise = runFVAcc (fvs_of_kind (varType v)) $
- acc `extendVarSet` v
+ | otherwise = runFVAcc (fvs_of_kind (varType v)) acc
+ `extendVarSet` v
+ -- Left-to-right: add the kind variables to the
+ -- accumulator before v itself
{- *********************************************************************
* *
@@ -395,8 +397,10 @@ deepDetUnitFV fvs_of_kind v
do_it :: BoundVars -> DTyCoVarSet -> DTyCoVarSet
do_it bvs acc | v `elemVarSet` bvs = acc
| v `elemDVarSet` acc = acc
- | otherwise = runFVAcc (fvs_of_kind (varType v)) $
- acc `extendDVarSet` v
+ | otherwise = runFVAcc (fvs_of_kind (varType v)) acc
+ `extendDVarSet` v
+ -- Left-to-right: add the kind variables to the
+ -- accumulator before v itself
{- *********************************************************************
* *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d06fd0687fe33a3eee01fcc4c0db3e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d06fd0687fe33a3eee01fcc4c0db3e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/VeryMilkyJoe/no-mod-loc-pat] Remove backwards compatability pattern synonym `ModLocation`
by Jana Chadt (＠VeryMilkyJoe) 24 Feb '26
by Jana Chadt (＠VeryMilkyJoe) 24 Feb '26
24 Feb '26
Jana Chadt pushed to branch wip/VeryMilkyJoe/no-mod-loc-pat at Glasgow Haskell Compiler / GHC
Commits:
61b16e2a by Jana Chadt at 2026-02-24T18:00:17+01:00
Remove backwards compatability pattern synonym `ModLocation`
* Introduce utility to create ShortByteString from an OsString.
* Introduce utility to create StringBuffer for a given OsPath.
* Add mkFastStringOsString, which returns a FastString for a given OsString.
Fixes #24932
- - - - -
12 changed files:
- compiler/GHC.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/CoreToStg/AddImplicitBinds.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Data/OsPath.hs
- compiler/GHC/Data/StringBuffer.hs
- compiler/GHC/Stg/Debug.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/ghc.cabal.in
- testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
- testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -79,7 +79,13 @@ module GHC (
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
- pattern ModLocation,
+ ml_hs_file,
+ ml_hi_file,
+ ml_dyn_hi_file,
+ ml_obj_file,
+ ml_dyn_obj_file,
+ ml_hie_file,
+ ml_bytecode_file,
getModSummary,
getModuleGraph,
isLoaded,
@@ -457,6 +463,7 @@ import System.Environment ( getEnv, getProgName )
import System.Exit ( exitWith, ExitCode(..) )
import System.FilePath
import System.IO.Error ( isDoesNotExistError )
+import GHC.Data.OsPath (OsPath)
#if defined(HAVE_INTERNAL_INTERPRETER)
import Foreign.C
@@ -1575,12 +1582,12 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
-- a module by using 'getModSummary'
--
-- XXX: Explain pre-conditions
-getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)
+getModuleSourceAndFlags :: ModSummary -> IO (OsPath, StringBuffer, DynFlags)
getModuleSourceAndFlags m = do
- case ml_hs_file $ ms_location m of
+ case ml_hs_file_ospath $ ms_location m of
Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))
Just sourceFile -> do
- source <- hGetStringBuffer sourceFile
+ source <- hGetStringBufferOsPath sourceFile
return (sourceFile, source, ms_hspp_opts m)
@@ -1592,7 +1599,7 @@ getModuleSourceAndFlags m = do
getTokenStream :: ModSummary -> IO [Located Token]
getTokenStream mod = do
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
- let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
+ let startLoc = mkRealSrcLoc (mkFastStringOsString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return ts
PFailed pst -> throwErrors (initSourceErrorContext dflags) (GhcPsMessage <$> getPsErrorMessages pst)
@@ -1603,7 +1610,7 @@ getTokenStream mod = do
getRichTokenStream :: ModSummary -> IO [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
- let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
+ let startLoc = mkRealSrcLoc (mkFastStringOsString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed pst -> throwErrors (initSourceErrorContext dflags) (GhcPsMessage <$> getPsErrorMessages pst)
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -33,7 +33,7 @@ import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse )
import GHC.Cmm.Utils
-import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString )
+import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastStringOsString )
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -156,7 +156,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
rangeRating (span, _)
| srcSpanFile span == thisFile = 1
| otherwise = 2 :: Int
- thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
+ thisFile = maybe nilFS mkFastStringOsString $ ml_hs_file_ospath modLoc
-- Returns block tree for this scope as well as all nested
-- scopes. Note that if there are multiple blocks in the (exact)
=====================================
compiler/GHC/CoreToStg/AddImplicitBinds.hs
=====================================
@@ -135,15 +135,16 @@ tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr
-- If we want to generate debug info, we put a source note on the
-- worker. This is useful, especially for heap profiling.
tick_it generate_debug_info mod_loc name
- | not generate_debug_info = id
+ | not generate_debug_info = id
| RealSrcSpan span _ <- nameSrcSpan name = tick span
- | Just file <- ml_hs_file mod_loc = tick (span1 file)
- | otherwise = tick (span1 "???")
+ | Just file <- ml_hs_file_ospath mod_loc = tick (span2 file)
+ | otherwise = tick (span1 "???")
where
tick span = Tick $ SourceNote span $
LexicalFastString $ mkFastString $
renderWithContext defaultSDocContext $ ppr name
- span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
+ span1 str = realSrcLocSpan $ mkRealSrcLoc (mkFastString str) 1 1
+ span2 file = realSrcLocSpan $ mkRealSrcLoc (mkFastStringOsString file) 1 1
=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -77,6 +77,7 @@ module GHC.Data.FastString
mkFastStringBytes,
mkFastStringByteList,
mkFastString#,
+ mkFastStringOsString,
-- ** Deconstruction
unpackFS, -- :: FastString -> String
@@ -134,12 +135,14 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Short as SBS
-import GHC.Data.ShortText (ShortText(..))
-import Foreign.C
-import System.IO
import Data.Data
import Data.IORef
import Data.Semigroup as Semi
+import Data.Type.Coercion (coerceWith)
+import Foreign.C
+import GHC.Data.ShortText (ShortText (..))
+import System.IO
+import System.OsString.Internal.Types
import Foreign
@@ -547,6 +550,14 @@ mkFastStringShortByteString :: ShortByteString -> FastString
mkFastStringShortByteString sbs =
inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs
+-- | Create a 'FastString' from an 'OsString', without copying.
+mkFastStringOsString :: OsString -> FastString
+mkFastStringOsString os = mkFastStringShortByteString $
+ -- Using 'OsPath''s 'unOS' here will unfortunately lead to cyclic dependencies
+ case coercionToPlatformTypes of
+ Left (_, windowsStringEv) -> unWS $ coerceWith windowsStringEv os
+ Right (_, posixStringEv) -> unPS $ coerceWith posixStringEv os
+
-- | Creates a UTF-8 encoded 'FastString' from a 'String'
mkFastString :: String -> FastString
{-# NOINLINE[1] mkFastString #-}
=====================================
compiler/GHC/Data/OsPath.hs
=====================================
@@ -8,6 +8,7 @@ module GHC.Data.OsPath
, unsafeDecodeUtf
, unsafeEncodeUtf
, os
+ , unOS
-- * Common utility functions
, (</>)
, (<.>)
@@ -28,13 +29,22 @@ import GHC.Prelude
import GHC.Utils.Misc (HasCallStack)
import GHC.Utils.Panic (panic)
+import Data.ByteString.Short (ShortByteString)
+import Data.Type.Coercion (coerceWith)
+import System.Directory.Internal (os)
+import System.Directory.OsPath (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getDirectoryContents)
import System.OsPath
import System.OsString (isSuffixOf)
-import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing)
-import System.Directory.Internal (os)
+import System.OsString.Internal.Types (coercionToPlatformTypes, unPS, unWS)
-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
-- Prefer 'decodeUtf' and gracious error handling.
unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
unsafeDecodeUtf p =
either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
+
+-- | Extracts underlying 'ShortByteString' from the given 'OsString', taking care of platform specifics.
+unOS :: OsString -> ShortByteString
+unOS os = case coercionToPlatformTypes of
+ Left (_, windowsStringEv) -> unWS $ coerceWith windowsStringEv os
+ Right (_, posixStringEv) -> unPS $ coerceWith posixStringEv os
=====================================
compiler/GHC/Data/StringBuffer.hs
=====================================
@@ -21,6 +21,7 @@ module GHC.Data.StringBuffer
-- * Creation\/destruction
hGetStringBuffer,
hGetStringBufferBlock,
+ hGetStringBufferOsPath,
hPutStringBuffer,
appendStringBuffers,
stringToStringBuffer,
@@ -56,17 +57,19 @@ module GHC.Data.StringBuffer
import GHC.Prelude
import GHC.Data.FastString
+import GHC.Data.OsPath (OsPath)
+import GHC.Fingerprint
import GHC.Utils.Encoding
+import GHC.Utils.Exception (bracket_)
import GHC.Utils.IO.Unsafe
import GHC.Utils.Panic.Plain
-import GHC.Utils.Exception ( bracket_ )
-import GHC.Fingerprint
import Data.Maybe
+import GHC.IO.Encoding.Failure (CodingFailureMode (IgnoreCodingFailure))
+import GHC.IO.Encoding.UTF8 (mkUTF8)
+import System.File.OsPath qualified as FileIO
import System.IO
-import System.IO.Unsafe ( unsafePerformIO )
-import GHC.IO.Encoding.UTF8 ( mkUTF8 )
-import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) )
+import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString as BS
@@ -111,6 +114,15 @@ instance Show StringBuffer where
hGetStringBuffer :: FilePath -> IO StringBuffer
hGetStringBuffer fname = do
h <- openBinaryFile fname ReadMode
+ hGetStringBufferHandle h
+
+hGetStringBufferOsPath :: OsPath -> IO StringBuffer
+hGetStringBufferOsPath fname = do
+ h <- FileIO.openBinaryFile fname ReadMode
+ hGetStringBufferHandle h
+
+hGetStringBufferHandle :: Handle -> IO StringBuffer
+hGetStringBufferHandle h = do
size_i <- hFileSize h
offset_i <- skipBOM h size_i 0 -- offset is 0 initially
let size = fromIntegral $ size_i - offset_i
=====================================
compiler/GHC/Stg/Debug.hs
=====================================
@@ -87,7 +87,7 @@ recordInfo :: Id -> StgExpr -> M ()
recordInfo bndr new_rhs = do
modLoc <- asks rModLocation
let
- thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
+ thisFile = maybe nilFS mkFastStringOsString $ ml_hs_file_ospath modLoc
-- A span from the ticks surrounding the new_rhs
best_span = quickSourcePos thisFile new_rhs
-- A back-up span if the bndr had a source position, many do not (think internally generated ids)
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -2,31 +2,28 @@
{-# LANGUAGE ViewPatterns #-}
-- | Module location
module GHC.Unit.Module.Location
- ( ModLocation
- ( ..
- , ml_hs_file
- , ml_hi_file
- , ml_dyn_hi_file
- , ml_obj_file
- , ml_dyn_obj_file
- , ml_hie_file
- , ml_bytecode_file
- )
- , pattern ModLocation
+ ( ModLocation(..)
, addBootSuffix
, addBootSuffixLocn
, addBootSuffixLocnOut
, removeBootSuffix
, mkFileSrcSpan
+ , ml_hs_file
+ , ml_hi_file
+ , ml_dyn_hi_file
+ , ml_obj_file
+ , ml_dyn_obj_file
+ , ml_hie_file
+ , ml_bytecode_file
)
where
import GHC.Prelude
+import GHC.Data.FastString (mkFastStringOsString)
import GHC.Data.OsPath
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
-import GHC.Data.FastString (mkFastString)
import qualified System.OsString as OsString
@@ -120,41 +117,31 @@ addBootSuffixLocnOut locn
-- | Compute a 'SrcSpan' from a 'ModLocation'.
mkFileSrcSpan :: ModLocation -> SrcSpan
mkFileSrcSpan mod_loc
- = case ml_hs_file mod_loc of
- Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
+ = case ml_hs_file_ospath mod_loc of
+ Just file_path -> mkGeneralSrcSpan (mkFastStringOsString file_path)
Nothing -> interactiveSrcSpan -- Presumably
-- ----------------------------------------------------------------------------
-- Helpers for backwards compatibility
-- ----------------------------------------------------------------------------
-{-# COMPLETE ModLocation #-}
-
-pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation
-pattern ModLocation
- { ml_hs_file
- , ml_hi_file
- , ml_dyn_hi_file
- , ml_obj_file
- , ml_dyn_obj_file
- , ml_hie_file
- , ml_bytecode_file
- } <- OsPathModLocation
- { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file)
- , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file)
- , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file)
- , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file)
- , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file)
- , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file)
- , ml_bytecode_file_ospath = (unsafeDecodeUtf -> ml_bytecode_file)
- } where
- ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file ml_bytecode_file
- = OsPathModLocation
- { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file
- , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file
- , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file
- , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file
- , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file
- , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file
- , ml_bytecode_file_ospath = unsafeEncodeUtf ml_bytecode_file
- }
+ml_hs_file :: ModLocation -> Maybe FilePath
+ml_hs_file = fmap unsafeDecodeUtf . ml_hs_file_ospath
+
+ml_hi_file :: ModLocation -> FilePath
+ml_hi_file = unsafeDecodeUtf . ml_hi_file_ospath
+
+ml_dyn_hi_file :: ModLocation -> FilePath
+ml_dyn_hi_file = unsafeDecodeUtf . ml_dyn_hi_file_ospath
+
+ml_obj_file :: ModLocation -> FilePath
+ml_obj_file = unsafeDecodeUtf . ml_obj_file_ospath
+
+ml_dyn_obj_file :: ModLocation -> FilePath
+ml_dyn_obj_file = unsafeDecodeUtf . ml_dyn_obj_file_ospath
+
+ml_hie_file :: ModLocation -> FilePath
+ml_hie_file = unsafeDecodeUtf . ml_hie_file_ospath
+
+ml_bytecode_file :: ModLocation -> FilePath
+ml_bytecode_file = unsafeDecodeUtf . ml_bytecode_file_ospath
=====================================
compiler/GHC/Unit/Module/ModSummary.hs
=====================================
@@ -46,7 +46,7 @@ import GHC.Types.PkgQual
import GHC.Types.Basic
import GHC.Data.Maybe
-import GHC.Data.OsPath (OsPath)
+import GHC.Data.OsPath ( OsPath )
import GHC.Data.StringBuffer ( StringBuffer )
import GHC.Utils.Fingerprint
@@ -214,7 +214,7 @@ findTarget ms ts =
= ms_mod_name summary == m && ms_unitid summary == unitId
summary `matches` Target { targetId = TargetFile f _, targetUnitId = unitid }
| Just f' <- ml_hs_file (ms_location summary)
- = f == f' && ms_unitid summary == unitid
+ = f == f' && ms_unitid summary == unitid
_ `matches` _
= False
=====================================
compiler/ghc.cabal.in
=====================================
@@ -125,6 +125,7 @@ Library
containers >= 0.6.2.1 && < 0.9,
array >= 0.1 && < 0.6,
filepath >= 1.5 && < 1.6,
+ file-io >= 0.1.5 && < 0.3,
os-string >= 2.0.1 && < 2.1,
hpc >= 0.6 && < 0.8,
transformers >= 0.5 && < 0.7,
=====================================
testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
=====================================
@@ -31,7 +31,7 @@ convertToFixed (ModuleNodeCompile ms) =
-- with the module summary information
let modName = ms_mod_name ms
modLoc = ms_location ms
- in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing}
+ in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing }
-- | Load a module graph and report the result
=====================================
testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
=====================================
@@ -29,7 +29,7 @@ convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo
convertToFixed (ModuleNodeCompile ms) =
let modName = ms_mod_name ms
modLoc = ms_location ms
- in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing}
+ in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing }
-- | Test a module graph and report if it matches expected invariant violations
testModuleGraph :: String -> ModuleGraph -> [ModuleGraphInvariantError] -> Ghc ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/61b16e2ac75640c990f9af4c7522679…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/61b16e2ac75640c990f9af4c7522679…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/VeryMilkyJoe/no-mod-loc-pat] Remove backwards compatability pattern synonym `ModLocation`
by Jana Chadt (＠VeryMilkyJoe) 24 Feb '26
by Jana Chadt (＠VeryMilkyJoe) 24 Feb '26
24 Feb '26
Jana Chadt pushed to branch wip/VeryMilkyJoe/no-mod-loc-pat at Glasgow Haskell Compiler / GHC
Commits:
07405614 by Jana Chadt at 2026-02-24T17:58:22+01:00
Remove backwards compatability pattern synonym `ModLocation`
* Introduce utility to create ShortByteString from an OsString.
* Introduce utility to create StringBuffer for a given OsPath.
* Add mkFastStringOsString, which returns a FastString for a given OsString.
Fixes #24932
- - - - -
12 changed files:
- compiler/GHC.hs
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/CoreToStg/AddImplicitBinds.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Data/OsPath.hs
- compiler/GHC/Data/StringBuffer.hs
- compiler/GHC/Stg/Debug.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/ghc.cabal.in
- testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
- testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -79,7 +79,13 @@ module GHC (
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
- pattern ModLocation,
+ ml_hs_file,
+ ml_hi_file,
+ ml_dyn_hi_file,
+ ml_obj_file,
+ ml_dyn_obj_file,
+ ml_hie_file,
+ ml_bytecode_file,
getModSummary,
getModuleGraph,
isLoaded,
@@ -457,6 +463,7 @@ import System.Environment ( getEnv, getProgName )
import System.Exit ( exitWith, ExitCode(..) )
import System.FilePath
import System.IO.Error ( isDoesNotExistError )
+import GHC.Data.OsPath (OsPath)
#if defined(HAVE_INTERNAL_INTERPRETER)
import Foreign.C
@@ -1575,12 +1582,12 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
-- a module by using 'getModSummary'
--
-- XXX: Explain pre-conditions
-getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)
+getModuleSourceAndFlags :: ModSummary -> IO (OsPath, StringBuffer, DynFlags)
getModuleSourceAndFlags m = do
- case ml_hs_file $ ms_location m of
+ case ml_hs_file_ospath $ ms_location m of
Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))
Just sourceFile -> do
- source <- hGetStringBuffer sourceFile
+ source <- hGetStringBufferOsPath sourceFile
return (sourceFile, source, ms_hspp_opts m)
@@ -1592,7 +1599,7 @@ getModuleSourceAndFlags m = do
getTokenStream :: ModSummary -> IO [Located Token]
getTokenStream mod = do
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
- let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
+ let startLoc = mkRealSrcLoc (mkFastStringOsString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return ts
PFailed pst -> throwErrors (initSourceErrorContext dflags) (GhcPsMessage <$> getPsErrorMessages pst)
@@ -1603,7 +1610,7 @@ getTokenStream mod = do
getRichTokenStream :: ModSummary -> IO [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, dflags) <- getModuleSourceAndFlags mod
- let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
+ let startLoc = mkRealSrcLoc (mkFastStringOsString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed pst -> throwErrors (initSourceErrorContext dflags) (GhcPsMessage <$> getPsErrorMessages pst)
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -33,7 +33,7 @@ import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse )
import GHC.Cmm.Utils
-import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString )
+import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastStringOsString )
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -156,7 +156,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
rangeRating (span, _)
| srcSpanFile span == thisFile = 1
| otherwise = 2 :: Int
- thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
+ thisFile = maybe nilFS mkFastStringOsString $ ml_hs_file_ospath modLoc
-- Returns block tree for this scope as well as all nested
-- scopes. Note that if there are multiple blocks in the (exact)
=====================================
compiler/GHC/CoreToStg/AddImplicitBinds.hs
=====================================
@@ -135,15 +135,16 @@ tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr
-- If we want to generate debug info, we put a source note on the
-- worker. This is useful, especially for heap profiling.
tick_it generate_debug_info mod_loc name
- | not generate_debug_info = id
+ | not generate_debug_info = id
| RealSrcSpan span _ <- nameSrcSpan name = tick span
- | Just file <- ml_hs_file mod_loc = tick (span1 file)
- | otherwise = tick (span1 "???")
+ | Just file <- ml_hs_file_ospath mod_loc = tick (span2 file)
+ | otherwise = tick (span1 "???")
where
tick span = Tick $ SourceNote span $
LexicalFastString $ mkFastString $
renderWithContext defaultSDocContext $ ppr name
- span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
+ span1 str = realSrcLocSpan $ mkRealSrcLoc (mkFastString str) 1 1
+ span2 file = realSrcLocSpan $ mkRealSrcLoc (mkFastStringOsString file) 1 1
=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -77,6 +77,7 @@ module GHC.Data.FastString
mkFastStringBytes,
mkFastStringByteList,
mkFastString#,
+ mkFastStringOsString,
-- ** Deconstruction
unpackFS, -- :: FastString -> String
@@ -134,12 +135,14 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Short as SBS
-import GHC.Data.ShortText (ShortText(..))
-import Foreign.C
-import System.IO
import Data.Data
import Data.IORef
import Data.Semigroup as Semi
+import Data.Type.Coercion (coerceWith)
+import Foreign.C
+import GHC.Data.ShortText (ShortText (..))
+import System.IO
+import System.OsString.Internal.Types
import Foreign
@@ -547,6 +550,14 @@ mkFastStringShortByteString :: ShortByteString -> FastString
mkFastStringShortByteString sbs =
inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs
+-- | Create a 'FastString' from an 'OsString', without copying.
+mkFastStringOsString :: OsString -> FastString
+mkFastStringOsString os = mkFastStringShortByteString $
+ -- Using 'OsPath''s 'unOS' here will unfortunately lead to cyclic dependencies
+ case coercionToPlatformTypes of
+ Left (_, windowsStringEv) -> unWS $ coerceWith windowsStringEv os
+ Right (_, posixStringEv) -> unPS $ coerceWith posixStringEv os
+
-- | Creates a UTF-8 encoded 'FastString' from a 'String'
mkFastString :: String -> FastString
{-# NOINLINE[1] mkFastString #-}
=====================================
compiler/GHC/Data/OsPath.hs
=====================================
@@ -8,6 +8,7 @@ module GHC.Data.OsPath
, unsafeDecodeUtf
, unsafeEncodeUtf
, os
+ , unOS
-- * Common utility functions
, (</>)
, (<.>)
@@ -28,13 +29,22 @@ import GHC.Prelude
import GHC.Utils.Misc (HasCallStack)
import GHC.Utils.Panic (panic)
+import Data.ByteString.Short (ShortByteString)
+import Data.Type.Coercion (coerceWith)
+import System.Directory.Internal (os)
+import System.Directory.OsPath (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getDirectoryContents)
import System.OsPath
import System.OsString (isSuffixOf)
-import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing)
-import System.Directory.Internal (os)
+import System.OsString.Internal.Types (coercionToPlatformTypes, unPS, unWS)
-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
-- Prefer 'decodeUtf' and gracious error handling.
unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
unsafeDecodeUtf p =
either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
+
+-- | Extracts underlying 'ShortByteString' from the given 'OsString', taking care of platform specifics.
+unOS :: OsString -> ShortByteString
+unOS os = case coercionToPlatformTypes of
+ Left (_, windowsStringEv) -> unWS $ coerceWith windowsStringEv os
+ Right (_, posixStringEv) -> unPS $ coerceWith posixStringEv os
=====================================
compiler/GHC/Data/StringBuffer.hs
=====================================
@@ -21,6 +21,7 @@ module GHC.Data.StringBuffer
-- * Creation\/destruction
hGetStringBuffer,
hGetStringBufferBlock,
+ hGetStringBufferOsPath,
hPutStringBuffer,
appendStringBuffers,
stringToStringBuffer,
@@ -56,17 +57,19 @@ module GHC.Data.StringBuffer
import GHC.Prelude
import GHC.Data.FastString
+import GHC.Data.OsPath (OsPath)
+import GHC.Fingerprint
import GHC.Utils.Encoding
+import GHC.Utils.Exception (bracket_)
import GHC.Utils.IO.Unsafe
import GHC.Utils.Panic.Plain
-import GHC.Utils.Exception ( bracket_ )
-import GHC.Fingerprint
import Data.Maybe
+import GHC.IO.Encoding.Failure (CodingFailureMode (IgnoreCodingFailure))
+import GHC.IO.Encoding.UTF8 (mkUTF8)
+import System.File.OsPath qualified as FileIO
import System.IO
-import System.IO.Unsafe ( unsafePerformIO )
-import GHC.IO.Encoding.UTF8 ( mkUTF8 )
-import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) )
+import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString as BS
@@ -111,6 +114,15 @@ instance Show StringBuffer where
hGetStringBuffer :: FilePath -> IO StringBuffer
hGetStringBuffer fname = do
h <- openBinaryFile fname ReadMode
+ hGetStringBufferHandle h
+
+hGetStringBufferOsPath :: OsPath -> IO StringBuffer
+hGetStringBufferOsPath fname = do
+ h <- FileIO.openBinaryFile fname ReadMode
+ hGetStringBufferHandle h
+
+hGetStringBufferHandle :: Handle -> IO StringBuffer
+hGetStringBufferHandle h = do
size_i <- hFileSize h
offset_i <- skipBOM h size_i 0 -- offset is 0 initially
let size = fromIntegral $ size_i - offset_i
=====================================
compiler/GHC/Stg/Debug.hs
=====================================
@@ -87,7 +87,7 @@ recordInfo :: Id -> StgExpr -> M ()
recordInfo bndr new_rhs = do
modLoc <- asks rModLocation
let
- thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
+ thisFile = maybe nilFS mkFastStringOsString $ ml_hs_file_ospath modLoc
-- A span from the ticks surrounding the new_rhs
best_span = quickSourcePos thisFile new_rhs
-- A back-up span if the bndr had a source position, many do not (think internally generated ids)
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -2,31 +2,28 @@
{-# LANGUAGE ViewPatterns #-}
-- | Module location
module GHC.Unit.Module.Location
- ( ModLocation
- ( ..
- , ml_hs_file
- , ml_hi_file
- , ml_dyn_hi_file
- , ml_obj_file
- , ml_dyn_obj_file
- , ml_hie_file
- , ml_bytecode_file
- )
- , pattern ModLocation
+ ( ModLocation(..)
, addBootSuffix
, addBootSuffixLocn
, addBootSuffixLocnOut
, removeBootSuffix
, mkFileSrcSpan
+ , ml_hs_file
+ , ml_hi_file
+ , ml_dyn_hi_file
+ , ml_obj_file
+ , ml_dyn_obj_file
+ , ml_hie_file
+ , ml_bytecode_file
)
where
import GHC.Prelude
+import GHC.Data.FastString (mkFastStringOsString)
import GHC.Data.OsPath
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
-import GHC.Data.FastString (mkFastString)
import qualified System.OsString as OsString
@@ -120,41 +117,31 @@ addBootSuffixLocnOut locn
-- | Compute a 'SrcSpan' from a 'ModLocation'.
mkFileSrcSpan :: ModLocation -> SrcSpan
mkFileSrcSpan mod_loc
- = case ml_hs_file mod_loc of
- Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
+ = case ml_hs_file_ospath mod_loc of
+ Just file_path -> mkGeneralSrcSpan (mkFastStringOsString file_path)
Nothing -> interactiveSrcSpan -- Presumably
-- ----------------------------------------------------------------------------
-- Helpers for backwards compatibility
-- ----------------------------------------------------------------------------
-{-# COMPLETE ModLocation #-}
-
-pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation
-pattern ModLocation
- { ml_hs_file
- , ml_hi_file
- , ml_dyn_hi_file
- , ml_obj_file
- , ml_dyn_obj_file
- , ml_hie_file
- , ml_bytecode_file
- } <- OsPathModLocation
- { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file)
- , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file)
- , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file)
- , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file)
- , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file)
- , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file)
- , ml_bytecode_file_ospath = (unsafeDecodeUtf -> ml_bytecode_file)
- } where
- ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file ml_bytecode_file
- = OsPathModLocation
- { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file
- , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file
- , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file
- , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file
- , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file
- , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file
- , ml_bytecode_file_ospath = unsafeEncodeUtf ml_bytecode_file
- }
+ml_hs_file :: ModLocation -> Maybe FilePath
+ml_hs_file = fmap unsafeDecodeUtf . ml_hs_file_ospath
+
+ml_hi_file :: ModLocation -> FilePath
+ml_hi_file = unsafeDecodeUtf . ml_hi_file_ospath
+
+ml_dyn_hi_file :: ModLocation -> FilePath
+ml_dyn_hi_file = unsafeDecodeUtf . ml_dyn_hi_file_ospath
+
+ml_obj_file :: ModLocation -> FilePath
+ml_obj_file = unsafeDecodeUtf . ml_obj_file_ospath
+
+ml_dyn_obj_file :: ModLocation -> FilePath
+ml_dyn_obj_file = unsafeDecodeUtf . ml_dyn_obj_file_ospath
+
+ml_hie_file :: ModLocation -> FilePath
+ml_hie_file = unsafeDecodeUtf . ml_hie_file_ospath
+
+ml_bytecode_file :: ModLocation -> FilePath
+ml_bytecode_file = unsafeDecodeUtf . ml_bytecode_file_ospath
=====================================
compiler/GHC/Unit/Module/ModSummary.hs
=====================================
@@ -46,7 +46,7 @@ import GHC.Types.PkgQual
import GHC.Types.Basic
import GHC.Data.Maybe
-import GHC.Data.OsPath (OsPath)
+import GHC.Data.OsPath ( OsPath )
import GHC.Data.StringBuffer ( StringBuffer )
import GHC.Utils.Fingerprint
@@ -214,7 +214,7 @@ findTarget ms ts =
= ms_mod_name summary == m && ms_unitid summary == unitId
summary `matches` Target { targetId = TargetFile f _, targetUnitId = unitid }
| Just f' <- ml_hs_file (ms_location summary)
- = f == f' && ms_unitid summary == unitid
+ = f == f' && ms_unitid summary == unitid
_ `matches` _
= False
=====================================
compiler/ghc.cabal.in
=====================================
@@ -125,6 +125,7 @@ Library
containers >= 0.6.2.1 && < 0.9,
array >= 0.1 && < 0.6,
filepath >= 1.5 && < 1.6,
+ file-io >= 0.1.5 && < 0.3,
os-string >= 2.0.1 && < 2.1,
hpc >= 0.6 && < 0.8,
transformers >= 0.5 && < 0.7,
=====================================
testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs
=====================================
@@ -31,7 +31,7 @@ convertToFixed (ModuleNodeCompile ms) =
-- with the module summary information
let modName = ms_mod_name ms
modLoc = ms_location ms
- in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing}
+ in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing }
-- | Load a module graph and report the result
=====================================
testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs
=====================================
@@ -29,7 +29,7 @@ convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo
convertToFixed (ModuleNodeCompile ms) =
let modName = ms_mod_name ms
modLoc = ms_location ms
- in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing}
+ in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing }
-- | Test a module graph and report if it matches expected invariant violations
testModuleGraph :: String -> ModuleGraph -> [ModuleGraphInvariantError] -> Ghc ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0740561449bca25bc6df9b4903589a7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0740561449bca25bc6df9b4903589a7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0