- ghc-commits - Haskell.org

[Git][ghc/ghc][master] wasm: fix `Illegal foreign declaration` failure when ghci loads modules with JSFFI exports
by Marge Bot (＠marge-bot) 09 Mar '26

09 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0bfd29c3 by Cheng Shao at 2026-03-09T04:54:46-04:00 wasm: fix `Illegal foreign declaration` failure when ghci loads modules with JSFFI exports This patch fixes a wasm ghci error when loading modules with JSFFI exports; the `backendValidityOfCExport` check in `tcCheckFEType` should only makes sense and should be performed when not checking the JavaScript calling convention; otherwise, when the calling convention is JavaScript, the codegen logic should be trusted to backends that actually make use of it. Fixes #26998. - - - - - 3 changed files: - compiler/GHC/Tc/Gen/Foreign.hs - + testsuite/tests/ghci-wasm/T26998.hs - testsuite/tests/ghci-wasm/all.T Changes: ===================================== compiler/GHC/Tc/Gen/Foreign.hs ===================================== @@ -449,8 +449,9 @@ tcFExport d = pprPanic "tcFExport" (ppr d) tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc) tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic str cconv))) = do - checkCg (Left edecl) backendValidityOfCExport - when (cconv /= JavaScriptCallConv) $ checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) + when (cconv /= JavaScriptCallConv) $ do + checkCg (Left edecl) backendValidityOfCExport + checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) cconv' <- checkCConv (Left edecl) cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty ===================================== testsuite/tests/ghci-wasm/T26998.hs ===================================== @@ -0,0 +1,4 @@ +main :: IO () +main = pure () + +foreign export javascript "my_main" main :: IO () ===================================== testsuite/tests/ghci-wasm/all.T ===================================== @@ -10,3 +10,5 @@ test('T26430', [ extra_hc_opts('-L. -lT26430B')] , compile_and_run, [''] ) + +test('T26998', [], compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0bfd29c3d233da282e96e89e5398cfd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0bfd29c3d233da282e96e89e5398cfd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] compiler: fix redundant import in GHC.StgToJS.Object
by Marge Bot (＠marge-bot) 09 Mar '26

09 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d7fe9671 by Cheng Shao at 2026-03-09T04:54:04-04:00 compiler: fix redundant import in GHC.StgToJS.Object This patch fixes a redundant import in GHC.StgToJS.Object that causes a build failure when compiling head from 9.14 with validate flavours. Fixes #26991. - - - - - 1 changed file: - compiler/GHC/StgToJS/Object.hs Changes: ===================================== compiler/GHC/StgToJS/Object.hs ===================================== @@ -72,7 +72,6 @@ import Data.List (sortOn) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as M -import Data.Word import Data.Semigroup import System.IO View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d7fe967111ba12d1d50684f089853d0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d7fe967111ba12d1d50684f089853d0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] T18832: fix Windows CI failure by dropping removeDirectoryRecursive
by Marge Bot (＠marge-bot) 09 Mar '26

09 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 91df4c82 by Sylvain Henry at 2026-03-09T04:53:20-04:00 T18832: fix Windows CI failure by dropping removeDirectoryRecursive On Windows, open file handles prevent deletion. After killThread, the closer thread may not have called hClose yet, causing removeDirectoryRecursive to fail with "permission denied". The test harness cleans up the run directory anyway, so the call is redundant. - - - - - 1 changed file: - libraries/base/tests/IO/T18832.hs Changes: ===================================== libraries/base/tests/IO/T18832.hs ===================================== @@ -41,7 +41,6 @@ test dir' = do -- cleanup mapM_ killThread [interrupter, deleter, closer] - removeDirectoryRecursive dir either throwIO (const $ putStrLn "No failures observed - success") result View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91df4c8207cbfa916e85580a1bd784d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91df4c8207cbfa916e85580a1bd784d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Remove in-package dependencies on `GHC.Internal.System.IO`
by Marge Bot (＠marge-bot) 09 Mar '26

