- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] 2 commits: Use topLibDir
by Sven Tennie (＠supersven) 25 Feb '26

25 Feb '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 6a2aa024 by Sven Tennie at 2026-02-25T19:34:01+00:00 Use topLibDir - - - - - 5d7e35f3 by Sven Tennie at 2026-02-25T20:52:55+00:00 Fix stages in generateSettings - - - - - 2 changed files: - compiler/GHC/Driver/Config/Interpreter.hs - hadrian/src/Rules/Generate.hs Changes: ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -17,8 +17,8 @@ import System.Directory initInterpOpts :: DynFlags -> IO InterpOpts initInterpOpts dflags = do - wasm_dyld <- makeAbsolute $ topDir dflags </> "dyld.mjs" - js_interp <- makeAbsolute $ topDir dflags </> "ghc-interp.js" + wasm_dyld <- makeAbsolute $ libTopDir dflags </> "dyld.mjs" + js_interp <- makeAbsolute $ libTopDir dflags </> "ghc-interp.js" pure $ InterpOpts { interpExternal = gopt Opt_ExternalInterpreter dflags , interpProg = pgm_i dflags ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -469,7 +469,8 @@ generateSettings :: FilePath -> Expr String generateSettings settingsFile = do ctx <- getContext stage <- getStage - isCrossStage <- expr $ crossStage stage + let ghcStage = predStage stage + isCrossStage <- expr $ crossStage ghcStage package_db_path <- expr $ do let get_pkg_db stg = packageDbPath (PackageDbLoc stg Final) @@ -489,7 +490,7 @@ generateSettings settingsFile = do Stage2 -> pkgUnitId Stage1 base Stage3 -> pkgUnitId Stage2 base - rel_lib_topDir :: FilePath <- expr $ buildRoot <&> (-/- stageString (if isCrossStage then stage else predStage stage) -/- "lib") + rel_lib_topDir :: FilePath <- expr $ buildRoot <&> (-/- stageString (if isCrossStage then stage else ghcStage) -/- "lib") let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path make_absolute rel_path = do abs_path <- liftIO (makeAbsolute rel_path) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6c99ca77f745b7c4565fe363d91a19… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6c99ca77f745b7c4565fe363d91a19… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ghc-pkg-ospath] 3 commits: Migrate ghc-pkg to use OsPath only
by Hannes Siebenhandl (＠fendor) 25 Feb '26

25 Feb '26

