{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.IO
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  portable
--
-- The standard IO library.
--
-----------------------------------------------------------------------------

module System.IO (
    -- * The IO monad

    IO,
    fixIO,

    -- * Files and handles

    FilePath,

    Handle,             -- abstract, instance of: Eq, Show.

    -- | GHC note: a 'Handle' will be automatically closed when the garbage
    -- collector detects that it has become unreferenced by the program.
    -- However, relying on this behaviour is not generally recommended:
    -- the garbage collector is unpredictable.  If possible, use
    -- an explicit 'hClose' to close 'Handle's when they are no longer
    -- required.  GHC does not currently attempt to free up file
    -- descriptors when they have run out, it is your responsibility to
    -- ensure that this doesn't happen.

    -- ** Standard handles

    -- | Three handles are allocated during program initialisation,
    -- and are initially open.

    stdin, stdout, stderr,

    -- * Opening and closing files

    -- ** Opening files

    withFile,
    openFile,
    IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),

    -- ** Closing files

    hClose,

    -- ** Special cases

    -- | These functions are also exported by the "Prelude".

    readFile,
    readFile',
    writeFile,
    appendFile,

    -- ** File locking

    -- $locking

    -- * Operations on handles

    -- ** Determining and changing the size of a file

    hFileSize,
    hSetFileSize,

    -- ** Detecting the end of input

    hIsEOF,
    isEOF,

    -- ** Buffering operations

    BufferMode(NoBuffering,LineBuffering,BlockBuffering),
    hSetBuffering,
    hGetBuffering,
    hFlush,

    -- ** Repositioning handles

    hGetPosn,
    hSetPosn,
    HandlePosn,                -- abstract, instance of: Eq, Show.

    hSeek,
    SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
    hTell,

    -- ** Handle properties

    hIsOpen, hIsClosed,
    hIsReadable, hIsWritable,
    hIsSeekable,

    -- ** Terminal operations (not portable: GHC only)

    hIsTerminalDevice,

    hSetEcho,
    hGetEcho,

    -- ** Showing handle state (not portable: GHC only)

    hShow,

    -- * Text input and output

    -- ** Text input

    hWaitForInput,
    hReady,
    hGetChar,
    hGetLine,
    hLookAhead,
    hGetContents,
    hGetContents',

    -- ** Text output

    hPutChar,
    hPutStr,
    hPutStrLn,
    hPrint,

    -- ** Special cases for standard input and output

    -- | These functions are also exported by the "Prelude".

    interact,
    putChar,
    putStr,
    putStrLn,
    print,
    getChar,
    getLine,
    getContents,
    getContents',
    readIO,
    readLn,

    -- * Binary input and output

    withBinaryFile,
    openBinaryFile,
    hSetBinaryMode,
    hPutBuf,
    hGetBuf,
    hGetBufSome,
    hPutBufNonBlocking,
    hGetBufNonBlocking,

    -- * Temporary files

    openTempFile,
    openBinaryTempFile,
    openTempFileWithDefaultPermissions,
    openBinaryTempFileWithDefaultPermissions,

    -- * Unicode encoding\/decoding

    -- | A text-mode 'Handle' has an associated 'TextEncoding', which
    -- is used to decode bytes into Unicode characters when reading,
    -- and encode Unicode characters into bytes when writing.
    --
    -- The default 'TextEncoding' is the same as the default encoding
    -- on your system, which is also available as 'localeEncoding'.
    -- (GHC note: on Windows, we currently do not support double-byte
    -- encodings; if the console\'s code page is unsupported, then
    -- 'localeEncoding' will be 'latin1'.)
    --
    -- Encoding and decoding errors are always detected and reported,
    -- except during lazy I/O ('hGetContents', 'getContents', and
    -- 'readFile'), where a decoding error merely results in
    -- termination of the character stream, as with other I/O errors.

    hSetEncoding,
    hGetEncoding,

    -- ** Unicode encodings
    TextEncoding,
    latin1,
    utf8, utf8_bom,
    utf16, utf16le, utf16be,
    utf32, utf32le, utf32be,
    localeEncoding,
    char8,
    mkTextEncoding,

    -- * Newline conversion

    -- | In Haskell, a newline is always represented by the character
    -- @\'\\n\'@.  However, in files and external character streams, a
    -- newline may be represented by another character sequence, such
    -- as @\'\\r\\n\'@.
    --
    -- A text-mode 'Handle' has an associated 'NewlineMode' that
    -- specifies how to translate newline characters.  The
    -- 'NewlineMode' specifies the input and output translation
    -- separately, so that for instance you can translate @\'\\r\\n\'@
    -- to @\'\\n\'@ on input, but leave newlines as @\'\\n\'@ on output.
    --
    -- The default 'NewlineMode' for a 'Handle' is
    -- 'nativeNewlineMode', which does no translation on Unix systems,
    -- but translates @\'\\r\\n\'@ to @\'\\n\'@ and back on Windows.
    --
    -- Binary-mode 'Handle's do no newline translation at all.
    --
    hSetNewlineMode,
    Newline(..), nativeNewline,
    NewlineMode(..),
    noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
  ) where