09 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f4e8fec2 by Wolfgang Jeltsch at 2026-03-09T04:52:01-04:00 Remove in-package dependencies on `GHC.Internal.System.IO` This contribution eliminates all dependencies on `GHC.Internal.System.IO` from within `ghc-internal`. It comprises the following changes: * Make `GHC.Internal.Fingerprint` independent of I/O support * Tighten the dependencies of `GHC.Internal.Data.Version` * Tighten the dependencies of `GHC.Internal.TH.Monad` * Tighten the dependencies of `GHCi.Helpers` * Move some code that needs `System.IO` to `template-haskell` * Move the `GHC.ResponseFile` implementation into `base` * Move the `System.Exit` implementation into `base` * Move the `System.IO.OS` implementation into `base` Metric Decrease: size_hello_artifact size_hello_artifact_gzip size_hello_unicode size_hello_unicode_gzip - - - - - 15 changed files: - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/ResponseFile.hs - libraries/base/src/System/Exit.hs - libraries/base/src/System/IO/OS.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs - libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs - − libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - − libraries/ghc-internal/src/GHC/Internal/System/Exit.hs - − libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/ffi/should_compile/all.T Changes: ===================================== libraries/base/src/GHC/Fingerprint.hs ===================================== @@ -9,3 +9,45 @@ module GHC.Fingerprint ( ) where import GHC.Internal.Fingerprint + +import Data.Function (($)) +import Control.Monad (return, when) +import Data.Bool (not, (&&)) +import Data.List ((++)) +import Data.Maybe (Maybe (Nothing, Just)) +import Data.Int (Int) +import Data.Word (Word8) +import Data.Eq ((/=)) +import Text.Show (show) +import System.IO + ( + IO, + FilePath, + IOMode (ReadMode), + withBinaryFile, + hGetBuf, + hIsEOF + ) +import Foreign.Ptr (Ptr) +import GHC.Err (errorWithoutStackTrace) + +-- | Computes the hash of a given file. +-- This function runs in constant memory. +-- +-- @since base-4.7.0.0 +getFileHash :: FilePath -> IO Fingerprint +getFileHash path = withBinaryFile path ReadMode $ \ hdl -> + let + readChunk :: Ptr Word8 -> Int -> IO (Maybe Int) + readChunk bufferPtr bufferSize = do + chunkSize <- hGetBuf hdl bufferPtr bufferSize + isFinished <- hIsEOF hdl + when (chunkSize /= bufferSize && not isFinished) + ( + errorWithoutStackTrace $ + "GHC.Fingerprint.getFileHash: could only read " ++ + show chunkSize ++ + " bytes, but more are available" + ) + return (if isFinished then Just chunkSize else Nothing) + in fingerprintBufferedStream readChunk ===================================== libraries/base/src/GHC/ResponseFile.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Safe #-} -- | @@ -19,4 +20,145 @@ module GHC.ResponseFile ( expandResponse ) where -import GHC.Internal.ResponseFile +import Control.Monad (return, (>>=), mapM) +import Control.Exception (IOException, catch) +import Data.Function (($), (.)) +import Data.Bool (Bool (False, True), otherwise, not, (||)) +import Data.Char (Char, isSpace) +import Data.List ((++), map, filter, concat, reverse) +import Data.String (String, unlines) +import Data.Functor (fmap) +import Data.Foldable (null, foldl') +import Data.Eq ((==)) +import Text.Show (show) +import System.Environment (getArgs) +import System.IO (IO, hPutStrLn, readFile, stderr) +import System.Exit (exitFailure) + +{-| +Like 'getArgs', but can also read arguments supplied via response files. + + +For example, consider a program @foo@: + +@ +main :: IO () +main = do + args <- getArgsWithResponseFiles + putStrLn (show args) +@ + + +And a response file @args.txt@: + +@ +--one 1 +--\'two\' 2 +--"three" 3 +@ + +Then the result of invoking @foo@ with @args.txt@ is: + +> > ./foo @args.txt +> ["--one","1","--two","2","--three","3"] + +-} +getArgsWithResponseFiles :: IO [String] +getArgsWithResponseFiles = getArgs >>= expandResponse + +-- | Given a string of concatenated strings, separate each by removing +-- a layer of /quoting/ and\/or /escaping/ of certain characters. +-- +-- These characters are: any whitespace, single quote, double quote, +-- and the backslash character. The backslash character always +-- escapes (i.e., passes through without further consideration) the +-- character which follows. Characters can also be escaped in blocks +-- by quoting (i.e., surrounding the blocks with matching pairs of +-- either single- or double-quotes which are not themselves escaped). +-- +-- Any whitespace which appears outside of either of the quoting and +-- escaping mechanisms, is interpreted as having been added by this +-- special concatenation process to designate where the boundaries +-- are between the original, un-concatenated list of strings. These +-- added whitespace characters are removed from the output. +-- +-- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] +unescapeArgs :: String -> [String] +unescapeArgs = filter (not . null) . unescape + +-- | Given a list of strings, concatenate them into a single string +-- with escaping of certain characters, and the addition of a newline +-- between each string. The escaping is done by adding a single +-- backslash character before any whitespace, single quote, double +-- quote, or backslash character, so this escaping character must be +-- removed. Unescaped whitespace (in this case, newline) is part +-- of this "transport" format to indicate the end of the previous +-- string and the start of a new string. +-- +-- While 'unescapeArgs' allows using quoting (i.e., convenient +-- escaping of many characters) by having matching sets of single- or +-- double-quotes,'escapeArgs' does not use the quoting mechanism, +-- and thus will always escape any whitespace, quotes, and +-- backslashes. +-- +-- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +-- | Arguments which look like @\@foo@ will be replaced with the +-- contents of file @foo@. A gcc-like syntax for response files arguments +-- is expected. This must re-constitute the argument list by doing an +-- inverse of the escaping mechanism done by the calling-program side. +-- +-- We quit if the file is not found or reading somehow fails. +-- (A convenience routine for haddock or possibly other clients) +expandResponse :: [String] -> IO [String] +expandResponse = fmap concat . mapM expand + where + expand :: String -> IO [String] + expand ('@':f) = readFileExc f >>= return . unescapeArgs + expand x = return [x] + + readFileExc f = + readFile f `catch` \(e :: IOException) -> do + hPutStrLn stderr $ "Error while expanding response file: " ++ show e + exitFailure + +data Quoting = NoneQ | SngQ | DblQ + +unescape :: String -> [String] +unescape args = reverse . map reverse $ go args NoneQ False [] [] + where + -- n.b., the order of these cases matters; these are cribbed from gcc + -- case 1: end of input + go [] _q _bs a as = a:as + -- case 2: back-slash escape in progress + go (c:cs) q True a as = go cs q False (c:a) as + -- case 3: no back-slash escape in progress, but got a back-slash + go (c:cs) q False a as + | '\\' == c = go cs q True a as + -- case 4: single-quote escaping in progress + go (c:cs) SngQ False a as + | '\'' == c = go cs NoneQ False a as + | otherwise = go cs SngQ False (c:a) as + -- case 5: double-quote escaping in progress + go (c:cs) DblQ False a as + | '"' == c = go cs NoneQ False a as + | otherwise = go cs DblQ False (c:a) as + -- case 6: no escaping is in progress + go (c:cs) NoneQ False a as + | isSpace c = go cs NoneQ False [] (a:as) + | '\'' == c = go cs SngQ False a as + | '"' == c = go cs DblQ False a as + | otherwise = go cs NoneQ False (c:a) as + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs ===================================== libraries/base/src/System/Exit.hs ===================================== @@ -21,4 +21,67 @@ module System.Exit die ) where -import GHC.Internal.System.Exit \ No newline at end of file +import GHC.IO.Exception + ( + IOErrorType (InvalidArgument), + IOException (IOError), + ExitCode (ExitSuccess, ExitFailure) + ) +import Control.Monad ((>>)) +import Control.Exception (throwIO, ioError) +import Data.Bool (otherwise) +import Data.Maybe (Maybe (Nothing)) +import Data.String (String) +import Data.Eq ((/=)) +import System.IO (IO, hPutStrLn, stderr) + +-- --------------------------------------------------------------------------- +-- exitWith + +-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. +-- Normally this terminates the program, returning @code@ to the +-- program's caller. +-- +-- On program termination, the standard 'Handle's 'stdout' and +-- 'stderr' are flushed automatically; any other buffered 'Handle's +-- need to be flushed manually, otherwise the buffered data will be +-- discarded. +-- +-- A program that fails in any other way is treated as if it had +-- called 'exitFailure'. +-- A program that terminates successfully without calling 'exitWith' +-- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. +-- +-- As an 'ExitCode' is an 'Control.Exception.Exception', it can be +-- caught using the functions of "Control.Exception". This means that +-- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from +-- "Control.Exception") are also executed properly on 'exitWith'. +-- +-- Note: in GHC, 'exitWith' should be called from the main program +-- thread in order to exit the process. When called from another +-- thread, 'exitWith' will throw an 'ExitCode' as normal, but the +-- exception will not cause the process itself to exit. +-- +exitWith :: ExitCode -> IO a +exitWith ExitSuccess = throwIO ExitSuccess +exitWith code@(ExitFailure n) + | n /= 0 = throwIO code + | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) + +-- | The computation 'exitFailure' is equivalent to +-- 'exitWith' @(@'ExitFailure' /exitfail/@)@, +-- where /exitfail/ is implementation-dependent. +exitFailure :: IO a +exitFailure = exitWith (ExitFailure 1) + +-- | The computation 'exitSuccess' is equivalent to +-- 'exitWith' 'ExitSuccess', It terminates the program +-- successfully. +exitSuccess :: IO a +exitSuccess = exitWith ExitSuccess + +-- | Write given error message to `stderr` and terminate with `exitFailure`. +-- +-- @since base-4.8.0.0 +die :: String -> IO a +die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/base/src/System/IO/OS.hs ===================================== @@ -1,4 +1,6 @@ {-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-| This module bridges between Haskell handles and underlying operating-system @@ -21,17 +23,293 @@ module System.IO.OS ) where -import GHC.Internal.System.IO.OS +import Control.Monad (return) +import Control.Concurrent.MVar (MVar) +import Control.Exception (mask) +import Data.Function (const, (.), ($)) +import Data.Functor (fmap) +import Data.Maybe (Maybe (Nothing), maybe) +#if defined(mingw32_HOST_OS) +import Data.Bool (otherwise) +import Data.Maybe (Maybe (Just)) +#endif +import Data.List ((++)) +import Data.String (String) +import Data.Typeable (Typeable, cast) +import System.IO (IO) +import GHC.IO.FD (fdFD) +#if defined(mingw32_HOST_OS) +import GHC.IO.Windows.Handle ( - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw + NativeHandle, + ConsoleHandle, + IoHandle, + toHANDLE ) +#endif +import GHC.IO.Handle.Types + ( + Handle (FileHandle, DuplexHandle), + Handle__ (Handle__, haDevice) + ) +import GHC.IO.Handle.Internals (withHandle_', flushBuffer) +import GHC.IO.Exception + ( + IOErrorType (InappropriateType), + IOException (IOError), + ioException + ) +import Foreign.Ptr (Ptr) +import Foreign.C.Types (CInt) + +-- * Obtaining POSIX file descriptors and Windows handles + +{-| + Executes a user-provided action on an operating-system handle that underlies + a Haskell handle. Before the user-provided action is run, user-defined + preparation based on the handle state that contains the operating-system + handle is performed. While the user-provided action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withOSHandle :: String + -- ^ The name of the overall operation + -> (Handle -> MVar Handle__) + {-^ + Obtaining of the handle state variable that holds the + operating-system handle + -} + -> (forall d. Typeable d => d -> IO a) + -- ^ Conversion of a device into an operating-system handle + -> (Handle__ -> IO ()) + -- ^ The preparation + -> Handle + -- ^ The Haskell handle to use + -> (a -> IO r) + -- ^ The action to execute on the operating-system handle + -> IO r +withOSHandle opName handleStateVar getOSHandle prepare handle act + = mask $ \ withOriginalMaskingState -> + withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do + osHandle <- getOSHandle dev + prepare handleState + withOriginalMaskingState $ act osHandle + where + + withHandleState = withHandle_' opName handle (handleStateVar handle) +{- + The 'withHandle_'' operation, which we use here, already performs masking. + Still, we have to employ 'mask', in order do obtain the operation that + restores the original masking state. The user-provided action should be + executed with this original masking state, as there is no inherent reason to + generally perform it with masking in place. The masking that 'withHandle_'' + performs is only for safely accessing handle state and thus constitutes an + implementation detail; it has nothing to do with the user-provided action. +-} +{- + The order of actions in 'withOSHandle' is such that any exception from + 'getOSHandle' is thrown before the user-defined preparation is performed. +-} + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for reading if the handle uses different state + variables for reading and writing. +-} +handleStateVarReadingBiased :: Handle -> MVar Handle__ +handleStateVarReadingBiased (FileHandle _ var) = var +handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar + +{-| + Obtains the handle state variable that underlies a handle or specifically + the handle state variable for writing if the handle uses different state + variables for reading and writing. +-} +handleStateVarWritingBiased :: Handle -> MVar Handle__ +handleStateVarWritingBiased (FileHandle _ var) = var +handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar + +{-| + Yields the result of another operation if that operation succeeded, and + otherwise throws an exception that signals that the other operation failed + because some Haskell handle does not use an operating-system handle of a + required type. +-} +requiringOSHandleOfType :: String + -- ^ The name of the operating-system handle type + -> Maybe a + {-^ + The result of the other operation if it succeeded + -} + -> IO a +requiringOSHandleOfType osHandleTypeName + = maybe (ioException osHandleOfTypeRequired) return + where + + osHandleOfTypeRequired :: IOException + osHandleOfTypeRequired + = IOError Nothing + InappropriateType + "" + ("handle does not use " ++ osHandleTypeName ++ "s") + Nothing + Nothing + +{-| + Obtains the POSIX file descriptor of a device if the device contains one, + and throws an exception otherwise. +-} +getFileDescriptor :: Typeable d => d -> IO CInt +getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . + fmap fdFD . cast + +{-| + Obtains the Windows handle of a device if the device contains one, and + throws an exception otherwise. +-} +getWindowsHandle :: Typeable d => d -> IO (Ptr ()) +getWindowsHandle = requiringOSHandleOfType "Windows handle" . + toMaybeWindowsHandle + where + + toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) +#if defined(mingw32_HOST_OS) + toMaybeWindowsHandle dev + | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) + = Just (toHANDLE nativeHandle) + | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) + = Just (toHANDLE consoleHandle) + | otherwise + = Nothing + {- + This is inspired by the implementation of + 'System.Win32.Types.withHandleToHANDLENative'. + -} +#else + toMaybeWindowsHandle _ = Nothing +#endif + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for reading if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" + handleStateVarReadingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the POSIX file descriptor that underlies + a handle or specifically on the POSIX file descriptor for writing if the + handle uses different file descriptors for reading and writing. The + Haskell-managed buffers related to the file descriptor are flushed before + the user-provided action is run. While this action is executed, further + operations on the handle are blocked to a degree that interference with this + action is prevented. + + If the handle does not use POSIX file descriptors, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" + handleStateVarWritingBiased + getFileDescriptor + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for reading if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" + handleStateVarReadingBiased + getWindowsHandle + flushBuffer + +{-| + Executes a user-provided action on the Windows handle that underlies a + Haskell handle or specifically on the Windows handle for writing if the + Haskell handle uses different Windows handles for reading and writing. The + Haskell-managed buffers related to the Windows handle are flushed before the + user-provided action is run. While this action is executed, further + operations on the Haskell handle are blocked to a degree that interference + with this action is prevented. + + If the Haskell handle does not use Windows handles, an exception is thrown. + + See [below](#with-ref-caveats) for caveats regarding this operation. +-} +withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" + handleStateVarWritingBiased + getWindowsHandle + flushBuffer + +{-| + Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorReadingBiasedRaw + = withOSHandle "withFileDescriptorReadingBiasedRaw" + handleStateVarReadingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r +withFileDescriptorWritingBiasedRaw + = withOSHandle "withFileDescriptorWritingBiasedRaw" + handleStateVarWritingBiased + getFileDescriptor + (const $ return ()) + +{-| + Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleReadingBiasedRaw + = withOSHandle "withWindowsHandleReadingBiasedRaw" + handleStateVarReadingBiased + getWindowsHandle + (const $ return ()) + +{-| + Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers + are not flushed. +-} +withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r +withWindowsHandleWritingBiasedRaw + = withOSHandle "withWindowsHandleWritingBiasedRaw" + handleStateVarWritingBiased + getWindowsHandle + (const $ return ()) -- ** Caveats ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -1,17 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GHCForeignImportPrim #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} --- Late cost centres introduce a thunk in the asBox function, which leads to --- an additional wrapper being added to any value placed inside a box. --- This can be removed once our boot compiler is no longer affected by #25212 -{-# OPTIONS_GHC -fno-prof-late #-} -{-# LANGUAGE NamedFieldPuns #-} - module GHC.Exts.Heap.Closures ( -- * Closures Closure ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -284,7 +284,6 @@ Library GHC.Internal.Read GHC.Internal.Real GHC.Internal.Records - GHC.Internal.ResponseFile GHC.Internal.RTS.Flags GHC.Internal.RTS.Flags.Test GHC.Internal.ST @@ -324,10 +323,8 @@ Library GHC.Internal.Numeric.Natural GHC.Internal.System.Environment GHC.Internal.System.Environment.Blank - GHC.Internal.System.Exit GHC.Internal.System.IO GHC.Internal.System.IO.Error - GHC.Internal.System.IO.OS GHC.Internal.System.Mem GHC.Internal.System.Mem.StableName GHC.Internal.System.Posix.Internals ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Version.hs ===================================== @@ -41,8 +41,7 @@ import GHC.Internal.Data.Eq import GHC.Internal.Int ( Int ) import GHC.Internal.Data.List ( map, sort, concat, concatMap, intersperse, (++) ) import GHC.Internal.Data.Ord -import GHC.Internal.Data.String ( String ) -import GHC.Internal.Base ( Applicative(..), (&&) ) +import GHC.Internal.Base ( Applicative(..), (&&), String ) import GHC.Internal.Generics import GHC.Internal.Unicode ( isDigit, isAlphaNum ) import GHC.Internal.Read ===================================== libraries/ghc-internal/src/GHC/Internal/Fingerprint.hs ===================================== @@ -16,23 +16,22 @@ module GHC.Internal.Fingerprint ( fingerprintData, fingerprintString, fingerprintFingerprints, - getFileHash + fingerprintBufferedStream ) where import GHC.Internal.IO import GHC.Internal.Base import GHC.Internal.Bits import GHC.Internal.Num +import GHC.Internal.Data.Maybe import GHC.Internal.List import GHC.Internal.Real import GHC.Internal.Word -import GHC.Internal.Show import GHC.Internal.Ptr import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Marshal.Alloc import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Foreign.Storable -import GHC.Internal.System.IO import GHC.Internal.Fingerprint.Type @@ -71,41 +70,27 @@ fingerprintString str = unsafeDupablePerformIO $ fromIntegral (w32 `shiftR` 8), fromIntegral w32] --- | Computes the hash of a given file. --- This function loops over the handle, running in constant memory. --- --- @since base-4.7.0.0 -getFileHash :: FilePath -> IO Fingerprint -getFileHash path = withBinaryFile path ReadMode $ \h -> +-- | Reads data in chunks and computes its hash. +-- This function runs in constant memory. +fingerprintBufferedStream :: (Ptr Word8 -> Int -> IO (Maybe Int)) + -> IO Fingerprint +fingerprintBufferedStream readChunk = allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do c_MD5Init pctxt - - processChunks h (\buf size -> c_MD5Update pctxt buf (fromIntegral size)) - + allocaBytes _BUFSIZE $ \arrPtr -> + let loop = do + maybeRemainderSize <- readChunk arrPtr _BUFSIZE + c_MD5Update pctxt + arrPtr + (fromIntegral (fromMaybe _BUFSIZE maybeRemainderSize)) + when (isNothing maybeRemainderSize) loop + in loop allocaBytes 16 $ \pdigest -> do c_MD5Final pdigest pctxt peek (castPtr pdigest :: Ptr Fingerprint) - where _BUFSIZE = 4096 - -- Loop over _BUFSIZE sized chunks read from the handle, - -- passing the callback a block of bytes and its size. - processChunks :: Handle -> (Ptr Word8 -> Int -> IO ()) -> IO () - processChunks h f = allocaBytes _BUFSIZE $ \arrPtr -> - - let loop = do - count <- hGetBuf h arrPtr _BUFSIZE - eof <- hIsEOF h - when (count /= _BUFSIZE && not eof) $ errorWithoutStackTrace $ - "GHC.Internal.Fingerprint.getFileHash: only read " ++ show count ++ " bytes" - - f arrPtr count - - when (not eof) loop - - in loop - data MD5Context foreign import ccall unsafe "__hsbase_MD5Init" ===================================== libraries/ghc-internal/src/GHC/Internal/GHCi/Helpers.hs ===================================== @@ -24,9 +24,10 @@ module GHC.Internal.GHCi.Helpers , evalWrapper ) where -import GHC.Internal.Base -import GHC.Internal.System.IO -import GHC.Internal.System.Environment +import GHC.Internal.Base (String, IO) +import GHC.Internal.IO.Handle (BufferMode (NoBuffering), hSetBuffering, hFlush) +import GHC.Internal.IO.StdHandles (stdin, stdout, stderr) +import GHC.Internal.System.Environment (withProgName, withArgs) disableBuffering :: IO () disableBuffering = do ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs deleted ===================================== @@ -1,163 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.ResponseFile --- License : BSD-style (see the file LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : internal --- Portability : portable --- --- GCC style response files. --- --- @since base-4.12.0.0 ----------------------------------------------------------------------------- - --- Migrated from Haddock. - -module GHC.Internal.ResponseFile ( - getArgsWithResponseFiles, - unescapeArgs, - escapeArgs, escapeArg, - expandResponse - ) where - -import GHC.Internal.Control.Exception -import GHC.Internal.Data.Foldable (Foldable(..)) -import GHC.Internal.Base -import GHC.Internal.Unicode (isSpace) -import GHC.Internal.Data.List (filter, unlines, concat, reverse) -import GHC.Internal.Text.Show (show) -import GHC.Internal.System.Environment (getArgs) -import GHC.Internal.System.Exit (exitFailure) -import GHC.Internal.System.IO - -{-| -Like 'getArgs', but can also read arguments supplied via response files. - - -For example, consider a program @foo@: - -@ -main :: IO () -main = do - args <- getArgsWithResponseFiles - putStrLn (show args) -@ - - -And a response file @args.txt@: - -@ ---one 1 ---\'two\' 2 ---"three" 3 -@ - -Then the result of invoking @foo@ with @args.txt@ is: - -> > ./foo @args.txt -> ["--one","1","--two","2","--three","3"] - --} -getArgsWithResponseFiles :: IO [String] -getArgsWithResponseFiles = getArgs >>= expandResponse - --- | Given a string of concatenated strings, separate each by removing --- a layer of /quoting/ and\/or /escaping/ of certain characters. --- --- These characters are: any whitespace, single quote, double quote, --- and the backslash character. The backslash character always --- escapes (i.e., passes through without further consideration) the --- character which follows. Characters can also be escaped in blocks --- by quoting (i.e., surrounding the blocks with matching pairs of --- either single- or double-quotes which are not themselves escaped). --- --- Any whitespace which appears outside of either of the quoting and --- escaping mechanisms, is interpreted as having been added by this --- special concatenation process to designate where the boundaries --- are between the original, un-concatenated list of strings. These --- added whitespace characters are removed from the output. --- --- > unescapeArgs "hello\\ \\\"world\\\"\n" == ["hello \"world\""] -unescapeArgs :: String -> [String] -unescapeArgs = filter (not . null) . unescape - --- | Given a list of strings, concatenate them into a single string --- with escaping of certain characters, and the addition of a newline --- between each string. The escaping is done by adding a single --- backslash character before any whitespace, single quote, double --- quote, or backslash character, so this escaping character must be --- removed. Unescaped whitespace (in this case, newline) is part --- of this "transport" format to indicate the end of the previous --- string and the start of a new string. --- --- While 'unescapeArgs' allows using quoting (i.e., convenient --- escaping of many characters) by having matching sets of single- or --- double-quotes,'escapeArgs' does not use the quoting mechanism, --- and thus will always escape any whitespace, quotes, and --- backslashes. --- --- > escapeArgs ["hello \"world\""] == "hello\\ \\\"world\\\"\n" -escapeArgs :: [String] -> String -escapeArgs = unlines . map escapeArg - --- | Arguments which look like @\@foo@ will be replaced with the --- contents of file @foo@. A gcc-like syntax for response files arguments --- is expected. This must re-constitute the argument list by doing an --- inverse of the escaping mechanism done by the calling-program side. --- --- We quit if the file is not found or reading somehow fails. --- (A convenience routine for haddock or possibly other clients) -expandResponse :: [String] -> IO [String] -expandResponse = fmap concat . mapM expand - where - expand :: String -> IO [String] - expand ('@':f) = readFileExc f >>= return . unescapeArgs - expand x = return [x] - - readFileExc f = - readFile f `catch` \(e :: IOException) -> do - hPutStrLn stderr $ "Error while expanding response file: " ++ show e - exitFailure - -data Quoting = NoneQ | SngQ | DblQ - -unescape :: String -> [String] -unescape args = reverse . map reverse $ go args NoneQ False [] [] - where - -- n.b., the order of these cases matters; these are cribbed from gcc - -- case 1: end of input - go [] _q _bs a as = a:as - -- case 2: back-slash escape in progress - go (c:cs) q True a as = go cs q False (c:a) as - -- case 3: no back-slash escape in progress, but got a back-slash - go (c:cs) q False a as - | '\\' == c = go cs q True a as - -- case 4: single-quote escaping in progress - go (c:cs) SngQ False a as - | '\'' == c = go cs NoneQ False a as - | otherwise = go cs SngQ False (c:a) as - -- case 5: double-quote escaping in progress - go (c:cs) DblQ False a as - | '"' == c = go cs NoneQ False a as - | otherwise = go cs DblQ False (c:a) as - -- case 6: no escaping is in progress - go (c:cs) NoneQ False a as - | isSpace c = go cs NoneQ False [] (a:as) - | '\'' == c = go cs SngQ False a as - | '"' == c = go cs DblQ False a as - | otherwise = go cs NoneQ False (c:a) as - -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs ===================================== libraries/ghc-internal/src/GHC/Internal/System/Exit.hs deleted ===================================== @@ -1,81 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.System.Exit --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : provisional --- Portability : portable --- --- Exiting the program. --- ------------------------------------------------------------------------------ - -module GHC.Internal.System.Exit - ( - ExitCode(ExitSuccess,ExitFailure) - , exitWith - , exitFailure - , exitSuccess - , die - ) where - -import GHC.Internal.System.IO - -import GHC.Internal.Base -import GHC.Internal.IO -import GHC.Internal.IO.Exception - --- --------------------------------------------------------------------------- --- exitWith - --- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. --- Normally this terminates the program, returning @code@ to the --- program's caller. --- --- On program termination, the standard 'Handle's 'stdout' and --- 'stderr' are flushed automatically; any other buffered 'Handle's --- need to be flushed manually, otherwise the buffered data will be --- discarded. --- --- A program that fails in any other way is treated as if it had --- called 'exitFailure'. --- A program that terminates successfully without calling 'exitWith' --- explicitly is treated as if it had called 'exitWith' 'ExitSuccess'. --- --- As an 'ExitCode' is an 'Control.Exception.Exception', it can be --- caught using the functions of "Control.Exception". This means that --- cleanup computations added with 'GHC.Internal.Control.Exception.bracket' (from --- "Control.Exception") are also executed properly on 'exitWith'. --- --- Note: in GHC, 'exitWith' should be called from the main program --- thread in order to exit the process. When called from another --- thread, 'exitWith' will throw an 'ExitCode' as normal, but the --- exception will not cause the process itself to exit. --- -exitWith :: ExitCode -> IO a -exitWith ExitSuccess = throwIO ExitSuccess -exitWith code@(ExitFailure n) - | n /= 0 = throwIO code - | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing Nothing) - --- | The computation 'exitFailure' is equivalent to --- 'exitWith' @(@'ExitFailure' /exitfail/@)@, --- where /exitfail/ is implementation-dependent. -exitFailure :: IO a -exitFailure = exitWith (ExitFailure 1) - --- | The computation 'exitSuccess' is equivalent to --- 'exitWith' 'ExitSuccess', It terminates the program --- successfully. -exitSuccess :: IO a -exitSuccess = exitWith ExitSuccess - --- | Write given error message to `stderr` and terminate with `exitFailure`. --- --- @since base-4.8.0.0 -die :: String -> IO a -die err = hPutStrLn stderr err >> exitFailure ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs deleted ===================================== @@ -1,323 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} - -{-| - This module bridges between Haskell handles and underlying operating-system - features. --} -module GHC.Internal.System.IO.OS -( - -- * Obtaining file descriptors and Windows handles - withFileDescriptorReadingBiased, - withFileDescriptorWritingBiased, - withWindowsHandleReadingBiased, - withWindowsHandleWritingBiased, - withFileDescriptorReadingBiasedRaw, - withFileDescriptorWritingBiasedRaw, - withWindowsHandleReadingBiasedRaw, - withWindowsHandleWritingBiasedRaw - - -- ** Caveats - -- $with-ref-caveats -) -where - -#if defined(mingw32_HOST_OS) -import GHC.Internal.Base (otherwise) -#endif -import GHC.Internal.Control.Monad (return) -import GHC.Internal.Control.Concurrent.MVar (MVar) -import GHC.Internal.Control.Exception (mask) -import GHC.Internal.Data.Function (const, (.), ($)) -import GHC.Internal.Data.Functor (fmap) -import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe) -#if defined(mingw32_HOST_OS) -import GHC.Internal.Data.Maybe (Maybe (Just)) -#endif -import GHC.Internal.Data.List ((++)) -import GHC.Internal.Data.String (String) -import GHC.Internal.Data.Typeable (Typeable, cast) -import GHC.Internal.System.IO (IO) -import GHC.Internal.IO.FD (fdFD) -#if defined(mingw32_HOST_OS) -import GHC.Internal.IO.Windows.Handle - ( - NativeHandle, - ConsoleHandle, - IoHandle, - toHANDLE - ) -#endif -import GHC.Internal.IO.Handle.Types - ( - Handle (FileHandle, DuplexHandle), - Handle__ (Handle__, haDevice) - ) -import GHC.Internal.IO.Handle.Internals (withHandle_', flushBuffer) -import GHC.Internal.IO.Exception - ( - IOErrorType (InappropriateType), - IOException (IOError), - ioException - ) -import GHC.Internal.Foreign.Ptr (Ptr) -import GHC.Internal.Foreign.C.Types (CInt) - --- * Obtaining POSIX file descriptors and Windows handles - -{-| - Executes a user-provided action on an operating-system handle that underlies - a Haskell handle. Before the user-provided action is run, user-defined - preparation based on the handle state that contains the operating-system - handle is performed. While the user-provided action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withOSHandle :: String - -- ^ The name of the overall operation - -> (Handle -> MVar Handle__) - {-^ - Obtaining of the handle state variable that holds the - operating-system handle - -} - -> (forall d. Typeable d => d -> IO a) - -- ^ Conversion of a device into an operating-system handle - -> (Handle__ -> IO ()) - -- ^ The preparation - -> Handle - -- ^ The Haskell handle to use - -> (a -> IO r) - -- ^ The action to execute on the operating-system handle - -> IO r -withOSHandle opName handleStateVar getOSHandle prepare handle act - = mask $ \ withOriginalMaskingState -> - withHandleState $ \ handleState@Handle__ {haDevice = dev} -> do - osHandle <- getOSHandle dev - prepare handleState - withOriginalMaskingState $ act osHandle - where - - withHandleState = withHandle_' opName handle (handleStateVar handle) -{- - The 'withHandle_'' operation, which we use here, already performs masking. - Still, we have to employ 'mask', in order do obtain the operation that - restores the original masking state. The user-provided action should be - executed with this original masking state, as there is no inherent reason to - generally perform it with masking in place. The masking that 'withHandle_'' - performs is only for safely accessing handle state and thus constitutes an - implementation detail; it has nothing to do with the user-provided action. --} -{- - The order of actions in 'withOSHandle' is such that any exception from - 'getOSHandle' is thrown before the user-defined preparation is performed. --} - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for reading if the handle uses different state - variables for reading and writing. --} -handleStateVarReadingBiased :: Handle -> MVar Handle__ -handleStateVarReadingBiased (FileHandle _ var) = var -handleStateVarReadingBiased (DuplexHandle _ readingVar _) = readingVar - -{-| - Obtains the handle state variable that underlies a handle or specifically - the handle state variable for writing if the handle uses different state - variables for reading and writing. --} -handleStateVarWritingBiased :: Handle -> MVar Handle__ -handleStateVarWritingBiased (FileHandle _ var) = var -handleStateVarWritingBiased (DuplexHandle _ _ writingVar) = writingVar - -{-| - Yields the result of another operation if that operation succeeded, and - otherwise throws an exception that signals that the other operation failed - because some Haskell handle does not use an operating-system handle of a - required type. --} -requiringOSHandleOfType :: String - -- ^ The name of the operating-system handle type - -> Maybe a - {-^ - The result of the other operation if it succeeded - -} - -> IO a -requiringOSHandleOfType osHandleTypeName - = maybe (ioException osHandleOfTypeRequired) return - where - - osHandleOfTypeRequired :: IOException - osHandleOfTypeRequired - = IOError Nothing - InappropriateType - "" - ("handle does not use " ++ osHandleTypeName ++ "s") - Nothing - Nothing - -{-| - Obtains the POSIX file descriptor of a device if the device contains one, - and throws an exception otherwise. --} -getFileDescriptor :: Typeable d => d -> IO CInt -getFileDescriptor = requiringOSHandleOfType "POSIX file descriptor" . - fmap fdFD . cast - -{-| - Obtains the Windows handle of a device if the device contains one, and - throws an exception otherwise. --} -getWindowsHandle :: Typeable d => d -> IO (Ptr ()) -getWindowsHandle = requiringOSHandleOfType "Windows handle" . - toMaybeWindowsHandle - where - - toMaybeWindowsHandle :: Typeable d => d -> Maybe (Ptr ()) -#if defined(mingw32_HOST_OS) - toMaybeWindowsHandle dev - | Just nativeHandle <- cast dev :: Maybe (IoHandle NativeHandle) - = Just (toHANDLE nativeHandle) - | Just consoleHandle <- cast dev :: Maybe (IoHandle ConsoleHandle) - = Just (toHANDLE consoleHandle) - | otherwise - = Nothing - {- - This is inspired by the implementation of - 'System.Win32.Types.withHandleToHANDLENative'. - -} -#else - toMaybeWindowsHandle _ = Nothing -#endif - -{-| - Executes a user-provided action on the POSIX file descriptor that underlies - a handle or specifically on the POSIX file descriptor for reading if the - handle uses different file descriptors for reading and writing. The - Haskell-managed buffers related to the file descriptor are flushed before - the user-provided action is run. While this action is executed, further - operations on the handle are blocked to a degree that interference with this - action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorReadingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiased = withOSHandle "withFileDescriptorReadingBiased" - handleStateVarReadingBiased - getFileDescriptor - flushBuffer - -{-| - Executes a user-provided action on the POSIX file descriptor that underlies - a handle or specifically on the POSIX file descriptor for writing if the - handle uses different file descriptors for reading and writing. The - Haskell-managed buffers related to the file descriptor are flushed before - the user-provided action is run. While this action is executed, further - operations on the handle are blocked to a degree that interference with this - action is prevented. - - If the handle does not use POSIX file descriptors, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withFileDescriptorWritingBiased :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiased = withOSHandle "withFileDescriptorWritingBiased" - handleStateVarWritingBiased - getFileDescriptor - flushBuffer - -{-| - Executes a user-provided action on the Windows handle that underlies a - Haskell handle or specifically on the Windows handle for reading if the - Haskell handle uses different Windows handles for reading and writing. The - Haskell-managed buffers related to the Windows handle are flushed before the - user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleReadingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiased = withOSHandle "withWindowsHandleReadingBiased" - handleStateVarReadingBiased - getWindowsHandle - flushBuffer - -{-| - Executes a user-provided action on the Windows handle that underlies a - Haskell handle or specifically on the Windows handle for writing if the - Haskell handle uses different Windows handles for reading and writing. The - Haskell-managed buffers related to the Windows handle are flushed before the - user-provided action is run. While this action is executed, further - operations on the Haskell handle are blocked to a degree that interference - with this action is prevented. - - If the Haskell handle does not use Windows handles, an exception is thrown. - - See [below](#with-ref-caveats) for caveats regarding this operation. --} -withWindowsHandleWritingBiased :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiased = withOSHandle "withWindowsHandleWritingBiased" - handleStateVarWritingBiased - getWindowsHandle - flushBuffer - -{-| - Like 'withFileDescriptorReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorReadingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorReadingBiasedRaw - = withOSHandle "withFileDescriptorReadingBiasedRaw" - handleStateVarReadingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withFileDescriptorWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withFileDescriptorWritingBiasedRaw :: Handle -> (CInt -> IO r) -> IO r -withFileDescriptorWritingBiasedRaw - = withOSHandle "withFileDescriptorWritingBiasedRaw" - handleStateVarWritingBiased - getFileDescriptor - (const $ return ()) - -{-| - Like 'withWindowsHandleReadingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleReadingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleReadingBiasedRaw - = withOSHandle "withWindowsHandleReadingBiasedRaw" - handleStateVarReadingBiased - getWindowsHandle - (const $ return ()) - -{-| - Like 'withWindowsHandleWritingBiased' except that Haskell-managed buffers - are not flushed. --} -withWindowsHandleWritingBiasedRaw :: Handle -> (Ptr () -> IO r) -> IO r -withWindowsHandleWritingBiasedRaw - = withOSHandle "withWindowsHandleWritingBiasedRaw" - handleStateVarWritingBiased - getWindowsHandle - (const $ return ()) - --- ** Caveats - -{-$with-ref-caveats - #with-ref-caveats#This subsection is just a dummy, whose purpose is to serve - as the target of the hyperlinks above. The real documentation of the caveats - is in the /Caveats/ subsection in the @base@ module @System.IO.OS@, which - re-exports the above operations. --} ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -26,17 +26,19 @@ module GHC.Internal.TH.Monad import Prelude import Data.Data hiding (Fixity(..)) import Data.IORef -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe (unsafePerformIO) import Control.Monad.IO.Class (MonadIO (..)) -import System.IO ( hPutStrLn, stderr ) +import System.IO (FilePath, hPutStrLn, stderr) import qualified Data.Kind as Kind (Type) -import GHC.Types (TYPE, RuntimeRep(..)) +import GHC.Types (TYPE, RuntimeRep(..)) #else 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.IO (FilePath) +import GHC.Internal.IO.Handle.Text (hPutStrLn) +import GHC.Internal.IO.StdHandles (stderr) import GHC.Internal.Data.Foldable import GHC.Internal.Data.Typeable import GHC.Internal.Control.Monad.IO.Class @@ -819,38 +821,6 @@ addTempFile suffix = Q (qAddTempFile suffix) addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) - --- | Emit a foreign file which will be compiled and linked to the object for --- the current module. Currently only languages that can be compiled with --- the C compiler are supported, and the flags passed as part of -optc will --- be also applied to the C compiler invocation that will compile them. --- --- Note that for non-C languages (for example C++) @extern "C"@ directives --- must be used to get symbols that we can access from Haskell. --- --- To get better errors, it is recommended to use #line pragmas when --- emitting C files, e.g. --- --- > {-# LANGUAGE CPP #-} --- > ... --- > addForeignSource LangC $ unlines --- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ --- > , ... --- > ] -addForeignSource :: ForeignSrcLang -> String -> Q () -addForeignSource lang src = do - let suffix = case lang of - LangC -> "c" - LangCxx -> "cpp" - LangObjc -> "m" - LangObjcxx -> "mm" - LangAsm -> "s" - LangJs -> "js" - RawObject -> "a" - path <- addTempFile suffix - runIO $ writeFile path src - addForeignFilePath lang path - -- | 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 -- conjunction with 'addTempFile'. ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -209,7 +209,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import GHC.Lexeme ( startsVarSym, startsVarId ) -- This module completely re-exports 'GHC.Boot.TH.Syntax', --- and exports additionally functions that depend on filepath. +-- and exports additionally functions that depend on @filepath@ or @System.IO@. -- | addForeignFile :: ForeignSrcLang -> String -> Q () @@ -218,6 +218,37 @@ addForeignFile = addForeignSource "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead" #-} -- deprecated in 8.6 +-- | Emit a foreign file which will be compiled and linked to the object for +-- the current module. Currently only languages that can be compiled with +-- the C compiler are supported, and the flags passed as part of -optc will +-- be also applied to the C compiler invocation that will compile them. +-- +-- Note that for non-C languages (for example C++) @extern "C"@ directives +-- must be used to get symbols that we can access from Haskell. +-- +-- To get better errors, it is recommended to use #line pragmas when +-- emitting C files, e.g. +-- +-- > {-# LANGUAGE CPP #-} +-- > ... +-- > addForeignSource LangC $ unlines +-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ +-- > , ... +-- > ] +addForeignSource :: ForeignSrcLang -> String -> Q () +addForeignSource lang src = do + let suffix = case lang of + LangC -> "c" + LangCxx -> "cpp" + LangObjc -> "m" + LangObjcxx -> "mm" + LangAsm -> "s" + LangJs -> "js" + RawObject -> "a" + path <- addTempFile suffix + runIO $ writeFile path src + addForeignFilePath lang path + -- | The input is a filepath, which if relative is offset by the package root. makeRelativeToProject :: FilePath -> Q FilePath makeRelativeToProject fp | isRelative fp = do ===================================== testsuite/tests/ffi/should_compile/all.T ===================================== @@ -33,6 +33,7 @@ test( compile, [ '-optc=-DC -optcxx=-DCXX -optcxx=-std=c++11' + + ' -package=template-haskell' + (' -optcxx=-stdlib=libc++' if opsys('darwin') else '') ], ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4e8fec26e445bd6cd623da30baa069… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4e8fec26e445bd6cd623da30baa069… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Don't use #line in haddocks
by Marge Bot (＠marge-bot) 09 Mar '26