Hannes Siebenhandl pushed to branch wip/fendor/ghc-pkg-ospath at Glasgow Haskell Compiler / GHC Commits: fd34717c by Fendor at 2026-02-25T18:45:39+01:00 Migrate ghc-pkg to use OsPath only - - - - - 90e66dbc by Fendor at 2026-02-25T18:45:39+01:00 Add ghc-pkg regression test for LONG PATH - - - - - 7b8f78ed by Fendor at 2026-02-25T19:35:58+01:00 Long Path aware manifest - - - - - 13 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Linker/Windows.hs - compiler/GHC/Unit/State.hs - docs/users_guide/phases.rst - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-boot/ghc-boot.cabal.in - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/ghcpkg10.stdout - utils/ghc-pkg/Main.hs - utils/ghc-pkg/ghc-pkg.cabal.in Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1208,6 +1208,7 @@ defaultFlags settings = [ Opt_AutoLinkPackages, Opt_DiagnosticsShowCaret, Opt_EmbedManifest, + Opt_WinLongPathAware, Opt_FamAppCache, Opt_GenManifest, Opt_GhciHistory, ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -743,6 +743,7 @@ data GeneralFlag | Opt_PrintBindContents | Opt_GenManifest | Opt_EmbedManifest + | Opt_WinLongPathAware | Opt_SharedImplib | Opt_BuildingCabalPackage | Opt_IgnoreDotGhci ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2523,6 +2523,7 @@ fFlagsDeps = [ flagSpec "eager-blackholing" Opt_EagerBlackHoling, flagSpec "orig-thunk-info" Opt_OrigThunkInfo, flagSpec "embed-manifest" Opt_EmbedManifest, + flagSpec "win-aware-long-paths" Opt_WinLongPathAware, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, flagSpec "error-spans" Opt_ErrorSpans, ===================================== compiler/GHC/Linker/Windows.hs ===================================== @@ -13,9 +13,11 @@ import GHC.Utils.Logger import System.FilePath import System.Directory +import Debug.Trace data ManifestOpts = ManifestOpts { manifestEmbed :: !Bool -- ^ Should the manifest be embedded in the binary with Windres + , manifestLongPathAware :: !Bool , manifestTempdir :: TempDir , manifestWindresConfig :: WindresConfig , manifestObjectSuf :: String @@ -24,11 +26,39 @@ data ManifestOpts = ManifestOpts initManifestOpts :: DynFlags -> ManifestOpts initManifestOpts dflags = ManifestOpts { manifestEmbed = gopt Opt_EmbedManifest dflags + , manifestLongPathAware = gopt Opt_WinLongPathAware dflags , manifestTempdir = tmpDir dflags , manifestWindresConfig = configureWindres dflags , manifestObjectSuf = objectSuf dflags } +manifestContents :: Bool -> FilePath -> String +manifestContents longPathAware exe_filename = + "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ + \ <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n\ + \ <assemblyIdentity version=\"1.0.0.0\"\n\ + \ processorArchitecture=\"X86\"\n\ + \ name=\"" ++ dropExtension exe_filename ++ "\"\n\ + \ type=\"win32\"/>\n\n\ + \ <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n\ + \ <security>\n\ + \ <requestedPrivileges>\n\ + \ <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n\ + \ </requestedPrivileges>\n\ + \ </security>\n\ + \ </trustInfo>\n" + ++ + if longPathAware + then + " <application xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n\ + \ <windowsSettings xmlns:ws2=\"http://schemas.microsoft.com/SMI/2016/WindowsSettings\">\n\ + \ <ws2:longPathAware>true</ws2:longPathAware>\n\ + \ </windowsSettings>\n\ + \ </application>\n" + else + "" + ++ "</assembly>\n" + maybeCreateManifest :: Logger -> TmpFs @@ -37,22 +67,9 @@ maybeCreateManifest -> IO [FilePath] -- ^ extra objects to embed, maybe maybeCreateManifest logger tmpfs opts exe_filename = do let manifest_filename = exe_filename <.> "manifest" - manifest = - "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ - \ <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n\ - \ <assemblyIdentity version=\"1.0.0.0\"\n\ - \ processorArchitecture=\"X86\"\n\ - \ name=\"" ++ dropExtension exe_filename ++ "\"\n\ - \ type=\"win32\"/>\n\n\ - \ <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n\ - \ <security>\n\ - \ <requestedPrivileges>\n\ - \ <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n\ - \ </requestedPrivileges>\n\ - \ </security>\n\ - \ </trustInfo>\n\ - \</assembly>\n" - + manifest = manifestContents (manifestLongPathAware opts) exe_filename + traceM "XML MANIFEST" + traceM manifest writeFile manifest_filename manifest -- Windows will find the manifest file if it is named ===================================== 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 ===================================== docs/users_guide/phases.rst ===================================== @@ -1430,6 +1430,16 @@ for example). See also :ghc-flag:`-pgmwindres ⟨cmd⟩` (:ref:`replacing-phases`) and :ghc-flag:`-optwindres ⟨option⟩` (:ref:`forcing-options-through`). +.. ghc-flag:: -fwin-aware-long-paths + :shortdesc: Do not embed the manifest in the executable (Windows only) + :type: dynamic + :category: linking + + .. index:: + single: windres + + The manifest file that GHC + .. ghc-flag:: -fno-shared-implib :shortdesc: Don't generate an import library for a DLL (Windows only) :type: dynamic ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -68,6 +68,8 @@ module GHC.Unit.Database -- * Misc , mkMungePathUrl , mungeUnitInfoPaths + , writeFileAtomic + , unsafeDecodeUtf ) where @@ -86,10 +88,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 +99,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 GHC.Stack.Types (HasCallStack) +import System.OsPath +import System.OsString.Internal.Types (getOsString) +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 +321,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 +357,10 @@ lockPackageDbWith mode file = do (lockFileOpenIn ReadWriteMode) (const $ lockFileOpenIn ReadMode) where - lock = file <.> "lock" + lock = file <.> 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 +394,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 +416,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 +432,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 +453,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 +503,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 +524,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 +534,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 $ unsafeDecodeUtf 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 Exception.bracketOnError - (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (FileIO.openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> 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 +718,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 @@ -742,3 +749,8 @@ mungeUnitInfoPaths top_dir pkgroot pkg = munge_paths = map munge_path munge_urls = map munge_url (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot + +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. +-- Prefer 'decodeUtf' and gracious error handling. +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath +unsafeDecodeUtf = OsPath.Internal.so ===================================== 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 ===================================== testsuite/tests/cabal/Makefile ===================================== @@ -79,6 +79,25 @@ ghcpkg04 : @: # testpkg-1.2.3.4 and newtestpkg-2.0 are both exposed now '$(TEST_HC)' $(TEST_HC_OPTS) -package-db $(PKGCONF04) -c ghcpkg04.hs || true +PKGCONF20=local20.package.conf +LOCAL_GHC_PKG20 = '$(GHC_PKG)' --no-user-package-db + +DIR1=asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf +DIR2=zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv +DIR3=uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop +DIR4=qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer +WDIR=$(DIR1)/$(DIR2)/$(DIR3)/$(DIR4) +.PHONY: ghcpkg10 +ghcpkg10 : + @mkdir -p $(WDIR) + @rm -rf $(WDIR)/$(PKGCONF20) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) init $(WDIR)/$(PKGCONF20) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) list + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) register --force test.pkg 2>/dev/null + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg | $(STRIP_PKGROOT) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) describe testpkg-1.2.3.4 | $(STRIP_PKGROOT) + $(LOCAL_GHC_PKG20) -f $(WDIR)/$(PKGCONF20) field testpkg-1.2.3.4 import-dirs + # Test stacking of package.confs (also #2441) PKGCONF05a=local05a.package.conf PKGCONF05b=local05b.package.conf ===================================== testsuite/tests/cabal/all.T ===================================== @@ -5,6 +5,7 @@ def ignore_warnings(str): return re.sub(r'Warning:.*\n', '', str) test('ghcpkg01', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, []) +test('ghcpkg10', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, []) # Use ignore_stderr to prevent (when HADDOCK_DOCS=NO): # warning: haddock-interfaces .. doesn't exist or isn't a file ===================================== testsuite/tests/cabal/ghcpkg10.stdout ===================================== @@ -0,0 +1,50 @@ +asdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdfasdf/zxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcvzxcv/uiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiopuiop/qwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwerqwer/local20.package.conf + (no packages) +Reading package info from "test.pkg" ... done. +name: testpkg +version: 1.2.3.4 +visibility: public +id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4-XXX +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users(a)haskell.org +author: simonmar(a)microsoft.com +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +exposed: True +exposed-modules: A +hidden-modules: B C.D +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +library-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +hs-libraries: testpkg-1.2.3.4-XXX +include-dirs: /usr/local/include/testpkg "c:/Program Files/testpkg" +pkgroot: + +name: testpkg +version: 1.2.3.4 +visibility: public +id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4-XXX +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users(a)haskell.org +author: simonmar(a)microsoft.com +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +exposed: True +exposed-modules: A +hidden-modules: B C.D +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +library-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" +hs-libraries: testpkg-1.2.3.4-XXX +include-dirs: /usr/local/include/testpkg "c:/Program Files/testpkg" +pkgroot: + +import-dirs: /usr/local/lib/testpkg "c:/Program Files/testpkg" ===================================== 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) +import qualified System.File.OsPath as FileIO import Text.Printf import Prelude hiding (Foldable(..)) @@ -65,15 +72,13 @@ 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 import System.IO.Error import GHC.IO ( catchException ) import GHC.IO.Exception (IOErrorType(InappropriateType)) +import GHC.Stack.Types (HasCallStack) import Data.List ( group, sort, sortBy, nub, partition, find , intercalate, intersperse, unfoldr , isInfixOf, isSuffixOf, isPrefixOf, stripPrefix ) @@ -430,7 +435,7 @@ runit verbosity cli nonopts = do glob filename >>= print #endif ["init", filename] -> - initPackageDB filename verbosity cli + initPackageDB (unsafeEncodeUtf filename) verbosity cli ["register", filename] -> registerPackage filename verbosity cli multi_instance @@ -538,7 +543,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 +575,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 +591,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 +631,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 unsafeEncodeUtf 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 (unsafeDecodeUtf ospath)) + else pure (Left ("Settings file doesn't exist: " ++ showOsPath settingsFile)) case erel_db of - Right rel_db -> return (dir, dir </> rel_db) + Right rel_db -> return (dir, dir </> unsafeEncodeUtf 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 " ++ showOsPath 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 = unsafeEncodeUtf $ last fs top_dir <- absolutePath (takeDirectory pkg_db) return (top_dir, pkg_db) @@ -662,10 +667,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 [ unsafeEncodeUtf 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 +699,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 (</> unsafeEncodeUtf 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 +721,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 unsafeEncodeUtf 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 +738,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 $ unsafeEncodeUtf f is_db_flag _ = Nothing let flag_db_names | null db_flags = env_stack @@ -748,7 +753,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 ] + [ unsafeEncodeUtf f | FlagConfig f <- reverse my_flags ] ++ env_stack top_db = if null db_flags @@ -764,7 +769,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: " ++ showOsPath (location db)) infoLn ("flag db stack: " ++ show (map location flag_db_stack)) return (db_stack, db_to_operate_on, flag_db_stack) @@ -843,12 +848,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 + ++ showOsPath 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 +868,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 +903,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 (" ++ showOsPath path ++ ") use 'ghc-pkg init'" ++ "to create the database with the correct format." | otherwise -> ioError err @@ -914,7 +919,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: " ++ showOsPath cache) warn ("ghc will fail to read this package db. " ++ recacheAdvice) else do @@ -923,7 +928,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 " ++ showOsPath 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 +936,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: " ++ showOsPath 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: " ++ showOsPath cache) warn ("ghc will see an old view of this " ++ "package db. " ++ recacheAdvice) ignore_cache $ \file -> do @@ -947,11 +952,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 " ++ showOsPath 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 +992,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: " ++ showOsPath 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 +1018,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 +1037,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 = unsafeDecodeUtf pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = unsafeDecodeUtf 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 (unsafeDecodeUtf pkgroot) p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath (unsafeDecodeUtf 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 +1064,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 +1081,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 " ++ showOsPath path_dir direxists <- doesDirectoryExist path_dir if direxists then do @@ -1112,7 +1119,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 +1128,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 (" ++ showOsPath (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: " ++ showOsPath filename ++ " already exists") b1 <- doesFileExist filename when b1 eexist b2 <- doesDirectoryExist filename @@ -1148,7 +1155,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 +1190,7 @@ registerPackage input verbosity my_flags multi_instance f -> do when (verbosity >= Normal) $ info ("Reading package info from " ++ show f ++ " ... ") - readUTF8File f + readUtf8File $ unsafeEncodeUtf f expanded <- if expand_env_vars then expandEnvVars s force else return s @@ -1274,13 +1281,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 </> unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf" + when (verbosity > Normal) $ infoLn ("removing " ++ showOsPath 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 </> unsafeEncodeUtf (display (installedUnitId p)) <.> os "conf" + when (verbosity > Normal) $ infoLn ("writing " ++ showOsPath file) + writeUtf8File file (showInstalledPackageInfo p) do_cmd (ModifyPackage p) = do_cmd (AddPackage p) @@ -1338,13 +1345,13 @@ updateDBCache verbosity db db_stack = do warn $ " " ++ pkg when (verbosity > Normal) $ - infoLn ("writing cache " ++ filename) + infoLn ("writing cache " ++ showOsPath 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 $ showOsPath filename ++ ": you don't have permission to modify this file" else ioError e case packageDbLock db of @@ -1583,7 +1590,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 (showOsPath db_name) if null pkg_confs then hPutStrLn stdout " (no packages)" else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs)) @@ -1610,7 +1617,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 (showOsPath db_name) if null pkg_confs then hPutStrLn stdout " (no packages)" else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs)) @@ -1698,7 +1705,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 +1738,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 " ++ showOsPath (location db)) mdb where pkg_msg (Id pkgid) = displayGlobPkgId pkgid pkg_msg (IUId ipid) = display ipid @@ -1944,7 +1951,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 unsafeEncodeUtf $ libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -2011,20 +2018,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 $ + | isRelative d' = verror ForceFiles $ thisfield ++ ": " ++ 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 +2039,8 @@ checkPath url_ok is_dir warn_only thisfield d if warn_only then vwarn msg else verror ForceFiles msg + where + d' = unsafeEncodeUtf d checkDep :: PackageDBStack -> UnitId -> Validate () checkDep db_stack pkgid @@ -2050,24 +2059,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 OsPath.unsafeEncodeUtf + [ "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 +2106,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 - | extension <- ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ] - b <- liftIO $ doesFileExistOnPath files (importDirs pkg) + let files = [ unsafeEncodeUtf (ModuleName.toFilePath modl) <.> extension + | extension <- fmap os ["hi", "p_hi", "dyn_hi", "p_dyn_hi"] ] + b <- liftIO $ doesFileExistOnPath files (fmap unsafeEncodeUtf $ importDirs pkg) when (not b) $ verror ForceFiles ("cannot find any of " ++ show files) @@ -2280,12 +2290,21 @@ 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 + +showOsPath :: HasCallStack => OsPath -> FilePath +showOsPath = unsafeDecodeUtf \ No newline at end of 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/-/compare/c1ec1219fd7ba78d2dca59b2d6d35e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1ec1219fd7ba78d2dca59b2d6d35e… 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) 25 Feb '26

