{-# LINE 1 "System\\Win32\\Types.hsc" #-}



{-# LINE 2 "System\\Win32\\Types.hsc" #-}

{-# LANGUAGE Trustworthy #-}



{-# LINE 4 "System\\Win32\\Types.hsc" #-}

{-# LANGUAGE CPP #-}

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

-- |

-- Module      :  System.Win32.Types

-- Copyright   :  (c) Alastair Reid, 1997-2003

-- License     :  BSD-style (see the file libraries/base/LICENSE)

--

-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>

-- Stability   :  provisional

-- Portability :  portable

--

-- A collection of FFI declarations for interfacing with Win32.

--

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



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 51 "System\\Win32\\Types.hsc" #-}





{-# LINE 53 "System\\Win32\\Types.hsc" #-}

import Data.Bits (finiteBitSize)



{-# LINE 60 "System\\Win32\\Types.hsc" #-}







#include "windows_cconv.h"



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

-- Platform specific definitions

--

-- Most typedefs and prototypes in Win32 are expressed in terms

-- of these types.  Try to follow suit - it'll make it easier to

-- get things working on Win64 (or whatever they call it on Alphas).

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



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 104 "System\\Win32\\Types.hsc" #-}

type HALF_PTR      = Ptr INT32



{-# LINE 108 "System\\Win32\\Types.hsc" #-}



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

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



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

-- Pointers

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



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



-- Optional things with defaults



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



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

-- Chars and strings

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



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



-- UTF-16 version:

type TCHAR     = CWchar

withTString    = withCWString

withTStringLen = withCWStringLen

peekTString    = peekCWString

peekTStringLen = peekCWStringLen

newTString     = newCWString



{- ANSI version:

type TCHAR     = CChar

withTString    = withCString

withTStringLen = withCStringLen

peekTString    = peekCString

peekTStringLen = peekCStringLen

newTString     = newCString

-}



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

-- Handles

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



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



foreign import ccall "_open_osfhandle"

  _open_osfhandle :: CIntPtr -> CInt -> IO CInt



-- | Create a Haskell 'Handle' from a Windows 'HANDLE'.

--

-- Beware that this function allocates a new file descriptor. A consequence of

-- this is that calling 'hANDLEToHandle' on the standard Windows handles will

-- not give you 'IO.stdin', 'IO.stdout', or 'IO.stderr'. For example, if you

-- run this code:

--

-- @

-- import Graphics.Win32.Misc

-- stdoutHANDLE <- getStdHandle sTD_OUTPUT_HANDLE

-- stdout2 <- 'hANDLEToHandle' stdoutHANDLE

-- @

--

-- Then although you can use @stdout2@ to write to standard output, it is not

-- the case that @'IO.stdout' == stdout2@.

hANDLEToHandle :: HANDLE -> IO Handle

hANDLEToHandle handle =

  _open_osfhandle (fromIntegral (ptrToIntPtr handle)) (32768) >>= fdToHandle

{-# LINE 248 "System\\Win32\\Types.hsc" #-}



foreign import ccall unsafe "_get_osfhandle"

  c_get_osfhandle :: CInt -> IO HANDLE



-- | Extract a Windows 'HANDLE' from a Haskell 'Handle' and perform

-- an action on it.



-- Originally authored by Max Bolingbroke in the ansi-terminal library

withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a

withHandleToHANDLE haskell_handle action =

    -- Create a stable pointer to the Handle. This prevents the garbage collector

    -- getting to it while we are doing horrible manipulations with it, and hence

    -- stops it being finalized (and closed).

    withStablePtr haskell_handle $ const $ do

        -- Grab the write handle variable from the Handle

        let write_handle_mvar = case haskell_handle of

                FileHandle _ handle_mvar     -> handle_mvar

                DuplexHandle _ _ handle_mvar -> handle_mvar

                  -- This is "write" MVar, we could also take the "read" one



        -- Get the FD from the algebraic data type

        Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev))

                 $ readMVar write_handle_mvar



        -- Finally, turn that (C-land) FD into a HANDLE using msvcrt

        windows_handle <- c_get_osfhandle fd



        -- Do what the user originally wanted

        action windows_handle



withStablePtr :: a -> (StablePtr a -> IO b) -> IO b

withStablePtr value = bracket (newStablePtr value) freeStablePtr



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

-- Errors

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



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 323 "System\\Win32\\Types.hsc" #-}



eRROR_MOD_NOT_FOUND :: ErrCode

eRROR_MOD_NOT_FOUND = 126

{-# LINE 326 "System\\Win32\\Types.hsc" #-}



eRROR_PROC_NOT_FOUND :: ErrCode

eRROR_PROC_NOT_FOUND = 127

{-# LINE 329 "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

                   -- We ignore failure of freeing c_msg, given we're already failing

                   _ <- localFree c_msg

                   return msg

  -- turn GetLastError() into errno, which errnoToIOError knows how to convert

  -- to an IOException we can throw.

  errno <- c_maperrno_func err_code

  let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n

      ioerror = errnoToIOError fn_name errno Nothing Nothing

                  `ioeSetErrorString` msg'

  throwIO ioerror





foreign import ccall unsafe "maperrno_func" -- in base/cbits/Win32Utils.c

   c_maperrno_func :: ErrCode -> IO Errno



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

-- Misc helpers

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



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)



-- Support for API calls that are passed a fixed-size buffer and tell

-- you via the return value if the buffer was too small.  In that

-- case, we double the buffer size and try again.

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



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

-- Primitives

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



{-# 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



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

-- End

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