09 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 9e3d6a58 by Simon Hengel at 2026-03-09T04:51:15-04:00 Don't use #line in haddocks This confuses the parser. Haddock output is unaffected by this change. (read: this still produces the same documentation) - - - - - 1 changed file: - compiler/GHC/Iface/Ext/Utils.hs Changes: ===================================== compiler/GHC/Iface/Ext/Utils.hs ===================================== @@ -461,11 +461,11 @@ in which @foozball@ and @quuuuuux@ have overlapping spans: @ module Baz where -# line 3 "Baz.hs" +# \line 3 "Baz.hs" foozball :: Int foozball = 0 -# line 3 "Baz.hs" +# \line 3 "Baz.hs" bar, quuuuuux :: Int bar = 1 quuuuuux = 2 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e3d6a5853347af30561e25cb15ba9a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e3d6a5853347af30561e25cb15ba9a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: compiler: add myCapabilityExpr to GHC.Cmm.Utils
by Marge Bot (＠marge-bot) 09 Mar '26

09 Mar '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a46a1bb1 by Cheng Shao at 2026-03-09T04:50:30-04:00 compiler: add myCapabilityExpr to GHC.Cmm.Utils This commit adds `myCapabilityExpr` to `GHC.Cmm.Utils` which is computed from `BaseReg`. It's convenient for codegen logic where one needs to pass the current Capability's pointer. - - - - - 4afc65b1 by Cheng Shao at 2026-03-09T04:50:30-04:00 compiler: lower tryPutMVar# into a ccall directly This patch addresses an old TODO of `stg_tryPutMVarzh` by removing it completely and making the compiler lower `tryPutMVar#` into a ccall to `performTryPutMVar` directly, without landing into an intermediate C or Cmm function. `performTryPutMVar` is promoted to a public RTS function with default visibility, and the compiler lowering logic takes into account the C ABI of `performTryPutMVar` and converts from C Bool to primop's `Int#` result properly. - - - - - 8 changed files: - compiler/GHC/Cmm/Utils.hs - compiler/GHC/StgToCmm/Prim.hs - rts/PrimOps.cmm - rts/RtsSymbols.c - rts/Threads.c - rts/Threads.h - rts/include/rts/Threads.h - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/Cmm/Utils.hs ===================================== @@ -37,6 +37,7 @@ module GHC.Cmm.Utils( baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, currentTSOExpr, currentNurseryExpr, cccsExpr, + myCapabilityExpr, -- Tagging cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged, @@ -569,7 +570,7 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b [] -- Access to common global registers baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr, - spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr + spLimExpr, hpLimExpr, cccsExpr, myCapabilityExpr :: Platform -> CmmExpr baseExpr p = CmmReg $ baseReg p spExpr p = CmmReg $ spReg p spLimExpr p = CmmReg $ spLimReg p @@ -578,3 +579,5 @@ hpLimExpr p = CmmReg $ hpLimReg p currentTSOExpr p = CmmReg $ currentTSOReg p currentNurseryExpr p = CmmReg $ currentNurseryReg p cccsExpr p = CmmReg $ cccsReg p +myCapabilityExpr p = + cmmRegOff (baseReg p) $ negate $ pc_OFFSET_Capability_r $ platformConstants p ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -345,6 +345,25 @@ emitPrimOp cfg primop = emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val] emitDirtyMutVar mutv (CmmReg (CmmLocal res)) + TryPutMVarOp -> \[mvar, val] -> inlinePrimop $ \[res] -> do + cres <- newTemp b8 + emitCCall + [(cres, NoHint)] + ( CmmLit + ( CmmLabel + ( mkForeignLabel + (fsLit "performTryPutMVar") + ForeignLabelInExternalPackage + IsFunction + ) + ) + ) + [(myCapabilityExpr platform, AddrHint), (mvar, AddrHint), (val, AddrHint)] + emitAssign (CmmLocal res) $ + CmmMachOp + (MO_UU_Conv W8 (wordWidth platform)) + [CmmReg (CmmLocal cres)] + -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes SizeofByteArrayOp -> \[arg] -> inlinePrimop $ \[res] -> @@ -1777,7 +1796,6 @@ emitPrimOp cfg primop = TakeMVarOp -> alwaysExternal TryTakeMVarOp -> alwaysExternal PutMVarOp -> alwaysExternal - TryPutMVarOp -> alwaysExternal ReadMVarOp -> alwaysExternal TryReadMVarOp -> alwaysExternal IsEmptyMVarOp -> alwaysExternal ===================================== rts/PrimOps.cmm ===================================== @@ -1927,95 +1927,6 @@ loop: } -// NOTE: there is another implementation of this function in -// Threads.c:performTryPutMVar(). Keep them in sync! It was -// measurably slower to call the C function from here (70% for a -// tight loop doing tryPutMVar#). -// -// TODO: we could kill the duplication by making tryPutMVar# into an -// inline primop that expands into a C call to performTryPutMVar(). -stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */ - P_ val, /* :: a */ ) -{ - W_ info, tso, q, qinfo; - - LOCK_CLOSURE(mvar, info); - - if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) { -#if defined(THREADED_RTS) - unlockClosure(mvar, info); -#endif - return (0); - } - - q = StgMVar_head(mvar); -loop: - if (q == stg_END_TSO_QUEUE_closure) { - /* No further takes, the MVar is now full. */ - if (info == stg_MVAR_CLEAN_info) { - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr", StgMVar_value(mvar) "ptr"); - } - - StgMVar_value(mvar) = val; - unlockClosure(mvar, stg_MVAR_DIRTY_info); - return (1); - } - - qinfo = GET_INFO_ACQUIRE(q); - - if (qinfo == stg_IND_info || - qinfo == stg_MSG_NULL_info) { - q = %acquire StgInd_indirectee(q); - goto loop; - } - - // There are takeMVar(s) waiting: wake up the first one - - tso = StgMVarTSOQueue_tso(q); - q = StgMVarTSOQueue_link(q); - StgMVar_head(mvar) = q; - if (q == stg_END_TSO_QUEUE_closure) { - StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; - } else { - if (info == stg_MVAR_CLEAN_info) { - // Resolve #18919. - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr", - StgMVar_value(mvar) "ptr"); - info = stg_MVAR_DIRTY_info; - } - } - - // save why_blocked here, because waking up the thread destroys - // this information - W_ why_blocked; - why_blocked = TO_W_(StgTSO_why_blocked(tso)); // TODO: Missing barrier - ASSERT(StgTSO_block_info(tso) == mvar); - - // actually perform the takeMVar - W_ stack; - stack = StgTSO_stackobj(tso); - if (IS_STACK_CLEAN(stack)) { - ccall dirty_STACK(MyCapability() "ptr", stack "ptr"); - } - PerformTake(stack, val); - - // indicate that the MVar operation has now completed. - StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; - - ccall tryWakeupThread(MyCapability() "ptr", tso); - - // If it was a readMVar, then we can still do work, - // so loop back. (XXX: This could take a while) - if (why_blocked == BlockedOnMVarRead) - goto loop; - - ASSERT(why_blocked == BlockedOnMVar); - - unlockClosure(mvar, info); - return (1); -} - - stg_readMVarzh ( P_ mvar, /* :: MVar a */ ) { W_ val, info, tso, q; ===================================== rts/RtsSymbols.c ===================================== @@ -678,6 +678,7 @@ extern char **environ; SymI_HasDataProto(stg_readTVarIOzh) \ SymI_HasProto(resumeThread) \ SymI_HasProto(setNumCapabilities) \ + SymI_HasProto(performTryPutMVar) \ SymI_HasProto(getNumberOfProcessors) \ SymI_HasProto(resolveObjs) \ SymI_HasDataProto(stg_retryzh) \ @@ -869,7 +870,6 @@ extern char **environ; SymI_HasDataProto(stg_takeMVarzh) \ SymI_HasDataProto(stg_readMVarzh) \ SymI_HasDataProto(stg_threadStatuszh) \ - SymI_HasDataProto(stg_tryPutMVarzh) \ SymI_HasDataProto(stg_tryTakeMVarzh) \ SymI_HasDataProto(stg_tryReadMVarzh) \ SymI_HasDataProto(stg_unmaskAsyncExceptionszh) \ ===================================== rts/Threads.c ===================================== @@ -795,8 +795,6 @@ threadStackUnderflow (Capability *cap, StgTSO *tso) /* ---------------------------------------------------------------------------- Implementation of tryPutMVar# - - NOTE: this should be kept in sync with stg_tryPutMVarzh in PrimOps.cmm ------------------------------------------------------------------------- */ bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value) ===================================== rts/Threads.h ===================================== @@ -24,7 +24,7 @@ void migrateThread (Capability *from, StgTSO *tso, Capability *to); // #if defined(THREADED_RTS) void wakeupThreadOnCapability (Capability *cap, - Capability *other_cap, + Capability *other_cap, StgTSO *tso); #endif @@ -40,8 +40,6 @@ StgBool isThreadBound (StgTSO* tso); void threadStackOverflow (Capability *cap, StgTSO *tso); W_ threadStackUnderflow (Capability *cap, StgTSO *tso); -bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value); - #if defined(DEBUG) void printThreadBlockage (StgTSO *tso); void printThreadStatus (StgTSO *t); ===================================== rts/include/rts/Threads.h ===================================== @@ -90,3 +90,5 @@ extern Capability MainCapability; // current value at the moment). // extern void setNumCapabilities (uint32_t new_); + +bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value); ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -512,7 +512,6 @@ RTS_FUN_DECL(stg_takeMVarzh); RTS_FUN_DECL(stg_putMVarzh); RTS_FUN_DECL(stg_readMVarzh); RTS_FUN_DECL(stg_tryTakeMVarzh); -RTS_FUN_DECL(stg_tryPutMVarzh); RTS_FUN_DECL(stg_tryReadMVarzh); RTS_FUN_DECL(stg_waitReadzh); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/689aafcd2e76283b6eee6659d0533f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/689aafcd2e76283b6eee6659d0533f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/kill-SrcCodeOrigin] route the correct ExpectedFunTyCtxt SDoc. Add missing RecordUpdCtxt to errCtxtCtOrigin
by Apoorv Ingle (＠ani) 09 Mar '26