25 Feb '26

Jana Chadt pushed to branch wip/VeryMilkyJoe/no-mod-loc-pat at Glasgow Haskell Compiler / GHC Commits: b2c52978 by Jana Chadt at 2026-02-25T19:07:50+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,38 @@ 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 +{-# INLINE ml_hs_file #-} +ml_hs_file = fmap unsafeDecodeUtf . ml_hs_file_ospath + +ml_hi_file :: ModLocation -> FilePath +{-# INLINE ml_hi_file #-} +ml_hi_file = unsafeDecodeUtf . ml_hi_file_ospath + +ml_dyn_hi_file :: ModLocation -> FilePath +{-# INLINE ml_dyn_hi_file #-} +ml_dyn_hi_file = unsafeDecodeUtf . ml_dyn_hi_file_ospath + +ml_obj_file :: ModLocation -> FilePath +{-# INLINE ml_obj_file #-} +ml_obj_file = unsafeDecodeUtf . ml_obj_file_ospath + +ml_dyn_obj_file :: ModLocation -> FilePath +{-# INLINE ml_dyn_obj_file #-} +ml_dyn_obj_file = unsafeDecodeUtf . ml_dyn_obj_file_ospath + +ml_hie_file :: ModLocation -> FilePath +{-# INLINE ml_hie_file #-} +ml_hie_file = unsafeDecodeUtf . ml_hie_file_ospath + +ml_bytecode_file :: ModLocation -> FilePath +{-# INLINE ml_bytecode_file #-} +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/b2c529781d420016794d9529608b7e3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b2c529781d420016794d9529608b7e3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] 2 commits: Add a config flag for LibDir and derived values
by Sven Tennie (＠supersven) 25 Feb '26

25 Feb '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: a366bebe by Sven Tennie at 2026-02-25T17:11:18+00:00 Add a config flag for LibDir and derived values For cross-compilers, we have to refer to the libs of the succeeding stage. This also affects other files previously relying on top_dir in GHC. - - - - - 6c99ca77 by Sven Tennie at 2026-02-25T17:13:24+00:00 Remove prior hack to provide WASM and GHCJS deps This can now be found in the succeeding stage. - - - - - 7 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - hadrian/bindist/Makefile - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Test.hs Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -60,7 +60,7 @@ module GHC.Driver.DynFlags ( -- ** System tool settings and locations programName, projectVersion, - ghcUsagePath, ghciUsagePath, topDir, toolDir, + ghcUsagePath, ghciUsagePath, topDir, libTopDir, toolDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, @@ -1506,6 +1506,8 @@ ghciUsagePath :: DynFlags -> FilePath ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags topDir :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags +libTopDir :: DynFlags -> FilePath +libTopDir dflags = fileSettings_libTopDir $ fileSettings dflags toolDir :: DynFlags -> Maybe FilePath toolDir dflags = fileSettings_toolDir $ fileSettings dflags extraGccViaCFlags :: DynFlags -> [String] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3647,7 +3647,7 @@ compilerInfo dflags -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), - ("LibDir", topDir dflags), + ("LibDir", libTopDir dflags), -- This is always an absolute path, unlike "Relative Global Package DB" which is -- in the settings file. ("Global Package DB", globalPackageDatabasePath dflags) ===================================== compiler/GHC/Settings.hs ===================================== @@ -184,6 +184,7 @@ data FileSettings = FileSettings , fileSettings_toolDir :: Maybe FilePath -- ditto , fileSettings_topDir :: FilePath -- ditto , fileSettings_globalPackageDatabase :: FilePath + , fileSettings_libTopDir :: FilePath } ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -148,6 +148,8 @@ initSettings top_dir = do baseUnitId <- getSetting_raw "base unit-id" + lib_top_dir <- getSetting "Lib TopDir" + return $ Settings { sGhcNameVersion = GhcNameVersion { ghcNameVersion_programName = "ghc" @@ -159,6 +161,7 @@ initSettings top_dir = do , fileSettings_ghciUsagePath = ghci_usage_msg_path , fileSettings_toolDir = mtool_dir , fileSettings_topDir = top_dir + , fileSettings_libTopDir = lib_top_dir , fileSettings_globalPackageDatabase = globalpkgdb_path } ===================================== hadrian/bindist/Makefile ===================================== @@ -90,6 +90,7 @@ lib/settings : config.mk @echo ',("RTS ways", "$(GhcRTSWays)")' >> $@ @echo ',("Relative Global Package DB", "package.conf.d")' >> $@ @echo ',("base unit-id", "$(BaseUnitId)")' >> $@ + @echo ',("Lib TopDir", "$$topdir/")' >> $@ @echo "]" >> $@ lib/targets/default.target : config.mk default.target ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp)) import GHC.Platform.ArchOS import qualified Data.Set as Set import UserSettings (finalStage) +import Hadrian.Oracles.Path -- | Track this file to rebuild generated files whenever it changes. trackGenerateHs :: Expr () @@ -468,6 +469,7 @@ generateSettings :: FilePath -> Expr String generateSettings settingsFile = do ctx <- getContext stage <- getStage + isCrossStage <- expr $ crossStage stage package_db_path <- expr $ do let get_pkg_db stg = packageDbPath (PackageDbLoc stg Final) @@ -487,7 +489,13 @@ generateSettings settingsFile = do Stage2 -> pkgUnitId Stage1 base Stage3 -> pkgUnitId Stage2 base + rel_lib_topDir :: FilePath <- expr $ buildRoot <&> (-/- stageString (if isCrossStage then stage else predStage stage) -/- "lib") let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path + make_absolute rel_path = do + abs_path <- liftIO (makeAbsolute rel_path) + fixAbsolutePathOnWindows abs_path + + lib_topDir :: FilePath <- expr $ make_absolute rel_lib_topDir settings <- traverse sequence $ [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit, Context.stage = predStage stage }))) @@ -498,6 +506,7 @@ generateSettings settingsFile = do , ("RTS ways", unwords . map show . Set.toList <$> getRtsWays) , ("Relative Global Package DB", pure rel_pkg_db) , ("base unit-id", pure base_unit_id) + , ("Lib TopDir", pure lib_topDir) ] let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of ===================================== hadrian/src/Rules/Test.hs ===================================== @@ -328,19 +328,7 @@ needTestsuitePackages stg = do -- Unfortunately, we still need the liba let pkgs = filter (\(_,p) -> not $ (pkgName p `elem` ["ghc", "Cabal"]) && isStage0 stg) (libpkgs ++ exepkgs ++ [ (stg,timeout) | windowsHost ]) - need =<< mapM (uncurry pkgFile) pkgs - when isCross $ do - jsTarget <- isJsTarget (succStage stg) - wasmTarget <- isWasmTarget (succStage stg) - libPath <- stageLibPath stg - let jsDeps - | jsTarget = ["ghc-interp.js"] - | otherwise = [] - wasmDeps - | wasmTarget = ["dyld.mjs", "post-link.mjs", "prelude.mjs"] - | otherwise = [] - need $ map (libPath -/-) (jsDeps ++ wasmDeps) -- stage 1 ghc lives under stage0/bin, -- stage 2 ghc lives under stage1/bin, etc View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc30c2356eb75c729997ff6cdeee83… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc30c2356eb75c729997ff6cdeee83… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26961] 2 commits: Add Data.RealFloat
by Brandon Chinn (＠brandonchinn178) 25 Feb '26

25 Feb '26

Brandon Chinn pushed to branch wip/T26961 at Glasgow Haskell Compiler / GHC Commits: 82efc179 by Brandon Chinn at 2026-02-25T09:00:25-08:00 Add Data.RealFloat - - - - - 3f57262f by Brandon Chinn at 2026-02-25T09:00:35-08:00 Add Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - 3 changed files: - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/Data/RealFloat.hs Changes: ===================================== libraries/base/base.cabal.in ===================================== @@ -111,6 +111,7 @@ Library , Data.Monoid , Data.Ord , Data.Proxy + , Data.RealFloat , Data.STRef , Data.STRef.Strict , Data.String ===================================== libraries/base/changelog.md ===================================== @@ -9,6 +9,8 @@ * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) + * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- +-- Module : Data.RealFloat +-- Copyright : (c) The University of Glasgow 2026 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries(a)haskell.org +-- Stability : stable +-- Portability : portable +-- + +module Data.RealFloat ( + RealFloat (..), + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, +) where + +import GHC.Internal.Float + +pattern Infinity :: (RealFloat a) => a +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Provided for convenience. Could also use the following instead: +-- * Pattern matching: @(negate -> Infinity)@ +-- * Expressions: @-Infinity@ +pattern NegInfinity :: (RealFloat a) => a +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +pattern NaN :: (RealFloat a) => a +pattern NaN <- (isNaN -> True) where NaN = 0/0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/28a74652d9011accb4902951ed82da… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/28a74652d9011accb4902951ed82da… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26961] 2 commits: Add Data.RealFloat
by Brandon Chinn (＠brandonchinn178) 25 Feb '26

