diff --git a/Graphics/Win32.hs b/Graphics/Win32.hs --- a/Graphics/Win32.hs +++ b/Graphics/Win32.hs @@ -31,7 +31,12 @@ module Graphics.Win32.Message, module Graphics.Win32.Misc, module Graphics.Win32.Resource, - module Graphics.Win32.Window + module Graphics.Win32.Window, + module Graphics.Win32.LayeredWindow, + module Graphics.Win32.Window.AnimateWindow, + module Graphics.Win32.Window.ForegroundWindow, + module Graphics.Win32.Window.IMM, + module Graphics.Win32.Window.PostMessage ) where import System.Win32.Types @@ -45,3 +50,8 @@ import Graphics.Win32.Misc import Graphics.Win32.Resource import Graphics.Win32.Window +import Graphics.Win32.LayeredWindow +import Graphics.Win32.Window.AnimateWindow +import Graphics.Win32.Window.ForegroundWindow +import Graphics.Win32.Window.IMM +import Graphics.Win32.Window.PostMessage diff --git a/Graphics/Win32/GDI/AlphaBlend.hsc b/Graphics/Win32/GDI/AlphaBlend.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/AlphaBlend.hsc @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.GDI.AlphaBlend + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provides alpha blending functionality. +-} +module Graphics.Win32.GDI.AlphaBlend where +import Foreign.Storable ( Storable(..) ) +import Foreign.Ptr ( Ptr ) +import Graphics.Win32.GDI.Types ( HDC ) +import System.Win32.Types ( BOOL, BYTE, UINT ) + +#include +#include "alignment.h" +##include "windows_cconv.h" + +foreign import ccall unsafe "alphablend.h" + c_AlphaBlend :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> PBLENDFUNCTION -> IO BOOL +{- +We use C wrapper function to call this API. +Because foreign stacall/ccall/capi doesn't work with non-pointer user defined type. + +We think that capi should support that when user defined type has Storable class instance +and using CTYPE pragma in the scope. + +{-# LANGUAGE CApiFFI #-} + +data {-# CTYPE "windows.h" "BLENDFUNCTION" #-} BLENDFUNCTION = + +foreign import capi unsafe "windows.h AlphaBlend" + c_AlphaBlend :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> BLENDFUNCTION -> IO BOOL +-} + +foreign import WINDOWS_CCONV unsafe "windows.h TransparentBlt" + c_TransparentBlt :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> UINT -> IO BOOL + +aC_SRC_OVER :: BYTE +aC_SRC_OVER = #const AC_SRC_OVER + +aC_SRC_ALPHA :: BYTE +aC_SRC_ALPHA = #const AC_SRC_ALPHA + +type PBLENDFUNCTION = Ptr BLENDFUNCTION +type LPBLENDFUNCTION = Ptr BLENDFUNCTION + +data BLENDFUNCTION = BLENDFUNCTION + { blendOp :: BYTE + , blendFlags :: BYTE + , sourceConstantAlpha :: BYTE + , alphaFormat :: BYTE + } deriving (Show) + +instance Storable BLENDFUNCTION where + sizeOf = const #size BLENDFUNCTION + alignment _ = #alignment BLENDFUNCTION + poke buf func = do + (#poke BLENDFUNCTION, BlendOp) buf (blendOp func) + (#poke BLENDFUNCTION, BlendFlags) buf (blendFlags func) + (#poke BLENDFUNCTION, SourceConstantAlpha) buf (sourceConstantAlpha func) + (#poke BLENDFUNCTION, AlphaFormat) buf (alphaFormat func) + + peek buf = do + blendOp' <- (#peek BLENDFUNCTION, BlendOp) buf + blendFlags' <- (#peek BLENDFUNCTION, BlendFlags) buf + sourceConstantAlpha' <- + (#peek BLENDFUNCTION, SourceConstantAlpha) buf + alphaFormat' <- (#peek BLENDFUNCTION, AlphaFormat) buf + return $ BLENDFUNCTION blendOp' blendFlags' sourceConstantAlpha' alphaFormat' diff --git a/Graphics/Win32/GDI/Clip.hsc b/Graphics/Win32/GDI/Clip.hsc --- a/Graphics/Win32/GDI/Clip.hsc +++ b/Graphics/Win32/GDI/Clip.hsc @@ -22,11 +22,17 @@ import Control.Monad import Graphics.Win32.GDI.Types import System.Win32.Types +import Graphics.Win32.Message ( WindowMessage ) import Foreign ##include "windows_cconv.h" +#undef WINVER +#define WINVER 0x0600 +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0600 + #include type ClipboardFormat = UINT @@ -55,7 +61,13 @@ , cF_TEXT = CF_TEXT , cF_WAVE = CF_WAVE , cF_TIFF = CF_TIFF + , cF_DIBV5 = CF_DIBV5 + , cF_GDIOBJLAST = CF_GDIOBJLAST + , cF_UNICODETEXT = CF_UNICODETEXT } + +wM_CLIPBOARDUPDATE :: WindowMessage +wM_CLIPBOARDUPDATE = 0x031D -- #const WM_CLIPBOARDUPDATE -- Can't use constant due to GHC 7.8.x support. -- % , CF_UNICODETEXT -- WinNT only diff --git a/Graphics/Win32/Key.hsc b/Graphics/Win32/Key.hsc --- a/Graphics/Win32/Key.hsc +++ b/Graphics/Win32/Key.hsc @@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Graphics.Win32.Key --- Copyright : (c) Alastair Reid, 1997-2003 +-- Copyright : (c) Alastair Reid, 1997-2003, 2013 shelarcy -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : Esa Ilari Vuokko @@ -21,88 +21,170 @@ import Control.Monad (liftM) import Graphics.Win32.GDI.Types (HWND) -import System.Win32.Types (DWORD, UINT, WORD, ptrToMaybe) +import System.Win32.Types ( DWORD, UINT, WORD, ptrToMaybe, BOOL, SHORT, + failIfFalse_, failIfZero ) +import Control.Exception ( bracket ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.C.Types ( CWchar(..) ) +import Foreign.Marshal.Array ( allocaArray, peekArray ) +import System.Win32.String ( LPTSTR, LPCTSTR + , withTString, withTStringBuffer, peekTString ) +import System.Win32.Thread ( TID, getCurrentThreadId ) ##include "windows_cconv.h" #include +#include "winuser_compat.h" type VKey = DWORD #{enum VKey, - , vK_LBUTTON = VK_LBUTTON - , vK_RBUTTON = VK_RBUTTON - , vK_CANCEL = VK_CANCEL - , vK_MBUTTON = VK_MBUTTON - , vK_BACK = VK_BACK - , vK_TAB = VK_TAB - , vK_CLEAR = VK_CLEAR - , vK_RETURN = VK_RETURN - , vK_SHIFT = VK_SHIFT - , vK_CONTROL = VK_CONTROL - , vK_MENU = VK_MENU - , vK_PAUSE = VK_PAUSE - , vK_CAPITAL = VK_CAPITAL - , vK_ESCAPE = VK_ESCAPE - , vK_SPACE = VK_SPACE - , vK_PRIOR = VK_PRIOR - , vK_NEXT = VK_NEXT - , vK_END = VK_END - , vK_HOME = VK_HOME - , vK_LEFT = VK_LEFT - , vK_UP = VK_UP - , vK_RIGHT = VK_RIGHT - , vK_DOWN = VK_DOWN - , vK_SELECT = VK_SELECT - , vK_EXECUTE = VK_EXECUTE - , vK_SNAPSHOT = VK_SNAPSHOT - , vK_INSERT = VK_INSERT - , vK_DELETE = VK_DELETE - , vK_HELP = VK_HELP - , vK_NUMPAD0 = VK_NUMPAD0 - , vK_NUMPAD1 = VK_NUMPAD1 - , vK_NUMPAD2 = VK_NUMPAD2 - , vK_NUMPAD3 = VK_NUMPAD3 - , vK_NUMPAD4 = VK_NUMPAD4 - , vK_NUMPAD5 = VK_NUMPAD5 - , vK_NUMPAD6 = VK_NUMPAD6 - , vK_NUMPAD7 = VK_NUMPAD7 - , vK_NUMPAD8 = VK_NUMPAD8 - , vK_NUMPAD9 = VK_NUMPAD9 - , vK_MULTIPLY = VK_MULTIPLY - , vK_ADD = VK_ADD - , vK_SEPARATOR = VK_SEPARATOR - , vK_SUBTRACT = VK_SUBTRACT - , vK_DECIMAL = VK_DECIMAL - , vK_DIVIDE = VK_DIVIDE - , vK_F1 = VK_F1 - , vK_F2 = VK_F2 - , vK_F3 = VK_F3 - , vK_F4 = VK_F4 - , vK_F5 = VK_F5 - , vK_F6 = VK_F6 - , vK_F7 = VK_F7 - , vK_F8 = VK_F8 - , vK_F9 = VK_F9 - , vK_F10 = VK_F10 - , vK_F11 = VK_F11 - , vK_F12 = VK_F12 - , vK_F13 = VK_F13 - , vK_F14 = VK_F14 - , vK_F15 = VK_F15 - , vK_F16 = VK_F16 - , vK_F17 = VK_F17 - , vK_F18 = VK_F18 - , vK_F19 = VK_F19 - , vK_F20 = VK_F20 - , vK_F21 = VK_F21 - , vK_F22 = VK_F22 - , vK_F23 = VK_F23 - , vK_F24 = VK_F24 - , vK_NUMLOCK = VK_NUMLOCK - , vK_SCROLL = VK_SCROLL + , vK_LBUTTON = VK_LBUTTON + , vK_RBUTTON = VK_RBUTTON + , vK_CANCEL = VK_CANCEL + , vK_MBUTTON = VK_MBUTTON + , vK_BACK = VK_BACK + , vK_TAB = VK_TAB + , vK_CLEAR = VK_CLEAR + , vK_RETURN = VK_RETURN + , vK_SHIFT = VK_SHIFT + , vK_CONTROL = VK_CONTROL + , vK_MENU = VK_MENU + , vK_PAUSE = VK_PAUSE + , vK_CAPITAL = VK_CAPITAL + , vK_ESCAPE = VK_ESCAPE + , vK_SPACE = VK_SPACE + , vK_PRIOR = VK_PRIOR + , vK_NEXT = VK_NEXT + , vK_END = VK_END + , vK_HOME = VK_HOME + , vK_LEFT = VK_LEFT + , vK_UP = VK_UP + , vK_RIGHT = VK_RIGHT + , vK_DOWN = VK_DOWN + , vK_SELECT = VK_SELECT + , vK_EXECUTE = VK_EXECUTE + , vK_SNAPSHOT = VK_SNAPSHOT + , vK_INSERT = VK_INSERT + , vK_DELETE = VK_DELETE + , vK_HELP = VK_HELP + , vK_NUMPAD0 = VK_NUMPAD0 + , vK_NUMPAD1 = VK_NUMPAD1 + , vK_NUMPAD2 = VK_NUMPAD2 + , vK_NUMPAD3 = VK_NUMPAD3 + , vK_NUMPAD4 = VK_NUMPAD4 + , vK_NUMPAD5 = VK_NUMPAD5 + , vK_NUMPAD6 = VK_NUMPAD6 + , vK_NUMPAD7 = VK_NUMPAD7 + , vK_NUMPAD8 = VK_NUMPAD8 + , vK_NUMPAD9 = VK_NUMPAD9 + , vK_MULTIPLY = VK_MULTIPLY + , vK_ADD = VK_ADD + , vK_SEPARATOR = VK_SEPARATOR + , vK_SUBTRACT = VK_SUBTRACT + , vK_DECIMAL = VK_DECIMAL + , vK_DIVIDE = VK_DIVIDE + , vK_F1 = VK_F1 + , vK_F2 = VK_F2 + , vK_F3 = VK_F3 + , vK_F4 = VK_F4 + , vK_F5 = VK_F5 + , vK_F6 = VK_F6 + , vK_F7 = VK_F7 + , vK_F8 = VK_F8 + , vK_F9 = VK_F9 + , vK_F10 = VK_F10 + , vK_F11 = VK_F11 + , vK_F12 = VK_F12 + , vK_F13 = VK_F13 + , vK_F14 = VK_F14 + , vK_F15 = VK_F15 + , vK_F16 = VK_F16 + , vK_F17 = VK_F17 + , vK_F18 = VK_F18 + , vK_F19 = VK_F19 + , vK_F20 = VK_F20 + , vK_F21 = VK_F21 + , vK_F22 = VK_F22 + , vK_F23 = VK_F23 + , vK_F24 = VK_F24 + , vK_NUMLOCK = VK_NUMLOCK + , vK_SCROLL = VK_SCROLL + , vK_XBUTTON1 = VK_XBUTTON1 + , vK_XBUTTON2 = VK_XBUTTON2 + , vK_KANA = VK_KANA + , vK_HANGUL = VK_HANGUL + , vK_JUNJA = VK_JUNJA + , vK_FINAL = VK_FINAL + , vK_HANJA = VK_HANJA + , vK_KANJI = VK_KANJI + , vK_CONVERT = VK_CONVERT + , vK_NONCONVERT = VK_NONCONVERT + , vK_ACCEPT = VK_ACCEPT + , vK_MODECHANGE = VK_MODECHANGE + , vK_PRINT = VK_PRINT + , vK_APPS = VK_APPS + , vK_SLEEP = VK_SLEEP + , vK_LWIN = VK_LWIN + , vK_RWIN = VK_RWIN + , vK_LSHIFT = VK_LSHIFT + , vK_RSHIFT = VK_RSHIFT + , vK_LCONTROL = VK_LCONTROL + , vK_RCONTROL = VK_RCONTROL + , vK_LMENU = VK_LMENU + , vK_RMENU = VK_RMENU + , vK_BROWSER_BACK = VK_BROWSER_BACK + , vK_BROWSER_FORWARD = VK_BROWSER_FORWARD + , vK_BROWSER_REFRESH = VK_BROWSER_REFRESH + , vK_BROWSER_STOP = VK_BROWSER_STOP + , vK_BROWSER_SEARCH = VK_BROWSER_SEARCH + , vK_BROWSER_FAVORITES = VK_BROWSER_FAVORITES + , vK_BROWSER_HOME = VK_BROWSER_HOME + , vK_VOLUME_MUTE = VK_VOLUME_MUTE + , vK_VOLUME_DOWN = VK_VOLUME_DOWN + , vK_VOLUME_UP = VK_VOLUME_UP + , vK_MEDIA_NEXT_TRACK = VK_MEDIA_NEXT_TRACK + , vK_MEDIA_PREV_TRACK = VK_MEDIA_PREV_TRACK + , vK_MEDIA_STOP = VK_MEDIA_STOP + , vK_MEDIA_PLAY_PAUSE = VK_MEDIA_PLAY_PAUSE + , vK_LAUNCH_MAIL = VK_LAUNCH_MAIL + , vK_LAUNCH_MEDIA_SELECT = VK_LAUNCH_MEDIA_SELECT + , vK_LAUNCH_APP1 = VK_LAUNCH_APP1 + , vK_LAUNCH_APP2 = VK_LAUNCH_APP2 + , vK_OEM_1 = VK_OEM_1 + , vK_OEM_PLUS = VK_OEM_PLUS + , vK_OEM_COMMA = VK_OEM_COMMA + , vK_OEM_MINUS = VK_OEM_MINUS + , vK_OEM_PERIOD = VK_OEM_PERIOD + , vK_OEM_2 = VK_OEM_2 + , vK_OEM_3 = VK_OEM_3 + , vK_OEM_4 = VK_OEM_4 + , vK_OEM_5 = VK_OEM_5 + , vK_OEM_6 = VK_OEM_6 + , vK_OEM_7 = VK_OEM_7 + , vK_OEM_8 = VK_OEM_8 + , vK_OEM_102 = VK_OEM_102 + , vK_PROCESSKEY = VK_PROCESSKEY + , vK_PACKET = VK_PACKET + , vK_ATTN = VK_ATTN + , vK_CRSEL = VK_CRSEL + , vK_EXSEL = VK_EXSEL + , vK_EREOF = VK_EREOF + , vK_PLAY = VK_PLAY + , vK_ZOOM = VK_ZOOM + , vK_NONAME = VK_NONAME + , vK_PA1 = VK_PA1 + , vK_OEM_CLEAR = VK_OEM_CLEAR } +foreign import WINDOWS_CCONV unsafe "windows.h VkKeyScanExW" + c_VkKeyScanEx :: CWchar -> HKL -> IO SHORT +foreign import WINDOWS_CCONV unsafe "windows.h MapVirtualKeyW" + c_MapVirtualKey :: VKey -> UINT -> IO UINT + +foreign import WINDOWS_CCONV unsafe "windows.h MapVirtualKeyExW" + c_MapVirtualKeyEx :: VKey -> UINT -> HKL -> IO UINT + foreign import WINDOWS_CCONV unsafe "windows.h EnableWindow" enableWindow :: HWND -> Bool -> IO Bool @@ -124,3 +206,69 @@ foreign import WINDOWS_CCONV unsafe "windows.h IsWindowEnabled" isWindowEnabled :: HWND -> IO Bool + +getCurrentKeyboardLayout :: IO HKL +getCurrentKeyboardLayout = do + tid <- getCurrentThreadId + c_GetKeyboardLayout tid + +getKeyboardLayoutList :: IO [HKL] +getKeyboardLayoutList = do + len' <- failIfZero "GetKeyboardLayoutList" $ c_GetKeyboardLayoutList 0 nullPtr + let len = fromIntegral len' + allocaArray len $ \buf -> do + _ <- failIfZero "GetKeyboardLayoutList" $ c_GetKeyboardLayoutList len buf + peekArray len buf + +getKeyboardLayoutName :: IO String +getKeyboardLayoutName + = withTStringBuffer 256 $ \buf -> do + failIfFalse_ "GetKeyboardLayoutName" $ c_GetKeyboardLayoutName buf + peekTString buf + +withLoadKeyboardLayout :: KeyLayoutFlags -> (HKL -> IO a) -> IO a +withLoadKeyboardLayout flag io + = withTStringBuffer 256 $ \buf -> do + failIfFalse_ "GetKeyboardLayoutName" $ c_GetKeyboardLayoutName buf + bracket (c_LoadKeyboardLayout buf flag) + unloadKeyboardLayout + io + +withLoadKeyboardLayoutWithName :: String -> KeyLayoutFlags -> (HKL -> IO a) -> IO a +withLoadKeyboardLayoutWithName str flag io + = withTString str $ \c_str -> + bracket (c_LoadKeyboardLayout c_str flag) + unloadKeyboardLayout + io + +unloadKeyboardLayout :: HKL -> IO () +unloadKeyboardLayout + = failIfFalse_ "UnloadKeyboardLayout" . c_UnloadKeyboardLayout + +foreign import WINDOWS_CCONV unsafe "windows.h GetKeyboardLayout" + c_GetKeyboardLayout :: TID -> IO HKL + +foreign import WINDOWS_CCONV unsafe "windows.h GetKeyboardLayoutList" + c_GetKeyboardLayoutList :: Int -> (Ptr HKL) -> IO UINT + +foreign import WINDOWS_CCONV unsafe "windows.h GetKeyboardLayoutNameW" + c_GetKeyboardLayoutName :: LPTSTR -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h LoadKeyboardLayoutW" + c_LoadKeyboardLayout :: LPCTSTR -> KeyLayoutFlags -> IO HKL + +foreign import WINDOWS_CCONV unsafe "windows.h UnloadKeyboardLayout" + c_UnloadKeyboardLayout :: HKL -> IO BOOL + +type HKL = Ptr () + +type KeyLayoutFlags = UINT + +#{enum KeyLayoutFlags, + , kLF_ACTIVATE = KLF_ACTIVATE + , kLF_NOTELLSHELL = KLF_NOTELLSHELL + , kLF_REORDER = KLF_REORDER + , kLF_REPLACELANG = KLF_REPLACELANG + , kLF_SUBSTITUTE_OK = KLF_SUBSTITUTE_OK + , kLF_SETFORPROCESS = KLF_SETFORPROCESS + } diff --git a/Graphics/Win32/LayeredWindow.hsc b/Graphics/Win32/LayeredWindow.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/LayeredWindow.hsc @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.LayeredWindow + Copyright : 2012-2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provides LayeredWindow functionality. +-} +module Graphics.Win32.LayeredWindow where +import Control.Monad ( void ) +import Data.Bits ( (.|.) ) +import Foreign.Ptr ( Ptr ) +import Foreign.C.Types ( CIntPtr(..) ) +import Foreign.Marshal.Utils ( with ) +import Graphics.Win32.GDI.AlphaBlend ( BLENDFUNCTION ) +import Graphics.Win32.GDI.Types ( COLORREF, HDC, SIZE, SIZE, POINT ) +import Graphics.Win32.Window ( WindowStyleEx, c_SetWindowLongPtr, ) +import System.Win32.Types ( DWORD, HANDLE, BYTE, BOOL, + LONG_PTR, INT ) + +#include +##include "windows_cconv.h" +#include "winuser_compat.h" + +toLayeredWindow :: HANDLE -> IO () +toLayeredWindow w = do + flg <- c_GetWindowLongPtr w gWL_EXSTYLE + void $ with (fromIntegral $ flg .|. (fromIntegral wS_EX_LAYERED)) $ c_SetWindowLongPtr w gWL_EXSTYLE + +-- test w = c_SetLayeredWindowAttributes w 0 128 lWA_ALPHA + +gWL_EXSTYLE :: INT +gWL_EXSTYLE = #const GWL_EXSTYLE + +wS_EX_LAYERED :: WindowStyleEx +wS_EX_LAYERED = #const WS_EX_LAYERED + +lWA_COLORKEY, lWA_ALPHA :: DWORD +lWA_COLORKEY = #const LWA_COLORKEY +lWA_ALPHA = #const LWA_ALPHA + +foreign import WINDOWS_CCONV unsafe "windows.h SetLayeredWindowAttributes" + c_SetLayeredWindowAttributes :: HANDLE -> COLORREF -> BYTE -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetLayeredWindowAttributes" + c_GetLayeredWindowAttributes :: HANDLE -> COLORREF -> Ptr BYTE -> Ptr DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h UpdateLayeredWindow" + c_UpdateLayeredWindow :: HANDLE -> HDC -> Ptr POINT -> Ptr SIZE -> HDC -> Ptr POINT -> COLORREF -> Ptr BLENDFUNCTION -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h GetWindowLongPtrW" + c_GetWindowLongPtr :: HANDLE -> INT -> IO LONG_PTR + +#{enum DWORD, + , uLW_ALPHA = ULW_ALPHA + , uLW_COLORKEY = ULW_COLORKEY + , uLW_OPAQUE = ULW_OPAQUE + } diff --git a/Graphics/Win32/Misc.hsc b/Graphics/Win32/Misc.hsc --- a/Graphics/Win32/Misc.hsc +++ b/Graphics/Win32/Misc.hsc @@ -133,7 +133,7 @@ withTString text $ \ c_text -> withTString caption $ \ c_caption -> failIfZero "MessageBox" $ c_MessageBox wnd c_text c_caption style -foreign import WINDOWS_CCONV unsafe "windows.h MessageBoxW" +foreign import WINDOWS_CCONV safe "windows.h MessageBoxW" c_MessageBox :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus ---------------------------------------------------------------- diff --git a/Graphics/Win32/Window.hsc b/Graphics/Win32/Window.hsc --- a/Graphics/Win32/Window.hsc +++ b/Graphics/Win32/Window.hsc @@ -475,6 +475,11 @@ withTString cname $ \ c_cname -> withTString wname $ \ c_wname -> liftM ptrToMaybe $ c_FindWindow c_cname c_wname + +findWindowByName :: String -> IO (Maybe HWND) +findWindowByName wname = withTString wname $ \ c_wname -> + liftM ptrToMaybe $ c_FindWindow nullPtr c_wname + foreign import WINDOWS_CCONV unsafe "windows.h FindWindowW" c_FindWindow :: LPCTSTR -> LPCTSTR -> IO HWND diff --git a/Graphics/Win32/Window/AnimateWindow.hsc b/Graphics/Win32/Window/AnimateWindow.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/AnimateWindow.hsc @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.AnimateWindow + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provide AnimatedWindow function and flags. +-} +module Graphics.Win32.Window.AnimateWindow where +import Graphics.Win32.GDI.Types ( HWND ) +import System.Win32.Types ( DWORD, BOOL, failIfFalse_ ) + +#include +##include "windows_cconv.h" +#include "winuser_compat.h" + +type AnimateWindowType = DWORD + +#{enum AnimateWindowType, + , aW_SLIDE = AW_SLIDE + , aW_ACTIVATE = AW_ACTIVATE + , aW_BLEND = AW_BLEND + , aW_HIDE = AW_HIDE + , aW_CENTER = AW_CENTER + , aW_HOR_POSITIVE = AW_HOR_POSITIVE + , aW_HOR_NEGATIVE = AW_HOR_NEGATIVE + , aW_VER_POSITIVE = AW_VER_POSITIVE + , aW_VER_NEGATIVE = AW_VER_NEGATIVE + } + +animateWindow :: HWND -> DWORD -> AnimateWindowType -> IO () +animateWindow hwnd dwTime dwFlags + = failIfFalse_ "AnimateWindow" $ c_AnimateWindow hwnd dwTime dwFlags + +foreign import WINDOWS_CCONV "windows.h AnimateWindow" + c_AnimateWindow :: HWND -> DWORD -> AnimateWindowType -> IO BOOL diff --git a/Graphics/Win32/Window/ForegroundWindow.hs b/Graphics/Win32/Window/ForegroundWindow.hs new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/ForegroundWindow.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.ForegroundWindow + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Get/Set Foreground Window. +-} + +module Graphics.Win32.Window.ForegroundWindow + ( getForegroundWindow + , setForegroundWindow + , c_SetForegroundWindow + , allowSetForegroundWindow + , c_AllowSetForegroundWindow + ) where + +import Control.Monad ( void ) +import Graphics.Win32.GDI.Types ( HWND ) +import Graphics.Win32.Window ( getForegroundWindow ) +import System.Win32.Process ( ProcessId ) + +#include "windows_cconv.h" + +---------------------------------------------------------------- +-- | Setting Window to Foreground. +-- See: , +-- . +---------------------------------------------------------------- +setForegroundWindow :: HWND -> IO Bool +setForegroundWindow = c_SetForegroundWindow + +foreign import WINDOWS_CCONV safe "windows.h SetForegroundWindow" + c_SetForegroundWindow :: HWND -> IO Bool + +---------------------------------------------------------------- +-- | Allow other process to set Window to Foreground +-- by using 'setForegroundWindow' function. +allowSetForegroundWindow :: ProcessId -> IO () +allowSetForegroundWindow = void . c_AllowSetForegroundWindow + +foreign import WINDOWS_CCONV safe "windows.h AllowSetForegroundWindow" + c_AllowSetForegroundWindow :: ProcessId -> IO Bool diff --git a/Graphics/Win32/Window/HotKey.hsc b/Graphics/Win32/Window/HotKey.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/HotKey.hsc @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.HotKey + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + An FFI binding to the hot key part of the Win32 API. +-} +module Graphics.Win32.Window.HotKey where + +import Data.Bits ( (.|.) ) +import Graphics.Win32.GDI.Types ( HWND, MbHWND ) +import Graphics.Win32.Key ( VKey ) +import Graphics.Win32.Message ( WindowMessage ) +import System.Win32.Types ( UINT, BOOL, maybePtr, failIfFalse_ ) +import System.Win32.Exception.Unsupported ( unsupportedVal, upgradeWindowsOS ) +import System.Win32.Info.Version ( is7OrLater ) + +#include +##include "windows_cconv.h" + +type FsModifiers = [FsModifier] +type FsModifier = UINT + +#{enum FsModifier, + , mOD_ALT = MOD_ALT + , mOD_CONTROL = MOD_CONTROL + , mOD_SHIFT = MOD_SHIFT + , mOD_WIN = MOD_WIN +} + +-- | This parameter requires to use Windows 7 or later. +mOD_NOREPEAT :: FsModifier +mOD_NOREPEAT + = unsupportedVal "MOD_NOREPEAT" + is7OrLater (upgradeWindowsOS "Windows 7") 0x4000 +{- + , mOD_NOREPEAT = MOD_NOREPEAT +-} + +wM_HOTKEY :: WindowMessage +wM_HOTKEY = #const WM_HOTKEY + +joinModifiers :: FsModifiers -> FsModifier +joinModifiers = foldr (.|.) 0 + +registerHotKey :: MbHWND -> Int -> FsModifier -> VKey -> IO () +registerHotKey mb_wnd kid md vkey = + failIfFalse_ (unwords ["RegisterHotKey", show mb_wnd, show kid, show md, show vkey]) + $ c_RegisterHotKey (maybePtr mb_wnd) kid md vkey + +foreign import WINDOWS_CCONV "windows.h RegisterHotKey" + c_RegisterHotKey :: HWND -> Int -> UINT -> VKey -> IO BOOL + +unregisterHotKey :: MbHWND -> Int -> IO () +unregisterHotKey mb_wnd kid = + failIfFalse_ (unwords ["UnregisterHotKey", show mb_wnd, show kid]) + $ c_UnregisterHotKey (maybePtr mb_wnd) kid + +foreign import WINDOWS_CCONV "windows.h UnregisterHotKey" + c_UnregisterHotKey :: HWND -> Int -> IO BOOL diff --git a/Graphics/Win32/Window/IMM.hsc b/Graphics/Win32/Window/IMM.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/IMM.hsc @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.IMM + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + An FFI binding to the IMM (Input Method Manager) part of the Win32 API. +-} +module Graphics.Win32.Window.IMM where +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Utils ( fromBool ) +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( peek ) +import Graphics.Win32.GDI.Types ( HWND ) +import Graphics.Win32.Key ( VKey ) +import System.Win32.Types ( UINT, DWORD, LPDWORD, BOOL, failIfFalse_ ) + +#include +##include "windows_cconv.h" + +type HIMC = Ptr () + +foreign import WINDOWS_CCONV "windows.h ImmGetContext" + immGetContext :: HWND -> IO HIMC + +foreign import WINDOWS_CCONV "windows.h ImmGetOpenStatus" + immGetOpenStatus :: HIMC -> IO BOOL + +immSetOpenStatus :: HIMC -> BOOL -> IO () +immSetOpenStatus imc flg = + failIfFalse_ (unwords ["ImmSetOpenStatus", show imc, show flg]) + $ c_ImmSetOpenStatus imc (fromBool flg) + +foreign import WINDOWS_CCONV "windows.h ImmSetOpenStatus" + c_ImmSetOpenStatus :: HIMC -> UINT -> IO BOOL + + +data IMEMode = IMEMode DWORD DWORD + +immGetConversionStatus :: HIMC -> IO IMEMode +immGetConversionStatus imc = + alloca $ \lpConv -> + alloca $ \lpStnc -> do + failIfFalse_ (unwords ["ImmGetConversionStatus", show imc, show lpConv, show lpStnc]) $ + c_ImmGetConversionStatus imc lpConv lpStnc + conv <- peek lpConv + stnc <- peek lpStnc + return $ IMEMode conv stnc + +foreign import WINDOWS_CCONV "windows.h ImmGetConversionStatus" + c_ImmGetConversionStatus :: HIMC -> LPDWORD -> LPDWORD -> IO BOOL + +immSetConversionStatus :: HIMC -> IMEMode -> IO () +immSetConversionStatus imc (IMEMode conv stnc) = + failIfFalse_ (unwords ["ImmSetConversionStatus", show imc, show conv, show stnc]) + $ c_ImmSetConversionStatus imc conv stnc + +foreign import WINDOWS_CCONV "windows.h ImmSetConversionStatus" + c_ImmSetConversionStatus :: HIMC -> DWORD -> DWORD -> IO BOOL + +-- iMN_SETCONVERSIONSTATUS = #const IMN_SETCONVERSIONSTATUS + +#{enum DWORD, + , iME_CMODE_ALPHANUMERIC = IME_CMODE_ALPHANUMERIC + , iME_CMODE_CHARCODE = IME_CMODE_CHARCODE + , iME_CMODE_EUDC = IME_CMODE_EUDC + , iME_CMODE_FIXED = IME_CMODE_FIXED + , iME_CMODE_FULLSHAPE = IME_CMODE_FULLSHAPE + , iME_CMODE_HANJACONVERT = IME_CMODE_HANJACONVERT + , iME_CMODE_KATAKANA = IME_CMODE_KATAKANA + , iME_CMODE_NATIVE = IME_CMODE_NATIVE + , iME_CMODE_NOCONVERSION = IME_CMODE_NOCONVERSION + , iME_CMODE_ROMAN = IME_CMODE_ROMAN + , iME_CMODE_SOFTKBD = IME_CMODE_SOFTKBD + , iME_CMODE_SYMBOL = IME_CMODE_SYMBOL + } + +#{enum DWORD, + , iME_SMODE_AUTOMATIC = IME_SMODE_AUTOMATIC + , iME_SMODE_NONE = IME_SMODE_NONE + , iME_SMODE_PHRASEPREDICT = IME_SMODE_PHRASEPREDICT + , iME_SMODE_PLAURALCLAUSE = IME_SMODE_PLAURALCLAUSE + , iME_SMODE_SINGLECONVERT = IME_SMODE_SINGLECONVERT + } +{- + , iME_SMODE_CONVERSATION = IME_SMODE_CONVERSATION +-} + +immReleaseContext :: HWND -> HIMC -> IO () +immReleaseContext wnd imc = + failIfFalse_ (unwords ["ImmSetOpenStatus", show wnd, show imc]) + $ c_ImmReleaseContext wnd imc + +foreign import WINDOWS_CCONV "windows.h ImmReleaseContext" + c_ImmReleaseContext :: HWND -> HIMC -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h ImmGetVirtualKey" + immGetVirtualKey :: HWND -> IO VKey + +immSimulateHotKey :: HWND -> DWORD -> IO () +immSimulateHotKey hwd hkey = + failIfFalse_ (unwords ["ImmSimulateHotKey", show hwd, show hkey]) + $ c_ImmSimulateHotKey hwd hkey + +foreign import WINDOWS_CCONV "windows.h ImmSimulateHotKey" + c_ImmSimulateHotKey :: HWND -> DWORD -> IO BOOL diff --git a/Graphics/Win32/Window/PostMessage.hsc b/Graphics/Win32/Window/PostMessage.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window/PostMessage.hsc @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Graphics.Win32.Window.PostMessage + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provide PostMessage function and friends. +-} +module Graphics.Win32.Window.PostMessage where + +import Foreign.C.Types ( CIntPtr(..) ) +import Graphics.Win32.GDI.Types ( HWND, MbHWND ) +import Graphics.Win32.Message ( WindowMessage ) +import System.Win32.Types ( DWORD, WPARAM, LPARAM, BOOL + , maybePtr, castUINTPtrToPtr, failIfFalse_ ) + +#include +##include "windows_cconv.h" + +postMessage :: MbHWND -> WindowMessage -> WPARAM -> LPARAM -> IO () +postMessage mb_wnd msg w l = + failIfFalse_ (unwords ["PostMessage", show mb_wnd, show msg, show w, show l]) $ + c_PostMessage (maybePtr mb_wnd) msg w l + +foreign import WINDOWS_CCONV "windows.h PostMessageW" + c_PostMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO BOOL + +foreign import WINDOWS_CCONV "windows.h PostQuitMessage" + postQuitMessage :: Int -> IO () + +postThreadMessage :: DWORD -> WindowMessage -> WPARAM -> LPARAM -> IO () +postThreadMessage tId msg w l = + failIfFalse_ (unwords ["PostThreadMessage", show tId, show msg, show w, show l]) $ + c_PostThreadMessage tId msg w l + +foreign import WINDOWS_CCONV "windows.h PostThreadMessageW" + c_PostThreadMessage :: DWORD -> WindowMessage -> WPARAM -> LPARAM -> IO BOOL + +#{enum HWND, castUINTPtrToPtr + , hWND_BROADCAST = (UINT_PTR)HWND_BROADCAST + } + +foreign import WINDOWS_CCONV "windows.h InSendMessage" + inSendMessage :: IO Bool diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,6 @@ Copyright (c) 1997-2003, Alastair Reid Copyright (c) 2006, Esa Ilari Vuokko +Copyright (c) 2012-2013, shelarcy All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Media/Win32.hs b/Media/Win32.hs new file mode 100644 --- /dev/null +++ b/Media/Win32.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Media.Win32 + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Multimedia API. TODO: provide more functions ... +-} + +module Media.Win32 + ( module Media.Win32 + ) where +import Control.Monad ( unless ) +import Prelude hiding ( ioError, userError ) +import System.IO.Error ( ioError, userError ) +import System.Win32.Encoding ( encodeMultiByte, getCurrentCodePage ) +import System.Win32.Types +import System.Win32.String ( withTStringBufferLen ) + +type MCIERROR = DWORD + +#include "windows_cconv.h" + +mciSendString :: String -> IO () +mciSendString cmd + = withTString cmd $ \sendCmd -> do + err <- c_mciSendString sendCmd nullPtr 0 nullPtr + unless (err == 0) + $ mciGetErrorString err + +foreign import WINDOWS_CCONV safe "windows.h mciSendStringW" + c_mciSendString :: LPCTSTR -> LPTSTR -> UINT -> HANDLE -> IO MCIERROR + +mciGetErrorString :: MCIERROR -> IO () +mciGetErrorString err + = withTStringBufferLen 256 $ \(cstr, len) -> do + failIfFalse_ (unwords ["mciGetErrorString", show err]) $ + c_mciGetErrorString err cstr $ fromIntegral len + msg <- peekTString cstr + cp <- getCurrentCodePage + ioError $ userError $ encodeMultiByte cp msg + +foreign import WINDOWS_CCONV unsafe "windows.h mciGetErrorStringW" + c_mciGetErrorString :: MCIERROR -> LPTSTR -> UINT -> IO BOOL diff --git a/System/Win32.hs b/System/Win32.hs --- a/System/Win32.hs +++ b/System/Win32.hs @@ -23,6 +23,7 @@ , module System.Win32.FileMapping , module System.Win32.Info , module System.Win32.Mem + , module System.Win32.MinTTY , module System.Win32.NLS , module System.Win32.Process , module System.Win32.Registry @@ -31,6 +32,11 @@ , module System.Win32.Security , module System.Win32.Types , module System.Win32.Shell + , module System.Win32.Automation + , module System.Win32.HardLink + , module System.Win32.SymbolicLink + , module System.Win32.Thread + , module System.Win32.Utils ) where import System.Win32.DLL @@ -38,6 +44,7 @@ import System.Win32.FileMapping import System.Win32.Info import System.Win32.Mem +import System.Win32.MinTTY import System.Win32.NLS hiding ( LCID, LANGID, SortID, SubLANGID , PrimaryLANGID, mAKELCID, lANGIDFROMLCID , sORTIDFROMLCID, mAKELANGID, pRIMARYLANGID @@ -49,6 +56,12 @@ import System.Win32.Types import System.Win32.Security import System.Win32.Shell + +import System.Win32.Automation +import System.Win32.HardLink +import System.Win32.SymbolicLink +import System.Win32.Thread +import System.Win32.Utils hiding ( try ) ---------------------------------------------------------------- -- End diff --git a/System/Win32/Automation.hs b/System/Win32/Automation.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Automation.hs @@ -0,0 +1,15 @@ +{- | + Module : System.Win32.Automation + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provide sendInput function and INPUT types. +-} +module System.Win32.Automation + ( module System.Win32.Automation.Input + ) where +import System.Win32.Automation.Input diff --git a/System/Win32/Automation/Input.hsc b/System/Win32/Automation/Input.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Automation/Input.hsc @@ -0,0 +1,122 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Automation.Input + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Provide sendInput function and INPUT types. +-} +module System.Win32.Automation.Input + ( module System.Win32.Automation.Input + , module System.Win32.Automation.Input.Key + , module System.Win32.Automation.Input.Mouse + ) where + +import Data.Bits ( (.|.) ) +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( Storable(..) ) +import Foreign.Marshal.Array ( withArrayLen ) +import Foreign.C.Types ( CIntPtr(..) ) +import Graphics.Win32.Key ( VKey, c_MapVirtualKey ) +import System.Win32.Automation.Input.Key +import System.Win32.Automation.Input.Mouse ( MOUSEINPUT ) +import System.Win32.Automation.Input.Mouse hiding ( MOUSEINPUT(..) ) +import qualified System.Win32.Automation.Input.Mouse +import System.Win32.Types ( UINT, LPARAM, failIfZero ) +import System.Win32.Word ( DWORD, WORD ) + +#include +#include "alignment.h" +##include "windows_cconv.h" +#include "winuser_compat.h" + +sendInput :: [INPUT] -> IO UINT +sendInput input + = withArrayLen input $ \len c_input -> + sendInputPtr len c_input + +{-# INLINE sendInputPtr #-} +-- | Raw pointer of array version of 'sendInput'. +-- Use this function to support non-list sequence. +sendInputPtr :: Int -> Ptr INPUT -> IO UINT +sendInputPtr len c_input + = failIfZero "SendInput" $ + c_SendInput (fromIntegral len) c_input $ sizeOf (undefined :: INPUT) + +foreign import WINDOWS_CCONV unsafe "windows.h SendInput" + c_SendInput :: UINT -> LPINPUT -> Int -> IO UINT + +makeKeyboardInput :: VKey -> Maybe DWORD -> IO INPUT +makeKeyboardInput vkey flag = do + let flag' = maybe kEYEVENTF_EXTENDEDKEY (kEYEVENTF_EXTENDEDKEY .|.) flag + scan <- c_MapVirtualKey vkey 0 + dwExtraInfo' <- getMessageExtraInfo + return $ Keyboard + $ KEYBDINPUT { + wVk = fromIntegral vkey + , wScan = fromIntegral scan + , dwFlags = flag' + , time = 0 + , dwExtraInfo = fromIntegral $ dwExtraInfo' + } + +type PINPUT = Ptr INPUT +type LPINPUT = Ptr INPUT + +data INPUT = Mouse MOUSEINPUT | Keyboard KEYBDINPUT | OtherHardware HARDWAREINPUT + deriving Show + +instance Storable INPUT where + sizeOf = const #{size INPUT} + alignment _ = #alignment INPUT + + poke buf (Mouse mouse) = do + (#poke INPUT, type) buf (#{const INPUT_MOUSE}:: DWORD) + (#poke INPUT, mi) buf mouse + poke buf (Keyboard key) = do + (#poke INPUT, type) buf (#{const INPUT_KEYBOARD} :: DWORD) + (#poke INPUT, ki) buf key + poke buf (OtherHardware hard) = do + (#poke INPUT, type) buf (#{const INPUT_HARDWARE} :: DWORD) + (#poke INPUT, hi) buf hard + + peek buf = do + type' <- (#peek INPUT, type) buf :: IO DWORD + case type' of + #{const INPUT_MOUSE} -> + Mouse `fmap` (#peek INPUT, mi) buf + #{const INPUT_KEYBOARD} -> + Keyboard `fmap` (#peek INPUT, ki) buf + _ -> OtherHardware `fmap` (#peek INPUT, hi) buf + + +type PHARDWAREINPUT = Ptr HARDWAREINPUT + +data HARDWAREINPUT = HARDWAREINPUT + { uMsg :: DWORD + , wParamL :: WORD + , wParamH :: WORD + } deriving Show + +instance Storable HARDWAREINPUT where + sizeOf = const #{size HARDWAREINPUT} + alignment _ = #alignment HARDWAREINPUT + poke buf input = do + (#poke HARDWAREINPUT, uMsg) buf (uMsg input) + (#poke HARDWAREINPUT, wParamL) buf (wParamL input) + (#poke HARDWAREINPUT, wParamH) buf (wParamH input) + peek buf = do + uMsg' <- (#peek HARDWAREINPUT, uMsg) buf + wParamL' <- (#peek HARDWAREINPUT, wParamL) buf + wParamH' <- (#peek HARDWAREINPUT, wParamH) buf + return $ HARDWAREINPUT uMsg' wParamL' wParamH' + +foreign import WINDOWS_CCONV unsafe "windows.h GetMessageExtraInfo" + getMessageExtraInfo :: IO LPARAM + +foreign import WINDOWS_CCONV unsafe "windows.h SetMessageExtraInfo" + setMessageExtraInfo :: LPARAM -> IO LPARAM diff --git a/System/Win32/Automation/Input/Key.hsc b/System/Win32/Automation/Input/Key.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Automation/Input/Key.hsc @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Automation.Input.Key + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Keyboard input events +-} +module System.Win32.Automation.Input.Key where +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( Storable(..) ) +import System.Win32.Types ( ULONG_PTR ) +import System.Win32.Word ( DWORD, WORD ) + +#include +#include "winuser_compat.h" +#include "alignment.h" + +type PKEYBDINPUT = Ptr KEYBDINPUT + +data KEYBDINPUT = KEYBDINPUT + { wVk :: WORD + , wScan :: WORD + , dwFlags :: DWORD + , time :: DWORD + , dwExtraInfo :: ULONG_PTR + } deriving Show + +instance Storable KEYBDINPUT where + sizeOf = const #{size KEYBDINPUT} + alignment _ = #alignment KEYBDINPUT + poke buf input = do + (#poke KEYBDINPUT, wVk) buf (wVk input) + (#poke KEYBDINPUT, wScan) buf (wScan input) + (#poke KEYBDINPUT, dwFlags) buf (dwFlags input) + (#poke KEYBDINPUT, time) buf (time input) + (#poke KEYBDINPUT, dwExtraInfo) buf (dwExtraInfo input) + peek buf = do + wVk' <- (#peek KEYBDINPUT, wVk) buf + wScan' <- (#peek KEYBDINPUT, wScan) buf + dwFlags' <- (#peek KEYBDINPUT, dwFlags) buf + time' <- (#peek KEYBDINPUT, time) buf + dwExtraInfo' <- (#peek KEYBDINPUT, dwExtraInfo) buf + return $ KEYBDINPUT wVk' wScan' dwFlags' time' dwExtraInfo' + +#{enum DWORD, + , kEYEVENTF_EXTENDEDKEY = KEYEVENTF_EXTENDEDKEY + , kEYEVENTF_KEYUP = KEYEVENTF_KEYUP + , kEYEVENTF_SCANCODE = KEYEVENTF_SCANCODE + , kEYEVENTF_UNICODE = KEYEVENTF_UNICODE + } diff --git a/System/Win32/Automation/Input/Mouse.hsc b/System/Win32/Automation/Input/Mouse.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Automation/Input/Mouse.hsc @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Automation.Input.Mouse + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Mouse input events +-} +module System.Win32.Automation.Input.Mouse where +import Foreign.Ptr ( Ptr ) +import Foreign.Storable ( Storable(..) ) +import System.Win32.Types ( LONG, ULONG_PTR ) +import System.Win32.Word ( DWORD ) + +#include +#include "winuser_compat.h" +#include "alignment.h" + +type PMOUSEINPUT = Ptr MOUSEINPUT + +data MOUSEINPUT = MOUSEINPUT + { dx :: LONG + , dy :: LONG + , mouseData :: DWORD + , dwFlags :: DWORD + , time :: DWORD + , dwExtraInfo :: ULONG_PTR + } deriving Show + +instance Storable MOUSEINPUT where + sizeOf = const #{size MOUSEINPUT} + alignment _ = #alignment MOUSEINPUT + poke buf input = do + (#poke MOUSEINPUT, dx) buf (dx input) + (#poke MOUSEINPUT, dx) buf (dx input) + (#poke MOUSEINPUT, mouseData) buf (mouseData input) + (#poke MOUSEINPUT, dwFlags) buf (dwFlags input) + (#poke MOUSEINPUT, time) buf (time input) + (#poke MOUSEINPUT, dwExtraInfo) buf (dwExtraInfo input) + peek buf = do + dx' <- (#peek MOUSEINPUT, dx) buf + dy' <- (#peek MOUSEINPUT, dy) buf + mouseData' <- (#peek MOUSEINPUT, mouseData) buf + dwFlags' <- (#peek MOUSEINPUT, dwFlags) buf + time' <- (#peek MOUSEINPUT, time) buf + dwExtraInfo' <- (#peek MOUSEINPUT, dwExtraInfo) buf + return $ MOUSEINPUT dx' dy' mouseData' dwFlags' time' dwExtraInfo' + +#{enum DWORD, + , xBUTTON1 = XBUTTON1 + , xBUTTON2 = XBUTTON2 + } + +#{enum DWORD, + , mOUSEEVENTF_ABSOLUTE = MOUSEEVENTF_ABSOLUTE + , mOUSEEVENTF_MOVE = MOUSEEVENTF_MOVE + , mOUSEEVENTF_LEFTDOWN = MOUSEEVENTF_LEFTDOWN + , mOUSEEVENTF_LEFTUP = MOUSEEVENTF_LEFTUP + , mOUSEEVENTF_RIGHTDOWN = MOUSEEVENTF_RIGHTDOWN + , mOUSEEVENTF_RIGHTUP = MOUSEEVENTF_RIGHTUP + , mOUSEEVENTF_MIDDLEDOWN = MOUSEEVENTF_MIDDLEDOWN + , mOUSEEVENTF_MIDDLEUP = MOUSEEVENTF_MIDDLEUP + , mOUSEEVENTF_WHEEL = MOUSEEVENTF_WHEEL + , mOUSEEVENTF_XDOWN = MOUSEEVENTF_XDOWN + , mOUSEEVENTF_XUP = MOUSEEVENTF_XUP + } + +{- + , mOUSEEVENTF_VIRTUALDESK = MOUSEEVENTF_VIRTUALDESK -- I don't know why we can't find this + , mOUSEEVENTF_HWHEEL = MOUSEEVENTF_HWHEEL + , mOUSEEVENTF_MOVE_NOCOALESCE = MOUSEEVENTF_MOVE_NOCOALESCE +-} diff --git a/System/Win32/Console/CtrlHandler.hs b/System/Win32/Console/CtrlHandler.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Console/CtrlHandler.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Console.CtrlHandler + Copyright : 2008-2013 Judah Jacobson, 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Set handlers of console Ctrl events. +-} +module System.Win32.Console.CtrlHandler + ( CtrlEvent, Handler, PHANDLER_ROUTINE + , withConsoleCtrlHandler + , setConsoleCtrlHandler, c_SetConsoleCtrlHandler + , mkHandler + , cTRL_C_EVENT, cTRL_BREAK_EVENT + ) where + +import Control.Exception ( bracket ) +import Control.Monad ( void ) +import Foreign.Ptr ( FunPtr ) +import System.Win32.Console ( CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT ) +import System.Win32.Types ( BOOL, failIfFalse_ ) + +#include "windows_cconv.h" + +type Handler = CtrlEvent -> IO BOOL +-- type HandlerRoutine = Handler +type PHANDLER_ROUTINE = FunPtr Handler + +withConsoleCtrlHandler :: Handler -> IO a -> IO a +withConsoleCtrlHandler handler io + = bracket (do hd <- mkHandler handler + -- don't fail if we can't set the Ctrl-C handler + -- for example, we might not be attached to a console? + void $ c_SetConsoleCtrlHandler hd True + return hd) + (\hd -> void $ c_SetConsoleCtrlHandler hd False) + $ const io + +-- | This function isn't suitable when we want to set the cTRL_C_EVENT handler. +-- If you want to set the cTRL_C_EVENT handler, use 'c_SetConsoleCtrlHandler' instead. +setConsoleCtrlHandler :: PHANDLER_ROUTINE -> BOOL -> IO () +setConsoleCtrlHandler handler flag + = failIfFalse_ "SetConsoleCtrlHandler" + $ c_SetConsoleCtrlHandler handler flag + +foreign import WINDOWS_CCONV "wrapper" mkHandler :: Handler -> IO PHANDLER_ROUTINE +foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler" + c_SetConsoleCtrlHandler :: PHANDLER_ROUTINE -> BOOL -> IO BOOL diff --git a/System/Win32/Console/HWND.hs b/System/Win32/Console/HWND.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Console/HWND.hs @@ -0,0 +1,34 @@ +{- | + Module : System.Win32.Console.HWND + Copyright : 2009 Balazs Komuves, 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Get the handle of the current console window. +-} +module System.Win32.Console.HWND where +import Control.Concurrent ( threadDelay ) +import Control.Exception ( bracket ) +import Foreign.Ptr ( nullPtr ) +import Graphics.Win32.Window ( c_FindWindow ) +import Graphics.Win32.GDI.Types ( HWND ) +import System.Win32.Console.Title ( getConsoleTitle, setConsoleTitle ) +import System.Win32.Process ( getCurrentProcessId ) +import System.Win32.String ( withTString ) +import System.Win32.Time ( getTickCount ) + +-- | Get the handle of the current console window by using window's title. +-- See: +getConsoleHWND :: IO HWND +getConsoleHWND + = bracket getConsoleTitle setConsoleTitle $ \_ -> do + time <- getTickCount + pid <- getCurrentProcessId + let unique = show time ++ show pid + setConsoleTitle unique + threadDelay (42*1000) + withTString unique $ \punique -> + c_FindWindow nullPtr punique diff --git a/System/Win32/Console/Title.hsc b/System/Win32/Console/Title.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Console/Title.hsc @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Console.Title + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Get/Set the title for the current console window. +-} +module System.Win32.Console.Title where + +import System.Win32.String ( LPTSTR, LPCTSTR + , withTStringBufferLen, withTString, peekTStringLen ) +import System.Win32.Types ( BOOL, failIfFalse_, failIfZero ) +import System.Win32.Word ( DWORD ) + +#include +##include "windows_cconv.h" + +getConsoleTitle :: IO String +getConsoleTitle = + withTStringBufferLen maxLength $ \(buf, len) -> do + len' <- failIfZero "GetConsoleTitle" + $ c_GetConsoleTitle buf (fromIntegral len) + peekTStringLen (buf, (fromIntegral len')) + where + maxLength = #const MAX_PATH + +setConsoleTitle :: String -> IO () +setConsoleTitle title = + withTString title $ \buf -> + failIfFalse_ (unwords ["SetConsoleTitle", title]) + $ c_SetConsoleTitle buf + +foreign import WINDOWS_CCONV "windows.h GetConsoleTitleW" + c_GetConsoleTitle :: LPTSTR -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h SetConsoleTitleW" + c_SetConsoleTitle :: LPCTSTR -> IO BOOL + diff --git a/System/Win32/DLL.hsc b/System/Win32/DLL.hsc --- a/System/Win32/DLL.hsc +++ b/System/Win32/DLL.hsc @@ -86,3 +86,11 @@ failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryExW" c_LoadLibraryEx :: LPCTSTR -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE + +setDllDirectory :: String -> IO () +setDllDirectory name = + withTString name $ \ c_name -> + failIfFalse_ (unwords ["SetDllDirectory", name]) $ c_SetDllDirectory c_name + +foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW" + c_SetDllDirectory :: LPTSTR -> IO BOOL diff --git a/System/Win32/DebugApi.hsc b/System/Win32/DebugApi.hsc --- a/System/Win32/DebugApi.hsc +++ b/System/Win32/DebugApi.hsc @@ -95,11 +95,11 @@ dwZero = 0 :: DWORD wZero = 0 :: WORD - rest (#const EXCEPTION_DEBUG_EVENT) p = do - chance <- (#peek EXCEPTION_DEBUG_INFO, dwFirstChance) p - flags <- (#peek EXCEPTION_RECORD, ExceptionFlags) p - addr <- (#peek EXCEPTION_RECORD, ExceptionAddress) p - code <- (#peek EXCEPTION_RECORD, ExceptionCode) p + rest (#const EXCEPTION_DEBUG_EVENT) p' = do + chance <- (#peek EXCEPTION_DEBUG_INFO, dwFirstChance) p' + flags <- (#peek EXCEPTION_RECORD, ExceptionFlags) p' + addr <- (#peek EXCEPTION_RECORD, ExceptionAddress) p' + code <- (#peek EXCEPTION_RECORD, ExceptionCode) p' e <- case code::DWORD of (#const EXCEPTION_ACCESS_VIOLATION) -> return $ AccessViolation False 0 (#const EXCEPTION_ARRAY_BOUNDS_EXCEEDED) -> return ArrayBoundsExceeded @@ -124,51 +124,51 @@ _ -> return UnknownException return $ Exception (chance/=dwZero, flags==dwZero, addr) e - rest (#const CREATE_THREAD_DEBUG_EVENT) p = do - handle <- (#peek CREATE_THREAD_DEBUG_INFO, hThread) p - local <- (#peek CREATE_THREAD_DEBUG_INFO, lpThreadLocalBase) p - start <- (#peek CREATE_THREAD_DEBUG_INFO, lpStartAddress) p + rest (#const CREATE_THREAD_DEBUG_EVENT) p' = do + handle <- (#peek CREATE_THREAD_DEBUG_INFO, hThread) p' + local <- (#peek CREATE_THREAD_DEBUG_INFO, lpThreadLocalBase) p' + start <- (#peek CREATE_THREAD_DEBUG_INFO, lpStartAddress) p' return $ CreateThread (handle, local, start) - rest (#const CREATE_PROCESS_DEBUG_EVENT) p = do - file <- (#peek CREATE_PROCESS_DEBUG_INFO, hFile) p - proc <- (#peek CREATE_PROCESS_DEBUG_INFO, hProcess) p - thread <- (#peek CREATE_PROCESS_DEBUG_INFO, hThread) p - imgbase <- (#peek CREATE_PROCESS_DEBUG_INFO, lpBaseOfImage) p - dbgoff <- (#peek CREATE_PROCESS_DEBUG_INFO, dwDebugInfoFileOffset) p - dbgsize <- (#peek CREATE_PROCESS_DEBUG_INFO, nDebugInfoSize) p - local <- (#peek CREATE_PROCESS_DEBUG_INFO, lpThreadLocalBase) p - start <- (#peek CREATE_PROCESS_DEBUG_INFO, lpStartAddress) p - imgname <- (#peek CREATE_PROCESS_DEBUG_INFO, lpImageName) p - --unicode <- (#peek CREATE_PROCESS_DEBUG_INFO, fUnicode) p + rest (#const CREATE_PROCESS_DEBUG_EVENT) p' = do + file <- (#peek CREATE_PROCESS_DEBUG_INFO, hFile) p' + proc <- (#peek CREATE_PROCESS_DEBUG_INFO, hProcess) p' + thread <- (#peek CREATE_PROCESS_DEBUG_INFO, hThread) p' + imgbase <- (#peek CREATE_PROCESS_DEBUG_INFO, lpBaseOfImage) p' + dbgoff <- (#peek CREATE_PROCESS_DEBUG_INFO, dwDebugInfoFileOffset) p' + dbgsize <- (#peek CREATE_PROCESS_DEBUG_INFO, nDebugInfoSize) p' + local <- (#peek CREATE_PROCESS_DEBUG_INFO, lpThreadLocalBase) p' + start <- (#peek CREATE_PROCESS_DEBUG_INFO, lpStartAddress) p' + imgname <- (#peek CREATE_PROCESS_DEBUG_INFO, lpImageName) p' + --unicode <- (#peek CREATE_PROCESS_DEBUG_INFO, fUnicode) p' return $ CreateProcess proc (file, imgbase, dbgoff, dbgsize, imgname) --, unicode/=wZero) (thread, local, start) - rest (#const EXIT_THREAD_DEBUG_EVENT) p = - (#peek EXIT_THREAD_DEBUG_INFO, dwExitCode) p >>= return.ExitThread + rest (#const EXIT_THREAD_DEBUG_EVENT) p' = + (#peek EXIT_THREAD_DEBUG_INFO, dwExitCode) p' >>= return.ExitThread - rest (#const EXIT_PROCESS_DEBUG_EVENT) p = - (#peek EXIT_PROCESS_DEBUG_INFO, dwExitCode) p >>= return.ExitProcess + rest (#const EXIT_PROCESS_DEBUG_EVENT) p' = + (#peek EXIT_PROCESS_DEBUG_INFO, dwExitCode) p' >>= return.ExitProcess - rest (#const LOAD_DLL_DEBUG_EVENT) p = do - file <- (#peek LOAD_DLL_DEBUG_INFO, hFile) p - imgbase <- (#peek LOAD_DLL_DEBUG_INFO, lpBaseOfDll) p - dbgoff <- (#peek LOAD_DLL_DEBUG_INFO, dwDebugInfoFileOffset) p - dbgsize <- (#peek LOAD_DLL_DEBUG_INFO, nDebugInfoSize) p - imgname <- (#peek LOAD_DLL_DEBUG_INFO, lpImageName) p - --unicode <- (#peek LOAD_DLL_DEBUG_INFO, fUnicode) p + rest (#const LOAD_DLL_DEBUG_EVENT) p' = do + file <- (#peek LOAD_DLL_DEBUG_INFO, hFile) p' + imgbase <- (#peek LOAD_DLL_DEBUG_INFO, lpBaseOfDll) p' + dbgoff <- (#peek LOAD_DLL_DEBUG_INFO, dwDebugInfoFileOffset) p' + dbgsize <- (#peek LOAD_DLL_DEBUG_INFO, nDebugInfoSize) p' + imgname <- (#peek LOAD_DLL_DEBUG_INFO, lpImageName) p' + --unicode <- (#peek LOAD_DLL_DEBUG_INFO, fUnicode) p' return $ LoadDll (file, imgbase, dbgoff, dbgsize, imgname)--, unicode/=wZero) - rest (#const OUTPUT_DEBUG_STRING_EVENT) p = do - dat <- (#peek OUTPUT_DEBUG_STRING_INFO, lpDebugStringData) p - unicode <- (#peek OUTPUT_DEBUG_STRING_INFO, fUnicode) p - length <- (#peek OUTPUT_DEBUG_STRING_INFO, nDebugStringLength) p - return $ DebugString dat (unicode/=wZero) length + rest (#const OUTPUT_DEBUG_STRING_EVENT) p' = do + dat <- (#peek OUTPUT_DEBUG_STRING_INFO, lpDebugStringData) p' + unicode <- (#peek OUTPUT_DEBUG_STRING_INFO, fUnicode) p' + len <- (#peek OUTPUT_DEBUG_STRING_INFO, nDebugStringLength) p' + return $ DebugString dat (unicode/=wZero) len - rest (#const UNLOAD_DLL_DEBUG_EVENT) p = - (#peek UNLOAD_DLL_DEBUG_INFO, lpBaseOfDll) p >>= return.UnloadDll + rest (#const UNLOAD_DLL_DEBUG_EVENT) p' = + (#peek UNLOAD_DLL_DEBUG_INFO, lpBaseOfDll) p' >>= return.UnloadDll rest _ _ = return UnknownDebugEvent @@ -191,9 +191,9 @@ where getMore e = case e of Nothing -> return [] - Just e -> do + Just e' -> do rest <- waitForDebugEvent (Just 0) >>= getMore - return $ e:rest + return $ e':rest continueDebugEvent :: DebugEventId -> Bool -> IO () continueDebugEvent (pid,tid) cont = @@ -362,7 +362,7 @@ -- On process being debugged outputDebugString :: String -> IO () -outputDebugString s = withTString s $ \s -> c_OutputDebugString s +outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s -------------------------------------------------------------------------- -- Raw imports diff --git a/System/Win32/Encoding.hs b/System/Win32/Encoding.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Encoding.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Encoding + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Enocode/Decode mutibyte charactor using Win32 API. +-} + +module System.Win32.Encoding + ( getCurrentCodePage + , encodeMultiByte + , encodeMultiByteIO + , decodeMultiByte + , decodeMultiByteIO + , wideCharToMultiByte + , multiByteToWideChar + ) where + +import Foreign.C.Types (CInt(..)) +import Foreign.C.String (peekCAStringLen, withCWStringLen) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Marshal.Unsafe (unsafeLocalState) +import System.Win32.Console +import System.Win32.NLS +import System.Win32.Types + +#include "windows_cconv.h" + +-- note CodePage = UInt which might not work on Win64. But the Win32 package +-- also has this issue. +getCurrentCodePage :: IO DWORD +getCurrentCodePage = do + conCP <- getConsoleCP + if conCP > 0 + then return conCP + else getACP + +-- | The "System.IO" output functions (e.g. `putStr`) don't +-- automatically convert to multibyte string on Windows, so this +-- function is provided to make the conversion from a Unicode string +-- in the given code page to a proper multibyte string. To get the +-- code page for the console, use `getCurrentCodePage`. +-- +encodeMultiByte :: CodePage -> String -> String +encodeMultiByte cp = unsafeLocalState . encodeMultiByteIO cp + +encodeMultiByteIO :: CodePage -> String -> IO String +encodeMultiByteIO _ "" = return "" + -- WideCharToMultiByte doesn't handle empty strings +encodeMultiByteIO cp wstr = + withCWStringLen wstr $ \(cwstr,len) -> do + mbchars' <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte + cp + 0 + cwstr + (fromIntegral len) + nullPtr 0 + nullPtr nullPtr + -- mbchar' is the length of buffer required + allocaArray (fromIntegral mbchars') $ \mbstr -> do + mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte + cp + 0 + cwstr + (fromIntegral len) + mbstr mbchars' + nullPtr nullPtr + peekCAStringLen (mbstr,fromIntegral mbchars) -- converts [Char] to UTF-16 + +foreign import WINDOWS_CCONV "WideCharToMultiByte" + wideCharToMultiByte + :: CodePage + -> DWORD -- dwFlags, + -> LPCWSTR -- lpWideCharStr + -> CInt -- cchWideChar + -> LPSTR -- lpMultiByteStr + -> CInt -- cbMultiByte + -> LPCSTR -- lpMultiByteStr + -> LPBOOL -- lpbFlags + -> IO CInt + +-- | The "System.IO" input functions (e.g. `getLine`) don't +-- automatically convert to Unicode, so this function is provided to +-- make the conversion from a multibyte string in the given code page +-- to a proper Unicode string. To get the code page for the console, +-- use `getCurrentCodePage`. +decodeMultiByte :: CodePage -> String -> String +decodeMultiByte cp = unsafeLocalState . decodeMultiByteIO cp + +-- | Because of `stringToUnicode` is unclear name, we use `decodeMultiByteIO` +-- for alias of `stringToUnicode`. +decodeMultiByteIO :: CodePage -> String -> IO String +decodeMultiByteIO = stringToUnicode +{-# INLINE decodeMultiByteIO #-} diff --git a/System/Win32/Exception/Unsupported.hs b/System/Win32/Exception/Unsupported.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Exception/Unsupported.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | + Module : System.Win32.Exception.Unsupported + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Exception handling if using unsupported Win32 API. +-} + +module System.Win32.Exception.Unsupported + ( module System.Win32.Exception.Unsupported + ) where + +import Control.Exception ( Exception(..), throwIO ) +import Data.Typeable ( Typeable ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.Marshal.Unsafe ( unsafeLocalState ) + +---------------------------------------------------------------- +-- Exception type of Unsupported +---------------------------------------------------------------- +data Unsupported = MissingLibrary FilePath String + | MissingFunction String String + | MissingValue String String + deriving Typeable + +instance Show Unsupported where + show (MissingLibrary name reason) + = "Can't load library \"" ++ name ++ "\". " ++ reason + show (MissingFunction name reason) + = "Can't find \"" ++ name ++ "\" function. " ++ reason + show (MissingValue name reason) + = "Can't use \"" ++ name ++ "\" value. " ++ reason + +instance Exception Unsupported + +missingLibrary :: FilePath -> Unsupported +missingFunction, missingValue :: String -> Unsupported +missingLibrary name = MissingLibrary name "" +missingFunction name = MissingFunction name "" +missingValue name = MissingValue name "" + +missingWin32Function, missingWin32Value :: String -> String -> Unsupported +missingWin32Function name reason = MissingFunction name $ doesn'tSupport ++ '\n':reason +missingWin32Value name reason = MissingValue name $ doesn'tSupport ++ '\n':reason + +doesn'tSupport, upgradeVista, removed :: String +doesn'tSupport = "Because it's not supported on this OS." +upgradeVista = upgradeWindowsOS "Windows Vista" +removed = "It's removed. " + +upgradeWindowsOS :: String -> String +upgradeWindowsOS ver + = "If you want to use it, please upgrade your OS to " + ++ ver ++ " or higher." + +unsupportedIfNull :: Unsupported -> IO (Ptr a) -> IO (Ptr a) +unsupportedIfNull wh act = do + v <- act + if v /= nullPtr then return v else throwIO wh + +unsupportedVal :: String -> IO Bool -> String -> a -> a +unsupportedVal name checkVer reason val = unsafeLocalState $ do + cv <- checkVer + if cv then return val else throwIO $ MissingValue name reason + diff --git a/System/Win32/File.hsc b/System/Win32/File.hsc --- a/System/Win32/File.hsc +++ b/System/Win32/File.hsc @@ -36,6 +36,7 @@ ##include "windows_cconv.h" #include +#include "alignment.h" ---------------------------------------------------------------- -- Enumeration types @@ -254,7 +255,7 @@ instance Storable BY_HANDLE_FILE_INFORMATION where sizeOf = const (#size BY_HANDLE_FILE_INFORMATION) - alignment = sizeOf + alignment _ = #alignment BY_HANDLE_FILE_INFORMATION poke buf bhi = do (#poke BY_HANDLE_FILE_INFORMATION, dwFileAttributes) buf (bhfiFileAttributes bhi) (#poke BY_HANDLE_FILE_INFORMATION, ftCreationTime) buf (bhfiCreationTime bhi) @@ -294,7 +295,7 @@ instance Storable WIN32_FILE_ATTRIBUTE_DATA where sizeOf = const (#size WIN32_FILE_ATTRIBUTE_DATA) - alignment = sizeOf + alignment _ = #alignment WIN32_FILE_ATTRIBUTE_DATA poke buf ad = do (#poke WIN32_FILE_ATTRIBUTE_DATA, dwFileAttributes) buf (fadFileAttributes ad) (#poke WIN32_FILE_ATTRIBUTE_DATA, ftCreationTime) buf (fadCreationTime ad) diff --git a/System/Win32/FileMapping.hsc b/System/Win32/FileMapping.hsc --- a/System/Win32/FileMapping.hsc +++ b/System/Win32/FileMapping.hsc @@ -130,17 +130,17 @@ --------------------------------------------------------------------------- createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> IO HANDLE createFileMapping mh flags mosize name = - maybeWith withTString name $ \name -> - failIf (==nullPtr) "createFileMapping: CreateFileMapping" $ c_CreateFileMapping handle nullPtr flags moshi moslow name + maybeWith withTString name $ \c_name -> + failIf (==nullPtr) "createFileMapping: CreateFileMapping" $ c_CreateFileMapping handle nullPtr flags moshi moslow c_name where (moshi,moslow) = ddwordToDwords mosize handle = maybe iNVALID_HANDLE_VALUE id mh openFileMapping :: FileMapAccess -> BOOL -> Maybe String -> IO HANDLE openFileMapping access inherit name = - maybeWith withTString name $ \name -> + maybeWith withTString name $ \c_name -> failIf (==nullPtr) "openFileMapping: OpenFileMapping" $ - c_OpenFileMapping access inherit name + c_OpenFileMapping access inherit c_name mapViewOfFileEx :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> Ptr a -> IO (Ptr b) mapViewOfFileEx h access offset size base = diff --git a/System/Win32/HardLink.hs b/System/Win32/HardLink.hs new file mode 100644 --- /dev/null +++ b/System/Win32/HardLink.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.HardLink + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Handling hard link using Win32 API. [NTFS only] + + Note: You should worry about file system type when use this module's function in your application: + + * NTFS only supprts this functionality. + + * ReFS doesn't support hard link currently. +-} +module System.Win32.HardLink + ( module System.Win32.HardLink + ) where +import System.Win32.File ( LPSECURITY_ATTRIBUTES, failIfFalseWithRetry_ ) +import System.Win32.String ( LPCTSTR, withTString ) +import System.Win32.Types ( BOOL, nullPtr ) + +#include "windows_cconv.h" + +-- | NOTE: createHardLink is /flipped arguments/ to provide compatiblity for Unix. +-- +-- If you want to create hard link by Windows way, use 'createHardLink'' instead. +createHardLink :: FilePath -- ^ Target file path + -> FilePath -- ^ Hard link name + -> IO () +createHardLink = flip createHardLink' + +createHardLink' :: FilePath -- ^ Hard link name + -> FilePath -- ^ Target file path + -> IO () +createHardLink' link target = + withTString target $ \c_target -> + withTString link $ \c_link -> + failIfFalseWithRetry_ (unwords ["CreateHardLinkW",show link,show target]) $ + c_CreateHardLink c_link c_target nullPtr + +foreign import WINDOWS_CCONV unsafe "windows.h CreateHardLinkW" + c_CreateHardLink :: LPCTSTR -- ^ Hard link name + -> LPCTSTR -- ^ Target file path + -> LPSECURITY_ATTRIBUTES -- ^ This parameter is reserved. You should pass just /nullPtr/. + -> IO BOOL + +{- +-- We plan to check file system type internally. + +-- We are thinking about API design, currently... +data VolumeInformation = VolumeInformation + { volumeName :: String + , volumeSerialNumber :: DWORD + , maximumComponentLength :: DWORD + , fileSystemFlags :: DWORD + , fileSystemName :: String + } deriving Show + +getVolumeInformation :: String -> IO VolumeInformation +getVolumeInformation drive = + withTString drive $ \c_drive -> + withTStringBufferLen 256 $ \(vnBuf, vnLen) -> + alloca $ \serialNum -> + alloca $ \maxLen -> + alloca $ \fsFlags -> + withTStringBufferLen 256 $ \(fsBuf, fsLen) -> do + failIfFalse_ (unwords ["GetVolumeInformationW", drive]) $ + c_GetVolumeInformation c_drive vnBuf (fromIntegral vnLen) + serialNum maxLen fsFlags + fsBuf (fromIntegral fsLen) + return VolumeInformation + <*> peekTString vnBuf + <*> peek serialNum + <*> peek maxLen + <*> peek fsFlags + <*> peekTString fsBuf + +-- Which is better? +getVolumeFileType :: String -> IO String +getVolumeFileType drive = fileSystemName <$> getVolumeInformation drive + +getVolumeFileType :: String -> IO String +getVolumeFileType drive = + withTString drive $ \c_drive -> + withTStringBufferLen 256 $ \(buf, len) -> do + failIfFalse_ (unwords ["GetVolumeInformationW", drive]) $ + c_GetVolumeInformation c_drive nullPtr 0 nullPtr nullPtr nullPtr buf (fromIntegral len) + peekTString buf + +foreign import WINDOWS_CCONV unsafe "windows.h GetVolumeInformationW" + c_GetVolumeInformation :: LPCTSTR -> LPTSTR -> DWORD -> LPDWORD -> LPDWORD -> LPDWORD -> LPTSTR -> DWORD -> IO BOOL +-} diff --git a/System/Win32/Info.hsc b/System/Win32/Info.hsc --- a/System/Win32/Info.hsc +++ b/System/Win32/Info.hsc @@ -36,6 +36,7 @@ ##include "windows_cconv.h" #include +#include "alignment.h" ---------------------------------------------------------------- -- Environment Strings @@ -218,7 +219,7 @@ instance Storable SYSTEM_INFO where sizeOf = const #size SYSTEM_INFO - alignment = sizeOf + alignment _ = #alignment SYSTEM_INFO poke buf si = do (#poke SYSTEM_INFO, wProcessorArchitecture) buf (siProcessorArchitecture si) (#poke SYSTEM_INFO, dwPageSize) buf (siPageSize si) @@ -367,45 +368,6 @@ failIfFalse_ "GetUserName" $ c_GetUserName c_str c_len len <- peek c_len peekTStringLen (c_str, fromIntegral len - 1) - ----------------------------------------------------------------- --- Version Info ----------------------------------------------------------------- - --- %fun GetVersionEx :: IO VersionInfo --- --- typedef struct _OSVERSIONINFO{ --- DWORD dwOSVersionInfoSize; --- DWORD dwMajorVersion; --- DWORD dwMinorVersion; --- DWORD dwBuildNumber; --- DWORD dwPlatformId; --- TCHAR szCSDVersion[ 128 ]; --- } OSVERSIONINFO; - ----------------------------------------------------------------- --- Processor features ----------------------------------------------------------------- - --- --- Including these lines causes problems on Win95 --- %fun IsProcessorFeaturePresent :: ProcessorFeature -> Bool --- --- type ProcessorFeature = DWORD --- %dis processorFeature x = dWORD x --- --- %const ProcessorFeature --- % [ PF_FLOATING_POINT_PRECISION_ERRATA --- % , PF_FLOATING_POINT_EMULATED --- % , PF_COMPARE_EXCHANGE_DOUBLE --- % , PF_MMX_INSTRUCTIONS_AVAILABLE --- % ] - ----------------------------------------------------------------- --- System Parameter Information ----------------------------------------------------------------- - --- %fun SystemParametersInfo :: ?? -> Bool -> IO ?? ---------------------------------------------------------------- -- End diff --git a/System/Win32/Info/Computer.hsc b/System/Win32/Info/Computer.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Info/Computer.hsc @@ -0,0 +1,237 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Info.Computer + Copyright : 2012-2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Information about your computer. +-} +module System.Win32.Info.Computer + ( -- * Environment Strings + expandEnvironmentStrings, c_ExpandEnvironmentStrings + + -- * Computer Name + , getComputerName, setComputerName + , c_GetComputerName, c_SetComputerName + + -- * System metrics + , getSystemMetrics + , sM_CMONITORS + , sM_IMMENABLED + , sM_MOUSEWHEELPRESENT + , sM_REMOTESESSION + , sM_SAMEDISPLAYFORMAT + , sM_XVIRTUALSCREEN + , sM_YVIRTUALSCREEN + , sM_SERVERR2 + , sM_MEDIACENTER + , sM_STARTER + , sM_TABLETPC + + -- * User name + , getUserName, c_GetUserName + + -- * Version Info + , OSVERSIONINFOEX(..), POSVERSIONINFOEX, LPOSVERSIONINFOEX + , ProductType(..) + , getVersionEx, c_GetVersionEx + + -- * Processor features + , ProcessorFeature + , isProcessorFeaturePresent + , pF_3DNOW_INSTRUCTIONS_AVAILABLE + , pF_COMPARE_EXCHANGE_DOUBLE + , pF_FLOATING_POINT_EMULATED + , pF_FLOATING_POINT_PRECISION_ERRATA + , pF_MMX_INSTRUCTIONS_AVAILABLE + , pF_PAE_ENABLED + , pF_RDTSC_INSTRUCTION_AVAILABLE + , pF_XMMI_INSTRUCTIONS_AVAILABLE + , pF_XMMI64_INSTRUCTIONS_AVAILABLE + ) where + +import Foreign.Marshal.Utils ( with ) +import Foreign.Storable ( Storable(..) ) +import System.Win32.Info ( SMSetting ) +import System.Win32.Info.Version +import System.Win32.String ( LPCTSTR, LPTSTR, withTString, withTStringBuffer + , peekTString, peekTStringLen ) +import System.Win32.Types ( BOOL, failIfFalse_ ) +import System.Win32.Utils ( tryWithoutNull ) +import System.Win32.Word ( DWORD, LPDWORD ) + +#include +#include +#include "alignment.h" +##include "windows_cconv.h" + +---------------------------------------------------------------- +-- Environment Strings +---------------------------------------------------------------- +expandEnvironmentStrings :: String -> IO String +expandEnvironmentStrings name = + withTString name $ \ c_name -> + tryWithoutNull (unwords ["ExpandEnvironmentStrings", name]) + (\buf len -> c_ExpandEnvironmentStrings c_name buf len) 512 + +foreign import WINDOWS_CCONV unsafe "windows.h ExpandEnvironmentStringsW" + c_ExpandEnvironmentStrings :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD + +---------------------------------------------------------------- +-- Computer Name +---------------------------------------------------------------- + +getComputerName :: IO String +getComputerName = + withTStringBuffer maxLength $ \buf -> + with (fromIntegral maxLength) $ \len -> do + failIfFalse_ "GetComputerName" + $ c_GetComputerName buf len + len' <- peek len + peekTStringLen (buf, (fromIntegral len')) + where + maxLength = #const MAX_COMPUTERNAME_LENGTH + +foreign import WINDOWS_CCONV unsafe "GetComputerNameW" + c_GetComputerName :: LPTSTR -> LPDWORD -> IO Bool + +setComputerName :: String -> IO () +setComputerName name = + withTString name $ \buf -> + failIfFalse_ (unwords ["SetComputerName", name]) + $ c_SetComputerName buf + +foreign import WINDOWS_CCONV unsafe "SetComputerNameW" + c_SetComputerName :: LPTSTR -> IO Bool +{- +type COMPUTER_NAME_FORMAT = UINT +{enum COMPUTER_NAME_FORMAT, + , computerNameNetBIOS = ComputerNameNetBIOS + , computerNameDnsHostname = ComputerNameDnsHostname + , computerNameDnsDomain = ComputerNameDnsDomain + , computerNameDnsFullyQualified = ComputerNameDnsFullyQualified + , computerNamePhysicalNetBIOS = ComputerNamePhysicalNetBIOS + , computerNamePhysicalDnsHostname = ComputerNamePhysicalDnsHostname + , computerNamePhysicalDnsDomain = ComputerNamePhysicalDnsFullyQualified + , computerNamePhysicalDnsFullyQualified = ComputerNamePhysicalDnsFullyQualified + , computerNameMax = ComputerNameMax + } +-} + +---------------------------------------------------------------- +-- Hardware Profiles +---------------------------------------------------------------- +{- +-- TODO: Deside HW_PROFILE_INFO type design + +type LPHW_PROFILE_INFO = Ptr HW_PROFILE_INFO + +data HW_PROFILE_INFO = HW_PROFILE_INFO + { dwDockInfo :: DWORD + , szHwProfileGuid :: String -- Should we use GUID type instead of String? + , szHwProfileName :: String + } deriving Show + +instance Storable HW_PROFILE_INFO where + sizeOf = const #{size HW_PROFILE_INFOW} + alignment _ = #alignment HW_PROFILE_INFOW + poke buf info = do + (#poke HW_PROFILE_INFOW, dwDockInfo) buf (dwDockInfo info) + withTString (szHwProfileGuid info) $ \szHwProfileGuid' -> + (#poke HW_PROFILE_INFOW, szHwProfileGuid) buf szHwProfileGuid' + withTString (szHwProfileName info) $ \szHwProfileName' -> + (#poke HW_PROFILE_INFOW, szHwProfileName) buf szHwProfileName' + + peek buf = do + dockInfo <- (#peek HW_PROFILE_INFOW, dwDockInfo) buf + hwProfileGuid <- peekTString $ (#ptr HW_PROFILE_INFOW, szHwProfileGuid) buf + hwProfileName <- peekTString $ (#ptr HW_PROFILE_INFOW, szHwProfileName) buf + return $ HW_PROFILE_INFO dockInfo hwProfileGuid hwProfileName + +getCurrentHwProfile :: IO HW_PROFILE_INFO +getCurrentHwProfile = + alloca $ \buf -> do + failIfFalse_ "GetCurrentHwProfile" + $ c_GetCurrentHwProfile buf + peek buf + +foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentHwProfileW" + c_GetCurrentHwProfile :: LPHW_PROFILE_INFO -> IO Bool +-} + +---------------------------------------------------------------- +-- System metrics +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h GetSystemMetrics" + getSystemMetrics :: SMSetting -> IO Int + +#{enum SMSetting, + , sM_CMONITORS = SM_CMONITORS + , sM_IMMENABLED = SM_IMMENABLED + , sM_MOUSEWHEELPRESENT = SM_MOUSEWHEELPRESENT + , sM_REMOTESESSION = SM_REMOTESESSION + , sM_SAMEDISPLAYFORMAT = SM_SAMEDISPLAYFORMAT + , sM_XVIRTUALSCREEN = SM_XVIRTUALSCREEN + , sM_YVIRTUALSCREEN = SM_YVIRTUALSCREEN + , sM_SERVERR2 = SM_SERVERR2 + , sM_MEDIACENTER = SM_MEDIACENTER + , sM_STARTER = SM_STARTER + , sM_TABLETPC = SM_TABLETPC + } + +---------------------------------------------------------------- +-- User name +---------------------------------------------------------------- + +-- | Get user name. See: , +getUserName :: IO String +getUserName = + withTStringBuffer maxLength $ \buf -> + with (fromIntegral maxLength) $ \len -> do + failIfFalse_ "GetComputerName" + $ c_GetUserName buf len + -- GetUserNameW includes NUL charactor. + peekTString buf + where + -- This requires Lmcons.h + maxLength = #const UNLEN + +foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW" + c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool + +---------------------------------------------------------------- +-- Processor features +---------------------------------------------------------------- + +foreign import WINDOWS_CCONV unsafe "windows.h IsProcessorFeaturePresent" + isProcessorFeaturePresent :: ProcessorFeature -> IO BOOL + +type ProcessorFeature = DWORD + +#{enum ProcessorFeature, + , pF_3DNOW_INSTRUCTIONS_AVAILABLE = PF_3DNOW_INSTRUCTIONS_AVAILABLE + , pF_COMPARE_EXCHANGE_DOUBLE = PF_COMPARE_EXCHANGE_DOUBLE + , pF_FLOATING_POINT_EMULATED = PF_FLOATING_POINT_EMULATED + , pF_FLOATING_POINT_PRECISION_ERRATA = PF_FLOATING_POINT_PRECISION_ERRATA + , pF_MMX_INSTRUCTIONS_AVAILABLE = PF_MMX_INSTRUCTIONS_AVAILABLE + , pF_PAE_ENABLED = PF_PAE_ENABLED + , pF_RDTSC_INSTRUCTION_AVAILABLE = PF_RDTSC_INSTRUCTION_AVAILABLE + , pF_XMMI_INSTRUCTIONS_AVAILABLE = PF_XMMI_INSTRUCTIONS_AVAILABLE + , pF_XMMI64_INSTRUCTIONS_AVAILABLE = PF_XMMI64_INSTRUCTIONS_AVAILABLE + } + +{- + , pF_CHANNELS_ENABLED = PF_CHANNELS_ENABLED + , pF_NX_ENABLED = PF_NX_ENABLED + , pF_COMPARE_EXCHANGE128 = PF_COMPARE_EXCHANGE128 + , pF_COMPARE64_EXCHANGE128 = PF_COMPARE64_EXCHANGE128 + , pF_SECOND_LEVEL_ADDRESS_TRANSLATION = PF_SECOND_LEVEL_ADDRESS_TRANSLATION + , pF_SSE3_INSTRUCTIONS_AVAILABLE = PF_SSE3_INSTRUCTIONS_AVAILABLE + , pF_VIRT_FIRMWARE_ENABLED = PF_VIRT_FIRMWARE_ENABLED + , pF_XSAVE_ENABLED = PF_XSAVE_ENABLED +-} diff --git a/System/Win32/Info/Version.hsc b/System/Win32/Info/Version.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Info/Version.hsc @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Info.Version + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Version information about your computer. +-} +module System.Win32.Info.Version + ( -- * Version Info + OSVERSIONINFOEX(..), POSVERSIONINFOEX, LPOSVERSIONINFOEX + , ProductType(..) + , getVersionEx, c_GetVersionEx + + -- * Verify OS version + , isVistaOrLater, is7OrLater + ) where +import Foreign.Ptr ( Ptr, plusPtr ) +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Storable ( Storable(..) ) +import System.Win32.String ( withTString, peekTString ) +import System.Win32.Types ( BOOL, BYTE, failIfFalse_ ) +import System.Win32.Word ( WORD, DWORD ) + +#include +#include "alignment.h" +##include "windows_cconv.h" + +---------------------------------------------------------------- +-- Version Info +---------------------------------------------------------------- +getVersionEx :: IO OSVERSIONINFOEX +getVersionEx = + alloca $ \buf -> do + (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf + $ sizeOf (undefined::OSVERSIONINFOEX) + failIfFalse_ "GetVersionEx" + $ c_GetVersionEx buf + peek buf + +data ProductType = VerUnknow BYTE | VerNTWorkStation | VerNTDomainControler | VerNTServer + deriving (Show,Eq) + +instance Storable ProductType where + sizeOf _ = sizeOf (undefined::BYTE) + alignment _ = alignment (undefined::BYTE) + poke buf v = pokeByteOff buf 0 $ case v of + VerUnknow w -> w + VerNTWorkStation -> #const VER_NT_WORKSTATION + VerNTDomainControler -> #const VER_NT_DOMAIN_CONTROLLER + VerNTServer -> #const VER_NT_SERVER + peek buf = do + v <- peekByteOff buf 0 + return $ case v of + (#const VER_NT_WORKSTATION) -> VerNTWorkStation + (#const VER_NT_DOMAIN_CONTROLLER) -> VerNTDomainControler + (#const VER_NT_SERVER) -> VerNTServer + w -> VerUnknow w + +type POSVERSIONINFOEX = Ptr OSVERSIONINFOEX +type LPOSVERSIONINFOEX = Ptr OSVERSIONINFOEX + +data OSVERSIONINFOEX = OSVERSIONINFOEX + { dwMajorVersion :: DWORD + , dwMinorVersion :: DWORD + , dwBuildNumber :: DWORD + , dwPlatformId :: DWORD + , szCSDVersion :: String + , wServicePackMajor :: WORD + , wServicePackMinor :: WORD + , wSuiteMask :: WORD + , wProductType :: ProductType + } deriving Show + +instance Storable OSVERSIONINFOEX where + sizeOf = const #{size struct _OSVERSIONINFOEXW} + alignment _ = #alignment OSVERSIONINFOEX + poke buf info = do + (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf (sizeOf info) + (#poke OSVERSIONINFOEXW, dwMajorVersion) buf (dwMajorVersion info) + (#poke OSVERSIONINFOEXW, dwMinorVersion) buf (dwMinorVersion info) + (#poke OSVERSIONINFOEXW, dwBuildNumber) buf (dwBuildNumber info) + (#poke OSVERSIONINFOEXW, dwPlatformId) buf (dwPlatformId info) + withTString (szCSDVersion info) $ \szCSDVersion' -> + (#poke OSVERSIONINFOEXW, szCSDVersion) buf szCSDVersion' + (#poke OSVERSIONINFOEXW, wServicePackMajor) buf (wServicePackMajor info) + (#poke OSVERSIONINFOEXW, wServicePackMinor) buf (wServicePackMinor info) + (#poke OSVERSIONINFOEXW, wSuiteMask) buf (wSuiteMask info) + (#poke OSVERSIONINFOEXW, wProductType) buf (wProductType info) + (#poke OSVERSIONINFOEXW, wReserved) buf (0::BYTE) + + peek buf = do + majorVersion <- (#peek OSVERSIONINFOEXW, dwMajorVersion) buf + minorVersion <- (#peek OSVERSIONINFOEXW, dwMinorVersion) buf + buildNumber <- (#peek OSVERSIONINFOEXW, dwBuildNumber) buf + platformId <- (#peek OSVERSIONINFOEXW, dwPlatformId) buf + cSDVersion <- peekTString $ (#ptr OSVERSIONINFOEXW, szCSDVersion) buf + servicePackMajor <- (#peek OSVERSIONINFOEXW, wServicePackMajor) buf + servicePackMinor <- (#peek OSVERSIONINFOEXW, wServicePackMinor) buf + suiteMask <- (#peek OSVERSIONINFOEXW, wSuiteMask) buf + productType <- (#peek OSVERSIONINFOEXW, wProductType) buf + return $ OSVERSIONINFOEX majorVersion minorVersion + buildNumber platformId cSDVersion + servicePackMajor servicePackMinor + suiteMask productType + +foreign import WINDOWS_CCONV unsafe "windows.h GetVersionExW" + c_GetVersionEx :: LPOSVERSIONINFOEX -> IO BOOL + +---------------------------------------------------------------- +-- Verify OS version +---------------------------------------------------------------- +-- See: http://msdn.microsoft.com/en-us/library/windows/desktop/ms724833(v=vs.85).aspx + +isVistaOrLater, is7OrLater :: IO Bool +isVistaOrLater = do + ver <- getVersionEx + return $ 6 <= dwMajorVersion ver + +is7OrLater = do + ver <- getVersionEx + return $ 6 <= dwMajorVersion ver + && 1 <= dwMinorVersion ver + +{- +We don't use VerifyVersionInfo function to above functions. + +Because VerifyVersionInfo is more difficult than GetVersionEx and accessing field in Haskell. + +-- | See: http://support.microsoft.com/kb/225013/ +-- http://msdn.microsoft.com/en-us/library/windows/desktop/ms725491(v=vs.85).aspx + +bIsWindowsVersionOK :: DWORD -> DWORD -> WORD -> IO BOOL +bIsWindowsVersionOK dwMajor dwMinor dwSPMajor = + alloca $ \buf -> do + zeroMemory buf + (#{size OSVERSIONINFOEXW}::DWORD) + (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf + (#{size OSVERSIONINFOEXW}::DWORD) + (#poke OSVERSIONINFOEXW, dwMajorVersion) buf dwMajor + (#poke OSVERSIONINFOEXW, dwMinorVersion) buf dwMinor + (#poke OSVERSIONINFOEXW, wServicePackMajor) buf dwSPMajor + -- Set up the condition mask. + let dwlConditionMask = 0 + flag = #const VER_MAJORVERSION + .|. #const VER_MINORVERSION + .|. #const VER_SERVICEPACKMAJOR + dwlConditionMask' <- vER_SET_CONDITION dwlConditionMask #{const VER_MAJORVERSION} #{const VER_GREATER_EQUAL} + dwlConditionMask'' <- vER_SET_CONDITION dwlConditionMask' #{const VER_MINORVERSION} #{const VER_MINORVERSION} + dwlConditionMask''' <- vER_SET_CONDITION dwlConditionMask'' #{const VER_SERVICEPACKMAJOR} #{const VER_SERVICEPACKMAJOR} + verifyVersionInfo buf flag dwlConditionMask''' + +type ULONGLONG = DWORDLONG + +foreign import capi unsafe "windows.h VER_SET_CONDITION" + vER_SET_CONDITION :: ULONGLONG -> DWORD -> BYTE -> IO ULONGLONG + +foreign import WINDOWS_CCONV unsafe "windows.h VerifyVersionInfoW" + verifyVersionInfo :: LPOSVERSIONINFOEX -> DWORD -> DWORDLONG -> IO BOOL +-} diff --git a/System/Win32/Mem.hsc b/System/Win32/Mem.hsc --- a/System/Win32/Mem.hsc +++ b/System/Win32/Mem.hsc @@ -27,6 +27,7 @@ ##include "windows_cconv.h" #include +#include "alignment.h" ---------------------------------------------------------------- -- Data types @@ -48,7 +49,7 @@ instance Storable MEMORY_BASIC_INFORMATION where sizeOf _ = #size MEMORY_BASIC_INFORMATION - alignment = sizeOf + alignment _ = #alignment MEMORY_BASIC_INFORMATION poke buf mbi = do (#poke MEMORY_BASIC_INFORMATION, BaseAddress) buf (mbiBaseAddress mbi) (#poke MEMORY_BASIC_INFORMATION, AllocationBase) buf (mbiAllocationBase mbi) diff --git a/System/Win32/MinTTY.hsc b/System/Win32/MinTTY.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/MinTTY.hsc @@ -0,0 +1,229 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.MinTTY +-- Copyright : (c) University of Glasgow 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- A function to check if the current terminal uses MinTTY. +-- Much of this code was originally authored by Phil Ruffwind and the +-- git-for-windows project. +-- +----------------------------------------------------------------------------- + +module System.Win32.MinTTY (isMinTTY, isMinTTYHandle) where + +import Graphics.Win32.Misc +import System.Win32.DLL +import System.Win32.File +import System.Win32.Types + +#if MIN_VERSION_base(4,6,0) +import Control.Exception (catch) +#endif +import Data.List (isPrefixOf, isInfixOf, isSuffixOf) +import Foreign +import Foreign.C.Types +import System.FilePath (takeFileName) + +#if __GLASGOW_HASKELL__ < 711 +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif + +-- The headers that are shipped with GHC's copy of MinGW-w64 assume Windows XP. +-- Since we need some structs that are only available with Vista or later, +-- we must manually set WINVER/_WIN32_WINNT accordingly. +#undef WINVER +#define WINVER 0x0600 +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0600 +##include "windows_cconv.h" +#include +#include "winternl_compat.h" + +-- | Returns 'True' if the current process's standard error is attached to a +-- MinTTY console (e.g., Cygwin or MSYS). Returns 'False' otherwise. +isMinTTY :: IO Bool +isMinTTY = do + h <- getStdHandle sTD_ERROR_HANDLE + `catch` \(_ :: IOError) -> + return nullHANDLE + if h == nullHANDLE + then return False + else isMinTTYHandle h + +-- | Returns 'True' is the given handle is attached to a MinTTY console +-- (e.g., Cygwin or MSYS). Returns 'False' otherwise. +isMinTTYHandle :: HANDLE -> IO Bool +isMinTTYHandle h = do + fileType <- getFileType h + if fileType /= fILE_TYPE_PIPE + then return False + else isMinTTYVista h `catch` \(_ :: IOError) -> isMinTTYCompat h + -- GetFileNameByHandleEx is only available on Vista and later (hence + -- the name isMinTTYVista). If we're on an older version of Windows, + -- getProcAddress will throw an IOException when it fails to find + -- GetFileNameByHandleEx, and thus we will default to using + -- NtQueryObject (isMinTTYCompat). + +isMinTTYVista :: HANDLE -> IO Bool +isMinTTYVista h = do + fn <- getFileNameByHandle h + return $ cygwinMSYSCheck fn + `catch` \(_ :: IOError) -> + return False + +isMinTTYCompat :: HANDLE -> IO Bool +isMinTTYCompat h = do + fn <- ntQueryObjectNameInformation h + return $ cygwinMSYSCheck fn + `catch` \(_ :: IOError) -> + return False + +cygwinMSYSCheck :: String -> Bool +cygwinMSYSCheck fn = ("cygwin-" `isPrefixOf` fn' || "msys-" `isPrefixOf` fn') && + "-pty" `isInfixOf` fn' && + "-master" `isSuffixOf` fn' + where + fn' = takeFileName fn +-- Note that GetFileInformationByHandleEx might return a filepath like: +-- +-- \msys-dd50a72ab4668b33-pty1-to-master +-- +-- But NtQueryObject might return something like: +-- +-- \Device\NamedPipe\msys-dd50a72ab4668b33-pty1-to-master +-- +-- This means we can't rely on "\cygwin-" or "\msys-" being at the very start +-- of the filepath. Therefore, we must take care to first call takeFileName +-- before checking for "cygwin" or "msys" at the start using `isPrefixOf`. + +getFileNameByHandle :: HANDLE -> IO String +getFileNameByHandle h = do + let sizeOfDWORD = sizeOf (undefined :: DWORD) + -- note: implicitly assuming that DWORD has stronger alignment than wchar_t + bufSize = sizeOfDWORD + mAX_PATH * sizeOfTCHAR + allocaBytes bufSize $ \buf -> do + getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize) + fni <- peek buf + return $ fniFileName fni + +getFileInformationByHandleEx + :: HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO () +getFileInformationByHandleEx h cls buf bufSize = do + lib <- getModuleHandle (Just "kernel32.dll") + ptr <- getProcAddress lib "GetFileInformationByHandleEx" + let c_GetFileInformationByHandleEx = + mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr) + failIfFalse_ "getFileInformationByHandleEx" + (c_GetFileInformationByHandleEx h cls buf bufSize) + +ntQueryObjectNameInformation :: HANDLE -> IO String +ntQueryObjectNameInformation h = do + let sizeOfONI = sizeOf (undefined :: OBJECT_NAME_INFORMATION) + bufSize = sizeOfONI + mAX_PATH * sizeOfTCHAR + allocaBytes bufSize $ \buf -> + alloca $ \p_len -> do + _ <- failIfNeg "NtQueryObject" $ c_NtQueryObject + h objectNameInformation buf (fromIntegral bufSize) p_len + oni <- peek buf + return $ usBuffer $ oniName oni + +fileNameInfo :: CInt +fileNameInfo = #const FileNameInfo + +mAX_PATH :: Num a => a +mAX_PATH = #const MAX_PATH + +objectNameInformation :: CInt +objectNameInformation = #const ObjectNameInformation + +type F_GetFileInformationByHandleEx = + HANDLE -> CInt -> Ptr FILE_NAME_INFO -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV "dynamic" + mk_GetFileInformationByHandleEx + :: FunPtr F_GetFileInformationByHandleEx -> F_GetFileInformationByHandleEx + +data FILE_NAME_INFO = FILE_NAME_INFO + { fniFileNameLength :: DWORD + , fniFileName :: String + } deriving Show + +instance Storable FILE_NAME_INFO where + sizeOf _ = #size FILE_NAME_INFO + alignment _ = #alignment FILE_NAME_INFO + poke buf fni = withTStringLen (fniFileName fni) $ \(str, len) -> do + let len' = (min mAX_PATH len) * sizeOfTCHAR + start = advancePtr (castPtr buf) (#offset FILE_NAME_INFO, FileName) + end = advancePtr start len' + (#poke FILE_NAME_INFO, FileNameLength) buf len' + copyArray start (castPtr str :: Ptr Word8) len' + poke (castPtr end) (0 :: TCHAR) + peek buf = do + vfniFileNameLength <- (#peek FILE_NAME_INFO, FileNameLength) buf + let len = fromIntegral vfniFileNameLength `div` sizeOfTCHAR + vfniFileName <- peekTStringLen (plusPtr buf (#offset FILE_NAME_INFO, FileName), len) + return $ FILE_NAME_INFO + { fniFileNameLength = vfniFileNameLength + , fniFileName = vfniFileName + } + +foreign import WINDOWS_CCONV "winternl.h NtQueryObject" + c_NtQueryObject :: HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION + -> ULONG -> Ptr ULONG -> IO NTSTATUS + +type NTSTATUS = #type NTSTATUS + +newtype OBJECT_NAME_INFORMATION = OBJECT_NAME_INFORMATION + { oniName :: UNICODE_STRING + } deriving Show + +instance Storable OBJECT_NAME_INFORMATION where + sizeOf _ = #size OBJECT_NAME_INFORMATION + alignment _ = #alignment OBJECT_NAME_INFORMATION + poke buf oni = (#poke OBJECT_NAME_INFORMATION, Name) buf (oniName oni) + peek buf = fmap OBJECT_NAME_INFORMATION $ (#peek OBJECT_NAME_INFORMATION, Name) buf + +data UNICODE_STRING = UNICODE_STRING + { usLength :: USHORT + , usMaximumLength :: USHORT + , usBuffer :: String + } deriving Show + +instance Storable UNICODE_STRING where + sizeOf _ = #size UNICODE_STRING + alignment _ = #alignment UNICODE_STRING + poke buf us = withTStringLen (usBuffer us) $ \(str, len) -> do + let len' = (min mAX_PATH len) * sizeOfTCHAR + start = advancePtr (castPtr buf) (#size UNICODE_STRING) + end = advancePtr start len' + (#poke UNICODE_STRING, Length) buf len' + (#poke UNICODE_STRING, MaximumLength) buf (len' + sizeOfTCHAR) + (#poke UNICODE_STRING, Buffer) buf start + copyArray start (castPtr str :: Ptr Word8) len' + poke (castPtr end) (0 :: TCHAR) + peek buf = do + vusLength <- (#peek UNICODE_STRING, Length) buf + vusMaximumLength <- (#peek UNICODE_STRING, MaximumLength) buf + vusBufferPtr <- (#peek UNICODE_STRING, Buffer) buf + let len = fromIntegral vusLength `div` sizeOfTCHAR + vusBuffer <- peekTStringLen (vusBufferPtr, len) + return $ UNICODE_STRING + { usLength = vusLength + , usMaximumLength = vusMaximumLength + , usBuffer = vusBuffer + } + +sizeOfTCHAR :: Int +sizeOfTCHAR = sizeOf (undefined :: TCHAR) diff --git a/System/Win32/NLS.hsc b/System/Win32/NLS.hsc --- a/System/Win32/NLS.hsc +++ b/System/Win32/NLS.hsc @@ -364,13 +364,13 @@ nullPtr 0 -- wchars is the length of buffer required allocaArray (fromIntegral wchars) $ \cwstr -> do - wchars <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar + wchars' <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar cp 0 cstr (fromIntegral len) cwstr wchars - peekCWStringLen (cwstr,fromIntegral wchars) -- converts UTF-16 to [Char] + peekCWStringLen (cwstr,fromIntegral wchars') -- converts UTF-16 to [Char] foreign import WINDOWS_CCONV unsafe "MultiByteToWideChar" multiByteToWideChar diff --git a/System/Win32/Process.hsc b/System/Win32/Process.hsc --- a/System/Win32/Process.hsc +++ b/System/Win32/Process.hsc @@ -69,11 +69,17 @@ getProcessId :: ProcessHandle -> IO ProcessId getProcessId h = failIfZero "GetProcessId" $ c_GetProcessId h +foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentProcess" + c_GetCurrentProcess :: IO ProcessHandle + foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentProcessId" c_GetCurrentProcessId :: IO ProcessId getCurrentProcessId :: IO ProcessId getCurrentProcessId = c_GetCurrentProcessId + +getCurrentProcess :: IO ProcessHandle +getCurrentProcess = c_GetCurrentProcess type Th32SnapHandle = HANDLE type Th32SnapFlags = DWORD diff --git a/System/Win32/Registry.hsc b/System/Win32/Registry.hsc --- a/System/Win32/Registry.hsc +++ b/System/Win32/Registry.hsc @@ -353,29 +353,29 @@ c_RegQueryInfoKey p_key c_class_string p_class_id nullPtr p_subkeys p_max_subkey_len p_max_class_len p_values p_max_value_name_len p_max_value_len p_sec_len p_lastWrite - class_string <- peekTString c_class_string - class_id <- peek p_class_id - subkeys <- peek p_subkeys - max_subkey_len <- peek p_max_subkey_len - max_class_len <- peek p_max_class_len - values <- peek p_values - max_value_name_len <- peek p_max_value_name_len - max_value_len <- peek p_max_value_len - sec_len <- peek p_sec_len - lastWrite_lo <- #{peek FILETIME,dwLowDateTime} p_lastWrite - lastWrite_hi <- #{peek FILETIME,dwHighDateTime} p_lastWrite + class_string' <- peekTString c_class_string + class_id' <- peek p_class_id + subkeys' <- peek p_subkeys + max_subkey_len' <- peek p_max_subkey_len + max_class_len' <- peek p_max_class_len + values' <- peek p_values + max_value_name_len' <- peek p_max_value_name_len + max_value_len' <- peek p_max_value_len + sec_len' <- peek p_sec_len + lastWrite_lo' <- #{peek FILETIME,dwLowDateTime} p_lastWrite + lastWrite_hi' <- #{peek FILETIME,dwHighDateTime} p_lastWrite return $ RegInfoKey - { class_string = class_string - , class_id = fromIntegral class_id - , subkeys = subkeys - , max_subkey_len = max_subkey_len - , max_class_len = max_class_len - , values = values - , max_value_name_len = max_value_name_len - , max_value_len = max_value_len - , sec_len = fromIntegral sec_len - , lastWrite_lo = lastWrite_lo - , lastWrite_hi = lastWrite_hi + { class_string = class_string' + , class_id = fromIntegral class_id' + , subkeys = subkeys' + , max_subkey_len = max_subkey_len' + , max_class_len = max_class_len' + , values = values' + , max_value_name_len = max_value_name_len' + , max_value_len = max_value_len' + , sec_len = fromIntegral sec_len' + , lastWrite_lo = lastWrite_lo' + , lastWrite_hi = lastWrite_hi' } foreign import WINDOWS_CCONV unsafe "windows.h RegQueryInfoKeyW" c_RegQueryInfoKey :: PKEY -> LPTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr FILETIME -> IO ErrCode diff --git a/System/Win32/SimpleMAPI.hsc b/System/Win32/SimpleMAPI.hsc --- a/System/Win32/SimpleMAPI.hsc +++ b/System/Win32/SimpleMAPI.hsc @@ -164,9 +164,9 @@ (loadProc "MAPISendMail" dll mkMapiSendMail) where loadProc :: String -> HMODULE -> (FunPtr a -> a) -> IO a - loadProc name dll conv = withCAString name $ \name' -> do + loadProc name dll' conv = withCAString name $ \name' -> do proc <- failIfNull ("loadMapiDll: " ++ dllname ++ ": " ++ name) - $ c_GetProcAddress dll name' + $ c_GetProcAddress dll' name' return $ conv $ castPtrToFunPtr proc -- | loadMapiDll :: String -> IO (MapiFuncs, HMODULE) @@ -213,12 +213,12 @@ -> MapiFlag -- ^ None, one or many flags: FORCE_DOWNLOAD, NEW_SESSION, LOGON_UI, PASSWORD_UI -> IO LHANDLE mapiLogon f hwnd ses pw flags = - maybeWith withCAString ses $ \ses -> - maybeWith withCAString pw $ \pw -> - alloca $ \out -> do + maybeWith withCAString ses $ \c_ses -> + maybeWith withCAString pw $ \c_pw -> + alloca $ \out -> do mapiFail_ "MAPILogon: " $ mapifLogon f (maybeHWND hwnd) - ses pw flags 0 out + c_ses c_pw flags 0 out peek out -- | End Simple MAPI-session @@ -265,12 +265,12 @@ act buf resolve err rc = case rc of Recip name addr -> - withCAString name $ \name -> - withCAString addr $ \addr -> + withCAString name $ \c_name -> + withCAString addr $ \c_addr -> allocaBytes (#size MapiRecipDesc) $ \buf -> do (#poke MapiRecipDesc, ulReserved) buf (0::ULONG) - (#poke MapiRecipDesc, lpszName) buf name - (#poke MapiRecipDesc, lpszAddress) buf addr + (#poke MapiRecipDesc, lpszName) buf c_name + (#poke MapiRecipDesc, lpszAddress) buf c_addr (#poke MapiRecipDesc, ulEIDSize) buf (0::ULONG) (#poke MapiRecipDesc, lpEntryID) buf nullPtr a buf @@ -351,18 +351,18 @@ where as = (#size MapiFileDesc) len = length att - write act _ [] = act - write act buf (att:y) = - withCAString (attPath att) $ \path -> - maybeWith withFileTag (attTag att) $ \tag -> - withCAString (maybe (attPath att) id (attName att)) $ \name -> do + write act' _ [] = act' + write act' buf (att':y) = + withCAString (attPath att') $ \path -> + maybeWith withFileTag (attTag att') $ \tag -> + withCAString (maybe (attPath att') id (attName att')) $ \name -> do (#poke MapiFileDesc, ulReserved) buf (0::ULONG) - (#poke MapiFileDesc, flFlags) buf (attFlag att) - (#poke MapiFileDesc, nPosition) buf (maybe 0xffffffff id $ attPosition att) + (#poke MapiFileDesc, flFlags) buf (attFlag att') + (#poke MapiFileDesc, nPosition) buf (maybe 0xffffffff id $ attPosition att') (#poke MapiFileDesc, lpszPathName) buf path (#poke MapiFileDesc, lpszFileName) buf name (#poke MapiFileDesc, lpFileType) buf tag - write act (plusPtr buf as) y + write act' (plusPtr buf as) y data Message = Message { msgSubject :: String @@ -410,8 +410,8 @@ act buf mapiSendMail :: MapiFuncs -> LHANDLE -> Maybe HWND -> Message -> MapiFlag -> IO () -mapiSendMail f ses hwnd msg flag = withMessage f ses msg $ \msg -> - mapiFail_ "MAPISendMail" $ mapifSendMail f ses (maybeHWND hwnd) msg flag 0 +mapiSendMail f ses hwnd msg flag = withMessage f ses msg $ \c_msg -> + mapiFail_ "MAPISendMail" $ mapifSendMail f ses (maybeHWND hwnd) c_msg flag 0 handleIOException :: (IOException -> IO a) -> IO a -> IO a handleIOException = handle diff --git a/System/Win32/String.hs b/System/Win32/String.hs new file mode 100644 --- /dev/null +++ b/System/Win32/String.hs @@ -0,0 +1,51 @@ +{- | + Module : System.Win32.String + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Utilities for primitive marshalling of Windows' C strings. +-} +module System.Win32.String + ( LPSTR, LPCSTR, LPWSTR, LPCWSTR + , TCHAR, LPTSTR, LPCTSTR, LPCTSTR_ + , withTString, withTStringLen, peekTString, peekTStringLen + , newTString + , withTStringBuffer, withTStringBufferLen + ) where +import System.Win32.Types + +-- | Marshal a dummy Haskell string into a NUL terminated C wide string +-- using temporary storage. +-- +-- * the Haskell string is created by length parameter. And the Haskell +-- string contains /only/ NUL characters. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withTStringBuffer :: Int -> (LPTSTR -> IO a) -> IO a +withTStringBuffer maxLength + = let dummyBuffer = replicate maxLength '\0' + in withTString dummyBuffer + +-- | Marshal a dummy Haskell string into a C wide string (i.e. wide +-- character array) in temporary storage, with explicit length +-- information. +-- +-- * the Haskell string is created by length parameter. And the Haskell +-- string contains /only/ NUL characters. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withTStringBufferLen :: Int -> ((LPTSTR, Int) -> IO a) -> IO a +withTStringBufferLen maxLength + = let dummyBuffer = replicate maxLength '\0' + in withTStringLen dummyBuffer + diff --git a/System/Win32/SymbolicLink.hsc b/System/Win32/SymbolicLink.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/SymbolicLink.hsc @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.SymbolicLink + Copyright : 2012 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Handling symbolic link using Win32 API. [Vista of later and desktop app only] + + Note: You should worry about UAC (User Account Control) when use this module's function in your application: + + * require to use 'Run As Administrator' to run your application. + + * or modify your application's manifect file to add + \. +-} +module System.Win32.SymbolicLink + ( module System.Win32.SymbolicLink + ) where + +import System.Win32.Types +import System.Win32.File ( failIfFalseWithRetry_ ) + +##include "windows_cconv.h" + +type SymbolicLinkFlags = DWORD + +#{enum SymbolicLinkFlags, + , sYMBOLIC_LINK_FLAG_FILE = 0x0 + , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 +} + +-- | createSymbolicLink* functions don't check that file is exist or not. +-- +-- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatiblity for Unix, +-- except 'createSymbolicLink''. +-- +-- If you want to create symbolic link by Windows way, use 'createSymbolicLink'' instead. +createSymbolicLink :: FilePath -- ^ Target file path + -> FilePath -- ^ Symbolic link name + -> SymbolicLinkFlags -> IO () +createSymbolicLink = flip createSymbolicLink' + +createSymbolicLinkFile :: FilePath -> FilePath -> IO () +createSymbolicLinkFile target link = createSymbolicLink' link target sYMBOLIC_LINK_FLAG_FILE + +createSymbolicLinkDirectory :: FilePath -> FilePath -> IO () +createSymbolicLinkDirectory target link = createSymbolicLink' link target sYMBOLIC_LINK_FLAG_DIRECTORY + +createSymbolicLink' :: FilePath -- ^ Symbolic link name + -> FilePath -- ^ Target file path + -> SymbolicLinkFlags -> IO () +createSymbolicLink' link target flag = do + withTString link $ \c_link -> + withTString target $ \c_target -> + failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $ + c_CreateSymbolicLink c_link c_target flag + +foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW" + c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL diff --git a/System/Win32/Thread.hs b/System/Win32/Thread.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Thread.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{- | + Module : System.Win32.Thread + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + This modules provides just thread control APIs. + This modules doesn't provide thread register control APIs. Because these APIs are used for Debugging. +-} +module System.Win32.Thread + ( THANDLE, TID + , getCurrentThread + , suspendThread + , c_SuspendThread + , resumeThread + , c_ResumeThread + , withSuspendedThread + , getThreadId + , c_GetThreadId + , getCurrentThreadId + , c_GetCurrentThreadId + ) where + +import System.Win32.DebugApi +import System.Win32.Types ( failIfZero ) + +#include "windows_cconv.h" + +getThreadId :: THANDLE -> IO TID +getThreadId = failIfZero "GetThreadId" . c_GetThreadId + +getCurrentThreadId :: IO TID +getCurrentThreadId = failIfZero "GetThreadId" c_GetCurrentThreadId + +foreign import WINDOWS_CCONV "windows.h GetCurrentThread" + getCurrentThread :: IO THANDLE + +foreign import WINDOWS_CCONV "windows.h GetThreadId" + c_GetThreadId :: THANDLE -> IO TID + +foreign import WINDOWS_CCONV "windows.h GetCurrentThreadId" + c_GetCurrentThreadId :: IO TID diff --git a/System/Win32/Time.hsc b/System/Win32/Time.hsc --- a/System/Win32/Time.hsc +++ b/System/Win32/Time.hsc @@ -32,8 +32,8 @@ , peekCWString, withCWStringLen, withCWString ) ##include "windows_cconv.h" - -#include "windows.h" +#include +#include "alignment.h" ---------------------------------------------------------------- -- data types @@ -64,7 +64,7 @@ instance Storable FILETIME where sizeOf = const (#size FILETIME) - alignment = sizeOf + alignment _ = #alignment FILETIME poke buf (FILETIME n) = do (#poke FILETIME, dwLowDateTime) buf low (#poke FILETIME, dwHighDateTime) buf hi @@ -76,7 +76,7 @@ instance Storable SYSTEMTIME where sizeOf _ = #size SYSTEMTIME - alignment = sizeOf + alignment _ = #alignment SYSTEMTIME poke buf st = do (#poke SYSTEMTIME, wYear) buf (wYear st) (#poke SYSTEMTIME, wMonth) buf (wMonth st) @@ -92,14 +92,14 @@ dow <- (#peek SYSTEMTIME, wDayOfWeek) buf day <- (#peek SYSTEMTIME, wDay) buf hour <- (#peek SYSTEMTIME, wHour) buf - min <- (#peek SYSTEMTIME, wMinute) buf + mins <- (#peek SYSTEMTIME, wMinute) buf sec <- (#peek SYSTEMTIME, wSecond) buf ms <- (#peek SYSTEMTIME, wMilliseconds) buf - return $ SYSTEMTIME year month dow day hour min sec ms + return $ SYSTEMTIME year month dow day hour mins sec ms instance Storable TIME_ZONE_INFORMATION where sizeOf _ = (#size TIME_ZONE_INFORMATION) - alignment = sizeOf + alignment _ = #alignment TIME_ZONE_INFORMATION poke buf tzi = do (#poke TIME_ZONE_INFORMATION, Bias) buf (tziBias tzi) (#poke TIME_ZONE_INFORMATION, StandardDate) buf (tziStandardDate tzi) @@ -109,12 +109,14 @@ write buf (#offset TIME_ZONE_INFORMATION, StandardName) (tziStandardName tzi) write buf (#offset TIME_ZONE_INFORMATION, DaylightName) (tziDaylightName tzi) where - write buf offset str = withCWStringLen str $ \(str,len) -> do + write buf_ offset str = withCWStringLen str $ \(c_str,len) -> do when (len>31) $ fail "Storable TIME_ZONE_INFORMATION.poke: Too long string." - let start = (advancePtr (castPtr buf) offset) - end = advancePtr start len - copyArray (castPtr str :: Ptr Word8) start len - poke end 0 + let len' = len * sizeOf (undefined :: CWchar) + start = (advancePtr (castPtr buf_) offset) + end = advancePtr start len' + copyArray start (castPtr c_str :: Ptr Word8) len' + poke (castPtr end) (0 :: CWchar) + peek buf = do bias <- (#peek TIME_ZONE_INFORMATION, Bias) buf sdat <- (#peek TIME_ZONE_INFORMATION, StandardDate) buf @@ -135,8 +137,8 @@ foreign import WINDOWS_CCONV "windows.h SetSystemTime" c_SetSystemTime :: Ptr SYSTEMTIME -> IO BOOL setSystemTime :: SYSTEMTIME -> IO () -setSystemTime st = with st $ \st -> failIf_ not "setSystemTime: SetSystemTime" $ - c_SetSystemTime st +setSystemTime st = with st $ \c_st -> failIf_ not "setSystemTime: SetSystemTime" $ + c_SetSystemTime c_st foreign import WINDOWS_CCONV "windows.h GetSystemTimeAsFileTime" c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO () @@ -155,8 +157,8 @@ foreign import WINDOWS_CCONV "windows.h SetLocalTime" c_SetLocalTime :: Ptr SYSTEMTIME -> IO BOOL setLocalTime :: SYSTEMTIME -> IO () -setLocalTime st = with st $ \st -> failIf_ not "setLocalTime: SetLocalTime" $ - c_SetLocalTime st +setLocalTime st = with st $ \c_st -> failIf_ not "setLocalTime: SetLocalTime" $ + c_SetLocalTime c_st foreign import WINDOWS_CCONV "windows.h GetSystemTimeAdjustment" c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL @@ -164,12 +166,12 @@ getSystemTimeAdjustment = alloca $ \ta -> alloca $ \ti -> alloca $ \enabled -> do failIf_ not "getSystemTimeAdjustment: GetSystemTimeAdjustment" $ c_GetSystemTimeAdjustment ta ti enabled - enabled <- peek enabled - if enabled + enabled' <- peek enabled + if enabled' then do - ta <- peek ta - ti <- peek ti - return $ Just (fromIntegral ta, fromIntegral ti) + ta' <- peek ta + ti' <- peek ti + return $ Just (fromIntegral ta', fromIntegral ti') else return Nothing foreign import WINDOWS_CCONV "windows.h GetTickCount" getTickCount :: IO DWORD @@ -191,8 +193,8 @@ getTimeZoneInformation = alloca $ \tzi -> do tz <- failIf (==(#const TIME_ZONE_ID_INVALID)) "getTimeZoneInformation: GetTimeZoneInformation" $ c_GetTimeZoneInformation tzi - tzi <- peek tzi - return . flip (,) tzi $ case tz of + tzi' <- peek tzi + return . flip (,) tzi' $ case tz of (#const TIME_ZONE_ID_UNKNOWN) -> TzIdUnknown (#const TIME_ZONE_ID_STANDARD) -> TzIdStandard (#const TIME_ZONE_ID_DAYLIGHT) -> TzIdDaylight @@ -201,17 +203,17 @@ foreign import WINDOWS_CCONV "windows.h SystemTimeToFileTime" c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL systemTimeToFileTime :: SYSTEMTIME -> IO FILETIME -systemTimeToFileTime s = with s $ \s -> alloca $ \ret -> do +systemTimeToFileTime s = with s $ \c_s -> alloca $ \ret -> do failIf_ not "systemTimeToFileTime: SystemTimeToFileTime" $ - c_SystemTimeToFileTime s ret + c_SystemTimeToFileTime c_s ret peek ret foreign import WINDOWS_CCONV "windows.h FileTimeToSystemTime" c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL fileTimeToSystemTime :: FILETIME -> IO SYSTEMTIME -fileTimeToSystemTime s = with s $ \s -> alloca $ \ret -> do +fileTimeToSystemTime s = with s $ \c_s -> alloca $ \ret -> do failIf_ not "fileTimeToSystemTime: FileTimeToSystemTime" $ - c_FileTimeToSystemTime s ret + c_FileTimeToSystemTime c_s ret peek ret foreign import WINDOWS_CCONV "windows.h GetFileTime" @@ -224,23 +226,26 @@ foreign import WINDOWS_CCONV "windows.h SetFileTime" c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL setFileTime :: HANDLE -> FILETIME -> FILETIME -> FILETIME -> IO () -setFileTime h crt acc wrt = with crt $ \crt -> with acc $ \acc -> with wrt $ \wrt -> do - failIf_ not "setFileTime: SetFileTime" $ c_SetFileTime h crt acc wrt +setFileTime h crt acc wrt = with crt $ + \c_crt -> with acc $ + \c_acc -> with wrt $ + \c_wrt -> do + failIf_ not "setFileTime: SetFileTime" $ c_SetFileTime h c_crt c_acc c_wrt foreign import WINDOWS_CCONV "windows.h FileTimeToLocalFileTime" c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL fileTimeToLocalFileTime :: FILETIME -> IO FILETIME -fileTimeToLocalFileTime ft = with ft $ \ft -> alloca $ \res -> do +fileTimeToLocalFileTime ft = with ft $ \c_ft -> alloca $ \res -> do failIf_ not "fileTimeToLocalFileTime: FileTimeToLocalFileTime" - $ c_FileTimeToLocalFileTime ft res + $ c_FileTimeToLocalFileTime c_ft res peek res foreign import WINDOWS_CCONV "windows.h LocalFileTimeToFileTime" c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL localFileTimeToFileTime :: FILETIME -> IO FILETIME -localFileTimeToFileTime ft = with ft $ \ft -> alloca $ \res -> do +localFileTimeToFileTime ft = with ft $ \c_ft -> alloca $ \res -> do failIf_ not "localFileTimeToFileTime: LocalFileTimeToFileTime" - $ c_LocalFileTimeToFileTime ft res + $ c_LocalFileTimeToFileTime c_ft res peek res {- @@ -302,10 +307,10 @@ c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt getTimeFormat :: LCID -> GetTimeFormatFlags -> SYSTEMTIME -> String -> IO String getTimeFormat locale flags st fmt = - with st $ \st -> - withCWString fmt $ \fmt -> do - size <- c_GetTimeFormat locale flags st fmt nullPtr 0 + with st $ \c_st -> + withCWString fmt $ \c_fmt -> do + size <- c_GetTimeFormat locale flags c_st c_fmt nullPtr 0 allocaBytes ((fromIntegral size) * (sizeOf (undefined::CWchar))) $ \out -> do - size <- failIf (==0) "getTimeFormat: GetTimeFormat" $ - c_GetTimeFormat locale flags st fmt (castPtr out) size - peekTStringLen (out,fromIntegral size) + size' <- failIf (==0) "getTimeFormat: GetTimeFormat" $ + c_GetTimeFormat locale flags c_st c_fmt (castPtr out) size + peekTStringLen (out,fromIntegral size') diff --git a/System/Win32/Types.hs b/System/Win32/Types.hs deleted file mode 100644 --- a/System/Win32/Types.hs +++ /dev/null @@ -1,345 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : System.Win32.Types --- Copyright : (c) Alastair Reid, 1997-2003 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : Esa Ilari Vuokko --- 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.Exception (throwIO) -import Data.Bits (shiftL, shiftR, (.|.), (.&.)) -import Data.Char (isSpace) -import Data.Int (Int32, Int64) -import Data.Maybe (fromMaybe) -import Data.Word (Word8, Word16, Word32, Word64) -import Foreign.C.Error (getErrno, errnoToIOError) -import Foreign.C.String (newCWString, withCWStringLen) -import Foreign.C.String (peekCWString, peekCWStringLen, withCWString) -import Foreign.C.Types (CChar, CUChar, CWchar, CIntPtr, CUIntPtr) -import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_) -import Foreign.Ptr (FunPtr, Ptr, nullPtr) -import Foreign (allocaArray) -import Numeric (showHex) -import System.IO.Error (ioeSetErrorString) -import System.IO.Unsafe (unsafePerformIO) - -#if !MIN_VERSION_base(4,8,0) -import Data.Word (Word) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Bits (finiteBitSize) -#else -import Data.Bits (Bits, bitSize) - -finiteBitSize :: (Bits a) => a -> Int -finiteBitSize = bitSize -#endif - -#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 UINT_PTR = Word -type LONG_PTR = CIntPtr -type ULONG_PTR = CUIntPtr - --- 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 - -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 (-1) - ----------------------------------------------------------------- --- 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 () - -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 - -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 - c_maperrno -- turn GetLastError() into errno, which errnoToIOError knows - -- how to convert to an IOException we can throw. - -- XXX we should really do this directly. - errno <- getErrno - 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" -- in base/cbits/Win32Utils.c - c_maperrno :: IO () - ----------------------------------------------------------------- --- 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 - -{-# 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 ----------------------------------------------------------------- diff --git a/System/Win32/Types.hsc b/System/Win32/Types.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Types.hsc @@ -0,0 +1,382 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +{-# 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 +-- 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.Exception (throwIO) +import Data.Bits (shiftL, shiftR, (.|.), (.&.)) +import Data.Char (isSpace) +import Data.Int (Int32, Int64, Int16) +import Data.Maybe (fromMaybe) +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) +import Foreign (allocaArray) +import Numeric (showHex) +import System.IO.Error (ioeSetErrorString) +import System.IO.Unsafe (unsafePerformIO) + +#if !MIN_VERSION_base(4,8,0) +import Data.Word (Word) +#endif + +#if MIN_VERSION_base(4,7,0) +import Data.Bits (finiteBitSize) +#else +import Data.Bits (Bits, bitSize) + +finiteBitSize :: (Bits a) => a -> Int +finiteBitSize = bitSize +#endif + +#include +##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 DWORD_PTR = Ptr DWORD32 +type INT_PTR = Ptr CInt +type ULONG = Word32 +type UINT_PTR = Word +type LONG_PTR = CIntPtr +type ULONG_PTR = CUIntPtr +#ifdef _WIN64 +type HALF_PTR = Ptr INT32 +#else +type HALF_PTR = Ptr SHORT +#endif + +-- 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 + +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 (-1) + +---------------------------------------------------------------- +-- 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 = #const ERROR_INSUFFICIENT_BUFFER + +eRROR_MOD_NOT_FOUND :: ErrCode +eRROR_MOD_NOT_FOUND = #const ERROR_MOD_NOT_FOUND + +eRROR_PROC_NOT_FOUND :: ErrCode +eRROR_PROC_NOT_FOUND = #const ERROR_PROC_NOT_FOUND + + +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 +---------------------------------------------------------------- diff --git a/System/Win32/Utils.hs b/System/Win32/Utils.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Utils.hs @@ -0,0 +1,76 @@ +{- | + Module : System.Win32.Utils + Copyright : 2009 Balazs Komuves, 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Utilities for calling Win32 API +-} +module System.Win32.Utils + ( try, tryWithoutNull, try' + -- * Maybe values + , maybePtr, ptrToMaybe, maybeNum, numToMaybe + , peekMaybe, withMaybe + ) where +import Control.Monad ( unless ) +import Foreign.Marshal.Array ( allocaArray, peekArray ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.Storable ( Storable(..) ) +import System.Win32.Types ( failIfZero + , failWith, getLastError, eRROR_INSUFFICIENT_BUFFER ) +import qualified System.Win32.Types ( try ) +import System.Win32.String ( LPTSTR, peekTString ) +import System.Win32.Types ( BOOL, UINT, maybePtr, ptrToMaybe, maybeNum, numToMaybe ) +import System.Win32.Word ( DWORD, PDWORD ) + + +-- | 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 extend the buffer size and try again. +try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String +try = System.Win32.Types.try +{-# INLINE try #-} + +tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String +tryWithoutNull 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 <- peekTString lptstr + return (Right str) + case e of + Left r' -> tryWithoutNull loc f r' + Right str -> return str + +try' :: Storable a => String -> (Ptr a -> PDWORD -> IO BOOL) -> DWORD -> IO [a] +try' loc f n = + with n $ \n' -> do + e <- allocaArray (fromIntegral n) $ \lptstr -> do + flg <- f lptstr n' + unless flg $ do + err_code <- getLastError + unless (err_code == eRROR_INSUFFICIENT_BUFFER) + $ failWith loc err_code + r <- peek n' + if (r > n) then return (Left r) else do + str <- peekArray (fromIntegral r) lptstr + return (Right str) + case e of + Left r' -> try' loc f r' + Right str -> return str + +-- | See also: 'Foreign.Marshal.Utils.maybePeek' function. +peekMaybe :: Storable a => Ptr a -> IO (Maybe a) +peekMaybe p = + if p == nullPtr + then return Nothing + else Just `fmap` peek p + +-- | See also: 'Foreign.Marshal.Utils.maybeWith' function. +withMaybe :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b +withMaybe Nothing action = action nullPtr +withMaybe (Just x) action = with x action diff --git a/System/Win32/Word.hs b/System/Win32/Word.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Word.hs @@ -0,0 +1,23 @@ +{- | + Module : System.Win32.Word + Copyright : 2013 shelarcy + License : BSD-style + + Maintainer : shelarcy@gmail.com + Stability : Provisional + Portability : Non-portable (Win32 API) + + Windows' unsigned integer types and pointer type. +-} +module System.Win32.Word + ( WORD, DWORD, PDWORD, LPDWORD + , DWORDLONG, DDWORD + , DWORD32, DWORD64, DWORD_PTR + ) where +import Data.Word ( Word64 ) +import Foreign.Ptr ( Ptr ) +import System.Win32.Types ( WORD, DWORD, LPDWORD, DDWORD, + DWORD32, DWORD64, DWORD_PTR ) + +type PDWORD = Ptr DWORD +type DWORDLONG = Word64 diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -1,9 +1,9 @@ name: Win32 -version: 2.4.0.0 +version: 2.5.0.0 license: BSD3 license-file: LICENSE -author: Alastair Reid -copyright: Alastair Reid, 1999-2003 +author: Alastair Reid, shelarcy +copyright: Alastair Reid, 1999-2003; shelarcy, 2012-2013 maintainer: Haskell Libraries bug-reports: https://github.com/haskell/win32/issues homepage: https://github.com/haskell/win32 @@ -14,10 +14,11 @@ cabal-version: >=1.6 extra-source-files: include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h - include/Win32Aux.h include/win32debug.h + include/Win32Aux.h include/win32debug.h include/alignment.h + changelog.md Library - build-depends: base >= 4.5 && < 5, bytestring + build-depends: base >= 4.5 && < 5, bytestring, filepath ghc-options: -Wall -fno-warn-name-shadowing cc-options: -fno-strict-aliasing exposed-modules: @@ -43,6 +44,16 @@ Graphics.Win32.Misc Graphics.Win32.Resource Graphics.Win32.Window + Graphics.Win32.LayeredWindow + Graphics.Win32.GDI.AlphaBlend + Graphics.Win32.Window.AnimateWindow + Graphics.Win32.Window.HotKey + Graphics.Win32.Window.IMM + Graphics.Win32.Window.ForegroundWindow + Graphics.Win32.Window.PostMessage + + Media.Win32 + System.Win32 System.Win32.DebugApi System.Win32.DLL @@ -51,6 +62,7 @@ System.Win32.Info System.Win32.Path System.Win32.Mem + System.Win32.MinTTY System.Win32.NLS System.Win32.Process System.Win32.Registry @@ -60,14 +72,33 @@ System.Win32.Security System.Win32.Types System.Win32.Shell - extensions: ForeignFunctionInterface, CPP + System.Win32.Automation + System.Win32.Automation.Input + System.Win32.Automation.Input.Key + System.Win32.Automation.Input.Mouse + System.Win32.Console.CtrlHandler + System.Win32.Console.HWND + System.Win32.Console.Title + System.Win32.Encoding + System.Win32.Exception.Unsupported + System.Win32.HardLink + System.Win32.Info.Computer + System.Win32.Info.Version + System.Win32.String + System.Win32.SymbolicLink + System.Win32.Thread + System.Win32.Utils + System.Win32.Word + + extensions: ForeignFunctionInterface, CPP if impl(ghc >= 7.1) extensions: NondecreasingIndentation extra-libraries: - "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder", "shlwapi" - include-dirs: include - includes: "HsWin32.h", "HsGDI.h", "WndProc.h" - install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h", "windows_cconv.h" + "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder", "shlwapi", "msimg32", "imm32", "ntdll" + ghc-options: -Wall + include-dirs: include + includes: "alphablend.h", "diatemp.h", "dumpBMP.h", "ellipse.h", "errors.h", "HsGDI.h", "HsWin32.h", "Win32Aux.h", "win32debug.h", "windows_cconv.h", "WndProc.h", "alignment.h" + install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h", "windows_cconv.h", "alphablend.h", "winternl_compat.h", "winuser_compat.h" c-sources: cbits/HsGDI.c cbits/HsWin32.c @@ -76,6 +107,8 @@ cbits/dumpBMP.c cbits/ellipse.c cbits/errors.c + cbits/alphablend.c + cc-options: -Wall source-repository head type: git diff --git a/cbits/alphablend.c b/cbits/alphablend.c new file mode 100644 --- /dev/null +++ b/cbits/alphablend.c @@ -0,0 +1,15 @@ +#include + +BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest + , HDC hdcSrc, int nXOriginSrc, int nYOriginSrc, int nWidthSrc, int nHeightSrc + , PBLENDFUNCTION pblendFunction) +{ + BLENDFUNCTION blendFunction; + blendFunction.BlendOp = pblendFunction->BlendOp; + blendFunction.BlendFlags = pblendFunction->BlendFlags; + blendFunction.SourceConstantAlpha = pblendFunction->SourceConstantAlpha; + blendFunction.AlphaFormat = pblendFunction->AlphaFormat; + return AlphaBlend ( hdcDest, nXOriginDest, nYOriginDest, nWidthDest, hHeightDest + , hdcSrc, nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc + , blendFunction); +} diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,37 @@ +# Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) + +## 2.5.0.0 *Jan 2017* + +* `failWith` (and the API calls that use it) now throw `IOError`s with proper + `IOErrorType`s. +* Add function `findWindowByName` +* Fix a bug in the implementation of `poke` for `TIME_ZONE_INFORMATION` which + would cause it to be marshalled incorrectly. +* Add `System.Win32.MinTTY` module for detecting the presence of MinTTY. +* Add `ULONG` type to `System.Win32.Types`. +* Add function `failIfNeg` to `System.Win32.Types`, which fails if a negative + number is returned. This simulates the behavior of the `NT_SUCCESS` macro. +* Merged package Win32-extras (See #16) +* `Graphics.Win32.Misc.messageBox` safely imported now https://github.com/haskell/win32/pull/5 +* Fixed various alignment calls that were incorrect. These would result in an incorrect alignment + being returned on certain platforms. (See #66) + +## 2.4.0.0 *Nov 2016* + +* Add `windows_cconv.h` to the `install-includes` field of `Win32.cabal`, + allowing packages that transitively depend on `Win32` to use the + `WINDOWS_CCONV` CPP macro (which expands to `stdcall` or `ccall` + appropriately depending on the system architecture) +* Added function `getLongPathName` +* Added function `getShortPathName` +* Added function `getUserName` +* Added file attribute `fILE_ATTRIBUTE_REPARSE_POINT` +* Added more [`File Access Rights` constants](https://msdn.microsoft.com/en-us/library/windows/desktop/gg258116%28v=vs.85%29.aspx) +* Added function `getCurrentProcessId` +* Added function `filepathRelativePathTo` +* Added function `pathRelativePathTo` +* Corrected 64 bit types (See #53) + +## 2.3.1.1 *May 2016* + +* Release for GHC 8.0.1 diff --git a/include/alignment.h b/include/alignment.h new file mode 100644 --- /dev/null +++ b/include/alignment.h @@ -0,0 +1,3 @@ +#if __GLASGOW_HASKELL__ < 711 +#define hsc_alignment(t ) hsc_printf ( "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__)); +#endif diff --git a/include/alphablend.h b/include/alphablend.h new file mode 100644 --- /dev/null +++ b/include/alphablend.h @@ -0,0 +1,10 @@ +#ifndef _ALPHABLEND_H +#define _ALPHABLEND_H +#define WINVER 0x0500 +#include + +BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest + , HDC hdcSrc, int nXOriginSrc, int nYOriginSrc, int nWidthSrc, int nHeightSrc + , PBLENDFUNCTION pblendFunction); + +#endif /* _ALPHABLEND_H */ diff --git a/include/winternl_compat.h b/include/winternl_compat.h new file mode 100644 --- /dev/null +++ b/include/winternl_compat.h @@ -0,0 +1,39 @@ +#ifndef WINTERNL_COMPAT_H +#define WINTERNL_COMPAT_H + +/* + * winternl.h is not included in MinGW, which was shipped with the 32-bit + * Windows version of GHC prior to the 7.10.3 release. + */ +#if defined(x86_64_HOST_ARCH) || \ + __GLASGOW_HASKELL__ >= 711 || \ + (__GLASGOW_HASKELL__ == 710 && \ + defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \ + __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2) +# include +#else +// Some declarations from winternl.h that we need in Win32 +# include + +typedef enum _OBJECT_INFORMATION_CLASS { + ObjectBasicInformation, + ObjectNameInformation, + ObjectTypeInformation, + ObjectAllInformation, + ObjectDataInformation +} OBJECT_INFORMATION_CLASS, *POBJECT_INFORMATION_CLASS; + +typedef LONG NTSTATUS, *PNTSTATUS; + +typedef struct _UNICODE_STRING { + USHORT Length; + USHORT MaximumLength; + PWSTR Buffer; +} UNICODE_STRING, *PUNICODE_STRING; + +typedef struct _OBJECT_NAME_INFORMATION { + UNICODE_STRING Name; +} OBJECT_NAME_INFORMATION, *POBJECT_NAME_INFORMATION; +#endif + +#endif /* WINTERNL_COMPAT_H */ diff --git a/include/winuser_compat.h b/include/winuser_compat.h new file mode 100644 --- /dev/null +++ b/include/winuser_compat.h @@ -0,0 +1,113 @@ +#ifndef WINUSER_COMPAT_H +#define WINUSER_COMPAT_H + +/* + * winuser.h is missing some includes in MinGW, which was shipped with the 32-bit + * Windows version of GHC prior to the 7.10.3 release. + */ +#if defined(x86_64_HOST_ARCH) || \ + __GLASGOW_HASKELL__ >= 711 || \ + (__GLASGOW_HASKELL__ == 710 && \ + defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \ + __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2) +#else +// Some declarations from winuser.h that we need in Win32 +# include + +#define VK_XBUTTON1 0x05 +#define VK_XBUTTON2 0x06 + +#define VK_BROWSER_BACK 0xA6 +#define VK_BROWSER_FORWARD 0xA7 +#define VK_BROWSER_REFRESH 0xA8 +#define VK_BROWSER_STOP 0xA9 +#define VK_BROWSER_SEARCH 0xAA +#define VK_BROWSER_FAVORITES 0xAB +#define VK_BROWSER_HOME 0xAC +#define VK_VOLUME_MUTE 0xAD +#define VK_VOLUME_DOWN 0xAE +#define VK_VOLUME_UP 0xAF +#define VK_MEDIA_NEXT_TRACK 0xB0 +#define VK_MEDIA_PREV_TRACK 0xB1 +#define VK_MEDIA_STOP 0xB2 +#define VK_MEDIA_PLAY_PAUSE 0xB3 +#define VK_LAUNCH_MAIL 0xB4 +#define VK_LAUNCH_MEDIA_SELECT 0xB5 +#define VK_LAUNCH_APP1 0xB6 +#define VK_LAUNCH_APP2 0xB7 + +#define VK_OEM_PLUS 0xBB +#define VK_OEM_COMMA 0xBC +#define VK_OEM_MINUS 0xBD +#define VK_OEM_PERIOD 0xBE +#define VK_OEM_102 0xE2 + +#define VK_PACKET 0xE7 + +#define LWA_COLORKEY 0x00000001 +#define LWA_ALPHA 0x00000002 + +#define ULW_COLORKEY 0x00000001 +#define ULW_ALPHA 0x00000002 +#define ULW_OPAQUE 0x00000004 +#define ULW_EX_NORESIZE 0x00000008 + +#define AW_HOR_POSITIVE 0x00000001 +#define AW_HOR_NEGATIVE 0x00000002 +#define AW_VER_POSITIVE 0x00000004 +#define AW_VER_NEGATIVE 0x00000008 +#define AW_CENTER 0x00000010 +#define AW_HIDE 0x00010000 +#define AW_ACTIVATE 0x00020000 +#define AW_SLIDE 0x00040000 +#define AW_BLEND 0x00080000 + +#define INPUT_MOUSE 0 +#define INPUT_KEYBOARD 1 +#define INPUT_HARDWARE 2 + +#define KEYEVENTF_UNICODE 0x0004 +#define KEYEVENTF_SCANCODE 0x0008 + +#define MOUSEEVENTF_XDOWN 0x0080 +#define MOUSEEVENTF_XUP 0x0100 + +#define XBUTTON1 0x0001 +#define XBUTTON2 0x0002 + +#if __GLASGOW_HASKELL__ < 710 +typedef struct tagMOUSEINPUT { + LONG dx; + LONG dy; + DWORD mouseData; + DWORD dwFlags; + DWORD time; + ULONG_PTR dwExtraInfo; +} MOUSEINPUT, *PMOUSEINPUT, *LPMOUSEINPUT; + +typedef struct tagKEYBDINPUT { + WORD wVk; + WORD wScan; + DWORD dwFlags; + DWORD time; + ULONG_PTR dwExtraInfo; +} KEYBDINPUT, *PKEYBDINPUT, *LPKEYBDINPUT; + +typedef struct tagHARDWAREINPUT { + DWORD uMsg; + WORD wParamL; + WORD wParamH; +} HARDWAREINPUT, *PHARDWAREINPUT, *LPHARDWAREINPUT; + +typedef struct tagINPUT { + DWORD type; + union { + MOUSEINPUT mi; + KEYBDINPUT ki; + HARDWAREINPUT hi; + } DUMMYUNIONNAME; +} INPUT, *PINPUT, *LPINPUT; +#endif + +#endif /* GHC Version check */ +#endif /* WINUSER_COMPAT_H */