1#if __GLASGOW_HASKELL__ >= 701
2{-# LANGUAGE Trustworthy #-}
3#endif
4{-# LANGUAGE CPP #-}
5-----------------------------------------------------------------------------
6-- |
7-- Module      :  System.Win32.Types
8-- Copyright   :  (c) Alastair Reid, 1997-2003
9-- License     :  BSD-style (see the file libraries/base/LICENSE)
10--
11-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>
12-- Stability   :  provisional
13-- Portability :  portable
14--
15-- A collection of FFI declarations for interfacing with Win32.
16--
17-----------------------------------------------------------------------------
18
19module System.Win32.Types
20        ( module System.Win32.Types
21        , nullPtr
22        ) where
23
24import Control.Concurrent.MVar (readMVar)
25import Control.Exception (bracket, throwIO)
26import Data.Bits (shiftL, shiftR, (.|.), (.&.))
27import Data.Char (isSpace)
28import Data.Int (Int32, Int64, Int16)
29import Data.Maybe (fromMaybe)
30import Data.Typeable (cast)
31import Data.Word (Word8, Word16, Word32, Word64)
32import Foreign.C.Error (Errno(..), errnoToIOError)
33import Foreign.C.String (newCWString, withCWStringLen)
34import Foreign.C.String (peekCWString, peekCWStringLen, withCWString)
35import Foreign.C.Types (CChar, CUChar, CWchar, CInt(..), CIntPtr(..), CUIntPtr)
36import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_)
37import Foreign.Ptr (FunPtr, Ptr, nullPtr, ptrToIntPtr)
38import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr)
39import Foreign (allocaArray)
40import GHC.IO.FD (FD(..))
41import GHC.IO.Handle.FD (fdToHandle)
42import GHC.IO.Handle.Types (Handle(..), Handle__(..))
43import Numeric (showHex)
44import qualified System.IO as IO ()
45import System.IO.Error (ioeSetErrorString)
46import System.IO.Unsafe (unsafePerformIO)
47
48#if !MIN_VERSION_base(4,8,0)
49import Data.Word (Word)
50#endif
51
52#if MIN_VERSION_base(4,7,0)
53import Data.Bits (finiteBitSize)
54#else
55import Data.Bits (Bits, bitSize)
56
57finiteBitSize :: (Bits a) => a -> Int
58finiteBitSize = bitSize
59#endif
60
61#include <fcntl.h>
62#include <windows.h>
63##include "windows_cconv.h"
64
65----------------------------------------------------------------
66-- Platform specific definitions
67--
68-- Most typedefs and prototypes in Win32 are expressed in terms
69-- of these types.  Try to follow suit - it'll make it easier to
70-- get things working on Win64 (or whatever they call it on Alphas).
71----------------------------------------------------------------
72
73type BOOL          = Bool
74type BYTE          = Word8
75type UCHAR         = CUChar
76type USHORT        = Word16
77type UINT          = Word32
78type INT           = Int32
79type WORD          = Word16
80type DWORD         = Word32
81type LONG          = Int32
82type FLOAT         = Float
83type LARGE_INTEGER = Int64
84
85type DWORD32       = Word32
86type DWORD64       = Word64
87type INT32         = Int32
88type INT64         = Int64
89type LONG32        = Int32
90type LONG64        = Int64
91type UINT32        = Word32
92type UINT64        = Word64
93type ULONG32       = Word32
94type ULONG64       = Word64
95type SHORT         = Int16
96
97type DWORD_PTR     = Ptr DWORD32
98type INT_PTR       = Ptr CInt
99type ULONG         = Word32
100type UINT_PTR      = Word
101type LONG_PTR      = CIntPtr
102type ULONG_PTR     = CUIntPtr
103#ifdef _WIN64
104type HALF_PTR      = Ptr INT32
105#else
106type HALF_PTR      = Ptr SHORT
107#endif
108
109-- Not really a basic type, but used in many places
110type DDWORD        = Word64
111
112----------------------------------------------------------------
113
114type MbString      = Maybe String
115type MbINT         = Maybe INT
116
117type ATOM          = WORD
118type WPARAM        = UINT_PTR
119type LPARAM        = LONG_PTR
120type LRESULT       = LONG_PTR
121type SIZE_T        = ULONG_PTR
122
123type MbATOM        = Maybe ATOM
124
125type HRESULT       = LONG
126
127----------------------------------------------------------------
128-- Pointers
129----------------------------------------------------------------
130
131type Addr          = Ptr ()
132
133type LPVOID        = Ptr ()
134type LPBOOL        = Ptr BOOL
135type LPBYTE        = Ptr BYTE
136type PUCHAR        = Ptr UCHAR
137type LPDWORD       = Ptr DWORD
138type LPSTR         = Ptr CChar
139type LPCSTR        = LPSTR
140type LPWSTR        = Ptr CWchar
141type LPCWSTR       = LPWSTR
142type LPTSTR        = Ptr TCHAR
143type LPCTSTR       = LPTSTR
144type LPCTSTR_      = LPCTSTR
145
146-- Optional things with defaults
147
148maybePtr :: Maybe (Ptr a) -> Ptr a
149maybePtr = fromMaybe nullPtr
150
151ptrToMaybe :: Ptr a -> Maybe (Ptr a)
152ptrToMaybe p = if p == nullPtr then Nothing else Just p
153
154maybeNum :: Num a => Maybe a -> a
155maybeNum = fromMaybe 0
156
157numToMaybe :: (Eq a, Num a) => a -> Maybe a
158numToMaybe n = if n == 0 then Nothing else Just n
159
160type MbLPVOID      = Maybe LPVOID
161type MbLPCSTR      = Maybe LPCSTR
162type MbLPCTSTR     = Maybe LPCTSTR
163
164----------------------------------------------------------------
165-- Chars and strings
166----------------------------------------------------------------
167
168withTString    :: String -> (LPTSTR -> IO a) -> IO a
169withTStringLen :: String -> ((LPTSTR, Int) -> IO a) -> IO a
170peekTString    :: LPCTSTR -> IO String
171peekTStringLen :: (LPCTSTR, Int) -> IO String
172newTString     :: String -> IO LPCTSTR
173
174-- UTF-16 version:
175type TCHAR     = CWchar
176withTString    = withCWString
177withTStringLen = withCWStringLen
178peekTString    = peekCWString
179peekTStringLen = peekCWStringLen
180newTString     = newCWString
181
182{- ANSI version:
183type TCHAR     = CChar
184withTString    = withCString
185withTStringLen = withCStringLen
186peekTString    = peekCString
187peekTStringLen = peekCStringLen
188newTString     = newCString
189-}
190
191----------------------------------------------------------------
192-- Handles
193----------------------------------------------------------------
194
195type   HANDLE      = Ptr ()
196type   ForeignHANDLE = ForeignPtr ()
197
198newForeignHANDLE :: HANDLE -> IO ForeignHANDLE
199newForeignHANDLE = newForeignPtr deleteObjectFinaliser
200
201handleToWord :: HANDLE -> UINT_PTR
202handleToWord = castPtrToUINTPtr
203
204type   HKEY        = ForeignHANDLE
205type   PKEY        = HANDLE
206
207nullHANDLE :: HANDLE
208nullHANDLE = nullPtr
209
210type MbHANDLE      = Maybe HANDLE
211
212nullHINSTANCE :: HINSTANCE
213nullHINSTANCE = nullPtr
214
215type   HINSTANCE   = Ptr ()
216type MbHINSTANCE   = Maybe HINSTANCE
217
218type   HMODULE     = Ptr ()
219type MbHMODULE     = Maybe HMODULE
220
221nullFinalHANDLE :: ForeignPtr a
222nullFinalHANDLE = unsafePerformIO (newForeignPtr_ nullPtr)
223
224iNVALID_HANDLE_VALUE :: HANDLE
225iNVALID_HANDLE_VALUE = castUINTPtrToPtr maxBound
226
227foreign import ccall "_open_osfhandle"
228  _open_osfhandle :: CIntPtr -> CInt -> IO CInt
229
230-- | Create a Haskell 'Handle' from a Windows 'HANDLE'.
231--
232-- Beware that this function allocates a new file descriptor. A consequence of
233-- this is that calling 'hANDLEToHandle' on the standard Windows handles will
234-- not give you 'IO.stdin', 'IO.stdout', or 'IO.stderr'. For example, if you
235-- run this code:
236--
237-- @
238-- import Graphics.Win32.Misc
239-- stdoutHANDLE <- getStdHandle sTD_OUTPUT_HANDLE
240-- stdout2 <- 'hANDLEToHandle' stdoutHANDLE
241-- @
242--
243-- Then although you can use @stdout2@ to write to standard output, it is not
244-- the case that @'IO.stdout' == stdout2@.
245hANDLEToHandle :: HANDLE -> IO Handle
246hANDLEToHandle handle =
247  _open_osfhandle (fromIntegral (ptrToIntPtr handle)) (#const _O_BINARY) >>= fdToHandle
248
249foreign import ccall unsafe "_get_osfhandle"
250  c_get_osfhandle :: CInt -> IO HANDLE
251
252-- | Extract a Windows 'HANDLE' from a Haskell 'Handle' and perform
253-- an action on it.
254
255-- Originally authored by Max Bolingbroke in the ansi-terminal library
256withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
257withHandleToHANDLE haskell_handle action =
258    -- Create a stable pointer to the Handle. This prevents the garbage collector
259    -- getting to it while we are doing horrible manipulations with it, and hence
260    -- stops it being finalized (and closed).
261    withStablePtr haskell_handle $ const $ do
262        -- Grab the write handle variable from the Handle
263        let write_handle_mvar = case haskell_handle of
264                FileHandle _ handle_mvar     -> handle_mvar
265                DuplexHandle _ _ handle_mvar -> handle_mvar
266                  -- This is "write" MVar, we could also take the "read" one
267
268        -- Get the FD from the algebraic data type
269        Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev))
270                 $ readMVar write_handle_mvar
271
272        -- Finally, turn that (C-land) FD into a HANDLE using msvcrt
273        windows_handle <- c_get_osfhandle fd
274
275        -- Do what the user originally wanted
276        action windows_handle
277
278withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
279withStablePtr value = bracket (newStablePtr value) freeStablePtr
280
281----------------------------------------------------------------
282-- Errors
283----------------------------------------------------------------
284
285type ErrCode = DWORD
286
287failIf :: (a -> Bool) -> String -> IO a -> IO a
288failIf p wh act = do
289  v <- act
290  if p v then errorWin wh else return v
291
292failIf_ :: (a -> Bool) -> String -> IO a -> IO ()
293failIf_ p wh act = do
294  v <- act
295  if p v then errorWin wh else return ()
296
297failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a
298failIfNeg = failIf (< 0)
299
300failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
301failIfNull = failIf (== nullPtr)
302
303failIfZero :: (Eq a, Num a) => String -> IO a -> IO a
304failIfZero = failIf (== 0)
305
306failIfFalse_ :: String -> IO Bool -> IO ()
307failIfFalse_ = failIf_ not
308
309failUnlessSuccess :: String -> IO ErrCode -> IO ()
310failUnlessSuccess fn_name act = do
311  r <- act
312  if r == 0 then return () else failWith fn_name r
313
314failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
315failUnlessSuccessOr val fn_name act = do
316  r <- act
317  if r == 0 then return False
318    else if r == val then return True
319    else failWith fn_name r
320
321eRROR_INSUFFICIENT_BUFFER :: ErrCode
322eRROR_INSUFFICIENT_BUFFER = #const ERROR_INSUFFICIENT_BUFFER
323
324eRROR_MOD_NOT_FOUND :: ErrCode
325eRROR_MOD_NOT_FOUND = #const ERROR_MOD_NOT_FOUND
326
327eRROR_PROC_NOT_FOUND :: ErrCode
328eRROR_PROC_NOT_FOUND = #const ERROR_PROC_NOT_FOUND
329
330
331errorWin :: String -> IO a
332errorWin fn_name = do
333  err_code <- getLastError
334  failWith fn_name err_code
335
336failWith :: String -> ErrCode -> IO a
337failWith fn_name err_code = do
338  c_msg <- getErrorMessage err_code
339  msg <- if c_msg == nullPtr
340           then return $ "Error 0x" ++ Numeric.showHex err_code ""
341           else do msg <- peekTString c_msg
342                   -- We ignore failure of freeing c_msg, given we're already failing
343                   _ <- localFree c_msg
344                   return msg
345  -- turn GetLastError() into errno, which errnoToIOError knows how to convert
346  -- to an IOException we can throw.
347  errno <- c_maperrno_func err_code
348  let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n
349      ioerror = errnoToIOError fn_name errno Nothing Nothing
350                  `ioeSetErrorString` msg'
351  throwIO ioerror
352
353
354foreign import ccall unsafe "maperrno_func" -- in base/cbits/Win32Utils.c
355   c_maperrno_func :: ErrCode -> IO Errno
356
357----------------------------------------------------------------
358-- Misc helpers
359----------------------------------------------------------------
360
361ddwordToDwords :: DDWORD -> (DWORD,DWORD)
362ddwordToDwords n =
363        (fromIntegral (n `shiftR` finiteBitSize (undefined :: DWORD))
364        ,fromIntegral (n .&. fromIntegral (maxBound :: DWORD)))
365
366dwordsToDdword:: (DWORD,DWORD) -> DDWORD
367dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL` finiteBitSize hi)
368
369-- Support for API calls that are passed a fixed-size buffer and tell
370-- you via the return value if the buffer was too small.  In that
371-- case, we double the buffer size and try again.
372try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
373try loc f n = do
374   e <- allocaArray (fromIntegral n) $ \lptstr -> do
375          r <- failIfZero loc $ f lptstr n
376          if (r > n) then return (Left r) else do
377            str <- peekTStringLen (lptstr, fromIntegral r)
378            return (Right str)
379   case e of
380        Left n'   -> try loc f n'
381        Right str -> return str
382
383----------------------------------------------------------------
384-- Primitives
385----------------------------------------------------------------
386
387{-# CFILES cbits/HsWin32.c #-}
388foreign import ccall "HsWin32.h &DeleteObjectFinaliser"
389  deleteObjectFinaliser :: FunPtr (Ptr a -> IO ())
390
391foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"
392  localFree :: Ptr a -> IO (Ptr a)
393
394foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
395  getLastError :: IO ErrCode
396
397foreign import WINDOWS_CCONV unsafe "windows.h SetLastError"
398  setLastError :: ErrCode -> IO ()
399
400{-# CFILES cbits/errors.c #-}
401
402foreign import ccall unsafe "errors.h"
403  getErrorMessage :: DWORD -> IO LPWSTR
404
405{-# CFILES cbits/HsWin32.c #-}
406
407foreign import ccall unsafe "HsWin32.h"
408  lOWORD :: DWORD -> WORD
409
410foreign import ccall unsafe "HsWin32.h"
411  hIWORD :: DWORD -> WORD
412
413foreign import ccall unsafe "HsWin32.h"
414  castUINTPtrToPtr :: UINT_PTR -> Ptr a
415
416foreign import ccall unsafe "HsWin32.h"
417  castPtrToUINTPtr :: Ptr s -> UINT_PTR
418
419type LCID = DWORD
420
421type LANGID = WORD
422type SortID = WORD
423
424foreign import ccall unsafe "HsWin32.h prim_MAKELCID"
425  mAKELCID :: LANGID -> SortID -> LCID
426
427foreign import ccall unsafe "HsWin32.h prim_LANGIDFROMLCID"
428  lANGIDFROMLCID :: LCID -> LANGID
429
430foreign import ccall unsafe "HsWin32.h prim_SORTIDFROMLCID"
431  sORTIDFROMLCID :: LCID -> SortID
432
433type SubLANGID = WORD
434type PrimaryLANGID = WORD
435
436foreign import ccall unsafe "HsWin32.h prim_MAKELANGID"
437  mAKELANGID :: PrimaryLANGID -> SubLANGID -> LANGID
438
439foreign import ccall unsafe "HsWin32.h prim_PRIMARYLANGID"
440  pRIMARYLANGID :: LANGID -> PrimaryLANGID
441
442foreign import ccall unsafe "HsWin32.h prim_SUBLANGID"
443  sUBLANGID :: LANGID -> SubLANGID
444
445----------------------------------------------------------------
446-- End
447----------------------------------------------------------------
448