25 Feb '26

Brandon Chinn pushed to branch wip/T26961 at Glasgow Haskell Compiler / GHC Commits: 8bfdd5a8 by Brandon Chinn at 2026-02-25T08:59:16-08:00 Add Data.RealFloat - - - - - 28a74652 by Brandon Chinn at 2026-02-25T08:59:26-08:00 Add Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - 3 changed files: - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/Data/RealFloat.hs Changes: ===================================== libraries/base/base.cabal.in ===================================== @@ -111,6 +111,7 @@ Library , Data.Monoid , Data.Ord , Data.Proxy + , Data.RealFloat , Data.STRef , Data.STRef.Strict , Data.String ===================================== libraries/base/changelog.md ===================================== @@ -9,6 +9,8 @@ * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) + * Add new `Data.RealFloat` module re-exporting `RealFloat` operations from `GHC.Float` + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- +-- Module : Data.RealFloat +-- Copyright : (c) The University of Glasgow 2026 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries(a)haskell.org +-- Stability : stable +-- Portability : portable +-- + +module Data.RealFloat ( + RealFloat (..), + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, +) where + +import GHC.Internal.Float + +pattern Infinity :: (RealFloat a) => a +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Provided for convenience. Could also use the following instead: +-- * Pattern matching: @(negate -> Infinity)@ +-- * Expressions: @-Infinity@ +pattern NegInfinity :: (RealFloat a) => a +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +pattern NaN :: (RealFloat a) => a +pattern NaN <- (isNaN -> True) where NaN = 0/0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/12e6303464af5543e81e1950d8a920… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/12e6303464af5543e81e1950d8a920… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26961] Add Infinity/NegInfinity/NaN pattern synonyms (#26961)
by Brandon Chinn (＠brandonchinn178) 25 Feb '26

25 Feb '26

Brandon Chinn pushed to branch wip/T26961 at Glasgow Haskell Compiler / GHC Commits: 12e63034 by Brandon Chinn at 2026-02-25T08:56:54-08:00 Add Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - 2 changed files: - libraries/base/changelog.md - libraries/base/src/Data/RealFloat.hs Changes: ===================================== libraries/base/changelog.md ===================================== @@ -10,6 +10,7 @@ * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) * Add new `Data.RealFloat` module re-exporting `RealFloat` operations from `GHC.Float` + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -1,4 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} -- | -- @@ -26,6 +28,25 @@ module Data.RealFloat ( integerToBinaryFloat', fromRat, fromRat', + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, ) where import GHC.Internal.Float + +pattern Infinity :: (RealFloat a) => a +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Provided for convenience. Could also use the following instead: +-- * Pattern matching: @(negate -> Infinity)@ +-- * Expressions: @-Infinity@ +pattern NegInfinity :: (RealFloat a) => a +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +pattern NaN :: (RealFloat a) => a +pattern NaN <- (isNaN -> True) where NaN = 0/0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12e6303464af5543e81e1950d8a9208… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/12e6303464af5543e81e1950d8a9208… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26961] Add Infinity/NegInfinity/NaN pattern synonyms (#26961)
by Brandon Chinn (＠brandonchinn178) 25 Feb '26

25 Feb '26

Brandon Chinn pushed to branch wip/T26961 at Glasgow Haskell Compiler / GHC Commits: 2c7d6e17 by Brandon Chinn at 2026-02-25T08:53:33-08:00 Add Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - 2 changed files: - libraries/base/changelog.md - libraries/base/src/Data/RealFloat.hs Changes: ===================================== libraries/base/changelog.md ===================================== @@ -10,6 +10,7 @@ * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) * Add new `Data.RealFloat` module re-exporting `RealFloat` operations from `GHC.Float` + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -1,4 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} -- | -- @@ -26,6 +28,23 @@ module Data.RealFloat ( integerToBinaryFloat', fromRat, fromRat', + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, ) where import GHC.Internal.Float + +pattern Infinity :: (RealFloat a) => a +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Only necessary for pattern matching; expressions could also use @-Infinity@. +pattern NegInfinity :: (RealFloat a) => a +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +pattern NaN :: (RealFloat a) => a +pattern NaN <- (isNaN -> True) where NaN = 0/0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c7d6e17a46266678ba71662a56b5cd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c7d6e17a46266678ba71662a56b5cd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26961] Add Infinity/NegInfinity/NaN pattern synonyms (#26961)
by Brandon Chinn (＠brandonchinn178) 25 Feb '26

25 Feb '26

Brandon Chinn pushed to branch wip/T26961 at Glasgow Haskell Compiler / GHC Commits: f6e52562 by Brandon Chinn at 2026-02-25T08:28:24-08:00 Add Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - 2 changed files: - libraries/base/changelog.md - libraries/base/src/Data/RealFloat.hs Changes: ===================================== libraries/base/changelog.md ===================================== @@ -10,6 +10,7 @@ * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) * Add new `Data.RealFloat` module re-exporting `RealFloat` operations from `GHC.Float` + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -1,4 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} -- | -- @@ -26,6 +28,20 @@ module Data.RealFloat ( integerToBinaryFloat', fromRat, fromRat', + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, ) where import GHC.Internal.Float + +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Only necessary for pattern matching; expressions should use @-Infinity@. +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +pattern NaN <- (isNaN -> True) where NaN = 0/0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f6e525620d21b989d0fbd75c5cccf0d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f6e525620d21b989d0fbd75c5cccf0d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26961
by Brandon Chinn (＠brandonchinn178) 25 Feb '26

25 Feb '26

Brandon Chinn pushed new branch wip/T26961 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26961 You're receiving this email because of your account on gitlab.haskell.org.

1 0