09 Mar '26

Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: 57c9748a by Apoorv Ingle at 2026-03-09T01:31:28-05:00 route the correct ExpectedFunTyCtxt SDoc. Add missing RecordUpdCtxt to errCtxtCtOrigin - - - - - 1 changed file: - compiler/GHC/Tc/Types/Origin.hs Changes: ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -431,7 +431,7 @@ data CtOrigin | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in -- particular the name and the right-hand side - | RecordUpdOrigin (LHsRecUpdFields GhcRn) + | RecordUpdOrigin | ViewPatOrigin -- | 'ScOrigin' is used only for the Wanted constraints for the @@ -623,7 +623,7 @@ exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsProjection _ p) = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p) -exprCtOrigin (RecordUpd _ _ flds) = RecordUpdOrigin flds +exprCtOrigin (RecordUpd{}) = RecordUpdOrigin exprCtOrigin (HsGetField _ _ f) = GetFieldOrigin (fmap field_label $ dfoLabel (unLoc f)) exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) @@ -639,6 +639,7 @@ errCtxtCtOrigin (FunAppCtxt (FunAppCtxtExpr _ e) _) = exprCtOrigin e errCtxtCtOrigin (StmtErrCtxt{}) = DoStmtOrigin errCtxtCtOrigin (DoStmtErrCtxt{}) = DoStmtOrigin errCtxtCtOrigin (StmtErrCtxtPat _ _ p) = DoPatOrigin p +errCtxtCtOrigin (RecordUpdCtxt{}) = RecordUpdOrigin errCtxtCtOrigin _ = Shouldn'tHappenOrigin "errCtxtCtOrigin" @@ -1168,8 +1169,8 @@ pprFixedRuntimeRepContext FRRBindStmtGuard = sep [ text "The body of the bind statement" ] pprFixedRuntimeRepContext (FRRArrow arrowContext) = pprFRRArrowContext arrowContext -pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _) - = pprExpectedFunTyHerald funTyOrig +pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig i) + = pprExpectedFunTyCtxt funTyOrig i pprFixedRuntimeRepContext (FRRDeepSubsumption is_exp pos mb_fun) = hsep [ text "The", what, text "type of the" , ppr (Argument pos) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57c9748aaeddb0d59328ea77e1505d8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57c9748aaeddb0d59328ea77e1505d8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/kill-SrcCodeOrigin] route the correct ExpectedFunTyCtxt SDoc. Add missing RecordUpdCtxt to errCtxtCtOrigin
by Apoorv Ingle (＠ani) 09 Mar '26

