{-# LINE 1 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
module System.Win32.Types
( module System.Win32.Types
, nullPtr
) where
import Control.Concurrent.MVar (readMVar)
import Control.Exception (bracket, throwIO)
import Data.Bits (shiftL, shiftR, (.|.), (.&.))
import Data.Char (isSpace)
import Data.Int (Int32, Int64, Int16)
import Data.Maybe (fromMaybe)
import Data.Typeable (cast)
import Data.Word (Word8, Word16, Word32, Word64)
import Foreign.C.Error (Errno(..), errnoToIOError)
import Foreign.C.String (newCWString, withCWStringLen)
import Foreign.C.String (peekCWString, peekCWStringLen, withCWString)
import Foreign.C.Types (CChar, CUChar, CWchar, CInt(..), CIntPtr(..), CUIntPtr)
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_)
import Foreign.Ptr (FunPtr, Ptr, nullPtr, ptrToIntPtr)
import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr)
import Foreign (allocaArray)
import GHC.IO.FD (FD(..))
import GHC.IO.Handle.FD (fdToHandle)
import GHC.IO.Handle.Types (Handle(..), Handle__(..))
import Numeric (showHex)
import qualified System.IO as IO ()
import System.IO.Error (ioeSetErrorString)
import System.IO.Unsafe (unsafePerformIO)
{-# LINE 49 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
{-# LINE 51 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
import Data.Bits (finiteBitSize)
{-# LINE 58 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
#if defined(__IO_MANAGER_WINIO__)
import Control.Monad (when, liftM2)
import Foreign.C.Types (CUIntPtr(..))
import Foreign.Marshal.Utils (fromBool, with)
import Foreign (peek)
import Foreign.Ptr (ptrToWordPtr)
import GHC.IO.Exception (ioException, IOException(..),
IOErrorType(InappropriateType, ResourceBusy))
import GHC.IO.SubSystem ((<!>))
import GHC.IO.Handle.Windows
import GHC.IO.IOMode
import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle(), ConsoleHandle(),
toHANDLE, handleToMode, optimizeFileAccess)
import qualified GHC.Event.Windows as Mgr
import GHC.IO.Device (IODeviceType(..), devType)
#endif
#include "windows_cconv.h"
type BOOL = Bool
type BYTE = Word8
type UCHAR = CUChar
type USHORT = Word16
type UINT = Word32
type INT = Int32
type WORD = Word16
type DWORD = Word32
type LONG = Int32
type FLOAT = Float
type LARGE_INTEGER = Int64
type DWORD32 = Word32
type DWORD64 = Word64
type INT32 = Int32
type INT64 = Int64
type LONG32 = Int32
type LONG64 = Int64
type UINT32 = Word32
type UINT64 = Word64
type ULONG32 = Word32
type ULONG64 = Word64
type SHORT = Int16
type INT_PTR = Ptr CInt
type ULONG = Word32
type UINT_PTR = Word
type LONG_PTR = CIntPtr
type ULONG_PTR = CUIntPtr
type DWORD_PTR = ULONG_PTR
{-# LINE 119 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
type HALF_PTR = Ptr INT32
{-# LINE 123 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
type DDWORD = Word64
type MbString = Maybe String
type MbINT = Maybe INT
type ATOM = WORD
type WPARAM = UINT_PTR
type LPARAM = LONG_PTR
type LRESULT = LONG_PTR
type SIZE_T = ULONG_PTR
type MbATOM = Maybe ATOM
type HRESULT = LONG
type Addr = Ptr ()
type LPVOID = Ptr ()
type LPBOOL = Ptr BOOL
type LPBYTE = Ptr BYTE
type PUCHAR = Ptr UCHAR
type LPDWORD = Ptr DWORD
type LPSTR = Ptr CChar
type LPCSTR = LPSTR
type LPWSTR = Ptr CWchar
type LPCWSTR = LPWSTR
type LPTSTR = Ptr TCHAR
type LPCTSTR = LPTSTR
type LPCTSTR_ = LPCTSTR
maybePtr :: Maybe (Ptr a) -> Ptr a
maybePtr = fromMaybe nullPtr
ptrToMaybe :: Ptr a -> Maybe (Ptr a)
ptrToMaybe p = if p == nullPtr then Nothing else Just p
maybeNum :: Num a => Maybe a -> a
maybeNum = fromMaybe 0
numToMaybe :: (Eq a, Num a) => a -> Maybe a
numToMaybe n = if n == 0 then Nothing else Just n
type MbLPVOID = Maybe LPVOID
type MbLPCSTR = Maybe LPCSTR
type MbLPCTSTR = Maybe LPCTSTR
withTString :: String -> (LPTSTR -> IO a) -> IO a
withTStringLen :: String -> ((LPTSTR, Int) -> IO a) -> IO a
peekTString :: LPCTSTR -> IO String
peekTStringLen :: (LPCTSTR, Int) -> IO String
newTString :: String -> IO LPCTSTR
type TCHAR = CWchar
withTString = withCWString
withTStringLen = withCWStringLen
peekTString = peekCWString
peekTStringLen = peekCWStringLen
newTString = newCWString
type HANDLE = Ptr ()
type ForeignHANDLE = ForeignPtr ()
newForeignHANDLE :: HANDLE -> IO ForeignHANDLE
newForeignHANDLE = newForeignPtr deleteObjectFinaliser
handleToWord :: HANDLE -> UINT_PTR
handleToWord = castPtrToUINTPtr
type HKEY = ForeignHANDLE
type PKEY = HANDLE
nullHANDLE :: HANDLE
nullHANDLE = nullPtr
type MbHANDLE = Maybe HANDLE
nullHINSTANCE :: HINSTANCE
nullHINSTANCE = nullPtr
type HINSTANCE = Ptr ()
type MbHINSTANCE = Maybe HINSTANCE
type HMODULE = Ptr ()
type MbHMODULE = Maybe HMODULE
nullFinalHANDLE :: ForeignPtr a
nullFinalHANDLE = unsafePerformIO (newForeignPtr_ nullPtr)
iNVALID_HANDLE_VALUE :: HANDLE
iNVALID_HANDLE_VALUE = castUINTPtrToPtr maxBound
iNVALID_SET_FILE_POINTER :: DWORD
iNVALID_SET_FILE_POINTER = 4294967295
{-# LINE 244 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
foreign import ccall "_open_osfhandle"
_open_osfhandle :: CIntPtr -> CInt -> IO CInt
hANDLEToHandle :: HANDLE -> IO Handle
hANDLEToHandle handle = posix
#if defined(__IO_MANAGER_WINIO__)
<!> native
#endif
where
#if defined(__IO_MANAGER_WINIO__)
native = do
Mgr.associateHandle' handle
let hwnd = fromHANDLE handle :: Io NativeHandle
_type <- devType hwnd
mode <- handleToMode handle
let write_lock = mode /= ReadMode
case _type of
RegularFile -> do
optimizeFileAccess handle
(unique_dev, unique_ino) <- getUniqueFileInfo handle
r <- internal_lockFile
(fromIntegral $ ptrToWordPtr handle) unique_dev unique_ino
(fromBool write_lock)
when (r == -1) $
ioException (IOError Nothing ResourceBusy "hANDLEToHandle"
"file is locked" Nothing Nothing)
_ -> return ()
mkHandleFromHANDLE hwnd Stream ("hwnd:" ++ show handle) mode Nothing
getUniqueFileInfo :: HANDLE -> IO (Word64, Word64)
getUniqueFileInfo hnl = do
with 0 $ \devptr -> do
with 0 $ \inoptr -> do
internal_getUniqueFileInfo hnl devptr inoptr
liftM2 (,) (peek devptr) (peek inoptr)
#endif
posix = _open_osfhandle (fromIntegral (ptrToIntPtr handle))
(32768) >>= fdToHandle
{-# LINE 310 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
#if defined(__IO_MANAGER_WINIO__)
foreign import ccall unsafe "lockFile"
internal_lockFile :: CUIntPtr -> Word64 -> Word64 -> CInt -> IO CInt
foreign import ccall unsafe "get_unique_file_info_hwnd"
internal_getUniqueFileInfo :: HANDLE -> Ptr Word64 -> Ptr Word64 -> IO ()
#endif
foreign import ccall unsafe "_get_osfhandle"
c_get_osfhandle :: CInt -> IO HANDLE
withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
#if defined(__IO_MANAGER_WINIO__)
withHandleToHANDLE = withHandleToHANDLEPosix <!> withHandleToHANDLENative
#else
withHandleToHANDLE = withHandleToHANDLEPosix
#endif
#if defined(__IO_MANAGER_WINIO__)
withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLENative haskell_handle action =
withStablePtr haskell_handle $ const $ do
let write_handle_mvar = case haskell_handle of
FileHandle _ handle_mvar -> handle_mvar
DuplexHandle _ _ handle_mvar -> handle_mvar
windows_handle <- readMVar write_handle_mvar >>= handle_ToHANDLE
action windows_handle
where
handle_ToHANDLE :: Handle__ -> IO HANDLE
handle_ToHANDLE (Handle__{haDevice = dev}) =
case (cast dev :: Maybe (Io NativeHandle), cast dev :: Maybe (Io ConsoleHandle)) of
(Just hwnd, Nothing) -> return $ toHANDLE hwnd
(Nothing, Just hwnd) -> return $ toHANDLE hwnd
_ -> throwErr "not a known HANDLE"
throwErr msg = ioException $ IOError (Just haskell_handle)
InappropriateType "withHandleToHANDLENative" msg Nothing Nothing
#endif
withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLEPosix haskell_handle action =
withStablePtr haskell_handle $ const $ do
let write_handle_mvar = case haskell_handle of
FileHandle _ handle_mvar -> handle_mvar
DuplexHandle _ _ handle_mvar -> handle_mvar
Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev))
$ readMVar write_handle_mvar
windows_handle <- c_get_osfhandle fd
action windows_handle
withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
withStablePtr value = bracket (newStablePtr value) freeStablePtr
type ErrCode = DWORD
failIf :: (a -> Bool) -> String -> IO a -> IO a
failIf p wh act = do
v <- act
if p v then errorWin wh else return v
failIf_ :: (a -> Bool) -> String -> IO a -> IO ()
failIf_ p wh act = do
v <- act
if p v then errorWin wh else return ()
failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a
failIfNeg = failIf (< 0)
failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
failIfNull = failIf (== nullPtr)
failIfZero :: (Eq a, Num a) => String -> IO a -> IO a
failIfZero = failIf (== 0)
failIfFalse_ :: String -> IO Bool -> IO ()
failIfFalse_ = failIf_ not
failUnlessSuccess :: String -> IO ErrCode -> IO ()
failUnlessSuccess fn_name act = do
r <- act
if r == 0 then return () else failWith fn_name r
failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
failUnlessSuccessOr val fn_name act = do
r <- act
if r == 0 then return False
else if r == val then return True
else failWith fn_name r
eRROR_INSUFFICIENT_BUFFER :: ErrCode
eRROR_INSUFFICIENT_BUFFER = 122
{-# LINE 432 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
eRROR_MOD_NOT_FOUND :: ErrCode
eRROR_MOD_NOT_FOUND = 126
{-# LINE 435 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
eRROR_PROC_NOT_FOUND :: ErrCode
eRROR_PROC_NOT_FOUND = 127
{-# LINE 438 "libraries\\Win32\\System\\Win32\\Types.hsc" #-}
errorWin :: String -> IO a
errorWin fn_name = do
err_code <- getLastError
failWith fn_name err_code
failWith :: String -> ErrCode -> IO a
failWith fn_name err_code = do
c_msg <- getErrorMessage err_code
msg <- if c_msg == nullPtr
then return $ "Error 0x" ++ Numeric.showHex err_code ""
else do msg <- peekTString c_msg
_ <- localFree c_msg
return msg
errno <- c_maperrno_func err_code
let msg' = reverse $ dropWhile isSpace $ reverse msg
ioerror = errnoToIOError fn_name errno Nothing Nothing
`ioeSetErrorString` msg'
throwIO ioerror
foreign import ccall unsafe "maperrno_func"
c_maperrno_func :: ErrCode -> IO Errno
ddwordToDwords :: DDWORD -> (DWORD,DWORD)
ddwordToDwords n =
(fromIntegral (n `shiftR` finiteBitSize (undefined :: DWORD))
,fromIntegral (n .&. fromIntegral (maxBound :: DWORD)))
dwordsToDdword:: (DWORD,DWORD) -> DDWORD
dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL` finiteBitSize hi)
try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
try loc f n = do
e <- allocaArray (fromIntegral n) $ \lptstr -> do
r <- failIfZero loc $ f lptstr n
if (r > n) then return (Left r) else do
str <- peekTStringLen (lptstr, fromIntegral r)
return (Right str)
case e of
Left n' -> try loc f n'
Right str -> return str
{-# CFILES cbits/HsWin32.c #-}
foreign import ccall "HsWin32.h &DeleteObjectFinaliser"
deleteObjectFinaliser :: FunPtr (Ptr a -> IO ())
foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"
localFree :: Ptr a -> IO (Ptr a)
foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
getLastError :: IO ErrCode
foreign import WINDOWS_CCONV unsafe "windows.h SetLastError"
setLastError :: ErrCode -> IO ()
{-# CFILES cbits/errors.c #-}
foreign import ccall unsafe "errors.h"
getErrorMessage :: DWORD -> IO LPWSTR
{-# CFILES cbits/HsWin32.c #-}
foreign import ccall unsafe "HsWin32.h"
lOWORD :: DWORD -> WORD
foreign import ccall unsafe "HsWin32.h"
hIWORD :: DWORD -> WORD
foreign import ccall unsafe "HsWin32.h"
castUINTPtrToPtr :: UINT_PTR -> Ptr a
foreign import ccall unsafe "HsWin32.h"
castPtrToUINTPtr :: Ptr s -> UINT_PTR
type LCID = DWORD
type LANGID = WORD
type SortID = WORD
foreign import ccall unsafe "HsWin32.h prim_MAKELCID"
mAKELCID :: LANGID -> SortID -> LCID
foreign import ccall unsafe "HsWin32.h prim_LANGIDFROMLCID"
lANGIDFROMLCID :: LCID -> LANGID
foreign import ccall unsafe "HsWin32.h prim_SORTIDFROMLCID"
sORTIDFROMLCID :: LCID -> SortID
type SubLANGID = WORD
type PrimaryLANGID = WORD
foreign import ccall unsafe "HsWin32.h prim_MAKELANGID"
mAKELANGID :: PrimaryLANGID -> SubLANGID -> LANGID
foreign import ccall unsafe "HsWin32.h prim_PRIMARYLANGID"
pRIMARYLANGID :: LANGID -> PrimaryLANGID
foreign import ccall unsafe "HsWin32.h prim_SUBLANGID"
sUBLANGID :: LANGID -> SubLANGID