Use primop wrappers instead of tagToEnum#
[packages/base.git] / GHC / Windows.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE CPP #-}
3 {-# LANGUAGE ForeignFunctionInterface #-}
4 {-# LANGUAGE NoImplicitPrelude #-}
5 -----------------------------------------------------------------------------
6 -- |
7 -- Module : GHC.Windows
8 -- Copyright : (c) The University of Glasgow, 2009
9 -- License : see libraries/base/LICENSE
10 --
11 -- Maintainer : libraries@haskell.org
12 -- Stability : internal
13 -- Portability : non-portable
14 --
15 -- Windows functionality used by several modules.
16 --
17 -- ToDo: this just duplicates part of System.Win32.Types, which isn't
18 -- available yet. We should move some Win32 functionality down here,
19 -- maybe as part of the grand reorganisation of the base package...
20 --
21 -----------------------------------------------------------------------------
22
23 module GHC.Windows (
24 -- * Types
25 BOOL,
26 LPBOOL,
27 BYTE,
28 DWORD,
29 UINT,
30 ErrCode,
31 HANDLE,
32 LPWSTR,
33 LPTSTR,
34
35 -- * Constants
36 iNFINITE,
37 iNVALID_HANDLE_VALUE,
38
39 -- * System errors
40 throwGetLastError,
41 failWith,
42 getLastError,
43 getErrorMessage,
44 errCodeToIOError,
45
46 -- ** Guards for system calls that might fail
47 failIf,
48 failIf_,
49 failIfNull,
50 failIfZero,
51 failIfFalse_,
52 failUnlessSuccess,
53 failUnlessSuccessOr,
54
55 -- ** Mapping system errors to errno
56 -- $errno
57 c_maperrno,
58 c_maperrno_func,
59 ) where
60
61 import Data.Char
62 import Data.List
63 import Data.Maybe
64 import Data.Word
65 import Foreign.C.Error
66 import Foreign.C.String
67 import Foreign.C.Types
68 import Foreign.Ptr
69 import GHC.Base
70 import GHC.IO
71 import GHC.Num
72 import System.IO.Error
73
74 import qualified Numeric
75
76 #if defined(i386_HOST_ARCH)
77 # define WINDOWS_CCONV stdcall
78 #elif defined(x86_64_HOST_ARCH)
79 # define WINDOWS_CCONV ccall
80 #else
81 # error Unknown mingw32 arch
82 #endif
83
84 type BOOL = Bool
85 type LPBOOL = Ptr BOOL
86 type BYTE = Word8
87 type DWORD = Word32
88 type UINT = Word32
89 type ErrCode = DWORD
90 type HANDLE = Ptr ()
91 type LPWSTR = Ptr CWchar
92
93 -- | Be careful with this. LPTSTR can mean either WCHAR* or CHAR*, depending
94 -- on whether the UNICODE macro is defined in the corresponding C code.
95 -- Consider using LPWSTR instead.
96 type LPTSTR = LPWSTR
97
98 iNFINITE :: DWORD
99 iNFINITE = 0xFFFFFFFF -- urgh
100
101 iNVALID_HANDLE_VALUE :: HANDLE
102 iNVALID_HANDLE_VALUE = wordPtrToPtr (-1)
103
104 -- | Get the last system error, and throw it as an 'IOError' exception.
105 throwGetLastError :: String -> IO a
106 throwGetLastError where_from =
107 getLastError >>= failWith where_from
108
109 -- | Convert a Windows error code to an exception, then throw it.
110 failWith :: String -> ErrCode -> IO a
111 failWith fn_name err_code =
112 errCodeToIOError fn_name err_code >>= throwIO
113
114 -- | Convert a Windows error code to an exception.
115 errCodeToIOError :: String -> ErrCode -> IO IOError
116 errCodeToIOError fn_name err_code = do
117 msg <- getErrorMessage err_code
118
119 -- turn GetLastError() into errno, which errnoToIOError knows
120 -- how to convert to an IOException we can throw.
121 -- XXX we should really do this directly.
122 let errno = c_maperrno_func err_code
123
124 let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n
125 ioerror = errnoToIOError fn_name errno Nothing Nothing
126 `ioeSetErrorString` msg'
127 return ioerror
128
129 -- | Get a string describing a Windows error code. This uses the
130 -- @FormatMessage@ system call.
131 getErrorMessage :: ErrCode -> IO String
132 getErrorMessage err_code =
133 mask_ $ do
134 c_msg <- c_getErrorMessage err_code
135 if c_msg == nullPtr
136 then return $ "Error 0x" ++ Numeric.showHex err_code ""
137 else do msg <- peekCWString c_msg
138 -- We ignore failure of freeing c_msg, given we're already failing
139 _ <- localFree c_msg
140 return msg
141
142 failIf :: (a -> Bool) -> String -> IO a -> IO a
143 failIf p wh act = do
144 v <- act
145 if p v then throwGetLastError wh else return v
146
147 failIf_ :: (a -> Bool) -> String -> IO a -> IO ()
148 failIf_ p wh act = do
149 v <- act
150 if p v then throwGetLastError wh else return ()
151
152 failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
153 failIfNull = failIf (== nullPtr)
154
155 failIfZero :: (Eq a, Num a) => String -> IO a -> IO a
156 failIfZero = failIf (== 0)
157
158 failIfFalse_ :: String -> IO Bool -> IO ()
159 failIfFalse_ = failIf_ not
160
161 failUnlessSuccess :: String -> IO ErrCode -> IO ()
162 failUnlessSuccess fn_name act = do
163 r <- act
164 if r == 0 then return () else failWith fn_name r
165
166 failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
167 failUnlessSuccessOr val fn_name act = do
168 r <- act
169 if r == 0 then return False
170 else if r == val then return True
171 else failWith fn_name r
172
173 -- $errno
174 --
175 -- On Windows, @errno@ is defined by msvcrt.dll for compatibility with other
176 -- systems, and is distinct from the system error as returned
177 -- by @GetLastError@.
178
179 -- | Map the last system error to an errno value, and assign it to @errno@.
180 foreign import ccall unsafe "maperrno" -- in Win32Utils.c
181 c_maperrno :: IO ()
182
183 -- | Pure function variant of 'c_maperrno' that does not call @GetLastError@
184 -- or modify @errno@.
185 foreign import ccall unsafe "maperrno_func" -- in Win32Utils.c
186 c_maperrno_func :: ErrCode -> Errno
187
188 foreign import ccall unsafe "base_getErrorMessage" -- in Win32Utils.c
189 c_getErrorMessage :: DWORD -> IO LPWSTR
190
191 foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"
192 localFree :: Ptr a -> IO (Ptr a)
193
194 -- | Get the last system error produced in the current thread.
195 foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
196 getLastError :: IO ErrCode