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

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Windows
-- Copyright   :  (c) The University of Glasgow, 2009
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- Windows functionality used by several modules.
--
-- ToDo: this just duplicates part of System.Win32.Types, which isn't
-- available yet.  We should move some Win32 functionality down here,
-- maybe as part of the grand reorganisation of the base package...
--
-----------------------------------------------------------------------------

module GHC.Windows (
#if defined(javascript_HOST_ARCH)
                   ) where

#else
        -- * Types
        BOOL,
        LPBOOL,
        BYTE,
        DWORD,
        DDWORD,
        UINT,
        ULONG,
        ErrCode,
        HANDLE,
        LPWSTR,
        LPTSTR,
        LPCTSTR,
        LPVOID,
        LPDWORD,
        LPSTR,
        LPCSTR,
        LPCWSTR,
        WORD,
        UCHAR,
        NTSTATUS,

        -- * Constants
        iNFINITE,
        iNVALID_HANDLE_VALUE,

        -- * System errors
        throwGetLastError,
        failWith,
        getLastError,
        getErrorMessage,
        errCodeToIOError,

        -- ** Guards for system calls that might fail
        failIf,
        failIf_,
        failIfNull,
        failIfZero,
        failIfFalse_,
        failUnlessSuccess,
        failUnlessSuccessOr,

        -- ** Mapping system errors to errno
        -- $errno
        c_maperrno,
        c_maperrno_func,

        -- * Misc
        ddwordToDwords,
        dwordsToDdword,
        nullHANDLE,
    ) where

import Data.Bits (finiteBitSize, shiftL, shiftR, (.|.), (.&.))
import Data.Char
import Data.OldList
import Data.Maybe
import Data.Word
import Data.Int
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import GHC.Base
import GHC.Enum (maxBound)
import GHC.IO
import GHC.Num
import GHC.Real (fromIntegral)
import System.IO.Error

import qualified Numeric

#include "windows_cconv.h"

type BOOL     = Bool
type LPBOOL   = Ptr BOOL
type BYTE     = Word8
type DWORD    = Word32
type UINT     = Word32
type ULONG    = Word32
type ErrCode  = DWORD
type HANDLE   = Ptr ()
type LPWSTR   = Ptr CWchar
type LPCTSTR  = LPTSTR
type LPVOID   = Ptr ()
type LPDWORD  = Ptr DWORD
type LPSTR    = Ptr CChar
type LPCSTR   = LPSTR
type LPCWSTR  = LPWSTR
type WORD     = Word16
type UCHAR    = Word8
type NTSTATUS = Int32

nullHANDLE :: HANDLE
nullHANDLE :: HANDLE
nullHANDLE = HANDLE
forall a. Ptr a
nullPtr

-- Not really a basic type, but used in many places
type DDWORD        = Word64

-- | Be careful with this.  LPTSTR can mean either WCHAR* or CHAR*, depending
-- on whether the UNICODE macro is defined in the corresponding C code.
-- Consider using LPWSTR instead.
type LPTSTR = LPWSTR

iNFINITE :: DWORD
iNFINITE :: DWORD
iNFINITE = DWORD
0xFFFFFFFF -- urgh

iNVALID_HANDLE_VALUE :: HANDLE
iNVALID_HANDLE_VALUE :: HANDLE
iNVALID_HANDLE_VALUE = WordPtr -> HANDLE
forall a. WordPtr -> Ptr a
wordPtrToPtr (-WordPtr
1)

-- | Get the last system error, and throw it as an 'IOError' exception.
throwGetLastError :: String -> IO a
throwGetLastError :: forall a. String -> IO a
throwGetLastError String
where_from =
    IO DWORD
