diff options
Diffstat (limited to 'libraries/base/System')
| -rw-r--r-- | libraries/base/System/Environment.hs | 106 | ||||
| -rw-r--r-- | libraries/base/System/Environment/Blank.hsc | 193 | ||||
| -rw-r--r-- | libraries/base/System/Environment/ExecutablePath.hsc | 86 | ||||
| -rw-r--r-- | libraries/base/System/Exit.hs | 2 | ||||
| -rw-r--r-- | libraries/base/System/IO.hs | 110 | ||||
| -rw-r--r-- | libraries/base/System/Mem/StableName.hs | 75 | ||||
| -rw-r--r-- | libraries/base/System/Timeout.hs | 11 |
7 files changed, 371 insertions, 212 deletions
diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs index 56e6961f8a..5604ca2b03 100644 --- a/libraries/base/System/Environment.hs +++ b/libraries/base/System/Environment.hs @@ -38,13 +38,13 @@ import Control.Exception.Base (bracket) #endif -- import GHC.IO import GHC.IO.Exception -import GHC.IO.Encoding (getFileSystemEncoding) import qualified GHC.Foreign as GHC import Control.Monad #if defined(mingw32_HOST_OS) -import GHC.Environment +import GHC.IO.Encoding (argvEncoding) import GHC.Windows #else +import GHC.IO.Encoding (getFileSystemEncoding, argvEncoding) import System.Posix.Internals (withFilePath) #endif @@ -65,89 +65,21 @@ import System.Environment.ExecutablePath -- --------------------------------------------------------------------------- -- getArgs, getProgName, getEnv -#if defined(mingw32_HOST_OS) - -{- -Note [Ignore hs_init argv] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Ignore the arguments to hs_init on Windows for the sake of Unicode compat - -Instead on Windows we get the list of arguments from getCommandLineW and -filter out arguments which the RTS would not have passed along. - -This is done to ensure we get the arguments in proper Unicode Encoding which -the RTS at this moment does not seem provide. The filtering has to match the -one done by the RTS to avoid inconsistencies like #13287. --} - -getWin32ProgArgv_certainly :: IO [String] -getWin32ProgArgv_certainly = do - mb_argv <- getWin32ProgArgv - case mb_argv of - -- see Note [Ignore hs_init argv] - Nothing -> fmap dropRTSArgs getFullArgs - Just argv -> return argv - -withWin32ProgArgv :: [String] -> IO a -> IO a -withWin32ProgArgv argv act = bracket begin setWin32ProgArgv (\_ -> act) - where - begin = do - mb_old_argv <- getWin32ProgArgv - setWin32ProgArgv (Just argv) - return mb_old_argv - -getWin32ProgArgv :: IO (Maybe [String]) -getWin32ProgArgv = alloca $ \p_argc -> alloca $ \p_argv -> do - c_getWin32ProgArgv p_argc p_argv - argc <- peek p_argc - argv_p <- peek p_argv - if argv_p == nullPtr - then return Nothing - else do - argv_ps <- peekArray (fromIntegral argc) argv_p - fmap Just $ mapM peekCWString argv_ps - -setWin32ProgArgv :: Maybe [String] -> IO () -setWin32ProgArgv Nothing = c_setWin32ProgArgv 0 nullPtr -setWin32ProgArgv (Just argv) = withMany withCWString argv $ \argv_ps -> withArrayLen argv_ps $ \argc argv_p -> do - c_setWin32ProgArgv (fromIntegral argc) argv_p - -foreign import ccall unsafe "getWin32ProgArgv" - c_getWin32ProgArgv :: Ptr CInt -> Ptr (Ptr CWString) -> IO () - -foreign import ccall unsafe "setWin32ProgArgv" - c_setWin32ProgArgv :: CInt -> Ptr CWString -> IO () - --- See Note [Ignore hs_init argv] -dropRTSArgs :: [String] -> [String] -dropRTSArgs [] = [] -dropRTSArgs rest@("--":_) = rest -dropRTSArgs ("+RTS":rest) = dropRTSArgs (dropWhile (/= "-RTS") rest) -dropRTSArgs ("--RTS":rest) = rest -dropRTSArgs ("-RTS":rest) = dropRTSArgs rest -dropRTSArgs (arg:rest) = arg : dropRTSArgs rest - -#endif - -- | Computation 'getArgs' returns a list of the program's command -- line arguments (not including the program name). getArgs :: IO [String] - -#if defined(mingw32_HOST_OS) -getArgs = fmap tail getWin32ProgArgv_certainly -#else getArgs = alloca $ \ p_argc -> alloca $ \ p_argv -> do getProgArgv p_argc p_argv p <- fromIntegral `liftM` peek p_argc argv <- peek p_argv - enc <- getFileSystemEncoding + enc <- argvEncoding peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc) + foreign import ccall unsafe "getProgArgv" getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () -#endif {-| Computation 'getProgName' returns the name of the program as it was @@ -160,10 +92,7 @@ between platforms: on Windows, for example, a program invoked as foo is probably really @FOO.EXE@, and that is what 'getProgName' will return. -} getProgName :: IO String -#if defined(mingw32_HOST_OS) -- Ignore the arguments to hs_init on Windows for the sake of Unicode compat -getProgName = fmap (basename . head) getWin32ProgArgv_certainly -#else getProgName = alloca $ \ p_argc -> alloca $ \ p_argv -> do @@ -173,10 +102,9 @@ getProgName = unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] unpackProgName argv = do - enc <- getFileSystemEncoding + enc <- argvEncoding s <- peekElemOff argv 0 >>= GHC.peekCString enc return (basename s) -#endif basename :: FilePath -> FilePath basename f = go f f @@ -195,8 +123,8 @@ basename f = go f f -- | Computation 'getEnv' @var@ returns the value --- of the environment variable @var@. For the inverse, POSIX users --- can use 'System.Posix.Env.putEnv'. +-- of the environment variable @var@. For the inverse, the +-- `System.Environment.setEnv` function can be used. -- -- This computation may fail with: -- @@ -262,9 +190,10 @@ ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv" -- | @setEnv name value@ sets the specified environment variable to @value@. -- --- On Windows setting an environment variable to the /empty string/ removes +-- Early versions of this function operated under the mistaken belief that +-- setting an environment variable to the /empty string/ on Windows removes -- that environment variable from the environment. For the sake of --- compatibility we adopt that behavior. In particular +-- compatibility, it adopted that behavior on POSIX. In particular -- -- @ -- setEnv name \"\" @@ -276,9 +205,8 @@ ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv" -- `unsetEnv` name -- @ -- --- If you don't care about Windows support and want to set an environment --- variable to the empty string use @System.Posix.Env.setEnv@ from the @unix@ --- package instead. +-- If you'd like to be able to set environment variables to blank strings, +-- use `System.Environment.Blank.setEnv`. -- -- Throws `Control.Exception.IOException` if @name@ is the empty string or -- contains an equals sign. @@ -371,15 +299,7 @@ withProgName nm act = do -- the duration of an action. withArgv :: [String] -> IO a -> IO a - -#if defined(mingw32_HOST_OS) --- We have to reflect the updated arguments in the RTS-side variables as --- well, because the RTS still consults them for error messages and the like. --- If we don't do this then ghc-e005 fails. -withArgv new_args act = withWin32ProgArgv new_args $ withProgArgv new_args act -#else withArgv = withProgArgv -#endif withProgArgv :: [String] -> IO a -> IO a withProgArgv new_args act = do @@ -391,7 +311,7 @@ withProgArgv new_args act = do setProgArgv :: [String] -> IO () setProgArgv argv = do - enc <- getFileSystemEncoding + enc <- argvEncoding GHC.withCStringsLen enc argv $ \len css -> c_setProgArgv (fromIntegral len) css diff --git a/libraries/base/System/Environment/Blank.hsc b/libraries/base/System/Environment/Blank.hsc new file mode 100644 index 0000000000..637a039809 --- /dev/null +++ b/libraries/base/System/Environment/Blank.hsc @@ -0,0 +1,193 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE CApiFFI #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Environment.Blank +-- Copyright : (c) Habib Alamin 2017 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A setEnv implementation that allows blank environment variables. Mimics +-- the `System.Posix.Env` module from the @unix@ package, but with support +-- for Windows too. +-- +-- The matrix of platforms that: +-- +-- * support @putenv("FOO")@ to unset environment variables, +-- * support @putenv("FOO=")@ to unset environment variables or set them +-- to blank values, +-- * support @unsetenv@ to unset environment variables, +-- * support @setenv@ to set environment variables, +-- * etc. +-- +-- is very complicated. Some platforms don't support unsetting of environment +-- variables at all. +-- +----------------------------------------------------------------------------- + +module System.Environment.Blank + ( + module System.Environment, + getEnv, + getEnvDefault, + setEnv, + unsetEnv, + ) where + +import Foreign.C +#ifdef mingw32_HOST_OS +import Foreign.Ptr +import GHC.Windows +import Control.Monad +#else +import System.Posix.Internals +#endif +import GHC.IO.Exception +import System.IO.Error +import Control.Exception.Base +import Data.Maybe + +import System.Environment + ( + getArgs, + getProgName, + getExecutablePath, + withArgs, + withProgName, + getEnvironment + ) +#ifndef mingw32_HOST_OS +import qualified System.Environment as Environment +#endif + +-- TODO: include windows_cconv.h when it's merged, instead of duplicating +-- this C macro block. +#if defined(mingw32_HOST_OS) +# if defined(i386_HOST_ARCH) +## define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +## define WINDOWS_CCONV ccall +# else +## error Unknown mingw32 arch +# endif +#endif + +#include "HsBaseConfig.h" + +throwInvalidArgument :: String -> IO a +throwInvalidArgument from = + throwIO (mkIOError InvalidArgument from Nothing Nothing) + +-- | Similar to 'System.Environment.lookupEnv'. +getEnv :: String -> IO (Maybe String) +#ifdef mingw32_HOST_OS +getEnv = (<$> getEnvironment) . lookup +#else +getEnv = Environment.lookupEnv +#endif + +-- | Get an environment value or a default value. +getEnvDefault :: + String {- ^ variable name -} -> + String {- ^ fallback value -} -> + IO String {- ^ variable value or fallback value -} +getEnvDefault name fallback = fromMaybe fallback <$> getEnv name + +-- | Like 'System.Environment.setEnv', but allows blank environment values +-- and mimics the function signature of 'System.Posix.Env.setEnv' from the +-- @unix@ package. +setEnv :: + String {- ^ variable name -} -> + String {- ^ variable value -} -> + Bool {- ^ overwrite -} -> + IO () +setEnv key_ value_ overwrite + | null key = throwInvalidArgument "setEnv" + | '=' `elem` key = throwInvalidArgument "setEnv" + | otherwise = + if overwrite + then setEnv_ key value + else do + env_var <- getEnv key + case env_var of + Just _ -> return () + Nothing -> setEnv_ key value + where + key = takeWhile (/= '\NUL') key_ + value = takeWhile (/= '\NUL') value_ + +setEnv_ :: String -> String -> IO () +#if defined(mingw32_HOST_OS) +setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do + success <- c_SetEnvironmentVariable k v + unless success (throwGetLastError "setEnv") + +foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" + c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool +#else +setEnv_ key value = + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum True)) + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> IO CInt +#endif + +-- | Like 'System.Environment.unsetEnv', but allows for the removal of +-- blank environment variables. May throw an exception if the underlying +-- platform doesn't support unsetting of environment variables. +unsetEnv :: String -> IO () +#if defined(mingw32_HOST_OS) +unsetEnv key = withCWString key $ \k -> do + success <- c_SetEnvironmentVariable k nullPtr + unless success $ do + -- We consider unsetting an environment variable that does not exist not as + -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND. + err <- c_GetLastError + unless (err == eRROR_ENVVAR_NOT_FOUND) $ do + throwGetLastError "unsetEnv" + +eRROR_ENVVAR_NOT_FOUND :: DWORD +eRROR_ENVVAR_NOT_FOUND = 203 + +foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" + c_GetLastError:: IO DWORD +#elif HAVE_UNSETENV +# if !UNSETENV_RETURNS_VOID +unsetEnv name = withFilePath name $ \ s -> + throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) + +-- POSIX.1-2001 compliant unsetenv(3) +foreign import capi unsafe "HsBase.h unsetenv" + c_unsetenv :: CString -> IO CInt +# else +unsetEnv name = withFilePath name c_unsetenv + +-- pre-POSIX unsetenv(3) returning @void@ +foreign import capi unsafe "HsBase.h unsetenv" + c_unsetenv :: CString -> IO () +# endif +#else +unsetEnv name = + if '=' `elem` name + then throwInvalidArgument "unsetEnv" + else putEnv name + +putEnv :: String -> IO () +putEnv keyvalue = do + s <- getFileSystemEncoding >>= (`newCString` keyvalue) + -- IMPORTANT: Do not free `s` after calling putenv! + -- + -- According to SUSv2, the string passed to putenv becomes part of the + -- environment. #7342 + throwErrnoIf_ (/= 0) "putenv" (c_putenv s) + +foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt +#endif diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc index 8b6c7b6c57..095b25c236 100644 --- a/libraries/base/System/Environment/ExecutablePath.hsc +++ b/libraries/base/System/Environment/ExecutablePath.hsc @@ -33,11 +33,14 @@ import Foreign.C import Foreign.Marshal.Array import System.Posix.Internals #elif defined(mingw32_HOST_OS) +import Control.Exception +import Data.List import Data.Word import Foreign.C import Foreign.Marshal.Array import Foreign.Ptr -import System.Posix.Internals +#include <windows.h> +#include <stdint.h> #else import Foreign.C import Foreign.Marshal.Alloc @@ -54,6 +57,10 @@ import System.Posix.Internals -- Note that for scripts and interactive sessions, this is the path to -- the interpreter (e.g. ghci.) -- +-- Since base 4.11.0.0, 'getExecutablePath' resolves symlinks on Windows. +-- If an executable is launched through a symlink, 'getExecutablePath' +-- returns the absolute path of the original executable. +-- -- @since 4.6.0.0 getExecutablePath :: IO FilePath @@ -137,18 +144,87 @@ getExecutablePath = readSymbolicLink $ "/proc/self/exe" # error Unknown mingw32 arch # endif -foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 - getExecutablePath = go 2048 -- plenty, PATH_MAX is 512 under Win32 where go size = allocaArray (fromIntegral size) $ \ buf -> do ret <- c_GetModuleFileName nullPtr buf size case ret of 0 -> errorWithoutStackTrace "getExecutablePath: GetModuleFileNameW returned an error" - _ | ret < size -> peekFilePath buf + _ | ret < size -> do + path <- peekCWString buf + real <- getFinalPath path + exists <- withCWString real c_pathFileExists + if exists + then return real + else fail path | otherwise -> go (size * 2) +-- | Returns the final path of the given path. If the given +-- path is a symbolic link, the returned value is the +-- path the (possibly chain of) symbolic link(s) points to. +-- Otherwise, the original path is returned, even when the filepath +-- is incorrect. +-- +-- Adapted from: +-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa364962.aspx +getFinalPath :: FilePath -> IO FilePath +getFinalPath path = withCWString path $ \s -> + bracket (createFile s) c_closeHandle $ \h -> do + let invalid = h == wordPtrToPtr (#const (intptr_t)INVALID_HANDLE_VALUE) + if invalid then pure path else go h bufSize + + where go h sz = allocaArray (fromIntegral sz) $ \outPath -> do + ret <- c_getFinalPathHandle h outPath sz (#const FILE_NAME_OPENED) + if ret < sz + then sanitize . rejectUNCPath <$> peekCWString outPath + else go h (2 * sz) + + sanitize s + | "\\\\?\\" `isPrefixOf` s = drop 4 s + | otherwise = s + + -- see https://ghc.haskell.org/trac/ghc/ticket/14460 + rejectUNCPath s + | "\\\\?\\UNC\\" `isPrefixOf` s = path + | otherwise = s + + -- the initial size of the buffer in which we store the + -- final path; if this is not enough, we try with a buffer of + -- size 2^k * bufSize, for k = 1, 2, 3, ... until the buffer + -- is large enough. + bufSize = 1024 + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 + +foreign import WINDOWS_CCONV unsafe "windows.h PathFileExistsW" + c_pathFileExists :: CWString -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW" + c_createFile :: CWString + -> Word32 + -> Word32 + -> Ptr () + -> Word32 + -> Word32 + -> Ptr () + -> IO (Ptr ()) + +createFile :: CWString -> IO (Ptr ()) +createFile file = + c_createFile file (#const GENERIC_READ) + (#const FILE_SHARE_READ) + nullPtr + (#const OPEN_EXISTING) + (#const FILE_ATTRIBUTE_NORMAL) + nullPtr + +foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle" + c_closeHandle :: Ptr () -> IO Bool + +foreign import WINDOWS_CCONV unsafe "windows.h GetFinalPathNameByHandleW" + c_getFinalPathHandle :: Ptr () -> CWString -> Word32 -> Word32 -> IO Word32 + -------------------------------------------------------------------------------- -- Fallback to argv[0] diff --git a/libraries/base/System/Exit.hs b/libraries/base/System/Exit.hs index 4f73665c0e..e4f7b13e33 100644 --- a/libraries/base/System/Exit.hs +++ b/libraries/base/System/Exit.hs @@ -47,7 +47,7 @@ import GHC.IO.Exception -- -- As an 'ExitCode' is not an 'IOError', 'exitWith' bypasses -- the error handling in the 'IO' monad and cannot be intercepted by --- 'catch' from the "Prelude". However it is a 'SomeException', and can +-- 'catch' from the "Prelude". However it is a 'Control.Exception.SomeException', and can -- be caught using the functions of "Control.Exception". This means -- that cleanup computations added with 'Control.Exception.bracket' -- (from "Control.Exception") are also executed properly on 'exitWith'. diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs index fde5bb66e5..900963a045 100644 --- a/libraries/base/System/IO.hs +++ b/libraries/base/System/IO.hs @@ -226,6 +226,9 @@ import Data.Maybe import Foreign.C.Error #if defined(mingw32_HOST_OS) import Foreign.C.String +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Storable #endif import Foreign.C.Types import System.Posix.Internals @@ -233,7 +236,9 @@ import System.Posix.Types import GHC.Base import GHC.List +#ifndef mingw32_HOST_OS import GHC.IORef +#endif import GHC.Num import GHC.IO hiding ( bracket, onException ) import GHC.IO.IOMode @@ -376,7 +381,8 @@ hReady h = hWaitForInput h 0 -- -- * 'System.IO.Error.isFullError' if the device is full; or -- --- * 'System.IO.Error.isPermissionError' if another system resource limit would be exceeded. +-- * 'System.IO.Error.isPermissionError' if another system resource limit +-- would be exceeded. hPrint :: Show a => Handle -> a -> IO () hPrint hdl = hPutStrLn hdl . show @@ -386,7 +392,7 @@ hPrint hdl = hPutStrLn hdl . show -- closed on exit from 'withFile', whether by normal termination or by -- raising an exception. If closing the handle raises an exception, then -- this exception will be raised by 'withFile' rather than any exception --- raised by 'act'. +-- raised by @act@. withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r withFile name mode = bracket (openFile name mode) hClose @@ -400,10 +406,15 @@ withBinaryFile name mode = bracket (openBinaryFile name mode) hClose -- --------------------------------------------------------------------------- -- fixIO +-- | The implementation of 'Control.Monad.Fix.mfix' for 'IO'. If the function +-- passed to 'fixIO' inspects its argument, the resulting action will throw +-- 'FixIOException'. fixIO :: (a -> IO a) -> IO a fixIO k = do m <- newEmptyMVar - ans <- unsafeDupableInterleaveIO (readMVar m) + ans <- unsafeDupableInterleaveIO + (readMVar m `catch` \BlockedIndefinitelyOnMVar -> + throwIO FixIOException) result <- k ans putMVar m result return result @@ -473,14 +484,14 @@ openBinaryTempFileWithDefaultPermissions tmp_dir template openTempFile' :: String -> FilePath -> String -> Bool -> CMode -> IO (FilePath, Handle) openTempFile' loc tmp_dir template binary mode - | pathSeparator `elem` template + | pathSeparator template = fail $ "openTempFile': Template string must not contain path separator characters: "++template | otherwise = findTempName where -- We split off the last extension, so we can use .foo.ext files -- for temporary files (hidden on Unix OSes). Unfortunately we're -- below filepath in the hierarchy here. - (prefix,suffix) = + (prefix, suffix) = case break (== '.') $ reverse template of -- First case: template contains no '.'s. Just re-reverse it. (rev_suffix, "") -> (reverse rev_suffix, "") @@ -493,7 +504,52 @@ openTempFile' loc tmp_dir template binary mode -- always return a pair with either the empty string or a string -- beginning with '.' as the second component. _ -> errorWithoutStackTrace "bug in System.IO.openTempFile" - +#if defined(mingw32_HOST_OS) + findTempName = do + let label = if null prefix then "ghc" else prefix + withCWString tmp_dir $ \c_tmp_dir -> + withCWString label $ \c_template -> + withCWString suffix $ \c_suffix -> + -- NOTE: revisit this when new I/O manager in place and use a UUID + -- based one when we are no longer MAX_PATH bound. + allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do + res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0 + c_str + if not res + then do errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + else do filename <- peekCWString c_str + handleResults filename + + handleResults filename = do + let oflags1 = rw_flags .|. o_EXCL + binary_flags + | binary = o_BINARY + | otherwise = 0 + oflags = oflags1 .|. binary_flags + fd <- withFilePath filename $ \ f -> c_open f oflags mode + case fd < 0 of + True -> do errno <- getErrno + ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + False -> + do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-} + False{-is_socket-} + True{-is_nonblock-} + + enc <- getLocaleEncoding + h <- mkHandleFromFD fD fd_type filename ReadWriteMode + False{-set non-block-} (Just enc) + + return (filename, h) + +foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo + :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool + +pathSeparator :: String -> Bool +pathSeparator template = any (\x-> x == '/' || x == '\\') template + +output_flags = std_flags +#else /* else mingw32_HOST_OS */ findTempName = do rs <- rand_string let filename = prefix ++ rs ++ suffix @@ -517,8 +573,8 @@ openTempFile' loc tmp_dir template binary mode combine a b | null b = a | null a = b - | last a == pathSeparator = a ++ b - | otherwise = a ++ [pathSeparator] ++ b + | pathSeparator [last a] = a ++ b + | otherwise = a ++ [pathSeparatorChar] ++ b tempCounter :: IORef Int tempCounter = unsafePerformIO $ newIORef 0 @@ -528,7 +584,7 @@ tempCounter = unsafePerformIO $ newIORef 0 rand_string :: IO String rand_string = do r1 <- c_getpid - r2 <- atomicModifyIORef tempCounter (\n -> (n+1, n)) + (r2, _) <- atomicModifyIORef'_ tempCounter (+1) return $ show r1 ++ "-" ++ show r2 data OpenNewFileResult @@ -552,41 +608,22 @@ openNewFile filepath binary mode = do errno <- getErrno case errno of _ | errno == eEXIST -> return FileExists -#if defined(mingw32_HOST_OS) - -- If c_open throws EACCES on windows, it could mean that filepath is a - -- directory. In this case, we want to return FileExists so that the - -- enclosing openTempFile can try again instead of failing outright. - -- See bug #4968. - _ | errno == eACCES -> do - withCString filepath $ \path -> do - -- There is a race here: the directory might have been moved or - -- deleted between the c_open call and the next line, but there - -- doesn't seem to be any direct way to detect that the c_open call - -- failed because of an existing directory. - exists <- c_fileExists path - return $ if exists - then FileExists - else OpenNewError errno -#endif _ -> return (OpenNewError errno) else return (NewFileCreated fd) -#if defined(mingw32_HOST_OS) -foreign import ccall "file_exists" c_fileExists :: CString -> IO Bool -#endif - -- XXX Should use filepath library -pathSeparator :: Char -#if defined(mingw32_HOST_OS) -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif +pathSeparatorChar :: Char +pathSeparatorChar = '/' + +pathSeparator :: String -> Bool +pathSeparator template = pathSeparatorChar `elem` template + +output_flags = std_flags .|. o_CREAT +#endif /* mingw32_HOST_OS */ -- XXX Copied from GHC.Handle std_flags, output_flags, rw_flags :: CInt std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT rw_flags = output_flags .|. o_RDWR -- $locking @@ -606,4 +643,3 @@ rw_flags = output_flags .|. o_RDWR -- It follows that an attempt to write to a file (using 'writeFile', for -- example) that was earlier opened by 'readFile' will usually result in -- failure with 'System.IO.Error.isAlreadyInUseError'. - diff --git a/libraries/base/System/Mem/StableName.hs b/libraries/base/System/Mem/StableName.hs index dcd527307b..064d928865 100644 --- a/libraries/base/System/Mem/StableName.hs +++ b/libraries/base/System/Mem/StableName.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | @@ -35,72 +32,4 @@ module System.Mem.StableName ( eqStableName ) where -import GHC.IO ( IO(..) ) -import GHC.Base ( Int(..), StableName#, makeStableName# - , eqStableName#, stableNameToInt# ) - ------------------------------------------------------------------------------ --- Stable Names - -{-| - An abstract name for an object, that supports equality and hashing. - - Stable names have the following property: - - * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@ - then @sn1@ and @sn2@ were created by calls to @makeStableName@ on - the same object. - - The reverse is not necessarily true: if two stable names are not - equal, then the objects they name may still be equal. Note in particular - that `makeStableName` may return a different `StableName` after an - object is evaluated. - - Stable Names are similar to Stable Pointers ("Foreign.StablePtr"), - but differ in the following ways: - - * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s. - Stable names are reclaimed by the runtime system when they are no - longer needed. - - * There is no @deRefStableName@ operation. You can\'t get back from - a stable name to the original Haskell object. The reason for - this is that the existence of a stable name for an object does not - guarantee the existence of the object itself; it can still be garbage - collected. --} - -data StableName a = StableName (StableName# a) - --- | Makes a 'StableName' for an arbitrary object. The object passed as --- the first argument is not evaluated by 'makeStableName'. -makeStableName :: a -> IO (StableName a) -makeStableName a = IO $ \ s -> - case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #) - --- | Convert a 'StableName' to an 'Int'. The 'Int' returned is not --- necessarily unique; several 'StableName's may map to the same 'Int' --- (in practice however, the chances of this are small, so the result --- of 'hashStableName' makes a good hash key). -hashStableName :: StableName a -> Int -hashStableName (StableName sn) = I# (stableNameToInt# sn) - --- | @since 2.01 -instance Eq (StableName a) where - (StableName sn1) == (StableName sn2) = - case eqStableName# sn1 sn2 of - 0# -> False - _ -> True - --- | Equality on 'StableName' that does not require that the types of --- the arguments match. --- --- @since 4.7.0.0 -eqStableName :: StableName a -> StableName b -> Bool -eqStableName (StableName sn1) (StableName sn2) = - case eqStableName# sn1 sn2 of - 0# -> False - _ -> True - -- Requested by Emil Axelsson on glasgow-haskell-users, who wants to - -- use it for implementing observable sharing. - +import GHC.StableName diff --git a/libraries/base/System/Timeout.hs b/libraries/base/System/Timeout.hs index d34082e64f..e2b85658bb 100644 --- a/libraries/base/System/Timeout.hs +++ b/libraries/base/System/Timeout.hs @@ -35,9 +35,9 @@ import Data.Unique (Unique, newUnique) -- interrupt the running IO computation when the timeout has -- expired. -newtype Timeout = Timeout Unique deriving (Eq) +newtype Timeout = Timeout Unique deriving Eq -- ^ @since 4.0 --- | @since 3.0 +-- | @since 4.0 instance Show Timeout where show _ = "<<timeout>>" @@ -53,6 +53,12 @@ instance Exception Timeout where -- timeout interval means \"wait indefinitely\". When specifying long timeouts, -- be careful not to exceed @maxBound :: Int@. -- +-- >>> timeout 1000000 (threadDelay 1000 *> pure "finished on time") +-- Just "finished on time" +-- +-- >>> timeout 10000 (threadDelay 100000 *> pure "finished on time") +-- Nothing +-- -- The design of this combinator was guided by the objective that @timeout n f@ -- should behave exactly the same as @f@ as long as @f@ doesn't time out. This -- means that @f@ has the same 'myThreadId' it would have without the timeout @@ -75,7 +81,6 @@ instance Exception Timeout where -- because the runtime system uses scheduling mechanisms like @select(2)@ to -- perform asynchronous I\/O, so it is possible to interrupt standard socket -- I\/O or file I\/O using this combinator. - timeout :: Int -> IO a -> IO (Maybe a) timeout n f | n < 0 = fmap Just f |