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