import Control.Exception.Base

import Data.Bits
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.Marshal.Utils (with)
import Foreign.Storable
import GHC.IO.SubSystem
import GHC.IO.Windows.Handle (openFileAsTemp)
import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
import GHC.IO.Device as IODevice
import GHC.Real (fromIntegral)
#endif
import Foreign.C.Types
import System.Posix.Internals
import System.Posix.Types

import GHC.Base
import GHC.List
#if !defined(mingw32_HOST_OS)
import GHC.IORef
#endif
import GHC.Num
import GHC.IO hiding ( bracket, onException )
import GHC.IO.IOMode
import qualified GHC.IO.FD as FD
import GHC.IO.Handle
import qualified GHC.IO.Handle.FD as POSIX
import GHC.IO.Handle.Text ( hGetBufSome, hPutStrLn )
import GHC.IO.Exception ( userError )
import GHC.IO.Encoding
import Text.Read
import GHC.IO.StdHandles
import GHC.Show
import GHC.MVar

-- -----------------------------------------------------------------------------
-- Standard IO

-- | Write a character to the standard output device
-- (same as 'hPutChar' 'stdout').

putChar         :: Char -> IO ()
putChar :: Char -> IO ()
putChar Char
c       =  Handle -> Char -> IO ()
hPutChar Handle
stdout Char
c

-- | Write a string to the standard output device
-- (same as 'hPutStr' 'stdout').

putStr          :: String -> IO ()
putStr :: String -> IO ()
putStr String
s        =  Handle -> String -> IO ()
hPutStr Handle
stdout String
s

-- | The same as 'putStr', but adds a newline character.

putStrLn        :: String -> IO ()
putStrLn :: String -> IO ()
putStrLn String
s      =  Handle -> String -> IO ()
hPutStrLn Handle
stdout String
s

-- | The 'print' function outputs a value of any printable type to the
-- standard output device.
-- Printable types are those that are instances of class 'Show'; 'print'
-- converts values to strings for output using the 'show' operation and
-- adds a newline.
--
-- For example, a program to print the first 20 integers and their
-- powers of 2 could be written as:
--
-- > main = print ([(n, 2^n) | n <- [0..19]])

print           :: Show a => a -> IO ()
print :: forall a. Show a => a -> IO ()
print a
x         =  String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
x)

-- | Read a character from the standard input device
-- (same as 'hGetChar' 'stdin').

getChar         :: IO Char
getChar :: IO Char
getChar         =  Handle -> IO Char
hGetChar Handle
stdin

-- | Read a line from the standard input device
-- (same as 'hGetLine' 'stdin').

getLine         :: IO String
getLine :: IO String
getLine         =  Handle -> IO String
hGetLine Handle
stdin

-- | The 'getContents' operation returns all user input as a single string,
-- which is read lazily as it is needed
-- (same as 'hGetContents' 'stdin').

getContents     :: IO String
getContents :: IO String
getContents     =  Handle -> IO String
hGetContents Handle
stdin