09 Mar '26

Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: 643f650f by Apoorv Ingle at 2026-03-09T01:21:07-05:00 route the correct ExpectedFunTyCtxt SDoc. Add missing RecordUpdCtxt to errCtxtCtOrigin - - - - - 1 changed file: - compiler/GHC/Tc/Types/Origin.hs Changes: ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -639,6 +639,7 @@ errCtxtCtOrigin (FunAppCtxt (FunAppCtxtExpr _ e) _) = exprCtOrigin e errCtxtCtOrigin (StmtErrCtxt{}) = DoStmtOrigin errCtxtCtOrigin (DoStmtErrCtxt{}) = DoStmtOrigin errCtxtCtOrigin (StmtErrCtxtPat _ _ p) = DoPatOrigin p +errCtxtCtOrigin (RecordUpdCtxt{}) = RecordUpdOrigin errCtxtCtOrigin _ = Shouldn'tHappenOrigin "errCtxtCtOrigin" @@ -1169,7 +1170,7 @@ pprFixedRuntimeRepContext FRRBindStmtGuard pprFixedRuntimeRepContext (FRRArrow arrowContext) = pprFRRArrowContext arrowContext pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _) - = pprExpectedFunTyHerald funTyOrig + = pprExpectedFunTyCtxt funTyOrig pprFixedRuntimeRepContext (FRRDeepSubsumption is_exp pos mb_fun) = hsep [ text "The", what, text "type of the" , ppr (Argument pos) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/643f650f97f0fae43fbb3b09a24103c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/643f650f97f0fae43fbb3b09a24103c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/kill-SrcCodeOrigin] trying out ErrCtxtMsg zonking
by Apoorv Ingle (＠ani) 09 Mar '26