getLastError IO DWORD -> (DWORD -> 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 -> DWORD -> IO a
forall a. String -> DWORD -> IO a
failWith String
where_from

-- | Convert a Windows error code to an exception, then throw it.
failWith :: String -> ErrCode -> IO a
failWith :: forall a. String -> DWORD -> IO a
failWith String
fn_name DWORD
err_code =
    String -> DWORD -> IO IOError
errCodeToIOError String
fn_name DWORD
err_code IO IOError -> (IOError -> 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
>>= IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO

-- | Convert a Windows error code to an exception.
errCodeToIOError :: String -> ErrCode -> IO IOError
errCodeToIOError :: String -> DWORD -> IO IOError
errCodeToIOError String
fn_name DWORD
err_code = do
    String
msg <- DWORD -> IO String
getErrorMessage DWORD
err_code

    -- turn GetLastError() into errno, which errnoToIOError knows
    -- how to convert to an IOException we can throw.
    -- XXX we should really do this directly.
    let errno :: Errno
errno = DWORD -> Errno
c_maperrno_func DWORD
err_code

    let msg' :: String
msg' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace String
msg -- drop trailing \n
        ioerror :: IOError
ioerror = String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
fn_name Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
                    IOError -> String -> IOError
`ioeSetErrorString` String
msg'
    IOError -> IO IOError
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IOError
ioerror

-- | Get a string describing a Windows error code.  This uses the
-- @FormatMessage@ system call.
getErrorMessage :: ErrCode -> IO String
getErrorMessage :: DWORD -> IO String
getErrorMessage DWORD
err_code =
    IO String -> IO String
forall a. IO a -> IO a
mask_ (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ do
        LPWSTR
c_msg <- DWORD -> IO LPWSTR
c_getErrorMessage DWORD
err_code
        if LPWSTR
c_msg LPWSTR -> LPWSTR -> Bool
forall a. Eq a => a -> a -> Bool
== LPWSTR
forall a. Ptr a
nullPtr
          then String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Error 0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DWORD -> String -> String
forall a. Integral a => a -> String -> String
Numeric.showHex DWORD
err_code String
""
          else do String
msg <- LPWSTR -> IO String
peekCWString LPWSTR
c_msg
                  -- We ignore failure of freeing c_msg, given we're already failing
                  LPWSTR
_ <- LPWSTR -> IO LPWSTR
forall a. Ptr a -> IO (Ptr a)
localFree LPWSTR
c_msg
                  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
msg

failIf :: (a -> Bool) -> String -> IO a -> IO a
failIf :: forall a. (a -> Bool) -> String -> IO a -> IO a
failIf a -> Bool
p String
wh IO a
act = do
    a
v <- IO a
act
    if a -> Bool
p a
v then String -> IO a
forall a. String -> IO a
throwGetLastError String
wh else a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

failIf_ :: (a -> Bool) -> String -> IO a -> IO ()
failIf_ :: forall a. (a -> Bool) -> String -> IO a -> IO ()
failIf_ a -> Bool
p String
wh IO a
act = do
    a
v <- IO a
act
    if a -> Bool
p a
v then String -> IO ()
forall a. String -> IO a
throwGetLastError String
wh else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
failIfNull :: forall a. String -> IO (Ptr a) -> IO (Ptr a)
failIfNull = (Ptr a -> Bool) -> String -> IO (Ptr a) -> IO (Ptr a)
forall a. (a -> Bool) -> String -> IO a -> IO a
failIf (Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr)

failIfZero :: (Eq a, Num a) => String -> IO a -> IO a
failIfZero :: forall a. (Eq a, Num a) => String -> IO a -> IO a
failIfZero = (a -> Bool) -> String -> IO a -> IO a
forall a. (a -> Bool) -> String -> IO a -> IO a
failIf (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0)

failIfFalse_ :: String -> IO Bool -> IO ()
failIfFalse_ :: String -> IO Bool -> IO ()
failIfFalse_ = (Bool -> Bool) -> String -> IO Bool -> IO ()
forall a. (a -> Bool) -> String -> IO a -> IO ()
failIf_ Bool -> Bool
not

failUnlessSuccess :: String -> IO ErrCode -> IO ()
failUnlessSuccess :: String -> IO DWORD -> IO ()
failUnlessSuccess String
fn_name IO DWORD
act = do
    DWORD
r <- IO DWORD
act
    if DWORD
r DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
0 then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else String -> DWORD -> IO ()
forall a. String -> DWORD -> IO a
failWith String
fn_name DWORD
r

failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
failUnlessSuccessOr :: DWORD -> String -> IO DWORD -> IO Bool
failUnlessSuccessOr DWORD
val String
fn_name IO DWORD
act = do
    DWORD
r <- IO DWORD
act
    if DWORD
r DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
0 then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else if DWORD
r DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
val then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else String -> DWORD -> IO Bool
forall a. String -> DWORD -> IO a
failWith String
fn_name DWORD
r

-- $errno
--
-- On Windows, @errno@ is defined by msvcrt.dll for compatibility with other
-- systems, and is distinct from the system error as returned
-- by @GetLastError@.

-- | Map the last system error to an errno value, and assign it to @errno@.
foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
   c_maperrno :: IO ()

-- | Pure function variant of 'c_maperrno' that does not call @GetLastError@
-- or modify @errno@.
foreign import ccall unsafe "maperrno_func"        -- in Win32Utils.c
   c_maperrno_func :: ErrCode -> Errno

foreign import ccall unsafe "base_getErrorMessage" -- in Win32Utils.c
    c_getErrorMessage :: DWORD -> IO LPWSTR

foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"
    localFree :: Ptr a -> IO (Ptr a)

-- | Get the last system error produced in the current thread.
foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
    getLastError :: IO ErrCode

----------------------------------------------------------------
-- Misc helpers
----------------------------------------------------------------

ddwordToDwords :: DDWORD -> (DWORD,DWORD)
ddwordToDwords :: DDWORD -> (DWORD, DWORD)
ddwordToDwords DDWORD
n =
        (DDWORD -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DDWORD
n DDWORD -> Int -> DDWORD
forall a. Bits a => a -> Int -> a
`shiftR` DWORD -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (DWORD
forall a. HasCallStack => a
undefined :: DWORD))
        ,DDWORD -> DWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DDWORD
n DDWORD -> DDWORD -> DDWORD
forall a. Bits a => a -> a -> a
.&. DWORD -> DDWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DWORD
forall a. Bounded a => a
maxBound :: DWORD)))

dwordsToDdword:: (DWORD,DWORD) -> DDWORD
dwordsToDdword :: (DWORD, DWORD) -> DDWORD
dwordsToDdword (DWORD
hi,DWORD
low) = (DWORD -> DDWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral DWORD
low) DDWORD -> DDWORD -> DDWORD
forall a. Bits a => a -> a -> a
.|. (DWORD -> DDWORD
forall a b. (Integral a, Num b) => a -> b
fromIntegral DWORD
hi DDWORD -> Int -> DDWORD
forall a. Bits a => a -> Int -> a
`shiftL` DWORD -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize DWORD
hi)

#endif