-- | The 'getContents'' operation returns all user input as a single string,
-- which is fully read before being returned
-- (same as 'hGetContents'' 'stdin').
--
-- @since 4.15.0.0

getContents'    :: IO String
getContents' :: IO String
getContents'    =  Handle -> IO String
hGetContents' Handle
stdin

-- | The 'interact' function takes a function of type @String->String@
-- as its argument.  The entire input from the standard input device is
-- passed to this function as its argument, and the resulting string is
-- output on the standard output device.

interact        ::  (String -> String) -> IO ()
interact :: (String -> String) -> IO ()
interact String -> String
f      =   do String
s <- IO String
getContents
                       String -> IO ()
putStr (String -> String
f String
s)

-- | The 'readFile' function reads a file and
-- returns the contents of the file as a string.
-- The file is read lazily, on demand, as with 'getContents'.

readFile        :: FilePath -> IO String
readFile :: String -> IO String
readFile String
name   =  String -> IOMode -> IO Handle
openFile String
name IOMode
ReadMode IO Handle -> (Handle -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> IO String
hGetContents

-- | The 'readFile'' function reads a file and
-- returns the contents of the file as a string.
-- The file is fully read before being returned, as with 'getContents''.
--
-- @since 4.15.0.0

readFile'       :: FilePath -> IO String
-- There's a bit of overkill here—both withFile and
-- hGetContents' will close the file in the end.
readFile' :: String -> IO String
readFile' String
name  =  String -> IOMode -> (Handle -> IO String) -> IO String
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
name IOMode
ReadMode Handle -> IO String
hGetContents'

-- | The computation 'writeFile' @file str@ function writes the string @str@,
-- to the file @file@.
writeFile :: FilePath -> String -> IO ()
writeFile :: String -> String -> IO ()
writeFile String
f String
txt = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
WriteMode (\ Handle
hdl -> Handle -> String -> IO ()
hPutStr Handle
hdl String
txt)

-- | The computation 'appendFile' @file str@ function appends the string @str@,
-- to the file @file@.
--
-- Note that 'writeFile' and 'appendFile' write a literal string
-- to a file.  To write a value of any printable type, as with 'print',
-- use the 'show' function to convert the value to a string first.
--
-- > main = appendFile "squares" (show [(x,x*x) | x <- [0,0.1..2]])

appendFile      :: FilePath -> String -> IO ()
appendFile :: String -> String -> IO ()
appendFile String
f String
txt = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
f IOMode
AppendMode (\ Handle
hdl -> Handle -> String -> IO ()
hPutStr Handle
hdl String
txt)

-- | The 'readLn' function combines 'getLine' and 'readIO'.

readLn :: Read a => IO a
readLn :: forall a. Read a => IO a
readLn = IO String
getLine IO String -> (String -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO a
forall a. Read a => String -> IO a
readIO

-- | The 'readIO' function is similar to 'read' except that it signals
-- parse failure to the 'IO' monad instead of terminating the program.

readIO          :: Read a => String -> IO a
readIO :: forall a. Read a => String -> IO a
readIO String
s        =  case (do { (a
x,String
t) <- ReadS a
forall a. Read a => ReadS a
reads String
s ;
                              (String
"",String
"") <- ReadS String
lex String
t ;
                              a -> [a]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return a
x }) of
                        [a
x]    -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
                        []     -> IOError -> IO a
forall a. IOError -> IO a
ioError (String -> IOError
userError String
"Prelude.readIO: no parse")
                        [a]
_      -> IOError -> IO a
forall a. IOError -> IO a
ioError (String -> IOError
userError String
"Prelude.readIO: ambiguous parse")

-- | The Unicode encoding of the current locale
--
-- This is the initial locale encoding: if it has been subsequently changed by
-- 'GHC.IO.Encoding.setLocaleEncoding' this value will not reflect that change.
localeEncoding :: TextEncoding
localeEncoding :: TextEncoding
localeEncoding = TextEncoding
initLocaleEncoding

-- | Computation 'hReady' @hdl@ indicates whether at least one item is
-- available for input from handle @hdl@.
--
-- This operation may fail with:
--
--  * 'System.IO.Error.isEOFError' if the end of file has been reached.

hReady          :: Handle -> IO Bool
hReady :: Handle -> IO Bool
hReady Handle
h        =  Handle -> Int -> IO Bool
hWaitForInput Handle
h Int
0

-- | Computation 'hPrint' @hdl t@ writes the string representation of @t@
-- given by the 'shows' function to the file or channel managed by @hdl@
-- and appends a newline.
--
-- This operation may fail with:
--
--  * 'System.IO.Error.isFullError' if the device is full; or
--
--  * 'System.IO.Error.isPermissionError' if another system resource limit
--    would be exceeded.

hPrint          :: Show a => Handle -> a -> IO ()
hPrint :: forall a. Show a => Handle -> a -> IO ()
hPrint Handle
hdl      =  Handle -> String -> IO ()
hPutStrLn Handle
hdl (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show


-- ---------------------------------------------------------------------------
-- 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 :: forall a. (a -> IO a) -> IO a
fixIO a -> IO a
k = do
    MVar a
m <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
    a
ans <- IO a -> IO a
forall a. IO a -> IO a
unsafeDupableInterleaveIO
             (MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
m IO a -> (BlockedIndefinitelyOnMVar -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar ->
                                    FixIOException -> IO a
forall e a. Exception e => e -> IO a
throwIO FixIOException
FixIOException)
    a
result <- a -> IO a
k a
ans
    MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
result
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

-- Note [Blackholing in fixIO]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- We do our own explicit black holing here, because GHC's lazy
-- blackholing isn't enough.  In an infinite loop, GHC may run the IO
-- computation a few times before it notices the loop, which is wrong.
--
-- NOTE2: the explicit black-holing with an IORef ran into trouble
-- with multiple threads (see #5421), so now we use an MVar. We used
-- to use takeMVar with unsafeInterleaveIO. This, however, uses noDuplicate#,
-- which is not particularly cheap. Better to use readMVar, which can be
-- performed in multiple threads safely, and to use unsafeDupableInterleaveIO
-- to avoid the noDuplicate cost.
--
-- What we'd ideally want is probably an IVar, but we don't quite have those.
-- STM TVars look like an option at first, but I don't think they are:
-- we'd need to be able to write to the variable in an IO context, which can
-- only be done using 'atomically', and 'atomically' is not allowed within
-- unsafePerformIO. We can't know if someone will try to use the result
-- of fixIO with unsafePerformIO!
--
-- See also System.IO.Unsafe.unsafeFixIO.
--

-- | The function creates a temporary file in ReadWrite mode.
-- The created file isn\'t deleted automatically, so you need to delete it manually.
--
-- The file is created with permissions such that only the current
-- user can read\/write it.
--
-- With some exceptions (see below), the file will be created securely
-- in the sense that an attacker should not be able to cause
-- openTempFile to overwrite another file on the filesystem using your
-- credentials, by putting symbolic links (on Unix) in the place where
-- the temporary file is to be created.  On Unix the @O_CREAT@ and
-- @O_EXCL@ flags are used to prevent this attack, but note that
-- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you
-- rely on this behaviour it is best to use local filesystems only.
--
openTempFile :: FilePath   -- ^ Directory in which to create the file
             -> String     -- ^ File name template. If the template is \"foo.ext\" then
                           -- the created file will be \"fooXXX.ext\" where XXX is some
                           -- random number. Note that this should not contain any path
                           -- separator characters. On Windows, the template prefix may
                           -- be truncated to 3 chars, e.g. \"foobar.ext\" will be
                           -- \"fooXXX.ext\".
             -> IO (FilePath, Handle)
openTempFile :: String -> String -> IO (String, Handle)
openTempFile String
tmp_dir String
template
    = String -> String -> String -> Bool -> CMode -> IO (String, Handle)
openTempFile' String
"openTempFile" String
tmp_dir String
template Bool
False CMode
0o600

-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
openBinaryTempFile :: String -> String -> IO (String, Handle)
openBinaryTempFile String
tmp_dir String
template
    = String -> String -> String -> Bool -> CMode -> IO (String, Handle)
openTempFile' String
"openBinaryTempFile" String
tmp_dir String
template Bool
True CMode
0o600

-- | Like 'openTempFile', but uses the default file permissions
openTempFileWithDefaultPermissions :: FilePath -> String
                                   -> IO (FilePath, Handle)
openTempFileWithDefaultPermissions :: String -> String -> IO (String, Handle)
openTempFileWithDefaultPermissions String
tmp_dir String
template
    = String -> String -> String -> Bool -> CMode -> IO (String, Handle)
openTempFile' String
"openTempFileWithDefaultPermissions" String
tmp_dir String
template Bool
False CMode
0o666

-- | Like 'openBinaryTempFile', but uses the default file permissions
openBinaryTempFileWithDefaultPermissions :: FilePath -> String
                                         -> IO (FilePath, Handle)
openBinaryTempFileWithDefaultPermissions :: String -> String -> IO (String, Handle)
openBinaryTempFileWithDefaultPermissions String
tmp_dir String
template
    = String -> String -> String -> Bool -> CMode -> IO (String, Handle)
openTempFile' String
"openBinaryTempFileWithDefaultPermissions" String
tmp_dir String
template Bool
True CMode
0o666

openTempFile' :: String -> FilePath -> String -> Bool -> CMode
              -> IO (FilePath, Handle)
openTempFile' :: String -> String -> String -> Bool -> CMode -> IO (String, Handle)
openTempFile' String
loc String
tmp_dir String
template Bool
binary CMode
mode
    | String -> Bool
pathSeparator String
template
    = String -> IO (String, Handle)
forall a. String -> IO a
failIO (String -> IO (String, Handle)) -> String -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ String
"openTempFile': Template string must not contain path separator characters: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
template
    | Bool
otherwise = IO (String, Handle)
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.
    (String
prefix, String
suffix) =
       case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
template of
         -- First case: template contains no '.'s. Just re-reverse it.
         (String
rev_suffix, String
"")       -> (String -> String
forall a. [a] -> [a]
reverse String
rev_suffix, String
"")
         -- Second case: template contains at least one '.'. Strip the
         -- dot from the prefix and prepend it to the suffix (if we don't
         -- do this, the unique number will get added after the '.' and
         -- thus be part of the extension, which is wrong.)
         (String
rev_suffix, Char
'.':String
rest) -> (String -> String
forall a. [a] -> [a]
reverse String
rest, Char
'.'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
forall a. [a] -> [a]
reverse String
rev_suffix)
         -- Otherwise, something is wrong, because (break (== '.')) should
         -- always return a pair with either the empty string or a string
         -- beginning with '.' as the second component.
         (String, String)
_                      -> String -> (String, String)
forall a. String -> a
errorWithoutStackTrace String
"bug in System.IO.openTempFile"
#if defined(mingw32_HOST_OS)
    findTempName :: IO (String, Handle)
findTempName = IO (String, Handle)
findTempNamePosix IO (String, Handle) -> IO (String, Handle) -> IO (String, Handle)
forall a. a -> a -> a
<!> IO (String, Handle)
findTempNameWinIO

    findTempNameWinIO :: IO (String, Handle)
findTempNameWinIO = do
      let label :: String
label = if String -> Bool
forall a. [a] -> Bool
null String
prefix then String
"ghc" else String
prefix
      String
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
tmp_dir ((Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle))
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
c_tmp_dir ->
        String
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
label ((Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle))
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
c_template ->
          String
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
suffix ((Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle))
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
c_suffix ->
            Ptr CWchar
-> (Ptr (Ptr CWchar) -> IO (String, Handle)) -> IO (String, Handle)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Ptr CWchar
forall a. Ptr a
nullPtr ((Ptr (Ptr CWchar) -> IO (String, Handle)) -> IO (String, Handle))
-> (Ptr (Ptr CWchar) -> IO (String, Handle)) -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CWchar)
c_ptr -> do
              Bool
res <- Ptr CWchar
-> Ptr CWchar -> Ptr CWchar -> Ptr (Ptr CWchar) -> IO Bool
c_createUUIDTempFileErrNo Ptr CWchar
c_tmp_dir Ptr CWchar
c_template Ptr CWchar
c_suffix Ptr (Ptr CWchar)
c_ptr
              if Bool -> Bool
not Bool
res
                 then do Errno
errno <- IO Errno
getErrno
                         IOError -> IO (String, Handle)
forall a. IOError -> IO a
ioError (String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
loc Errno
errno Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
tmp_dir))
                 else do Ptr CWchar
c_p <- Ptr (Ptr CWchar) -> IO (Ptr CWchar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CWchar)
c_ptr
                         String
filename <- Ptr CWchar -> IO String
peekCWString Ptr CWchar
c_p
                         Ptr CWchar -> IO ()
forall a. Ptr a -> IO ()
free Ptr CWchar
c_p
                         let flags :: CInt
flags = CMode -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CMode
mode CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.&. CInt
o_EXCL
                         String -> Bool -> IO (String, Handle)
handleResultsWinIO String
filename (CInt
flags CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
o_EXCL)

    findTempNamePosix :: IO (String, Handle)
findTempNamePosix = do
      let label :: String
label = if String -> Bool
forall a. [a] -> Bool
null String
prefix then String
"ghc" else String
prefix
      String
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
tmp_dir ((Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle))
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
c_tmp_dir ->
        String
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
label ((Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle))
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
c_template ->
          String
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withCWString String
suffix ((Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle))
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
c_suffix ->
            Int -> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (CWchar -> Int
forall a. Storable a => a -> Int
sizeOf (CWchar
forall a. HasCallStack => a
undefined :: CWchar) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
260) ((Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle))
-> (Ptr CWchar -> IO (String, Handle)) -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ \Ptr CWchar
c_str -> do
            Bool
res <- Ptr CWchar
-> Ptr CWchar -> Ptr CWchar -> CUInt -> Ptr CWchar -> IO Bool
c_getTempFileNameErrorNo Ptr CWchar
c_tmp_dir Ptr CWchar
c_template Ptr CWchar
c_suffix CUInt
0
                                            Ptr CWchar
c_str
            if Bool -> Bool
not Bool
res
               then do Errno
errno <- IO Errno
getErrno
                       IOError -> IO (String, Handle)
forall a. IOError -> IO a
ioError (String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
loc Errno
errno Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
tmp_dir))
               else do String
filename <- Ptr CWchar -> IO String
peekCWString Ptr CWchar
c_str
                       String -> IO (String, Handle)
handleResultsPosix String
filename

    handleResultsPosix :: String -> IO (String, Handle)
handleResultsPosix String
filename = do
      let oflags1 :: CInt
oflags1 = CInt
rw_flags CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_EXCL
          binary_flags :: CInt
binary_flags
              | Bool
binary    = CInt
o_BINARY
              | Bool
otherwise = CInt
0
          oflags :: CInt
oflags = CInt
oflags1 CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
binary_flags
      CInt
fd <- String -> (Ptr CWchar -> IO CInt) -> IO CInt
forall a. String -> (Ptr CWchar -> IO a) -> IO a
withFilePath String
filename ((Ptr CWchar -> IO CInt) -> IO CInt)
-> (Ptr CWchar -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \ Ptr CWchar
f -> Ptr CWchar -> CInt -> CMode -> IO CInt
c_open Ptr CWchar
f CInt
oflags CMode
mode
      case CInt
fd CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0 of
        Bool
True -> do Errno
errno <- IO Errno
getErrno
                   IOError -> IO (String, Handle)
forall a. IOError -> IO a
ioError (String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
loc Errno
errno Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
tmp_dir))
        Bool
False ->
          do (FD
fD,IODeviceType
fd_type) <- CInt
-> IOMode
-> Maybe (IODeviceType, CDev, CIno)
-> Bool
-> Bool
-> IO (FD, IODeviceType)
FD.mkFD CInt
fd IOMode
ReadWriteMode Maybe (IODeviceType, CDev, CIno)
forall a. Maybe a
Nothing{-no stat-}
                                     Bool
False{-is_socket-}
                                     Bool
True{-is_nonblock-}

             TextEncoding
enc <- IO TextEncoding
getLocaleEncoding
             Handle
h <- FD
-> IODeviceType
-> String
-> IOMode
-> Bool
-> Maybe TextEncoding
-> IO Handle
POSIX.mkHandleFromFD FD
fD IODeviceType
fd_type String
filename IOMode
ReadWriteMode
                                 Bool
False{-set non-block-} (TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just TextEncoding
enc)

             (String, Handle) -> IO (String, Handle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
filename, Handle
h)

    handleResultsWinIO :: String -> Bool -> IO (String, Handle)
handleResultsWinIO String
filename Bool
excl = do
      (Io NativeHandle
hwnd, IODeviceType
hwnd_type) <- String -> Bool -> Bool -> IO (Io NativeHandle, IODeviceType)
openFileAsTemp String
filename Bool
True Bool
excl
      Maybe TextEncoding
mb_codec <- if Bool
binary then Maybe TextEncoding -> IO (Maybe TextEncoding)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TextEncoding
forall a. Maybe a
Nothing else (TextEncoding -> Maybe TextEncoding)
-> IO TextEncoding -> IO (Maybe TextEncoding)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just IO TextEncoding
getLocaleEncoding

      -- then use it to make a Handle
      Handle
h <- Io NativeHandle
-> IODeviceType
-> String
-> IOMode
-> Maybe TextEncoding
-> IO Handle
forall dev.
(RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> IODeviceType
-> String
-> IOMode
-> Maybe TextEncoding
-> IO Handle
mkHandleFromHANDLE Io NativeHandle
hwnd IODeviceType
hwnd_type String
filename IOMode
ReadWriteMode Maybe TextEncoding
mb_codec
                IO Handle -> IO () -> IO Handle
forall a b. IO a -> IO b -> IO a
`onException` Io NativeHandle -> IO ()
forall a. IODevice a => a -> IO ()
IODevice.close Io NativeHandle
hwnd
      (String, Handle) -> IO (String, Handle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
filename, Handle
h)

foreign import ccall "getTempFileNameErrorNo" c_getTempFileNameErrorNo
  :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool

foreign import ccall "__createUUIDTempFileErrNo" c_createUUIDTempFileErrNo
  :: CWString -> CWString -> CWString -> Ptr CWString -> IO Bool

pathSeparator :: String -> Bool
pathSeparator :: String -> Bool
pathSeparator String
template = (Char -> Bool) -> String -> Bool
forall a. (a -> Bool) -> [a] -> Bool
any (\Char
x-> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\') String
template

output_flags :: CInt
output_flags = CInt
std_flags
#else /* else mingw32_HOST_OS */
    findTempName = do
      rs <- rand_string
      let filename = prefix ++ rs ++ suffix
          filepath = tmp_dir `combine` filename
      r <- openNewFile filepath binary mode
      case r of
        FileExists -> findTempName
        OpenNewError errno -> ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
        NewFileCreated fd -> do
          (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}
                               False{-is_socket-}
                               True{-is_nonblock-}

          enc <- getLocaleEncoding
          h <- POSIX.mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} (Just enc)

          return (filepath, h)

      where
        -- XXX bits copied from System.FilePath, since that's not available here
        combine a b
                  | null b = a
                  | null a = b
                  | pathSeparator [last a] = a ++ b
                  | otherwise = a ++ [pathSeparatorChar] ++ b

tempCounter :: IORef Int
tempCounter = unsafePerformIO $ newIORef 0
{-# NOINLINE tempCounter #-}

-- build large digit-alike number
rand_string :: IO String
rand_string = do
  r1 <- c_getpid
  (r2, _) <- atomicModifyIORef'_ tempCounter (+1)
  return $ show r1 ++ "-" ++ show r2

data OpenNewFileResult
  = NewFileCreated CInt
  | FileExists
  | OpenNewError Errno

openNewFile :: FilePath -> Bool -> CMode -> IO OpenNewFileResult
openNewFile filepath binary mode = do
  let oflags1 = rw_flags .|. o_EXCL

      binary_flags
        | binary    = o_BINARY
        | otherwise = 0

      oflags = oflags1 .|. binary_flags
  fd <- withFilePath filepath $ \ f ->
          c_open f oflags mode
  if fd < 0
    then do
      errno <- getErrno
      case errno of
        _ | errno == eEXIST -> return FileExists
        _ -> return (OpenNewError errno)
    else return (NewFileCreated fd)

-- XXX Should use filepath library
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 :: CInt
std_flags    = CInt
o_NONBLOCK   CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_NOCTTY
rw_flags :: CInt
rw_flags     = CInt
output_flags CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
o_RDWR

-- $locking
-- Implementations should enforce as far as possible, at least locally to the
-- Haskell process, multiple-reader single-writer locking on files.
-- That is, /there may either be many handles on the same file which manage input, or just one handle on the file which manages output/.  If any
-- open or semi-closed handle is managing a file for output, no new
-- handle can be allocated for that file.  If any open or semi-closed
-- handle is managing a file for input, new handles can only be allocated
-- if they do not manage output.  Whether two files are the same is
-- implementation-dependent, but they should normally be the same if they
-- have the same absolute path name and neither has been renamed, for
-- example.
--
-- /Warning/: the 'readFile' operation holds a semi-closed handle on
-- the file until the entire contents of the file have been consumed.
-- 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'.