09 Mar '26

Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: b611de8e by Apoorv Ingle at 2026-03-09T00:58:26-05:00 trying out ErrCtxtMsg zonking - - - - - 4 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1064,6 +1064,7 @@ instance Outputable XXExprGhcRn where pprCtxt (ExprCtxt e) = ppr_builder "<OrigExpr>:" (ppr e) pprCtxt (StmtErrCtxt _ stmt) = ppr_builder "<OrigStmt>:" (ppr stmt) pprCtxt (StmtErrCtxtPat _ _ pat) = ppr_builder "<OrigPat>:" (ppr pat) + pprCtxt (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e) pprCtxt _ = empty instance Outputable XXExprGhcTc where @@ -1079,6 +1080,7 @@ instance Outputable XXExprGhcTc where pprCtxt (ExprCtxt e) = ppr_builder "<OrigExpr>:" (ppr e) pprCtxt (StmtErrCtxt _ stmt) = ppr_builder "<OrigStmt>:" (ppr stmt) pprCtxt (StmtErrCtxtPat _ _ pat) = ppr_builder "<OrigPat>:" (ppr pat) + pprCtxt (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e) pprCtxt _ = empty -- e is the expanded expression, we print the original ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1961,18 +1961,20 @@ mkErrCtxt env ctxts = go False 0 env ctxts -- regular error ctx where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] - go _ _ _ [] = return [] + go _ _ _ [] = return [] go dbg n env (MkErrCtxt LandmarkUserSrcCode ctxt : ctxts) - = do { -- (env', msg) <- liftZonkM $ emptyTidyEnv env - ; rest <- go dbg n env ctxts - ; return (ctxt : rest) } + = do { (env', msg) <- liftZonkM $ zonkTidyErrCtxtMsg env ctxt + ; rest <- go dbg n env' ctxts + ; return (msg : rest) } go dbg n env (MkErrCtxt _ ctxt : ctxts) | n < mAX_CONTEXTS -- Too verbose || dbg - = do { -- (env', msg) <- liftZonkM $ emptyTidyEnv env - ; rest <- go dbg (n+1) env ctxts - ; return (ctxt : rest) } - | otherwise - = go dbg n env ctxts -- need to compute this for zonking + = do { (env', msg) <- liftZonkM $ zonkTidyErrCtxtMsg env ctxt + ; rest <- go dbg (n+1) env' ctxts + ; return (msg : rest) } + | otherwise -- need to compute this for zonking + = do { (env', _) <- liftZonkM $ zonkTidyErrCtxtMsg env ctxt + ; go dbg n env' ctxts + } mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -49,7 +49,7 @@ module GHC.Tc.Zonk.TcType , tidyCt, tidyEvVar, tidyDelayedError -- ** Zonk & tidy - , zonkTidyTcType, zonkTidyTcTypes + , zonkTidyTcType, zonkTidyTcTypes, zonkTidyErrCtxtMsg , zonkTidyOrigin, zonkTidyOrigins , zonkTidyFRRInfos @@ -793,3 +793,171 @@ tidyFRROrigin env (FixedRuntimeRepOrigin ty orig) tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = updateIdTypeAndMult (tidyType env) var -- No need for tidyOpenType because all the free tyvars are already tidied + + + +{- +Zonk ErrCtxtMsg +-} + +zonkTidyErrCtxtMsg :: TidyEnv -> ErrCtxtMsg -> ZonkM (TidyEnv, ErrCtxtMsg) +zonkTidyErrCtxtMsg env e@(ExprCtxt{}) = return (env, e) +zonkTidyErrCtxtMsg env (ThetaCtxt ctxt theta_ty) = do + (env', theta_ty') <- zonkTidyTcTypes env theta_ty + return $ (env', ThetaCtxt ctxt theta_ty') +-- zonkTidyErrCtxtMsg env (QuantifiedCtCtxt ty) = do +-- (env', ty') <- zonkTidyTcTypes env ty +-- return $ QuantifiedCtCtxt ty' +zonkTidyErrCtxtMsg env (InferredTypeCtxt n ty) = do + (env', ty') <- zonkTidyTcType env ty + return $ (env', InferredTypeCtxt n ty') +-- zonkTidyErrCtxtMsg (RecordUpdCtxt n1 n2 tys) = do +-- tys' <- lift $ mapM zonkTcTypeToType tys +-- return $ RecordUpdCtxt n1 n2 tys' +zonkTidyErrCtxtMsg env (ClassOpCtxt n ty) = do + (env', ty') <- zonkTidyTcType env ty + return $ (env', ClassOpCtxt n ty') +zonkTidyErrCtxtMsg env (MethSigCtxt n ty1 ty2) = do + (env', ty1) <- zonkTidyTcType env ty1 + (env', ty2) <- zonkTidyTcType env ty2 + return $ (env', MethSigCtxt n ty1 ty2) +-- zonkTidyErrCtxtMsg (PatSigErrCtxt ty exp_ty) = do +-- ty' <- lift $ zonkTcTypeToType ty +-- exp_ty' <- lift $ readExpType_maybe exp_ty +-- case exp_ty' of +-- Nothing -> error "zonkTidyErrCtxtMsg PatSingErrCtxt" +-- Just exp_ty' -> do +-- exp_ty' <- lift $ zonkTcTypeToType exp_ty' +-- return $ PatSigErrCtxt ty' exp_ty' + +zonkTidyErrCtxtMsg env e@(FunAppCtxt{}) = return (env, e) +zonkTidyErrCtxtMsg env (FunTysCtxt ctxt ty i1 i2) = do + (env', ty') <- zonkTidyTcType env ty + return $ (env', FunTysCtxt ctxt ty' i1 i2) +zonkTidyErrCtxtMsg env (FunResCtxt e i1 ty1 ty2 i2 i3) = do + (env', ty1') <- zonkTidyTcType env ty1 + (env', ty2') <- zonkTidyTcType env ty2 + return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3) +zonkTidyErrCtxtMsg env p = return (env, p) +{- + -- or a type signature, or... (see 'Sig'). + | SigCtxt !(Sig GhcRn) + -- | In a user-written type signature. + | UserSigCtxt !UserTypeCtxt !UserSigType + + -- | In a pattern. + | PatCtxt !(Pat GhcRn) + -- | In a pattern synonym declaration. + | PatSynDeclCtxt !Name + -- | In a pattern matching context, e.g. a equation for a function binding, + -- or a case alternative, ... + | MatchCtxt !HsMatchContextRn + -- | In a match in a pattern matching context, + -- either for an expression or for an arrow command. + | forall body. (Outputable body) + => MatchInCtxt !(Match GhcRn body) + -- | In the declaration of a type constructor. + | TyConDeclCtxt !Name !(TyConFlavour TyCon) + -- | In a type or data family instance (or default instance). + | TyConInstCtxt !Name !TyConInstFlavour + -- | In the declaration of a data constructor. + | DataConDefCtxt !(NE.NonEmpty (LocatedN Name)) + -- | In the result type of a data constructor. + | DataConResTyCtxt !(NE.NonEmpty (LocatedN Name)) + -- | In the equations for a closed type family. + | ClosedFamEqnCtxt !TyCon + -- | In the expansion of a type synonym. + | TySynErrCtxt !TyCon + -- | In a role annotation. + | RoleAnnotErrCtxt !Name + -- | In an arrow command. + | CmdCtxt !(HsCmd GhcRn) + -- | In an instance declaration. + | InstDeclErrCtxt !(Either (LHsType GhcRn) PredType) + -- | In a default declaration. + | DefaultDeclErrCtxt { ddec_in_type_list :: !Bool } + -- | In the body of a static form. + | StaticFormCtxt !(LHsExpr GhcRn) + -- | In a pattern binding. + | forall p. OutputableBndrId p + => PatMonoBindsCtxt !(LPat (GhcPass p)) !(GRHSs GhcRn (LHsExpr GhcRn)) + -- | In a foreign import/export declaration. + | ForeignDeclCtxt !(ForeignDecl GhcRn) + -- | In a record field. + | FieldCtxt !FieldLabelString + -- | In a type. + | TypeCtxt !(LHsType GhcRn) + -- | In a kind. + | KindCtxt !(LHsKind GhcRn) + -- | In an ambiguity check. + | AmbiguityCheckCtxt !UserTypeCtxt !Bool + + -- | In a term-level use of a 'Name'. + | TermLevelUseCtxt !Name !TermLevelUseCtxt + + -- | When checking the type of the @main@ function. + | MainCtxt !Name + -- | Warning emitted when inferring use of visible dependent quantification. + | VDQWarningCtxt !TcTyCon + + -- | In a statement + | forall body. + ( Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA + , Outputable body + ) => StmtErrCtxt !HsStmtContextRn !(StmtLR GhcRn GhcRn body) + + -- | In a do statement. + | DoStmtErrCtxt !HsStmtContextRn !(ExprLStmt GhcRn) + + -- | In patten of the do statement. (c.f. MonadFailErrors) + | StmtErrCtxtPat !HsStmtContextRn !(ExprLStmt GhcRn) (LPat GhcRn) + + -- | In an rebindable syntax expression. + | SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan + -- | In a RULE. + | RuleCtxt !FastString + -- | In a subtype check. + | SubTypeCtxt !TcType !TcType + + -- | In an export. + | forall p. OutputableBndrId p + => ExportCtxt (IE (GhcPass p)) + -- | In an export of a pattern synonym. + | PatSynExportCtxt !PatSyn + -- | In an export of a pattern synonym record field. + | PatSynRecSelExportCtxt !PatSyn !Name + + -- | In an annotation. + | forall p. OutputableBndrId p + => AnnCtxt (AnnDecl (GhcPass p)) + + -- | In a specialise pragma. + | SpecPragmaCtxt !(Sig GhcRn) + + -- | In a deriving clause. + | DerivInstCtxt !PredType + -- | In a standalone deriving clause. + | StandaloneDerivCtxt !(LHsSigWcType GhcRn) + -- | When typechecking the body of a derived instance. + | DerivBindCtxt !Id !Class ![Type] + + -- | In an untyped Template Haskell quote. + | UntypedTHBracketCtxt !(HsQuote GhcPs) + -- | In a typed Template Haskell quote. + | forall p. OutputableBndrId p + => TypedTHBracketCtxt !(LHsExpr (GhcPass p)) + -- | In an untyped Template Haskell splice or quasi-quote. + | UntypedSpliceCtxt !(HsUntypedSplice GhcPs) + -- | In a typed Template Haskell splice. + | forall p. OutputableBndrId p + => TypedSpliceCtxt !(Maybe SplicePointName) !(HsTypedSplice (GhcPass p)) + -- | In the result of a typed Template Haskell splice. + | TypedSpliceResultCtxt !(LHsExpr GhcTc) + -- | In an argument to the Template Haskell @reifyInstances@ function. + | ReifyInstancesCtxt !TH.Name ![TH.Type] + + -- | While merging Backpack signatures. + | MergeSignaturesCtxt !UnitState !ModuleName ![InstantiatedModule] + -- | While checking that a module implements a Backpack signature. + | CheckImplementsCtxt !UnitState !Module !InstantiatedModule +-} ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -2005,4 +2005,3 @@ Quantifying here is awkward because (a) the data type is big and (b) finding the free type vars of an expression is necessarily monadic operation. (consider /\a -> f @ b, where b is side-effected to a) -} - View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b611de8e019ea78a89a98fb061ac9a7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b611de8e019ea78a89a98fb061ac9a7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/kill-SrcCodeOrigin] remove CtOrigin.ExpansionOrigin in favour of errCtxtCtOrigin, remove CtOrign...
by Apoorv Ingle (＠ani) 09 Mar '26

