Win32 2.4.0.0 → 2.5.0.0

raw patch · 53 files changed

+3105/−601 lines, 53 filesdep +filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: filepath

API changes (from Hackage documentation)

Files

• Graphics/Win32.hs +11/−1
• Graphics/Win32/GDI/AlphaBlend.hsc +74/−0
• Graphics/Win32/GDI/Clip.hsc +12/−0
• Graphics/Win32/Key.hsc +221/−73
• Graphics/Win32/LayeredWindow.hsc +62/−0
• Graphics/Win32/Misc.hsc +1/−1
• Graphics/Win32/Window.hsc +5/−0
• Graphics/Win32/Window/AnimateWindow.hsc +40/−0
• Graphics/Win32/Window/ForegroundWindow.hs +47/−0
• Graphics/Win32/Window/HotKey.hsc +65/−0
• Graphics/Win32/Window/IMM.hsc +110/−0
• Graphics/Win32/Window/PostMessage.hsc +48/−0
• LICENSE +1/−0
• Media/Win32.hs +48/−0
• System/Win32.hs +13/−0
• System/Win32/Automation.hs +15/−0
• System/Win32/Automation/Input.hsc +122/−0
• System/Win32/Automation/Input/Key.hsc +55/−0
• System/Win32/Automation/Input/Mouse.hsc +76/−0
• System/Win32/Console/CtrlHandler.hs +52/−0
• System/Win32/Console/HWND.hs +34/−0
• System/Win32/Console/Title.hsc +43/−0
• System/Win32/DLL.hsc +8/−0
• System/Win32/DebugApi.hsc +41/−41
• System/Win32/Encoding.hs +99/−0
• System/Win32/Exception/Unsupported.hs +70/−0
• System/Win32/File.hsc +3/−2
• System/Win32/FileMapping.hsc +4/−4
• System/Win32/HardLink.hs +96/−0
• System/Win32/Info.hsc +2/−40
• System/Win32/Info/Computer.hsc +237/−0
• System/Win32/Info/Version.hsc +164/−0
• System/Win32/Mem.hsc +2/−1
• System/Win32/MinTTY.hsc +229/−0
• System/Win32/NLS.hsc +2/−2
• System/Win32/Process.hsc +6/−0
• System/Win32/Registry.hsc +22/−22
• System/Win32/SimpleMAPI.hsc +20/−20
• System/Win32/String.hs +51/−0
• System/Win32/SymbolicLink.hsc +63/−0
• System/Win32/Thread.hs +46/−0
• System/Win32/Time.hsc +44/−39
• System/Win32/Types.hs +0/−345
• System/Win32/Types.hsc +382/−0
• System/Win32/Utils.hs +76/−0
• System/Win32/Word.hs +23/−0
• Win32.cabal +43/−10
• cbits/alphablend.c +15/−0
• changelog.md +37/−0
• include/alignment.h +3/−0
• include/alphablend.h +10/−0
• include/winternl_compat.h +39/−0
• include/winuser_compat.h +113/−0

@@ -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

@@ -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 <windows.h>
+#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'

@@ -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 <windows.h>  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 

@@ -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 <ei@vuokko.info>@@ -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 <windows.h>+#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+ }

@@ -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 <windows.h>
+##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
+ }

@@ -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  ----------------------------------------------------------------

@@ -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 

@@ -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 <windows.h>
+##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

@@ -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: <https://github.com/haskell/win32/pull/9>,
+-- <http://stackoverflow.com/questions/14297146/win32-setforegroundwindow-in-haskell>.
+----------------------------------------------------------------
+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

@@ -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 <windows.h>
+##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

@@ -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 <windows.h>
+##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

@@ -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 <windows.h>
+##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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 <windows.h>
+#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

@@ -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 <windows.h>
+#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
+ }

@@ -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 <windows.h>
+#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
+-}

@@ -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

@@ -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: <http://support.microsoft.com/kb/124103>
+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

@@ -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 <windows.h>
+##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
+

@@ -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

@@ -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

@@ -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 #-}

@@ -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
+

@@ -36,6 +36,7 @@ ##include "windows_cconv.h"  #include <windows.h>+#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)

@@ -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 = 

@@ -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
+-}

@@ -36,6 +36,7 @@ ##include "windows_cconv.h"  #include <windows.h>+#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

@@ -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 <windows.h>
+#include <Lmcons.h>
+#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: <https://github.com/haskell/win32/issues/8>, <http://lpaste.net/41521>
+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
+-}

@@ -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 <windows.h>
+#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
+-}

@@ -27,6 +27,7 @@ ##include "windows_cconv.h"  #include <windows.h>+#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)

@@ -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 <ei@vuokko.info>+-- 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 <windows.h>+#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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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
+

@@ -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
+       \<requestedExecutionLevel level='requireAdministrator' uiAccess='false'/\>.
+-}
+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

@@ -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

@@ -32,8 +32,8 @@                         , peekCWString, withCWStringLen, withCWString )  ##include "windows_cconv.h"--#include "windows.h"+#include <windows.h>+#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')

@@ -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 <ei@vuokko.info>--- Stability   :  provisional--- Portability :  portable------ A collection of FFI declarations for interfacing with Win32.-----------------------------------------------------------------------------------module System.Win32.Types-        ( module System.Win32.Types-        , nullPtr-        ) where--import Control.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-----------------------------------------------------------------

@@ -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 <ei@vuokko.info>+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.Types+        ( module System.Win32.Types+        , nullPtr+        ) where++import Control.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 <windows.h>+##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+----------------------------------------------------------------

@@ -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

@@ -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

@@ -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 <libraries@haskell.org> 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

@@ -0,0 +1,15 @@+#include <alphablend.h>++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);+}

@@ -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

@@ -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

@@ -0,0 +1,10 @@+#ifndef _ALPHABLEND_H+#define _ALPHABLEND_H+#define WINVER 0x0500+#include <windows.h>++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 */

@@ -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 <winternl.h>+#else+// Some declarations from winternl.h that we need in Win32+# include <windows.h>++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 */

@@ -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 <windows.h>++#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 */