{-# LINE 1 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
{-# LANGUAGE Trustworthy          #-}
{-# LANGUAGE CPP                  #-}
{-# LANGUAGE NoImplicitPrelude    #-}
{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE FlexibleContexts     #-}
-- Whether there are identities depends on the platform

{-# OPTIONS_HADDOCK hide #-}

-----------------------------------------------------------------------------

-- |

-- Module      :  GHC.Internal.IO.Windows.Handle

-- Copyright   :  (c) The University of Glasgow, 2017

-- License     :  see libraries/base/LICENSE

--

-- Maintainer  :  libraries@haskell.org

-- Stability   :  internal

-- Portability :  non-portable

--

-- Raw read/write operations on Windows Handles

--

-----------------------------------------------------------------------------


module GHC.Internal.IO.Windows.Handle
 ( -- * Basic Types

   NativeHandle(),
   ConsoleHandle(),
   IoHandle(),
   HANDLE,
   Io(),

   -- * Utility functions

   convertHandle,
   toHANDLE,
   fromHANDLE,
   handleToMode,
   isAsynchronous,
   optimizeFileAccess,

   -- * Standard Handles

   stdin,
   stdout,
   stderr,

   -- * File utilities

   openFile,
   openFileAsTemp,
   release
 ) where





-- Can't avoid these semantics leaks, they are base constructs

import GHC.Internal.Data.Bits ((.|.), (.&.), shiftL)
import GHC.Internal.Data.Functor ((<$>))
import GHC.Internal.Data.Typeable

import GHC.Internal.Base
import GHC.Internal.Enum
import GHC.Internal.Num
import GHC.Internal.Real
import GHC.Internal.List
import GHC.Internal.Word (Word8, Word16, Word64)

import GHC.Internal.IO hiding (mask)
import GHC.Internal.IO.Buffer
import GHC.Internal.IO.BufferedIO
import qualified GHC.Internal.IO.Device as GHC.IO.Device
import GHC.Internal.IO.Device (SeekMode(..), IODeviceType(..), IODevice(), devType, setSize)
import GHC.Internal.IO.Exception
import GHC.Internal.IO.IOMode
import GHC.Internal.IO.Windows.Encoding (withGhcInternalToUTF16, withUTF16ToGhcInternal)
import GHC.Internal.IO.Windows.Paths (getDevicePath)
import GHC.Internal.IO.Handle.Internals (debugIO)
import GHC.Internal.IORef
import GHC.Internal.Event.Windows (LPOVERLAPPED, withOverlappedEx, IOResult(..))
import GHC.Internal.Foreign.Ptr
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.C.Error
import GHC.Internal.Foreign.C.String
import GHC.Internal.Foreign.Marshal.Array (pokeArray)
import GHC.Internal.Foreign.Marshal.Alloc (alloca, allocaBytes)
import GHC.Internal.Foreign.Marshal.Utils (with, fromBool)
import GHC.Internal.Foreign.Storable (Storable (..))
import qualified GHC.Internal.Event.Windows as Mgr

import GHC.Internal.Windows (LPVOID, LPDWORD, DWORD, HANDLE, BOOL, LPCTSTR, ULONG, WORD,
                             UCHAR, failIf, iNVALID_HANDLE_VALUE, failWith,
                             failIfFalse_, getLastError)
import GHC.Internal.Text.Show

-- -----------------------------------------------------------------------------

-- The Windows IO device handles


data NativeHandle
data ConsoleHandle

-- | Bit of a Hack, but we don't want every handle to have a cooked entry

--   but all copies of the handles for which we do want one need to share

--   the same value.

--   We can't store it separately because we don't know when the handle will

--   be destroyed or invalidated.

data IoHandle a where
  NativeHandle  :: { IoHandle NativeHandle -> HANDLE
getNativeHandle  :: HANDLE
                   -- In certain cases we have inherited a handle and the

                   -- handle and it may not have been created for async

                   -- access.  In those case we can't issue a completion

                   -- request as it would never finish and we'd deadlock.

                   , IoHandle NativeHandle -> Bool
isAsynchronous :: Bool } -> IoHandle NativeHandle
  ConsoleHandle :: { Io ConsoleHandle -> HANDLE
getConsoleHandle :: HANDLE
                   , Io ConsoleHandle -> IORef Bool
cookedHandle :: IORef Bool
                   } -> IoHandle ConsoleHandle

type Io a = IoHandle a

-- | Convert a ConsoleHandle into a general FileHandle

--   This will change which DeviceIO is used.

convertHandle :: Io ConsoleHandle -> Bool -> Io NativeHandle
convertHandle :: Io ConsoleHandle -> Bool -> IoHandle NativeHandle
convertHandle Io ConsoleHandle
io Bool
async
  = let !hwnd :: HANDLE
hwnd = Io ConsoleHandle -> HANDLE
getConsoleHandle Io ConsoleHandle
io
    in HANDLE -> Bool -> IoHandle NativeHandle
NativeHandle HANDLE
hwnd Bool
async

-- | @since base-4.11.0.0

instance Show (Io NativeHandle) where
  show :: IoHandle NativeHandle -> String
show = HANDLE -> String
forall a. Show a => a -> String
show (HANDLE -> String)
-> (IoHandle NativeHandle -> HANDLE)
-> IoHandle NativeHandle
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IoHandle NativeHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE

-- | @since base-4.11.0.0

instance Show (Io ConsoleHandle) where
  show :: Io ConsoleHandle -> String
show = HANDLE -> String
forall a. Show a => a -> String
show (HANDLE -> String)
-> (Io ConsoleHandle -> HANDLE) -> Io ConsoleHandle -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Io ConsoleHandle -> HANDLE
getConsoleHandle

-- | @since base-4.11.0.0

instance GHC.IO.Device.RawIO (Io NativeHandle) where
  read :: IoHandle NativeHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
read             = IoHandle NativeHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
hwndRead
  readNonBlocking :: IoHandle NativeHandle
-> Ptr UCHAR -> Word64 -> Int -> IO (Maybe Int)
readNonBlocking  = IoHandle NativeHandle
-> Ptr UCHAR -> Word64 -> Int -> IO (Maybe Int)
hwndReadNonBlocking
  write :: IoHandle NativeHandle -> Ptr UCHAR -> Word64 -> Int -> IO ()
write            = IoHandle NativeHandle -> Ptr UCHAR -> Word64 -> Int -> IO ()
hwndWrite
  writeNonBlocking :: IoHandle NativeHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
writeNonBlocking = IoHandle NativeHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
hwndWriteNonBlocking

-- | @since base-4.11.0.0

instance GHC.IO.Device.RawIO (Io ConsoleHandle) where
  read :: Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
read             = Bool -> Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
consoleRead Bool
True
  readNonBlocking :: Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO (Maybe Int)
readNonBlocking  = Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO (Maybe Int)
consoleReadNonBlocking
  write :: Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO ()
write            = Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO ()
consoleWrite
  writeNonBlocking :: Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
writeNonBlocking = Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
consoleWriteNonBlocking

-- | Generalize a way to get and create handles.

class (GHC.IO.Device.RawIO a, IODevice a, BufferedIO a, Typeable a)
      => RawHandle a where
  toHANDLE   :: a -> HANDLE
  fromHANDLE :: HANDLE -> a
  isLockable :: a -> Bool
  setCooked  :: a -> Bool -> IO a
  isCooked   :: a -> IO Bool

instance RawHandle (Io NativeHandle) where
  toHANDLE :: IoHandle NativeHandle -> HANDLE
toHANDLE     = IoHandle NativeHandle -> HANDLE
getNativeHandle
  -- In order to convert to a native handle we have to check to see

  -- is the handle can be used async or not.

  fromHANDLE :: HANDLE -> IoHandle NativeHandle
fromHANDLE   = (HANDLE -> Bool -> IoHandle NativeHandle)
-> Bool -> HANDLE -> IoHandle NativeHandle
forall a b c. (a -> b -> c) -> b -> a -> c
flip HANDLE -> Bool -> IoHandle NativeHandle
NativeHandle Bool
True
  isLockable :: IoHandle NativeHandle -> Bool
isLockable IoHandle NativeHandle
_ = Bool
True
  setCooked :: IoHandle NativeHandle -> Bool -> IO (IoHandle NativeHandle)
setCooked    = IO (IoHandle NativeHandle) -> Bool -> IO (IoHandle NativeHandle)
forall a b. a -> b -> a
const (IO (IoHandle NativeHandle) -> Bool -> IO (IoHandle NativeHandle))
-> (IoHandle NativeHandle -> IO (IoHandle NativeHandle))
-> IoHandle NativeHandle
-> Bool
-> IO (IoHandle NativeHandle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IoHandle NativeHandle -> IO (IoHandle NativeHandle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  isCooked :: IoHandle NativeHandle -> IO Bool
isCooked   IoHandle NativeHandle
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

instance RawHandle (Io ConsoleHandle) where
  toHANDLE :: Io ConsoleHandle -> HANDLE
toHANDLE         = Io ConsoleHandle -> HANDLE
getConsoleHandle
  fromHANDLE :: HANDLE -> Io ConsoleHandle
fromHANDLE HANDLE
h     = IO (Io ConsoleHandle) -> Io ConsoleHandle
forall a. IO a -> a
unsafePerformIO (IO (Io ConsoleHandle) -> Io ConsoleHandle)
-> IO (Io ConsoleHandle) -> Io ConsoleHandle
forall a b. (a -> b) -> a -> b
$ HANDLE -> IORef Bool -> Io ConsoleHandle
ConsoleHandle HANDLE
h (IORef Bool -> Io ConsoleHandle)
-> IO (IORef Bool) -> IO (Io ConsoleHandle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  isLockable :: Io ConsoleHandle -> Bool
isLockable Io ConsoleHandle
_     = Bool
False
  setCooked :: Io ConsoleHandle -> Bool -> IO (Io ConsoleHandle)
setCooked  Io ConsoleHandle
h Bool
val =
    do IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Io ConsoleHandle -> IORef Bool
cookedHandle Io ConsoleHandle
h) Bool
val
       Io ConsoleHandle -> IO (Io ConsoleHandle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Io ConsoleHandle
h
  isCooked :: Io ConsoleHandle -> IO Bool
isCooked   Io ConsoleHandle
h     = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Io ConsoleHandle -> IORef Bool
cookedHandle Io ConsoleHandle
h)

-- -----------------------------------------------------------------------------

-- The Windows IO device implementation


-- | @since base-4.11.0.0

instance GHC.IO.Device.IODevice (Io NativeHandle) where
  ready :: IoHandle NativeHandle -> Bool -> Int -> IO Bool
ready      = IoHandle NativeHandle -> Bool -> Int -> IO Bool
forall a. RawHandle a => a -> Bool -> Int -> IO Bool
handle_ready
  close :: IoHandle NativeHandle -> IO ()
close      = IoHandle NativeHandle -> IO ()
forall a. RawHandle a => a -> IO ()
handle_close
  isTerminal :: IoHandle NativeHandle -> IO Bool
isTerminal = IoHandle NativeHandle -> IO Bool
forall a. RawHandle a => a -> IO Bool
handle_is_console
  isSeekable :: IoHandle NativeHandle -> IO Bool
isSeekable = IoHandle NativeHandle -> IO Bool
forall a. RawHandle a => a -> IO Bool
handle_is_seekable
  seek :: IoHandle NativeHandle -> SeekMode -> Integer -> IO Integer
seek       = IoHandle NativeHandle -> SeekMode -> Integer -> IO Integer
forall a. RawHandle a => a -> SeekMode -> Integer -> IO Integer
handle_seek
  tell :: IoHandle NativeHandle -> IO Integer
tell       = IoHandle NativeHandle -> IO Integer
forall a. RawHandle a => a -> IO Integer
handle_tell
  getSize :: IoHandle NativeHandle -> IO Integer
getSize    = IoHandle NativeHandle -> IO Integer
forall a. RawHandle a => a -> IO Integer
handle_get_size
  setSize :: IoHandle NativeHandle -> Integer -> IO ()
setSize    = IoHandle NativeHandle -> Integer -> IO ()
forall a. RawHandle a => a -> Integer -> IO ()
handle_set_size
  setEcho :: IoHandle NativeHandle -> Bool -> IO ()
setEcho    = IoHandle NativeHandle -> Bool -> IO ()
forall a. RawHandle a => a -> Bool -> IO ()
handle_set_echo
  getEcho :: IoHandle NativeHandle -> IO Bool
getEcho    = IoHandle NativeHandle -> IO Bool
forall a. RawHandle a => a -> IO Bool
handle_get_echo
  setRaw :: IoHandle NativeHandle -> Bool -> IO ()
setRaw     = IoHandle NativeHandle -> Bool -> IO ()
forall a. RawHandle a => a -> Bool -> IO ()
handle_set_buffering
  devType :: IoHandle NativeHandle -> IO IODeviceType
devType    = IoHandle NativeHandle -> IO IODeviceType
forall a. RawHandle a => a -> IO IODeviceType
handle_dev_type
  dup :: IoHandle NativeHandle -> IO (IoHandle NativeHandle)
dup        = IoHandle NativeHandle -> IO (IoHandle NativeHandle)
forall a. RawHandle a => a -> IO a
handle_duplicate

-- | @since base-4.11.0.0

instance GHC.IO.Device.IODevice (Io ConsoleHandle) where
  ready :: Io ConsoleHandle -> Bool -> Int -> IO Bool
ready      = Io ConsoleHandle -> Bool -> Int -> IO Bool
forall a. RawHandle a => a -> Bool -> Int -> IO Bool
handle_ready
  close :: Io ConsoleHandle -> IO ()
close      = IoHandle NativeHandle -> IO ()
forall a. RawHandle a => a -> IO ()
handle_close (IoHandle NativeHandle -> IO ())
-> (Io ConsoleHandle -> IoHandle NativeHandle)
-> Io ConsoleHandle
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Io ConsoleHandle -> Bool -> IoHandle NativeHandle)
-> Bool -> Io ConsoleHandle -> IoHandle NativeHandle
forall a b c. (a -> b -> c) -> b -> a -> c
flip Io ConsoleHandle -> Bool -> IoHandle NativeHandle
convertHandle Bool
False
  isTerminal :: Io ConsoleHandle -> IO Bool
isTerminal = Io ConsoleHandle -> IO Bool
forall a. RawHandle a => a -> IO Bool
handle_is_console
  isSeekable :: Io ConsoleHandle -> IO Bool
isSeekable = Io ConsoleHandle -> IO Bool
forall a. RawHandle a => a -> IO Bool
handle_is_seekable
  seek :: Io ConsoleHandle -> SeekMode -> Integer -> IO Integer
seek       = Io ConsoleHandle -> SeekMode -> Integer -> IO Integer
forall a. RawHandle a => a -> SeekMode -> Integer -> IO Integer
handle_console_seek
  tell :: Io ConsoleHandle -> IO Integer
tell       = Io ConsoleHandle -> IO Integer
forall a. RawHandle a => a -> IO Integer
handle_console_tell
  getSize :: Io ConsoleHandle -> IO Integer
getSize    = Io ConsoleHandle -> IO Integer
forall a. RawHandle a => a -> IO Integer
handle_get_console_size
  setSize :: Io ConsoleHandle -> Integer -> IO ()
setSize    = Io ConsoleHandle -> Integer -> IO ()
forall a. RawHandle a => a -> Integer -> IO ()
handle_set_console_size
  setEcho :: Io ConsoleHandle -> Bool -> IO ()
setEcho    = Io ConsoleHandle -> Bool -> IO ()
forall a. RawHandle a => a -> Bool -> IO ()
handle_set_echo
  getEcho :: Io ConsoleHandle -> IO Bool
getEcho    = Io ConsoleHandle -> IO Bool
forall a. RawHandle a => a -> IO Bool
handle_get_echo
  setRaw :: Io ConsoleHandle -> Bool -> IO ()
setRaw     = Io ConsoleHandle -> Bool -> IO ()
console_set_buffering
  devType :: Io ConsoleHandle -> IO IODeviceType
devType    = Io ConsoleHandle -> IO IODeviceType
forall a. RawHandle a => a -> IO IODeviceType
handle_dev_type
  dup :: Io ConsoleHandle -> IO (Io ConsoleHandle)
dup        = Io ConsoleHandle -> IO (Io ConsoleHandle)
forall a. RawHandle a => a -> IO a
handle_duplicate

-- Default sequential read buffer size.

-- for Windows 8k seems to be the optimal

-- buffer size.

dEFAULT_BUFFER_SIZE :: Int
dEFAULT_BUFFER_SIZE :: Int
dEFAULT_BUFFER_SIZE = Int
8192

-- | @since base-4.11.0.0

-- See libraries/base/GHC/IO/BufferedIO.hs

instance BufferedIO (Io NativeHandle) where
  newBuffer :: IoHandle NativeHandle -> BufferState -> IO (Buffer UCHAR)
newBuffer IoHandle NativeHandle
_dev BufferState
state = Int -> BufferState -> IO (Buffer UCHAR)
newByteBuffer Int
dEFAULT_BUFFER_SIZE BufferState
state
  fillReadBuffer :: IoHandle NativeHandle -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
fillReadBuffer       = IoHandle NativeHandle -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
forall a.
RawHandle a =>
a -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
readBuf'
  fillReadBuffer0 :: IoHandle NativeHandle
-> Buffer UCHAR -> IO (Maybe Int, Buffer UCHAR)
fillReadBuffer0      = IoHandle NativeHandle
-> Buffer UCHAR -> IO (Maybe Int, Buffer UCHAR)
forall dev.
RawIO dev =>
dev -> Buffer UCHAR -> IO (Maybe Int, Buffer UCHAR)
readBufNonBlocking
  flushWriteBuffer :: IoHandle NativeHandle -> Buffer UCHAR -> IO (Buffer UCHAR)
flushWriteBuffer     = IoHandle NativeHandle -> Buffer UCHAR -> IO (Buffer UCHAR)
forall a. RawHandle a => a -> Buffer UCHAR -> IO (Buffer UCHAR)
writeBuf'
  flushWriteBuffer0 :: IoHandle NativeHandle -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
flushWriteBuffer0    = IoHandle NativeHandle -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
forall dev.
RawIO dev =>
dev -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
writeBufNonBlocking

-- | @since base-4.11.0.0

-- See libraries/base/GHC/IO/BufferedIO.hs

instance BufferedIO (Io ConsoleHandle) where
  newBuffer :: Io ConsoleHandle -> BufferState -> IO (Buffer UCHAR)
newBuffer Io ConsoleHandle
_dev BufferState
state = Int -> BufferState -> IO (Buffer UCHAR)
newByteBuffer Int
dEFAULT_BUFFER_SIZE BufferState
state
  fillReadBuffer :: Io ConsoleHandle -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
fillReadBuffer       = Io ConsoleHandle -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
forall a.
RawHandle a =>
a -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
readBuf'
  fillReadBuffer0 :: Io ConsoleHandle -> Buffer UCHAR -> IO (Maybe Int, Buffer UCHAR)
fillReadBuffer0      = Io ConsoleHandle -> Buffer UCHAR -> IO (Maybe Int, Buffer UCHAR)
forall dev.
RawIO dev =>
dev -> Buffer UCHAR -> IO (Maybe Int, Buffer UCHAR)
readBufNonBlocking
  flushWriteBuffer :: Io ConsoleHandle -> Buffer UCHAR -> IO (Buffer UCHAR)
flushWriteBuffer     = Io ConsoleHandle -> Buffer UCHAR -> IO (Buffer UCHAR)
forall a. RawHandle a => a -> Buffer UCHAR -> IO (Buffer UCHAR)
writeBuf'
  flushWriteBuffer0 :: Io ConsoleHandle -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
flushWriteBuffer0    = Io ConsoleHandle -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
forall dev.
RawIO dev =>
dev -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
writeBufNonBlocking


readBuf' :: RawHandle a => a -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf' :: forall a.
RawHandle a =>
a -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
readBuf' a
hnd Buffer UCHAR
buf = do
  String -> IO ()
debugIO (String
"readBuf handle=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ HANDLE -> String
forall a. Show a => a -> String
show (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hnd) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++
           Buffer UCHAR -> String
forall a. Buffer a -> String
summaryBuffer Buffer UCHAR
buf String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
  (r,buf') <- a -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
forall dev.
RawIO dev =>
dev -> Buffer UCHAR -> IO (Int, Buffer UCHAR)
readBuf a
hnd Buffer UCHAR
buf
  debugIO ("after: " ++ summaryBuffer buf' ++ "\n")
  return (r,buf')

writeBuf' :: RawHandle a => a -> Buffer Word8 -> IO (Buffer Word8)
writeBuf' :: forall a. RawHandle a => a -> Buffer UCHAR -> IO (Buffer UCHAR)
writeBuf' a
hnd Buffer UCHAR
buf = do
  String -> IO ()
debugIO (String
"writeBuf handle=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ HANDLE -> String
forall a. Show a => a -> String
show (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hnd) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++
           Buffer UCHAR -> String
forall a. Buffer a -> String
summaryBuffer Buffer UCHAR
buf String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")
  a -> Buffer UCHAR -> IO (Buffer UCHAR)
forall dev. RawIO dev => dev -> Buffer UCHAR -> IO (Buffer UCHAR)
writeBuf a
hnd Buffer UCHAR
buf

-- -----------------------------------------------------------------------------

-- Standard I/O handles


type StdHandleId  = DWORD

sTD_INPUT_HANDLE   :: StdHandleId
sTD_INPUT_HANDLE :: DWORD
sTD_INPUT_HANDLE   =  DWORD
4294967286
sTD_OUTPUT_HANDLE  :: StdHandleId
sTD_OUTPUT_HANDLE :: DWORD
sTD_OUTPUT_HANDLE  =  DWORD
4294967285
sTD_ERROR_HANDLE   :: StdHandleId
sTD_ERROR_HANDLE :: DWORD
sTD_ERROR_HANDLE   =  DWORD
4294967284

{-# LINE 260 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}

getStdHandle :: StdHandleId -> IO HANDLE
getStdHandle hid =
  failIf (== iNVALID_HANDLE_VALUE) "GetStdHandle" $ c_GetStdHandle hid

stdin, stdout, stderr :: Io ConsoleHandle
stdin :: Io ConsoleHandle
stdin  = IO (Io ConsoleHandle) -> Io ConsoleHandle
forall a. IO a -> a
unsafePerformIO (IO (Io ConsoleHandle) -> Io ConsoleHandle)
-> IO (Io ConsoleHandle) -> Io ConsoleHandle
forall a b. (a -> b) -> a -> b
$ HANDLE -> IO (Io ConsoleHandle)
mkConsoleHandle (HANDLE -> IO (Io ConsoleHandle))
-> IO HANDLE -> IO (Io ConsoleHandle)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DWORD -> IO HANDLE
getStdHandle DWORD
sTD_INPUT_HANDLE
stdout :: Io ConsoleHandle
stdout = IO (Io ConsoleHandle) -> Io ConsoleHandle
forall a. IO a -> a
unsafePerformIO (IO (Io ConsoleHandle) -> Io ConsoleHandle)
-> IO (Io ConsoleHandle) -> Io ConsoleHandle
forall a b. (a -> b) -> a -> b
$ HANDLE -> IO (Io ConsoleHandle)
mkConsoleHandle (HANDLE -> IO (Io ConsoleHandle))
-> IO HANDLE -> IO (Io ConsoleHandle)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DWORD -> IO HANDLE
getStdHandle DWORD
sTD_OUTPUT_HANDLE
stderr :: Io ConsoleHandle
stderr = IO (Io ConsoleHandle) -> Io ConsoleHandle
forall a. IO a -> a
unsafePerformIO (IO (Io ConsoleHandle) -> Io ConsoleHandle)
-> IO (Io ConsoleHandle) -> Io ConsoleHandle
forall a b. (a -> b) -> a -> b
$ HANDLE -> IO (Io ConsoleHandle)
mkConsoleHandle (HANDLE -> IO (Io ConsoleHandle))
-> IO HANDLE -> IO (Io ConsoleHandle)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DWORD -> IO HANDLE
getStdHandle DWORD
sTD_ERROR_HANDLE

mkConsoleHandle :: HANDLE -> IO (Io ConsoleHandle)
mkConsoleHandle :: HANDLE -> IO (Io ConsoleHandle)
mkConsoleHandle HANDLE
hwnd
  = do ref <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
       return $ ConsoleHandle hwnd ref

-- -----------------------------------------------------------------------------

-- Some console internal types to detect EOF.


-- ASCII Ctrl+D (EOT) character.  Typically used by Unix consoles.

-- use for cross platform compatibility and to adhere to the ASCII standard.

acCtrlD :: Int
acCtrlD :: Int
acCtrlD = Int
0x04
-- ASCII Ctrl+Z (SUB) character. Typically used by Windows consoles to denote

-- EOT.  Use for compatibility with user expectations.

acCtrlZ :: Int
acCtrlZ :: Int
acCtrlZ = Int
0x1A

-- Mask to use to trigger ReadConsole input processing end.

acEotMask :: ULONG
acEotMask :: DWORD
acEotMask = (DWORD
1 DWORD -> Int -> DWORD
forall a. Bits a => a -> Int -> a
`shiftL` Int
acCtrlD) DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. (DWORD
1 DWORD -> Int -> DWORD
forall a. Bits a => a -> Int -> a
`shiftL` Int
acCtrlZ)

-- Structure to hold the control character masks

type PCONSOLE_READCONSOLE_CONTROL = Ptr CONSOLE_READCONSOLE_CONTROL
data CONSOLE_READCONSOLE_CONTROL = CONSOLE_READCONSOLE_CONTROL
  { CONSOLE_READCONSOLE_CONTROL -> DWORD
crcNLength           :: ULONG
  , CONSOLE_READCONSOLE_CONTROL -> DWORD
crcNInitialChars     :: ULONG
  , CONSOLE_READCONSOLE_CONTROL -> DWORD
crcDwCtrlWakeupMask  :: ULONG
  , CONSOLE_READCONSOLE_CONTROL -> DWORD
crcDwControlKeyState :: ULONG
  } deriving Int -> CONSOLE_READCONSOLE_CONTROL -> ShowS
[CONSOLE_READCONSOLE_CONTROL] -> ShowS
CONSOLE_READCONSOLE_CONTROL -> String
(Int -> CONSOLE_READCONSOLE_CONTROL -> ShowS)
-> (CONSOLE_READCONSOLE_CONTROL -> String)
-> ([CONSOLE_READCONSOLE_CONTROL] -> ShowS)
-> Show CONSOLE_READCONSOLE_CONTROL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CONSOLE_READCONSOLE_CONTROL -> ShowS
showsPrec :: Int -> CONSOLE_READCONSOLE_CONTROL -> ShowS
$cshow :: CONSOLE_READCONSOLE_CONTROL -> String
show :: CONSOLE_READCONSOLE_CONTROL -> String
$cshowList :: [CONSOLE_READCONSOLE_CONTROL] -> ShowS
showList :: [CONSOLE_READCONSOLE_CONTROL] -> ShowS
Show

instance Storable CONSOLE_READCONSOLE_CONTROL where
  sizeOf :: CONSOLE_READCONSOLE_CONTROL -> Int
sizeOf = Int -> CONSOLE_READCONSOLE_CONTROL -> Int
forall a b. a -> b -> a
const (Int
16)
{-# LINE 302 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
  alignment = const 4
{-# LINE 303 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
  poke buf crc = do
    ((\hsc_ptr -> pokeByteOff hsc_ptr 0))           buf
{-# LINE 305 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
        (crcNLength           crc)
    ((\hsc_ptr -> pokeByteOff hsc_ptr 4))     buf
{-# LINE 307 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
        (crcNInitialChars     crc)
    ((\hsc_ptr -> pokeByteOff hsc_ptr 8))  buf
{-# LINE 309 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
        (crcDwCtrlWakeupMask  crc)
    ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) buf
{-# LINE 311 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
        (crcDwControlKeyState crc)

  peek :: Ptr CONSOLE_READCONSOLE_CONTROL -> IO CONSOLE_READCONSOLE_CONTROL
peek Ptr CONSOLE_READCONSOLE_CONTROL
buf = do
    vNLength           <-
      ((\Ptr CONSOLE_READCONSOLE_CONTROL
hsc_ptr -> Ptr CONSOLE_READCONSOLE_CONTROL -> Int -> IO DWORD
forall b. Ptr b -> Int -> IO DWORD
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CONSOLE_READCONSOLE_CONTROL
hsc_ptr Int
0))           Ptr CONSOLE_READCONSOLE_CONTROL
buf
{-# LINE 316 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
    vNInitialChars     <-
      ((\hsc_ptr -> peekByteOff hsc_ptr 4))     buf
{-# LINE 318 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
    vDwCtrlWakeupMask  <-
      ((\hsc_ptr -> peekByteOff hsc_ptr 8))  buf
{-# LINE 320 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
    vDwControlKeyState <-
      ((\hsc_ptr -> peekByteOff hsc_ptr 12)) buf
{-# LINE 322 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
    return $ CONSOLE_READCONSOLE_CONTROL {
        crcNLength           = vNLength,
        crcNInitialChars     = vNInitialChars,
        crcDwCtrlWakeupMask  = vDwCtrlWakeupMask,
        crcDwControlKeyState = vDwControlKeyState
      }

-- Create CONSOLE_READCONSOLE_CONTROL for breaking on control characters

-- specified by acEotMask

eotControl :: CONSOLE_READCONSOLE_CONTROL
eotControl :: CONSOLE_READCONSOLE_CONTROL
eotControl =
  CONSOLE_READCONSOLE_CONTROL
    { crcNLength :: DWORD
crcNLength           = Int -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> DWORD) -> Int -> DWORD
forall a b. (a -> b) -> a -> b
$
                               CONSOLE_READCONSOLE_CONTROL -> Int
forall a. Storable a => a -> Int
sizeOf (CONSOLE_READCONSOLE_CONTROL
forall a. HasCallStack => a
undefined :: CONSOLE_READCONSOLE_CONTROL)
    , crcNInitialChars :: DWORD
crcNInitialChars     = DWORD
0
    , crcDwCtrlWakeupMask :: DWORD
crcDwCtrlWakeupMask  = DWORD
acEotMask
    , crcDwControlKeyState :: DWORD
crcDwControlKeyState = DWORD
0
    }

type PINPUT_RECORD = Ptr ()
-- -----------------------------------------------------------------------------

-- Foreign imports



foreign import ccall safe "windows.h CreateFileW"
    c_CreateFile :: LPCTSTR -> DWORD -> DWORD -> LPSECURITY_ATTRIBUTES
                 -> DWORD -> DWORD -> HANDLE
                 -> IO HANDLE

foreign import ccall safe "windows.h SetFileCompletionNotificationModes"
    c_SetFileCompletionNotificationModes :: HANDLE -> UCHAR -> IO BOOL

foreign import ccall safe "windows.h ReadFile"
    c_ReadFile :: HANDLE -> LPVOID -> DWORD -> LPDWORD -> LPOVERLAPPED
               -> IO BOOL

foreign import ccall safe "windows.h WriteFile"
    c_WriteFile :: HANDLE -> LPVOID -> DWORD -> LPDWORD -> LPOVERLAPPED
                -> IO BOOL

foreign import ccall safe "windows.h GetStdHandle"
    c_GetStdHandle :: StdHandleId -> IO HANDLE

foreign import ccall safe "__handle_ready"
    c_handle_ready :: HANDLE -> BOOL -> CInt -> IO CInt

foreign import ccall safe "__is_console"
    c_is_console :: HANDLE -> IO BOOL

foreign import ccall safe "__set_console_buffering"
    c_set_console_buffering :: HANDLE -> BOOL -> IO BOOL

foreign import ccall safe "__set_console_echo"
    c_set_console_echo :: HANDLE -> BOOL -> IO BOOL

foreign import ccall safe "__get_console_echo"
    c_get_console_echo :: HANDLE -> IO BOOL

foreign import ccall safe "__close_handle"
    c_close_handle :: HANDLE -> IO Bool

foreign import ccall safe "__handle_type"
    c_handle_type :: HANDLE -> IO Int

foreign import ccall safe "__set_file_pointer"
  c_set_file_pointer :: HANDLE -> CLong -> DWORD -> Ptr CLong -> IO BOOL

foreign import ccall safe "__get_file_pointer"
  c_get_file_pointer :: HANDLE -> IO CLong

foreign import ccall safe "__get_file_size"
  c_get_file_size :: HANDLE -> IO CLong

foreign import ccall safe "__set_file_size"
  c_set_file_size :: HANDLE -> CLong -> IO BOOL

foreign import ccall safe "__duplicate_handle"
  c_duplicate_handle :: HANDLE -> Ptr HANDLE -> IO BOOL

foreign import ccall safe "__set_console_pointer"
  c_set_console_pointer :: HANDLE -> CLong -> DWORD -> Ptr CLong -> IO BOOL

foreign import ccall safe "__get_console_pointer"
  c_get_console_pointer :: HANDLE -> IO CLong

foreign import ccall safe "__get_console_buffer_size"
  c_get_console_buffer_size :: HANDLE -> IO CLong

foreign import ccall safe "__set_console_buffer_size"
  c_set_console_buffer_size :: HANDLE -> CLong -> IO BOOL

foreign import ccall safe "windows.h ReadConsoleW"
  c_read_console :: HANDLE -> Ptr Word16 -> DWORD -> Ptr DWORD
                 -> PCONSOLE_READCONSOLE_CONTROL -> IO BOOL

foreign import ccall safe "windows.h WriteConsoleW"
  c_write_console :: HANDLE -> Ptr Word16 -> DWORD -> Ptr DWORD -> Ptr ()
                  -> IO BOOL

foreign import ccall safe "windows.h ReadConsoleInputW"
  c_read_console_input :: HANDLE -> PINPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL

foreign import ccall safe "windows.h GetNumberOfConsoleInputEvents"
  c_get_num_console_inputs :: HANDLE -> LPDWORD -> IO BOOL

type LPSECURITY_ATTRIBUTES = LPVOID

-- -----------------------------------------------------------------------------

-- Reading and Writing


-- For this to actually block, the file handle must have

-- been created with FILE_FLAG_OVERLAPPED not set. As an implementation note I

-- am choosing never to let this block. But this can be easily accomplished by

-- a getOverlappedResult call with True

hwndRead :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO Int
hwndRead :: IoHandle NativeHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
hwndRead IoHandle NativeHandle
hwnd Ptr UCHAR
ptr Word64
offset Int
bytes = do
  mngr <- IO Manager
Mgr.getSystemManager
  fmap fromIntegral $ Mgr.withException "hwndRead" $
     withOverlappedEx mngr "hwndRead" (toHANDLE hwnd) (isAsynchronous hwnd)
                      offset (startCB ptr) completionCB
  where
    startCB :: Ptr UCHAR -> StartIOCallback Int
startCB Ptr UCHAR
outBuf LPOVERLAPPED
lpOverlapped = do
      String -> IO ()
debugIO String
":: hwndRead"
      -- See Note [ReadFile/WriteFile].

      ret <- HANDLE -> HANDLE -> DWORD -> LPDWORD -> LPOVERLAPPED -> IO Bool
c_ReadFile (IoHandle NativeHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE IoHandle NativeHandle
hwnd) (Ptr UCHAR -> HANDLE
forall a b. Ptr a -> Ptr b
castPtr Ptr UCHAR
outBuf)
                        (Int -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bytes) LPDWORD
forall a. Ptr a
nullPtr LPOVERLAPPED
lpOverlapped
      return $ Mgr.CbNone ret

    completionCB :: a -> a -> IO (IOResult a)
completionCB a
err a
dwBytes
      | a
err a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0       = a -> IO (IOResult a)
forall a. a -> IO (IOResult a)
Mgr.ioSuccess (a -> IO (IOResult a)) -> a -> IO (IOResult a)
forall a b. (a -> b) -> a -> b
$ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dwBytes
{-# LINE 452 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == 38    = Mgr.ioSuccess 0
{-# LINE 453 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == -1073741807  = Mgr.ioSuccess 0
{-# LINE 454 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == 109   = Mgr.ioSuccess 0
{-# LINE 455 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == -1073741493  = Mgr.ioSuccess 0
{-# LINE 456 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == 259 = Mgr.ioSuccess $ fromIntegral dwBytes
{-# LINE 457 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == 234     = Mgr.ioSuccess $ fromIntegral dwBytes
{-# LINE 458 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | otherwise                           = Mgr.ioFailed err

-- In WinIO we'll never block in the FFI call, so this call is equivalent to

-- hwndRead,  Though we may revisit this when implementing sockets and pipes.

-- It still won't block, but may set up extra book keeping so threadWait and

-- threadWrite may work.

hwndReadNonBlocking :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int
                    -> IO (Maybe Int)
hwndReadNonBlocking :: IoHandle NativeHandle
-> Ptr UCHAR -> Word64 -> Int -> IO (Maybe Int)
hwndReadNonBlocking IoHandle NativeHandle
hwnd Ptr UCHAR
ptr Word64
offset Int
bytes
  = do mngr <- IO Manager
Mgr.getSystemManager
       val <- withOverlappedEx mngr "hwndReadNonBlocking" (toHANDLE hwnd)
                               (isAsynchronous hwnd) offset (startCB ptr)
                               completionCB
       return $ ioValue val
  where
    startCB :: Ptr UCHAR -> StartIOCallback Int
startCB Ptr UCHAR
inputBuf LPOVERLAPPED
lpOverlapped = do
      String -> IO ()
debugIO String
":: hwndReadNonBlocking"
      -- See Note [ReadFile/WriteFile].

      ret <- HANDLE -> HANDLE -> DWORD -> LPDWORD -> LPOVERLAPPED -> IO Bool
c_ReadFile (IoHandle NativeHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE IoHandle NativeHandle
hwnd) (Ptr UCHAR -> HANDLE
forall a b. Ptr a -> Ptr b
castPtr Ptr UCHAR
inputBuf)
                        (Int -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bytes) LPDWORD
forall a. Ptr a
nullPtr LPOVERLAPPED
lpOverlapped
      return $ Mgr.CbNone ret

    completionCB :: a -> a -> IO (IOResult (Maybe a))
completionCB a
err a
dwBytes
      | a
err a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0       = Maybe a -> IO (IOResult (Maybe a))
forall a. a -> IO (IOResult a)
Mgr.ioSuccess (Maybe a -> IO (IOResult (Maybe a)))
-> Maybe a -> IO (IOResult (Maybe a))
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$! a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dwBytes
{-# LINE 482 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == 38    = Mgr.ioSuccess Nothing
{-# LINE 483 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == -1073741807  = Mgr.ioSuccess Nothing
{-# LINE 484 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == 109   = Mgr.ioSuccess Nothing
{-# LINE 485 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == -1073741493  = Mgr.ioSuccess Nothing
{-# LINE 486 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == 259 = Mgr.ioSuccess Nothing
{-# LINE 487 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | err == 234     = Mgr.ioSuccess $ Just $! fromIntegral dwBytes
{-# LINE 488 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
      | otherwise                           = Mgr.ioFailedAny err

hwndWrite :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO ()
hwndWrite :: IoHandle NativeHandle -> Ptr UCHAR -> Word64 -> Int -> IO ()
hwndWrite IoHandle NativeHandle
hwnd Ptr UCHAR
ptr Word64
offset Int
bytes
  = do mngr <- IO Manager
Mgr.getSystemManager
       _ <- Mgr.withException "hwndWrite" $
          withOverlappedEx mngr "hwndWrite" (toHANDLE hwnd)
                           (isAsynchronous hwnd) offset (startCB ptr)
                           completionCB
       return ()
  where
    startCB :: Ptr UCHAR -> StartIOCallback Int
startCB Ptr UCHAR
outBuf LPOVERLAPPED
lpOverlapped = do
      String -> IO ()
debugIO String
":: hwndWrite"
      -- See Note [ReadFile/WriteFile].

      ret <- HANDLE -> HANDLE -> DWORD -> LPDWORD -> LPOVERLAPPED -> IO Bool
c_WriteFile (IoHandle NativeHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE IoHandle NativeHandle
hwnd) (Ptr UCHAR -> HANDLE
forall a b. Ptr a -> Ptr b
castPtr Ptr UCHAR
outBuf)
                         (Int -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bytes) LPDWORD
forall a. Ptr a
nullPtr LPOVERLAPPED
lpOverlapped
      return $ Mgr.CbNone ret

    completionCB :: a -> a -> IO (IOResult a)
completionCB a
err a
dwBytes
        | a
err a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0  =   a -> IO (IOResult a)
forall a. a -> IO (IOResult a)
Mgr.ioSuccess (a -> IO (IOResult a)) -> a -> IO (IOResult a)
forall a b. (a -> b) -> a -> b
$ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dwBytes
{-# LINE 508 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
        | a
err a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
38 = a -> IO (IOResult a)
forall a. a -> IO (IOResult a)
Mgr.ioSuccess (a -> IO (IOResult a)) -> a -> IO (IOResult a)
forall a b. (a -> b) -> a -> b
$ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dwBytes
{-# LINE 509 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
        | Bool
otherwise                        = a -> IO (IOResult a)
forall a. Integral a => a -> IO (IOResult a)
Mgr.ioFailed a
err

hwndWriteNonBlocking :: Io NativeHandle -> Ptr Word8 -> Word64 -> Int -> IO Int
hwndWriteNonBlocking :: IoHandle NativeHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
hwndWriteNonBlocking IoHandle NativeHandle
hwnd Ptr UCHAR
ptr Word64
offset Int
bytes
  = do mngr <- IO Manager
Mgr.getSystemManager
       val <- withOverlappedEx mngr "hwndReadNonBlocking" (toHANDLE hwnd)
                               (isAsynchronous hwnd) offset (startCB ptr)
                               completionCB
       return $ fromIntegral $ ioValue val
  where
    startCB :: Ptr a -> LPOVERLAPPED -> IO (Mgr.CbResult a1)
    startCB :: forall a a1. Ptr a -> LPOVERLAPPED -> IO (CbResult a1)
startCB Ptr a
outBuf LPOVERLAPPED
lpOverlapped = do
      String -> IO ()
debugIO String
":: hwndWriteNonBlocking"
      -- See Note [ReadFile/WriteFile].

      ret <- HANDLE -> HANDLE -> DWORD -> LPDWORD -> LPOVERLAPPED -> IO Bool
c_WriteFile (IoHandle NativeHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE IoHandle NativeHandle
hwnd) (Ptr a -> HANDLE
forall a b. Ptr a -> Ptr b
castPtr Ptr a
outBuf)
                         (Int -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bytes) LPDWORD
forall a. Ptr a
nullPtr LPOVERLAPPED
lpOverlapped
      return $ Mgr.CbNone ret

    completionCB :: a -> a -> IO (IOResult a)
completionCB a
err a
dwBytes
        | a
err a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0    = a -> IO (IOResult a)
forall a. a -> IO (IOResult a)
Mgr.ioSuccess (a -> IO (IOResult a)) -> a -> IO (IOResult a)
forall a b. (a -> b) -> a -> b
$ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dwBytes
{-# LINE 529 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
        | a
err a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
38 = a -> IO (IOResult a)
forall a. a -> IO (IOResult a)
Mgr.ioSuccess (a -> IO (IOResult a)) -> a -> IO (IOResult a)
forall a b. (a -> b) -> a -> b
$ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dwBytes
{-# LINE 530 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
        | Bool
otherwise                        = a -> IO (IOResult a)
forall a. Integral a => a -> IO (IOResult a)
Mgr.ioFailed a
err

-- Note [ReadFile/WriteFile]

-- ~~~~~~~~~~~~~~~~~~~~~~~~~

-- The results of these functions are somewhat different when working in an

-- asynchronous manner. The returning bool has two meaning.

--

-- True: The operation is done and was completed synchronously.  This is

--       possible because of the optimization flags we enable.  In this case

--       there won't be a completion event for this call and so we shouldn't

--       queue one up. If we do this request will never terminate.  It's also

--       safe to free the OVERLAPPED structure immediately.

--

-- False: Only indicates that the operation was not completed synchronously, a

--        call to GetLastError () is needed to find out the actual status. If

--        the result is ERROR_IO_PENDING then the operation has been queued on

--        the completion port and we should proceed asynchronously.  Any other

--        state is usually an indication that the call failed.

--

-- NB. reading an EOF will result in ERROR_HANDLE_EOF or STATUS_END_OF_FILE

-- during the checking of the completion results.  We need to check for these

-- so we don't incorrectly fail.



consoleWrite :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO ()
consoleWrite :: Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO ()
consoleWrite Io ConsoleHandle
hwnd Ptr UCHAR
ptr Word64
_offset Int
bytes
  = (LPDWORD -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((LPDWORD -> IO ()) -> IO ()) -> (LPDWORD -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LPDWORD
res ->
      do String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.consoleWrite" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
           String -> IO ()
debugIO String
":: consoleWrite"
           Ptr UCHAR -> Int -> ((Ptr WORD, CInt) -> IO Bool) -> IO Bool
forall a. Ptr UCHAR -> Int -> ((Ptr WORD, CInt) -> IO a) -> IO a
withGhcInternalToUTF16 Ptr UCHAR
ptr Int
bytes (((Ptr WORD, CInt) -> IO Bool) -> IO Bool)
-> ((Ptr WORD, CInt) -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \(Ptr WORD
w_ptr, CInt
w_len) -> do
              success <- HANDLE -> Ptr WORD -> DWORD -> LPDWORD -> HANDLE -> IO Bool
c_write_console (Io ConsoleHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE Io ConsoleHandle
hwnd) Ptr WORD
w_ptr
                                         (CInt -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
w_len) LPDWORD
res HANDLE
forall a. Ptr a
nullPtr
              if not success
                 then return False
                 else do val <- fromIntegral <$> peek res
                         return $ val == w_len

consoleWriteNonBlocking :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO Int
consoleWriteNonBlocking :: Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
consoleWriteNonBlocking Io ConsoleHandle
hwnd Ptr UCHAR
ptr Word64
_offset Int
bytes
  = (LPDWORD -> IO Int) -> IO Int
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((LPDWORD -> IO Int) -> IO Int) -> (LPDWORD -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \LPDWORD
res ->
      do String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.consoleWriteNonBlocking" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
debugIO String
":: consoleWriteNonBlocking"
            Ptr UCHAR -> Int -> ((Ptr WORD, CInt) -> IO Bool) -> IO Bool
forall a. Ptr UCHAR -> Int -> ((Ptr WORD, CInt) -> IO a) -> IO a
withGhcInternalToUTF16 Ptr UCHAR
ptr Int
bytes (((Ptr WORD, CInt) -> IO Bool) -> IO Bool)
-> ((Ptr WORD, CInt) -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \(Ptr WORD
w_ptr, CInt
w_len) -> do
              HANDLE -> Ptr WORD -> DWORD -> LPDWORD -> HANDLE -> IO Bool
c_write_console (Io ConsoleHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE Io ConsoleHandle
hwnd) Ptr WORD
w_ptr (CInt -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
w_len)
                              LPDWORD
res HANDLE
forall a. Ptr a
nullPtr
         val <- DWORD -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DWORD -> Int) -> IO DWORD -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LPDWORD -> IO DWORD
forall a. Storable a => Ptr a -> IO a
peek LPDWORD
res
         return val

consoleRead :: Bool -> Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int -> IO Int
consoleRead :: Bool -> Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
consoleRead Bool
blocking Io ConsoleHandle
hwnd Ptr UCHAR
ptr Word64
_offset Int
bytes
  = (LPDWORD -> IO Int) -> IO Int
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((LPDWORD -> IO Int) -> IO Int) -> (LPDWORD -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \LPDWORD
res -> do
      cooked <- Io ConsoleHandle -> IO Bool
forall a. RawHandle a => a -> IO Bool
isCooked Io ConsoleHandle
hwnd
      -- Cooked input must be handled differently when the STD handles are

      -- attached to a real console handle.  For File based handles we can't do

      -- proper cooked inputs, but since the actions are async you would get

      -- results as soon as available.

      --

      -- For console handles We have to use a lower level API then ReadConsole,

      -- namely we must use ReadConsoleInput which requires us to process

      -- all console message manually.

      --

      -- Do note that MSYS2 shells such as bash don't attach to a real handle,

      -- and instead have by default a pipe/file based std handles.  Which

      -- means the cooked behaviour is best when used in a native Windows

      -- terminal such as cmd, powershell or ConEmu.

      case cooked || not blocking of
        Bool
False -> Ptr UCHAR -> Int -> (CInt -> Ptr WORD -> IO CInt) -> IO Int
withUTF16ToGhcInternal Ptr UCHAR
ptr Int
bytes ((CInt -> Ptr WORD -> IO CInt) -> IO Int)
-> (CInt -> Ptr WORD -> IO CInt) -> IO Int
forall a b. (a -> b) -> a -> b
$ \CInt
reqBytes Ptr WORD
w_ptr ->  do
          String -> IO ()
debugIO String
"consoleRead :: un-cooked I/O read."
          -- eotControl allows us to handle control characters like EOL

          -- without needing a newline, which would sort of defeat the point

          -- of an EOL.

          res_code <- CONSOLE_READCONSOLE_CONTROL
-> (Ptr CONSOLE_READCONSOLE_CONTROL -> IO Bool) -> IO Bool
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with CONSOLE_READCONSOLE_CONTROL
eotControl ((Ptr CONSOLE_READCONSOLE_CONTROL -> IO Bool) -> IO Bool)
-> (Ptr CONSOLE_READCONSOLE_CONTROL -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr CONSOLE_READCONSOLE_CONTROL
p_eotControl ->
                HANDLE
-> Ptr WORD
-> DWORD
-> LPDWORD
-> Ptr CONSOLE_READCONSOLE_CONTROL
-> IO Bool
c_read_console (Io ConsoleHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE Io ConsoleHandle
hwnd) Ptr WORD
w_ptr (CInt -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
reqBytes) LPDWORD
res
                               Ptr CONSOLE_READCONSOLE_CONTROL
p_eotControl

          -- Restore a quirk of the POSIX read call, which only returns a fail

          -- when the handle is invalid, e.g. closed or not a handle.  It how-

          -- ever returns 0 when the handle is valid but unreadable, such as

          -- passing a handle with no GENERIC_READ permission, like /dev/null

          err <- getLastError
          when (not res_code) $
            case () of
             ()
_ | DWORD
err DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
1 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# LINE 613 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
               | Bool
otherwise -> String -> DWORD -> IO ()
forall a. String -> DWORD -> IO a
failWith String
"GHC.Internal.IO.Handle.consoleRead" DWORD
err
          b_read <- fromIntegral <$> peek res
          if b_read /= 1
              then return b_read
              else do w_first <- peekElemOff w_ptr 0
                      case () of
                        -- Handle Ctrl+Z which is the actual EOL sequence on

                        -- windows, but also handle Ctrl+D which is what the

                        -- ASCII standard defines as EOL.

                        ()
_ | WORD
w_first WORD -> WORD -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> WORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
acCtrlD -> CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
0
                          | WORD
w_first WORD -> WORD -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> WORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
acCtrlZ -> CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
0
                          | Bool
otherwise                       -> CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
b_read
        Bool
True -> do
          String -> IO ()
debugIO String
"consoleRead :: cooked I/O read."
          -- Input is cooked, don't wait till a line return and consume all

          -- characters as they are.  Technically this function can handle any

          -- console event.  Including mouse, window and virtual key events

          -- but for now I'm only interested in key presses.

          let entries :: Int
entries = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
bytes Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` ((Int
20))
{-# LINE 632 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
          Int -> (HANDLE -> IO Int) -> IO Int
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
entries ((HANDLE -> IO Int) -> IO Int) -> (HANDLE -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \HANDLE
p_inputs ->
            HANDLE -> Int -> LPDWORD -> Ptr UCHAR -> IO Int
maybeReadEvent HANDLE
p_inputs Int
entries LPDWORD
res Ptr UCHAR
ptr

          -- Check to see if we have been explicitly asked to do a non-blocking

          -- I/O, and if we were, make sure that if we didn't have any console

          -- events that we don't block.

    where maybeReadEvent :: HANDLE -> Int -> LPDWORD -> Ptr UCHAR -> IO Int
maybeReadEvent HANDLE
p_inputs Int
entries LPDWORD
res Ptr UCHAR
w_ptr =
            case (Bool -> Bool
not Bool
blocking) of
              Bool
True -> do
                avail <- DWORD -> (LPDWORD -> IO DWORD) -> IO DWORD
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (DWORD
0 :: DWORD) ((LPDWORD -> IO DWORD) -> IO DWORD)
-> (LPDWORD -> IO DWORD) -> IO DWORD
forall a b. (a -> b) -> a -> b
$ \LPDWORD
num_events_ptr -> do
                  String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.consoleRead [non-blocking]" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
                    HANDLE -> LPDWORD -> IO Bool
c_get_num_console_inputs (Io ConsoleHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE Io ConsoleHandle
hwnd) LPDWORD
num_events_ptr
                  LPDWORD -> IO DWORD
forall a. Storable a => Ptr a -> IO a
peek LPDWORD
num_events_ptr
                debugIO $ "consoleRead [avail] :: " ++ show avail
                if avail > 0
                  then readEvent p_inputs entries res w_ptr
                  else return 0
              Bool
False -> HANDLE -> Int -> LPDWORD -> Ptr UCHAR -> IO Int
readEvent HANDLE
p_inputs Int
entries LPDWORD
res Ptr UCHAR
w_ptr

          -- Unconditionally issue the first read, but conditionally

          -- do the recursion.

          readEvent :: HANDLE -> Int -> LPDWORD -> Ptr UCHAR -> IO Int
readEvent HANDLE
p_inputs Int
entries LPDWORD
res Ptr UCHAR
w_ptr = do
            String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.consoleRead" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
              HANDLE -> HANDLE -> DWORD -> LPDWORD -> IO Bool
c_read_console_input (Io ConsoleHandle -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE Io ConsoleHandle
hwnd) HANDLE
p_inputs
                                   (Int -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
entries) LPDWORD
res

            b_read <- DWORD -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DWORD -> Int) -> IO DWORD -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LPDWORD -> IO DWORD
forall a. Storable a => Ptr a -> IO a
peek LPDWORD
res
            read <- cobble b_read w_ptr p_inputs
            debugIO $ "readEvent: =" ++ show read
            if read > 0
               then return $ fromIntegral read
               else maybeReadEvent p_inputs entries res w_ptr

          -- Dereference and read console input records.  We only read the bare

          -- minimum required to know which key/sequences were pressed.  To do

          -- this and prevent having to fully port the PINPUT_RECORD structure

          -- in Haskell we use some GCC builtins to find the correct offsets.

          cobble :: Int -> Ptr Word8 -> PINPUT_RECORD -> IO Int
          cobble :: Int -> Ptr UCHAR -> HANDLE -> IO Int
cobble Int
0 Ptr UCHAR
_ HANDLE
_ = do String -> IO ()
debugIO String
"cobble: done."
                            Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
          cobble Int
n Ptr UCHAR
w_ptr HANDLE
p_inputs =
            do eventType <- HANDLE -> Int -> IO WORD
forall b. Ptr b -> Int -> IO WORD
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff HANDLE
p_inputs Int
0 :: IO WORD
               debugIO $ "cobble: Length=" ++ show n
               debugIO $ "cobble: Type=" ++ show eventType
               let ni_offset      = (Int
20)
{-# LINE 677 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
               let event          = Int
4
{-# LINE 678 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
               let char_offset    = Int
event Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
{-# LINE 679 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
               let btnDown_offset = Int
event Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0
{-# LINE 680 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
               let repeat_offset  = Int
event Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
{-# LINE 681 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
               let n'             = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
               let p_inputs'      = HANDLE
p_inputs HANDLE -> Int -> HANDLE
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ni_offset
               btnDown  <- peekByteOff p_inputs btnDown_offset
               repeated <- fromIntegral <$> (peekByteOff p_inputs repeat_offset :: IO WORD)
               debugIO $ "cobble: BtnDown=" ++ show btnDown
               -- Handle the key only on button down and not on button up.

               if eventType == 1 && btnDown
{-# LINE 688 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                  then do debugIO $ "cobble: read-char."
                          char <- peekByteOff p_inputs char_offset
                          let w_ptr' = Ptr UCHAR
w_ptr Ptr UCHAR -> Int -> Ptr UCHAR
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1
                          debugIO $ "cobble: offset - " ++ show char_offset
                          debugIO $ "cobble: show > " ++ show char
                          debugIO $ "cobble: repeat: " ++ show repeated
                          -- The documentation here is rather subtle, but

                          -- according to MSDN the uWChar being provided here

                          -- has been "translated".  What this actually means

                          -- is that the surrogate pairs have already been

                          -- translated into byte sequences.  That is, despite

                          -- the Word16 storage type, it's actually a byte

                          -- stream.  This means we shouldn't try to decode

                          -- to UTF-8 again since we'd end up incorrectly

                          -- interpreting two bytes as an extended unicode

                          -- character.

                          pokeArray w_ptr $ replicate repeated char
                          (+repeated) <$> cobble n' w_ptr' p_inputs'
                  else do debugIO $ "cobble: skip event."
                          cobble n' w_ptr p_inputs'


consoleReadNonBlocking :: Io ConsoleHandle -> Ptr Word8 -> Word64 -> Int
                       -> IO (Maybe Int)
consoleReadNonBlocking :: Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO (Maybe Int)
consoleReadNonBlocking Io ConsoleHandle
hwnd Ptr UCHAR
ptr Word64
offset Int
bytes
  = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> IO Int -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Io ConsoleHandle -> Ptr UCHAR -> Word64 -> Int -> IO Int
consoleRead Bool
False Io ConsoleHandle
hwnd Ptr UCHAR
ptr Word64
offset Int
bytes

-- -----------------------------------------------------------------------------

-- Operations on file handles


handle_ready :: RawHandle a => a -> Bool -> Int -> IO Bool
handle_ready :: forall a. RawHandle a => a -> Bool -> Int -> IO Bool
handle_ready a
hwnd Bool
write Int
msecs = do
  r <- String -> IO CInt -> IO CInt
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"GHC.Internal.IO.Windows.Handle.handle_ready" (IO CInt -> IO CInt) -> IO CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$
          HANDLE -> Bool -> CInt -> IO CInt
c_handle_ready (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd) Bool
write (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
msecs)
  return (toEnum (fromIntegral r))

handle_is_console :: RawHandle a => a -> IO Bool
handle_is_console :: forall a. RawHandle a => a -> IO Bool
handle_is_console = HANDLE -> IO Bool
c_is_console (HANDLE -> IO Bool) -> (a -> HANDLE) -> a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE

handle_close :: RawHandle a => a -> IO ()
handle_close :: forall a. RawHandle a => a -> IO ()
handle_close a
h = do a -> IO ()
forall a. RawHandle a => a -> IO ()
release a
h
                    String -> IO Bool -> IO ()
failIfFalse_ String
"handle_close" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ HANDLE -> IO Bool
c_close_handle (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
h)

handle_dev_type :: RawHandle a => a -> IO IODeviceType
handle_dev_type :: forall a. RawHandle a => a -> IO IODeviceType
handle_dev_type a
hwnd = do _type <- HANDLE -> IO Int
c_handle_type (HANDLE -> IO Int) -> HANDLE -> IO Int
forall a b. (a -> b) -> a -> b
$ a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd
                          return $ case _type of
                                     Int
_ | Int
_type Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 -> IODeviceType
Stream
                                       | Int
_type Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 -> IODeviceType
RawDevice
                                       | Bool
otherwise  -> IODeviceType
RegularFile

handle_is_seekable :: RawHandle a => a -> IO Bool
handle_is_seekable :: forall a. RawHandle a => a -> IO Bool
handle_is_seekable a
hwnd = do
  t <- a -> IO IODeviceType
forall a. RawHandle a => a -> IO IODeviceType
handle_dev_type a
hwnd
  return (t == RegularFile || t == RawDevice)

handle_seek :: RawHandle a => a -> SeekMode -> Integer -> IO Integer
handle_seek :: forall a. RawHandle a => a -> SeekMode -> Integer -> IO Integer
handle_seek a
hwnd SeekMode
mode Integer
off =
  CLong -> (Ptr CLong -> IO Integer) -> IO Integer
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with CLong
0 ((Ptr CLong -> IO Integer) -> IO Integer)
-> (Ptr CLong -> IO Integer) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \Ptr CLong
off_rel -> do
    String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.handle_seek" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
        HANDLE -> CLong -> DWORD -> Ptr CLong -> IO Bool
c_set_file_pointer (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd) (Integer -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off) DWORD
seektype Ptr CLong
off_rel
    CLong -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong -> Integer) -> IO CLong -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CLong -> IO CLong
forall a. Storable a => Ptr a -> IO a
peek Ptr CLong
off_rel
 where
    seektype :: DWORD
    seektype :: DWORD
seektype = case SeekMode
mode of
                   SeekMode
AbsoluteSeek -> DWORD
0
{-# LINE 753 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                   SeekMode
RelativeSeek -> DWORD
1
{-# LINE 754 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                   SeekMode
SeekFromEnd  -> DWORD
2
{-# LINE 755 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}

handle_tell :: RawHandle a => a -> IO Integer
handle_tell :: forall a. RawHandle a => a -> IO Integer
handle_tell a
hwnd =
   CLong -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong -> Integer) -> IO CLong -> IO Integer
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
      (String -> IO CLong -> IO CLong
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"GHC.Internal.IO.Handle.handle_tell" (IO CLong -> IO CLong) -> IO CLong -> IO CLong
forall a b. (a -> b) -> a -> b
$
          HANDLE -> IO CLong
c_get_file_pointer (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd))

handle_set_size :: RawHandle a => a -> Integer -> IO ()
handle_set_size :: forall a. RawHandle a => a -> Integer -> IO ()
handle_set_size a
hwnd Integer
size =
  String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.handle_set_size" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
      HANDLE -> CLong -> IO Bool
c_set_file_size (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd) (Integer -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
size)

handle_get_size :: RawHandle a => a -> IO Integer
handle_get_size :: forall a. RawHandle a => a -> IO Integer
handle_get_size a
hwnd =
   CLong -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong -> Integer) -> IO CLong -> IO Integer
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
      (String -> IO CLong -> IO CLong
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"GHC.Internal.IO.Handle.handle_set_size" (IO CLong -> IO CLong) -> IO CLong -> IO CLong
forall a b. (a -> b) -> a -> b
$
          HANDLE -> IO CLong
c_get_file_size (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd))

handle_set_echo :: RawHandle a => a -> Bool -> IO ()
handle_set_echo :: forall a. RawHandle a => a -> Bool -> IO ()
handle_set_echo a
hwnd Bool
value =
  String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.handle_set_echo" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
      HANDLE -> Bool -> IO Bool
c_set_console_echo (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd) Bool
value

handle_get_echo :: RawHandle a => a -> IO Bool
handle_get_echo :: forall a. RawHandle a => a -> IO Bool
handle_get_echo = HANDLE -> IO Bool
c_get_console_echo (HANDLE -> IO Bool) -> (a -> HANDLE) -> a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE

handle_duplicate :: RawHandle a => a -> IO a
handle_duplicate :: forall a. RawHandle a => a -> IO a
handle_duplicate a
hwnd = (Ptr HANDLE -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr HANDLE -> IO a) -> IO a) -> (Ptr HANDLE -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr HANDLE
ptr -> do
  String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.handle_duplicate" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
      HANDLE -> Ptr HANDLE -> IO Bool
c_duplicate_handle (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd) Ptr HANDLE
ptr
  HANDLE -> a
forall a. RawHandle a => HANDLE -> a
fromHANDLE (HANDLE -> a) -> IO HANDLE -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr HANDLE -> IO HANDLE
forall a. Storable a => Ptr a -> IO a
peek Ptr HANDLE
ptr

console_set_buffering :: Io ConsoleHandle -> Bool -> IO ()
console_set_buffering :: Io ConsoleHandle -> Bool -> IO ()
console_set_buffering Io ConsoleHandle
hwnd Bool
value = Io ConsoleHandle -> Bool -> IO (Io ConsoleHandle)
forall a. RawHandle a => a -> Bool -> IO a
setCooked Io ConsoleHandle
hwnd Bool
value IO (Io ConsoleHandle) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

handle_set_buffering :: RawHandle a => a -> Bool -> IO ()
handle_set_buffering :: forall a. RawHandle a => a -> Bool -> IO ()
handle_set_buffering a
hwnd Bool
value =
  String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.handle_set_buffering" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
      HANDLE -> Bool -> IO Bool
c_set_console_buffering (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd) Bool
value

handle_console_seek :: RawHandle a => a -> SeekMode -> Integer -> IO Integer
handle_console_seek :: forall a. RawHandle a => a -> SeekMode -> Integer -> IO Integer
handle_console_seek a
hwnd SeekMode
mode Integer
off =
  CLong -> (Ptr CLong -> IO Integer) -> IO Integer
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with CLong
0 ((Ptr CLong -> IO Integer) -> IO Integer)
-> (Ptr CLong -> IO Integer) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \Ptr CLong
loc_ptr -> do
    String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.handle_console_seek" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
      HANDLE -> CLong -> DWORD -> Ptr CLong -> IO Bool
c_set_console_pointer (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd) (Integer -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off) DWORD
seektype Ptr CLong
loc_ptr
    CLong -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong -> Integer) -> IO CLong -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CLong -> IO CLong
forall a. Storable a => Ptr a -> IO a
peek Ptr CLong
loc_ptr
 where
    seektype :: DWORD
    seektype :: DWORD
seektype = case SeekMode
mode of
                 SeekMode
AbsoluteSeek -> DWORD
0
{-# LINE 805 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                 SeekMode
RelativeSeek -> DWORD
1
{-# LINE 806 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                 SeekMode
SeekFromEnd  -> DWORD
2
{-# LINE 807 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}

handle_console_tell :: RawHandle a => a -> IO Integer
handle_console_tell :: forall a. RawHandle a => a -> IO Integer
handle_console_tell a
hwnd =
   CLong -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong -> Integer) -> IO CLong -> IO Integer
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
      (String -> IO CLong -> IO CLong
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"GHC.Internal.IO.Handle.handle_console_tell" (IO CLong -> IO CLong) -> IO CLong -> IO CLong
forall a b. (a -> b) -> a -> b
$
          HANDLE -> IO CLong
c_get_console_pointer (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd))

handle_set_console_size :: RawHandle a => a -> Integer -> IO ()
handle_set_console_size :: forall a. RawHandle a => a -> Integer -> IO ()
handle_set_console_size a
hwnd Integer
size =
  String -> IO Bool -> IO ()
failIfFalse_ String
"GHC.Internal.IO.Handle.handle_set_console_size" (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
      HANDLE -> CLong -> IO Bool
c_set_console_buffer_size (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd) (Integer -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
size)

handle_get_console_size :: RawHandle a => a -> IO Integer
handle_get_console_size :: forall a. RawHandle a => a -> IO Integer
handle_get_console_size a
hwnd =
   CLong -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong -> Integer) -> IO CLong -> IO Integer
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
      (String -> IO CLong -> IO CLong
forall a. (Eq a, Num a) => String -> IO a -> IO a
throwErrnoIfMinus1Retry String
"GHC.Internal.IO.Handle.handle_get_console_size" (IO CLong -> IO CLong) -> IO CLong -> IO CLong
forall a b. (a -> b) -> a -> b
$
          HANDLE -> IO CLong
c_get_console_buffer_size (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
hwnd))

-- -----------------------------------------------------------------------------

-- opening files


-- | Describes if and which temp file flags to use.

data TempFileOptions = NoTemp | TempNonExcl | TempExcl deriving TempFileOptions -> TempFileOptions -> Bool
(TempFileOptions -> TempFileOptions -> Bool)
-> (TempFileOptions -> TempFileOptions -> Bool)
-> Eq TempFileOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TempFileOptions -> TempFileOptions -> Bool
== :: TempFileOptions -> TempFileOptions -> Bool
$c/= :: TempFileOptions -> TempFileOptions -> Bool
/= :: TempFileOptions -> TempFileOptions -> Bool
Eq

-- | Open a file and make an 'NativeHandle' for it.  Truncates the file to zero

-- size when the `IOMode` is `WriteMode`.

openFile
  :: FilePath -- ^ file to open

  -> IOMode   -- ^ mode in which to open the file

  -> Bool     -- ^ open the file in non-blocking mode?

  -> IO (Io NativeHandle, IODeviceType)
openFile :: String
-> IOMode -> Bool -> IO (IoHandle NativeHandle, IODeviceType)
openFile String
filepath IOMode
iomode Bool
non_blocking = String
-> IOMode
-> Bool
-> TempFileOptions
-> IO (IoHandle NativeHandle, IODeviceType)
openFile' String
filepath IOMode
iomode Bool
non_blocking TempFileOptions
NoTemp

-- | Open a file as a temporary file and make an 'NativeHandle' for it.

-- Truncates the file to zero size when the `IOMode` is `WriteMode`.

openFileAsTemp
  :: FilePath -- ^ file to open

  -> Bool     -- ^ open the file in non-blocking mode?

  -> Bool     -- ^ Exclusive mode

  -> IO (Io NativeHandle, IODeviceType)
openFileAsTemp :: String -> Bool -> Bool -> IO (IoHandle NativeHandle, IODeviceType)
openFileAsTemp String
filepath Bool
non_blocking Bool
excl
  = String
-> IOMode
-> Bool
-> TempFileOptions
-> IO (IoHandle NativeHandle, IODeviceType)
openFile' String
filepath IOMode
ReadWriteMode Bool
non_blocking (if Bool
excl then TempFileOptions
TempExcl else TempFileOptions
TempNonExcl)

-- | Open a file and make an 'NativeHandle' for it.  Truncates the file to zero

-- size when the `IOMode` is `WriteMode`.

openFile'
  :: FilePath -- ^ file to open

  -> IOMode   -- ^ mode in which to open the file

  -> Bool     -- ^ open the file in non-blocking mode?

  -> TempFileOptions
  -> IO (Io NativeHandle, IODeviceType)
openFile' :: String
-> IOMode
-> Bool
-> TempFileOptions
-> IO (IoHandle NativeHandle, IODeviceType)
openFile' String
filepath IOMode
iomode Bool
non_blocking TempFileOptions
tmp_opts =
   do devicepath <- String -> IO String
getDevicePath String
filepath
      h <- createFile devicepath
      -- Attach the handle to the I/O manager's CompletionPort.  This allows the

      -- I/O manager to service requests for this Handle.

      Mgr.associateHandle' h
      let hwnd = HANDLE -> IoHandle NativeHandle
forall a. RawHandle a => HANDLE -> a
fromHANDLE HANDLE
h
      _type <- devType hwnd

      -- Use the rts to enforce any file locking we may need.

      let write_lock = IOMode
iomode IOMode -> IOMode -> Bool
forall a. Eq a => a -> a -> Bool
/= IOMode
ReadMode

      case _type of
        -- Regular files need to be locked.

        -- See also Note [RTS File locking]

        IODeviceType
RegularFile -> do
          HANDLE -> IO ()
optimizeFileAccess HANDLE
h -- Set a few optimization flags on file handles.

          (unique_dev, unique_ino) <- IoHandle NativeHandle -> IO (Word64, Word64)
forall a. RawHandle a => a -> IO (Word64, Word64)
getUniqueFileInfo IoHandle NativeHandle
hwnd
          r <- lockFile (fromIntegral $ ptrToWordPtr h) unique_dev unique_ino
                        (fromBool write_lock)
          when (r == -1)  $
               ioException (IOError Nothing ResourceBusy "openFile"
                                  "file is locked" Nothing Nothing)

        -- I don't see a reason for blocking directories.  So unlike the FD

        -- implementation I'll allow it.

        IODeviceType
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- We want to truncate() if this is an open in WriteMode, but only

      -- if the target is a RegularFile.  but TRUNCATE_EXISTING would fail if

      -- the file didn't exit.  So just set the size afterwards.

      when (iomode == WriteMode && _type == RegularFile) $
        setSize hwnd 0

      return (hwnd, _type)
        where
          flagIf :: Bool -> p -> p
flagIf Bool
p p
f2
            | Bool
p         = p
f2
            | Bool
otherwise = p
0
          -- We have to use in-process locking (e.g. use the locking mechanism

          -- in the rts) so we're consistent with the linux behavior and the

          -- rts knows about the lock.  See #4363 for more.

          file_share_mode :: DWORD
file_share_mode =  DWORD
1
{-# LINE 901 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                         DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. DWORD
4
{-# LINE 902 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                         -- Don't support shared writing for temp files.

                         DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. (Bool -> DWORD -> DWORD
forall {p}. Num p => Bool -> p -> p
flagIf (TempFileOptions
tmp_opts TempFileOptions -> TempFileOptions -> Bool
forall a. Eq a => a -> a -> Bool
== TempFileOptions
NoTemp)
                                     DWORD
2)
{-# LINE 905 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}

          file_access_mode :: DWORD
file_access_mode =
            case IOMode
iomode of
              IOMode
ReadMode      -> DWORD
2147483648
{-# LINE 909 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
              IOMode
WriteMode     -> DWORD
1073741824
{-# LINE 910 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
              IOMode
ReadWriteMode -> DWORD
2147483648
{-# LINE 911 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                            DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. DWORD
1073741824
{-# LINE 912 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
              IOMode
AppendMode    -> DWORD
1073741824
{-# LINE 913 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                            DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. DWORD
4
{-# LINE 914 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}

          file_open_mode :: DWORD
file_open_mode =
            case IOMode
iomode of
              IOMode
ReadMode      -> DWORD
3 -- O_RDONLY

{-# LINE 918 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
              IOMode
WriteMode     -> DWORD
4   -- O_CREAT | O_WRONLY | O_TRUNC

{-# LINE 919 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
              IOMode
ReadWriteMode ->
                case TempFileOptions
tmp_opts of
                  TempFileOptions
NoTemp    -> DWORD
4   -- O_CREAT | O_RDWR

{-# LINE 922 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                  TempFileOptions
TempNonExcl ->  DWORD
2 -- O_CREAT | O_RDWR

{-# LINE 923 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                  TempFileOptions
TempExcl  -> DWORD
1    -- O_CREAT | O_RDWR | O_EXCL

{-# LINE 924 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
              IOMode
AppendMode    -> DWORD
4   -- O_APPEND

{-# LINE 925 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}

          file_create_flags :: DWORD
file_create_flags =
            if Bool
non_blocking
               -- On Windows, the choice of whether an operation completes

               -- asynchronously or not depends on how the Handle was created

               -- and not on the operation called.  As in, the behaviour of

               -- ReadFile and WriteFile depends on the flags used to open the

               -- handle.   For WinIO we always use FILE_FLAG_OVERLAPPED, which

               -- means we always issue asynchronous file operation using an

               -- OVERLAPPED structure.  All blocking, if required must be done

               -- on the Haskell side by using existing mechanisms such as MVar

               -- or IOPorts.

               then DWORD
1073741824
{-# LINE 938 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                    -- I believe most haskell programs do sequential scans, so

                    -- optimize for the common case.  Though ideally, this would

                    -- be parameterized by openFile.  This will absolutely trash

                    -- the cache on reverse scans.

                    --

                    -- TODO: make a parameter to openFile and specify only for

                    -- operations we know are sequential.  This parameter should

                    -- be usable by madvise too.

                    DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. DWORD
134217728
{-# LINE 947 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                    DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. (Bool -> DWORD -> DWORD
forall {p}. Num p => Bool -> p -> p
flagIf (TempFileOptions
tmp_opts TempFileOptions -> TempFileOptions -> Bool
forall a. Eq a => a -> a -> Bool
/= TempFileOptions
NoTemp)
                                -- Hold data in cache for as long as possible

                                DWORD
256 )
{-# LINE 950 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
               else DWORD
128
{-# LINE 951 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
                    DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.|. (Bool -> DWORD -> DWORD
forall {p}. Num p => Bool -> p -> p
flagIf (TempFileOptions
tmp_opts TempFileOptions -> TempFileOptions -> Bool
forall a. Eq a => a -> a -> Bool
/= TempFileOptions
NoTemp)
                                -- Hold data in cache for as long as possible

                                DWORD
256 )
{-# LINE 954 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}

          createFile :: String -> IO HANDLE
createFile String
devicepath =
            String -> (CWString -> IO HANDLE) -> IO HANDLE
forall a. String -> (CWString -> IO a) -> IO a
withCWString String
devicepath ((CWString -> IO HANDLE) -> IO HANDLE)
-> (CWString -> IO HANDLE) -> IO HANDLE
forall a b. (a -> b) -> a -> b
$ \CWString
fp ->
                (HANDLE -> Bool) -> String -> IO HANDLE -> IO HANDLE
forall a. (a -> Bool) -> String -> IO a -> IO a
failIf (HANDLE -> HANDLE -> Bool
forall a. Eq a => a -> a -> Bool
== HANDLE
iNVALID_HANDLE_VALUE) String
"CreateFile" (IO HANDLE -> IO HANDLE) -> IO HANDLE -> IO HANDLE
forall a b. (a -> b) -> a -> b
$
                      CWString
-> DWORD
-> DWORD
-> HANDLE
-> DWORD
-> DWORD
-> HANDLE
-> IO HANDLE
c_CreateFile CWString
fp DWORD
file_access_mode
                                      DWORD
file_share_mode
                                      HANDLE
forall a. Ptr a
nullPtr
                                      DWORD
file_open_mode
                                      DWORD
file_create_flags
                                      HANDLE
forall a. Ptr a
nullPtr

-- Tell the OS that we support skipping the request Queue if the

-- IRQ can be handled immediately, e.g. if the data is in the cache.

optimizeFileAccess :: HANDLE -> IO ()
optimizeFileAccess :: HANDLE -> IO ()
optimizeFileAccess HANDLE
handle =
    String -> IO Bool -> IO ()
failIfFalse_ String
"SetFileCompletionNotificationModes"  (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
      HANDLE -> UCHAR -> IO Bool
c_SetFileCompletionNotificationModes HANDLE
handle
          (    UCHAR
1
{-# LINE 972 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
            UCHAR -> UCHAR -> UCHAR
forall a. Bits a => a -> a -> a
.|. UCHAR
2)
{-# LINE 973 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}

-- Reconstruct an I/O mode from an open HANDLE

handleToMode :: HANDLE -> IO IOMode
handleToMode :: HANDLE -> IO IOMode
handleToMode HANDLE
hwnd = do
  mask <- HANDLE -> IO DWORD
c_get_handle_access_mask HANDLE
hwnd
  let hasFlag DWORD
flag = (DWORD
flag DWORD -> DWORD -> DWORD
forall a. Bits a => a -> a -> a
.&. DWORD
mask) DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
flag
  case () of
    () | DWORD -> Bool
hasFlag (DWORD
4)                        -> IOMode -> IO IOMode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IOMode
AppendMode
{-# LINE 981 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
       | hasFlag (1073741824 .|. 2147483648) -> return ReadWriteMode
{-# LINE 982 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
       | hasFlag (2147483648)                            -> return ReadMode
{-# LINE 983 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
       | hasFlag (1073741824)                           -> return WriteMode
{-# LINE 984 "libraries\\ghc-internal\\src\\GHC\\Internal\\IO\\Windows\\Handle.hsc" #-}
       | otherwise -> error "unknown access mask in handleToMode."

foreign import ccall unsafe "__get_handle_access_mask"
  c_get_handle_access_mask :: HANDLE -> IO DWORD

release :: RawHandle a => a -> IO ()
release :: forall a. RawHandle a => a -> IO ()
release a
h = if a -> Bool
forall a. RawHandle a => a -> Bool
isLockable a
h
               then do let handle :: CUIntPtr
handle = WordPtr -> CUIntPtr
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordPtr -> CUIntPtr) -> WordPtr -> CUIntPtr
forall a b. (a -> b) -> a -> b
$ HANDLE -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr (HANDLE -> WordPtr) -> HANDLE -> WordPtr
forall a b. (a -> b) -> a -> b
$ a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
h
                       _ <- CUIntPtr -> IO CInt
unlockFile CUIntPtr
handle
                       return ()
               else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- -----------------------------------------------------------------------------

-- Locking/unlocking


foreign import ccall unsafe "lockFile"
  lockFile :: CUIntPtr -> Word64 -> Word64 -> CInt -> IO CInt

foreign import ccall unsafe "unlockFile"
  unlockFile :: CUIntPtr -> IO CInt

-- | Returns -1 on error. Otherwise writes two values representing

-- the file into the given ptrs.

foreign import ccall unsafe "get_unique_file_info_hwnd"
  c_getUniqueFileInfo :: HANDLE -> Ptr Word64 -> Ptr Word64 -> IO ()

-- | getUniqueFileInfo assumes the C call to getUniqueFileInfo

-- succeeds.

getUniqueFileInfo :: RawHandle a => a -> IO (Word64, Word64)
getUniqueFileInfo :: forall a. RawHandle a => a -> IO (Word64, Word64)
getUniqueFileInfo a
handle = do
  Word64
-> (Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Word64
0 ((Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64))
-> (Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64)
forall a b. (a -> b) -> a -> b
$ \Ptr Word64
devptr -> do
    Word64
-> (Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Word64
0 ((Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64))
-> (Ptr Word64 -> IO (Word64, Word64)) -> IO (Word64, Word64)
forall a b. (a -> b) -> a -> b
$ \Ptr Word64
inoptr -> do
      HANDLE -> Ptr Word64 -> Ptr Word64 -> IO ()
c_getUniqueFileInfo (a -> HANDLE
forall a. RawHandle a => a -> HANDLE
toHANDLE a
handle) Ptr Word64
devptr Ptr Word64
inoptr
      (Word64 -> Word64 -> (Word64, Word64))
-> IO Word64 -> IO Word64 -> IO (Word64, Word64)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
devptr) (Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
inoptr)