09 Mar '26

Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: a648f030 by Apoorv Ingle at 2026-03-08T22:00:00-05:00 remove CtOrigin.ExpansionOrigin in favour of errCtxtCtOrigin, remove CtOrign from ErrMsgCtxt.FunTysCtxt - - - - - 14 changed files: - compiler/GHC/Hs/Instances.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -642,7 +642,7 @@ deriving instance Eq (IE GhcTc) -- TODO: I think we still need instances for StmtCtxt, ExprCtxt and PatCtxt ctors of ErrCtxtMsg instance Data ErrCtxtMsg where gunfold _ _ _ = error "no gunfold for ErrCtxtMsg" - gfoldl _ _ _ = error "no goldl for ErrCtxtMsg" + gfoldl _ _ _ = error "no gfoldl for ErrCtxtMsg" toConstr = error "no toConstr for ErrCtxtMsg" dataTypeOf = error "no dataTypeOf for ErrCtxtMsg" ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -83,7 +83,6 @@ import qualified GHC.Data.Strict as Strict import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Language.Haskell.Syntax (HsExpr (RecordUpd, HsGetField, HsProjection)) import Control.Monad ( when, foldM, forM_ ) import Data.Bifunctor ( bimap ) @@ -2778,10 +2777,6 @@ isHasFieldOrigin = \case RecordUpdOrigin {} -> True RecordFieldProjectionOrigin {} -> True GetFieldOrigin {} -> True - ExpansionOrigin (ExprCtxt e) - | HsGetField{} <- e -> True - | RecordUpd{} <- e -> True - | HsProjection{} <- e -> True _ -> False ----------------------- ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7798,6 +7798,7 @@ pprErrCtxtMsg = \case | otherwise -> empty + -- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env] where not_fun ty -- ty is definitely not an arrow type, -- and cannot conceivably become one ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -907,10 +907,10 @@ tcInstFun do_ql inst_final ds_flag (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigm ; return (mkScaled mult_ty arg_nu) } - mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> CtOrigin + mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> ExpectedFunTyCtxt mk_herald tc_fun arg = case fun_orig of - ExpansionOrigin (StmtErrCtxt{}) -> ExpectedTySyntax DoStmtOrigin arg + DoStmtOrigin -> ExpectedTySyntax DoStmtOrigin arg _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) arg -- Is the argument supposed to instantiate a forall? ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -1068,7 +1068,7 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside -- fixed RuntimeRep, as needed to call mkWpFun. ; return (result, match_wrapper <.> fun_wrap) } where - herald = ExpectedFunTySyntaxOp 1 orig op + herald = ExpectedFunTySyntaxOp orig op go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty @@ -1097,7 +1097,7 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) ; return (result, match_wrapper, arg_wrappers, res_wrapper) } where - herald = ExpectedFunTySyntaxOp (length arg_shapes) orig op + herald = ExpectedFunTySyntaxOp orig op tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) @@ -1849,4 +1849,3 @@ checkMissingFields con_like rbinds arg_tys field_strs = conLikeImplBangs con_like fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -465,7 +465,7 @@ tcInferAppHead_maybe fun = case fun of -- visible type applications in the argument. -- c.f. T19167 (\ (e, ds_flag, ty) -> (mkExpandedTc o e, ds_flag, ty)) <$> - tcExprSigma False (ExpansionOrigin o) e + tcExprSigma False (errCtxtCtOrigin o) e ) _ -> return Nothing ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -114,7 +114,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty = assertPpr (funBindPrecondition matches) (pprMatches matches) $ do { -- Check that they all have the same no of arguments arity <- checkArgCounts matches - ; let herald = ExpectedFunTyMatches arity (NameThing fun_name) matches + ; let herald = ExpectedFunTyMatches (NameThing fun_name) matches ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) ; (wrap_fun, r) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -701,7 +701,7 @@ tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside = -- 'view_expr' must be a function; expose its argument/result types -- using 'matchActualFunTy'. - ; let herald = ExpectedFunTyViewPat 1 $ unLoc view_expr + ; let herald = ExpectedFunTyViewPat $ unLoc view_expr ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty) <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr) (1, view_expr_rho) view_expr_rho ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -20,7 +20,7 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(ExpansionOrigin) ) +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs ) import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) @@ -1288,7 +1288,7 @@ warnIncompleteRecSel dflags sel_id ct_loc -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, -- despite the expansion to (getField @"x" r) - isGetFieldOrigin (ExpansionOrigin (ExprCtxt (HsGetField {}))) = True + isGetFieldOrigin GetFieldOrigin{} = True isGetFieldOrigin _ = False lookupHasFieldLabel ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Hs.Extension import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) -import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin ) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin, ExpectedFunTyCtxt ) import GHC.Tc.Utils.TcType ( TcType, TcTyCon, ExpType ) import GHC.Types.Basic ( TyConFlavour ) @@ -283,7 +283,7 @@ data ErrCtxtMsg -- | In a function application. | FunAppCtxt !FunAppCtxtFunArg !Int -- | In a function call. - | FunTysCtxt !CtOrigin !Type !Int !Int + | FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int -- | In the result of a function call. | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int -- | In the declaration of a type constructor. ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -211,9 +211,6 @@ setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec) -- See Note [ErrCtxtStack Manipulation] setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt setLclCtxtSrcCodeOrigin ec lclCtxt - -- | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt - -- , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec - -- = lclCtxt { tcl_err_ctxt = ec : ecs } -- never stack 2 statement error contexts on top of each other | MkErrCtxt _ DoStmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt , MkErrCtxt _ DoStmtErrCtxt{} <- ec ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -9,9 +9,8 @@ module GHC.Tc.Types.Origin ( -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - srcCodeOriginCtOrigin, + srcCodeOriginCtOrigin, errCtxtCtOrigin, invisibleOrigin_maybe, isVisibleOrigin, toInvisibleOrigin, - updatePositionCtOrigin, pprCtOrigin, pprCtOriginBriefly, isGivenOrigin, defaultReprEqOrigins, isWantedSuperclassOrigin, ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..), @@ -37,7 +36,7 @@ module GHC.Tc.Types.Origin ( FRRArrowContext(..), pprFRRArrowContext, -- ** ExpectedFunTy FixedRuntimeRepOrigin - pprExpectedFunTyHerald, + ExpectedFunTyCtxt(..), pprExpectedFunTyCtxt, pprExpectedFunTyHerald, -- * InstanceWhat InstanceWhat(..), SafeOverlapping @@ -512,72 +511,6 @@ data CtOrigin | AmbiguityCheckOrigin UserTypeCtxt | ImplicitLiftOrigin HsImplicitLiftSplice - | ExpansionOrigin ErrCtxtMsg -- This is due to an expansion of the original thing given by the ErrCtxtMsg - - | ExpectedTySyntax !CtOrigin (HsExpr GhcRn) - - -- | A rebindable syntax operator is expected to have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK - | forall (p :: Pass) - . (OutputableBndrId p) - => ExpectedFunTySyntaxOp Int - !CtOrigin !(HsExpr (GhcPass p)) - -- ^ rebindable syntax operator - - -- | A view pattern must have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder - | ExpectedFunTyViewPat Int - !(HsExpr GhcRn) - -- ^ function used in the view pattern - - -- | Need to be able to extract an argument type from a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyApp - | forall (p :: Pass) - . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg - !TypedThing - -- ^ function - !(HsExpr (GhcPass p)) - -- ^ argument - - -- | Ensure that a function defined by equations indeed has a function type - -- with the appropriate number of arguments. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern - | ExpectedFunTyMatches Int - !TypedThing - -- ^ name of the function - !(MatchGroup GhcRn (LHsExpr GhcRn)) - -- ^ equations - - -- | Ensure that a lambda abstraction has a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyLambda, RepPolyMatch - | ExpectedFunTyLam HsLamVariant - !(HsExpr GhcRn) - -- ^ the entire lambda-case expression - - -- | A partial application of the constructor of a representation-polymorphic - -- unlifted newtype in which the argument type does not have a fixed - -- runtime representation. - -- - -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. - | FRRRepPolyUnliftedNewtype !DataCon - - -updatePositionCtOrigin :: Int -> CtOrigin -> CtOrigin -updatePositionCtOrigin i (ExpectedFunTySyntaxOp _ c e) = ExpectedFunTySyntaxOp i c e -updatePositionCtOrigin i (ExpectedFunTyViewPat _ e) = ExpectedFunTyViewPat i e -updatePositionCtOrigin i (ExpectedFunTyMatches _ t e) = ExpectedFunTyMatches i t e -updatePositionCtOrigin _ c = c - data NonLinearPatternReason = LazyPatternReason @@ -680,18 +613,18 @@ exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket" exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket" exprCtOrigin (HsTypedSplice {}) = Shouldn'tHappenOrigin "TH typed splice" exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice" -exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" -exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" -exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression" -exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" -exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] -exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] -exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] -exprCtOrigin e@(ExplicitList {}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(HsIf {}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (ExprCtxt e) -exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (ExprCtxt e) +exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" +exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" +exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression" +exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" +exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] +exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] +exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] +exprCtOrigin (ExplicitList {}) = ListOrigin +exprCtOrigin (HsIf {}) = IfThenElseOrigin +exprCtOrigin (HsProjection _ p) = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p) +exprCtOrigin (RecordUpd _ _ flds) = RecordUpdOrigin flds +exprCtOrigin (HsGetField _ _ f) = GetFieldOrigin (fmap field_label $ dfoLabel (unLoc f)) exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) @@ -736,31 +669,6 @@ pprCtOrigin :: CtOrigin -> SDoc pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk -pprCtOrigin (ExpansionOrigin o) - = ctoHerald <+> what - where - what :: SDoc - what = case o of - StmtErrCtxt{} -> - text "a do statement" - DoStmtErrCtxt{} -> - text "a do statement" - StmtErrCtxtPat _ _ p -> - text "a do statement" $$ - text "with the failable pattern" <+> quotes (ppr p) - ExprCtxt (HsGetField _ _ (L _ f)) -> - hsep [text "selecting the field", quotes (ppr f)] - ExprCtxt (HsOverLabel _ l) -> - hsep [text "the overloaded label" , quotes (char '#' <> ppr l)] - ExprCtxt (RecordUpd{}) -> text "a record update" - ExprCtxt (ExplicitList{}) -> text "an overloaded list" - ExprCtxt (HsIf{}) -> text "an if-then-else expression" - ExprCtxt (HsProjection _ p) -> text "the record selector" <+> - quotes (ppr ((FieldLabelStrings $ fmap noLocA p))) - ExprCtxt e -> text "the expression" <+> (ppr e) - RecordUpdCtxt{} -> text "a record update" - _ -> text "shouldn't happen ExpansionOrigin pprCtOrigin" - pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] @@ -867,46 +775,9 @@ pprCtOrigin (NonLinearPatternOrigin reason pat) = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat)) 2 (pprNonLinearPatternReason reason) -pprCtOrigin (ExpectedTySyntax orig arg) - = vcat [ text "The expression" <+> quotes (ppr arg) - , nest 2 (ppr orig) ] - -pprCtOrigin (ExpectedFunTySyntaxOp i orig op) = - vcat [ sep [ the_arg_of i - , text "the rebindable syntax operator" - , quotes (ppr op) ] - , nest 2 (ppr orig) ] - -pprCtOrigin (ExpectedFunTyViewPat i expr) = - vcat [ the_arg_of i <+> text "the view pattern" - , nest 2 (ppr expr) ] -pprCtOrigin (ExpectedFunTyArg fun arg) = - sep [ text "The argument" - , quotes (ppr arg) - , text "of" - , quotes (ppr fun) ] -pprCtOrigin (ExpectedFunTyMatches i fun (MG { mg_alts = L _ alts })) - | null alts - = the_arg_of i <+> quotes (ppr fun) - | otherwise - = text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts - <+> text "for" <+> quotes (ppr fun) -pprCtOrigin (ExpectedFunTyLam lam_variant _) = binder_of $ lamCaseKeyword lam_variant -pprCtOrigin (FRRRepPolyUnliftedNewtype dc) = - vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype." - , text "The argument of the newtype constructor" <+> quotes (ppr dc) ] - pprCtOrigin simple_origin = ctoHerald <+> pprCtOriginBriefly simple_origin -the_arg_of :: Int -> SDoc -the_arg_of i = text "The" <+> speakNth i <+> text "argument of" - -binder_of :: SDoc -> SDoc -binder_of what = text "The binder of the" <+> what <+> text "expression" - - - -- | Print CtOrigin briefly, with a one-liner pprCtOriginBriefly :: CtOrigin -> SDoc pprCtOriginBriefly = ppr_br -- ppr_br is a local function with a short name! @@ -979,22 +850,6 @@ ppr_br (InstanceSigOrigin {}) = text "a type signature in an instance" ppr_br (AmbiguityCheckOrigin {}) = text "a type ambiguity check" ppr_br (ImpedanceMatching {}) = text "combining required constraints" ppr_br (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] -ppr_br (ExpansionOrigin (ExprCtxt (HsOverLabel _ l))) = hsep [text "the overloaded label", quotes (char '#' <> ppr l)] -ppr_br (ExpansionOrigin (ExprCtxt (RecordUpd{}))) = text "a record update" -ppr_br (ExpansionOrigin (ExprCtxt (ExplicitList{}))) = text "an overloaded list" -ppr_br (ExpansionOrigin (ExprCtxt (HsIf{}))) = text "an if-then-else expression" -ppr_br (ExpansionOrigin (ExprCtxt e)) = text "an expression" <+> ppr e -ppr_br (ExpansionOrigin (StmtErrCtxt{})) = text "a do statement" -ppr_br (ExpansionOrigin (StmtErrCtxtPat{})) = text "a do statement" -ppr_br (ExpansionOrigin{}) = text "shouldn't happen ExpansionOrigin ppr_br" -ppr_br (ExpectedTySyntax o _) = ppr_br o -ppr_br (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" -ppr_br (ExpectedFunTyViewPat{}) = text "a view pattern" -ppr_br (ExpectedFunTyArg{}) = text "a funtion head" -ppr_br (ExpectedFunTyMatches{}) = text "a match statement" -ppr_br (ExpectedFunTyLam{}) = text "a lambda expression" -ppr_br (FRRRepPolyUnliftedNewtype{}) = text "a unlifted newtype" - pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear") @@ -1225,9 +1080,9 @@ data FixedRuntimeRepContext -- | A representation-polymorphism check arising from a call -- to 'matchExpectedFunTys' or 'matchActualFunTy'. -- - -- See 'ExpectedFunTyOrigin' for more details. + -- See 'ExpectedFunTyCtxt' for more details. | FRRExpectedFunTy - !CtOrigin + !ExpectedFunTyCtxt !Int -- ^ argument position (1-indexed) @@ -1314,7 +1169,7 @@ pprFixedRuntimeRepContext FRRBindStmtGuard pprFixedRuntimeRepContext (FRRArrow arrowContext) = pprFRRArrowContext arrowContext pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _) - = pprCtOrigin funTyOrig + = pprExpectedFunTyHerald funTyOrig pprFixedRuntimeRepContext (FRRDeepSubsumption is_exp pos mb_fun) = hsep [ text "The", what, text "type of the" , ppr (Argument pos) @@ -1540,15 +1395,136 @@ instance Outputable FRRArrowContext where ppr = pprFRRArrowContext -pprExpectedFunTyHerald :: CtOrigin -> SDoc +{- ********************************************************************* +* * + FixedRuntimeRep: ExpectedFunTy origin +* * +********************************************************************* -} + +-- | In what context are we calling 'matchExpectedFunTys' +-- or 'matchActualFunTy'? +-- +-- Used for two things: +-- +-- 1. Reporting error messages which explain that a function has been +-- given an unexpected number of arguments. +-- Uses 'pprExpectedFunTyHerald'. +-- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify. +-- +-- 2. Reporting representation-polymorphism errors when a function argument +-- doesn't have a fixed RuntimeRep as per Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +-- Uses 'pprExpectedFunTyCtxt'. +-- See 'FixedRuntimeRepContext' for the situations in which +-- representation-polymorphism checks are performed. +data ExpectedFunTyCtxt + + -- | A rebindable syntax operator is expected to have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK + = forall (p :: Pass) + . (OutputableBndrId p) + => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) + -- ^ rebindable syntax operator + + -- | + | ExpectedTySyntax !CtOrigin !(HsExpr GhcRn) + + -- | A view pattern must have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder + | ExpectedFunTyViewPat + !(HsExpr GhcRn) + -- ^ function used in the view pattern + + -- | Need to be able to extract an argument type from a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyApp + | forall (p :: Pass) + . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg + !TypedThing + -- ^ function + !(HsExpr (GhcPass p)) + -- ^ argument + + -- | Ensure that a function defined by equations indeed has a function type + -- with the appropriate number of arguments. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern + | ExpectedFunTyMatches + !TypedThing + -- ^ name of the function + !(MatchGroup GhcRn (LHsExpr GhcRn)) + -- ^ equations + + -- | Ensure that a lambda abstraction has a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyLambda, RepPolyMatch + | ExpectedFunTyLam HsLamVariant + !(HsExpr GhcRn) + -- ^ the entire lambda-case expression + + -- | A partial application of the constructor of a representation-polymorphic + -- unlifted newtype in which the argument type does not have a fixed + -- runtime representation. + -- + -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. + | FRRRepPolyUnliftedNewtype !DataCon + +pprExpectedFunTyCtxt :: ExpectedFunTyCtxt + -> Int -- ^ argument position (starting at 1) + -> SDoc +pprExpectedFunTyCtxt funTy_origin i = + case funTy_origin of + ExpectedFunTySyntaxOp orig op -> + vcat [ sep [ the_arg_of + , text "the rebindable syntax operator" + , quotes (ppr op) ] + , nest 2 (ppr orig) ] + ExpectedTySyntax orig arg -> + vcat [ text "the expression" <+> quotes (ppr arg) + , nest 2 (ppr orig) ] + ExpectedFunTyViewPat expr -> + vcat [ the_arg_of <+> text "the view pattern" + , nest 2 (ppr expr) ] + ExpectedFunTyArg fun arg -> + sep [ text "The argument" + , quotes (ppr arg) + , text "of" + , quotes (ppr fun) ] + ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }) + | null alts + -> the_arg_of <+> quotes (ppr fun) + | otherwise + -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts + <+> text "for" <+> quotes (ppr fun) + ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant + FRRRepPolyUnliftedNewtype dc -> + vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype." + , text "The argument of the newtype constructor" <+> quotes (ppr dc) ] + where + the_arg_of :: SDoc + the_arg_of = text "The" <+> speakNth i <+> text "argument of" + + binder_of :: SDoc -> SDoc + binder_of what = text "The binder of the" <+> what <+> text "expression" + +pprExpectedFunTyHerald :: ExpectedFunTyCtxt -> SDoc pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {}) = text "This rebindable syntax expects a function with" +pprExpectedFunTyHerald (ExpectedTySyntax orig _) + = pprCtOriginBriefly orig pprExpectedFunTyHerald (ExpectedFunTyViewPat {}) = text "A view pattern expression expects" pprExpectedFunTyHerald (ExpectedFunTyArg fun _) = sep [ text "The function" <+> quotes (ppr fun) , text "is applied to" ] -pprExpectedFunTyHerald (ExpectedFunTyMatches _ fun (MG { mg_alts = L _ alts })) +pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })) = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression" @@ -1557,7 +1533,6 @@ pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) , text "has" ] pprExpectedFunTyHerald (FRRRepPolyUnliftedNewtype dc) = text "The unlifted newtype" <+> quotes (ppr dc) <+> text "expects" -pprExpectedFunTyHerald orig = ppr (Shouldn'tHappenOrigin "pprExpectedFunTyHerald") <+> ppr orig {- ******************************************************************* * * ===================================== compiler/GHC/Tc/Types/Origin.hs-boot ===================================== @@ -5,6 +5,7 @@ import GHC.Utils.Misc ( HasDebugCallStack ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) data CtOrigin +data ExpectedFunTyCtxt data SkolemInfoAnon data SkolemInfo data FixedRuntimeRepContext ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -139,7 +139,7 @@ import Data.Traversable (for) -- -- See Note [Return arguments with a fixed RuntimeRep]. matchActualFunTy - :: CtOrigin + :: ExpectedFunTyCtxt -- ^ See Note [Herald for matchExpectedFunTys] -> Maybe TypedThing -- ^ The thing with type TcSigmaType @@ -178,7 +178,7 @@ matchActualFunTy herald mb_thing err_info fun_ty go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ - do { (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin 1 herald) 1) arg_ty + do { (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald 1) arg_ty ; let fun_co = mkFunCo Nominal af (mkReflCo Nominal w) arg_co @@ -249,7 +249,7 @@ Ugh! -- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. -matchActualFunTys :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys] +matchActualFunTys :: ExpectedFunTyCtxt -- ^ See Note [Herald for matchExpectedFunTys] -> CtOrigin -> Arity -> TcSigmaType @@ -793,7 +793,7 @@ Example: -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. matchExpectedFunTys :: forall a. - CtOrigin -- See Note [Herald for matchExpectedFunTys] + ExpectedFunTyCtxt -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> VisArity -> ExpSigmaType @@ -875,7 +875,7 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside , ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc - ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) arg_ty + ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr ; (res_wrap, result) <- check (n_req - 1) (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys) @@ -947,19 +947,19 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty ; return (mkWpCastN co, result) } -new_infer_arg_ty :: CtOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR) +new_infer_arg_ty :: ExpectedFunTyCtxt -> Int -> TcM (Scaled ExpRhoTypeFRR) new_infer_arg_ty herald arg_pos -- position for error messages only = do { mult <- newFlexiTyVarTy multiplicityTy - ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) + ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult inf_hole) } -new_check_arg_ty :: CtOrigin -> Int -> TcM (Scaled TcType) +new_check_arg_ty :: ExpectedFunTyCtxt -> Int -> TcM (Scaled TcType) new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg = do { mult <- newFlexiTyVarTy multiplicityTy - ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) + ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult arg_ty) } -mkFunTysMsg :: CtOrigin +mkFunTysMsg :: ExpectedFunTyCtxt -> (VisArity, TcType) -> ErrCtxtMsg -- See Note [Reporting application arity errors] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a648f0303e70e85481ce8a1f532d502… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a648f0303e70e85481ce8a1f532d502… You're receiving this email because of your account on gitlab.haskell.org.

1 0