Win32 2.2.2.0 → 2.14.2.2

raw patch · 114 files changed

Files

Graphics/Win32.hs +25/−13
Graphics/Win32/Control.hsc +14/−12
Graphics/Win32/Dialogue.hsc +55/−51
Graphics/Win32/GDI.hs +14/−16
Graphics/Win32/GDI/AlphaBlend.hsc +74/−0
Graphics/Win32/GDI/Bitmap.hsc +70/−66
Graphics/Win32/GDI/Brush.hsc +10/−6
Graphics/Win32/GDI/Clip.hsc +39/−19
Graphics/Win32/GDI/Font.hsc +30/−27
Graphics/Win32/GDI/Graphics2D.hs +31/−27
Graphics/Win32/GDI/HDC.hs +76/−46
Graphics/Win32/GDI/Palette.hsc +6/−3
Graphics/Win32/GDI/Path.hs +17/−13
Graphics/Win32/GDI/Pen.hsc +12/−8
Graphics/Win32/GDI/Region.hs +21/−17
Graphics/Win32/GDI/Types.hsc +40/−42
Graphics/Win32/Icon.hs +15/−4
Graphics/Win32/Key.hsc +233/−82
Graphics/Win32/LayeredWindow.hsc +57/−0
Graphics/Win32/Menu.hsc +47/−43
Graphics/Win32/Message.hsc +9/−2
Graphics/Win32/Misc.hsc +39/−36
Graphics/Win32/Resource.hsc +33/−29
Graphics/Win32/Window.hsc +221/−75
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
Setup.hs +0/−6
System/Win32.hs +32/−15
System/Win32/Automation.hs +15/−0
System/Win32/Automation/Input.hsc +130/−0
System/Win32/Automation/Input/Key.hsc +55/−0
System/Win32/Automation/Input/Mouse.hsc +76/−0
System/Win32/Console.hsc +219/−25
System/Win32/Console/CtrlHandler.hs +52/−0
System/Win32/Console/HWND.hs +34/−0
System/Win32/Console/Internal.hsc +336/−0
System/Win32/Console/Title.hsc +46/−0
System/Win32/DLL.hsc +26/−31
System/Win32/DLL/Internal.hsc +57/−0
System/Win32/DebugApi.hsc +180/−115
System/Win32/DebugApi/Internal.hsc +80/−0
System/Win32/Encoding.hs +99/−0
System/Win32/Event.hsc +163/−0
System/Win32/Exception/Unsupported.hs +70/−0
System/Win32/File.hsc +318/−338
System/Win32/File/Internal.hsc +548/−0
System/Win32/FileMapping.hsc +41/−55
System/Win32/FileMapping/Internal.hsc +72/−0
System/Win32/HardLink.hs +94/−0
System/Win32/HardLink/Internal.hs +31/−0
System/Win32/Info.hsc +150/−280
System/Win32/Info/Computer.hsc +237/−0
System/Win32/Info/Internal.hsc +313/−0
System/Win32/Info/Version.hsc +165/−0
System/Win32/Mem.hsc +175/−40
System/Win32/MinTTY.hsc +245/−0
System/Win32/NLS.hsc +516/−58
System/Win32/NamedPipes.hsc +276/−0
System/Win32/Path.hsc +56/−0
System/Win32/Path/Internal.hsc +29/−0
System/Win32/Process.hsc +126/−25
System/Win32/Registry.hsc +224/−114
System/Win32/Security.hsc +36/−36
System/Win32/Semaphore.hsc +146/−0
System/Win32/Shell.hsc +10/−10
System/Win32/Shell/Internal.hsc +50/−0
System/Win32/SimpleMAPI.hsc +63/−35
System/Win32/String.hs +51/−0
System/Win32/SymbolicLink.hsc +93/−0
System/Win32/SymbolicLink/Internal.hsc +26/−0
System/Win32/Thread.hs +42/−0
System/Win32/Time.hsc +121/−179
System/Win32/Time/Internal.hsc +245/−0
System/Win32/Types.hs +0/−307
System/Win32/Types.hsc +578/−0
System/Win32/Utils.hs +410/−0
System/Win32/WindowsString/Console.hsc +180/−0
System/Win32/WindowsString/DLL.hsc +67/−0
System/Win32/WindowsString/DebugApi.hsc +33/−0
System/Win32/WindowsString/File.hsc +269/−0
System/Win32/WindowsString/FileMapping.hsc +107/−0
System/Win32/WindowsString/HardLink.hs +47/−0
System/Win32/WindowsString/Info.hsc +114/−0
System/Win32/WindowsString/Path.hsc +52/−0
System/Win32/WindowsString/Shell.hsc +59/−0
System/Win32/WindowsString/String.hs +73/−0
System/Win32/WindowsString/SymbolicLink.hsc +94/−0
System/Win32/WindowsString/Time.hsc +60/−0
System/Win32/WindowsString/Types.hsc +214/−0
System/Win32/WindowsString/Utils.hs +63/−0
System/Win32/Word.hs +23/−0
Win32.cabal +121/−24
cbits/WndProc.c +1/−1
cbits/alphablend.c +15/−0
cbits/dumpBMP.c +3/−11
changelog.md +246/−0
include/HsWin32.h +2/−3
include/alignment.h +3/−0
include/alphablend.h +10/−0
include/gettime.h +0/−5
include/namedpipeapi_compat.h +16/−0
include/tlhelp32_compat.h +26/−0
include/wincon_compat.h +26/−0
include/windows_cconv.h +13/−0
include/winnls_compat.h +105/−0
include/winnt_compat.h +13/−0
include/winreg_compat.h +32/−0
include/winternl_compat.h +39/−0
include/winuser_compat.h +113/−0

Graphics/Win32.hs view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -19,18 +21,23 @@ -----------------------------------------------------------------------------  module Graphics.Win32 (-	module System.Win32.Types,-	module Graphics.Win32.Control,-	module Graphics.Win32.Dialogue,-	module Graphics.Win32.GDI,-	module Graphics.Win32.Icon,-	module Graphics.Win32.Key,-	module Graphics.Win32.Menu,-	module Graphics.Win32.Message,-	module Graphics.Win32.Misc,-	module Graphics.Win32.Resource,-	module Graphics.Win32.Window-	) where+        module System.Win32.Types,+        module Graphics.Win32.Control,+        module Graphics.Win32.Dialogue,+        module Graphics.Win32.GDI,+        module Graphics.Win32.Icon,+        module Graphics.Win32.Key,+        module Graphics.Win32.Menu,+        module Graphics.Win32.Message,+        module Graphics.Win32.Misc,+        module Graphics.Win32.Resource,+        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 import Graphics.Win32.Control@@ -43,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

Graphics/Win32/Control.hsc view

@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Win32.Control@@ -17,13 +15,17 @@  module Graphics.Win32.Control where -import Graphics.Win32.GDI.Types-import Graphics.Win32.Window-import System.Win32.Types-import Graphics.Win32.Message+import Data.Bits ((.|.))+import Graphics.Win32.GDI.Types (HMENU, HWND)+import Graphics.Win32.Message (WindowMessage)+import Graphics.Win32.Window (ClassName, Pos, WindowStyle, maybePos)+import Graphics.Win32.Window (c_CreateWindowEx)+import System.IO.Unsafe (unsafePerformIO)+import System.Win32.Types (HANDLE, UINT, maybePtr, newTString, withTString)+import System.Win32.Types (failIfFalse_, failIfNull, failIfZero)+import Foreign.Ptr (nullPtr) -import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe+##include "windows_cconv.h"  #include <windows.h> #include <commctrl.h>@@ -73,20 +75,20 @@ checkDlgButton :: HWND -> Int -> ButtonState -> IO () checkDlgButton dialog button check =   failIfFalse_ "CheckDlgButton" $ c_CheckDlgButton dialog button check-foreign import stdcall unsafe "windows.h CheckDlgButton"+foreign import WINDOWS_CCONV unsafe "windows.h CheckDlgButton"   c_CheckDlgButton :: HWND -> Int -> ButtonState -> IO Bool  checkRadioButton :: HWND -> Int -> Int -> Int -> IO () checkRadioButton dialog first_button last_button check =   failIfFalse_ "CheckRadioButton" $     c_CheckRadioButton dialog first_button last_button check-foreign import stdcall unsafe "windows.h CheckRadioButton"+foreign import WINDOWS_CCONV unsafe "windows.h CheckRadioButton"   c_CheckRadioButton :: HWND -> Int -> Int -> Int -> IO Bool  isDlgButtonChecked :: HWND -> Int -> IO ButtonState isDlgButtonChecked wnd button =   failIfZero "IsDlgButtonChecked" $ c_IsDlgButtonChecked wnd button-foreign import stdcall unsafe "windows.h IsDlgButtonChecked"+foreign import WINDOWS_CCONV unsafe "windows.h IsDlgButtonChecked"   c_IsDlgButtonChecked :: HWND -> Int -> IO ButtonState  @@ -324,7 +326,7 @@       (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)       (maybePtr mb_parent) (maybePtr mb_menu) h nullPtr -foreign import stdcall unsafe "windows.h InitCommonControls"+foreign import WINDOWS_CCONV unsafe "windows.h InitCommonControls"   initCommonControls :: IO ()  #endif

Graphics/Win32/Dialogue.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -26,6 +28,8 @@ import Foreign import Foreign.C +##include "windows_cconv.h"+ #include <windows.h>  type DTemplate = LPCTSTR@@ -43,7 +47,7 @@ type ResourceID = Int  mkResource :: ResourceID -> IO (Ptr a)-mkResource res = return (castUINTToPtr (fromIntegral res))+mkResource res = return (castUINTPtrToPtr (fromIntegral res))  mkDialogTemplateFromResource :: Int -> IO DTemplate mkDialogTemplateFromResource = mkResource@@ -67,7 +71,7 @@   c_dia_fn <- mkDialogClosure dia_fn   failIf (== -1) "DialogBoxParam" $     c_DialogBoxParam inst template (maybePtr mb_parent) c_dia_fn init_val-foreign import stdcall "windows.h DialogBoxParamW"+foreign import WINDOWS_CCONV "windows.h DialogBoxParamW"   c_DialogBoxParam :: HINSTANCE -> DTemplate -> HWND -> FunPtr DialogProc -> LPARAM -> IO Int  dialogBoxIndirect :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> IO Int@@ -79,7 +83,7 @@   c_dia_fn <- mkDialogClosure dia_fn   failIf (== -1) "DialogBoxIndirectParam" $     c_DialogBoxIndirectParam inst template (maybePtr mb_parent) c_dia_fn init_val-foreign import stdcall "windows.h DialogBoxIndirectParamW"+foreign import WINDOWS_CCONV "windows.h DialogBoxIndirectParamW"   c_DialogBoxIndirectParam :: HINSTANCE -> DTemplateMem -> HWND -> FunPtr DialogProc -> LPARAM -> IO Int  @@ -92,7 +96,7 @@       (Either ResourceID String)  -- class       (Either ResourceID String)  -- caption       (Either ResourceID String)  -- fontname-      Int	 		  -- font height+      Int                         -- font height       [DialogControl]  data DialogControl@@ -102,72 +106,72 @@       (Either ResourceID String) -- classname       WindowStyle       DWORD-      Int			 -- dia_id+      Int                        -- dia_id  mkDialogFromTemplate :: DialogTemplate -> IO DTemplateMem mkDialogFromTemplate (DialogTemplate x y cx cy-				     wstyle extstyle-				     mb_menu mb_class caption-				     font font_height-				     controls) = do+                                     wstyle extstyle+                                     mb_menu mb_class caption+                                     font font_height+                                     controls) = do   prim_hmenu    <- marshall_res mb_menu   prim_class    <- marshall_res mb_class   prim_caption  <- marshall_res caption   prim_font     <- marshall_res font   dtemp <- mkDiaTemplate 0 x y cx cy wstyle extstyle-  			 prim_hmenu prim_class-			 prim_caption prim_font-			 font_height+                         prim_hmenu prim_class+                         prim_caption prim_font+                         font_height   mapM_ (addControl dtemp) controls   getFinalDialog dtemp  pushButtonControl :: Int -> Int -> Int -> Int-		  -> DWORD -> DWORD -> Int-		  -> String-		  -> DialogControl+                  -> DWORD -> DWORD -> Int+                  -> String+                  -> DialogControl pushButtonControl x y cx cy style estyle dia_id lab =   DialogControl x y cx cy (Left 0x0080) (Right lab)-  		(style + bS_DEFPUSHBUTTON) estyle dia_id+                (style + bS_DEFPUSHBUTTON) estyle dia_id  labelControl :: Int -> Int -> Int -> Int-	     -> DWORD -> DWORD -> Int-	     -> String+             -> DWORD -> DWORD -> Int+             -> String              -> DialogControl labelControl x y cx cy style estyle dia_id lab =   DialogControl x y cx cy (Left 0x0082) (Right lab)-  		(style + sS_LEFT) estyle dia_id+                (style + sS_LEFT) estyle dia_id  listBoxControl :: Int -> Int -> Int -> Int-	       -> DWORD -> DWORD -> Int-	       -> String+               -> DWORD -> DWORD -> Int+               -> String                -> DialogControl listBoxControl x y cx cy style estyle dia_id lab =   DialogControl x y cx cy (Left 0x0083) (Right lab)-  		(style) estyle dia_id+                (style) estyle dia_id  comboBoxControl :: Int -> Int -> Int -> Int-	       -> DWORD -> DWORD -> Int-	       -> String+               -> DWORD -> DWORD -> Int+               -> String                -> DialogControl comboBoxControl x y cx cy style estyle dia_id lab =   DialogControl x y cx cy (Left 0x0085) (Right lab)-  		(style) estyle dia_id+                (style) estyle dia_id  editControl :: Int -> Int -> Int -> Int-	       -> DWORD -> DWORD -> Int-	       -> String+               -> DWORD -> DWORD -> Int+               -> String                -> DialogControl editControl x y cx cy style estyle dia_id lab =   DialogControl x y cx cy (Left 0x0081) (Right lab)-  		(style + eS_LEFT) estyle dia_id+                (style + eS_LEFT) estyle dia_id  scrollBarControl :: Int -> Int -> Int -> Int-	       -> DWORD -> DWORD -> Int-	       -> String+               -> DWORD -> DWORD -> Int+               -> String                -> DialogControl scrollBarControl x y cx cy style estyle dia_id lab =   DialogControl x y cx cy (Left 0x0084) (Right lab)-  		(style) estyle dia_id+                (style) estyle dia_id  foreign import ccall unsafe "diatemp.h getFinalDialog"   getFinalDialog :: Ptr DIA_TEMPLATE -> IO DTemplateMem@@ -178,12 +182,12 @@  addControl :: Ptr DIA_TEMPLATE -> DialogControl -> IO () addControl dtemp (DialogControl x y cx cy mb_text mb_class-				style exstyle-				dia_id) = do+                                style exstyle+                                dia_id) = do    prim_text  <- marshall_res mb_text    prim_class <- marshall_res mb_class    _ <- addDiaControl dtemp prim_text dia_id prim_class style-  		 x y cx cy exstyle+                 x y cx cy exstyle    return ()  foreign import ccall unsafe "diatemp.h addDiaControl"@@ -207,7 +211,7 @@   c_dia_fn <- mkDialogClosure dia_fn   failIfNull "CreateDialogParam" $     c_CreateDialogParam inst template (maybePtr mb_parent) c_dia_fn init_val-foreign import stdcall "windows.h CreateDialogParamW"+foreign import WINDOWS_CCONV "windows.h CreateDialogParamW"   c_CreateDialogParam :: HINSTANCE -> DTemplate -> HWND -> FunPtr DialogProc -> LPARAM -> IO HWND  createDialogIndirect :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> IO HWND@@ -219,31 +223,31 @@   c_dia_fn <- mkDialogClosure dia_fn   failIfNull "CreateDialogIndirectParam" $     c_CreateDialogIndirectParam inst template (maybePtr mb_parent) c_dia_fn init_val-foreign import stdcall "windows.h CreateDialogIndirectParamW"+foreign import WINDOWS_CCONV "windows.h CreateDialogIndirectParamW"   c_CreateDialogIndirectParam :: HINSTANCE -> DTemplateMem -> HWND -> FunPtr DialogProc -> LPARAM -> IO HWND -foreign import stdcall "windows.h DefDlgProcW"+foreign import WINDOWS_CCONV "windows.h DefDlgProcW"   defDlgProc :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT  endDialog :: HWND -> Int -> IO () endDialog dlg res =   failIfFalse_ "EndDialog" $ c_EndDialog dlg res-foreign import stdcall "windows.h EndDialog"+foreign import WINDOWS_CCONV "windows.h EndDialog"   c_EndDialog :: HWND -> Int -> IO BOOL -foreign import stdcall unsafe "windows.h GetDialogBaseUnits"+foreign import WINDOWS_CCONV unsafe "windows.h GetDialogBaseUnits"   getDialogBaseUnits :: IO LONG  getDlgCtrlID :: HWND -> IO Int getDlgCtrlID ctl =   failIfZero "GetDlgCtrlID" $ c_GetDlgCtrlID ctl-foreign import stdcall unsafe "windows.h GetDlgCtrlID"+foreign import WINDOWS_CCONV unsafe "windows.h GetDlgCtrlID"   c_GetDlgCtrlID :: HWND -> IO Int  getDlgItem :: HWND -> Int -> IO HWND getDlgItem dlg item =   failIfNull "GetDlgItem" $ c_GetDlgItem dlg item-foreign import stdcall unsafe "windows.h GetDlgItem"+foreign import WINDOWS_CCONV unsafe "windows.h GetDlgItem"   c_GetDlgItem :: HWND -> Int -> IO HWND  getDlgItemInt :: HWND -> Int -> Bool -> IO Int@@ -252,7 +256,7 @@   res <- c_GetDlgItemInt dlg item p_trans signed   failIfFalse_ "GetDlgItemInt" $ peek p_trans   return (fromIntegral res)-foreign import stdcall "windows.h GetDlgItemInt"+foreign import WINDOWS_CCONV "windows.h GetDlgItemInt"   c_GetDlgItemInt :: HWND -> Int -> Ptr Bool -> Bool -> IO UINT  getDlgItemText :: HWND -> Int -> Int -> IO String@@ -260,46 +264,46 @@   allocaArray size $ \ p_buf -> do   _ <- failIfZero "GetDlgItemInt" $ c_GetDlgItemText dlg item p_buf size   peekTString p_buf-foreign import stdcall "windows.h GetDlgItemTextW"+foreign import WINDOWS_CCONV "windows.h GetDlgItemTextW"   c_GetDlgItemText :: HWND -> Int -> LPTSTR -> Int -> IO Int  getNextDlgGroupItem :: HWND -> HWND -> BOOL -> IO HWND getNextDlgGroupItem dlg ctl previous =   failIfNull "GetNextDlgGroupItem" $ c_GetNextDlgGroupItem dlg ctl previous-foreign import stdcall unsafe "windows.h GetNextDlgGroupItem"+foreign import WINDOWS_CCONV unsafe "windows.h GetNextDlgGroupItem"   c_GetNextDlgGroupItem :: HWND -> HWND -> BOOL -> IO HWND  getNextDlgTabItem :: HWND -> HWND -> BOOL -> IO HWND getNextDlgTabItem dlg ctl previous =   failIfNull "GetNextDlgTabItem" $ c_GetNextDlgTabItem dlg ctl previous-foreign import stdcall unsafe "windows.h GetNextDlgTabItem"+foreign import WINDOWS_CCONV unsafe "windows.h GetNextDlgTabItem"   c_GetNextDlgTabItem :: HWND -> HWND -> BOOL -> IO HWND -foreign import stdcall "windows.h IsDialogMessageW"+foreign import WINDOWS_CCONV "windows.h IsDialogMessageW"   isDialogMessage :: HWND -> LPMSG -> IO BOOL  mapDialogRect :: HWND -> LPRECT -> IO () mapDialogRect dlg p_rect =   failIfFalse_ "MapDialogRect" $ c_MapDialogRect dlg p_rect-foreign import stdcall unsafe "windows.h MapDialogRect"+foreign import WINDOWS_CCONV unsafe "windows.h MapDialogRect"   c_MapDialogRect :: HWND -> LPRECT -> IO Bool  -- No MessageBox* funs in here just yet. -foreign import stdcall "windows.h SendDlgItemMessageW"+foreign import WINDOWS_CCONV "windows.h SendDlgItemMessageW"   sendDlgItemMessage :: HWND -> Int -> WindowMessage -> WPARAM -> LPARAM -> IO LONG  setDlgItemInt :: HWND -> Int -> UINT -> BOOL -> IO () setDlgItemInt dlg item value signed =   failIfFalse_ "SetDlgItemInt" $ c_SetDlgItemInt dlg item value signed-foreign import stdcall "windows.h SetDlgItemInt"+foreign import WINDOWS_CCONV "windows.h SetDlgItemInt"   c_SetDlgItemInt :: HWND -> Int -> UINT -> BOOL -> IO Bool  setDlgItemText :: HWND -> Int -> String -> IO () setDlgItemText dlg item str =   withTString str $ \ c_str ->   failIfFalse_ "SetDlgItemText" $ c_SetDlgItemText dlg item c_str-foreign import stdcall "windows.h SetDlgItemTextW"+foreign import WINDOWS_CCONV "windows.h SetDlgItemTextW"   c_SetDlgItemText :: HWND -> Int -> LPCTSTR -> IO Bool  #{enum WindowStyle,

Graphics/Win32/GDI.hs view

@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Win32.GDI@@ -18,25 +16,25 @@ -----------------------------------------------------------------------------  {-# OPTIONS_GHC -w #-}--- The above warning supression flag is a temporary kludge.+-- The above warning suppression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See---     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings+--     https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details  module Graphics.Win32.GDI (-	module Graphics.Win32.GDI.Bitmap,-	module Graphics.Win32.GDI.Brush,-	module Graphics.Win32.GDI.Clip,-	module Graphics.Win32.GDI.Font,-	module Graphics.Win32.GDI.Graphics2D,-	module Graphics.Win32.GDI.HDC,-	module Graphics.Win32.GDI.Palette,-	module Graphics.Win32.GDI.Path,-	module Graphics.Win32.GDI.Pen,-	module Graphics.Win32.GDI.Region,-	module Graphics.Win32.GDI.Types-	) where+        module Graphics.Win32.GDI.Bitmap,+        module Graphics.Win32.GDI.Brush,+        module Graphics.Win32.GDI.Clip,+        module Graphics.Win32.GDI.Font,+        module Graphics.Win32.GDI.Graphics2D,+        module Graphics.Win32.GDI.HDC,+        module Graphics.Win32.GDI.Palette,+        module Graphics.Win32.GDI.Path,+        module Graphics.Win32.GDI.Pen,+        module Graphics.Win32.GDI.Region,+        module Graphics.Win32.GDI.Types+        ) where  import Graphics.Win32.GDI.Bitmap import Graphics.Win32.GDI.Brush

+ Graphics/Win32/GDI/AlphaBlend.hsc view

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

Graphics/Win32/GDI/Bitmap.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,68 +18,68 @@ -----------------------------------------------------------------------------  module Graphics.Win32.GDI.Bitmap(-	RasterOp3,-	RasterOp4,-	sRCCOPY,-	sRCPAINT,-	sRCAND,-	sRCINVERT,-	sRCERASE,-	nOTSRCCOPY,-	nOTSRCERASE,-	mERGECOPY,-	mERGEPAINT,-	pATCOPY,-	pATPAINT,-	pATINVERT,-	dSTINVERT,-	bLACKNESS,-	wHITENESS,+        RasterOp3,+        RasterOp4,+        sRCCOPY,+        sRCPAINT,+        sRCAND,+        sRCINVERT,+        sRCERASE,+        nOTSRCCOPY,+        nOTSRCERASE,+        mERGECOPY,+        mERGEPAINT,+        pATCOPY,+        pATPAINT,+        pATINVERT,+        dSTINVERT,+        bLACKNESS,+        wHITENESS, -	mAKEROP4,+        mAKEROP4, -	BITMAP,-	LPBITMAP,-	setBITMAP,-	deleteBitmap,-	createCompatibleBitmap,-	createBitmap,-	createBitmapIndirect,-	createDIBPatternBrushPt,-	getBitmapDimensionEx,-	setBitmapDimensionEx,-	getBitmapInfo,+        BITMAP,+        LPBITMAP,+        setBITMAP,+        deleteBitmap,+        createCompatibleBitmap,+        createBitmap,+        createBitmapIndirect,+        createDIBPatternBrushPt,+        getBitmapDimensionEx,+        setBitmapDimensionEx,+        getBitmapInfo, -	BitmapCompression,-	bI_RGB,-	bI_RLE8,-	bI_RLE4,-	bI_BITFIELDS,+        BitmapCompression,+        bI_RGB,+        bI_RLE8,+        bI_RLE4,+        bI_BITFIELDS, -	ColorFormat,-	dIB_PAL_COLORS,-	dIB_RGB_COLORS,+        ColorFormat,+        dIB_PAL_COLORS,+        dIB_RGB_COLORS, -	LPBITMAPINFO,-	BITMAPINFOHEADER,-	LPBITMAPINFOHEADER,-	getBITMAPINFOHEADER_,+        LPBITMAPINFO,+        BITMAPINFOHEADER,+        LPBITMAPINFOHEADER,+        getBITMAPINFOHEADER_, -	BITMAPFILEHEADER,-	LPBITMAPFILEHEADER,-	getBITMAPFILEHEADER,+        BITMAPFILEHEADER,+        LPBITMAPFILEHEADER,+        getBITMAPFILEHEADER, -	sizeofBITMAP,-	sizeofBITMAPINFO,-	sizeofBITMAPINFOHEADER,-	sizeofBITMAPFILEHEADER,-	sizeofLPBITMAPFILEHEADER,+        sizeofBITMAP,+        sizeofBITMAPINFO,+        sizeofBITMAPINFOHEADER,+        sizeofBITMAPFILEHEADER,+        sizeofLPBITMAPFILEHEADER, -	createBMPFile,-	cBM_INIT,-	getDIBits,-	setDIBits,-	createDIBitmap+        createBMPFile,+        cBM_INIT,+        getDIBits,+        setDIBits,+        createDIBitmap          ) where @@ -89,6 +91,8 @@ import Foreign.C  #include "Win32Aux.h"+##include "windows_cconv.h"+ #include <windows.h>  ----------------------------------------------------------------@@ -212,32 +216,32 @@ deleteBitmap :: HBITMAP -> IO () deleteBitmap bitmap =   failIfFalse_ "DeleteBitmap" $ c_DeleteBitmap bitmap-foreign import stdcall unsafe "windows.h DeleteObject"+foreign import WINDOWS_CCONV unsafe "windows.h DeleteObject"   c_DeleteBitmap :: HBITMAP -> IO Bool  createBitmap :: INT -> INT -> UINT -> UINT -> Maybe LPVOID -> IO HBITMAP createBitmap w h planes bits mb_color_data =   failIfNull "CreateBitmap" $     c_CreateBitmap w h planes bits (maybePtr mb_color_data)-foreign import stdcall unsafe "windows.h CreateBitmap"+foreign import WINDOWS_CCONV unsafe "windows.h CreateBitmap"   c_CreateBitmap :: INT -> INT -> UINT -> UINT -> LPVOID -> IO HBITMAP  createBitmapIndirect :: LPBITMAP -> IO HBITMAP createBitmapIndirect p_bm =   failIfNull "CreateBitmapIndirect" $ c_CreateBitmapIndirect p_bm-foreign import stdcall unsafe "windows.h CreateBitmapIndirect"+foreign import WINDOWS_CCONV unsafe "windows.h CreateBitmapIndirect"   c_CreateBitmapIndirect :: LPBITMAP -> IO HBITMAP  createCompatibleBitmap :: HDC -> Int32 -> Int32 -> IO HBITMAP createCompatibleBitmap dc w h =   failIfNull "CreateCompatibleBitmap" $ c_CreateCompatibleBitmap dc w h-foreign import stdcall unsafe "windows.h CreateCompatibleBitmap"+foreign import WINDOWS_CCONV unsafe "windows.h CreateCompatibleBitmap"   c_CreateCompatibleBitmap :: HDC -> Int32 -> Int32 -> IO HBITMAP  createDIBPatternBrushPt :: LPVOID -> ColorFormat -> IO HBRUSH createDIBPatternBrushPt bm usage =   failIfNull "CreateDIBPatternBrushPt" $ c_CreateDIBPatternBrushPt bm usage-foreign import stdcall unsafe "windows.h CreateDIBPatternBrushPt"+foreign import WINDOWS_CCONV unsafe "windows.h CreateDIBPatternBrushPt"   c_CreateDIBPatternBrushPt :: LPVOID -> ColorFormat -> IO HBRUSH  ----------------------------------------------------------------@@ -249,7 +253,7 @@   allocaSIZE $ \ p_size -> do   failIfFalse_ "GetBitmapDimensionEx" $ c_GetBitmapDimensionEx bm p_size   peekSIZE p_size-foreign import stdcall unsafe "windows.h GetBitmapDimensionEx"+foreign import WINDOWS_CCONV unsafe "windows.h GetBitmapDimensionEx"   c_GetBitmapDimensionEx :: HBITMAP -> Ptr SIZE -> IO Bool  setBitmapDimensionEx :: HBITMAP -> SIZE -> IO SIZE@@ -258,7 +262,7 @@   failIfFalse_ "SetBitmapDimensionEx" $ do     c_SetBitmapDimensionEx bm cx cy p_size   peekSIZE p_size-foreign import stdcall unsafe "windows.h SetBitmapDimensionEx"+foreign import WINDOWS_CCONV unsafe "windows.h SetBitmapDimensionEx"   c_SetBitmapDimensionEx :: HBITMAP -> LONG -> LONG -> Ptr SIZE -> IO Bool  getBitmapInfo :: HBITMAP -> IO BITMAP@@ -266,7 +270,7 @@   allocaBytes (fromIntegral sizeofBITMAP) $ \ p_bm -> do   failIfFalse_ "GetBitmapInfo" $ c_GetBitmapInfo bm sizeofBITMAP p_bm   peekBITMAP p_bm-foreign import stdcall unsafe "windows.h GetObjectW"+foreign import WINDOWS_CCONV unsafe "windows.h GetObjectW"   c_GetBitmapInfo :: HBITMAP -> DWORD -> LPBITMAP -> IO Bool  ----------------------------------------------------------------@@ -398,20 +402,20 @@ getDIBits dc bm start nlines mb_bits info usage =   failIfZero "GetDIBits" $     c_GetDIBits dc bm start nlines (maybePtr mb_bits) info usage-foreign import stdcall unsafe "windows.h GetDIBits"+foreign import WINDOWS_CCONV unsafe "windows.h GetDIBits"   c_GetDIBits :: HDC -> HBITMAP -> INT -> INT -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT  setDIBits :: HDC -> HBITMAP -> INT -> INT -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT setDIBits dc bm start nlines bits info use =   failIfZero "SetDIBits" $ c_SetDIBits dc bm start nlines bits info use-foreign import stdcall unsafe "windows.h SetDIBits"+foreign import WINDOWS_CCONV unsafe "windows.h SetDIBits"   c_SetDIBits :: HDC -> HBITMAP -> INT -> INT -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT  createDIBitmap :: HDC -> LPBITMAPINFOHEADER -> DWORD -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO HBITMAP createDIBitmap dc hdr option init_val info usage =   failIfNull "CreateDIBitmap" $     c_CreateDIBitmap dc hdr option init_val info usage-foreign import stdcall unsafe "windows.h CreateDIBitmap"+foreign import WINDOWS_CCONV unsafe "windows.h CreateDIBitmap"   c_CreateDIBitmap :: HDC -> LPBITMAPINFOHEADER -> DWORD -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO HBITMAP  ----------------------------------------------------------------

Graphics/Win32/GDI/Brush.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -20,6 +22,8 @@ import System.Win32.Types import Graphics.Win32.GDI.Types +##include "windows_cconv.h"+ #include <windows.h>  ----------------------------------------------------------------@@ -29,25 +33,25 @@ createSolidBrush :: COLORREF -> IO HBRUSH createSolidBrush color =   failIfNull "CreateSolidBrush" $ c_CreateSolidBrush color-foreign import stdcall unsafe "windows.h CreateSolidBrush"+foreign import WINDOWS_CCONV unsafe "windows.h CreateSolidBrush"   c_CreateSolidBrush :: COLORREF -> IO HBRUSH  createHatchBrush :: HatchStyle -> COLORREF -> IO HBRUSH createHatchBrush style color =   failIfNull "CreateHatchBrush" $ c_CreateHatchBrush style color-foreign import stdcall unsafe "windows.h CreateHatchBrush"+foreign import WINDOWS_CCONV unsafe "windows.h CreateHatchBrush"   c_CreateHatchBrush :: HatchStyle -> COLORREF -> IO HBRUSH  createPatternBrush :: HBITMAP -> IO HBRUSH createPatternBrush bitmap =   failIfNull "CreatePatternBrush" $ c_CreatePatternBrush bitmap-foreign import stdcall unsafe "windows.h CreatePatternBrush"+foreign import WINDOWS_CCONV unsafe "windows.h CreatePatternBrush"   c_CreatePatternBrush :: HBITMAP -> IO HBRUSH  deleteBrush :: HBRUSH -> IO () deleteBrush brush =   failIfFalse_ "DeleteBrush" $ c_DeleteBrush brush-foreign import stdcall unsafe "windows.h DeleteObject"+foreign import WINDOWS_CCONV unsafe "windows.h DeleteObject"   c_DeleteBrush :: HBRUSH -> IO Bool  ----------------------------------------------------------------@@ -67,7 +71,7 @@ getStockBrush :: StockBrush -> IO HBRUSH getStockBrush sb =   failIfNull "GetStockBrush" $ c_GetStockBrush sb-foreign import stdcall unsafe "windows.h GetStockObject"+foreign import WINDOWS_CCONV unsafe "windows.h GetStockObject"   c_GetStockBrush :: StockBrush -> IO HBRUSH  ----------------------------------------------------------------

Graphics/Win32/GDI/Clip.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,11 +19,20 @@  module Graphics.Win32.GDI.Clip where +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@@ -50,40 +61,49 @@  , 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 -foreign import stdcall unsafe "windows.h ChangeClipboardChain"+foreign import WINDOWS_CCONV unsafe "windows.h ChangeClipboardChain"   changeClipboardChain :: HWND -> HWND -> IO Bool  closeClipboard :: IO () closeClipboard =   failIfFalse_ "CloseClipboard" c_CloseClipboard-foreign import stdcall unsafe "windows.h CloseClipboard"+foreign import WINDOWS_CCONV unsafe "windows.h CloseClipboard"   c_CloseClipboard :: IO BOOL -foreign import stdcall unsafe "windows.h CountClipboardFormats"+foreign import WINDOWS_CCONV unsafe "windows.h CountClipboardFormats"   countClipboardFormats :: IO Int  emptyClipboard :: IO () emptyClipboard =   failIfFalse_ "EmptyClipboard" c_EmptyClipboard-foreign import stdcall unsafe "windows.h EmptyClipboard"+foreign import WINDOWS_CCONV unsafe "windows.h EmptyClipboard"   c_EmptyClipboard :: IO BOOL  -- original also tested GetLastError() != NO_ERROR  enumClipboardFormats :: ClipboardFormat -> IO ClipboardFormat-enumClipboardFormats format =-  failIfZero "EnumClipboardFormats" $ c_EnumClipboardFormats format-foreign import stdcall unsafe "windows.h EnumClipboardFormats"+enumClipboardFormats format = do+  format' <- c_EnumClipboardFormats format+  when (format' == 0) $+    failUnlessSuccess "EnumClipboardFormats" getLastError+  return format'+foreign import WINDOWS_CCONV unsafe "windows.h EnumClipboardFormats"   c_EnumClipboardFormats :: ClipboardFormat -> IO ClipboardFormat  getClipboardData :: ClipboardFormat -> IO HANDLE getClipboardData format =   failIfNull "GetClipboardData" $ c_GetClipboardData format-foreign import stdcall unsafe "windows.h GetClipboardData"+foreign import WINDOWS_CCONV unsafe "windows.h GetClipboardData"   c_GetClipboardData :: ClipboardFormat -> IO HANDLE  getClipboardFormatName :: ClipboardFormat -> IO String@@ -92,25 +112,25 @@   len <- failIfZero "GetClipboardFormatName" $     c_GetClipboardFormatName format c_name 256   peekTStringLen (c_name, len)-foreign import stdcall unsafe "windows.h GetClipboardFormatNameW"+foreign import WINDOWS_CCONV unsafe "windows.h GetClipboardFormatNameW"   c_GetClipboardFormatName :: ClipboardFormat -> LPTSTR -> Int -> IO Int  getClipboardOwner :: IO HWND getClipboardOwner =   failIfNull "GetClipboardOwner" c_GetClipboardOwner-foreign import stdcall unsafe "windows.h GetClipboardOwner"+foreign import WINDOWS_CCONV unsafe "windows.h GetClipboardOwner"   c_GetClipboardOwner :: IO HWND  getClipboardViewer :: IO HWND getClipboardViewer =   failIfNull "GetClipboardViewer" c_GetClipboardViewer-foreign import stdcall unsafe "windows.h GetClipboardViewer"+foreign import WINDOWS_CCONV unsafe "windows.h GetClipboardViewer"   c_GetClipboardViewer :: IO HWND  getOpenClipboardWindow :: IO HWND getOpenClipboardWindow =   failIfNull "GetClipboardWindow" c_GetOpenClipboardWindow-foreign import stdcall unsafe "windows.h GetOpenClipboardWindow"+foreign import WINDOWS_CCONV unsafe "windows.h GetOpenClipboardWindow"   c_GetOpenClipboardWindow :: IO HWND  getPriorityClipboardFormat :: [ClipboardFormat] -> IO Int@@ -118,16 +138,16 @@   withArray formats $ \ format_array ->   failIf (== -1) "GetPriorityClipboardFormat" $     c_GetPriorityClipboardFormat format_array (length formats)-foreign import stdcall unsafe "windows.h GetPriorityClipboardFormat"+foreign import WINDOWS_CCONV unsafe "windows.h GetPriorityClipboardFormat"   c_GetPriorityClipboardFormat :: Ptr UINT -> Int -> IO Int -foreign import stdcall unsafe "windows.h IsClipboardFormatAvailable"+foreign import WINDOWS_CCONV unsafe "windows.h IsClipboardFormatAvailable"   isClipboardFormatAvailable :: ClipboardFormat -> IO BOOL  openClipboard :: HWND -> IO () openClipboard wnd =   failIfFalse_ "OpenClipboard" $ c_OpenClipboard wnd-foreign import stdcall unsafe "windows.h OpenClipboard"+foreign import WINDOWS_CCONV unsafe "windows.h OpenClipboard"   c_OpenClipboard :: HWND -> IO BOOL  registerClipboardFormat :: String -> IO ClipboardFormat@@ -135,17 +155,17 @@   withTString name $ \ c_name ->   failIfZero "RegisterClipboardFormat" $     c_RegisterClipboardFormat c_name-foreign import stdcall unsafe "windows.h RegisterClipboardFormatW"+foreign import WINDOWS_CCONV unsafe "windows.h RegisterClipboardFormatW"   c_RegisterClipboardFormat :: LPCTSTR -> IO ClipboardFormat  setClipboardData :: ClipboardFormat -> HANDLE -> IO HANDLE setClipboardData format mem =   failIfNull "SetClipboardData" $ c_SetClipboardData format mem-foreign import stdcall unsafe "windows.h SetClipboardData"+foreign import WINDOWS_CCONV unsafe "windows.h SetClipboardData"   c_SetClipboardData :: ClipboardFormat -> HANDLE -> IO HANDLE  setClipboardViewer :: HWND -> IO HWND setClipboardViewer wnd =   failIfNull "SetClipboardViewer" $ c_SetClipboardViewer wnd-foreign import stdcall unsafe "windows.h SetClipboardViewer"+foreign import WINDOWS_CCONV unsafe "windows.h SetClipboardViewer"   c_SetClipboardViewer :: HWND -> IO HWND

Graphics/Win32/GDI/Font.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,27 +19,28 @@  module Graphics.Win32.GDI.Font {--	( CharSet-	, PitchAndFamily-	, OutPrecision-	, ClipPrecision-	, FontQuality-	, FontWeight+        ( CharSet+        , PitchAndFamily+        , OutPrecision+        , ClipPrecision+        , FontQuality+        , FontWeight -	, createFont, deleteFont+        , createFont, deleteFont -	, StockFont, getStockFont-	, oEM_FIXED_FONT, aNSI_FIXED_FONT, aNSI_VAR_FONT, sYSTEM_FONT-	, dEVICE_DEFAULT_FONT, sYSTEM_FIXED_FONT-	) where+        , StockFont, getStockFont+        , oEM_FIXED_FONT, aNSI_FIXED_FONT, aNSI_VAR_FONT, sYSTEM_FONT+        , dEVICE_DEFAULT_FONT, sYSTEM_FIXED_FONT+        ) where -}-	where+        where  import System.Win32.Types import Graphics.Win32.GDI.Types  import Foreign +##include "windows_cconv.h" #include <windows.h>  ----------------------------------------------------------------@@ -148,7 +151,7 @@   withTString face $ \ c_face ->   failIfNull "CreateFont" $     c_CreateFont h w esc orient wt ital under strike cset out clip q pf c_face-foreign import stdcall unsafe "windows.h CreateFontW"+foreign import WINDOWS_CCONV unsafe "windows.h CreateFontW"   c_CreateFont      :: INT -> INT -> INT -> INT      -> FontWeight -> Bool -> Bool -> Bool@@ -165,24 +168,24 @@ -- -- createFont_adr (width, height) escapement bold italic family = --  createFont height width--- 		     (round (escapement * 1800/pi))--- 		     0                     -- orientation--- 		     weight--- 		     italic False False    -- italic, underline, strikeout--- 		     aNSI_CHARSET--- 		     oUT_DEFAULT_PRECIS--- 		     cLIP_DEFAULT_PRECIS--- 		     dEFAULT_QUALITY--- 		     dEFAULT_PITCH--- 		     family+--                   (round (escapement * 1800/pi))+--                   0                     -- orientation+--                   weight+--                   italic False False    -- italic, underline, strikeout+--                   aNSI_CHARSET+--                   oUT_DEFAULT_PRECIS+--                   cLIP_DEFAULT_PRECIS+--                   dEFAULT_QUALITY+--                   dEFAULT_PITCH+--                   family --  where --   weight | bold      = fW_BOLD--- 	    | otherwise = fW_NORMAL+--          | otherwise = fW_NORMAL   -- missing CreateFontIndirect from WinFonts.ss; GSL ??? -foreign import stdcall unsafe "windows.h DeleteObject"+foreign import WINDOWS_CCONV unsafe "windows.h DeleteObject"   deleteFont :: HFONT -> IO ()  ----------------------------------------------------------------@@ -198,7 +201,7 @@  , sYSTEM_FIXED_FONT   = SYSTEM_FIXED_FONT  } -foreign import stdcall unsafe "windows.h GetStockObject"+foreign import WINDOWS_CCONV unsafe "windows.h GetStockObject"   getStockFont :: StockFont -> IO HFONT  ----------------------------------------------------------------

Graphics/Win32/GDI/Graphics2D.hs view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,13 +18,15 @@ -----------------------------------------------------------------------------  module Graphics.Win32.GDI.Graphics2D-	where+        where  import System.Win32.Types import Graphics.Win32.GDI.Types  import Foreign +#include "windows_cconv.h"+ ---------------------------------------------------------------- -- Lines and Curves ----------------------------------------------------------------@@ -32,124 +36,124 @@   allocaPOINT $ \ p_point -> do   failIfFalse_ "MoveToEx" $ c_MoveToEx dc x y p_point   peekPOINT p_point-foreign import stdcall unsafe "windows.h MoveToEx"+foreign import WINDOWS_CCONV unsafe "windows.h MoveToEx"   c_MoveToEx :: HDC -> Int32 -> Int32 -> Ptr POINT -> IO Bool  lineTo :: HDC -> Int32 -> Int32 -> IO () lineTo dc x y =   failIfFalse_ "LineTo" $ c_LineTo dc x y-foreign import stdcall unsafe "windows.h LineTo"+foreign import WINDOWS_CCONV unsafe "windows.h LineTo"   c_LineTo :: HDC -> Int32 -> Int32 -> IO Bool  polyline :: HDC -> [POINT] -> IO () polyline dc points =   withPOINTArray points $ \ pount_array npoints ->   failIfFalse_ "Polyline" $ c_Polyline dc pount_array npoints-foreign import stdcall unsafe "windows.h Polyline"+foreign import WINDOWS_CCONV unsafe "windows.h Polyline"   c_Polyline :: HDC -> Ptr POINT -> Int -> IO Bool  polylineTo :: HDC -> [POINT] -> IO () polylineTo dc points =   withPOINTArray points $ \ pount_array npoints ->   failIfFalse_ "PolylineTo" $ c_PolylineTo dc pount_array npoints-foreign import stdcall unsafe "windows.h PolylineTo"+foreign import WINDOWS_CCONV unsafe "windows.h PolylineTo"   c_PolylineTo :: HDC -> Ptr POINT -> Int -> IO Bool  polygon :: HDC -> [POINT] -> IO () polygon dc points =   withPOINTArray points $ \ pount_array npoints ->   failIfFalse_ "Polygon" $ c_Polygon dc pount_array npoints-foreign import stdcall unsafe "windows.h Polygon"+foreign import WINDOWS_CCONV unsafe "windows.h Polygon"   c_Polygon :: HDC -> Ptr POINT -> Int -> IO Bool  polyBezier :: HDC -> [POINT] -> IO () polyBezier dc points =   withPOINTArray points $ \ pount_array npoints ->   failIfFalse_ "PolyBezier" $ c_PolyBezier dc pount_array npoints-foreign import stdcall unsafe "windows.h PolyBezier"+foreign import WINDOWS_CCONV unsafe "windows.h PolyBezier"   c_PolyBezier :: HDC -> Ptr POINT -> Int -> IO Bool  polyBezierTo :: HDC -> [POINT] -> IO () polyBezierTo dc points =   withPOINTArray points $ \ pount_array npoints ->   failIfFalse_ "PolyBezierTo" $ c_PolyBezierTo dc pount_array npoints-foreign import stdcall unsafe "windows.h PolyBezierTo"+foreign import WINDOWS_CCONV unsafe "windows.h PolyBezierTo"   c_PolyBezierTo :: HDC -> Ptr POINT -> Int -> IO Bool  arc :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO () arc dc left top right bottom x1 y1 x2 y2 =   failIfFalse_ "Arc" $ c_Arc dc left top right bottom x1 y1 x2 y2-foreign import stdcall unsafe "windows.h Arc"+foreign import WINDOWS_CCONV unsafe "windows.h Arc"   c_Arc :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool  arcTo :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO () arcTo dc left top right bottom x1 y1 x2 y2 =   failIfFalse_ "ArcTo" $ c_ArcTo dc left top right bottom x1 y1 x2 y2-foreign import stdcall unsafe "windows.h ArcTo"+foreign import WINDOWS_CCONV unsafe "windows.h ArcTo"   c_ArcTo :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool  angleArc :: HDC -> Int32 -> Int32 -> WORD -> Float -> Float -> IO () angleArc dc x y r start sweep =   failIfFalse_ "AngleArc" $ c_AngleArc dc x y r start sweep-foreign import stdcall unsafe "windows.h AngleArc"+foreign import WINDOWS_CCONV unsafe "windows.h AngleArc"   c_AngleArc :: HDC -> Int32 -> Int32 -> WORD -> Float -> Float -> IO Bool  ---------------------------------------------------------------- -- Filled Shapes ---------------------------------------------------------------- --- ToDo: We ought to be able to specify a colour instead of the+-- TODO: We ought to be able to specify a colour instead of the -- Brush by adding 1 to colour number.  fillRect :: HDC -> RECT -> HBRUSH -> IO () fillRect dc rect brush =   withRECT rect $ \ c_rect ->   failIfFalse_ "FillRect" $ c_FillRect dc c_rect brush-foreign import stdcall unsafe "windows.h FillRect"+foreign import WINDOWS_CCONV unsafe "windows.h FillRect"   c_FillRect :: HDC -> Ptr RECT -> HBRUSH -> IO Bool  frameRect :: HDC -> RECT -> HBRUSH -> IO () frameRect dc rect brush =   withRECT rect $ \ c_rect ->   failIfFalse_ "FrameRect" $ c_FrameRect dc c_rect brush-foreign import stdcall unsafe "windows.h FrameRect"+foreign import WINDOWS_CCONV unsafe "windows.h FrameRect"   c_FrameRect :: HDC -> Ptr RECT -> HBRUSH -> IO Bool  invertRect :: HDC -> RECT -> IO () invertRect dc rect =   withRECT rect $ \ c_rect ->   failIfFalse_ "InvertRect" $ c_InvertRect dc c_rect-foreign import stdcall unsafe "windows.h InvertRect"+foreign import WINDOWS_CCONV unsafe "windows.h InvertRect"   c_InvertRect :: HDC -> Ptr RECT -> IO Bool  rectangle :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> IO () rectangle dc left top right bottom =   failIfFalse_ "Rectangle" $ c_Rectangle dc left top right bottom-foreign import stdcall unsafe "windows.h Rectangle"+foreign import WINDOWS_CCONV unsafe "windows.h Rectangle"   c_Rectangle :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool  roundRect :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO () roundRect dc left top right bottom w h =   failIfFalse_ "RoundRect" $ c_RoundRect dc left top right bottom w h-foreign import stdcall unsafe "windows.h RoundRect"+foreign import WINDOWS_CCONV unsafe "windows.h RoundRect"   c_RoundRect :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool  ellipse :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> IO () ellipse dc left top right bottom =   failIfFalse_ "Ellipse" $ c_Ellipse dc left top right bottom-foreign import stdcall unsafe "windows.h Ellipse"+foreign import WINDOWS_CCONV unsafe "windows.h Ellipse"   c_Ellipse :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool  chord :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO () chord dc left top right bottom x1 y1 x2 y2 =   failIfFalse_ "Chord" $ c_Chord dc left top right bottom x1 y1 x2 y2-foreign import stdcall unsafe "windows.h Chord"+foreign import WINDOWS_CCONV unsafe "windows.h Chord"   c_Chord :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool  pie :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO () pie dc left top right bottom x1 y1 x2 y2 =   failIfFalse_ "Pie" $ c_Pie dc left top right bottom x1 y1 x2 y2-foreign import stdcall unsafe "windows.h Pie"+foreign import WINDOWS_CCONV unsafe "windows.h Pie"   c_Pie :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool  ----------------------------------------------------------------@@ -159,21 +163,21 @@ bitBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> RasterOp3 -> IO () bitBlt dcDest xDest yDest w h dcSrc xSrc ySrc rop =   failIfFalse_ "BitBlt" $ c_BitBlt dcDest xDest yDest w h dcSrc xSrc ySrc rop-foreign import stdcall unsafe "windows.h BitBlt"+foreign import WINDOWS_CCONV unsafe "windows.h BitBlt"   c_BitBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> RasterOp3 -> IO Bool  maskBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> HBITMAP -> INT -> INT -> RasterOp4 -> IO () maskBlt dcDest xDest yDest w h dcSrc xSrc ySrc bm xMask yMask rop =   failIfFalse_ "MaskBlt" $     c_MaskBlt dcDest xDest yDest w h dcSrc xSrc ySrc bm xMask yMask rop-foreign import stdcall unsafe "windows.h MaskBlt"+foreign import WINDOWS_CCONV unsafe "windows.h MaskBlt"   c_MaskBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> HBITMAP -> INT -> INT -> RasterOp4 -> IO Bool  stretchBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> INT -> INT -> RasterOp3 -> IO () stretchBlt dcDest xDest yDest wDest hDest hdcSrc xSrc ySrc wSrc hSrc rop =   failIfFalse_ "StretchBlt" $     c_StretchBlt dcDest xDest yDest wDest hDest hdcSrc xSrc ySrc wSrc hSrc rop-foreign import stdcall unsafe "windows.h StretchBlt"+foreign import WINDOWS_CCONV unsafe "windows.h StretchBlt"   c_StretchBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> INT -> INT -> RasterOp3 -> IO Bool  -- We deviate slightly from the Win32 interface@@ -188,7 +192,7 @@   withPOINTArray [p1,p2,p3] $ \ vertices _ ->   failIfFalse_ "PlgBlt" $     c_PlgBlt hdDest vertices hdSrc x y w h (maybePtr mb_bm) xMask yMask-foreign import stdcall unsafe "windows.h PlgBlt"+foreign import WINDOWS_CCONV unsafe "windows.h PlgBlt"   c_PlgBlt :: HDC -> Ptr POINT -> HDC -> INT -> INT -> INT -> INT -> HBITMAP -> INT -> INT -> IO Bool  ----------------------------------------------------------------@@ -199,7 +203,7 @@ textOut dc x y str =   withTStringLen str $ \ (c_str, len) ->   failIfFalse_ "TextOut" $ c_TextOut dc x y c_str len-foreign import stdcall unsafe "windows.h TextOutW"+foreign import WINDOWS_CCONV unsafe "windows.h TextOutW"   c_TextOut :: HDC -> INT -> INT -> LPCTSTR -> Int -> IO Bool  -- missing TabbedTextOut from WinFonts.ss; GSL ???@@ -211,7 +215,7 @@   failIfFalse_ "GetTextExtentPoint32" $     c_GetTextExtentPoint32 dc c_str len p_size   peekSIZE p_size-foreign import stdcall unsafe "windows.h GetTextExtentPoint32W"+foreign import WINDOWS_CCONV unsafe "windows.h GetTextExtentPoint32W"   c_GetTextExtentPoint32 :: HDC -> LPCTSTR -> Int -> Ptr SIZE -> IO Bool  -- missing getTabbedTextExtent from WinFonts.ss; GSL ???

Graphics/Win32/GDI/HDC.hs view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,98 +18,124 @@ -----------------------------------------------------------------------------  module Graphics.Win32.GDI.HDC-	( module Graphics.Win32.GDI.HDC-	) where+        ( module Graphics.Win32.GDI.HDC+        ) where  import System.Win32.Types import Graphics.Win32.GDI.Types  import Foreign -----------------------------------------------------------------+#include "windows_cconv.h" +{- Note [Overflow checking and fromIntegral]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Some windows APIs use the value 0x80000000 to represent failure return+codes. However, when GHC builds libraries with -XNegativeLiterals+enabled, it will fail in contexts where the type would suffer from+signed overflow - such as Int32. (minBound :: Int32 == 0x80000000)++Technically, the frontend is correct that the literal overflows in the+context it is used in. So instead, we use fromIntegral to convert the+literal from a Word32 to the necessary type. This isn't any less+efficient (fromIntegral is optimized away,) and conveys the idea we+simply want the same representational value.+-}++----------------------+-- Implement GetPixel+----------------------++getPixel :: HDC -> Int -> Int -> IO COLORREF+getPixel dc x y = c_GetPixel dc x y+foreign import WINDOWS_CCONV unsafe "windows.h GetPixel"+  c_GetPixel :: HDC -> Int -> Int -> IO COLORREF++----------------------+ setArcDirection :: HDC -> ArcDirection -> IO ArcDirection setArcDirection dc dir =   failIfZero "SetArcDirection" $ c_SetArcDirection dc dir-foreign import stdcall unsafe "windows.h SetArcDirection"+foreign import WINDOWS_CCONV unsafe "windows.h SetArcDirection"   c_SetArcDirection :: HDC ->  ArcDirection  -> IO  ArcDirection  getArcDirection :: HDC -> IO ArcDirection getArcDirection dc =   failIfZero "GetArcDirection" $ c_GetArcDirection dc-foreign import stdcall unsafe "windows.h GetArcDirection"+foreign import WINDOWS_CCONV unsafe "windows.h GetArcDirection"   c_GetArcDirection :: HDC -> IO  ArcDirection  setPolyFillMode :: HDC -> PolyFillMode -> IO PolyFillMode setPolyFillMode dc mode =   failIfZero "SetPolyFillMode" $ c_SetPolyFillMode dc mode-foreign import stdcall unsafe "windows.h SetPolyFillMode"+foreign import WINDOWS_CCONV unsafe "windows.h SetPolyFillMode"   c_SetPolyFillMode :: HDC ->  PolyFillMode  -> IO  PolyFillMode  getPolyFillMode :: HDC -> IO PolyFillMode getPolyFillMode dc =   failIfZero "GetPolyFillMode" $ c_GetPolyFillMode dc-foreign import stdcall unsafe "windows.h GetPolyFillMode"+foreign import WINDOWS_CCONV unsafe "windows.h GetPolyFillMode"   c_GetPolyFillMode :: HDC -> IO  PolyFillMode  setGraphicsMode :: HDC -> GraphicsMode -> IO GraphicsMode setGraphicsMode dc mode =   failIfZero "SetGraphicsMode" $ c_SetGraphicsMode dc mode-foreign import stdcall unsafe "windows.h SetGraphicsMode"+foreign import WINDOWS_CCONV unsafe "windows.h SetGraphicsMode"   c_SetGraphicsMode :: HDC ->  GraphicsMode  -> IO  GraphicsMode  getGraphicsMode :: HDC -> IO GraphicsMode getGraphicsMode dc =   failIfZero "GetGraphicsMode" $ c_GetGraphicsMode dc-foreign import stdcall unsafe "windows.h GetGraphicsMode"+foreign import WINDOWS_CCONV unsafe "windows.h GetGraphicsMode"   c_GetGraphicsMode :: HDC -> IO  GraphicsMode  setStretchBltMode :: HDC -> StretchBltMode -> IO StretchBltMode setStretchBltMode dc mode =   failIfZero "SetStretchBltMode" $ c_SetStretchBltMode dc mode-foreign import stdcall unsafe "windows.h SetStretchBltMode"+foreign import WINDOWS_CCONV unsafe "windows.h SetStretchBltMode"   c_SetStretchBltMode :: HDC ->  StretchBltMode  -> IO  StretchBltMode  getStretchBltMode :: HDC -> IO StretchBltMode getStretchBltMode dc =   failIfZero "GetStretchBltMode" $ c_GetStretchBltMode dc-foreign import stdcall unsafe "windows.h GetStretchBltMode"+foreign import WINDOWS_CCONV unsafe "windows.h GetStretchBltMode"   c_GetStretchBltMode :: HDC -> IO  StretchBltMode  setBkColor :: HDC -> COLORREF -> IO COLORREF setBkColor dc color =   failIfZero "SetBkColor" $ c_SetBkColor dc color-foreign import stdcall unsafe "windows.h SetBkColor"+foreign import WINDOWS_CCONV unsafe "windows.h SetBkColor"   c_SetBkColor :: HDC ->  COLORREF  -> IO  COLORREF  getBkColor :: HDC -> IO COLORREF getBkColor dc =   failIfZero "GetBkColor" $ c_GetBkColor dc-foreign import stdcall unsafe "windows.h GetBkColor"+foreign import WINDOWS_CCONV unsafe "windows.h GetBkColor"   c_GetBkColor :: HDC -> IO  COLORREF  setTextColor :: HDC -> COLORREF -> IO COLORREF setTextColor dc color =   failIf (== cLR_INVALID) "SetTextColor" $ c_SetTextColor dc color-foreign import stdcall unsafe "windows.h SetTextColor"+foreign import WINDOWS_CCONV unsafe "windows.h SetTextColor"   c_SetTextColor :: HDC ->  COLORREF  -> IO  COLORREF  getTextColor :: HDC -> IO COLORREF getTextColor dc =   failIf (== cLR_INVALID) "GetTextColor" $ c_GetTextColor dc-foreign import stdcall unsafe "windows.h GetTextColor"+foreign import WINDOWS_CCONV unsafe "windows.h GetTextColor"   c_GetTextColor :: HDC -> IO  COLORREF  setBkMode :: HDC -> BackgroundMode -> IO BackgroundMode setBkMode dc mode =   failIfZero "SetBkMode" $ c_SetBkMode dc mode-foreign import stdcall unsafe "windows.h SetBkMode"+foreign import WINDOWS_CCONV unsafe "windows.h SetBkMode"   c_SetBkMode :: HDC ->  BackgroundMode  -> IO  BackgroundMode  getBkMode :: HDC -> IO BackgroundMode getBkMode dc =   failIfZero "GetBkMode" $ c_GetBkMode dc-foreign import stdcall unsafe "windows.h GetBkMode"+foreign import WINDOWS_CCONV unsafe "windows.h GetBkMode"   c_GetBkMode :: HDC -> IO  BackgroundMode  setBrushOrgEx :: HDC -> Int -> Int -> IO POINT@@ -115,7 +143,7 @@   allocaPOINT $ \ pt -> do   failIfFalse_ "SetBrushOrgEx" $ c_SetBrushOrgEx dc x y pt   peekPOINT pt-foreign import stdcall unsafe "windows.h SetBrushOrgEx"+foreign import WINDOWS_CCONV unsafe "windows.h SetBrushOrgEx"   c_SetBrushOrgEx :: HDC -> Int -> Int -> Ptr POINT -> IO Bool  getBrushOrgEx :: HDC -> IO POINT@@ -123,32 +151,34 @@   allocaPOINT $ \ pt -> do   failIfFalse_ "GetBrushOrgEx" $ c_GetBrushOrgEx dc pt   peekPOINT pt-foreign import stdcall unsafe "windows.h GetBrushOrgEx"+foreign import WINDOWS_CCONV unsafe "windows.h GetBrushOrgEx"   c_GetBrushOrgEx :: HDC -> Ptr POINT -> IO Bool  setTextAlign :: HDC -> TextAlignment -> IO TextAlignment setTextAlign dc align =   failIf (== gDI_ERROR) "SetTextAlign" $ c_SetTextAlign dc align-foreign import stdcall unsafe "windows.h SetTextAlign"+foreign import WINDOWS_CCONV unsafe "windows.h SetTextAlign"   c_SetTextAlign :: HDC ->  TextAlignment  -> IO  TextAlignment  getTextAlign :: HDC -> IO TextAlignment getTextAlign dc =   failIf (== gDI_ERROR) "GetTextAlign" $ c_GetTextAlign dc-foreign import stdcall unsafe "windows.h GetTextAlign"+foreign import WINDOWS_CCONV unsafe "windows.h GetTextAlign"   c_GetTextAlign :: HDC -> IO  TextAlignment  setTextCharacterExtra :: HDC -> Int -> IO Int setTextCharacterExtra dc extra =-  failIf (== 0x80000000) "SetTextCharacterExtra" $+  -- See Note [Overflow checking and fromIntegral]+  failIf (== fromIntegral (0x80000000 :: Word32)) "SetTextCharacterExtra" $     c_SetTextCharacterExtra dc extra-foreign import stdcall unsafe "windows.h SetTextCharacterExtra"+foreign import WINDOWS_CCONV unsafe "windows.h SetTextCharacterExtra"   c_SetTextCharacterExtra :: HDC ->  Int  -> IO  Int  getTextCharacterExtra :: HDC -> IO Int getTextCharacterExtra dc =-  failIf (== 0x80000000) "GetTextCharacterExtra" $ c_GetTextCharacterExtra dc-foreign import stdcall unsafe "windows.h GetTextCharacterExtra"+  -- See Note [Overflow checking and fromIntegral]+  failIf (== fromIntegral (0x80000000 :: Word32)) "GetTextCharacterExtra" $ c_GetTextCharacterExtra dc+foreign import WINDOWS_CCONV unsafe "windows.h GetTextCharacterExtra"   c_GetTextCharacterExtra :: HDC -> IO  Int  getMiterLimit :: HDC -> IO Float@@ -156,7 +186,7 @@   alloca $ \ p_res -> do   failIfFalse_ "GetMiterLimit" $ c_GetMiterLimit dc p_res   peek p_res-foreign import stdcall unsafe "windows.h GetMiterLimit"+foreign import WINDOWS_CCONV unsafe "windows.h GetMiterLimit"   c_GetMiterLimit :: HDC -> Ptr FLOAT -> IO Bool  setMiterLimit :: HDC -> Float -> IO Float@@ -164,7 +194,7 @@   alloca $ \ p_old_limit -> do   failIfFalse_ "SetMiterLimit" $ c_SetMiterLimit dc new_limit p_old_limit   peek p_old_limit-foreign import stdcall unsafe "windows.h SetMiterLimit"+foreign import WINDOWS_CCONV unsafe "windows.h SetMiterLimit"   c_SetMiterLimit :: HDC -> FLOAT -> Ptr FLOAT -> IO Bool  ----------------------------------------------------------------@@ -172,13 +202,13 @@ saveDC :: HDC -> IO Int saveDC dc =   failIfZero "SaveDC" $ c_SaveDC dc-foreign import stdcall unsafe "windows.h SaveDC"+foreign import WINDOWS_CCONV unsafe "windows.h SaveDC"   c_SaveDC :: HDC -> IO Int  restoreDC :: HDC -> Int -> IO () restoreDC dc saved =   failIfFalse_ "RestoreDC" $ c_RestoreDC dc saved-foreign import stdcall unsafe "windows.h RestoreDC"+foreign import WINDOWS_CCONV unsafe "windows.h RestoreDC"   c_RestoreDC :: HDC -> Int -> IO Bool  ----------------------------------------------------------------@@ -186,55 +216,55 @@ getCurrentBitmap :: HDC -> IO HBITMAP getCurrentBitmap dc =   failIfNull "GetCurrentBitmap" $ c_GetCurrentBitmap dc oBJ_BITMAP-foreign import stdcall unsafe "windows.h GetCurrentObject"+foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentObject"   c_GetCurrentBitmap :: HDC -> UINT -> IO  HBITMAP  getCurrentBrush :: HDC -> IO HBRUSH getCurrentBrush dc =   failIfNull "GetCurrentBrush" $ c_GetCurrentBrush dc oBJ_BRUSH-foreign import stdcall unsafe "windows.h GetCurrentObject"+foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentObject"   c_GetCurrentBrush :: HDC -> UINT -> IO   HBRUSH  getCurrentFont :: HDC -> IO HFONT getCurrentFont dc =   failIfNull "GetCurrentFont" $ c_GetCurrentFont dc oBJ_FONT-foreign import stdcall unsafe "windows.h GetCurrentObject"+foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentObject"   c_GetCurrentFont :: HDC -> UINT -> IO    HFONT  getCurrentPalette :: HDC -> IO HPALETTE getCurrentPalette dc =   failIfNull "GetCurrentPalette" $ c_GetCurrentPalette dc oBJ_PAL-foreign import stdcall unsafe "windows.h GetCurrentObject"+foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentObject"   c_GetCurrentPalette :: HDC -> UINT -> IO     HPALETTE  getCurrentPen :: HDC -> IO HPEN getCurrentPen dc =   failIfNull "GetCurrentPen" $ c_GetCurrentPen dc oBJ_PEN-foreign import stdcall unsafe "windows.h GetCurrentObject"+foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentObject"   c_GetCurrentPen :: HDC -> UINT -> IO     HPEN  selectBitmap :: HDC -> HBITMAP -> IO HBITMAP selectBitmap dc bitmap =   failIfNull "SelectBitmap" $ c_SelectBitmap dc bitmap-foreign import stdcall unsafe "windows.h SelectObject"+foreign import WINDOWS_CCONV unsafe "windows.h SelectObject"   c_SelectBitmap :: HDC ->   HBITMAP  -> IO   HBITMAP  selectBrush :: HDC -> HBRUSH -> IO HBRUSH selectBrush dc brush =   failIfNull "SelectBrush" $ c_SelectBrush dc brush-foreign import stdcall unsafe "windows.h SelectObject"+foreign import WINDOWS_CCONV unsafe "windows.h SelectObject"   c_SelectBrush :: HDC ->    HBRUSH  -> IO    HBRUSH  selectFont :: HDC -> HFONT -> IO HFONT selectFont dc font =   failIfNull "SelectFont" $ c_SelectFont dc font-foreign import stdcall unsafe "windows.h SelectObject"+foreign import WINDOWS_CCONV unsafe "windows.h SelectObject"   c_SelectFont :: HDC ->     HFONT  -> IO     HFONT  selectPen :: HDC -> HPEN -> IO HPEN selectPen dc pen =   failIfNull "SelectPen" $ c_SelectPen dc pen-foreign import stdcall unsafe "windows.h SelectObject"+foreign import WINDOWS_CCONV unsafe "windows.h SelectObject"   c_SelectPen :: HDC ->      HPEN  -> IO      HPEN  ----------------------------------------------------------------@@ -244,7 +274,7 @@ selectPalette :: HDC -> HPALETTE -> Bool -> IO HPALETTE selectPalette dc palette force_bg =   failIfNull "SelectPalette" $ c_SelectPalette dc palette force_bg-foreign import stdcall unsafe "windows.h SelectPalette"+foreign import WINDOWS_CCONV unsafe "windows.h SelectPalette"   c_SelectPalette :: HDC -> HPALETTE -> Bool -> IO HPALETTE  selectRgn :: HDC -> HRGN -> IO RegionType@@ -260,20 +290,20 @@ selectClipRgn dc mb_rgn =   maybeWith withForeignPtr mb_rgn $ \ p_rgn ->   failIfZero "SelectClipRgn" $ c_SelectClipRgn dc p_rgn-foreign import stdcall unsafe "windows.h SelectClipRgn"+foreign import WINDOWS_CCONV unsafe "windows.h SelectClipRgn"   c_SelectClipRgn :: HDC -> PRGN -> IO RegionType  extSelectClipRgn :: HDC -> Maybe HRGN -> ClippingMode -> IO RegionType extSelectClipRgn dc mb_rgn mode =   maybeWith withForeignPtr mb_rgn $ \ p_rgn ->   failIfZero "ExtSelectClipRgn" $ c_ExtSelectClipRgn dc p_rgn mode-foreign import stdcall unsafe "windows.h ExtSelectClipRgn"+foreign import WINDOWS_CCONV unsafe "windows.h ExtSelectClipRgn"   c_ExtSelectClipRgn :: HDC -> PRGN -> ClippingMode -> IO RegionType  selectClipPath :: HDC -> ClippingMode -> IO RegionType selectClipPath dc mode =   failIfZero "SelectClipPath" $ c_SelectClipPath dc mode-foreign import stdcall unsafe "windows.h SelectClipPath"+foreign import WINDOWS_CCONV unsafe "windows.h SelectClipPath"   c_SelectClipPath :: HDC -> ClippingMode -> IO RegionType  ----------------------------------------------------------------@@ -283,19 +313,19 @@ cancelDC :: HDC -> IO () cancelDC dc =   failIfFalse_ "CancelDC" $ c_CancelDC dc-foreign import stdcall unsafe "windows.h CancelDC"+foreign import WINDOWS_CCONV unsafe "windows.h CancelDC"   c_CancelDC :: HDC -> IO Bool  createCompatibleDC :: Maybe HDC -> IO HDC createCompatibleDC mb_dc =   failIfNull "CreateCompatibleDC" $ c_CreateCompatibleDC (maybePtr mb_dc)-foreign import stdcall unsafe "windows.h CreateCompatibleDC"+foreign import WINDOWS_CCONV unsafe "windows.h CreateCompatibleDC"   c_CreateCompatibleDC :: HDC -> IO HDC  deleteDC :: HDC -> IO () deleteDC dc =   failIfFalse_ "DeleteDC" $ c_DeleteDC dc-foreign import stdcall unsafe "windows.h DeleteDC"+foreign import WINDOWS_CCONV unsafe "windows.h DeleteDC"   c_DeleteDC :: HDC -> IO Bool  ----------------------------------------------------------------

Graphics/Win32/GDI/Palette.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -20,6 +22,7 @@ import System.Win32.Types import Graphics.Win32.GDI.Types +##include "windows_cconv.h" #include <windows.h>  ----------------------------------------------------------------@@ -35,13 +38,13 @@ getStockPalette :: StockPalette -> IO HPALETTE getStockPalette sp =   failIfNull "GetStockPalette" $ c_GetStockPalette sp-foreign import stdcall unsafe "windows.h GetStockObject"+foreign import WINDOWS_CCONV unsafe "windows.h GetStockObject"   c_GetStockPalette :: StockPalette -> IO HPALETTE  deletePalette :: HPALETTE -> IO () deletePalette p =   failIfFalse_ "DeletePalette" $ c_DeletePalette p-foreign import stdcall unsafe "windows.h DeleteObject"+foreign import WINDOWS_CCONV unsafe "windows.h DeleteObject"   c_DeletePalette :: HPALETTE -> IO Bool  ----------------------------------------------------------------

Graphics/Win32/GDI/Path.hs view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,13 +18,15 @@ -----------------------------------------------------------------------------  module Graphics.Win32.GDI.Path-	( beginPath, closeFigure, endPath, fillPath, flattenPath-	, pathToRegion, strokeAndFillPath, strokePath, widenPath-	) where+        ( beginPath, closeFigure, endPath, fillPath, flattenPath+        , pathToRegion, strokeAndFillPath, strokePath, widenPath+        ) where  import Graphics.Win32.GDI.Types import System.Win32.Types +#include "windows_cconv.h"+ ---------------------------------------------------------------- -- Paths ----------------------------------------------------------------@@ -32,56 +36,56 @@ beginPath :: HDC -> IO () beginPath dc =   failIfFalse_ "BeginPath" $ c_BeginPath dc-foreign import stdcall unsafe "windows.h BeginPath"+foreign import WINDOWS_CCONV unsafe "windows.h BeginPath"   c_BeginPath :: HDC -> IO Bool  closeFigure :: HDC -> IO () closeFigure dc =   failIfFalse_ "CloseFigure" $ c_CloseFigure dc-foreign import stdcall unsafe "windows.h CloseFigure"+foreign import WINDOWS_CCONV unsafe "windows.h CloseFigure"   c_CloseFigure :: HDC -> IO Bool  endPath :: HDC -> IO () endPath dc =   failIfFalse_ "EndPath" $ c_EndPath dc-foreign import stdcall unsafe "windows.h EndPath"+foreign import WINDOWS_CCONV unsafe "windows.h EndPath"   c_EndPath :: HDC -> IO Bool  fillPath :: HDC -> IO () fillPath dc =   failIfFalse_ "FillPath" $ c_FillPath dc-foreign import stdcall unsafe "windows.h FillPath"+foreign import WINDOWS_CCONV unsafe "windows.h FillPath"   c_FillPath :: HDC -> IO Bool  flattenPath :: HDC -> IO () flattenPath dc =   failIfFalse_ "FlattenPath" $ c_FlattenPath dc-foreign import stdcall unsafe "windows.h FlattenPath"+foreign import WINDOWS_CCONV unsafe "windows.h FlattenPath"   c_FlattenPath :: HDC -> IO Bool  pathToRegion :: HDC -> IO HRGN pathToRegion dc = do   ptr <- failIfNull "PathToRegion" $ c_PathToRegion dc   newForeignHANDLE ptr-foreign import stdcall unsafe "windows.h PathToRegion"+foreign import WINDOWS_CCONV unsafe "windows.h PathToRegion"   c_PathToRegion :: HDC -> IO PRGN  strokeAndFillPath :: HDC -> IO () strokeAndFillPath dc =   failIfFalse_ "StrokeAndFillPath" $ c_StrokeAndFillPath dc-foreign import stdcall unsafe "windows.h StrokeAndFillPath"+foreign import WINDOWS_CCONV unsafe "windows.h StrokeAndFillPath"   c_StrokeAndFillPath :: HDC -> IO Bool  strokePath :: HDC -> IO () strokePath dc =   failIfFalse_ "StrokePath" $ c_StrokePath dc-foreign import stdcall unsafe "windows.h StrokePath"+foreign import WINDOWS_CCONV unsafe "windows.h StrokePath"   c_StrokePath :: HDC -> IO Bool  widenPath :: HDC -> IO () widenPath dc =   failIfFalse_ "WidenPath" $ c_WidenPath dc-foreign import stdcall unsafe "windows.h WidenPath"+foreign import WINDOWS_CCONV unsafe "windows.h WidenPath"   c_WidenPath :: HDC -> IO Bool  ----------------------------------------------------------------

Graphics/Win32/GDI/Pen.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -20,6 +22,8 @@ import System.Win32.Types import Graphics.Win32.GDI.Types +##include "windows_cconv.h"+ #include <windows.h>  ----------------------------------------------------------------@@ -37,13 +41,13 @@ getStockPen :: StockPen -> IO HPEN getStockPen stockpen =   failIfNull "GetStockPen" $ c_GetStockPen stockpen-foreign import stdcall unsafe "windows.h GetStockObject"+foreign import WINDOWS_CCONV unsafe "windows.h GetStockObject"   c_GetStockPen :: StockPen -> IO HPEN  deletePen :: HPEN -> IO () deletePen pen =   failIfFalse_ "DeletePen" $ c_DeletePen pen-foreign import stdcall unsafe "windows.h DeleteObject"+foreign import WINDOWS_CCONV unsafe "windows.h DeleteObject"   c_DeletePen :: HPEN -> IO Bool  ----------------------------------------------------------------@@ -52,7 +56,7 @@  type PenStyle   = INT -#{enum PenStyle,                              // Pick one of these+#{enum PenStyle,  , pS_SOLID             = PS_SOLID            // default  , pS_DASH              = PS_DASH             // -------  , pS_DOT               = PS_DOT              // .......@@ -65,14 +69,14 @@  , pS_STYLE_MASK        = PS_STYLE_MASK       // all the above  } -#{enum PenStyle ,                             // "or" with one of these+#{enum PenStyle,  , pS_ENDCAP_ROUND      = PS_ENDCAP_ROUND     // default  , pS_ENDCAP_SQUARE     = PS_ENDCAP_SQUARE  , pS_ENDCAP_FLAT       = PS_ENDCAP_FLAT  , pS_ENDCAP_MASK       = PS_ENDCAP_MASK      // all the above  } -#{enum PenStyle,                              // "or" with one of these+#{enum PenStyle,  , pS_JOIN_ROUND        = PS_JOIN_ROUND       // default  , pS_JOIN_BEVEL        = PS_JOIN_BEVEL  , pS_JOIN_MITER        = PS_JOIN_MITER@@ -83,7 +87,7 @@ you'll have to define it. -} -#{enum PenStyle,                              // "or" with one of these+#{enum PenStyle,  , pS_COSMETIC          = PS_COSMETIC         // default  , pS_GEOMETRIC         = PS_GEOMETRIC  , pS_TYPE_MASK         = PS_TYPE_MASK        // all the above@@ -92,7 +96,7 @@ createPen :: PenStyle -> INT -> COLORREF -> IO HPEN createPen style n color =   failIfNull "CreatePen" $ c_CreatePen style n color-foreign import stdcall unsafe "windows.h CreatePen"+foreign import WINDOWS_CCONV unsafe "windows.h CreatePen"   c_CreatePen :: PenStyle -> INT -> COLORREF -> IO HPEN  -- Not very well supported on Win'95

Graphics/Win32/GDI/Region.hs view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -22,6 +24,8 @@  import Foreign +#include "windows_cconv.h"+ ---------------------------------------------------------------- -- Regions ----------------------------------------------------------------@@ -35,56 +39,56 @@   withForeignPtr src1 $ \ p_src1 ->   withForeignPtr src2 $ \ p_src2 ->   failIf badRegion "CombineRgn" $ c_CombineRgn p_dest p_src1 p_src2 mode-foreign import stdcall unsafe "windows.h CombineRgn"+foreign import WINDOWS_CCONV unsafe "windows.h CombineRgn"   c_CombineRgn :: PRGN -> PRGN -> PRGN -> ClippingMode -> IO RegionType  offsetRgn :: HRGN -> INT -> INT -> IO RegionType offsetRgn rgn xoff yoff =   withForeignPtr rgn $ \ p_rgn ->   failIf badRegion "OffsetRgn" $ c_OffsetRgn p_rgn xoff yoff-foreign import stdcall unsafe "windows.h OffsetRgn"+foreign import WINDOWS_CCONV unsafe "windows.h OffsetRgn"   c_OffsetRgn :: PRGN -> INT -> INT -> IO RegionType  getRgnBox :: HRGN -> LPRECT -> IO RegionType getRgnBox rgn p_rect =   withForeignPtr rgn $ \ p_rgn ->   failIf badRegion "GetRgnBox" $ c_GetRgnBox p_rgn p_rect-foreign import stdcall unsafe "windows.h GetRgnBox"+foreign import WINDOWS_CCONV unsafe "windows.h GetRgnBox"   c_GetRgnBox :: PRGN -> LPRECT -> IO RegionType  createEllipticRgn :: INT -> INT -> INT -> INT -> IO HRGN createEllipticRgn x0 y0 x1 y1 = do   ptr <- failIfNull "CreateEllipticRgn" $ c_CreateEllipticRgn x0 y0 x1 y1   newForeignHANDLE ptr-foreign import stdcall unsafe "windows.h CreateEllipticRgn"+foreign import WINDOWS_CCONV unsafe "windows.h CreateEllipticRgn"   c_CreateEllipticRgn :: INT -> INT -> INT -> INT -> IO PRGN  createEllipticRgnIndirect :: LPRECT -> IO HRGN createEllipticRgnIndirect rp = do   ptr <- failIfNull "CreateEllipticRgnIndirect" $ c_CreateEllipticRgnIndirect rp   newForeignHANDLE ptr-foreign import stdcall unsafe "windows.h CreateEllipticRgnIndirect"+foreign import WINDOWS_CCONV unsafe "windows.h CreateEllipticRgnIndirect"   c_CreateEllipticRgnIndirect :: LPRECT -> IO PRGN  createRectRgn :: INT -> INT -> INT -> INT -> IO HRGN createRectRgn x0 y0 x1 y1 = do   ptr <- failIfNull "CreateRectRgn" $ c_CreateRectRgn x0 y0 x1 y1   newForeignHANDLE ptr-foreign import stdcall unsafe "windows.h CreateRectRgn"+foreign import WINDOWS_CCONV unsafe "windows.h CreateRectRgn"   c_CreateRectRgn :: INT -> INT -> INT -> INT -> IO PRGN  createRectRgnIndirect :: LPRECT -> IO HRGN createRectRgnIndirect rp = do   ptr <- failIfNull "CreateRectRgnIndirect" $ c_CreateRectRgnIndirect rp   newForeignHANDLE ptr-foreign import stdcall unsafe "windows.h CreateRectRgnIndirect"+foreign import WINDOWS_CCONV unsafe "windows.h CreateRectRgnIndirect"   c_CreateRectRgnIndirect :: LPRECT -> IO PRGN  createRoundRectRgn :: INT -> INT -> INT -> INT -> INT -> INT -> IO HRGN createRoundRectRgn x0 y0 x1 y1 h w = do   ptr <- failIfNull "CreateRoundRectRgn" $ c_CreateRoundRectRgn x0 y0 x1 y1 h w   newForeignHANDLE ptr-foreign import stdcall unsafe "windows.h CreateRoundRectRgn"+foreign import WINDOWS_CCONV unsafe "windows.h CreateRoundRectRgn"   c_CreateRoundRectRgn :: INT -> INT -> INT -> INT -> INT -> INT -> IO PRGN  createPolygonRgn :: [POINT] -> PolyFillMode -> IO HRGN@@ -93,54 +97,54 @@   ptr <- failIfNull "CreatePolygonRgn" $     c_CreatePolygonRgn point_array npoints mode   newForeignHANDLE ptr-foreign import stdcall unsafe "windows.h CreatePolygonRgn"+foreign import WINDOWS_CCONV unsafe "windows.h CreatePolygonRgn"   c_CreatePolygonRgn :: Ptr POINT -> Int -> PolyFillMode -> IO PRGN  -- Needs to do proper error test for EqualRgn; GSL ??? -foreign import stdcall unsafe "windows.h EqualRgn"+foreign import WINDOWS_CCONV unsafe "windows.h EqualRgn"   equalRgn :: PRGN -> PRGN -> IO Bool  fillRgn :: HDC -> HRGN -> HBRUSH -> IO () fillRgn dc rgn brush =   withForeignPtr rgn $ \ p_rgn ->   failIfFalse_ "FillRgn" $ c_FillRgn dc p_rgn brush-foreign import stdcall unsafe "windows.h FillRgn"+foreign import WINDOWS_CCONV unsafe "windows.h FillRgn"   c_FillRgn :: HDC -> PRGN -> HBRUSH -> IO Bool  invertRgn :: HDC -> HRGN -> IO () invertRgn dc rgn =   withForeignPtr rgn $ \ p_rgn ->   failIfFalse_ "InvertRgn" $ c_InvertRgn dc p_rgn-foreign import stdcall unsafe "windows.h InvertRgn"+foreign import WINDOWS_CCONV unsafe "windows.h InvertRgn"   c_InvertRgn :: HDC -> PRGN -> IO Bool  paintRgn :: HDC -> HRGN -> IO () paintRgn dc rgn =   withForeignPtr rgn $ \ p_rgn ->   failIfFalse_ "PaintRgn" $ c_PaintRgn dc p_rgn-foreign import stdcall unsafe "windows.h PaintRgn"+foreign import WINDOWS_CCONV unsafe "windows.h PaintRgn"   c_PaintRgn :: HDC -> PRGN -> IO Bool  frameRgn :: HDC -> HRGN -> HBRUSH -> Int -> Int -> IO () frameRgn dc rgn brush w h =   withForeignPtr rgn $ \ p_rgn ->   failIfFalse_ "FrameRgn" $ c_FrameRgn dc p_rgn brush w h-foreign import stdcall unsafe "windows.h FrameRgn"+foreign import WINDOWS_CCONV unsafe "windows.h FrameRgn"   c_FrameRgn :: HDC -> PRGN -> HBRUSH -> Int -> Int -> IO Bool  ptInRegion :: HRGN -> Int -> Int -> IO Bool ptInRegion rgn x y =   withForeignPtr rgn $ \ p_rgn ->   c_PtInRegion p_rgn x y-foreign import stdcall unsafe "windows.h PtInRegion"+foreign import WINDOWS_CCONV unsafe "windows.h PtInRegion"   c_PtInRegion :: PRGN -> Int -> Int -> IO Bool  rectInRegion :: HRGN -> RECT -> IO Bool rectInRegion rgn rect =   withForeignPtr rgn $ \ p_rgn ->   withRECT rect $ c_RectInRegion p_rgn-foreign import stdcall unsafe "windows.h RectInRegion"+foreign import WINDOWS_CCONV unsafe "windows.h RectInRegion"   c_RectInRegion :: PRGN -> Ptr RECT -> IO Bool  ----------------------------------------------------------------

Graphics/Win32/GDI/Types.hsc view

@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Win32.GDI.Types@@ -17,42 +15,42 @@  module Graphics.Win32.GDI.Types {-  -- still incomplete-	( POINT,        marshall_point, unmarshall_point-	, ListPOINT,    marshall_ListPOINT_-	, ListLenPOINT, marshall_ListLenPOINT_-	, RECT,         marshall_rect, unmarshall_rect-	, SIZE,         marshall_size, unmarshall_size-	, nullPtr-	, HBITMAP	, MbHBITMAP-	, HFONT		, MbHFONT-	, HCURSOR	, MbHCURSOR-	, HICON		, MbHICON-	, HRGN		, MbHRGN-	, PRGN-	, HPALETTE	, MbHPALETTE-	, HBRUSH	, MbHBRUSH-	, HPEN		, MbHPEN-	, HACCEL	--, MbHACCEL-	, HDC		, MbHDC-	, HDWP          , MbHDWP-	, HWND		, MbHWND-	, HMENU		, MbHMENU-	, PolyFillMode-	, ArcDirection-	, MbArcDirection-	, GraphicsMode-	, MbGraphicsMode-	, BackgroundMode-	, HatchStyle-	, StretchBltMode-	, COLORREF-	, TextAlignment-	, ClippingMode-	, RegionType-	, gDI_ERROR-	)+        ( POINT,        marshall_point, unmarshall_point+        , ListPOINT,    marshall_ListPOINT_+        , ListLenPOINT, marshall_ListLenPOINT_+        , RECT,         marshall_rect, unmarshall_rect+        , SIZE,         marshall_size, unmarshall_size+        , nullPtr+        , HBITMAP       , MbHBITMAP+        , HFONT         , MbHFONT+        , HCURSOR       , MbHCURSOR+        , HICON         , MbHICON+        , HRGN          , MbHRGN+        , PRGN+        , HPALETTE      , MbHPALETTE+        , HBRUSH        , MbHBRUSH+        , HPEN          , MbHPEN+        , HACCEL        --, MbHACCEL+        , HDC           , MbHDC+        , HDWP          , MbHDWP+        , HWND          , MbHWND+        , HMENU         , MbHMENU+        , PolyFillMode+        , ArcDirection+        , MbArcDirection+        , GraphicsMode+        , MbGraphicsMode+        , BackgroundMode+        , HatchStyle+        , StretchBltMode+        , COLORREF+        , TextAlignment+        , ClippingMode+        , RegionType+        , gDI_ERROR+        ) -}-	where+        where  import System.Win32.Types @@ -215,11 +213,11 @@ type   HWND       = HANDLE type MbHWND       = Maybe HWND -#{enum HWND, castUINTToPtr- , hWND_BOTTOM    = HWND_BOTTOM- , hWND_NOTOPMOST = HWND_NOTOPMOST- , hWND_TOP       = HWND_TOP- , hWND_TOPMOST   = HWND_TOPMOST+#{enum HWND, castUINTPtrToPtr+ , hWND_BOTTOM    = (UINT_PTR)HWND_BOTTOM+ , hWND_NOTOPMOST = (UINT_PTR)HWND_NOTOPMOST+ , hWND_TOP       = (UINT_PTR)HWND_TOP+ , hWND_TOPMOST   = (UINT_PTR)HWND_TOPMOST  }  type   HMENU      = HANDLE

Graphics/Win32/Icon.hs view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,29 +19,38 @@  module Graphics.Win32.Icon where +import Foreign (Ptr) import Graphics.Win32.GDI.Types import System.Win32.Types +#include "windows_cconv.h"+ ---------------------------------------------------------------- -- Icons ---------------------------------------------------------------- +createIcon :: HINSTANCE -> Int -> Int -> BYTE -> BYTE -> Ptr BYTE -> Ptr BYTE -> IO HICON+createIcon instance_ width height planes bitsPixel andBits xorBits =+    failIfNull "CreateIcon" $ c_CreateIcon instance_ width height planes bitsPixel andBits xorBits+foreign import WINDOWS_CCONV unsafe "windows.h CreateIcon"+    c_CreateIcon :: HINSTANCE -> Int -> Int -> BYTE -> BYTE -> Ptr BYTE -> Ptr BYTE -> IO HICON+ copyIcon :: HICON -> IO HICON copyIcon icon =   failIfNull "CopyIcon" $ c_CopyIcon icon-foreign import stdcall unsafe "windows.h CopyIcon"+foreign import WINDOWS_CCONV unsafe "windows.h CopyIcon"   c_CopyIcon :: HICON -> IO HICON  drawIcon :: HDC -> Int -> Int -> HICON -> IO () drawIcon dc x y icon =   failIfFalse_ "DrawIcon" $ c_DrawIcon dc x y icon-foreign import stdcall unsafe "windows.h DrawIcon"+foreign import WINDOWS_CCONV unsafe "windows.h DrawIcon"   c_DrawIcon :: HDC -> Int -> Int -> HICON -> IO Bool  destroyIcon :: HICON -> IO () destroyIcon icon =   failIfFalse_ "DestroyIcon" $ c_DestroyIcon icon-foreign import stdcall unsafe "windows.h DestroyIcon"+foreign import WINDOWS_CCONV unsafe "windows.h DestroyIcon"   c_DestroyIcon :: HICON -> IO Bool  ----------------------------------------------------------------

Graphics/Win32/Key.hsc view

@@ -1,10 +1,12 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- 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>@@ -17,107 +19,256 @@  module Graphics.Win32.Key where -import Graphics.Win32.GDI.Types-import System.Win32.Types- import Control.Monad (liftM)+import Graphics.Win32.GDI.Types (HWND)+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 stdcall unsafe "windows.h EnableWindow"+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  getActiveWindow :: IO (Maybe HWND) getActiveWindow = liftM ptrToMaybe c_GetActiveWindow-foreign import stdcall unsafe "windows.h GetActiveWindow"+foreign import WINDOWS_CCONV unsafe "windows.h GetActiveWindow"   c_GetActiveWindow :: IO HWND -foreign import stdcall unsafe "windows.h GetAsyncKeyState"+foreign import WINDOWS_CCONV unsafe "windows.h GetAsyncKeyState"   getAsyncKeyState :: Int -> IO WORD  getFocus :: IO (Maybe HWND) getFocus = liftM ptrToMaybe c_GetFocus-foreign import stdcall unsafe "windows.h GetFocus"+foreign import WINDOWS_CCONV unsafe "windows.h GetFocus"   c_GetFocus :: IO HWND -foreign import stdcall unsafe "windows.h GetKBCodePage"+foreign import WINDOWS_CCONV unsafe "windows.h GetKBCodePage"   getKBCodePage :: IO UINT -foreign import stdcall unsafe "windows.h IsWindowEnabled"+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+ }

+ Graphics/Win32/LayeredWindow.hsc view

@@ -0,0 +1,57 @@+{-# 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 (module Graphics.Win32.LayeredWindow, Graphics.Win32.Window.c_GetWindowLongPtr ) where
+import Control.Monad   ( void )
+import Data.Bits       ( (.|.) )
+import Foreign.Ptr     ( Ptr )
+import Graphics.Win32.GDI.AlphaBlend ( BLENDFUNCTION )
+import Graphics.Win32.GDI.Types      ( COLORREF, HDC, SIZE, SIZE, POINT )
+import Graphics.Win32.Window         ( WindowStyleEx, c_GetWindowLongPtr, c_SetWindowLongPtr )
+import System.Win32.Types ( DWORD, HANDLE, BYTE, BOOL, 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 $ c_SetWindowLongPtr w gWL_EXSTYLE (flg .|. (fromIntegral wS_EX_LAYERED))
+
+-- 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
+
+#{enum DWORD,
+ , uLW_ALPHA    = ULW_ALPHA
+ , uLW_COLORKEY = ULW_COLORKEY
+ , uLW_OPAQUE   = ULW_OPAQUE
+ }
+

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -69,40 +71,42 @@ import Foreign import Control.Monad (liftM) +##include "windows_cconv.h"+ #include <windows.h>  type MenuName = LPCTSTR  checkMenuItem :: HMENU -> MenuItem -> MenuFlag -> IO Bool checkMenuItem menu item check = do-  rv <- failIf (== -1) "CheckMenuItem" $ c_CheckMenuItem menu item check+  rv <- failIf (== maxBound) "CheckMenuItem" $ c_CheckMenuItem menu item check   return (rv == mF_CHECKED)-foreign import stdcall unsafe "windows.h CheckMenuItem"+foreign import WINDOWS_CCONV unsafe "windows.h CheckMenuItem"   c_CheckMenuItem :: HMENU -> UINT -> UINT -> IO DWORD  checkMenuRadioItem :: HMENU -> MenuItem -> MenuItem -> MenuItem -> MenuFlag -> IO () checkMenuRadioItem menu first_id last_id check flags =   failIfFalse_ "CheckMenuRadioItem" $     c_CheckMenuRadioItem menu first_id last_id check flags-foreign import stdcall unsafe "windows.h CheckMenuRadioItem"+foreign import WINDOWS_CCONV unsafe "windows.h CheckMenuRadioItem"   c_CheckMenuRadioItem :: HMENU -> UINT -> UINT -> UINT -> UINT -> IO Bool  createMenu :: IO HMENU createMenu =   failIfNull "CreateMenu" $ c_CreateMenu-foreign import stdcall unsafe "windows.h CreateMenu"+foreign import WINDOWS_CCONV unsafe "windows.h CreateMenu"   c_CreateMenu :: IO HMENU  createPopupMenu :: IO HMENU createPopupMenu =   failIfNull "CreatePopupMenu" $ c_CreatePopupMenu-foreign import stdcall unsafe "windows.h CreatePopupMenu"+foreign import WINDOWS_CCONV unsafe "windows.h CreatePopupMenu"   c_CreatePopupMenu :: IO HMENU  drawMenuBar :: HWND -> IO () drawMenuBar wnd =   failIfFalse_ "DrawMenuBar" $ c_DrawMenuBar wnd-foreign import stdcall unsafe "windows.h DrawMenuBar"+foreign import WINDOWS_CCONV unsafe "windows.h DrawMenuBar"   c_DrawMenuBar :: HWND -> IO Bool  type MenuState = MenuFlag@@ -110,7 +114,7 @@ enableMenuItem :: HMENU -> MenuItem -> MenuFlag -> IO MenuState enableMenuItem menu item flag =   failIf (== 0xffffffff) "EnableMenuItem" $ c_EnableMenuItem menu item flag-foreign import stdcall unsafe "windows.h EnableMenuItem"+foreign import WINDOWS_CCONV unsafe "windows.h EnableMenuItem"   c_EnableMenuItem :: HMENU -> UINT -> UINT -> IO MenuState  type GMDIFlag = UINT@@ -210,56 +214,56 @@  , sC_SEPARATOR         = SC_SEPARATOR  } -foreign import stdcall unsafe "windows.h IsMenu" isMenu :: HMENU -> IO Bool+foreign import WINDOWS_CCONV unsafe "windows.h IsMenu" isMenu :: HMENU -> IO Bool  getSystemMenu :: HWND  -> Bool ->     IO (Maybe HMENU) getSystemMenu wnd revert =   liftM ptrToMaybe $ c_GetSystemMenu wnd revert-foreign import stdcall unsafe "windows.h GetSystemMenu"+foreign import WINDOWS_CCONV unsafe "windows.h GetSystemMenu"   c_GetSystemMenu :: HWND  -> Bool ->     IO HMENU  getMenu :: HWND  ->             IO (Maybe HMENU) getMenu wnd =   liftM ptrToMaybe $ c_GetMenu wnd-foreign import stdcall unsafe "windows.h GetMenu"+foreign import WINDOWS_CCONV unsafe "windows.h GetMenu"   c_GetMenu :: HWND  ->             IO HMENU  getMenuDefaultItem :: HMENU -> Bool -> GMDIFlag -> IO MenuItem getMenuDefaultItem menu bypos flags =-  failIf (== -1) "GetMenuDefaultItem" $ c_GetMenuDefaultItem menu bypos flags-foreign import stdcall unsafe "windows.h GetMenuDefaultItem"+  failIf (== maxBound) "GetMenuDefaultItem" $ c_GetMenuDefaultItem menu bypos flags+foreign import WINDOWS_CCONV unsafe "windows.h GetMenuDefaultItem"   c_GetMenuDefaultItem :: HMENU -> Bool -> UINT -> IO UINT  getMenuState :: HMENU -> MenuItem -> MenuFlag -> IO MenuState getMenuState menu item flags =-  failIf (== -1) "GetMenuState" $ c_GetMenuState menu item flags-foreign import stdcall unsafe "windows.h GetMenuState"+  failIf (== maxBound) "GetMenuState" $ c_GetMenuState menu item flags+foreign import WINDOWS_CCONV unsafe "windows.h GetMenuState"   c_GetMenuState :: HMENU -> UINT -> UINT -> IO MenuState  getSubMenu :: HMENU -> MenuItem -> IO (Maybe HMENU) getSubMenu menu pos =   liftM ptrToMaybe $ c_GetSubMenu menu pos-foreign import stdcall unsafe "windows.h GetSubMenu"+foreign import WINDOWS_CCONV unsafe "windows.h GetSubMenu"   c_GetSubMenu :: HMENU -> UINT -> IO HMENU  setMenu :: HWND -> HMENU -> IO () setMenu wnd menu =   failIfFalse_ "SetMenu" $ c_SetMenu wnd menu-foreign import stdcall unsafe "windows.h SetMenu"+foreign import WINDOWS_CCONV unsafe "windows.h SetMenu"   c_SetMenu :: HWND -> HMENU -> IO Bool  getMenuItemCount :: HMENU -> IO Int getMenuItemCount menu =-  failIf (== -1) "GetMenuItemCount" $ c_GetMenuItemCount menu-foreign import stdcall unsafe "windows.h GetMenuItemCount"+  failIf (== maxBound) "GetMenuItemCount" $ c_GetMenuItemCount menu+foreign import WINDOWS_CCONV unsafe "windows.h GetMenuItemCount"   c_GetMenuItemCount :: HMENU -> IO Int  type MenuID = UINT  getMenuItemID :: HMENU -> MenuItem -> IO MenuID getMenuItemID menu item =-  failIf (== -1) "GetMenuItemID" $ c_GetMenuItemID menu item-foreign import stdcall unsafe "windows.h GetMenuItemID"+  failIf (== maxBound) "GetMenuItemID" $ c_GetMenuItemID menu item+foreign import WINDOWS_CCONV unsafe "windows.h GetMenuItemID"   c_GetMenuItemID :: HMENU -> UINT -> IO MenuID  data MenuItemInfo@@ -341,7 +345,7 @@   pokeFMask p_info mask   failIfFalse_ "GetMenuItemInfo" $ c_GetMenuItemInfo menu item bypos p_info   peekMenuItemInfo p_info-foreign import stdcall unsafe "windows.h GetMenuItemInfoW"+foreign import WINDOWS_CCONV unsafe "windows.h GetMenuItemInfoW"   c_GetMenuItemInfo :: HMENU -> UINT -> Bool -> Ptr MenuItemInfo -> IO Bool  getMenuItemRect :: HWND -> HMENU -> MenuItem -> IO RECT@@ -349,17 +353,17 @@   allocaRECT $ \ p_rect -> do   failIfFalse_ "GetMenuItemRect" $ c_GetMenuItemRect wnd menu item p_rect   peekRECT p_rect-foreign import stdcall unsafe "windows.h GetMenuItemRect"+foreign import WINDOWS_CCONV unsafe "windows.h GetMenuItemRect"   c_GetMenuItemRect :: HWND -> HMENU -> UINT -> LPRECT -> IO Bool -foreign import stdcall unsafe "windows.h HiliteMenuItem"+foreign import WINDOWS_CCONV unsafe "windows.h HiliteMenuItem"   hiliteMenuItem :: HWND  -> HMENU -> MenuItem -> MenuFlag -> IO Bool  insertMenuItem :: HMENU -> MenuItem -> Bool -> MenuItemInfo -> IO () insertMenuItem menu item bypos info =   withMenuItemInfo info $ \ p_info ->   failIfFalse_ "InsertMenuItem" $ c_InsertMenuItem menu item bypos p_info-foreign import stdcall unsafe "windows.h InsertMenuItemW"+foreign import WINDOWS_CCONV unsafe "windows.h InsertMenuItemW"   c_InsertMenuItem :: HMENU -> UINT -> Bool -> Ptr MenuItemInfo -> IO Bool  type Menu = LPCTSTR@@ -369,7 +373,7 @@ loadMenu :: Maybe HINSTANCE -> Menu -> IO HMENU loadMenu mb_inst menu =   failIfNull "LoadMenu" $ c_LoadMenu (maybePtr mb_inst) menu-foreign import stdcall unsafe "windows.h LoadMenuW"+foreign import WINDOWS_CCONV unsafe "windows.h LoadMenuW"   c_LoadMenu :: HINSTANCE -> Menu -> IO HMENU  -- Dealing with mappings to/from structs is a pain in GC,@@ -385,26 +389,26 @@ setMenuDefaultItem :: HMENU -> MenuItem -> Bool -> IO () setMenuDefaultItem menu item bypos =   failIfFalse_ "SetMenuDefaultItem" $ c_SetMenuDefaultItem menu item bypos-foreign import stdcall unsafe "windows.h SetMenuDefaultItem"+foreign import WINDOWS_CCONV unsafe "windows.h SetMenuDefaultItem"   c_SetMenuDefaultItem :: HMENU -> MenuItem -> Bool -> IO Bool  setMenuItemBitmaps :: HMENU -> MenuItem -> MenuFlag -> HBITMAP -> HBITMAP -> IO () setMenuItemBitmaps menu pos flags bm_unchecked bm_checked =   failIfFalse_ "SetMenuItemBitmaps" $     c_SetMenuItemBitmaps menu pos flags bm_unchecked bm_checked-foreign import stdcall unsafe "windows.h SetMenuItemBitmaps"+foreign import WINDOWS_CCONV unsafe "windows.h SetMenuItemBitmaps"   c_SetMenuItemBitmaps :: HMENU -> UINT -> UINT -> HBITMAP -> HBITMAP -> IO Bool  destroyMenu :: HMENU -> IO () destroyMenu menu =   failIfFalse_ "DestroyMenu" $ c_DestroyMenu menu-foreign import stdcall unsafe "windows.h DestroyMenu"+foreign import WINDOWS_CCONV unsafe "windows.h DestroyMenu"   c_DestroyMenu :: HMENU -> IO Bool  deleteMenu :: HMENU -> MenuItem -> MenuFlag -> IO () deleteMenu menu item flag =   failIfFalse_ "DeleteMenu" $ c_DeleteMenu menu item flag-foreign import stdcall unsafe "windows.h DeleteMenu"+foreign import WINDOWS_CCONV unsafe "windows.h DeleteMenu"   c_DeleteMenu :: HMENU -> UINT -> UINT -> IO Bool  setMenuItemInfo :: HMENU -> MenuItem -> Bool -> MenuItemMask -> MenuItemInfo -> IO ()@@ -412,14 +416,14 @@   withMenuItemInfo info $ \ p_info -> do   pokeFMask p_info mask   failIfFalse_ "SetMenuItemInfo" $ c_SetMenuItemInfo menu item bypos p_info-foreign import stdcall unsafe "windows.h SetMenuItemInfoW"+foreign import WINDOWS_CCONV unsafe "windows.h SetMenuItemInfoW"   c_SetMenuItemInfo :: HMENU -> UINT -> Bool -> Ptr MenuItemInfo -> IO Bool  trackPopupMenu :: HMENU -> TrackMenuFlag -> Int -> Int -> HWND -> RECT -> IO () trackPopupMenu menu flags x y wnd rect =   withRECT rect $ \ p_rect ->   failIfFalse_ "TrackPopupMenu" $ c_TrackPopupMenu menu flags x y 0 wnd p_rect-foreign import stdcall unsafe "windows.h TrackPopupMenu"+foreign import WINDOWS_CCONV unsafe "windows.h TrackPopupMenu"   c_TrackPopupMenu :: HMENU -> TrackMenuFlag -> Int -> Int -> Int -> HWND -> LPRECT -> IO Bool  type TPMPARAMS = ()@@ -436,37 +440,37 @@ trackPopupMenuEx menu flags x y wnd mb_p_rect =   maybeWith withTPMPARAMS mb_p_rect $ \ p_ptmp ->   failIfFalse_ "TrackPopupMenuEx" $ c_TrackPopupMenuEx menu flags x y wnd p_ptmp-foreign import stdcall unsafe "windows.h TrackPopupMenuEx"+foreign import WINDOWS_CCONV unsafe "windows.h TrackPopupMenuEx"   c_TrackPopupMenuEx :: HMENU -> TrackMenuFlag -> Int -> Int -> HWND -> Ptr TPMPARAMS -> IO Bool  -- Note: these 3 assume the flags don't include MF_BITMAP or MF_OWNERDRAW -- (which are hidden by this interface) -appendMenu :: HMENU -> MenuFlag -> MenuID -> String -> IO ()+appendMenu :: HMENU -> MenuFlag -> MenuID -> Maybe String -> IO () appendMenu menu flags id_item name =-  withTString name $ \ c_name ->+  maybeWith withTString name $ \ c_name ->   failIfFalse_ "AppendMenu" $ c_AppendMenu menu flags id_item c_name-foreign import stdcall unsafe "windows.h AppendMenuW"+foreign import WINDOWS_CCONV unsafe "windows.h AppendMenuW"   c_AppendMenu :: HMENU -> UINT -> MenuID -> LPCTSTR -> IO Bool -insertMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> String -> IO ()+insertMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> Maybe String -> IO () insertMenu menu item flags id_item name =-  withTString name $ \ c_name ->+  maybeWith withTString name $ \ c_name ->   failIfFalse_ "InsertMenu" $ c_InsertMenu menu item flags id_item c_name-foreign import stdcall unsafe "windows.h InsertMenuW"+foreign import WINDOWS_CCONV unsafe "windows.h InsertMenuW"   c_InsertMenu :: HMENU -> UINT -> UINT -> MenuID -> LPCTSTR -> IO Bool -modifyMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> String -> IO ()+modifyMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> Maybe String -> IO () modifyMenu menu item flags id_item name =-  withTString name $ \ c_name ->+  maybeWith withTString name $ \ c_name ->   failIfFalse_ "ModifyMenu" $ c_ModifyMenu menu item flags id_item c_name-foreign import stdcall unsafe "windows.h ModifyMenuW"+foreign import WINDOWS_CCONV unsafe "windows.h ModifyMenuW"   c_ModifyMenu :: HMENU -> UINT -> UINT -> MenuID -> LPCTSTR -> IO Bool  removeMenu :: HMENU -> MenuItem -> MenuFlag -> IO () removeMenu menu pos flags =   failIfFalse_ "RemoveMenu" $ c_RemoveMenu menu pos flags-foreign import stdcall unsafe "windows.h RemoveMenu"+foreign import WINDOWS_CCONV unsafe "windows.h RemoveMenu"   c_RemoveMenu :: HMENU -> UINT -> UINT -> IO Bool  ----------------------------------------------------------------

Graphics/Win32/Message.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -19,6 +21,8 @@  import System.Win32.Types +##include "windows_cconv.h"+ #include <windows.h>  type WindowMessage   = DWORD@@ -154,12 +158,13 @@  , wM_QUEUESYNC         = WM_QUEUESYNC  , wM_USER              = WM_USER  , wM_APP               = WM_APP+ , wM_SETICON           = WM_SETICON  }  registerWindowMessage :: String -> IO WindowMessage registerWindowMessage msg =   withTString msg c_RegisterWindowMessage-foreign import stdcall unsafe "windows.h RegisterWindowMessageW"+foreign import WINDOWS_CCONV unsafe "windows.h RegisterWindowMessageW"   c_RegisterWindowMessage :: LPCTSTR -> IO WindowMessage  -- These are WM_SIZE specific@@ -169,6 +174,8 @@  , sIZE_MAXIMIZED       = SIZE_MAXIMIZED  , sIZE_MAXSHOW         = SIZE_MAXSHOW  , sIZE_MAXHIDE         = SIZE_MAXHIDE+ , iCON_SMALL           = ICON_SMALL+ , iCON_BIG             = ICON_BIG  }  ----------------------------------------------------------------

Graphics/Win32/Misc.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -23,8 +25,9 @@ import Data.Maybe import Foreign +##include "windows_cconv.h"+ #include <windows.h>-#include "gettime.h"  ---------------------------------------------------------------- -- Resources@@ -48,39 +51,39 @@ loadAccelerators :: Maybe HINSTANCE -> Accelerator -> IO HACCEL loadAccelerators mb_inst accel =   failIfNull "LoadAccelerators" $ c_LoadAccelerators (maybePtr mb_inst) accel-foreign import stdcall unsafe "windows.h LoadAcceleratorsW"+foreign import WINDOWS_CCONV unsafe "windows.h LoadAcceleratorsW"   c_LoadAccelerators :: HINSTANCE -> Accelerator -> IO HACCEL  loadCursor :: Maybe HINSTANCE -> Cursor -> IO HCURSOR loadCursor mb_inst cursor =   failIfNull "LoadCursor" $ c_LoadCursor (maybePtr mb_inst) cursor-foreign import stdcall unsafe "windows.h LoadCursorW"+foreign import WINDOWS_CCONV unsafe "windows.h LoadCursorW"   c_LoadCursor :: HINSTANCE -> Cursor -> IO HCURSOR  loadIcon :: Maybe HINSTANCE -> Icon -> IO HICON loadIcon mb_inst icon =   failIfNull "LoadIcon" $ c_LoadIcon (maybePtr mb_inst) icon-foreign import stdcall unsafe "windows.h LoadIconW"+foreign import WINDOWS_CCONV unsafe "windows.h LoadIconW"   c_LoadIcon :: HINSTANCE -> Icon -> IO HICON -#{enum Cursor, castUINTToPtr- , iDC_ARROW        = (UINT)IDC_ARROW- , iDC_IBEAM        = (UINT)IDC_IBEAM- , iDC_WAIT         = (UINT)IDC_WAIT- , iDC_CROSS        = (UINT)IDC_CROSS- , iDC_UPARROW      = (UINT)IDC_UPARROW- , iDC_SIZENWSE     = (UINT)IDC_SIZENWSE- , iDC_SIZENESW     = (UINT)IDC_SIZENESW- , iDC_SIZEWE       = (UINT)IDC_SIZEWE- , iDC_SIZENS       = (UINT)IDC_SIZENS+#{enum Cursor, castUINTPtrToPtr+ , iDC_ARROW        = (UINT_PTR)IDC_ARROW+ , iDC_IBEAM        = (UINT_PTR)IDC_IBEAM+ , iDC_WAIT         = (UINT_PTR)IDC_WAIT+ , iDC_CROSS        = (UINT_PTR)IDC_CROSS+ , iDC_UPARROW      = (UINT_PTR)IDC_UPARROW+ , iDC_SIZENWSE     = (UINT_PTR)IDC_SIZENWSE+ , iDC_SIZENESW     = (UINT_PTR)IDC_SIZENESW+ , iDC_SIZEWE       = (UINT_PTR)IDC_SIZEWE+ , iDC_SIZENS       = (UINT_PTR)IDC_SIZENS  } -#{enum Icon, castUINTToPtr- , iDI_APPLICATION  = (UINT)IDI_APPLICATION- , iDI_HAND         = (UINT)IDI_HAND- , iDI_QUESTION     = (UINT)IDI_QUESTION- , iDI_EXCLAMATION  = (UINT)IDI_EXCLAMATION- , iDI_ASTERISK     = (UINT)IDI_ASTERISK+#{enum Icon, castUINTPtrToPtr+ , iDI_APPLICATION  = (UINT_PTR)IDI_APPLICATION+ , iDI_HAND         = (UINT_PTR)IDI_HAND+ , iDI_QUESTION     = (UINT_PTR)IDI_QUESTION+ , iDI_EXCLAMATION  = (UINT_PTR)IDI_EXCLAMATION+ , iDI_ASTERISK     = (UINT_PTR)IDI_ASTERISK  }  ----------------------------------------------------------------@@ -125,12 +128,12 @@  -- Note: if the error is ever raised, we're in a very sad way! -messageBox :: HWND -> String -> String -> MBStyle -> IO MBStatus+messageBox :: Maybe HWND -> String -> String -> MBStyle -> IO MBStatus messageBox wnd text caption style =   withTString text $ \ c_text ->   withTString caption $ \ c_caption ->-  failIfZero "MessageBox" $ c_MessageBox wnd c_text c_caption style-foreign import stdcall unsafe "windows.h MessageBoxW"+  failIfZero "MessageBox" $ c_MessageBox (maybePtr wnd) c_text c_caption style+foreign import WINDOWS_CCONV safe "windows.h MessageBoxW"   c_MessageBox :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus  ----------------------------------------------------------------@@ -148,7 +151,7 @@ getStdHandle :: StdHandleId -> IO HANDLE getStdHandle hid =   failIf (== iNVALID_HANDLE_VALUE) "GetStdHandle" $ c_GetStdHandle hid-foreign import stdcall unsafe "windows.h GetStdHandle"+foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle"   c_GetStdHandle :: StdHandleId -> IO HANDLE  ----------------------------------------------------------------@@ -181,20 +184,20 @@   allocaPOINT $ \ p_pt -> do   failIfFalse_ "GetCursorPos" $ c_GetCursorPos p_pt   peekPOINT p_pt-foreign import stdcall unsafe "windows.h GetCursorPos"+foreign import WINDOWS_CCONV unsafe "windows.h GetCursorPos"   c_GetCursorPos :: Ptr POINT -> IO Bool  setCursorPos :: POINT -> IO () setCursorPos (x,y) =   failIfFalse_ "setCursorPos" $ c_SetCursorPos x y-foreign import stdcall unsafe "windows.h SetCursorPos"+foreign import WINDOWS_CCONV unsafe "windows.h SetCursorPos"   c_SetCursorPos :: LONG -> LONG -> IO Bool  clipCursor :: RECT -> IO () clipCursor rect =   withRECT rect $ \ p_rect ->   failIfFalse_ "ClipCursor" $ c_ClipCursor p_rect-foreign import stdcall unsafe "windows.h ClipCursor"+foreign import WINDOWS_CCONV unsafe "windows.h ClipCursor"   c_ClipCursor :: Ptr RECT -> IO Bool  getClipCursor :: IO RECT@@ -202,7 +205,7 @@   allocaRECT $ \ p_rect -> do   failIfFalse_ "GetClipCursor" $ c_GetClipCursor p_rect   peekRECT p_rect-foreign import stdcall unsafe "windows.h GetClipCursor"+foreign import WINDOWS_CCONV unsafe "windows.h GetClipCursor"   c_GetClipCursor :: Ptr RECT -> IO Bool  ----------------------------------------------------------------@@ -222,7 +225,7 @@ exitWindowsEx :: ExitOption -> IO () exitWindowsEx opt =   failIfFalse_ "ExitWindowsEx" $ c_ExitWindowsEx opt 0-foreign import stdcall unsafe "windows.h ExitWindowsEx"+foreign import WINDOWS_CCONV unsafe "windows.h ExitWindowsEx"   c_ExitWindowsEx :: ExitOption -> DWORD -> IO Bool  exitWindows :: IO ()@@ -248,13 +251,13 @@ messageBeep :: Maybe Beep -> IO () messageBeep mb_beep =   c_MessageBeep (maybeBeep mb_beep)-foreign import stdcall unsafe "windows.h MessageBeep"+foreign import WINDOWS_CCONV unsafe "windows.h MessageBeep"   c_MessageBeep :: Beep -> IO ()  beep :: WORD -> MbDuration -> IO () beep freq mb_dur =   failIfFalse_ "Beep" $ c_Beep freq (maybeDuration mb_dur)-foreign import stdcall unsafe "windows.h Beep"+foreign import WINDOWS_CCONV unsafe "windows.h Beep"   c_Beep :: WORD -> Duration -> IO Bool  ----------------------------------------------------------------@@ -265,26 +268,26 @@  type TIMERPROC = FunPtr (HWND -> UINT -> TimerId -> DWORD -> IO ()) --- ToDo: support the other two forms of timer initialisation+-- TODO: support the other two forms of timer initialisation  -- Cause WM_TIMER events to be sent to window callback  setWinTimer :: HWND -> TimerId -> UINT -> IO TimerId setWinTimer wnd timer elapse =   failIfZero "SetTimer" $ c_SetTimer wnd timer elapse nullFunPtr-foreign import stdcall unsafe "windows.h SetTimer"+foreign import WINDOWS_CCONV unsafe "windows.h SetTimer"   c_SetTimer :: HWND -> TimerId -> UINT -> TIMERPROC -> IO TimerId  killTimer :: Maybe HWND -> TimerId -> IO () killTimer mb_wnd timer =   failIfFalse_ "KillTimer" $ c_KillTimer (maybePtr mb_wnd) timer-foreign import stdcall unsafe "windows.h KillTimer"+foreign import WINDOWS_CCONV unsafe "windows.h KillTimer"   c_KillTimer :: HWND -> TimerId -> IO Bool  -- For documentation purposes: type MilliSeconds = DWORD -foreign import stdcall unsafe "windows.h timeGetTime"+foreign import WINDOWS_CCONV unsafe "windows.h timeGetTime"   timeGetTime :: IO MilliSeconds  ----------------------------------------------------------------

Graphics/Win32/Resource.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -21,13 +23,15 @@  import Foreign +##include "windows_cconv.h"+ #include <windows.h>  beginUpdateResource :: String -> Bool -> IO HANDLE beginUpdateResource name del =   withTString name $ \ c_name ->   failIfNull "BeginUpdateResource" $ c_BeginUpdateResource c_name del-foreign import stdcall unsafe "windows.h BeginUpdateResourceW"+foreign import WINDOWS_CCONV unsafe "windows.h BeginUpdateResourceW"   c_BeginUpdateResource :: LPCTSTR -> Bool -> IO HANDLE  type ResourceImageType = UINT@@ -45,42 +49,42 @@ copyImage :: HANDLE -> ResourceImageType -> Int -> Int -> UINT -> IO HANDLE copyImage h ty x y flags =   failIfNull "CopyImage" $ c_CopyImage h ty x y flags-foreign import stdcall unsafe "windows.h CopyImage"+foreign import WINDOWS_CCONV unsafe "windows.h CopyImage"   c_CopyImage :: HANDLE -> ResourceImageType -> Int -> Int -> UINT -> IO HANDLE  endUpdateResource :: HANDLE -> BOOL -> IO () endUpdateResource h discard =   failIfFalse_ "EndUpdateResource" $ c_EndUpdateResource h discard-foreign import stdcall unsafe "windows.h EndUpdateResourceW"+foreign import WINDOWS_CCONV unsafe "windows.h EndUpdateResourceW"   c_EndUpdateResource :: HANDLE -> BOOL -> IO Bool  type ResourceType = LPCTSTR -#{enum ResourceType, castUINTToPtr- , rT_ACCELERATOR  = (UINT)RT_ACCELERATOR // Accelerator table- , rT_ANICURSOR    = (UINT)RT_ANICURSOR // Animated cursor- , rT_ANIICON      = (UINT)RT_ANIICON   // Animated icon- , rT_BITMAP       = (UINT)RT_BITMAP    // Bitmap resource- , rT_CURSOR       = (UINT)RT_CURSOR    // Hardware-dependent cursor resource- , rT_DIALOG       = (UINT)RT_DIALOG    // Dialog box- , rT_FONT         = (UINT)RT_FONT      // Font resource- , rT_FONTDIR      = (UINT)RT_FONTDIR    // Font directory resource- , rT_GROUP_CURSOR = (UINT)RT_GROUP_CURSOR // Hardware-independent cursor resource- , rT_GROUP_ICON   = (UINT)RT_GROUP_ICON // Hardware-independent icon resource- , rT_HTML         = (UINT)RT_HTML      // HTML document- , rT_ICON         = (UINT)RT_ICON      // Hardware-dependent icon resource- , rT_MENU         = (UINT)RT_MENU      // Menu resource- , rT_MESSAGETABLE = (UINT)RT_MESSAGETABLE // Message-table entry- , rT_RCDATA       = (UINT)RT_RCDATA    // Application-defined resource (raw data)- , rT_STRING       = (UINT)RT_STRING    // String-table entry- , rT_VERSION      = (UINT)RT_VERSION   // Version resource+#{enum ResourceType, castUINTPtrToPtr+ , rT_ACCELERATOR  = (UINT_PTR)RT_ACCELERATOR // Accelerator table+ , rT_ANICURSOR    = (UINT_PTR)RT_ANICURSOR // Animated cursor+ , rT_ANIICON      = (UINT_PTR)RT_ANIICON   // Animated icon+ , rT_BITMAP       = (UINT_PTR)RT_BITMAP    // Bitmap resource+ , rT_CURSOR       = (UINT_PTR)RT_CURSOR    // Hardware-dependent cursor resource+ , rT_DIALOG       = (UINT_PTR)RT_DIALOG    // Dialog box+ , rT_FONT         = (UINT_PTR)RT_FONT      // Font resource+ , rT_FONTDIR      = (UINT_PTR)RT_FONTDIR    // Font directory resource+ , rT_GROUP_CURSOR = (UINT_PTR)RT_GROUP_CURSOR // Hardware-independent cursor resource+ , rT_GROUP_ICON   = (UINT_PTR)RT_GROUP_ICON // Hardware-independent icon resource+ , rT_HTML         = (UINT_PTR)RT_HTML      // HTML document+ , rT_ICON         = (UINT_PTR)RT_ICON      // Hardware-dependent icon resource+ , rT_MENU         = (UINT_PTR)RT_MENU      // Menu resource+ , rT_MESSAGETABLE = (UINT_PTR)RT_MESSAGETABLE // Message-table entry+ , rT_RCDATA       = (UINT_PTR)RT_RCDATA    // Application-defined resource (raw data)+ , rT_STRING       = (UINT_PTR)RT_STRING    // String-table entry+ , rT_VERSION      = (UINT_PTR)RT_VERSION   // Version resource  }  findResource :: HMODULE -> String -> ResourceType -> IO HRSRC findResource hmod name ty =   withTString name $ \ c_name ->   failIfNull "FindResource" $ c_FindResource hmod c_name ty-foreign import stdcall unsafe "windows.h FindResourceW"+foreign import WINDOWS_CCONV unsafe "windows.h FindResourceW"   c_FindResource :: HMODULE -> LPCTSTR -> LPCTSTR -> IO HRSRC  -- was: LPCTSTR_@@ -88,7 +92,7 @@ findResourceEx hmod name ty lang =   withTString name $ \ c_name ->   failIfNull "FindResourceEx" $ c_FindResourceEx hmod c_name ty lang-foreign import stdcall unsafe "windows.h FindResourceExW"+foreign import WINDOWS_CCONV unsafe "windows.h FindResourceExW"   c_FindResourceEx :: HMODULE -> LPCTSTR -> LPCTSTR -> WORD -> IO HRSRC  type ResourceSize = Int@@ -115,25 +119,25 @@ loadImage inst name ty x y load =   withTString name $ \ c_name ->   failIfNull "LoadImage" $ c_LoadImage inst c_name ty x y load-foreign import stdcall unsafe "windows.h LoadImageW"+foreign import WINDOWS_CCONV unsafe "windows.h LoadImageW"   c_LoadImage :: HINSTANCE -> LPCTSTR -> ResourceImageType -> ResourceSize -> ResourceSize -> LoadImageFlags -> IO HANDLE  loadResource :: HMODULE -> HRSRC -> IO HGLOBAL loadResource hmod res =   failIfNull "LoadResource" $ c_LoadResource hmod res-foreign import stdcall unsafe "windows.h LoadResource"+foreign import WINDOWS_CCONV unsafe "windows.h LoadResource"   c_LoadResource :: HMODULE -> HRSRC -> IO HGLOBAL  lockResource :: HGLOBAL -> IO Addr lockResource res =   failIfNull "LockResource" $ c_LockResource res-foreign import stdcall unsafe "windows.h LockResource"+foreign import WINDOWS_CCONV unsafe "windows.h LockResource"   c_LockResource :: HGLOBAL -> IO Addr  sizeofResource :: HMODULE -> HRSRC -> IO DWORD sizeofResource hmod res =   failIfZero "SizeofResource" $ c_SizeofResource hmod res-foreign import stdcall unsafe "windows.h SizeofResource"+foreign import WINDOWS_CCONV unsafe "windows.h SizeofResource"   c_SizeofResource :: HMODULE -> HRSRC -> IO DWORD  -- was: LPCTSTR_@@ -142,5 +146,5 @@   withTString name $ \ c_name ->   failIfFalse_ "UpdateResource" $     c_UpdateResource h ty c_name lang p_data data_len-foreign import stdcall unsafe "windows.h UpdateResourceW"+foreign import WINDOWS_CCONV unsafe "windows.h UpdateResourceW"   c_UpdateResource :: HANDLE -> LPCTSTR -> LPCTSTR -> WORD -> Addr -> DWORD -> IO Bool

Graphics/Win32/Window.hsc view

@@ -1,6 +1,5 @@-#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE CApiFFI #-} {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Win32.Window@@ -17,14 +16,31 @@  module Graphics.Win32.Window where -import System.Win32.Types-import Graphics.Win32.GDI.Types-import Graphics.Win32.Message+import Control.Monad (liftM, when, unless)+import Data.Maybe (fromMaybe)+import Data.Int (Int32)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Utils (maybeWith)+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Marshal.Array (allocaArray)+import Foreign.Ptr (FunPtr, Ptr, castFunPtrToPtr, nullPtr)+import Foreign.Ptr (intPtrToPtr, castPtrToFunPtr, freeHaskellFunPtr,ptrToIntPtr)+import Foreign.Storable (pokeByteOff)+import Foreign.C.Types (CIntPtr(..))+import Graphics.Win32.GDI.Types (HBITMAP, HCURSOR, HDC, HDWP, HRGN, HWND, PRGN)+import Graphics.Win32.GDI.Types (HBRUSH, HICON, HMENU, prim_ChildWindowFromPoint)+import Graphics.Win32.GDI.Types (LPRECT, RECT, allocaRECT, peekRECT, withRECT)+import Graphics.Win32.GDI.Types (POINT, allocaPOINT, peekPOINT, withPOINT)+import Graphics.Win32.GDI.Types (prim_ChildWindowFromPointEx)+import Graphics.Win32.Message (WindowMessage, wM_NCDESTROY)+import System.IO.Unsafe (unsafePerformIO)+import System.Win32.Types (ATOM, maybePtr, newTString, ptrToMaybe, numToMaybe)+import System.Win32.Types (Addr, BOOL, DWORD, INT, LONG, LRESULT, UINT, WPARAM)+import System.Win32.Types (HANDLE, HINSTANCE, LONG_PTR, LPARAM, LPCTSTR)+import System.Win32.Types (LPTSTR, LPVOID, withTString, peekTString)+import System.Win32.Types (failIf, failIf_, failIfFalse_, failIfNull, maybeNum, failUnlessSuccess, getLastError, errorWin) -import Control.Monad-import Data.Maybe-import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe+##include "windows_cconv.h"  #include <windows.h> @@ -38,7 +54,7 @@  type ClassName   = LPCTSTR --- Note: this is one of those rare functions which doesnt free all+-- Note: this is one of those rare functions which doesn't free all -- its String arguments.  mkClassName :: String -> ClassName@@ -91,7 +107,7 @@   #{poke WNDCLASS,lpszClassName} p cls   f p -foreign import stdcall unsafe "WndProc.h &genericWndProc"+foreign import WINDOWS_CCONV unsafe "WndProc.h &genericWndProc"   genericWndProc_p :: FunPtr WindowClosure  {-# CFILES cbits/WndProc.c #-}@@ -100,10 +116,10 @@ registerClass cls =   withWNDCLASS cls $ \ p ->   liftM numToMaybe $ c_RegisterClass p-foreign import stdcall unsafe "windows.h RegisterClassW"+foreign import WINDOWS_CCONV unsafe "windows.h RegisterClassW"   c_RegisterClass :: Ptr WNDCLASS -> IO ATOM -foreign import stdcall unsafe "windows.h UnregisterClassW"+foreign import WINDOWS_CCONV unsafe "windows.h UnregisterClassW"   unregisterClass :: ClassName -> HINSTANCE -> IO ()  ----------------------------------------------------------------@@ -168,8 +184,13 @@  , wS_EX_PALETTEWINDOW  = WS_EX_PALETTEWINDOW  } + cW_USEDEFAULT :: Pos-cW_USEDEFAULT = #{const CW_USEDEFAULT}+-- See Note [Overflow checking and fromIntegral] in Graphics/Win32/GDI/HDC.hs+-- Weird way to essentially get a value with the top bit set. But GHC 7.8.4 was+-- rejecting all other sane attempts.+cW_USEDEFAULT = let val = negate (#{const CW_USEDEFAULT}) :: Integer+                in fromIntegral (fromIntegral val :: Int32) :: Pos  type Pos = Int @@ -180,17 +201,64 @@  type WindowClosure = HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT -foreign import stdcall "wrapper"+foreign import WINDOWS_CCONV "wrapper"   mkWindowClosure :: WindowClosure -> IO (FunPtr WindowClosure) -setWindowClosure :: HWND -> WindowClosure -> IO ()+mkCIntPtr :: FunPtr a -> CIntPtr+mkCIntPtr = fromIntegral . ptrToIntPtr . castFunPtrToPtr++-- | The standard C wndproc for every window class registered by+-- 'registerClass' is a C function pointer provided with this library. It in+-- turn delegates to a Haskell function pointer stored in 'gWLP_USERDATA'.+-- This action creates that function pointer. All Haskell function pointers+-- must be freed in order to allow the objects they close over to be garbage+-- collected. Consequently, if you are replacing a window closure previously+-- set via this method or indirectly with 'createWindow' or 'createWindowEx'+-- you must free it. This action returns a function pointer to the old window+-- closure for you to free. The current window closure is freed automatically+-- by 'defWindowProc' when it receives 'wM_NCDESTROY'.+setWindowClosure :: HWND -> WindowClosure -> IO (Maybe (FunPtr WindowClosure)) setWindowClosure wnd closure = do   fp <- mkWindowClosure closure-  _ <- c_SetWindowLong wnd (#{const GWL_USERDATA}) (castFunPtrToLONG fp)-  return ()-foreign import stdcall unsafe "windows.h SetWindowLongW"-  c_SetWindowLong :: HWND -> INT -> LONG -> IO LONG+  fpOld <- c_SetWindowLongPtr wnd (#{const GWLP_USERDATA})+                              (mkCIntPtr fp)+  if fpOld == 0+     then return Nothing+     else return $ Just $ castPtrToFunPtr $ intPtrToPtr $ fromIntegral fpOld +{- Note [SetWindowLongPtrW]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Windows.h defines SetWindowLongPtrW as SetWindowLongW for 32-bit platforms+(i386_HOST_ARCH for our mingw32 environment). Unfortunately since the foreign+import name is given inside of a string, the macro will not be expanded.++Until a better solution is presented each version is provided explicitly here.++-}+#if defined(i386_HOST_ARCH)+foreign import WINDOWS_CCONV unsafe "windows.h SetWindowLongW"+#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)+foreign import WINDOWS_CCONV unsafe "windows.h SetWindowLongPtrW"+#else+# error Unknown mingw32 arch+#endif+  c_SetWindowLongPtr :: HWND -> INT -> LONG_PTR -> IO (LONG_PTR)++#if defined(i386_HOST_ARCH)+foreign import WINDOWS_CCONV unsafe "windows.h GetWindowLongW"+#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)+foreign import WINDOWS_CCONV unsafe "windows.h GetWindowLongPtrW"+#else+# error Unknown mingw32 arch+#endif+  c_GetWindowLongPtr :: HANDLE -> INT -> IO LONG_PTR+++-- | Creates a window with a default extended window style. If you create many+-- windows over the life of your program, WindowClosure may leak memory. Be+-- sure to delegate to 'defWindowProc' for 'wM_NCDESTROY' and see+-- 'defWindowProc' and 'setWindowClosure' for details. createWindow   :: ClassName -> String -> WindowStyle ->      Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos ->@@ -199,6 +267,10 @@ createWindow = createWindowEx 0 -- apparently CreateWindowA/W are just macros for CreateWindowExA/W +-- | Creates a window and allows your to specify the  extended window style. If+-- you create many windows over the life of your program, WindowClosure may+-- leak memory. Be sure to delegate to 'defWindowProc' for 'wM_NCDESTROY' and see+-- 'defWindowProc' and 'setWindowClosure' for details. createWindowEx   :: WindowStyle -> ClassName -> String -> WindowStyle   -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos@@ -213,9 +285,9 @@     c_CreateWindowEx estyle cname c_wname wstyle       (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)       (maybePtr mb_parent) (maybePtr mb_menu) inst nullPtr-  setWindowClosure wnd closure+  _ <- setWindowClosure wnd closure   return wnd-foreign import stdcall "windows.h CreateWindowExW"+foreign import WINDOWS_CCONV "windows.h CreateWindowExW"   c_CreateWindowEx     :: WindowStyle -> ClassName -> LPCTSTR -> WindowStyle     -> Pos -> Pos -> Pos -> Pos@@ -224,12 +296,43 @@  ---------------------------------------------------------------- +-- | Delegates to the Win32 default window procedure. If you are using a+-- window created by 'createWindow', 'createWindowEx' or on which you have+-- called 'setWindowClosure', please note that the window will leak memory once+-- it is destroyed unless you call 'freeWindowProc' when it receives+-- 'wM_NCDESTROY'. If you wish to do this, instead of using this function+-- directly, you can delegate to 'defWindowProcSafe' which will handle it for+-- you. As an alternative, you can manually retrieve the window closure+-- function pointer and free it after the window has been destroyed. Check the+-- implementation of 'freeWindowProc' for a guide. defWindowProc :: Maybe HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT defWindowProc mb_wnd msg w l =   c_DefWindowProc (maybePtr mb_wnd) msg w l-foreign import stdcall "windows.h DefWindowProcW"++-- | Delegates to the standard default window procedure, but if it receives the+-- 'wM_NCDESTROY' message it first frees the window closure to allow the+-- closure and any objects it closes over to be garbage collected. 'wM_NCDESTROY' is+-- the last message a window receives prior to being deleted.+defWindowProcSafe :: Maybe HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT+defWindowProcSafe mb_wnd msg w l = do+  when (msg == wM_NCDESTROY) (maybe (return ()) freeWindowProc mb_wnd)+  defWindowProc mb_wnd msg w l++foreign import WINDOWS_CCONV "windows.h DefWindowProcW"   c_DefWindowProc :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT +-- | Frees a function pointer to the window closure which has been set+-- directly by 'setWindowClosure' or indirectly by 'createWindowEx'. You+-- should call this function in your window closure's 'wM_NCDESTROY' case+-- unless you delegate that case to 'defWindowProc' (e.g. as part of the+-- default).+freeWindowProc :: HWND -> IO ()+freeWindowProc hwnd = do+   fp <- c_GetWindowLongPtr hwnd (#{const GWLP_USERDATA})+   unless (fp == 0) $ +      freeHaskellFunPtr $ castPtrToFunPtr . intPtrToPtr . fromIntegral $ fp++ ----------------------------------------------------------------  getClientRect :: HWND -> IO RECT@@ -237,7 +340,7 @@   allocaRECT $ \ p_rect -> do   failIfFalse_ "GetClientRect" $ c_GetClientRect wnd p_rect   peekRECT p_rect-foreign import stdcall unsafe "windows.h GetClientRect"+foreign import WINDOWS_CCONV unsafe "windows.h GetClientRect"   c_GetClientRect :: HWND -> Ptr RECT -> IO Bool  getWindowRect :: HWND -> IO RECT@@ -245,7 +348,7 @@   allocaRECT $ \ p_rect -> do   failIfFalse_ "GetWindowRect" $ c_GetWindowRect wnd p_rect   peekRECT p_rect-foreign import stdcall unsafe "windows.h GetWindowRect"+foreign import WINDOWS_CCONV unsafe "windows.h GetWindowRect"   c_GetWindowRect :: HWND -> Ptr RECT -> IO Bool  -- Should it be Maybe RECT instead?@@ -254,7 +357,7 @@ invalidateRect wnd p_mb_rect erase =   failIfFalse_ "InvalidateRect" $     c_InvalidateRect (maybePtr wnd) (maybePtr p_mb_rect) erase-foreign import stdcall "windows.h InvalidateRect"+foreign import WINDOWS_CCONV "windows.h InvalidateRect"   c_InvalidateRect :: HWND -> LPRECT -> Bool -> IO Bool  screenToClient :: HWND -> POINT -> IO POINT@@ -262,7 +365,7 @@   withPOINT pt $ \ p_pt -> do   failIfFalse_ "ScreenToClient" $ c_ScreenToClient wnd p_pt   peekPOINT p_pt-foreign import stdcall unsafe "windows.h ScreenToClient"+foreign import WINDOWS_CCONV unsafe "windows.h ScreenToClient"   c_ScreenToClient :: HWND -> Ptr POINT -> IO Bool  clientToScreen :: HWND -> POINT -> IO POINT@@ -270,7 +373,7 @@   withPOINT pt $ \ p_pt -> do   failIfFalse_ "ClientToScreen" $ c_ClientToScreen wnd p_pt   peekPOINT p_pt-foreign import stdcall unsafe "windows.h ClientToScreen"+foreign import WINDOWS_CCONV unsafe "windows.h ClientToScreen"   c_ClientToScreen :: HWND -> Ptr POINT -> IO Bool  ----------------------------------------------------------------@@ -282,10 +385,45 @@ setWindowText wnd text =   withTString text $ \ c_text ->   failIfFalse_ "SetWindowText" $ c_SetWindowText wnd c_text-foreign import stdcall "windows.h SetWindowTextW"+foreign import WINDOWS_CCONV "windows.h SetWindowTextW"   c_SetWindowText :: HWND -> LPCTSTR -> IO Bool  ----------------------------------------------------------------+-- Getting window text/label+----------------------------------------------------------------+-- For getting the title bar text. +-- If the window has no title bar or text, if the title bar is empty,+-- or if the window or control handle is invalid, the return value is zero.+-- If invalid handle throws exception.+-- If size <= 0 throws exception.++getWindowText :: HWND -> Int -> IO String+getWindowText wnd size +  | size <= 0 = errorWin "GetWindowTextW"+  | otherwise  = do+      allocaArray size $ \ p_buf -> do+      _ <- c_GetWindowText wnd p_buf size+      failUnlessSuccess "GetWindowTextW" getLastError+      peekTString p_buf+foreign import WINDOWS_CCONV "windows.h GetWindowTextW"+  c_GetWindowText :: HWND -> LPTSTR -> Int -> IO Int++----------------------------------------------------------------+-- Getting window text length+----------------------------------------------------------------+-- For getting the title bar text length. +-- If the window has no text, the return value is zero.+-- If invalid handle throws exception.+  +getWindowTextLength :: HWND -> IO Int+getWindowTextLength wnd = do+  size' <- c_GetWindowTextLength wnd+  failUnlessSuccess "GetWindowTextLengthW" getLastError+  return size'+foreign import WINDOWS_CCONV "windows.h GetWindowTextLengthW"+  c_GetWindowTextLength :: HWND -> IO Int+  +---------------------------------------------------------------- -- Paint struct ---------------------------------------------------------------- @@ -306,10 +444,10 @@ beginPaint :: HWND -> LPPAINTSTRUCT -> IO HDC beginPaint wnd paint =   failIfNull "BeginPaint" $ c_BeginPaint wnd paint-foreign import stdcall "windows.h BeginPaint"+foreign import WINDOWS_CCONV "windows.h BeginPaint"   c_BeginPaint :: HWND -> LPPAINTSTRUCT -> IO HDC -foreign import stdcall "windows.h EndPaint"+foreign import WINDOWS_CCONV "windows.h EndPaint"   endPaint :: HWND -> LPPAINTSTRUCT -> IO () -- Apparently always succeeds (return non-zero) @@ -333,9 +471,12 @@  , sW_RESTORE           = SW_RESTORE  } -foreign import stdcall "windows.h ShowWindow"+foreign import WINDOWS_CCONV "windows.h ShowWindow"   showWindow :: HWND  -> ShowWindowControl  -> IO Bool +foreign import WINDOWS_CCONV "windows.h IsWindowVisible"+  isWindowVisible :: HWND -> IO Bool+ ---------------------------------------------------------------- -- Misc ----------------------------------------------------------------@@ -345,7 +486,7 @@   withRECT rect $ \ p_rect -> do   failIfFalse_ "AdjustWindowRect" $ c_AdjustWindowRect p_rect style menu   peekRECT p_rect-foreign import stdcall unsafe "windows.h AdjustWindowRect"+foreign import WINDOWS_CCONV unsafe "windows.h AdjustWindowRect"   c_AdjustWindowRect :: Ptr RECT -> WindowStyle -> Bool -> IO Bool  adjustWindowRectEx :: RECT -> WindowStyle -> Bool -> WindowStyleEx -> IO RECT@@ -354,7 +495,7 @@   failIfFalse_ "AdjustWindowRectEx" $     c_AdjustWindowRectEx p_rect style menu exstyle   peekRECT p_rect-foreign import stdcall unsafe "windows.h AdjustWindowRectEx"+foreign import WINDOWS_CCONV unsafe "windows.h AdjustWindowRectEx"   c_AdjustWindowRectEx :: Ptr RECT -> WindowStyle -> Bool -> WindowStyleEx -> IO Bool  -- Win2K and later:@@ -381,25 +522,25 @@ -- %code BOOL success = AnimateWindow(arg1,arg2,arg3) -- %fail { !success } { ErrorWin("AnimateWindow") } -foreign import stdcall unsafe "windows.h AnyPopup"+foreign import WINDOWS_CCONV unsafe "windows.h AnyPopup"   anyPopup :: IO Bool  arrangeIconicWindows :: HWND -> IO () arrangeIconicWindows wnd =   failIfFalse_ "ArrangeIconicWindows" $ c_ArrangeIconicWindows wnd-foreign import stdcall unsafe "windows.h ArrangeIconicWindows"+foreign import WINDOWS_CCONV unsafe "windows.h ArrangeIconicWindows"   c_ArrangeIconicWindows :: HWND -> IO Bool  beginDeferWindowPos :: Int -> IO HDWP beginDeferWindowPos n =   failIfNull "BeginDeferWindowPos" $ c_BeginDeferWindowPos n-foreign import stdcall unsafe "windows.h BeginDeferWindowPos"+foreign import WINDOWS_CCONV unsafe "windows.h BeginDeferWindowPos"   c_BeginDeferWindowPos :: Int -> IO HDWP  bringWindowToTop :: HWND -> IO () bringWindowToTop wnd =   failIfFalse_ "BringWindowToTop" $ c_BringWindowToTop wnd-foreign import stdcall "windows.h BringWindowToTop"+foreign import WINDOWS_CCONV "windows.h BringWindowToTop"   c_BringWindowToTop :: HWND -> IO Bool  -- Can't pass structs with current FFI, so use a C wrapper (in Types)@@ -421,63 +562,68 @@ deferWindowPos :: HDWP -> HWND -> HWND -> Int -> Int -> Int -> Int -> SetWindowPosFlags -> IO HDWP deferWindowPos wp wnd after x y cx cy flags =   failIfNull "DeferWindowPos" $ c_DeferWindowPos wp wnd after x y cx cy flags-foreign import stdcall unsafe "windows.h DeferWindowPos"+foreign import WINDOWS_CCONV unsafe "windows.h DeferWindowPos"   c_DeferWindowPos :: HDWP -> HWND -> HWND -> Int -> Int -> Int -> Int -> SetWindowPosFlags -> IO HDWP  destroyWindow :: HWND -> IO () destroyWindow wnd =   failIfFalse_ "DestroyWindow" $ c_DestroyWindow wnd-foreign import stdcall "windows.h DestroyWindow"+foreign import WINDOWS_CCONV "windows.h DestroyWindow"   c_DestroyWindow :: HWND -> IO Bool  endDeferWindowPos :: HDWP -> IO () endDeferWindowPos pos =   failIfFalse_ "EndDeferWindowPos" $ c_EndDeferWindowPos pos-foreign import stdcall unsafe "windows.h EndDeferWindowPos"+foreign import WINDOWS_CCONV unsafe "windows.h EndDeferWindowPos"   c_EndDeferWindowPos :: HDWP -> IO Bool -findWindow :: String -> String -> IO (Maybe HWND)+findWindow :: Maybe String -> Maybe String -> IO (Maybe HWND) findWindow cname wname =-  withTString cname $ \ c_cname ->-  withTString wname $ \ c_wname ->+  maybeWith withTString cname $ \ c_cname ->+  maybeWith withTString wname $ \ c_wname ->   liftM ptrToMaybe $ c_FindWindow c_cname c_wname-foreign import stdcall unsafe "windows.h FindWindowW"++{-# DEPRECATED findWindowByName "Use 'findWindow Nothing' instead." #-}+findWindowByName :: String -> IO (Maybe HWND)+findWindowByName wname = findWindow Nothing $ Just wname++foreign import WINDOWS_CCONV unsafe "windows.h FindWindowW"   c_FindWindow :: LPCTSTR -> LPCTSTR -> IO HWND -findWindowEx :: HWND -> HWND -> String -> String -> IO (Maybe HWND)+findWindowEx :: Maybe HWND -> Maybe HWND -> Maybe String -> Maybe String -> IO (Maybe HWND) findWindowEx parent after cname wname =-  withTString cname $ \ c_cname ->-  withTString wname $ \ c_wname ->-  liftM ptrToMaybe $ c_FindWindowEx parent after c_cname c_wname-foreign import stdcall unsafe "windows.h FindWindowExW"+  maybeWith withTString cname $ \ c_cname ->+  maybeWith withTString wname $ \ c_wname ->+  liftM ptrToMaybe $ c_FindWindowEx (maybePtr parent) (maybePtr after) c_cname c_wname+foreign import WINDOWS_CCONV unsafe "windows.h FindWindowExW"   c_FindWindowEx :: HWND -> HWND -> LPCTSTR -> LPCTSTR -> IO HWND -foreign import stdcall unsafe "windows.h FlashWindow"+foreign import WINDOWS_CCONV unsafe "windows.h FlashWindow"   flashWindow :: HWND -> Bool -> IO Bool -- No error code  moveWindow :: HWND -> Int -> Int -> Int -> Int -> Bool -> IO () moveWindow wnd x y w h repaint =   failIfFalse_ "MoveWindow" $ c_MoveWindow wnd x y w h repaint-foreign import stdcall "windows.h MoveWindow"+foreign import WINDOWS_CCONV "windows.h MoveWindow"   c_MoveWindow :: HWND -> Int -> Int -> Int -> Int -> Bool -> IO Bool -foreign import stdcall unsafe "windows.h GetDesktopWindow"+foreign import WINDOWS_CCONV unsafe "windows.h GetDesktopWindow"   getDesktopWindow :: IO HWND -foreign import stdcall unsafe "windows.h GetForegroundWindow"+foreign import WINDOWS_CCONV unsafe "windows.h GetForegroundWindow"   getForegroundWindow :: IO HWND-+   getParent :: HWND -> IO HWND getParent wnd =   failIfNull "GetParent" $ c_GetParent wnd-foreign import stdcall unsafe "windows.h GetParent"+foreign import WINDOWS_CCONV unsafe "windows.h GetParent"   c_GetParent :: HWND -> IO HWND  getTopWindow :: HWND -> IO HWND getTopWindow wnd =   failIfNull "GetTopWindow" $ c_GetTopWindow wnd-foreign import stdcall unsafe "windows.h GetTopWindow"+foreign import WINDOWS_CCONV unsafe "windows.h GetTopWindow"   c_GetTopWindow :: HWND -> IO HWND  @@ -522,25 +668,25 @@ getDCEx wnd rgn flags =   withForeignPtr rgn $ \ p_rgn ->   failIfNull "GetDCEx" $ c_GetDCEx wnd p_rgn flags-foreign import stdcall unsafe "windows.h GetDCEx"+foreign import WINDOWS_CCONV unsafe "windows.h GetDCEx"   c_GetDCEx :: HWND -> PRGN -> GetDCExFlags -> IO HDC  getDC :: Maybe HWND -> IO HDC getDC mb_wnd =   failIfNull "GetDC" $ c_GetDC (maybePtr mb_wnd)-foreign import stdcall unsafe "windows.h GetDC"+foreign import WINDOWS_CCONV unsafe "windows.h GetDC"   c_GetDC :: HWND -> IO HDC  getWindowDC :: Maybe HWND -> IO HDC getWindowDC mb_wnd =   failIfNull "GetWindowDC" $ c_GetWindowDC (maybePtr mb_wnd)-foreign import stdcall unsafe "windows.h GetWindowDC"+foreign import WINDOWS_CCONV unsafe "windows.h GetWindowDC"   c_GetWindowDC :: HWND -> IO HDC  releaseDC :: Maybe HWND -> HDC -> IO () releaseDC mb_wnd dc =   failIfFalse_ "ReleaseDC" $ c_ReleaseDC (maybePtr mb_wnd) dc-foreign import stdcall unsafe "windows.h ReleaseDC"+foreign import WINDOWS_CCONV unsafe "windows.h ReleaseDC"   c_ReleaseDC :: HWND -> HDC -> IO Bool  getDCOrgEx :: HDC -> IO POINT@@ -548,7 +694,7 @@   allocaPOINT $ \ p_pt -> do   failIfFalse_ "GetDCOrgEx" $ c_GetDCOrgEx dc p_pt   peekPOINT p_pt-foreign import stdcall unsafe "windows.h GetDCOrgEx"+foreign import WINDOWS_CCONV unsafe "windows.h GetDCOrgEx"   c_GetDCOrgEx :: HDC -> Ptr POINT -> IO Bool  ----------------------------------------------------------------@@ -558,13 +704,13 @@ hideCaret :: HWND -> IO () hideCaret wnd =   failIfFalse_ "HideCaret" $ c_HideCaret wnd-foreign import stdcall unsafe "windows.h HideCaret"+foreign import WINDOWS_CCONV unsafe "windows.h HideCaret"   c_HideCaret :: HWND -> IO Bool  showCaret :: HWND -> IO () showCaret wnd =   failIfFalse_ "ShowCaret" $ c_ShowCaret wnd-foreign import stdcall unsafe "windows.h ShowCaret"+foreign import WINDOWS_CCONV unsafe "windows.h ShowCaret"   c_ShowCaret :: HWND -> IO Bool  -- ToDo: allow arg2 to be NULL or {(HBITMAP)1}@@ -573,13 +719,13 @@ createCaret wnd bm mb_w mb_h =   failIfFalse_ "CreateCaret" $     c_CreateCaret wnd bm (maybeNum mb_w) (maybeNum mb_h)-foreign import stdcall unsafe "windows.h CreateCaret"+foreign import WINDOWS_CCONV unsafe "windows.h CreateCaret"   c_CreateCaret :: HWND -> HBITMAP -> INT -> INT -> IO Bool  destroyCaret :: IO () destroyCaret =   failIfFalse_ "DestroyCaret" $ c_DestroyCaret-foreign import stdcall unsafe "windows.h DestroyCaret"+foreign import WINDOWS_CCONV unsafe "windows.h DestroyCaret"   c_DestroyCaret :: IO Bool  getCaretPos :: IO POINT@@ -587,13 +733,13 @@   allocaPOINT $ \ p_pt -> do   failIfFalse_ "GetCaretPos" $ c_GetCaretPos p_pt   peekPOINT p_pt-foreign import stdcall unsafe "windows.h GetCaretPos"+foreign import WINDOWS_CCONV unsafe "windows.h GetCaretPos"   c_GetCaretPos :: Ptr POINT -> IO Bool  setCaretPos :: POINT -> IO () setCaretPos (x,y) =   failIfFalse_ "SetCaretPos" $ c_SetCaretPos x y-foreign import stdcall unsafe "windows.h SetCaretPos"+foreign import WINDOWS_CCONV unsafe "windows.h SetCaretPos"   c_SetCaretPos :: LONG -> LONG -> IO Bool  -- The remarks on SetCaretBlinkTime are either highly risible or very sad -@@ -609,7 +755,7 @@ --   UpdateWindow   (I think) --   RedrawWindow   (I think) ----- The following dont have to be reentrant (according to documentation)+-- The following don't have to be reentrant (according to documentation) -- --   GetMessage --   PeekMessage@@ -643,7 +789,7 @@   res <- failIf (== -1) "GetMessage" $     c_GetMessage msg (maybePtr mb_wnd) 0 0   return (res /= 0)-foreign import stdcall "windows.h GetMessageW"+foreign import WINDOWS_CCONV "windows.h GetMessageW"   c_GetMessage :: LPMSG -> HWND -> UINT -> UINT -> IO LONG  -- A NULL window requests messages for any window belonging to this thread.@@ -654,26 +800,26 @@ peekMessage msg mb_wnd filterMin filterMax remove = do   failIf_ (== -1) "PeekMessage" $     c_PeekMessage msg (maybePtr mb_wnd) filterMin filterMax remove-foreign import stdcall "windows.h PeekMessageW"+foreign import WINDOWS_CCONV "windows.h PeekMessageW"   c_PeekMessage :: LPMSG -> HWND -> UINT -> UINT -> UINT -> IO LONG  -- Note: you're not supposed to call this if you're using accelerators -foreign import stdcall "windows.h TranslateMessage"+foreign import WINDOWS_CCONV "windows.h TranslateMessage"   translateMessage :: LPMSG -> IO BOOL  updateWindow :: HWND -> IO () updateWindow wnd =   failIfFalse_ "UpdateWindow" $ c_UpdateWindow wnd-foreign import stdcall "windows.h UpdateWindow"+foreign import WINDOWS_CCONV "windows.h UpdateWindow"   c_UpdateWindow :: HWND -> IO Bool  -- Return value of DispatchMessage is usually ignored -foreign import stdcall "windows.h DispatchMessageW"+foreign import WINDOWS_CCONV "windows.h DispatchMessageW"   dispatchMessage :: LPMSG -> IO LONG -foreign import stdcall "windows.h SendMessageW"+foreign import WINDOWS_CCONV "windows.h SendMessageW"   sendMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT  ----------------------------------------------------------------

+ Graphics/Win32/Window/AnimateWindow.hsc view

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

+ Graphics/Win32/Window/ForegroundWindow.hs view

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

+ Graphics/Win32/Window/HotKey.hsc view

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

+ Graphics/Win32/Window/IMM.hsc view

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

+ Graphics/Win32/Window/PostMessage.hsc view

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

LICENSE view

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

+ Media/Win32.hs view

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

− Setup.hs

@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMainWithHooks defaultUserHooks

System/Win32.hs view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,26 +18,35 @@ -----------------------------------------------------------------------------  module System.Win32-	( module System.Win32.DLL-	, module System.Win32.File-	, module System.Win32.FileMapping-	, module System.Win32.Info-	, module System.Win32.Mem-	, module System.Win32.NLS-	, module System.Win32.Process-	, module System.Win32.Registry-	, module System.Win32.Time-	, module System.Win32.Console-	, module System.Win32.Security-	, module System.Win32.Types-	, module System.Win32.Shell-	) where+        ( module System.Win32.DLL+        , module System.Win32.Event+        , module System.Win32.File+        , 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+        , module System.Win32.Time+        , module System.Win32.Console+        , 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+import System.Win32.Event import System.Win32.File 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@@ -47,6 +58,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

+ System/Win32/Automation.hs view

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

+ System/Win32/Automation/Input.hsc view

@@ -0,0 +1,130 @@+{-# 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
+  ( sendInput
+  , sendInputPtr
+  , makeKeyboardInput
+  , PINPUT
+  , LPINPUT
+  , INPUT(..)
+  , PHARDWAREINPUT
+  , HARDWAREINPUT(..)
+  , getMessageExtraInfo
+  , setMessageExtraInfo
+  , 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 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

+ System/Win32/Automation/Input/Key.hsc view

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

+ System/Win32/Automation/Input/Mouse.hsc view

@@ -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, dy) buf (dy 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
+-}

System/Win32/Console.hsc view

@@ -1,5 +1,7 @@-#if __GLASGOW_HASKELL__ >= 701
+#if __GLASGOW_HASKELL__ >= 709
 {-# LANGUAGE Trustworthy #-}
+#else
+{-# LANGUAGE Trustworthy #-}
 #endif
 -----------------------------------------------------------------------------
 -- |
@@ -16,35 +18,108 @@ -----------------------------------------------------------------------------
 
 module System.Win32.Console (
-	-- * Console code pages
-	getConsoleCP,
-	setConsoleCP,
-	getConsoleOutputCP,
-	setConsoleOutputCP,
-	-- * Ctrl events
-	CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT,
-	generateConsoleCtrlEvent
+        -- * Console mode
+        getConsoleMode,
+        setConsoleMode,
+        eNABLE_ECHO_INPUT,
+        eNABLE_EXTENDED_FLAGS,
+        eNABLE_INSERT_MODE,
+        eNABLE_LINE_INPUT,
+        eNABLE_MOUSE_INPUT,
+        eNABLE_PROCESSED_INPUT,
+        eNABLE_QUICK_EDIT_MODE,
+        eNABLE_WINDOW_INPUT,
+        eNABLE_VIRTUAL_TERMINAL_INPUT,
+        eNABLE_PROCESSED_OUTPUT,
+        eNABLE_WRAP_AT_EOL_OUTPUT,
+        eNABLE_VIRTUAL_TERMINAL_PROCESSING,
+        dISABLE_NEWLINE_AUTO_RETURN,
+        eNABLE_LVB_GRID_WORLDWIDE,
+        -- * Console code pages
+        getConsoleCP,
+        setConsoleCP,
+        getConsoleOutputCP,
+        setConsoleOutputCP,
+        -- * Ctrl events
+        CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT,
+        generateConsoleCtrlEvent,
+        -- * Command line
+        commandLineToArgv,
+        getCommandLineW,
+        getArgs,
+        -- * Screen buffer
+        CONSOLE_SCREEN_BUFFER_INFO(..),
+        CONSOLE_SCREEN_BUFFER_INFOEX(..),
+        COORD(..),
+        SMALL_RECT(..),
+        COLORREF,
+        getConsoleScreenBufferInfo,
+        getCurrentConsoleScreenBufferInfo,
+        getConsoleScreenBufferInfoEx,
+        getCurrentConsoleScreenBufferInfoEx,
+
+        -- * Env
+        getEnv,
+        getEnvironment,
+        -- * Console I/O
+        KEY_EVENT_RECORD(..),
+        MOUSE_EVENT_RECORD(..),
+        WINDOW_BUFFER_SIZE_RECORD(..),
+        MENU_EVENT_RECORD(..),
+        FOCUS_EVENT_RECORD(..),
+        INPUT_RECORD(..),
+        readConsoleInput
   ) where
 
+#include <windows.h>
+#include "alignment.h"
+##include "windows_cconv.h"
+#include "wincon_compat.h"
+
+import Data.Char (chr)
 import System.Win32.Types
+import System.Win32.String
+import System.Win32.Console.Internal
+import Graphics.Win32.Misc
+import Graphics.Win32.GDI.Types (COLORREF)
 
-foreign import stdcall unsafe "windows.h GetConsoleCP"
-	getConsoleCP :: IO UINT
+import GHC.IO (bracket)
+import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))
+import Foreign.Ptr (plusPtr, Ptr)
+import Foreign.C.Types (CWchar)
+import Foreign.C.String (withCWString, CWString)
+import Foreign.Storable (Storable(..))
+import Foreign.Marshal.Array (peekArray, peekArray0)
+import Foreign.Marshal.Alloc (alloca)
 
-foreign import stdcall unsafe "windows.h SetConsoleCP"
-	setConsoleCP :: UINT -> IO ()
 
-foreign import stdcall unsafe "windows.h GetConsoleOutputCP"
-	getConsoleOutputCP :: IO UINT
+getConsoleMode :: HANDLE -> IO DWORD
+getConsoleMode h = alloca $ \ptr -> do
+    failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h ptr
+    peek ptr
 
-foreign import stdcall unsafe "windows.h SetConsoleOutputCP"
-	setConsoleOutputCP :: UINT -> IO ()
+setConsoleMode :: HANDLE -> DWORD -> IO ()
+setConsoleMode h mode = failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h mode
 
-type CtrlEvent = DWORD
-#{enum CtrlEvent,
-    , cTRL_C_EVENT      = 0
-    , cTRL_BREAK_EVENT  = 1
-    }
+eNABLE_ECHO_INPUT, eNABLE_EXTENDED_FLAGS, eNABLE_INSERT_MODE, eNABLE_LINE_INPUT,
+    eNABLE_MOUSE_INPUT, eNABLE_PROCESSED_INPUT, eNABLE_QUICK_EDIT_MODE,
+    eNABLE_WINDOW_INPUT, eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_PROCESSED_OUTPUT,
+    eNABLE_WRAP_AT_EOL_OUTPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING,
+    dISABLE_NEWLINE_AUTO_RETURN, eNABLE_LVB_GRID_WORLDWIDE :: DWORD
+eNABLE_ECHO_INPUT = 4
+eNABLE_EXTENDED_FLAGS = 128
+eNABLE_INSERT_MODE = 32
+eNABLE_LINE_INPUT = 2
+eNABLE_MOUSE_INPUT = 16
+eNABLE_PROCESSED_INPUT = 1
+eNABLE_QUICK_EDIT_MODE = 64
+eNABLE_WINDOW_INPUT = 8
+eNABLE_VIRTUAL_TERMINAL_INPUT = 512
+eNABLE_PROCESSED_OUTPUT = 1
+eNABLE_WRAP_AT_EOL_OUTPUT = 2
+eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4
+dISABLE_NEWLINE_AUTO_RETURN = 8
+eNABLE_LVB_GRID_WORLDWIDE = 16
 
 generateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO ()
 generateConsoleCtrlEvent e p
@@ -52,7 +127,126 @@         "generateConsoleCtrlEvent"
         $ c_GenerateConsoleCtrlEvent e p
 
-foreign import stdcall safe "windows.h GenerateConsoleCtrlEvent"
-    c_GenerateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO BOOL
+-- | This function can be used to parse command line arguments and return
+--   the split up arguments as elements in a list.
+commandLineToArgv :: String -> IO [String]
+commandLineToArgv []  = return []
+commandLineToArgv arg =
+  do withCWString arg $ \c_arg -> do
+       alloca $ \c_size -> do
+         res <- c_CommandLineToArgvW c_arg c_size
+         size <- peek c_size
+         args <- peekArray (fromIntegral size) res
+         _ <- localFree res
+         mapM peekTString args
 
--- ToDo: lots more
+-- | Based on 'GetCommandLineW'. This behaves slightly different
+-- than 'System.Environment.getArgs'. See the online documentation:
+-- <https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getcommandlinew>
+getArgs :: IO [String]
+getArgs = do
+  getCommandLineW >>= peekTString >>= commandLineToArgv
+
+getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO
+getConsoleScreenBufferInfo h = alloca $ \ptr -> do
+    failIfFalse_ "GetConsoleScreenBufferInfo" $ c_GetConsoleScreenBufferInfo h ptr
+    peek ptr
+
+getCurrentConsoleScreenBufferInfo :: IO CONSOLE_SCREEN_BUFFER_INFO
+getCurrentConsoleScreenBufferInfo = do
+    h <- failIf (== nullHANDLE) "getStdHandle" $ getStdHandle sTD_OUTPUT_HANDLE
+    getConsoleScreenBufferInfo h
+
+getConsoleScreenBufferInfoEx :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFOEX
+getConsoleScreenBufferInfoEx h = alloca $ \ptr -> do
+    -- The cbSize member must be set or GetConsoleScreenBufferInfoEx fails with
+    -- ERROR_INVALID_PARAMETER (87).
+    (#poke CONSOLE_SCREEN_BUFFER_INFOEX, cbSize) ptr cbSize
+    failIfFalse_ "GetConsoleScreenBufferInfoEx" $ c_GetConsoleScreenBufferInfoEx h ptr
+    peek ptr
+  where
+    cbSize :: ULONG
+    cbSize = #{size CONSOLE_SCREEN_BUFFER_INFOEX}
+
+getCurrentConsoleScreenBufferInfoEx :: IO CONSOLE_SCREEN_BUFFER_INFOEX
+getCurrentConsoleScreenBufferInfoEx = do
+    h <- failIf (== nullHANDLE) "getStdHandle" $ getStdHandle sTD_OUTPUT_HANDLE
+    getConsoleScreenBufferInfoEx h
+
+
+-- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD
+getEnv :: String -> IO (Maybe String)
+getEnv name =
+  withCWString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do
+    let c_len = fromIntegral len
+    c_len' <- c_GetEnvironmentVariableW c_name buf c_len
+    case c_len' of
+      0 -> do
+        err_code <- getLastError
+        if err_code  == eERROR_ENVVAR_NOT_FOUND
+        then return Nothing
+        else errorWin "GetEnvironmentVariableW"
+      _ | c_len' > fromIntegral maxLength ->
+            -- shouldn't happen, because we provide maxLength
+            ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing)
+        | otherwise -> do
+            let len' = fromIntegral c_len'
+            Just <$> peekTStringLen (buf, len')
+ where
+  -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew
+  -- max characters (wide chars): 32767
+  -- => bytes = 32767 * 2 = 65534
+  -- +1 byte for NUL (although not needed I think)
+  maxLength :: Int
+  maxLength = 65535
+
+
+getEnvironment :: IO [(String, String)]
+getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do
+    strs <- builder lpwstr
+    return (divvy <$> strs)
+ where
+  divvy :: String -> (String, String)
+  divvy str =
+    case break (=='=') str of
+      (xs,[])        -> (xs,[]) -- don't barf (like Posix.getEnvironment)
+      (name,_:value) -> (name,value)
+
+  builder :: LPWSTR -> IO [String]
+  builder ptr = go 0
+   where
+    go :: Int -> IO [String]
+    go off = do
+      (str, l) <- peekCWStringOff ptr off
+      if l == 0
+      then pure []
+      else (str:) <$> go (((l + 1) * 2) + off)
+
+
+peekCWStringOff :: CWString -> Int -> IO (String, Int)
+peekCWStringOff cp off = do
+  cs <- peekArray0 wNUL (cp `plusPtr` off)
+  return (cWcharsToChars cs, length cs)
+
+wNUL :: CWchar
+wNUL = 0
+
+cWcharsToChars :: [CWchar] -> [Char]
+cWcharsToChars = map chr . fromUTF16 . map fromIntegral
+ where
+  fromUTF16 (c1:c2:wcs)
+    | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =
+      ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs
+  fromUTF16 (c:wcs) = c : fromUTF16 wcs
+  fromUTF16 [] = []
+
+-- | Reads all available input records up to the amount specified by the
+-- len parameter.
+readConsoleInput :: HANDLE -> Int -> Ptr INPUT_RECORD -> IO Int
+readConsoleInput handle len inputRecordPtr =
+  alloca $ \numEventsReadPtr -> do
+    poke numEventsReadPtr 0
+    failIfFalse_ "ReadConsoleInput" $
+      c_ReadConsoleInput handle inputRecordPtr (fromIntegral len) numEventsReadPtr
+    numEvents <- peek numEventsReadPtr
+    return $ fromIntegral numEvents

+ System/Win32/Console/CtrlHandler.hs view

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

+ System/Win32/Console/HWND.hs view

@@ -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 (getConsoleHWND) 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

+ System/Win32/Console/Internal.hsc view

@@ -0,0 +1,336 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.Console.Internal+-- Copyright   :  (c) University of Glasgow 2023+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>+-- Stability   :  provisional+-- Portability :  portable+--+-- Internals for Console modules.+--+-----------------------------------------------------------------------------++module System.Win32.Console.Internal where++#include <windows.h>+#include "alignment.h"+##include "windows_cconv.h"+#include "wincon_compat.h"++import System.Win32.Types+import Graphics.Win32.GDI.Types (COLORREF)++import Foreign.C.Types (CInt(..), CWchar)+import Foreign.C.String (CWString)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Array (peekArray, pokeArray)++foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode"+        c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL++foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode"+        c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL++foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCP"+        getConsoleCP :: IO UINT++foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCP"+        setConsoleCP :: UINT -> IO ()++foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleOutputCP"+        getConsoleOutputCP :: IO UINT++foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleOutputCP"+        setConsoleOutputCP :: UINT -> IO ()++type CtrlEvent = DWORD+#{enum CtrlEvent,+    , cTRL_C_EVENT      = 0+    , cTRL_BREAK_EVENT  = 1+    }++foreign import WINDOWS_CCONV safe "windows.h GenerateConsoleCtrlEvent"+    c_GenerateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO BOOL++foreign import WINDOWS_CCONV unsafe "Shellapi.h CommandLineToArgvW"+     c_CommandLineToArgvW :: CWString -> Ptr CInt -> IO (Ptr CWString)++foreign import WINDOWS_CCONV unsafe "processenv.h GetCommandLineW"+        getCommandLineW :: IO LPWSTR++foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentVariableW"+        c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD++foreign import WINDOWS_CCONV unsafe "processenv.h GetEnvironmentStringsW"+        c_GetEnvironmentStringsW :: IO LPWSTR++foreign import WINDOWS_CCONV unsafe "processenv.h FreeEnvironmentStringsW"+  c_FreeEnvironmentStrings :: LPWSTR -> IO Bool++data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO+    { dwSize              :: COORD+    , dwCursorPosition    :: COORD+    , wAttributes         :: WORD+    , srWindow            :: SMALL_RECT+    , dwMaximumWindowSize :: COORD+    } deriving (Show, Eq)++instance Storable CONSOLE_SCREEN_BUFFER_INFO where+    sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFO}+    alignment _ = #alignment CONSOLE_SCREEN_BUFFER_INFO+    peek buf = do+        dwSize'              <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf+        dwCursorPosition'    <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf+        wAttributes'         <- (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf+        srWindow'            <- (#peek CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf+        dwMaximumWindowSize' <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf+        return $ CONSOLE_SCREEN_BUFFER_INFO dwSize' dwCursorPosition' wAttributes' srWindow' dwMaximumWindowSize'+    poke buf info = do+        (#poke CONSOLE_SCREEN_BUFFER_INFO, dwSize) buf (dwSize info)+        (#poke CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) buf (dwCursorPosition info)+        (#poke CONSOLE_SCREEN_BUFFER_INFO, wAttributes) buf (wAttributes info)+        (#poke CONSOLE_SCREEN_BUFFER_INFO, srWindow) buf (srWindow info)+        (#poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf (dwMaximumWindowSize info)++data CONSOLE_SCREEN_BUFFER_INFOEX = CONSOLE_SCREEN_BUFFER_INFOEX+    { dwSizeEx              :: COORD+    , dwCursorPositionEx    :: COORD+    , wAttributesEx         :: WORD+    , srWindowEx            :: SMALL_RECT+    , dwMaximumWindowSizeEx :: COORD+    , wPopupAttributes      :: WORD+    , bFullscreenSupported  :: BOOL+    , colorTable            :: [COLORREF]+      -- ^ Only the first 16 'COLORREF' values passed to the Windows Console+      -- API. If fewer than 16 values, the remainder are padded with @0@ when+      -- passed to the API.+    } deriving (Show, Eq)++instance Storable CONSOLE_SCREEN_BUFFER_INFOEX where+    sizeOf = const #{size CONSOLE_SCREEN_BUFFER_INFOEX}+    alignment = const #{alignment CONSOLE_SCREEN_BUFFER_INFOEX}+    peek buf = do+        dwSize'               <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf+        dwCursorPosition'     <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf+        wAttributes'          <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf+        srWindow'             <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf+        dwMaximumWindowSize'  <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf+        wPopupAttributes'     <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf+        bFullscreenSupported' <- (#peek CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf+        colorTable'           <- peekArray 16 ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf)+        return $ CONSOLE_SCREEN_BUFFER_INFOEX dwSize' dwCursorPosition'+          wAttributes' srWindow' dwMaximumWindowSize' wPopupAttributes'+          bFullscreenSupported' colorTable'+    poke buf info = do+        (#poke CONSOLE_SCREEN_BUFFER_INFOEX, cbSize) buf cbSize+        (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwSize) buf (dwSizeEx info)+        (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwCursorPosition) buf (dwCursorPositionEx info)+        (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wAttributes) buf (wAttributesEx info)+        (#poke CONSOLE_SCREEN_BUFFER_INFOEX, srWindow) buf (srWindowEx info)+        (#poke CONSOLE_SCREEN_BUFFER_INFOEX, dwMaximumWindowSize) buf (dwMaximumWindowSizeEx info)+        (#poke CONSOLE_SCREEN_BUFFER_INFOEX, wPopupAttributes) buf (wPopupAttributes info)+        (#poke CONSOLE_SCREEN_BUFFER_INFOEX, bFullscreenSupported) buf (bFullscreenSupported info)+        pokeArray ((#ptr CONSOLE_SCREEN_BUFFER_INFOEX, ColorTable) buf) colorTable'+      where+        cbSize :: ULONG+        cbSize = #{size CONSOLE_SCREEN_BUFFER_INFOEX}+        colorTable' = take 16 $ colorTable info ++ repeat 0++data COORD = COORD+    { xPos :: SHORT+    , yPos :: SHORT+    } deriving (Show, Eq)++instance Storable COORD where+    sizeOf = const #{size COORD}+    alignment _ = #alignment COORD+    peek buf = do+        x' <- (#peek COORD, X) buf+        y' <- (#peek COORD, Y) buf+        return $ COORD x' y'+    poke buf coord = do+        (#poke COORD, X) buf (xPos coord)+        (#poke COORD, Y) buf (yPos coord)++data SMALL_RECT = SMALL_RECT+    { leftPos   :: SHORT+    , topPos    :: SHORT+    , rightPos  :: SHORT+    , bottomPos :: SHORT+    } deriving (Show, Eq)++instance Storable SMALL_RECT where+    sizeOf _ = #{size SMALL_RECT}+    alignment _ = #alignment SMALL_RECT+    peek buf = do+        left'   <- (#peek SMALL_RECT, Left) buf+        top'    <- (#peek SMALL_RECT, Top) buf+        right'  <- (#peek SMALL_RECT, Right) buf+        bottom' <- (#peek SMALL_RECT, Bottom) buf+        return $ SMALL_RECT left' top' right' bottom'+    poke buf small_rect = do+        (#poke SMALL_RECT, Left) buf (leftPos small_rect)+        (#poke SMALL_RECT, Top) buf (topPos small_rect)+        (#poke SMALL_RECT, Right) buf (rightPos small_rect)+        (#poke SMALL_RECT, Bottom) buf (bottomPos small_rect)++foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfo"+    c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL++foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfoEx"+    c_GetConsoleScreenBufferInfoEx :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFOEX -> IO BOOL++-- | This type represents a keyboard input event. The structure is documented here:+-- https://learn.microsoft.com/en-us/windows/console/key-event-record-str+data KEY_EVENT_RECORD = KEY_EVENT_RECORD+    { keyDown          :: BOOL+    , repeatCount      :: WORD+    , virtualKeyCode   :: WORD+    , virtualScanCode  :: WORD+    , uChar            :: CWchar+    , controlKeyStateK :: DWORD+    } deriving (Eq, Show)++-- | This type represents a mouse event. The structure is documented here:+-- https://learn.microsoft.com/en-us/windows/console/mouse-event-record-str+data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD+  { mousePosition    :: COORD+  , buttonState      :: DWORD+  , controlKeyStateM :: DWORD+  , eventFlags       :: DWORD+  } deriving (Eq, Show)++-- | This type represents a window size change event. The structure is documented here:+-- https://learn.microsoft.com/en-us/windows/console/window-buffer-size-record-str+newtype WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD+  { windowSize :: COORD+  } deriving (Eq, Show)++-- | This type represents a window menu event. (Current ignored by VTY). The structure+-- is documented here: https://learn.microsoft.com/en-us/windows/console/menu-event-record-str+newtype MENU_EVENT_RECORD = MENU_EVENT_RECORD+  { commandId :: UINT+  } deriving (Eq, Show)++-- | This type represents a window focus change event. The structure is documented here:+-- https://learn.microsoft.com/en-us/windows/console/focus-event-record-str+newtype FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD+  { setFocus :: BOOL+  } deriving (Eq, Show)++-- | Description of a Windows console input event. Documented here:+-- https://learn.microsoft.com/en-us/windows/console/input-record-str+data INPUT_RECORD =+    KeyEvent KEY_EVENT_RECORD+  | MouseEvent MOUSE_EVENT_RECORD+  | WindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD+  | MenuEvent MENU_EVENT_RECORD+  | FocusEvent FOCUS_EVENT_RECORD+  deriving (Eq, Show)++instance Storable KEY_EVENT_RECORD where+    sizeOf = const #{size KEY_EVENT_RECORD}+    alignment _ = #alignment KEY_EVENT_RECORD+    poke buf input = do+        (#poke KEY_EVENT_RECORD, bKeyDown)          buf (keyDown input)+        (#poke KEY_EVENT_RECORD, wRepeatCount)      buf (repeatCount input)+        (#poke KEY_EVENT_RECORD, wVirtualKeyCode)   buf (virtualKeyCode input)+        (#poke KEY_EVENT_RECORD, wVirtualScanCode)  buf (virtualScanCode input)+        (#poke KEY_EVENT_RECORD, uChar)             buf (uChar input)+        (#poke KEY_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateK input)+    peek buf = do+        keyDown'          <- (#peek KEY_EVENT_RECORD, bKeyDown) buf+        repeatCount'      <- (#peek KEY_EVENT_RECORD, wRepeatCount) buf+        virtualKeyCode'   <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) buf+        virtualScanCode'  <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) buf+        uChar'            <- (#peek KEY_EVENT_RECORD, uChar) buf+        controlKeyStateK' <- (#peek KEY_EVENT_RECORD, dwControlKeyState) buf+        return $ KEY_EVENT_RECORD keyDown' repeatCount' virtualKeyCode' virtualScanCode' uChar' controlKeyStateK'++instance Storable MOUSE_EVENT_RECORD where+    sizeOf = const #{size MOUSE_EVENT_RECORD}+    alignment _ = #alignment MOUSE_EVENT_RECORD+    poke buf input = do+        (#poke MOUSE_EVENT_RECORD, dwMousePosition)   buf (mousePosition input)+        (#poke MOUSE_EVENT_RECORD, dwButtonState)     buf (buttonState input)+        (#poke MOUSE_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateM input)+        (#poke MOUSE_EVENT_RECORD, dwEventFlags)      buf (eventFlags input)+    peek buf = do+        mousePosition'    <- (#peek MOUSE_EVENT_RECORD, dwMousePosition) buf+        buttonState'      <- (#peek MOUSE_EVENT_RECORD, dwButtonState) buf+        controlKeyStateM' <- (#peek MOUSE_EVENT_RECORD, dwControlKeyState) buf+        eventFlags'       <- (#peek MOUSE_EVENT_RECORD, dwEventFlags) buf+        return $ MOUSE_EVENT_RECORD mousePosition' buttonState' controlKeyStateM' eventFlags'++instance Storable WINDOW_BUFFER_SIZE_RECORD where+    sizeOf = const #{size WINDOW_BUFFER_SIZE_RECORD}+    alignment _ = #alignment WINDOW_BUFFER_SIZE_RECORD+    poke buf input = do+        (#poke WINDOW_BUFFER_SIZE_RECORD, dwSize) buf (windowSize input)+    peek buf = do+        size' <- (#peek WINDOW_BUFFER_SIZE_RECORD, dwSize) buf+        return $ WINDOW_BUFFER_SIZE_RECORD size'++instance Storable MENU_EVENT_RECORD where+    sizeOf = const #{size MENU_EVENT_RECORD}+    alignment _ = #alignment MENU_EVENT_RECORD+    poke buf input = do+        (#poke MENU_EVENT_RECORD, dwCommandId) buf (commandId input)+    peek buf = do+        commandId' <- (#peek MENU_EVENT_RECORD, dwCommandId) buf+        return $ MENU_EVENT_RECORD commandId'++instance Storable FOCUS_EVENT_RECORD where+    sizeOf = const #{size FOCUS_EVENT_RECORD}+    alignment _ = #alignment FOCUS_EVENT_RECORD+    poke buf input = do+        (#poke FOCUS_EVENT_RECORD, bSetFocus) buf (setFocus input)+    peek buf = do+        setFocus' <- (#peek FOCUS_EVENT_RECORD, bSetFocus) buf+        return $ FOCUS_EVENT_RECORD setFocus'++instance Storable INPUT_RECORD where+    sizeOf = const #{size INPUT_RECORD}+    alignment _ = #alignment INPUT_RECORD++    poke buf (KeyEvent key) = do+        (#poke INPUT_RECORD, EventType) buf (#{const KEY_EVENT} :: WORD)+        (#poke INPUT_RECORD, Event) buf key+    poke buf (MouseEvent mouse) = do+        (#poke INPUT_RECORD, EventType) buf (#{const MOUSE_EVENT} :: WORD)+        (#poke INPUT_RECORD, Event) buf mouse+    poke buf (WindowBufferSizeEvent window) = do+        (#poke INPUT_RECORD, EventType) buf (#{const WINDOW_BUFFER_SIZE_EVENT} :: WORD)+        (#poke INPUT_RECORD, Event) buf window+    poke buf (MenuEvent menu) = do+        (#poke INPUT_RECORD, EventType) buf (#{const MENU_EVENT} :: WORD)+        (#poke INPUT_RECORD, Event) buf menu+    poke buf (FocusEvent focus) = do+        (#poke INPUT_RECORD, EventType) buf (#{const FOCUS_EVENT} :: WORD)+        (#poke INPUT_RECORD, Event) buf focus++    peek buf = do+        event <- (#peek INPUT_RECORD, EventType) buf :: IO WORD+        case event of+          #{const KEY_EVENT} ->+              KeyEvent `fmap` (#peek INPUT_RECORD, Event) buf+          #{const MOUSE_EVENT} ->+              MouseEvent `fmap` (#peek INPUT_RECORD, Event) buf+          #{const WINDOW_BUFFER_SIZE_EVENT} ->+              WindowBufferSizeEvent `fmap` (#peek INPUT_RECORD, Event) buf+          #{const MENU_EVENT} ->+              MenuEvent `fmap` (#peek INPUT_RECORD, Event) buf+          #{const FOCUS_EVENT} ->+              FocusEvent `fmap` (#peek INPUT_RECORD, Event) buf+          _ -> error $ "Unknown input event type " ++ show event++foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW"+    c_ReadConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL

+ System/Win32/Console/Title.hsc view

@@ -0,0 +1,46 @@+{-# 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
+    ( getConsoleTitle
+    , setConsoleTitle
+    ) 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
+

System/Win32/DLL.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -15,70 +17,63 @@ -- ----------------------------------------------------------------------------- -module System.Win32.DLL where+module System.Win32.DLL+    ( disableThreadLibraryCalls+    , freeLibrary+    , getModuleFileName+    , getModuleHandle+    , getProcAddress+    , loadLibrary+    , loadLibraryEx+    , setDllDirectory+    , LoadLibraryFlags+    , lOAD_LIBRARY_AS_DATAFILE+    , lOAD_WITH_ALTERED_SEARCH_PATH+    ) where +import System.Win32.DLL.Internal import System.Win32.Types  import Foreign import Foreign.C--#include <windows.h>+import Data.Maybe (fromMaybe)  disableThreadLibraryCalls :: HMODULE -> IO () disableThreadLibraryCalls hmod =   failIfFalse_ "DisableThreadLibraryCalls" $ c_DisableThreadLibraryCalls hmod-foreign import stdcall unsafe "windows.h DisableThreadLibraryCalls"-  c_DisableThreadLibraryCalls :: HMODULE -> IO Bool  freeLibrary :: HMODULE -> IO () freeLibrary hmod =   failIfFalse_ "FreeLibrary" $ c_FreeLibrary hmod-foreign import stdcall unsafe "windows.h FreeLibrary"-  c_FreeLibrary :: HMODULE -> IO Bool -{-# CFILES cbits/HsWin32.c #-}-foreign import ccall "HsWin32.h &FreeLibraryFinaliser"-    c_FreeLibraryFinaliser :: FunPtr (HMODULE -> IO ())- getModuleFileName :: HMODULE -> IO String getModuleFileName hmod =   allocaArray 512 $ \ c_str -> do   failIfFalse_ "GetModuleFileName" $ c_GetModuleFileName hmod c_str 512   peekTString c_str-foreign import stdcall unsafe "windows.h GetModuleFileNameW"-  c_GetModuleFileName :: HMODULE -> LPTSTR -> Int -> IO Bool  getModuleHandle :: Maybe String -> IO HMODULE getModuleHandle mb_name =   maybeWith withTString mb_name $ \ c_name ->   failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name-foreign import stdcall unsafe "windows.h GetModuleHandleW"-  c_GetModuleHandle :: LPCTSTR -> IO HMODULE  getProcAddress :: HMODULE -> String -> IO Addr getProcAddress hmod procname =   withCAString procname $ \ c_procname ->   failIfNull "GetProcAddress" $ c_GetProcAddress hmod c_procname-foreign import stdcall unsafe "windows.h GetProcAddress"-  c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr -loadLibrary :: String -> IO HINSTANCE+loadLibrary :: String -> IO HMODULE loadLibrary name =   withTString name $ \ c_name ->   failIfNull "LoadLibrary" $ c_LoadLibrary c_name-foreign import stdcall unsafe "windows.h LoadLibraryW"-  c_LoadLibrary :: LPCTSTR -> IO HINSTANCE -type LoadLibraryFlags = DWORD--#{enum LoadLibraryFlags,- , lOAD_LIBRARY_AS_DATAFILE      = LOAD_LIBRARY_AS_DATAFILE- , lOAD_WITH_ALTERED_SEARCH_PATH = LOAD_WITH_ALTERED_SEARCH_PATH- }--loadLibraryEx :: String -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE+loadLibraryEx :: String -> HANDLE -> LoadLibraryFlags -> IO HMODULE loadLibraryEx name h flags =   withTString name $ \ c_name ->   failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags-foreign import stdcall unsafe "windows.h LoadLibraryExW"-  c_LoadLibraryEx :: LPCTSTR -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE++setDllDirectory :: Maybe String -> IO ()+setDllDirectory name =+  maybeWith withTString name $ \ c_name ->+  failIfFalse_ (unwords ["SetDllDirectory", fromMaybe "NULL" name]) $ c_SetDllDirectory c_name+

+ System/Win32/DLL/Internal.hsc view

@@ -0,0 +1,57 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.DLL.Internal+-- 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.DLL.Internal where++import System.Win32.Types++##include "windows_cconv.h"++#include <windows.h>++foreign import WINDOWS_CCONV unsafe "windows.h DisableThreadLibraryCalls"+  c_DisableThreadLibraryCalls :: HMODULE -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h FreeLibrary"+  c_FreeLibrary :: HMODULE -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"+  c_GetModuleFileName :: HMODULE -> LPTSTR -> Int -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h GetModuleHandleW"+  c_GetModuleHandle :: LPCTSTR -> IO HMODULE++foreign import WINDOWS_CCONV unsafe "windows.h GetProcAddress"+  c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr++foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryW"+  c_LoadLibrary :: LPCTSTR -> IO HMODULE++type LoadLibraryFlags = DWORD++#{enum LoadLibraryFlags,+ , lOAD_LIBRARY_AS_DATAFILE      = LOAD_LIBRARY_AS_DATAFILE+ , lOAD_WITH_ALTERED_SEARCH_PATH = LOAD_WITH_ALTERED_SEARCH_PATH+ }++foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryExW"+  c_LoadLibraryEx :: LPCTSTR -> HANDLE -> LoadLibraryFlags -> IO HMODULE++foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW"+  c_SetDllDirectory :: LPTSTR -> IO BOOL

System/Win32/DebugApi.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -14,32 +16,82 @@ -- A collection of FFI declarations for using Windows DebugApi. -- ------------------------------------------------------------------------------module System.Win32.DebugApi where+module System.Win32.DebugApi+    ( PID, TID, DebugEventId, ForeignAddress+    , PHANDLE, THANDLE+    , ThreadInfo+    , ImageInfo+    , ExceptionInfo+    , Exception(..)+    , DebugEventInfo(..)+    , DebugEvent +    , debugBreak+    , isDebuggerPresent++      -- * Debug events+    , waitForDebugEvent+    , getDebugEvents+    , continueDebugEvent++      -- * Debugging another process+    , debugActiveProcess+    , peekProcessMemory+    , readProcessMemory+    , pokeProcessMemory+    , withProcessMemory+    , peekP+    , pokeP++      -- * Thread control+    , suspendThread+    , resumeThread+    , withSuspendedThread++      -- * Thread register control+    , getThreadContext+    , setThreadContext+    , useAllRegs+    , withThreadContext++#if defined(i386_HOST_ARCH)+    , eax, ebx, ecx, edx, esi, edi, ebp, eip, esp+#elif defined(x86_64_HOST_ARCH)+    , rax, rbx, rcx, rdx, rsi, rdi, rbp, rip, rsp+#endif+#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH)+    , segCs, segDs, segEs, segFs, segGs+    , eFlags+    , dr+#endif+#if defined(aarch64_HOST_ARCH)+    , x0,   x1,  x2,  x3,  x4,  x5,  x6,  x7,  x8+    , x9,  x10, x11, x12, x13, x14, x15, x16, x17+    , x18, x19, x20, x21, x22, x23, x24, x25, x26+    , x27, x28,  fp,  lr,  sp,  pc+#endif+    , setReg, getReg, modReg+    , makeModThreadContext+    , modifyThreadContext++      -- * Sending debug output to another process+    , outputDebugString+    ) where++import System.Win32.DebugApi.Internal import Control.Exception( bracket_ )-import Data.Word        ( Word8, Word32 ) import Foreign          ( Ptr, nullPtr, ForeignPtr, mallocForeignPtrBytes                         , peekByteOff, plusPtr, allocaBytes, castPtr, poke                         , withForeignPtr, Storable, sizeOf, peek, pokeByteOff ) import System.IO        ( fixIO )-import System.Win32.Types   ( HANDLE, BOOL, WORD, DWORD, failIf_, failWith-                            , getLastError, failIf, LPTSTR, withTString )+import System.Win32.Types   ( WORD, DWORD, failIf_, failWith+                            , getLastError, failIf, withTString ) +##include "windows_cconv.h" #include "windows.h" -type PID = DWORD-type TID = DWORD-type DebugEventId = (PID, TID)-type ForeignAddress = Word32 -type PHANDLE = Ptr ()-type THANDLE = Ptr () -type ThreadInfo = (THANDLE, ForeignAddress, ForeignAddress)   -- handle to thread, thread local, thread start-type ImageInfo = (HANDLE, ForeignAddress, DWORD, DWORD, ForeignAddress)-type ExceptionInfo = (Bool, Bool, ForeignAddress) -- First chance, continuable, address-- data Exception     = UnknownException     | AccessViolation Bool ForeignAddress@@ -63,7 +115,7 @@     | SingleStep     | StackOverflow     deriving (Show)-    + data DebugEventInfo     = UnknownDebugEvent     | Exception         ExceptionInfo Exception@@ -91,12 +143,12 @@     where         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@@ -118,55 +170,55 @@                 (#const EXCEPTION_PRIV_INSTRUCTION)         -> return PrivilegedInstruction                 (#const EXCEPTION_SINGLE_STEP)              -> return SingleStep                 (#const EXCEPTION_STACK_OVERFLOW)           -> return StackOverflow-                _                                           -> return UnknownException +                _                                           -> 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-            return $ CreateProcess proc +        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_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-            return $ ++        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 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 UNLOAD_DLL_DEBUG_EVENT) p =-            (#peek UNLOAD_DLL_DEBUG_INFO, lpBaseOfDll) p >>= return.UnloadDll+        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 _ _ = return UnknownDebugEvent  @@ -188,9 +240,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 =@@ -287,12 +339,10 @@             (act buf)  +#if defined(i386_HOST_ARCH) eax, ebx, ecx, edx :: Int esi, edi :: Int ebp, eip, esp :: Int-segCs, segDs, segEs, segFs, segGs :: Int-eFlags :: Int- eax = (#offset CONTEXT, Eax) ebx = (#offset CONTEXT, Ebx) ecx = (#offset CONTEXT, Ecx)@@ -302,11 +352,70 @@ ebp = (#offset CONTEXT, Ebp) eip = (#offset CONTEXT, Eip) esp = (#offset CONTEXT, Esp)+#elif defined(x86_64_HOST_ARCH)+rax, rbx, rcx, rdx :: Int+rsi, rdi :: Int+rbp, rip, rsp :: Int+rax = (#offset CONTEXT, Rax)+rbx = (#offset CONTEXT, Rbx)+rcx = (#offset CONTEXT, Rcx)+rdx = (#offset CONTEXT, Rdx)+rsi = (#offset CONTEXT, Rsi)+rdi = (#offset CONTEXT, Rdi)+rbp = (#offset CONTEXT, Rbp)+rip = (#offset CONTEXT, Rip)+rsp = (#offset CONTEXT, Rsp)+#elif defined(aarch64_HOST_ARCH)+x0,   x1,  x2,  x3,  x4,  x5,  x6,  x7,  x8 :: Int+x9,  x10, x11, x12, x13, x14, x15, x16, x17 :: Int+x18, x19, x20, x21, x22, x23, x24, x25, x26 :: Int+x27, x28,  fp,  lr,  sp,  pc                :: Int+x0  = (#offset CONTEXT, X0 )+x1  = (#offset CONTEXT, X1 )+x2  = (#offset CONTEXT, X2 )+x3  = (#offset CONTEXT, X3 )+x4  = (#offset CONTEXT, X4 )+x5  = (#offset CONTEXT, X5 )+x6  = (#offset CONTEXT, X6 )+x7  = (#offset CONTEXT, X7 )+x8  = (#offset CONTEXT, X8 )+x9  = (#offset CONTEXT, X9 )+x10 = (#offset CONTEXT, X10)+x11 = (#offset CONTEXT, X11)+x12 = (#offset CONTEXT, X12)+x13 = (#offset CONTEXT, X13)+x14 = (#offset CONTEXT, X14)+x15 = (#offset CONTEXT, X15)+x16 = (#offset CONTEXT, X16)+x17 = (#offset CONTEXT, X17)+x18 = (#offset CONTEXT, X18)+x19 = (#offset CONTEXT, X19)+x20 = (#offset CONTEXT, X20)+x21 = (#offset CONTEXT, X21)+x22 = (#offset CONTEXT, X22)+x23 = (#offset CONTEXT, X23)+x24 = (#offset CONTEXT, X24)+x25 = (#offset CONTEXT, X25)+x26 = (#offset CONTEXT, X26)+x27 = (#offset CONTEXT, X27)+x28 = (#offset CONTEXT, X28)+fp  = (#offset CONTEXT, Fp)+lr  = (#offset CONTEXT, Lr)+sp  = (#offset CONTEXT, Sp)+pc  = (#offset CONTEXT, Pc)+#else+#error Unknown mingw32 arch+#endif++#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH)+segCs, segDs, segEs, segFs, segGs :: Int segCs = (#offset CONTEXT, SegCs) segDs = (#offset CONTEXT, SegDs) segEs = (#offset CONTEXT, SegEs) segFs = (#offset CONTEXT, SegFs) segGs = (#offset CONTEXT, SegGs)++eFlags :: Int eFlags  = (#offset CONTEXT, EFlags)  dr :: Int -> Int@@ -318,7 +427,8 @@     6 -> (#offset CONTEXT, Dr6)     7 -> (#offset CONTEXT, Dr7)     _ -> undefined-    +#endif+ setReg :: Ptr a -> Int -> DWORD -> IO () setReg = pokeByteOff @@ -341,50 +451,5 @@ -- On process being debugged  outputDebugString :: String -> IO ()-outputDebugString s = withTString s $ \s -> c_OutputDebugString s------------------------------------------------------------------------------- Raw imports--foreign import stdcall "windows.h SuspendThread"-    c_SuspendThread :: THANDLE -> IO DWORD--foreign import stdcall "windows.h ResumeThread"-    c_ResumeThread :: THANDLE -> IO DWORD--foreign import stdcall "windows.h WaitForDebugEvent"-    c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL--foreign import stdcall "windows.h ContinueDebugEvent"-    c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL--foreign import stdcall "windows.h DebugActiveProcess"-    c_DebugActiveProcess :: DWORD -> IO Bool-    --- Windows XP--- foreign import stdcall "windows.h DebugActiveProcessStop"---     c_DebugActiveProcessStop :: DWORD -> IO Bool--foreign import stdcall "windows.h ReadProcessMemory" c_ReadProcessMemory :: -    PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL--foreign import stdcall "windows.h WriteProcessMemory" c_WriteProcessMemory ::-    PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL--foreign import stdcall "windows.h GetThreadContext"-    c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL--foreign import stdcall "windows.h SetThreadContext"-    c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL----foreign import stdcall "windows.h GetThreadId"---    c_GetThreadId :: THANDLE -> IO TID--foreign import stdcall "windows.h OutputDebugStringW"-    c_OutputDebugString :: LPTSTR -> IO ()--foreign import stdcall "windows.h IsDebuggerPresent"-    isDebuggerPresent :: IO BOOL+outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s -foreign import stdcall "windows.h  DebugBreak"-    debugBreak :: IO ()

+ System/Win32/DebugApi/Internal.hsc view

@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.WindowsString.DebugApi.Internal+-- Copyright   :  (c) Esa Ilari Vuokko, 2006+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of FFI declarations for using Windows DebugApi.+--+-----------------------------------------------------------------------------++module System.Win32.DebugApi.Internal where++import Data.Word            ( Word8, Word32 )+import Foreign              ( Ptr )+import System.Win32.Types   ( BOOL, DWORD, HANDLE, LPTSTR )++##include "windows_cconv.h"+#include "windows.h"++type PID = DWORD+type TID = DWORD+type DebugEventId = (PID, TID)+type ForeignAddress = Word32++type PHANDLE = Ptr ()+type THANDLE = Ptr ()++type ThreadInfo = (THANDLE, ForeignAddress, ForeignAddress)   -- handle to thread, thread local, thread start+type ImageInfo = (HANDLE, ForeignAddress, DWORD, DWORD, ForeignAddress)+type ExceptionInfo = (Bool, Bool, ForeignAddress) -- First chance, continuable, address++--------------------------------------------------------------------------+-- Raw imports++foreign import WINDOWS_CCONV "windows.h SuspendThread"+    c_SuspendThread :: THANDLE -> IO DWORD++foreign import WINDOWS_CCONV "windows.h ResumeThread"+    c_ResumeThread :: THANDLE -> IO DWORD++foreign import WINDOWS_CCONV "windows.h WaitForDebugEvent"+    c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL++foreign import WINDOWS_CCONV "windows.h ContinueDebugEvent"+    c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL++foreign import WINDOWS_CCONV "windows.h DebugActiveProcess"+    c_DebugActiveProcess :: DWORD -> IO Bool++-- Windows XP+-- foreign import WINDOWS_CCONV "windows.h DebugActiveProcessStop"+--     c_DebugActiveProcessStop :: DWORD -> IO Bool++foreign import WINDOWS_CCONV "windows.h ReadProcessMemory" c_ReadProcessMemory ::+    PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL++foreign import WINDOWS_CCONV "windows.h WriteProcessMemory" c_WriteProcessMemory ::+    PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL++foreign import WINDOWS_CCONV "windows.h GetThreadContext"+    c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL++foreign import WINDOWS_CCONV "windows.h SetThreadContext"+    c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL++--foreign import WINDOWS_CCONV "windows.h GetThreadId"+--    c_GetThreadId :: THANDLE -> IO TID++foreign import WINDOWS_CCONV "windows.h OutputDebugStringW"+    c_OutputDebugString :: LPTSTR -> IO ()++foreign import WINDOWS_CCONV "windows.h IsDebuggerPresent"+    isDebuggerPresent :: IO BOOL++foreign import WINDOWS_CCONV "windows.h  DebugBreak"+    debugBreak :: IO ()

+ System/Win32/Encoding.hs view

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

+ System/Win32/Event.hsc view

@@ -0,0 +1,163 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.Event+-- Copyright   :  (c) Esa Ilari Vuokko, 2006+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of FFI declarations for interfacing with Win32 event system between+-- processes.+--+-----------------------------------------------------------------------------+module System.Win32.Event+    ( -- * Duplicate options+      DuplicateOption+    , dUPLICATE_CLOSE_SOURCE+    , dUPLICATE_SAME_ACCESS+      -- * Access modes+    , AccessMode+    , eVENT_ALL_ACCESS+    , eVENT_MODIFY_STATE+      -- * Wait results+    , WaitResult+    , wAIT_ABANDONED+    , wAIT_IO_COMPLETION+    , wAIT_OBJECT_0+    , wAIT_TIMEOUT+    , wAIT_FAILED+      -- * Managing events+    , openEvent+    , createEvent+    , duplicateHandle+    , setEvent+    , resetEvent+    , pulseEvent+      -- * Signalling objects+    , signalObjectAndWait+      -- * Waiting on objects+    , waitForSingleObject+    , waitForSingleObjectEx+    , waitForMultipleObjects+    , waitForMultipleObjectsEx+    ) where++import Foreign.Marshal.Alloc     ( alloca )+import Foreign.Marshal.Array     ( withArrayLen )+import Foreign.Marshal.Utils     ( maybeWith, with )+import Foreign.Ptr               ( Ptr, nullPtr )+import Foreign.Storable          ( Storable(..) )+import Graphics.Win32.Misc       ( MilliSeconds )+import System.Win32.File         ( AccessMode, LPSECURITY_ATTRIBUTES, SECURITY_ATTRIBUTES )+import System.Win32.Types        ( LPCTSTR, HANDLE, BOOL, withTString, failIf, failIfFalse_  )+import System.Win32.Word         ( DWORD )++##include "windows_cconv.h"++#include "windows.h"+#include "winuser_compat.h"+#include "alignment.h"++---------------------------------------------------------------------------+-- Enums+---------------------------------------------------------------------------+type DuplicateOption = DWORD+#{enum DuplicateOption,+    , dUPLICATE_CLOSE_SOURCE = DUPLICATE_CLOSE_SOURCE+    , dUPLICATE_SAME_ACCESS  = DUPLICATE_SAME_ACCESS+    }++#{enum AccessMode,+    , eVENT_ALL_ACCESS   = EVENT_ALL_ACCESS+    , eVENT_MODIFY_STATE = EVENT_MODIFY_STATE+    }++type WaitResult = DWORD+#{enum WaitResult,+    , wAIT_ABANDONED     = WAIT_ABANDONED+    , wAIT_IO_COMPLETION = WAIT_IO_COMPLETION+    , wAIT_OBJECT_0      = WAIT_OBJECT_0+    , wAIT_TIMEOUT       = WAIT_TIMEOUT+    , wAIT_FAILED        = WAIT_FAILED+    }++---------------------------------------------------------------------------+-- API in Haskell+---------------------------------------------------------------------------+openEvent :: AccessMode -> Bool -> String -> IO HANDLE+openEvent amode inherit name = withTString name $ \c_name ->+    failIf (==nullPtr) "openEvent: OpenEvent" $ c_OpenEvent (fromIntegral amode) inherit c_name++createEvent :: Maybe SECURITY_ATTRIBUTES -> Bool -> Bool -> String -> IO HANDLE+createEvent msecurity manual initial name = withTString name $ \c_name ->+    maybeWith with msecurity $ \c_sec ->+        failIf (==nullPtr) "createEvent: CreateEvent" $ c_CreateEvent c_sec manual initial c_name++duplicateHandle :: HANDLE -> HANDLE -> HANDLE -> AccessMode -> Bool -> DuplicateOption -> IO HANDLE+duplicateHandle srcProccess srcHandler targetProcess access inherit opts = alloca $ \res -> do+    failIfFalse_ "duplicateHandle: DuplicateHandle" $ c_DuplicateHandle srcProccess srcHandler targetProcess res (fromIntegral access) inherit opts+    peek res++setEvent :: HANDLE -> IO ()+setEvent event = failIfFalse_ "setEvent: SetEvent" $ c_SetEvent event++resetEvent :: HANDLE -> IO ()+resetEvent event = failIfFalse_ "resetEvent: ResetEvent" $ c_ResetEvent event++pulseEvent :: HANDLE -> IO ()+pulseEvent event = failIfFalse_ "pulseEvent: PulseEvent" $ c_PulseEvent event++signalObjectAndWait :: HANDLE -> HANDLE -> MilliSeconds -> Bool -> IO WaitResult+signalObjectAndWait toSignal toWaitOn millis alterable = c_SignalObjectAndWait toSignal toWaitOn millis alterable++waitForSingleObject :: HANDLE -> MilliSeconds -> IO WaitResult+waitForSingleObject toWaitOn millis = c_WaitForSingleObject toWaitOn millis++waitForSingleObjectEx :: HANDLE -> MilliSeconds -> Bool -> IO WaitResult+waitForSingleObjectEx toWaitOn millis alterable = c_WaitForSingleObjectEx toWaitOn millis alterable++waitForMultipleObjects :: [HANDLE] -> Bool -> MilliSeconds -> IO WaitResult+waitForMultipleObjects hs waitAll millis = withArrayLen hs $ \n hsp ->+  c_WaitForMultipleObjects (fromIntegral n) hsp waitAll millis++waitForMultipleObjectsEx :: [HANDLE] -> Bool -> MilliSeconds -> Bool -> IO WaitResult+waitForMultipleObjectsEx hs waitAll millis alterable = withArrayLen hs $ \n hsp ->+  c_WaitForMultipleObjectsEx (fromIntegral n) hsp waitAll millis alterable++---------------------------------------------------------------------------+-- Imports+---------------------------------------------------------------------------+foreign import WINDOWS_CCONV "windows.h OpenEventW"+    c_OpenEvent :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE++foreign import WINDOWS_CCONV "windows.h CreateEventW"+    c_CreateEvent :: LPSECURITY_ATTRIBUTES -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE++foreign import WINDOWS_CCONV "windows.h DuplicateHandle"+    c_DuplicateHandle :: HANDLE -> HANDLE -> HANDLE -> Ptr HANDLE -> DWORD -> BOOL -> DWORD -> IO BOOL++foreign import WINDOWS_CCONV "windows.h SetEvent"+    c_SetEvent :: HANDLE -> IO Bool++foreign import WINDOWS_CCONV "windows.h ResetEvent"+    c_ResetEvent :: HANDLE -> IO Bool++foreign import WINDOWS_CCONV "windows.h PulseEvent"+    c_PulseEvent :: HANDLE -> IO Bool++foreign import WINDOWS_CCONV "windows.h SignalObjectAndWait"+    c_SignalObjectAndWait :: HANDLE -> HANDLE -> DWORD -> BOOL -> IO DWORD++foreign import WINDOWS_CCONV "windows.h WaitForSingleObject"+    c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD++foreign import WINDOWS_CCONV "windows.h WaitForSingleObjectEx"+    c_WaitForSingleObjectEx :: HANDLE -> DWORD -> BOOL -> IO DWORD++foreign import WINDOWS_CCONV "windows.h WaitForMultipleObjects"+    c_WaitForMultipleObjects :: DWORD -> Ptr HANDLE -> BOOL -> DWORD -> IO DWORD++foreign import WINDOWS_CCONV "windows.h WaitForMultipleObjectsEx"+    c_WaitForMultipleObjectsEx :: DWORD -> Ptr HANDLE -> BOOL -> DWORD -> BOOL -> IO DWORD

+ System/Win32/Exception/Unsupported.hs view

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

System/Win32/File.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,250 +18,249 @@ -----------------------------------------------------------------------------  module System.Win32.File-{--	( AccessMode, ShareMode, CreateMode, FileAttributeOrFlag-	, CreateFile, CloseHandle, DeleteFile, CopyFile-	, MoveFileFlag, MoveFile, MoveFileEx,-	)--}-where--import System.Win32.Types-import System.Win32.Time--import Foreign hiding (void)-import Control.Monad-import Control.Concurrent--#include <windows.h>--------------------------------------------------------------------- Enumeration types-------------------------------------------------------------------type AccessMode   = UINT--gENERIC_NONE :: AccessMode-gENERIC_NONE = 0--#{enum AccessMode,- , gENERIC_READ             = GENERIC_READ- , gENERIC_WRITE            = GENERIC_WRITE- , gENERIC_EXECUTE          = GENERIC_EXECUTE- , gENERIC_ALL              = GENERIC_ALL- , dELETE                   = DELETE- , rEAD_CONTROL             = READ_CONTROL- , wRITE_DAC                = WRITE_DAC- , wRITE_OWNER              = WRITE_OWNER- , sYNCHRONIZE              = SYNCHRONIZE- , sTANDARD_RIGHTS_REQUIRED = STANDARD_RIGHTS_REQUIRED- , sTANDARD_RIGHTS_READ     = STANDARD_RIGHTS_READ- , sTANDARD_RIGHTS_WRITE    = STANDARD_RIGHTS_WRITE- , sTANDARD_RIGHTS_EXECUTE  = STANDARD_RIGHTS_EXECUTE- , sTANDARD_RIGHTS_ALL      = STANDARD_RIGHTS_ALL- , sPECIFIC_RIGHTS_ALL      = SPECIFIC_RIGHTS_ALL- , aCCESS_SYSTEM_SECURITY   = ACCESS_SYSTEM_SECURITY- , mAXIMUM_ALLOWED          = MAXIMUM_ALLOWED- }--------------------------------------------------------------------type ShareMode   = UINT--fILE_SHARE_NONE :: ShareMode-fILE_SHARE_NONE = 0--#{enum ShareMode,- , fILE_SHARE_READ      = FILE_SHARE_READ- , fILE_SHARE_WRITE     = FILE_SHARE_WRITE- }--------------------------------------------------------------------type CreateMode   = UINT--#{enum CreateMode,- , cREATE_NEW           = CREATE_NEW- , cREATE_ALWAYS        = CREATE_ALWAYS- , oPEN_EXISTING        = OPEN_EXISTING- , oPEN_ALWAYS          = OPEN_ALWAYS- , tRUNCATE_EXISTING    = TRUNCATE_EXISTING- }+    ( -- * Access modes+      AccessMode+    , gENERIC_NONE+    , gENERIC_READ+    , gENERIC_WRITE+    , gENERIC_EXECUTE+    , gENERIC_ALL+    , dELETE+    , rEAD_CONTROL+    , wRITE_DAC+    , wRITE_OWNER+    , sYNCHRONIZE+    , sTANDARD_RIGHTS_REQUIRED+    , sTANDARD_RIGHTS_READ+    , sTANDARD_RIGHTS_WRITE+    , sTANDARD_RIGHTS_EXECUTE+    , sTANDARD_RIGHTS_ALL+    , sPECIFIC_RIGHTS_ALL+    , aCCESS_SYSTEM_SECURITY+    , mAXIMUM_ALLOWED+    , fILE_ADD_FILE+    , fILE_ADD_SUBDIRECTORY+    , fILE_ALL_ACCESS+    , fILE_APPEND_DATA+    , fILE_CREATE_PIPE_INSTANCE+    , fILE_DELETE_CHILD+    , fILE_EXECUTE+    , fILE_LIST_DIRECTORY+    , fILE_READ_ATTRIBUTES+    , fILE_READ_DATA+    , fILE_READ_EA+    , fILE_TRAVERSE+    , fILE_WRITE_ATTRIBUTES+    , fILE_WRITE_DATA+    , fILE_WRITE_EA -----------------------------------------------------------------+      -- * Sharing modes+    , ShareMode+    , fILE_SHARE_NONE+    , fILE_SHARE_READ+    , fILE_SHARE_WRITE+    , fILE_SHARE_DELETE -type FileAttributeOrFlag   = UINT+      -- * Creation modes+    , CreateMode+    , cREATE_NEW+    , cREATE_ALWAYS+    , oPEN_EXISTING+    , oPEN_ALWAYS+    , tRUNCATE_EXISTING -#{enum FileAttributeOrFlag,- , fILE_ATTRIBUTE_READONLY      = FILE_ATTRIBUTE_READONLY- , fILE_ATTRIBUTE_HIDDEN        = FILE_ATTRIBUTE_HIDDEN- , fILE_ATTRIBUTE_SYSTEM        = FILE_ATTRIBUTE_SYSTEM- , fILE_ATTRIBUTE_DIRECTORY     = FILE_ATTRIBUTE_DIRECTORY- , fILE_ATTRIBUTE_ARCHIVE       = FILE_ATTRIBUTE_ARCHIVE- , fILE_ATTRIBUTE_NORMAL        = FILE_ATTRIBUTE_NORMAL- , fILE_ATTRIBUTE_TEMPORARY     = FILE_ATTRIBUTE_TEMPORARY- , fILE_ATTRIBUTE_COMPRESSED    = FILE_ATTRIBUTE_COMPRESSED- , fILE_FLAG_WRITE_THROUGH      = FILE_FLAG_WRITE_THROUGH- , fILE_FLAG_OVERLAPPED         = FILE_FLAG_OVERLAPPED- , fILE_FLAG_NO_BUFFERING       = FILE_FLAG_NO_BUFFERING- , fILE_FLAG_RANDOM_ACCESS      = FILE_FLAG_RANDOM_ACCESS- , fILE_FLAG_SEQUENTIAL_SCAN    = FILE_FLAG_SEQUENTIAL_SCAN- , fILE_FLAG_DELETE_ON_CLOSE    = FILE_FLAG_DELETE_ON_CLOSE- , fILE_FLAG_BACKUP_SEMANTICS   = FILE_FLAG_BACKUP_SEMANTICS- , fILE_FLAG_POSIX_SEMANTICS    = FILE_FLAG_POSIX_SEMANTICS- }+      -- * File attributes and flags+    , FileAttributeOrFlag+    , fILE_ATTRIBUTE_READONLY+    , fILE_ATTRIBUTE_HIDDEN+    , fILE_ATTRIBUTE_SYSTEM+    , fILE_ATTRIBUTE_DIRECTORY+    , fILE_ATTRIBUTE_ARCHIVE+    , fILE_ATTRIBUTE_NORMAL+    , fILE_ATTRIBUTE_TEMPORARY+    , fILE_ATTRIBUTE_COMPRESSED+    , fILE_ATTRIBUTE_REPARSE_POINT+    , fILE_FLAG_WRITE_THROUGH+    , fILE_FLAG_OVERLAPPED+    , fILE_FLAG_NO_BUFFERING+    , fILE_FLAG_RANDOM_ACCESS+    , fILE_FLAG_SEQUENTIAL_SCAN+    , fILE_FLAG_DELETE_ON_CLOSE+    , fILE_FLAG_BACKUP_SEMANTICS+    , fILE_FLAG_POSIX_SEMANTICS #ifndef __WINE_WINDOWS_H-#{enum FileAttributeOrFlag,- , sECURITY_ANONYMOUS           = SECURITY_ANONYMOUS- , sECURITY_IDENTIFICATION      = SECURITY_IDENTIFICATION- , sECURITY_IMPERSONATION       = SECURITY_IMPERSONATION- , sECURITY_DELEGATION          = SECURITY_DELEGATION- , sECURITY_CONTEXT_TRACKING    = SECURITY_CONTEXT_TRACKING- , sECURITY_EFFECTIVE_ONLY      = SECURITY_EFFECTIVE_ONLY- , sECURITY_SQOS_PRESENT        = SECURITY_SQOS_PRESENT- , sECURITY_VALID_SQOS_FLAGS    = SECURITY_VALID_SQOS_FLAGS- }+    , sECURITY_ANONYMOUS+    , sECURITY_IDENTIFICATION+    , sECURITY_IMPERSONATION+    , sECURITY_DELEGATION+    , sECURITY_CONTEXT_TRACKING+    , sECURITY_EFFECTIVE_ONLY+    , sECURITY_SQOS_PRESENT+    , sECURITY_VALID_SQOS_FLAGS #endif -------------------------------------------------------------------type MoveFileFlag   = DWORD--#{enum MoveFileFlag,- , mOVEFILE_REPLACE_EXISTING	= MOVEFILE_REPLACE_EXISTING- , mOVEFILE_COPY_ALLOWED	= MOVEFILE_COPY_ALLOWED- , mOVEFILE_DELAY_UNTIL_REBOOT	= MOVEFILE_DELAY_UNTIL_REBOOT- }--------------------------------------------------------------------type FilePtrDirection   = DWORD+      -- * Move file flags+    , MoveFileFlag+    , mOVEFILE_REPLACE_EXISTING+    , mOVEFILE_COPY_ALLOWED+    , mOVEFILE_DELAY_UNTIL_REBOOT -#{enum FilePtrDirection,- , fILE_BEGIN   = FILE_BEGIN- , fILE_CURRENT = FILE_CURRENT- , fILE_END     = FILE_END- }+      -- * File pointer directions+    , FilePtrDirection+    , fILE_BEGIN+    , fILE_CURRENT+    , fILE_END -----------------------------------------------------------------+      -- * Drive types+    , DriveType+    , dRIVE_UNKNOWN+    , dRIVE_NO_ROOT_DIR+    , dRIVE_REMOVABLE+    , dRIVE_FIXED+    , dRIVE_REMOTE+    , dRIVE_CDROM+    , dRIVE_RAMDISK -type DriveType = UINT+      -- * Define DOS device flags+    , DefineDosDeviceFlags+    , dDD_RAW_TARGET_PATH+    , dDD_REMOVE_DEFINITION+    , dDD_EXACT_MATCH_ON_REMOVE -#{enum DriveType,- , dRIVE_UNKNOWN        = DRIVE_UNKNOWN- , dRIVE_NO_ROOT_DIR    = DRIVE_NO_ROOT_DIR- , dRIVE_REMOVABLE      = DRIVE_REMOVABLE- , dRIVE_FIXED          = DRIVE_FIXED- , dRIVE_REMOTE         = DRIVE_REMOTE- , dRIVE_CDROM          = DRIVE_CDROM- , dRIVE_RAMDISK        = DRIVE_RAMDISK- }+      -- * Binary types+    , BinaryType+    , sCS_32BIT_BINARY+    , sCS_DOS_BINARY+    , sCS_WOW_BINARY+    , sCS_PIF_BINARY+    , sCS_POSIX_BINARY+    , sCS_OS216_BINARY -----------------------------------------------------------------+      -- * File notification flags+    , FileNotificationFlag+    , fILE_NOTIFY_CHANGE_FILE_NAME+    , fILE_NOTIFY_CHANGE_DIR_NAME+    , fILE_NOTIFY_CHANGE_ATTRIBUTES+    , fILE_NOTIFY_CHANGE_SIZE+    , fILE_NOTIFY_CHANGE_LAST_WRITE+    , fILE_NOTIFY_CHANGE_SECURITY -type DefineDosDeviceFlags = DWORD+      -- * File types+    , FileType+    , fILE_TYPE_UNKNOWN+    , fILE_TYPE_DISK+    , fILE_TYPE_CHAR+    , fILE_TYPE_PIPE+    , fILE_TYPE_REMOTE -#{enum DefineDosDeviceFlags,- , dDD_RAW_TARGET_PATH          = DDD_RAW_TARGET_PATH- , dDD_REMOVE_DEFINITION        = DDD_REMOVE_DEFINITION- , dDD_EXACT_MATCH_ON_REMOVE    = DDD_EXACT_MATCH_ON_REMOVE- }+      -- * Lock modes+    , LockMode+    , lOCKFILE_EXCLUSIVE_LOCK+    , lOCKFILE_FAIL_IMMEDIATELY -----------------------------------------------------------------+      -- * GetFileEx information levels+    , GET_FILEEX_INFO_LEVELS+    , getFileExInfoStandard+    , getFileExMaxInfoLevel -type BinaryType = DWORD+      -- * Security attributes+    , SECURITY_ATTRIBUTES(..)+    , PSECURITY_ATTRIBUTES+    , LPSECURITY_ATTRIBUTES+    , MbLPSECURITY_ATTRIBUTES -#{enum BinaryType,- , sCS_32BIT_BINARY     = SCS_32BIT_BINARY- , sCS_DOS_BINARY       = SCS_DOS_BINARY- , sCS_WOW_BINARY       = SCS_WOW_BINARY- , sCS_PIF_BINARY       = SCS_PIF_BINARY- , sCS_POSIX_BINARY     = SCS_POSIX_BINARY- , sCS_OS216_BINARY     = SCS_OS216_BINARY- }+      -- * BY_HANDLE file information+    , BY_HANDLE_FILE_INFORMATION(..) -----------------------------------------------------------------+      -- * Win32 file attribute data+    , WIN32_FILE_ATTRIBUTE_DATA(..) -type FileNotificationFlag = DWORD+      -- * Helpers+    , failIfWithRetry+    , failIfWithRetry_+    , failIfFalseWithRetry_+      -- * File operations+    , deleteFile+    , copyFile+    , moveFile+    , moveFileEx+    , setCurrentDirectory+    , createDirectory+    , createDirectoryEx+    , removeDirectory+    , getBinaryType+    , getTempFileName+    , replaceFile -#{enum FileNotificationFlag,- , fILE_NOTIFY_CHANGE_FILE_NAME  = FILE_NOTIFY_CHANGE_FILE_NAME- , fILE_NOTIFY_CHANGE_DIR_NAME   = FILE_NOTIFY_CHANGE_DIR_NAME- , fILE_NOTIFY_CHANGE_ATTRIBUTES = FILE_NOTIFY_CHANGE_ATTRIBUTES- , fILE_NOTIFY_CHANGE_SIZE       = FILE_NOTIFY_CHANGE_SIZE- , fILE_NOTIFY_CHANGE_LAST_WRITE = FILE_NOTIFY_CHANGE_LAST_WRITE- , fILE_NOTIFY_CHANGE_SECURITY   = FILE_NOTIFY_CHANGE_SECURITY- }+      -- * HANDLE operations+    , createFile+    , createFile_NoRetry+    , closeHandle+    , getFileType+    , flushFileBuffers+    , setEndOfFile+    , setFileAttributes+    , getFileAttributes+    , getFileAttributesExStandard+    , getFileInformationByHandle -----------------------------------------------------------------+      -- ** Reading/writing+      -- | Some operations below bear the @win32_@ prefix to avoid shadowing+      -- operations from "Prelude".+    , OVERLAPPED(..)+    , LPOVERLAPPED+    , MbLPOVERLAPPED+    , win32_ReadFile+    , win32_WriteFile+    , setFilePointerEx -type FileType = DWORD+      -- * File notifications+    , findFirstChangeNotification+    , findNextChangeNotification+    , findCloseChangeNotification -#{enum FileType,- , fILE_TYPE_UNKNOWN    = FILE_TYPE_UNKNOWN- , fILE_TYPE_DISK       = FILE_TYPE_DISK- , fILE_TYPE_CHAR       = FILE_TYPE_CHAR- , fILE_TYPE_PIPE       = FILE_TYPE_PIPE- , fILE_TYPE_REMOTE     = FILE_TYPE_REMOTE- }+      -- * Directories+    , FindData+    , getFindDataFileName+    , findFirstFile+    , findNextFile+    , findClose -----------------------------------------------------------------+      -- * DOS device flags+    , defineDosDevice+    , areFileApisANSI+    , setFileApisToOEM+    , setFileApisToANSI+    , setHandleCount+    , getLogicalDrives+    , getDiskFreeSpace+    , setVolumeLabel -type LPSECURITY_ATTRIBUTES = Ptr ()-type MbLPSECURITY_ATTRIBUTES = Maybe LPSECURITY_ATTRIBUTES+      -- * File locks+    , lockFile+    , unlockFile+    ) where -------------------------------------------------------------------- Other types-----------------------------------------------------------------+import System.Win32.File.Internal+import System.Win32.Types -data BY_HANDLE_FILE_INFORMATION = BY_HANDLE_FILE_INFORMATION-    { bhfiFileAttributes :: FileAttributeOrFlag-    , bhfiCreationTime, bhfiLastAccessTime, bhfiLastWriteTime :: FILETIME-    , bhfiVolumeSerialNumber :: DWORD-    , bhfiSize :: DDWORD-    , bhfiNumberOfLinks :: DWORD-    , bhfiFileIndex :: DDWORD-    } deriving (Show)+import Foreign hiding (void)+import Control.Monad+import Control.Concurrent+import Data.Maybe (fromMaybe) -instance Storable BY_HANDLE_FILE_INFORMATION where-    sizeOf = const (#size BY_HANDLE_FILE_INFORMATION)-    alignment = sizeOf-    poke buf bhi = do-        (#poke BY_HANDLE_FILE_INFORMATION, dwFileAttributes)     buf (bhfiFileAttributes bhi)-        (#poke BY_HANDLE_FILE_INFORMATION, ftCreationTime)       buf (bhfiCreationTime bhi)-        (#poke BY_HANDLE_FILE_INFORMATION, ftLastAccessTime)     buf (bhfiLastAccessTime bhi)-        (#poke BY_HANDLE_FILE_INFORMATION, ftLastWriteTime)      buf (bhfiLastWriteTime bhi)-        (#poke BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf (bhfiVolumeSerialNumber bhi)-        (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeHigh)        buf sizeHi-        (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeLow)         buf sizeLow-        (#poke BY_HANDLE_FILE_INFORMATION, nNumberOfLinks)       buf (bhfiNumberOfLinks bhi)-        (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexHigh)       buf idxHi-        (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexLow)        buf idxLow-        where-            (sizeHi,sizeLow) = ddwordToDwords $ bhfiSize bhi-            (idxHi,idxLow) = ddwordToDwords $ bhfiFileIndex bhi+##include "windows_cconv.h" -    peek buf = do-        attr <- (#peek BY_HANDLE_FILE_INFORMATION, dwFileAttributes)     buf-        ctim <- (#peek BY_HANDLE_FILE_INFORMATION, ftCreationTime)       buf-        lati <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastAccessTime)     buf-        lwti <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastWriteTime)      buf-        vser <- (#peek BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf-        fshi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeHigh)        buf-        fslo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeLow)         buf-        link <- (#peek BY_HANDLE_FILE_INFORMATION, nNumberOfLinks)       buf-        idhi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexHigh)       buf-        idlo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexLow)        buf-        return $ BY_HANDLE_FILE_INFORMATION attr ctim lati lwti vser-            (dwordsToDdword (fshi,fslo)) link (dwordsToDdword (idhi,idlo))+#include <windows.h>+#include "alignment.h"  ---------------------------------------------------------------- -- File operations ---------------------------------------------------------------- --- | like failIfFalse_, but retried on sharing violations.+-- | like failIf, but retried on sharing violations. -- This is necessary for many file operations; see---   http://support.microsoft.com/kb/316609+--   https://www.betaarchive.com/wiki/index.php/Microsoft_KB_Archive/316609 -- failIfWithRetry :: (a -> Bool) -> String -> IO a -> IO a failIfWithRetry cond msg action = retryOrFail retries@@ -289,157 +290,144 @@  deleteFile :: String -> IO () deleteFile name =-  withTString name $ \ c_name ->+  withFilePath name $ \ c_name ->     failIfFalseWithRetry_ (unwords ["DeleteFile",show name]) $       c_DeleteFile c_name-foreign import stdcall unsafe "windows.h DeleteFileW"-  c_DeleteFile :: LPCTSTR -> IO Bool  copyFile :: String -> String -> Bool -> IO () copyFile src dest over =-  withTString src $ \ c_src ->-  withTString dest $ \ c_dest ->+  withFilePath src $ \ c_src ->+  withFilePath dest $ \ c_dest ->   failIfFalseWithRetry_ (unwords ["CopyFile",show src,show dest]) $     c_CopyFile c_src c_dest over-foreign import stdcall unsafe "windows.h CopyFileW"-  c_CopyFile :: LPCTSTR -> LPCTSTR -> Bool -> IO Bool  moveFile :: String -> String -> IO () moveFile src dest =-  withTString src $ \ c_src ->-  withTString dest $ \ c_dest ->+  withFilePath src $ \ c_src ->+  withFilePath dest $ \ c_dest ->   failIfFalseWithRetry_ (unwords ["MoveFile",show src,show dest]) $     c_MoveFile c_src c_dest-foreign import stdcall unsafe "windows.h MoveFileW"-  c_MoveFile :: LPCTSTR -> LPCTSTR -> IO Bool -moveFileEx :: String -> String -> MoveFileFlag -> IO ()+moveFileEx :: String -> Maybe String -> MoveFileFlag -> IO () moveFileEx src dest flags =-  withTString src $ \ c_src ->-  withTString dest $ \ c_dest ->+  withFilePath src $ \ c_src ->+  maybeWith withFilePath dest $ \ c_dest ->   failIfFalseWithRetry_ (unwords ["MoveFileEx",show src,show dest]) $     c_MoveFileEx c_src c_dest flags-foreign import stdcall unsafe "windows.h MoveFileExW"-  c_MoveFileEx :: LPCTSTR -> LPCTSTR -> MoveFileFlag -> IO Bool  setCurrentDirectory :: String -> IO () setCurrentDirectory name =-  withTString name $ \ c_name ->+  withFilePath name $ \ c_name ->   failIfFalse_ (unwords ["SetCurrentDirectory",show name]) $     c_SetCurrentDirectory c_name-foreign import stdcall unsafe "windows.h SetCurrentDirectoryW"-  c_SetCurrentDirectory :: LPCTSTR -> IO Bool  createDirectory :: String -> Maybe LPSECURITY_ATTRIBUTES -> IO () createDirectory name mb_attr =-  withTString name $ \ c_name ->+  withFilePath name $ \ c_name ->   failIfFalseWithRetry_ (unwords ["CreateDirectory",show name]) $     c_CreateDirectory c_name (maybePtr mb_attr)-foreign import stdcall unsafe "windows.h CreateDirectoryW"-  c_CreateDirectory :: LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool  createDirectoryEx :: String -> String -> Maybe LPSECURITY_ATTRIBUTES -> IO () createDirectoryEx template name mb_attr =-  withTString template $ \ c_template ->-  withTString name $ \ c_name ->+  withFilePath template $ \ c_template ->+  withFilePath name $ \ c_name ->   failIfFalseWithRetry_ (unwords ["CreateDirectoryEx",show template,show name]) $     c_CreateDirectoryEx c_template c_name (maybePtr mb_attr)-foreign import stdcall unsafe "windows.h CreateDirectoryExW"-  c_CreateDirectoryEx :: LPCTSTR -> LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool  removeDirectory :: String -> IO () removeDirectory name =-  withTString name $ \ c_name ->+  withFilePath name $ \ c_name ->   failIfFalseWithRetry_ (unwords ["RemoveDirectory",show name]) $     c_RemoveDirectory c_name-foreign import stdcall unsafe "windows.h RemoveDirectoryW"-  c_RemoveDirectory :: LPCTSTR -> IO Bool  getBinaryType :: String -> IO BinaryType getBinaryType name =-  withTString name $ \ c_name ->+  withFilePath name $ \ c_name ->   alloca $ \ p_btype -> do   failIfFalse_ (unwords ["GetBinaryType",show name]) $     c_GetBinaryType c_name p_btype   peek p_btype-foreign import stdcall unsafe "windows.h GetBinaryTypeW"-  c_GetBinaryType :: LPCTSTR -> Ptr DWORD -> IO Bool +-- | Get a unique temporary filename.+--+-- Calls 'GetTempFileNameW'.+getTempFileName :: String     -- ^ directory for the temporary file (must be at most MAX_PATH - 14 characters long)+                -> String     -- ^ prefix for the temporary file name+                -> Maybe UINT -- ^ if 'Nothing', a unique name is generated+                              --   otherwise a non-zero value is used as the unique part+                -> IO (String, UINT)+getTempFileName dir prefix unique = allocaBytes ((#const MAX_PATH) * sizeOf (undefined :: TCHAR)) $ \c_buf -> do+  uid <- withFilePath dir $ \c_dir ->+    withFilePath prefix $ \ c_prefix -> do+      failIfZero "getTempFileName" $+        c_GetTempFileNameW c_dir c_prefix (fromMaybe 0 unique) c_buf+  fname <- peekTString c_buf+  return (fname, uid)+ ---------------------------------------------------------------- -- HANDLE operations ----------------------------------------------------------------  createFile :: String -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE-createFile name access share mb_attr mode flag mb_h =-  withTString name $ \ c_name ->-  failIfWithRetry (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $+createFile = createFile' failIfWithRetry++createFile' :: ((HANDLE -> Bool) -> String -> IO HANDLE -> IO HANDLE) -> String -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE+createFile' f name access share mb_attr mode flag mb_h =+  withFilePath name $ \ c_name ->+  f (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $     c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h)-foreign import stdcall unsafe "windows.h CreateFileW"-  c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE +-- | Like createFile, but does not use failIfWithRetry. If another+-- process has the same file open, this will fail.+createFile_NoRetry :: String -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE+createFile_NoRetry = createFile' failIf+ closeHandle :: HANDLE -> IO () closeHandle h =   failIfFalse_ "CloseHandle" $ c_CloseHandle h-foreign import stdcall unsafe "windows.h CloseHandle"-  c_CloseHandle :: HANDLE -> IO Bool -{-# CFILES cbits/HsWin32.c #-}-foreign import ccall "HsWin32.h &CloseHandleFinaliser"-    c_CloseHandleFinaliser :: FunPtr (Ptr a -> IO ())--foreign import stdcall unsafe "windows.h GetFileType"-  getFileType :: HANDLE -> IO FileType --Apparently no error code  flushFileBuffers :: HANDLE -> IO () flushFileBuffers h =   failIfFalse_ "FlushFileBuffers" $ c_FlushFileBuffers h-foreign import stdcall unsafe "windows.h FlushFileBuffers"-  c_FlushFileBuffers :: HANDLE -> IO Bool  setEndOfFile :: HANDLE -> IO () setEndOfFile h =   failIfFalse_ "SetEndOfFile" $ c_SetEndOfFile h-foreign import stdcall unsafe "windows.h SetEndOfFile"-  c_SetEndOfFile :: HANDLE -> IO Bool  setFileAttributes :: String -> FileAttributeOrFlag -> IO () setFileAttributes name attr =-  withTString name $ \ c_name ->+  withFilePath name $ \ c_name ->   failIfFalseWithRetry_ (unwords ["SetFileAttributes",show name])     $ c_SetFileAttributes c_name attr-foreign import stdcall unsafe "windows.h SetFileAttributesW"-  c_SetFileAttributes :: LPCTSTR -> FileAttributeOrFlag -> IO Bool  getFileAttributes :: String -> IO FileAttributeOrFlag getFileAttributes name =-  withTString name $ \ c_name ->+  withFilePath name $ \ c_name ->   failIfWithRetry (== 0xFFFFFFFF) (unwords ["GetFileAttributes",show name]) $     c_GetFileAttributes c_name-foreign import stdcall unsafe "windows.h GetFileAttributesW"-  c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag +getFileAttributesExStandard :: String -> IO WIN32_FILE_ATTRIBUTE_DATA+getFileAttributesExStandard name =  alloca $ \res -> do+  withFilePath name $ \ c_name ->+    failIfFalseWithRetry_ "getFileAttributesExStandard" $+      c_GetFileAttributesEx c_name getFileExInfoStandard res+  peek res+ getFileInformationByHandle :: HANDLE -> IO BY_HANDLE_FILE_INFORMATION getFileInformationByHandle h = alloca $ \res -> do     failIfFalseWithRetry_ "GetFileInformationByHandle" $ c_GetFileInformationByHandle h res     peek res-foreign import stdcall unsafe "windows.h GetFileInformationByHandle"-    c_GetFileInformationByHandle :: HANDLE -> Ptr BY_HANDLE_FILE_INFORMATION -> IO BOOL +replaceFile :: LPCWSTR -> LPCWSTR -> LPCWSTR -> DWORD -> IO ()+replaceFile replacedFile replacementFile backupFile replaceFlags =+  failIfFalse_ "ReplaceFile" $ c_ReplaceFile replacedFile replacementFile backupFile replaceFlags nullPtr nullPtr+ ---------------------------------------------------------------- -- Read/write files ---------------------------------------------------------------- --- No support for this yet---type OVERLAPPED =--- (DWORD,  -- Offset---  DWORD,  -- OffsetHigh---  HANDLE) -- hEvent--type LPOVERLAPPED = Ptr ()--type MbLPOVERLAPPED = Maybe LPOVERLAPPED- --Sigh - I give up & prefix win32_ to the next two to avoid -- senseless Prelude name clashes. --sof. @@ -448,20 +436,18 @@   alloca $ \ p_n -> do   failIfFalse_ "ReadFile" $ c_ReadFile h buf n p_n (maybePtr mb_over)   peek p_n-foreign import stdcall unsafe "windows.h ReadFile"-  c_ReadFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool  win32_WriteFile :: HANDLE -> Ptr a -> DWORD -> Maybe LPOVERLAPPED -> IO DWORD win32_WriteFile h buf n mb_over =   alloca $ \ p_n -> do   failIfFalse_ "WriteFile" $ c_WriteFile h buf n p_n (maybePtr mb_over)   peek p_n-foreign import stdcall unsafe "windows.h WriteFile"-  c_WriteFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool --- missing Seek functioinality; GSL ???--- Dont have Word64; ADR--- %fun SetFilePointer :: HANDLE -> Word64 -> FilePtrDirection -> IO Word64+setFilePointerEx :: HANDLE -> LARGE_INTEGER -> FilePtrDirection -> IO LARGE_INTEGER+setFilePointerEx h dist dir =+  alloca $ \p_pos -> do+  failIfFalse_ "SetFilePointerEx" $ c_SetFilePointerEx h dist p_pos dir+  peek p_pos  ---------------------------------------------------------------- -- File Notifications@@ -472,47 +458,35 @@  findFirstChangeNotification :: String -> Bool -> FileNotificationFlag -> IO HANDLE findFirstChangeNotification path watch flag =-  withTString path $ \ c_path ->+  withFilePath path $ \ c_path ->   failIfNull (unwords ["FindFirstChangeNotification",show path]) $     c_FindFirstChangeNotification c_path watch flag-foreign import stdcall unsafe "windows.h FindFirstChangeNotificationW"-  c_FindFirstChangeNotification :: LPCTSTR -> Bool -> FileNotificationFlag -> IO HANDLE  findNextChangeNotification :: HANDLE -> IO () findNextChangeNotification h =   failIfFalse_ "FindNextChangeNotification" $ c_FindNextChangeNotification h-foreign import stdcall unsafe "windows.h FindNextChangeNotification"-  c_FindNextChangeNotification :: HANDLE -> IO Bool  findCloseChangeNotification :: HANDLE -> IO () findCloseChangeNotification h =   failIfFalse_ "FindCloseChangeNotification" $ c_FindCloseChangeNotification h-foreign import stdcall unsafe "windows.h FindCloseChangeNotification"-  c_FindCloseChangeNotification :: HANDLE -> IO Bool  ---------------------------------------------------------------- -- Directories ---------------------------------------------------------------- -type WIN32_FIND_DATA = ()--newtype FindData = FindData (ForeignPtr WIN32_FIND_DATA)- getFindDataFileName :: FindData -> IO FilePath-getFindDataFileName (FindData fp) = -  withForeignPtr fp $ \p -> +getFindDataFileName (FindData fp) =+  withForeignPtr fp $ \p ->     peekTString ((# ptr WIN32_FIND_DATAW, cFileName ) p)  findFirstFile :: String -> IO (HANDLE, FindData) findFirstFile str = do   fp_finddata <- mallocForeignPtrBytes (# const sizeof(WIN32_FIND_DATAW) )   withForeignPtr fp_finddata $ \p_finddata -> do-    handle <- withTString str $ \tstr -> do-                failIf (== iNVALID_HANDLE_VALUE) "findFirstFile" $ +    handle <- withFilePath str $ \tstr -> do+                failIf (== iNVALID_HANDLE_VALUE) "findFirstFile" $                   c_FindFirstFile tstr p_finddata     return (handle, FindData fp_finddata)-foreign import stdcall unsafe "windows.h FindFirstFileW"-  c_FindFirstFile :: LPCTSTR -> Ptr WIN32_FIND_DATA -> IO HANDLE  findNextFile :: HANDLE -> FindData -> IO Bool -- False -> no more files findNextFile h (FindData finddata) = do@@ -525,56 +499,31 @@              if err_code == (# const ERROR_NO_MORE_FILES )                 then return False                 else failWith "findNextFile" err_code-foreign import stdcall unsafe "windows.h FindNextFileW"-  c_FindNextFile :: HANDLE -> Ptr WIN32_FIND_DATA -> IO BOOL  findClose :: HANDLE -> IO () findClose h = failIfFalse_ "findClose" $ c_FindClose h-foreign import stdcall unsafe "windows.h FindClose"-  c_FindClose :: HANDLE -> IO BOOL  ---------------------------------------------------------------- -- DOS Device flags ---------------------------------------------------------------- -defineDosDevice :: DefineDosDeviceFlags -> String -> String -> IO ()+defineDosDevice :: DefineDosDeviceFlags -> String -> Maybe String -> IO () defineDosDevice flags name path =-  withTString path $ \ c_path ->-  withTString name $ \ c_name ->+  maybeWith withFilePath path $ \ c_path ->+  withFilePath name $ \ c_name ->   failIfFalse_ "DefineDosDevice" $ c_DefineDosDevice flags c_name c_path-foreign import stdcall unsafe "windows.h DefineDosDeviceW"-  c_DefineDosDevice :: DefineDosDeviceFlags -> LPCTSTR -> LPCTSTR -> IO Bool  ---------------------------------------------------------------- --- These functions are very unusual in the Win32 API:--- They dont return error codes--foreign import stdcall unsafe "windows.h AreFileApisANSI"-  areFileApisANSI :: IO Bool--foreign import stdcall unsafe "windows.h SetFileApisToOEM"-  setFileApisToOEM :: IO ()--foreign import stdcall unsafe "windows.h SetFileApisToANSI"-  setFileApisToANSI :: IO ()--foreign import stdcall unsafe "windows.h SetHandleCount"-  setHandleCount :: UINT -> IO UINT------------------------------------------------------------------- getLogicalDrives :: IO DWORD getLogicalDrives =   failIfZero "GetLogicalDrives" $ c_GetLogicalDrives-foreign import stdcall unsafe "windows.h GetLogicalDrives"-  c_GetLogicalDrives :: IO DWORD  -- %fun GetDriveType :: Maybe String -> IO DriveType  getDiskFreeSpace :: Maybe String -> IO (DWORD,DWORD,DWORD,DWORD) getDiskFreeSpace path =-  maybeWith withTString path $ \ c_path ->+  maybeWith withFilePath path $ \ c_path ->   alloca $ \ p_sectors ->   alloca $ \ p_bytes ->   alloca $ \ p_nfree ->@@ -586,16 +535,47 @@   nfree <- peek p_nfree   nclusters <- peek p_nclusters   return (sectors, bytes, nfree, nclusters)-foreign import stdcall unsafe "windows.h GetDiskFreeSpaceW"-  c_GetDiskFreeSpace :: LPCTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> IO Bool -setVolumeLabel :: String -> String -> IO ()+setVolumeLabel :: Maybe String -> Maybe String -> IO () setVolumeLabel path name =-  withTString path $ \ c_path ->-  withTString name $ \ c_name ->+  maybeWith withFilePath path $ \ c_path ->+  maybeWith withFilePath name $ \ c_name ->   failIfFalse_ "SetVolumeLabel" $ c_SetVolumeLabel c_path c_name-foreign import stdcall unsafe "windows.h SetVolumeLabelW"-  c_SetVolumeLabel :: LPCTSTR -> LPCTSTR -> IO Bool++----------------------------------------------------------------+-- File locks+----------------------------------------------------------------++-- | Locks a given range in a file handle, To lock an entire file+--   use 0xFFFFFFFFFFFFFFFF for size and 0 for offset.+lockFile :: HANDLE   -- ^ CreateFile handle+         -> LockMode -- ^ Locking mode+         -> DWORD64  -- ^ Size of region to lock+         -> DWORD64  -- ^ Beginning offset of file to lock+         -> IO BOOL  -- ^ Indicates if locking was successful, if not query+                     --   getLastError.+lockFile hwnd mode size f_offset =+  do let s_low = fromIntegral (size .&. 0xFFFFFFFF)+         s_hi  = fromIntegral (size `shiftR` 32)+         o_low = fromIntegral (f_offset .&. 0xFFFFFFFF)+         o_hi  = fromIntegral (f_offset `shiftR` 32)+         ovlp  = OVERLAPPED 0 0 o_low o_hi nullPtr+     with ovlp $ \ptr -> c_LockFileEx hwnd mode 0 s_low s_hi ptr++-- | Unlocks a given range in a file handle, To unlock an entire file+--   use 0xFFFFFFFFFFFFFFFF for size and 0 for offset.+unlockFile :: HANDLE  -- ^ CreateFile handle+           -> DWORD64 -- ^ Size of region to unlock+           -> DWORD64 -- ^ Beginning offset of file to unlock+           -> IO BOOL -- ^ Indicates if unlocking was successful, if not query+                      --   getLastError.+unlockFile hwnd size f_offset =+  do let s_low = fromIntegral (size .&. 0xFFFFFFFF)+         s_hi  = fromIntegral (size `shiftR` 32)+         o_low = fromIntegral (f_offset .&. 0xFFFFFFFF)+         o_hi  = fromIntegral (f_offset `shiftR` 32)+         ovlp  = OVERLAPPED 0 0 o_low o_hi nullPtr+     with ovlp $ \ptr -> c_UnlockFileEx hwnd 0 s_low s_hi ptr  ---------------------------------------------------------------- -- End

+ System/Win32/File/Internal.hsc view

@@ -0,0 +1,548 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.File.Internal+-- 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.File.Internal where++import System.Win32.Types+import System.Win32.Time++import Foreign hiding (void)++##include "windows_cconv.h"++-- For REPLACEFILE_IGNORE_ACL_ERRORS+#define  _WIN32_WINNT 0x0600++#include <windows.h>+#include "alignment.h"++----------------------------------------------------------------+-- Enumeration types+----------------------------------------------------------------++type AccessMode   = UINT++gENERIC_NONE :: AccessMode+gENERIC_NONE = 0++#{enum AccessMode,+ , gENERIC_READ              = GENERIC_READ+ , gENERIC_WRITE             = GENERIC_WRITE+ , gENERIC_EXECUTE           = GENERIC_EXECUTE+ , gENERIC_ALL               = GENERIC_ALL+ , dELETE                    = DELETE+ , rEAD_CONTROL              = READ_CONTROL+ , wRITE_DAC                 = WRITE_DAC+ , wRITE_OWNER               = WRITE_OWNER+ , sYNCHRONIZE               = SYNCHRONIZE+ , sTANDARD_RIGHTS_REQUIRED  = STANDARD_RIGHTS_REQUIRED+ , sTANDARD_RIGHTS_READ      = STANDARD_RIGHTS_READ+ , sTANDARD_RIGHTS_WRITE     = STANDARD_RIGHTS_WRITE+ , sTANDARD_RIGHTS_EXECUTE   = STANDARD_RIGHTS_EXECUTE+ , sTANDARD_RIGHTS_ALL       = STANDARD_RIGHTS_ALL+ , sPECIFIC_RIGHTS_ALL       = SPECIFIC_RIGHTS_ALL+ , aCCESS_SYSTEM_SECURITY    = ACCESS_SYSTEM_SECURITY+ , mAXIMUM_ALLOWED           = MAXIMUM_ALLOWED+ , fILE_ADD_FILE             = FILE_ADD_FILE+ , fILE_ADD_SUBDIRECTORY     = FILE_ADD_SUBDIRECTORY+ , fILE_ALL_ACCESS           = FILE_ALL_ACCESS+ , fILE_APPEND_DATA          = FILE_APPEND_DATA+ , fILE_CREATE_PIPE_INSTANCE = FILE_CREATE_PIPE_INSTANCE+ , fILE_DELETE_CHILD         = FILE_DELETE_CHILD+ , fILE_EXECUTE              = FILE_EXECUTE+ , fILE_LIST_DIRECTORY       = FILE_LIST_DIRECTORY+ , fILE_READ_ATTRIBUTES      = FILE_READ_ATTRIBUTES+ , fILE_READ_DATA            = FILE_READ_DATA+ , fILE_READ_EA              = FILE_READ_EA+ , fILE_TRAVERSE             = FILE_TRAVERSE+ , fILE_WRITE_ATTRIBUTES     = FILE_WRITE_ATTRIBUTES+ , fILE_WRITE_DATA           = FILE_WRITE_DATA+ , fILE_WRITE_EA             = FILE_WRITE_EA+ }++----------------------------------------------------------------++type ShareMode   = UINT++fILE_SHARE_NONE :: ShareMode+fILE_SHARE_NONE = 0++#{enum ShareMode,+ , fILE_SHARE_READ      = FILE_SHARE_READ+ , fILE_SHARE_WRITE     = FILE_SHARE_WRITE+ , fILE_SHARE_DELETE    = FILE_SHARE_DELETE+ }++----------------------------------------------------------------++type CreateMode   = UINT++#{enum CreateMode,+ , cREATE_NEW           = CREATE_NEW+ , cREATE_ALWAYS        = CREATE_ALWAYS+ , oPEN_EXISTING        = OPEN_EXISTING+ , oPEN_ALWAYS          = OPEN_ALWAYS+ , tRUNCATE_EXISTING    = TRUNCATE_EXISTING+ }++----------------------------------------------------------------++type FileAttributeOrFlag   = UINT++#{enum FileAttributeOrFlag,+ , fILE_ATTRIBUTE_READONLY      = FILE_ATTRIBUTE_READONLY+ , fILE_ATTRIBUTE_HIDDEN        = FILE_ATTRIBUTE_HIDDEN+ , fILE_ATTRIBUTE_SYSTEM        = FILE_ATTRIBUTE_SYSTEM+ , fILE_ATTRIBUTE_DIRECTORY     = FILE_ATTRIBUTE_DIRECTORY+ , fILE_ATTRIBUTE_ARCHIVE       = FILE_ATTRIBUTE_ARCHIVE+ , fILE_ATTRIBUTE_NORMAL        = FILE_ATTRIBUTE_NORMAL+ , fILE_ATTRIBUTE_TEMPORARY     = FILE_ATTRIBUTE_TEMPORARY+ , fILE_ATTRIBUTE_COMPRESSED    = FILE_ATTRIBUTE_COMPRESSED+ , fILE_ATTRIBUTE_REPARSE_POINT = FILE_ATTRIBUTE_REPARSE_POINT+ , fILE_FLAG_WRITE_THROUGH      = FILE_FLAG_WRITE_THROUGH+ , fILE_FLAG_OVERLAPPED         = FILE_FLAG_OVERLAPPED+ , fILE_FLAG_NO_BUFFERING       = FILE_FLAG_NO_BUFFERING+ , fILE_FLAG_RANDOM_ACCESS      = FILE_FLAG_RANDOM_ACCESS+ , fILE_FLAG_SEQUENTIAL_SCAN    = FILE_FLAG_SEQUENTIAL_SCAN+ , fILE_FLAG_DELETE_ON_CLOSE    = FILE_FLAG_DELETE_ON_CLOSE+ , fILE_FLAG_BACKUP_SEMANTICS   = FILE_FLAG_BACKUP_SEMANTICS+ , fILE_FLAG_POSIX_SEMANTICS    = FILE_FLAG_POSIX_SEMANTICS+ }+#ifndef __WINE_WINDOWS_H+#{enum FileAttributeOrFlag,+ , sECURITY_ANONYMOUS           = SECURITY_ANONYMOUS+ , sECURITY_IDENTIFICATION      = SECURITY_IDENTIFICATION+ , sECURITY_IMPERSONATION       = SECURITY_IMPERSONATION+ , sECURITY_DELEGATION          = SECURITY_DELEGATION+ , sECURITY_CONTEXT_TRACKING    = SECURITY_CONTEXT_TRACKING+ , sECURITY_EFFECTIVE_ONLY      = SECURITY_EFFECTIVE_ONLY+ , sECURITY_SQOS_PRESENT        = SECURITY_SQOS_PRESENT+ , sECURITY_VALID_SQOS_FLAGS    = SECURITY_VALID_SQOS_FLAGS+ }+#endif++----------------------------------------------------------------++type MoveFileFlag   = DWORD++#{enum MoveFileFlag,+ , mOVEFILE_REPLACE_EXISTING    = MOVEFILE_REPLACE_EXISTING+ , mOVEFILE_COPY_ALLOWED        = MOVEFILE_COPY_ALLOWED+ , mOVEFILE_DELAY_UNTIL_REBOOT  = MOVEFILE_DELAY_UNTIL_REBOOT+ }++----------------------------------------------------------------++type FilePtrDirection   = DWORD++#{enum FilePtrDirection,+ , fILE_BEGIN   = FILE_BEGIN+ , fILE_CURRENT = FILE_CURRENT+ , fILE_END     = FILE_END+ }++----------------------------------------------------------------++type DriveType = UINT++#{enum DriveType,+ , dRIVE_UNKNOWN        = DRIVE_UNKNOWN+ , dRIVE_NO_ROOT_DIR    = DRIVE_NO_ROOT_DIR+ , dRIVE_REMOVABLE      = DRIVE_REMOVABLE+ , dRIVE_FIXED          = DRIVE_FIXED+ , dRIVE_REMOTE         = DRIVE_REMOTE+ , dRIVE_CDROM          = DRIVE_CDROM+ , dRIVE_RAMDISK        = DRIVE_RAMDISK+ }++----------------------------------------------------------------++type DefineDosDeviceFlags = DWORD++#{enum DefineDosDeviceFlags,+ , dDD_RAW_TARGET_PATH          = DDD_RAW_TARGET_PATH+ , dDD_REMOVE_DEFINITION        = DDD_REMOVE_DEFINITION+ , dDD_EXACT_MATCH_ON_REMOVE    = DDD_EXACT_MATCH_ON_REMOVE+ }++----------------------------------------------------------------++type BinaryType = DWORD++#{enum BinaryType,+ , sCS_32BIT_BINARY     = SCS_32BIT_BINARY+ , sCS_DOS_BINARY       = SCS_DOS_BINARY+ , sCS_WOW_BINARY       = SCS_WOW_BINARY+ , sCS_PIF_BINARY       = SCS_PIF_BINARY+ , sCS_POSIX_BINARY     = SCS_POSIX_BINARY+ , sCS_OS216_BINARY     = SCS_OS216_BINARY+ }++----------------------------------------------------------------++type ReplaceType = DWORD++#{enum ReplaceType,+ , rEPLACEFILE_WRITE_THROUGH       = REPLACEFILE_WRITE_THROUGH+ , rEPLACEFILE_IGNORE_MERGE_ERRORS = REPLACEFILE_IGNORE_MERGE_ERRORS+ , rEPLACEFILE_IGNORE_ACL_ERRORS   = REPLACEFILE_IGNORE_ACL_ERRORS+ }++----------------------------------------------------------------++type FileNotificationFlag = DWORD++#{enum FileNotificationFlag,+ , fILE_NOTIFY_CHANGE_FILE_NAME  = FILE_NOTIFY_CHANGE_FILE_NAME+ , fILE_NOTIFY_CHANGE_DIR_NAME   = FILE_NOTIFY_CHANGE_DIR_NAME+ , fILE_NOTIFY_CHANGE_ATTRIBUTES = FILE_NOTIFY_CHANGE_ATTRIBUTES+ , fILE_NOTIFY_CHANGE_SIZE       = FILE_NOTIFY_CHANGE_SIZE+ , fILE_NOTIFY_CHANGE_LAST_WRITE = FILE_NOTIFY_CHANGE_LAST_WRITE+ , fILE_NOTIFY_CHANGE_SECURITY   = FILE_NOTIFY_CHANGE_SECURITY+ }++----------------------------------------------------------------++type FileType = DWORD++#{enum FileType,+ , fILE_TYPE_UNKNOWN    = FILE_TYPE_UNKNOWN+ , fILE_TYPE_DISK       = FILE_TYPE_DISK+ , fILE_TYPE_CHAR       = FILE_TYPE_CHAR+ , fILE_TYPE_PIPE       = FILE_TYPE_PIPE+ , fILE_TYPE_REMOTE     = FILE_TYPE_REMOTE+ }++----------------------------------------------------------------++type LockMode = DWORD++#{enum LockMode,+ , lOCKFILE_EXCLUSIVE_LOCK   = LOCKFILE_EXCLUSIVE_LOCK+ , lOCKFILE_FAIL_IMMEDIATELY = LOCKFILE_FAIL_IMMEDIATELY+ }++----------------------------------------------------------------++newtype GET_FILEEX_INFO_LEVELS = GET_FILEEX_INFO_LEVELS (#type GET_FILEEX_INFO_LEVELS)+    deriving (Eq, Ord)++#{enum GET_FILEEX_INFO_LEVELS, GET_FILEEX_INFO_LEVELS+ , getFileExInfoStandard = GetFileExInfoStandard+ , getFileExMaxInfoLevel = GetFileExMaxInfoLevel+ }++----------------------------------------------------------------++data SECURITY_ATTRIBUTES = SECURITY_ATTRIBUTES+    { nLength              :: !DWORD+    , lpSecurityDescriptor :: !LPVOID+    , bInheritHandle       :: !BOOL+    } deriving Show++type PSECURITY_ATTRIBUTES = Ptr SECURITY_ATTRIBUTES+type LPSECURITY_ATTRIBUTES = Ptr SECURITY_ATTRIBUTES+type MbLPSECURITY_ATTRIBUTES = Maybe LPSECURITY_ATTRIBUTES++instance Storable SECURITY_ATTRIBUTES where+    sizeOf = const #{size SECURITY_ATTRIBUTES}+    alignment _ = #alignment SECURITY_ATTRIBUTES+    poke buf input = do+        (#poke SECURITY_ATTRIBUTES, nLength)              buf (nLength input)+        (#poke SECURITY_ATTRIBUTES, lpSecurityDescriptor) buf (lpSecurityDescriptor input)+        (#poke SECURITY_ATTRIBUTES, bInheritHandle)       buf (bInheritHandle input)+    peek buf = do+        nLength'              <- (#peek SECURITY_ATTRIBUTES, nLength)              buf+        lpSecurityDescriptor' <- (#peek SECURITY_ATTRIBUTES, lpSecurityDescriptor) buf+        bInheritHandle'       <- (#peek SECURITY_ATTRIBUTES, bInheritHandle)       buf+        return $ SECURITY_ATTRIBUTES nLength' lpSecurityDescriptor' bInheritHandle'++----------------------------------------------------------------+-- Other types+----------------------------------------------------------------++data BY_HANDLE_FILE_INFORMATION = BY_HANDLE_FILE_INFORMATION+    { bhfiFileAttributes :: FileAttributeOrFlag+    , bhfiCreationTime, bhfiLastAccessTime, bhfiLastWriteTime :: FILETIME+    , bhfiVolumeSerialNumber :: DWORD+    , bhfiSize :: DDWORD+    , bhfiNumberOfLinks :: DWORD+    , bhfiFileIndex :: DDWORD+    } deriving (Show)++instance Storable BY_HANDLE_FILE_INFORMATION where+    sizeOf = const (#size BY_HANDLE_FILE_INFORMATION)+    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)+        (#poke BY_HANDLE_FILE_INFORMATION, ftLastAccessTime)     buf (bhfiLastAccessTime bhi)+        (#poke BY_HANDLE_FILE_INFORMATION, ftLastWriteTime)      buf (bhfiLastWriteTime bhi)+        (#poke BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf (bhfiVolumeSerialNumber bhi)+        (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeHigh)        buf sizeHi+        (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeLow)         buf sizeLow+        (#poke BY_HANDLE_FILE_INFORMATION, nNumberOfLinks)       buf (bhfiNumberOfLinks bhi)+        (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexHigh)       buf idxHi+        (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexLow)        buf idxLow+        where+            (sizeHi,sizeLow) = ddwordToDwords $ bhfiSize bhi+            (idxHi,idxLow) = ddwordToDwords $ bhfiFileIndex bhi++    peek buf = do+        attr <- (#peek BY_HANDLE_FILE_INFORMATION, dwFileAttributes)     buf+        ctim <- (#peek BY_HANDLE_FILE_INFORMATION, ftCreationTime)       buf+        lati <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastAccessTime)     buf+        lwti <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastWriteTime)      buf+        vser <- (#peek BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf+        fshi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeHigh)        buf+        fslo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeLow)         buf+        link <- (#peek BY_HANDLE_FILE_INFORMATION, nNumberOfLinks)       buf+        idhi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexHigh)       buf+        idlo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexLow)        buf+        return $ BY_HANDLE_FILE_INFORMATION attr ctim lati lwti vser+            (dwordsToDdword (fshi,fslo)) link (dwordsToDdword (idhi,idlo))++----------------------------------------------------------------++data WIN32_FILE_ATTRIBUTE_DATA = WIN32_FILE_ATTRIBUTE_DATA+    { fadFileAttributes :: DWORD+    , fadCreationTime , fadLastAccessTime , fadLastWriteTime :: FILETIME+    , fadFileSize :: DDWORD+    } deriving (Show)++instance Storable WIN32_FILE_ATTRIBUTE_DATA where+    sizeOf = const (#size WIN32_FILE_ATTRIBUTE_DATA)+    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)+        (#poke WIN32_FILE_ATTRIBUTE_DATA, ftLastAccessTime) buf (fadLastAccessTime ad)+        (#poke WIN32_FILE_ATTRIBUTE_DATA, ftLastWriteTime)  buf (fadLastWriteTime ad)+        (#poke WIN32_FILE_ATTRIBUTE_DATA, nFileSizeHigh)    buf sizeHi+        (#poke WIN32_FILE_ATTRIBUTE_DATA, nFileSizeLow)     buf sizeLo+        where+            (sizeHi,sizeLo) = ddwordToDwords $ fadFileSize ad++    peek buf = do+        attr <- (#peek WIN32_FILE_ATTRIBUTE_DATA, dwFileAttributes) buf+        ctim <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftCreationTime)   buf+        lati <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftLastAccessTime) buf+        lwti <- (#peek WIN32_FILE_ATTRIBUTE_DATA, ftLastWriteTime)  buf+        fshi <- (#peek WIN32_FILE_ATTRIBUTE_DATA, nFileSizeHigh)    buf+        fslo <- (#peek WIN32_FILE_ATTRIBUTE_DATA, nFileSizeLow)     buf+        return $ WIN32_FILE_ATTRIBUTE_DATA attr ctim lati lwti+            (dwordsToDdword (fshi,fslo))++----------------------------------------------------------------+-- File operations+----------------------------------------------------------------++foreign import WINDOWS_CCONV unsafe "windows.h DeleteFileW"+  c_DeleteFile :: LPCTSTR -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h CopyFileW"+  c_CopyFile :: LPCTSTR -> LPCTSTR -> Bool -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h MoveFileW"+  c_MoveFile :: LPCTSTR -> LPCTSTR -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h MoveFileExW"+  c_MoveFileEx :: LPCTSTR -> LPCTSTR -> MoveFileFlag -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h SetCurrentDirectoryW"+  c_SetCurrentDirectory :: LPCTSTR -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h CreateDirectoryW"+  c_CreateDirectory :: LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h CreateDirectoryExW"+  c_CreateDirectoryEx :: LPCTSTR -> LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h RemoveDirectoryW"+  c_RemoveDirectory :: LPCTSTR -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h GetBinaryTypeW"+  c_GetBinaryType :: LPCTSTR -> Ptr DWORD -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h ReplaceFileW"+  c_ReplaceFile :: LPCWSTR -> LPCWSTR -> LPCWSTR -> DWORD -> LPVOID -> LPVOID -> IO Bool++----------------------------------------------------------------+-- HANDLE operations+----------------------------------------------------------------++foreign import WINDOWS_CCONV unsafe "windows.h CreateFileW"+  c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE++foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle"+  c_CloseHandle :: HANDLE -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h GetFileType"+  getFileType :: HANDLE -> IO FileType+--Apparently no error code++foreign import WINDOWS_CCONV unsafe "windows.h FlushFileBuffers"+  c_FlushFileBuffers :: HANDLE -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h SetEndOfFile"+  c_SetEndOfFile :: HANDLE -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h SetFileAttributesW"+  c_SetFileAttributes :: LPCTSTR -> FileAttributeOrFlag -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h GetFileAttributesW"+  c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag++foreign import WINDOWS_CCONV unsafe "windows.h GetFileAttributesExW"+  c_GetFileAttributesEx :: LPCTSTR -> GET_FILEEX_INFO_LEVELS -> Ptr a -> IO BOOL++foreign import WINDOWS_CCONV unsafe "windows.h GetFileInformationByHandle"+    c_GetFileInformationByHandle :: HANDLE -> Ptr BY_HANDLE_FILE_INFORMATION -> IO BOOL++foreign import WINDOWS_CCONV unsafe "windows.h GetTempFileNameW"+    c_GetTempFileNameW :: LPCWSTR -> LPCWSTR -> UINT -> LPWSTR -> IO UINT++----------------------------------------------------------------+-- Read/write files+----------------------------------------------------------------++-- No support for this yet+data OVERLAPPED+  = OVERLAPPED { ovl_internal     :: ULONG_PTR+               , ovl_internalHigh :: ULONG_PTR+               , ovl_offset       :: DWORD+               , ovl_offsetHigh   :: DWORD+               , ovl_hEvent       :: HANDLE+               } deriving (Show)++instance Storable OVERLAPPED where+  sizeOf = const (#size OVERLAPPED)+  alignment _ = #alignment OVERLAPPED+  poke buf ad = do+      (#poke OVERLAPPED, Internal    ) buf (ovl_internal     ad)+      (#poke OVERLAPPED, InternalHigh) buf (ovl_internalHigh ad)+      (#poke OVERLAPPED, Offset      ) buf (ovl_offset       ad)+      (#poke OVERLAPPED, OffsetHigh  ) buf (ovl_offsetHigh   ad)+      (#poke OVERLAPPED, hEvent      ) buf (ovl_hEvent       ad)++  peek buf = do+      intnl      <- (#peek OVERLAPPED, Internal    ) buf+      intnl_high <- (#peek OVERLAPPED, InternalHigh) buf+      off        <- (#peek OVERLAPPED, Offset      ) buf+      off_high   <- (#peek OVERLAPPED, OffsetHigh  ) buf+      hevnt      <- (#peek OVERLAPPED, hEvent      ) buf+      return $ OVERLAPPED intnl intnl_high off off_high hevnt++type LPOVERLAPPED = Ptr OVERLAPPED++type MbLPOVERLAPPED = Maybe LPOVERLAPPED++foreign import WINDOWS_CCONV unsafe "windows.h ReadFile"+  c_ReadFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h WriteFile"+  c_WriteFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h SetFilePointerEx"+  c_SetFilePointerEx :: HANDLE -> LARGE_INTEGER -> Ptr LARGE_INTEGER -> FilePtrDirection -> IO Bool++----------------------------------------------------------------+-- File Notifications+--+-- Use these to initialise, "increment" and close a HANDLE you can wait+-- on.+----------------------------------------------------------------++foreign import WINDOWS_CCONV unsafe "windows.h FindFirstChangeNotificationW"+  c_FindFirstChangeNotification :: LPCTSTR -> Bool -> FileNotificationFlag -> IO HANDLE++foreign import WINDOWS_CCONV unsafe "windows.h FindNextChangeNotification"+  c_FindNextChangeNotification :: HANDLE -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h FindCloseChangeNotification"+  c_FindCloseChangeNotification :: HANDLE -> IO Bool++----------------------------------------------------------------+-- Directories+----------------------------------------------------------------++type WIN32_FIND_DATA = ()++newtype FindData = FindData (ForeignPtr WIN32_FIND_DATA)++foreign import WINDOWS_CCONV unsafe "windows.h FindFirstFileW"+  c_FindFirstFile :: LPCTSTR -> Ptr WIN32_FIND_DATA -> IO HANDLE++foreign import WINDOWS_CCONV unsafe "windows.h FindNextFileW"+  c_FindNextFile :: HANDLE -> Ptr WIN32_FIND_DATA -> IO BOOL++foreign import WINDOWS_CCONV unsafe "windows.h FindClose"+  c_FindClose :: HANDLE -> IO BOOL++----------------------------------------------------------------+-- DOS Device flags+----------------------------------------------------------------++foreign import WINDOWS_CCONV unsafe "windows.h DefineDosDeviceW"+  c_DefineDosDevice :: DefineDosDeviceFlags -> LPCTSTR -> LPCTSTR -> IO Bool++----------------------------------------------------------------++-- These functions are very unusual in the Win32 API:+-- They don't return error codes++foreign import WINDOWS_CCONV unsafe "windows.h AreFileApisANSI"+  areFileApisANSI :: IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h SetFileApisToOEM"+  setFileApisToOEM :: IO ()++foreign import WINDOWS_CCONV unsafe "windows.h SetFileApisToANSI"+  setFileApisToANSI :: IO ()++foreign import WINDOWS_CCONV unsafe "windows.h SetHandleCount"+  setHandleCount :: UINT -> IO UINT++----------------------------------------------------------------++foreign import WINDOWS_CCONV unsafe "windows.h GetLogicalDrives"+  c_GetLogicalDrives :: IO DWORD++-- %fun GetDriveType :: Maybe String -> IO DriveType++foreign import WINDOWS_CCONV unsafe "windows.h GetDiskFreeSpaceW"+  c_GetDiskFreeSpace :: LPCTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h SetVolumeLabelW"+  c_SetVolumeLabel :: LPCTSTR -> LPCTSTR -> IO Bool++----------------------------------------------------------------+-- File locks+----------------------------------------------------------------++foreign import WINDOWS_CCONV unsafe "LockFileEx"+  c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED+               -> IO BOOL++foreign import WINDOWS_CCONV unsafe "UnlockFileEx"+  c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL++----------------------------------------------------------------+-- End+----------------------------------------------------------------

System/Win32/FileMapping.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -14,9 +16,37 @@ -- A collection of FFI declarations for interfacing with Win32 mapped files. -- ------------------------------------------------------------------------------module System.Win32.FileMapping where+module System.Win32.FileMapping+    ( mapFile+    , MappedObject(..)+    , withMappedFile+    , withMappedArea+      -- * Enums+      -- ** Section protection flags+    , ProtectSectionFlags+    , sEC_COMMIT+    , sEC_IMAGE+    , sEC_NOCACHE+    , sEC_RESERVE+      -- ** Access falgs+    , FileMapAccess+    , fILE_MAP_ALL_ACCESS+    , fILE_MAP_COPY+    , fILE_MAP_READ+    , fILE_MAP_WRITE+    , fILE_SHARE_WRITE -import System.Win32.Types   ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR, withTString+      -- * Mapping files+    , createFileMapping+    , openFileMapping+    , mapViewOfFileEx+    , mapViewOfFile+    , unmapViewOfFile+    ) where+++import System.Win32.FileMapping.Internal+import System.Win32.Types   ( HANDLE, BOOL, SIZE_T, withTString                             , failIf, failIfNull, DDWORD, ddwordToDwords                             , iNVALID_HANDLE_VALUE ) import System.Win32.Mem@@ -24,11 +54,11 @@ import System.Win32.Info  import Control.Exception        ( mask_, bracket )-import Data.ByteString          ( ByteString )-import Data.ByteString.Internal ( fromForeignPtr )-import Foreign                  ( Ptr, nullPtr, plusPtr, maybeWith, FunPtr+import Foreign                  ( Ptr, nullPtr, plusPtr, maybeWith                                 , ForeignPtr, newForeignPtr ) +##include "windows_cconv.h"+ #include "windows.h"  ---------------------------------------------------------------------------@@ -52,14 +82,6 @@                     newForeignPtr c_UnmapViewOfFileFinaliser ptr                 return (fp, fromIntegral $ bhfiSize fi) --- | As mapFile, but returns ByteString-mapFileBs :: FilePath -> IO ByteString-mapFileBs p = do-    (fp,i) <- mapFile p-    return $ fromForeignPtr fp 0 i--data MappedObject = MappedObject HANDLE HANDLE FileMapAccess- -- | Opens an existing file and creates mapping object to it. withMappedFile     :: FilePath             -- ^ Path@@ -105,42 +127,24 @@         (act . flip plusPtr (fromIntegral offset))  ------------------------------------------------------------------------------ Enums-----------------------------------------------------------------------------type ProtectSectionFlags = DWORD-#{enum ProtectSectionFlags,-    , sEC_COMMIT    = SEC_COMMIT-    , sEC_IMAGE     = SEC_IMAGE-    , sEC_NOCACHE   = SEC_NOCACHE-    , sEC_RESERVE   = SEC_RESERVE-    }-type FileMapAccess = DWORD-#{enum FileMapAccess,-    , fILE_MAP_ALL_ACCESS   = FILE_MAP_ALL_ACCESS-    , fILE_MAP_COPY         = FILE_MAP_COPY-    , fILE_MAP_READ         = FILE_MAP_READ-    , fILE_MAP_WRITE        = FILE_MAP_WRITE-    }----------------------------------------------------------------------------- -- API in Haskell --------------------------------------------------------------------------- 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 = +mapViewOfFileEx h access offset size base =     failIfNull "mapViewOfFile(Ex): c_MapViewOfFileEx" $         c_MapViewOfFileEx h access ohi olow size base     where@@ -152,21 +156,3 @@ unmapViewOfFile :: Ptr a -> IO () unmapViewOfFile v = c_UnmapViewOfFile v >> return () ------------------------------------------------------------------------------- Imports-----------------------------------------------------------------------------foreign import stdcall "windows.h OpenFileMappingW"-    c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE--foreign import stdcall "windows.h CreateFileMappingW"-    c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE --foreign import stdcall "windows.h MapViewOfFileEx"-    c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b)--foreign import stdcall "windows.h UnmapViewOfFile"-    c_UnmapViewOfFile :: Ptr a -> IO BOOL--{-# CFILES cbits/HsWin32.c #-}-foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser"-    c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ())

+ System/Win32/FileMapping/Internal.hsc view

@@ -0,0 +1,72 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.FileMapping.Internal+-- Copyright   :  (c) Esa Ilari Vuokko, 2006+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of FFI declarations for interfacing with Win32 mapped files.+--+-----------------------------------------------------------------------------+module System.Win32.FileMapping.Internal where++import System.Win32.Types   ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR )++import Foreign                  ( Ptr, FunPtr )+import Foreign.C.Types (CUIntPtr(..))++##include "windows_cconv.h"++#include "windows.h"++---------------------------------------------------------------------------+-- Derived functions+---------------------------------------------------------------------------++data MappedObject = MappedObject HANDLE HANDLE FileMapAccess+++---------------------------------------------------------------------------+-- Enums+---------------------------------------------------------------------------+type ProtectSectionFlags = DWORD+#{enum ProtectSectionFlags,+    , sEC_COMMIT    = SEC_COMMIT+    , sEC_IMAGE     = SEC_IMAGE+    , sEC_NOCACHE   = SEC_NOCACHE+    , sEC_RESERVE   = SEC_RESERVE+    }+type FileMapAccess = DWORD+#{enum FileMapAccess,+    , fILE_MAP_ALL_ACCESS   = FILE_MAP_ALL_ACCESS+    , fILE_MAP_COPY         = FILE_MAP_COPY+    , fILE_MAP_READ         = FILE_MAP_READ+    , fILE_MAP_WRITE        = FILE_MAP_WRITE+    }++---------------------------------------------------------------------------+-- Imports+---------------------------------------------------------------------------+foreign import WINDOWS_CCONV "windows.h OpenFileMappingW"+    c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE++foreign import WINDOWS_CCONV "windows.h CreateFileMappingW"+    c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE++foreign import WINDOWS_CCONV "windows.h MapViewOfFileEx"+    c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b)++foreign import WINDOWS_CCONV "windows.h UnmapViewOfFile"+    c_UnmapViewOfFile :: Ptr a -> IO BOOL++{-# CFILES cbits/HsWin32.c #-}+foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser"+    c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ())

+ System/Win32/HardLink.hs view

@@ -0,0 +1,94 @@+{-# 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 supports this functionality.
+
+     * ReFS doesn't support hard link currently.
+-}
+module System.Win32.HardLink
+  ( createHardLink
+  , createHardLink'
+  ) where
+
+import System.Win32.HardLink.Internal
+import System.Win32.File   ( failIfFalseWithRetry_ )
+import System.Win32.String ( withTString )
+import System.Win32.Types  ( nullPtr )
+
+#include "windows_cconv.h"
+
+-- | NOTE: createHardLink is /flipped arguments/ to provide compatibility 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
+
+
+{-
+-- 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 :: Maybe String -> IO VolumeInformation
+getVolumeInformation drive =
+   maybeWith 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
+-}

+ System/Win32/HardLink/Internal.hs view

@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}+{- |+   Module      :  System.Win32.HardLink.Internal+   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.Internal where++import System.Win32.File   ( LPSECURITY_ATTRIBUTES )+import System.Win32.String ( LPCTSTR )+import System.Win32.Types  ( BOOL )++#include "windows_cconv.h"++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

System/Win32/Info.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -15,18 +17,136 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Info where+module System.Win32.Info+    ( SystemColor+    , cOLOR_SCROLLBAR+    , cOLOR_BACKGROUND+    , cOLOR_ACTIVECAPTION+    , cOLOR_INACTIVECAPTION+    , cOLOR_MENU+    , cOLOR_WINDOW+    , cOLOR_WINDOWFRAME+    , cOLOR_MENUTEXT+    , cOLOR_WINDOWTEXT+    , cOLOR_CAPTIONTEXT+    , cOLOR_ACTIVEBORDER+    , cOLOR_INACTIVEBORDER+    , cOLOR_APPWORKSPACE+    , cOLOR_HIGHLIGHT+    , cOLOR_HIGHLIGHTTEXT+    , cOLOR_BTNFACE+    , cOLOR_BTNSHADOW+    , cOLOR_GRAYTEXT+    , cOLOR_BTNTEXT+    , cOLOR_INACTIVECAPTIONTEXT+    , cOLOR_BTNHIGHLIGHT -import System.Win32.Types+      -- * Standard directories+    , getSystemDirectory+    , getWindowsDirectory+    , getCurrentDirectory+    , getTemporaryDirectory+    , getFullPathName+    , getLongPathName+    , getShortPathName+    , searchPath -import Prelude hiding (catch)+      -- * System information+    , ProcessorArchitecture(..)+    , SYSTEM_INFO(..)+    , getSystemInfo++      -- * System metrics+    , SMSetting+    , sM_ARRANGE+    , sM_CLEANBOOT+    , sM_CMETRICS+    , sM_CMOUSEBUTTONS+    , sM_CXBORDER+    , sM_CYBORDER+    , sM_CXCURSOR+    , sM_CYCURSOR+    , sM_CXDLGFRAME+    , sM_CYDLGFRAME+    , sM_CXDOUBLECLK+    , sM_CYDOUBLECLK+    , sM_CXDRAG+    , sM_CYDRAG+    , sM_CXEDGE+    , sM_CYEDGE+    , sM_CXFRAME+    , sM_CYFRAME+    , sM_CXFULLSCREEN+    , sM_CYFULLSCREEN+    , sM_CXHSCROLL+    , sM_CYVSCROLL+    , sM_CXICON+    , sM_CYICON+    , sM_CXICONSPACING+    , sM_CYICONSPACING+    , sM_CXMAXIMIZED+    , sM_CYMAXIMIZED+    , sM_CXMENUCHECK+    , sM_CYMENUCHECK+    , sM_CXMENUSIZE+    , sM_CYMENUSIZE+    , sM_CXMIN+    , sM_CYMIN+    , sM_CXMINIMIZED+    , sM_CYMINIMIZED+    , sM_CXMINTRACK+    , sM_CYMINTRACK+    , sM_CXSCREEN+    , sM_CYSCREEN+    , sM_CXSIZE+    , sM_CYSIZE+    , sM_CXSIZEFRAME+    , sM_CYSIZEFRAME+    , sM_CXSMICON+    , sM_CYSMICON+    , sM_CXSMSIZE+    , sM_CYSMSIZE+    , sM_CXVSCROLL+    , sM_CYHSCROLL+    , sM_CYVTHUMB+    , sM_CYCAPTION+    , sM_CYKANJIWINDOW+    , sM_CYMENU+    , sM_CYSMCAPTION+    , sM_DBCSENABLED+    , sM_DEBUG+    , sM_MENUDROPALIGNMENT+    , sM_MIDEASTENABLED+    , sM_MOUSEPRESENT+    , sM_NETWORK+    , sM_PENWINDOWS+    , sM_SECURE+    , sM_SHOWSOUNDS+    , sM_SLOWMACHINE+    , sM_SWAPBUTTON++      -- * User name+    , getUserName+    ) where++import System.Win32.Info.Internal import Control.Exception (catch)-import System.IO.Error hiding (catch, try)-import Foreign      ( Storable(sizeOf, alignment, peekByteOff, pokeByteOff,-                               peek, poke)-                    , Ptr, alloca, allocaArray )+import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Utils (with, maybeWith)+import Foreign.Marshal.Array (allocaArray)+import Foreign.Ptr (nullPtr)+import Foreign.Storable (Storable(..))+import System.IO.Error (isDoesNotExistError)+import System.Win32.Types (failIfFalse_, peekTStringLen, withTString, try) +#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++##include "windows_cconv.h"+ #include <windows.h>+#include "alignment.h"  ---------------------------------------------------------------- -- Environment Strings@@ -55,41 +175,6 @@ -- %fun GetKeyboardType :: KeyboardTypeKind -> IO KeyboardType  ------------------------------------------------------------------- System Color-------------------------------------------------------------------type SystemColor   = UINT---- ToDo: This list is out of date.--#{enum SystemColor,- , cOLOR_SCROLLBAR      = COLOR_SCROLLBAR- , cOLOR_BACKGROUND     = COLOR_BACKGROUND- , cOLOR_ACTIVECAPTION  = COLOR_ACTIVECAPTION- , cOLOR_INACTIVECAPTION = COLOR_INACTIVECAPTION- , cOLOR_MENU           = COLOR_MENU- , cOLOR_WINDOW         = COLOR_WINDOW- , cOLOR_WINDOWFRAME    = COLOR_WINDOWFRAME- , cOLOR_MENUTEXT       = COLOR_MENUTEXT- , cOLOR_WINDOWTEXT     = COLOR_WINDOWTEXT- , cOLOR_CAPTIONTEXT    = COLOR_CAPTIONTEXT- , cOLOR_ACTIVEBORDER   = COLOR_ACTIVEBORDER- , cOLOR_INACTIVEBORDER = COLOR_INACTIVEBORDER- , cOLOR_APPWORKSPACE   = COLOR_APPWORKSPACE- , cOLOR_HIGHLIGHT      = COLOR_HIGHLIGHT- , cOLOR_HIGHLIGHTTEXT  = COLOR_HIGHLIGHTTEXT- , cOLOR_BTNFACE        = COLOR_BTNFACE- , cOLOR_BTNSHADOW      = COLOR_BTNSHADOW- , cOLOR_GRAYTEXT       = COLOR_GRAYTEXT- , cOLOR_BTNTEXT        = COLOR_BTNTEXT- , cOLOR_INACTIVECAPTIONTEXT = COLOR_INACTIVECAPTIONTEXT- , cOLOR_BTNHIGHLIGHT   = COLOR_BTNHIGHLIGHT- }---- %fun GetSysColor :: SystemColor -> IO COLORREF--- %fun SetSysColors :: [(SystemColor,COLORREF)] -> IO ()------------------------------------------------------------------ -- Standard Directories ---------------------------------------------------------------- @@ -101,6 +186,7 @@  getCurrentDirectory :: IO String getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512+ getTemporaryDirectory :: IO String getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512 @@ -110,11 +196,23 @@     try "getFullPathName"       (\buf len -> c_GetFullPathName c_name len buf nullPtr) 512 -searchPath :: Maybe String -> FilePath -> String -> IO (Maybe FilePath)+getLongPathName :: FilePath -> IO FilePath+getLongPathName name = do+  withTString name $ \ c_name ->+    try "getLongPathName"+      (c_GetLongPathName c_name) 512++getShortPathName :: FilePath -> IO FilePath+getShortPathName name = do+  withTString name $ \ c_name ->+    try "getShortPathName"+      (c_GetShortPathName c_name) 512++searchPath :: Maybe String -> FilePath -> Maybe String -> IO (Maybe FilePath) searchPath path filename ext =   maybe ($ nullPtr) withTString path $ \p_path ->   withTString filename $ \p_filename ->-  withTString ext      $ \p_ext ->+  maybeWith withTString ext      $ \p_ext ->   alloca $ \ppFilePart -> (do     s <- try "searchPath" (\buf len -> c_SearchPath p_path p_filename p_ext                           len buf ppFilePart) 512@@ -123,212 +221,15 @@                        then return Nothing                        else ioError e --- 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--foreign import stdcall unsafe "GetWindowsDirectoryW"-  c_getWindowsDirectory :: LPTSTR -> UINT -> IO UINT--foreign import stdcall unsafe "GetSystemDirectoryW"-  c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT--foreign import stdcall unsafe "GetCurrentDirectoryW"-  c_getCurrentDirectory :: DWORD -> LPTSTR -> IO UINT--foreign import stdcall unsafe "GetTempPathW"-  c_getTempPath :: DWORD -> LPTSTR -> IO UINT--foreign import stdcall unsafe "GetFullPathNameW"-  c_GetFullPathName :: LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR -> IO DWORD--foreign import stdcall unsafe "SearchPathW"-  c_SearchPath :: LPCTSTR -> LPCTSTR -> LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR-               -> IO DWORD- ---------------------------------------------------------------- -- System Info (Info about processor and memory subsystem) ---------------------------------------------------------------- -data ProcessorArchitecture = PaUnknown WORD | PaIntel | PaMips | PaAlpha | PaPpc | PaIa64 | PaIa32OnIa64 | PaAmd64-    deriving (Show,Eq)--instance Storable ProcessorArchitecture where-    sizeOf _ = sizeOf (undefined::WORD)-    alignment _ = alignment (undefined::WORD)-    poke buf pa = pokeByteOff buf 0 $ case pa of-        PaUnknown w -> w-        PaIntel     -> #const PROCESSOR_ARCHITECTURE_INTEL-        PaMips      -> #const PROCESSOR_ARCHITECTURE_MIPS-        PaAlpha     -> #const PROCESSOR_ARCHITECTURE_ALPHA-        PaPpc       -> #const PROCESSOR_ARCHITECTURE_PPC-        PaIa64      -> #const PROCESSOR_ARCHITECTURE_IA64-#ifndef __WINE_WINDOWS_H-        PaIa32OnIa64 -> #const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64-#endif-        PaAmd64     -> #const PROCESSOR_ARCHITECTURE_AMD64-    peek buf = do-        v <- (peekByteOff buf 0:: IO WORD)-        return $ case v of-            (#const PROCESSOR_ARCHITECTURE_INTEL) -> PaIntel-            (#const PROCESSOR_ARCHITECTURE_MIPS)  -> PaMips-            (#const PROCESSOR_ARCHITECTURE_ALPHA) -> PaAlpha-            (#const PROCESSOR_ARCHITECTURE_PPC)   -> PaPpc-            (#const PROCESSOR_ARCHITECTURE_IA64)  -> PaIa64-#ifndef __WINE_WINDOWS_H-            (#const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64) -> PaIa32OnIa64-#endif-            (#const PROCESSOR_ARCHITECTURE_AMD64) -> PaAmd64-            w                                   -> PaUnknown w--data SYSTEM_INFO = SYSTEM_INFO-    { siProcessorArchitecture :: ProcessorArchitecture-    , siPageSize :: DWORD-    , siMinimumApplicationAddress, siMaximumApplicationAddress :: LPVOID-    , siActiveProcessorMask :: DWORD-    , siNumberOfProcessors :: DWORD-    , siProcessorType :: DWORD-    , siAllocationGranularity :: DWORD-    , siProcessorLevel :: WORD-    , siProcessorRevision :: WORD-    } deriving (Show)--instance Storable SYSTEM_INFO where-    sizeOf = const #size SYSTEM_INFO-    alignment = sizeOf-    poke buf si = do-        (#poke SYSTEM_INFO, wProcessorArchitecture) buf (siProcessorArchitecture si)-        (#poke SYSTEM_INFO, dwPageSize)             buf (siPageSize si)-        (#poke SYSTEM_INFO, lpMinimumApplicationAddress) buf (siMinimumApplicationAddress si)-        (#poke SYSTEM_INFO, lpMaximumApplicationAddress) buf (siMaximumApplicationAddress si)-        (#poke SYSTEM_INFO, dwActiveProcessorMask)  buf (siActiveProcessorMask si)-        (#poke SYSTEM_INFO, dwNumberOfProcessors)   buf (siNumberOfProcessors si)-        (#poke SYSTEM_INFO, dwProcessorType)        buf (siProcessorType si)-        (#poke SYSTEM_INFO, dwAllocationGranularity) buf (siAllocationGranularity si)-        (#poke SYSTEM_INFO, wProcessorLevel)        buf (siProcessorLevel si)-        (#poke SYSTEM_INFO, wProcessorRevision)     buf (siProcessorRevision si)--    peek buf = do-        processorArchitecture <--            (#peek SYSTEM_INFO, wProcessorArchitecture) buf-        pageSize            <- (#peek SYSTEM_INFO, dwPageSize) buf-        minimumApplicationAddress <--            (#peek SYSTEM_INFO, lpMinimumApplicationAddress) buf-        maximumApplicationAddress <--            (#peek SYSTEM_INFO, lpMaximumApplicationAddress) buf-        activeProcessorMask <- (#peek SYSTEM_INFO, dwActiveProcessorMask) buf-        numberOfProcessors  <- (#peek SYSTEM_INFO, dwNumberOfProcessors) buf-        processorType       <- (#peek SYSTEM_INFO, dwProcessorType) buf-        allocationGranularity <--            (#peek SYSTEM_INFO, dwAllocationGranularity) buf-        processorLevel      <- (#peek SYSTEM_INFO, wProcessorLevel) buf-        processorRevision   <- (#peek SYSTEM_INFO, wProcessorRevision) buf-        return $ SYSTEM_INFO {-            siProcessorArchitecture     = processorArchitecture,-            siPageSize                  = pageSize,-            siMinimumApplicationAddress = minimumApplicationAddress,-            siMaximumApplicationAddress = maximumApplicationAddress,-            siActiveProcessorMask       = activeProcessorMask,-            siNumberOfProcessors        = numberOfProcessors,-            siProcessorType             = processorType,-            siAllocationGranularity     = allocationGranularity,-            siProcessorLevel            = processorLevel,-            siProcessorRevision         = processorRevision-            }--foreign import stdcall unsafe "windows.h GetSystemInfo"-    c_GetSystemInfo :: Ptr SYSTEM_INFO -> IO ()- getSystemInfo :: IO SYSTEM_INFO getSystemInfo = alloca $ \ret -> do     c_GetSystemInfo ret     peek ret -------------------------------------------------------------------- System metrics-------------------------------------------------------------------type SMSetting = UINT--#{enum SMSetting,- , sM_ARRANGE           = SM_ARRANGE- , sM_CLEANBOOT         = SM_CLEANBOOT- , sM_CMETRICS          = SM_CMETRICS- , sM_CMOUSEBUTTONS     = SM_CMOUSEBUTTONS- , sM_CXBORDER          = SM_CXBORDER- , sM_CYBORDER          = SM_CYBORDER- , sM_CXCURSOR          = SM_CXCURSOR- , sM_CYCURSOR          = SM_CYCURSOR- , sM_CXDLGFRAME        = SM_CXDLGFRAME- , sM_CYDLGFRAME        = SM_CYDLGFRAME- , sM_CXDOUBLECLK       = SM_CXDOUBLECLK- , sM_CYDOUBLECLK       = SM_CYDOUBLECLK- , sM_CXDRAG            = SM_CXDRAG- , sM_CYDRAG            = SM_CYDRAG- , sM_CXEDGE            = SM_CXEDGE- , sM_CYEDGE            = SM_CYEDGE- , sM_CXFRAME           = SM_CXFRAME- , sM_CYFRAME           = SM_CYFRAME- , sM_CXFULLSCREEN      = SM_CXFULLSCREEN- , sM_CYFULLSCREEN      = SM_CYFULLSCREEN- , sM_CXHSCROLL         = SM_CXHSCROLL- , sM_CYVSCROLL         = SM_CYVSCROLL- , sM_CXICON            = SM_CXICON- , sM_CYICON            = SM_CYICON- , sM_CXICONSPACING     = SM_CXICONSPACING- , sM_CYICONSPACING     = SM_CYICONSPACING- , sM_CXMAXIMIZED       = SM_CXMAXIMIZED- , sM_CYMAXIMIZED       = SM_CYMAXIMIZED- , sM_CXMENUCHECK       = SM_CXMENUCHECK- , sM_CYMENUCHECK       = SM_CYMENUCHECK- , sM_CXMENUSIZE        = SM_CXMENUSIZE- , sM_CYMENUSIZE        = SM_CYMENUSIZE- , sM_CXMIN             = SM_CXMIN- , sM_CYMIN             = SM_CYMIN- , sM_CXMINIMIZED       = SM_CXMINIMIZED- , sM_CYMINIMIZED       = SM_CYMINIMIZED- , sM_CXMINTRACK        = SM_CXMINTRACK- , sM_CYMINTRACK        = SM_CYMINTRACK- , sM_CXSCREEN          = SM_CXSCREEN- , sM_CYSCREEN          = SM_CYSCREEN- , sM_CXSIZE            = SM_CXSIZE- , sM_CYSIZE            = SM_CYSIZE- , sM_CXSIZEFRAME       = SM_CXSIZEFRAME- , sM_CYSIZEFRAME       = SM_CYSIZEFRAME- , sM_CXSMICON          = SM_CXSMICON- , sM_CYSMICON          = SM_CYSMICON- , sM_CXSMSIZE          = SM_CXSMSIZE- , sM_CYSMSIZE          = SM_CYSMSIZE- , sM_CXVSCROLL         = SM_CXVSCROLL- , sM_CYHSCROLL         = SM_CYHSCROLL- , sM_CYVTHUMB          = SM_CYVTHUMB- , sM_CYCAPTION         = SM_CYCAPTION- , sM_CYKANJIWINDOW     = SM_CYKANJIWINDOW- , sM_CYMENU            = SM_CYMENU- , sM_CYSMCAPTION       = SM_CYSMCAPTION- , sM_DBCSENABLED       = SM_DBCSENABLED- , sM_DEBUG             = SM_DEBUG- , sM_MENUDROPALIGNMENT = SM_MENUDROPALIGNMENT- , sM_MIDEASTENABLED    = SM_MIDEASTENABLED- , sM_MOUSEPRESENT      = SM_MOUSEPRESENT- , sM_NETWORK           = SM_NETWORK- , sM_PENWINDOWS        = SM_PENWINDOWS- , sM_SECURE            = SM_SECURE- , sM_SHOWSOUNDS        = SM_SHOWSOUNDS- , sM_SLOWMACHINE       = SM_SLOWMACHINE- , sM_SWAPBUTTON        = SM_SWAPBUTTON- }- -- %fun GetSystemMetrics :: SMSetting -> IO Int  ----------------------------------------------------------------@@ -344,44 +245,13 @@  -- %fun GetUserName :: IO String -------------------------------------------------------------------- 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 ??+getUserName :: IO String+getUserName =+  allocaArray 512 $ \ c_str ->+    with 512 $ \ c_len -> do+        failIfFalse_ "GetUserName" $ c_GetUserName c_str c_len+        len <- peek c_len+        peekTStringLen (c_str, fromIntegral len - 1)  ---------------------------------------------------------------- -- End

+ System/Win32/Info/Computer.hsc view

@@ -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_PATH
+
+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: Decide 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 character.
+      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
+-}

+ System/Win32/Info/Internal.hsc view

@@ -0,0 +1,313 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.Info.Internal+-- 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.Info.Internal where++import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable(..))+import System.Win32.Types (DWORD, LPDWORD, LPCTSTR, LPTSTR, LPVOID, UINT, WORD)++#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++##include "windows_cconv.h"++#include <windows.h>+#include "alignment.h"++----------------------------------------------------------------+-- Environment Strings+----------------------------------------------------------------++-- %fun ExpandEnvironmentStrings :: String -> IO String++----------------------------------------------------------------+-- Computer Name+----------------------------------------------------------------++-- %fun GetComputerName :: IO String+-- %fun SetComputerName :: String -> IO ()+-- %end free(arg1)++----------------------------------------------------------------+-- Hardware Profiles+----------------------------------------------------------------++-- %fun GetCurrentHwProfile :: IO HW_PROFILE_INFO++----------------------------------------------------------------+-- Keyboard Type+----------------------------------------------------------------++-- %fun GetKeyboardType :: KeyboardTypeKind -> IO KeyboardType++----------------------------------------------------------------+-- System Color+----------------------------------------------------------------++type SystemColor   = UINT++-- ToDo: This list is out of date.++#{enum SystemColor,+ , cOLOR_SCROLLBAR      = COLOR_SCROLLBAR+ , cOLOR_BACKGROUND     = COLOR_BACKGROUND+ , cOLOR_ACTIVECAPTION  = COLOR_ACTIVECAPTION+ , cOLOR_INACTIVECAPTION = COLOR_INACTIVECAPTION+ , cOLOR_MENU           = COLOR_MENU+ , cOLOR_WINDOW         = COLOR_WINDOW+ , cOLOR_WINDOWFRAME    = COLOR_WINDOWFRAME+ , cOLOR_MENUTEXT       = COLOR_MENUTEXT+ , cOLOR_WINDOWTEXT     = COLOR_WINDOWTEXT+ , cOLOR_CAPTIONTEXT    = COLOR_CAPTIONTEXT+ , cOLOR_ACTIVEBORDER   = COLOR_ACTIVEBORDER+ , cOLOR_INACTIVEBORDER = COLOR_INACTIVEBORDER+ , cOLOR_APPWORKSPACE   = COLOR_APPWORKSPACE+ , cOLOR_HIGHLIGHT      = COLOR_HIGHLIGHT+ , cOLOR_HIGHLIGHTTEXT  = COLOR_HIGHLIGHTTEXT+ , cOLOR_BTNFACE        = COLOR_BTNFACE+ , cOLOR_BTNSHADOW      = COLOR_BTNSHADOW+ , cOLOR_GRAYTEXT       = COLOR_GRAYTEXT+ , cOLOR_BTNTEXT        = COLOR_BTNTEXT+ , cOLOR_INACTIVECAPTIONTEXT = COLOR_INACTIVECAPTIONTEXT+ , cOLOR_BTNHIGHLIGHT   = COLOR_BTNHIGHLIGHT+ }++-- %fun GetSysColor :: SystemColor -> IO COLORREF+-- %fun SetSysColors :: [(SystemColor,COLORREF)] -> IO ()++----------------------------------------------------------------+-- Standard Directories+----------------------------------------------------------------++foreign import WINDOWS_CCONV unsafe "GetWindowsDirectoryW"+  c_getWindowsDirectory :: LPTSTR -> UINT -> IO UINT++foreign import WINDOWS_CCONV unsafe "GetSystemDirectoryW"+  c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT++foreign import WINDOWS_CCONV unsafe "GetCurrentDirectoryW"+  c_getCurrentDirectory :: DWORD -> LPTSTR -> IO UINT++foreign import WINDOWS_CCONV unsafe "GetTempPathW"+  c_getTempPath :: DWORD -> LPTSTR -> IO UINT++foreign import WINDOWS_CCONV unsafe "GetFullPathNameW"+  c_GetFullPathName :: LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR -> IO DWORD++foreign import WINDOWS_CCONV unsafe "GetLongPathNameW"+  c_GetLongPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD++foreign import WINDOWS_CCONV unsafe "GetShortPathNameW"+  c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD++foreign import WINDOWS_CCONV unsafe "SearchPathW"+  c_SearchPath :: LPCTSTR -> LPCTSTR -> LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR+               -> IO DWORD++----------------------------------------------------------------+-- System Info (Info about processor and memory subsystem)+----------------------------------------------------------------++data ProcessorArchitecture = PaUnknown WORD | PaIntel | PaMips | PaAlpha | PaPpc | PaIa64 | PaIa32OnIa64 | PaAmd64+    deriving (Show,Eq)++instance Storable ProcessorArchitecture where+    sizeOf _ = sizeOf (undefined::WORD)+    alignment _ = alignment (undefined::WORD)+    poke buf pa = pokeByteOff buf 0 $ case pa of+        PaUnknown w -> w+        PaIntel     -> #const PROCESSOR_ARCHITECTURE_INTEL+        PaMips      -> #const PROCESSOR_ARCHITECTURE_MIPS+        PaAlpha     -> #const PROCESSOR_ARCHITECTURE_ALPHA+        PaPpc       -> #const PROCESSOR_ARCHITECTURE_PPC+        PaIa64      -> #const PROCESSOR_ARCHITECTURE_IA64+#ifndef __WINE_WINDOWS_H+        PaIa32OnIa64 -> #const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64+#endif+        PaAmd64     -> #const PROCESSOR_ARCHITECTURE_AMD64+    peek buf = do+        v <- (peekByteOff buf 0:: IO WORD)+        return $ case v of+            (#const PROCESSOR_ARCHITECTURE_INTEL) -> PaIntel+            (#const PROCESSOR_ARCHITECTURE_MIPS)  -> PaMips+            (#const PROCESSOR_ARCHITECTURE_ALPHA) -> PaAlpha+            (#const PROCESSOR_ARCHITECTURE_PPC)   -> PaPpc+            (#const PROCESSOR_ARCHITECTURE_IA64)  -> PaIa64+#ifndef __WINE_WINDOWS_H+            (#const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64) -> PaIa32OnIa64+#endif+            (#const PROCESSOR_ARCHITECTURE_AMD64) -> PaAmd64+            w                                   -> PaUnknown w++data SYSTEM_INFO = SYSTEM_INFO+    { siProcessorArchitecture :: ProcessorArchitecture+    , siPageSize :: DWORD+    , siMinimumApplicationAddress, siMaximumApplicationAddress :: LPVOID+    , siActiveProcessorMask :: DWORD+    , siNumberOfProcessors :: DWORD+    , siProcessorType :: DWORD+    , siAllocationGranularity :: DWORD+    , siProcessorLevel :: WORD+    , siProcessorRevision :: WORD+    } deriving (Show)++instance Storable SYSTEM_INFO where+    sizeOf = const #size SYSTEM_INFO+    alignment _ = #alignment SYSTEM_INFO+    poke buf si = do+        (#poke SYSTEM_INFO, wProcessorArchitecture) buf (siProcessorArchitecture si)+        (#poke SYSTEM_INFO, dwPageSize)             buf (siPageSize si)+        (#poke SYSTEM_INFO, lpMinimumApplicationAddress) buf (siMinimumApplicationAddress si)+        (#poke SYSTEM_INFO, lpMaximumApplicationAddress) buf (siMaximumApplicationAddress si)+        (#poke SYSTEM_INFO, dwActiveProcessorMask)  buf (siActiveProcessorMask si)+        (#poke SYSTEM_INFO, dwNumberOfProcessors)   buf (siNumberOfProcessors si)+        (#poke SYSTEM_INFO, dwProcessorType)        buf (siProcessorType si)+        (#poke SYSTEM_INFO, dwAllocationGranularity) buf (siAllocationGranularity si)+        (#poke SYSTEM_INFO, wProcessorLevel)        buf (siProcessorLevel si)+        (#poke SYSTEM_INFO, wProcessorRevision)     buf (siProcessorRevision si)++    peek buf = do+        processorArchitecture <-+            (#peek SYSTEM_INFO, wProcessorArchitecture) buf+        pageSize            <- (#peek SYSTEM_INFO, dwPageSize) buf+        minimumApplicationAddress <-+            (#peek SYSTEM_INFO, lpMinimumApplicationAddress) buf+        maximumApplicationAddress <-+            (#peek SYSTEM_INFO, lpMaximumApplicationAddress) buf+        activeProcessorMask <- (#peek SYSTEM_INFO, dwActiveProcessorMask) buf+        numberOfProcessors  <- (#peek SYSTEM_INFO, dwNumberOfProcessors) buf+        processorType       <- (#peek SYSTEM_INFO, dwProcessorType) buf+        allocationGranularity <-+            (#peek SYSTEM_INFO, dwAllocationGranularity) buf+        processorLevel      <- (#peek SYSTEM_INFO, wProcessorLevel) buf+        processorRevision   <- (#peek SYSTEM_INFO, wProcessorRevision) buf+        return $ SYSTEM_INFO {+            siProcessorArchitecture     = processorArchitecture,+            siPageSize                  = pageSize,+            siMinimumApplicationAddress = minimumApplicationAddress,+            siMaximumApplicationAddress = maximumApplicationAddress,+            siActiveProcessorMask       = activeProcessorMask,+            siNumberOfProcessors        = numberOfProcessors,+            siProcessorType             = processorType,+            siAllocationGranularity     = allocationGranularity,+            siProcessorLevel            = processorLevel,+            siProcessorRevision         = processorRevision+            }++foreign import WINDOWS_CCONV unsafe "windows.h GetSystemInfo"+    c_GetSystemInfo :: Ptr SYSTEM_INFO -> IO ()++----------------------------------------------------------------+-- System metrics+----------------------------------------------------------------++type SMSetting = UINT++#{enum SMSetting,+ , sM_ARRANGE           = SM_ARRANGE+ , sM_CLEANBOOT         = SM_CLEANBOOT+ , sM_CMETRICS          = SM_CMETRICS+ , sM_CMOUSEBUTTONS     = SM_CMOUSEBUTTONS+ , sM_CXBORDER          = SM_CXBORDER+ , sM_CYBORDER          = SM_CYBORDER+ , sM_CXCURSOR          = SM_CXCURSOR+ , sM_CYCURSOR          = SM_CYCURSOR+ , sM_CXDLGFRAME        = SM_CXDLGFRAME+ , sM_CYDLGFRAME        = SM_CYDLGFRAME+ , sM_CXDOUBLECLK       = SM_CXDOUBLECLK+ , sM_CYDOUBLECLK       = SM_CYDOUBLECLK+ , sM_CXDRAG            = SM_CXDRAG+ , sM_CYDRAG            = SM_CYDRAG+ , sM_CXEDGE            = SM_CXEDGE+ , sM_CYEDGE            = SM_CYEDGE+ , sM_CXFRAME           = SM_CXFRAME+ , sM_CYFRAME           = SM_CYFRAME+ , sM_CXFULLSCREEN      = SM_CXFULLSCREEN+ , sM_CYFULLSCREEN      = SM_CYFULLSCREEN+ , sM_CXHSCROLL         = SM_CXHSCROLL+ , sM_CYVSCROLL         = SM_CYVSCROLL+ , sM_CXICON            = SM_CXICON+ , sM_CYICON            = SM_CYICON+ , sM_CXICONSPACING     = SM_CXICONSPACING+ , sM_CYICONSPACING     = SM_CYICONSPACING+ , sM_CXMAXIMIZED       = SM_CXMAXIMIZED+ , sM_CYMAXIMIZED       = SM_CYMAXIMIZED+ , sM_CXMENUCHECK       = SM_CXMENUCHECK+ , sM_CYMENUCHECK       = SM_CYMENUCHECK+ , sM_CXMENUSIZE        = SM_CXMENUSIZE+ , sM_CYMENUSIZE        = SM_CYMENUSIZE+ , sM_CXMIN             = SM_CXMIN+ , sM_CYMIN             = SM_CYMIN+ , sM_CXMINIMIZED       = SM_CXMINIMIZED+ , sM_CYMINIMIZED       = SM_CYMINIMIZED+ , sM_CXMINTRACK        = SM_CXMINTRACK+ , sM_CYMINTRACK        = SM_CYMINTRACK+ , sM_CXSCREEN          = SM_CXSCREEN+ , sM_CYSCREEN          = SM_CYSCREEN+ , sM_CXSIZE            = SM_CXSIZE+ , sM_CYSIZE            = SM_CYSIZE+ , sM_CXSIZEFRAME       = SM_CXSIZEFRAME+ , sM_CYSIZEFRAME       = SM_CYSIZEFRAME+ , sM_CXSMICON          = SM_CXSMICON+ , sM_CYSMICON          = SM_CYSMICON+ , sM_CXSMSIZE          = SM_CXSMSIZE+ , sM_CYSMSIZE          = SM_CYSMSIZE+ , sM_CXVSCROLL         = SM_CXVSCROLL+ , sM_CYHSCROLL         = SM_CYHSCROLL+ , sM_CYVTHUMB          = SM_CYVTHUMB+ , sM_CYCAPTION         = SM_CYCAPTION+ , sM_CYKANJIWINDOW     = SM_CYKANJIWINDOW+ , sM_CYMENU            = SM_CYMENU+ , sM_CYSMCAPTION       = SM_CYSMCAPTION+ , sM_DBCSENABLED       = SM_DBCSENABLED+ , sM_DEBUG             = SM_DEBUG+ , sM_MENUDROPALIGNMENT = SM_MENUDROPALIGNMENT+ , sM_MIDEASTENABLED    = SM_MIDEASTENABLED+ , sM_MOUSEPRESENT      = SM_MOUSEPRESENT+ , sM_NETWORK           = SM_NETWORK+ , sM_PENWINDOWS        = SM_PENWINDOWS+ , sM_SECURE            = SM_SECURE+ , sM_SHOWSOUNDS        = SM_SHOWSOUNDS+ , sM_SLOWMACHINE       = SM_SLOWMACHINE+ , sM_SWAPBUTTON        = SM_SWAPBUTTON+ }++-- %fun GetSystemMetrics :: SMSetting -> IO Int++----------------------------------------------------------------+-- Thread Desktops+----------------------------------------------------------------++-- %fun GetThreadDesktop :: ThreadId -> IO HDESK+-- %fun SetThreadDesktop :: ThreadId -> HDESK -> IO ()++----------------------------------------------------------------+-- User name+----------------------------------------------------------------++-- %fun GetUserName :: IO String++foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW"+  c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool++----------------------------------------------------------------+-- End+----------------------------------------------------------------

+ System/Win32/Info/Version.hsc view

@@ -0,0 +1,165 @@+{-# 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
+-}

System/Win32/Mem.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -15,15 +17,142 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Mem where+module System.Win32.Mem+    ( MEMORY_BASIC_INFORMATION(..)+    , copyMemory+    , moveMemory+    , fillMemory+    , zeroMemory+    , memset+    , getProcessHeap+#ifndef __WINE_WINDOWS_H+    , getProcessHeaps+#endif+    , HGLOBAL+      -- * Global allocation+    , GlobalAllocFlags+    , gMEM_INVALID_HANDLE+    , gMEM_FIXED+    , gMEM_MOVEABLE+    , gPTR+    , gHND+    , gMEM_DDESHARE+    , gMEM_SHARE+    , gMEM_LOWER+    , gMEM_NOCOMPACT+    , gMEM_NODISCARD+    , gMEM_NOT_BANKED+    , gMEM_NOTIFY+    , gMEM_ZEROINIT+    , globalAlloc+    , globalFlags+    , globalFree+    , globalHandle+    , globalLock+    , globalReAlloc+    , globalSize+    , globalUnlock +      -- * Heap allocation+    , HeapAllocFlags+    , hEAP_GENERATE_EXCEPTIONS+    , hEAP_NO_SERIALIZE+    , hEAP_ZERO_MEMORY+    , heapAlloc+    , heapCompact+    , heapCreate+    , heapDestroy+    , heapFree+    , heapLock+    , heapReAlloc+    , heapSize+    , heapUnlock+    , heapValidate++      -- * Virtual allocation+      -- ** Allocation+    , virtualAlloc+    , virtualAllocEx+    , VirtualAllocFlags+    , mEM_COMMIT+    , mEM_RESERVE+      -- ** Locking+    , virtualLock+    , virtualUnlock+      -- ** Protection+    , virtualProtect+    , virtualProtectEx+    , virtualQueryEx+    , ProtectFlags+    , pAGE_READONLY+    , pAGE_READWRITE+    , pAGE_EXECUTE+    , pAGE_EXECUTE_READ+    , pAGE_EXECUTE_READWRITE+    , pAGE_GUARD+    , pAGE_NOACCESS+    , pAGE_NOCACHE+      -- ** Freeing+    , virtualFree+    , virtualFreeEx+    , FreeFlags+    , mEM_DECOMMIT+    , mEM_RELEASE+++    ) where+ import System.Win32.Types  import Foreign import Foreign.C.Types +##include "windows_cconv.h"+ #include <windows.h>+#include "alignment.h" +----------------------------------------------------------------+-- Data types+----------------------------------------------------------------++data MEMORY_BASIC_INFORMATION = MEMORY_BASIC_INFORMATION+    { mbiBaseAddress       :: Addr+    , mbiAllocationBase    :: Addr+    , mbiAllocationProtect :: DWORD+    , mbiRegionSize        :: SIZE_T+    , mbiState             :: DWORD+    , mbiProtect           :: DWORD+    , mbiType              :: DWORD+    } deriving (Show)++----------------------------------------------------------------+-- Instances+----------------------------------------------------------------++instance Storable MEMORY_BASIC_INFORMATION where+    sizeOf _ = #size MEMORY_BASIC_INFORMATION+    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)+        (#poke MEMORY_BASIC_INFORMATION, AllocationProtect) buf (mbiAllocationProtect mbi)+        (#poke MEMORY_BASIC_INFORMATION, RegionSize)        buf (mbiRegionSize mbi)+        (#poke MEMORY_BASIC_INFORMATION, State)             buf (mbiState mbi)+        (#poke MEMORY_BASIC_INFORMATION, Protect)           buf (mbiProtect mbi)+        (#poke MEMORY_BASIC_INFORMATION, Type)              buf (mbiType mbi)+    peek buf = do+        baseAddress       <- (#peek MEMORY_BASIC_INFORMATION, BaseAddress)       buf+        allocationBase    <- (#peek MEMORY_BASIC_INFORMATION, AllocationBase)    buf+        allocationProtect <- (#peek MEMORY_BASIC_INFORMATION, AllocationProtect) buf+        regionSize        <- (#peek MEMORY_BASIC_INFORMATION, RegionSize)        buf+        state             <- (#peek MEMORY_BASIC_INFORMATION, State)             buf+        protect           <- (#peek MEMORY_BASIC_INFORMATION, Protect)           buf+        ty                <- (#peek MEMORY_BASIC_INFORMATION, Type)              buf+        return $ MEMORY_BASIC_INFORMATION baseAddress allocationBase allocationProtect regionSize state protect ty++----------------------------------------------------------------+ copyMemory :: Ptr a -> Ptr a -> DWORD -> IO () copyMemory dest src nbytes = copyBytes dest src (fromIntegral nbytes) @@ -39,11 +168,11 @@  foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO () -foreign import stdcall unsafe "windows.h GetProcessHeap"+foreign import WINDOWS_CCONV unsafe "windows.h GetProcessHeap"   getProcessHeap :: IO HANDLE  #ifndef __WINE_WINDOWS_H-foreign import stdcall unsafe "windows.h GetProcessHeaps"+foreign import WINDOWS_CCONV unsafe "windows.h GetProcessHeaps"   getProcessHeaps :: DWORD -> Addr -> IO DWORD #endif @@ -72,7 +201,7 @@ globalAlloc :: GlobalAllocFlags -> DWORD -> IO HGLOBAL globalAlloc flags size =   failIfNull "GlobalAlloc" $ c_GlobalAlloc flags size-foreign import stdcall unsafe "windows.h GlobalAlloc"+foreign import WINDOWS_CCONV unsafe "windows.h GlobalAlloc"   c_GlobalAlloc :: GlobalAllocFlags -> DWORD -> IO HGLOBAL  -- %fun GlobalDiscard :: HGLOBAL -> IO HGLOBAL@@ -81,25 +210,25 @@ globalFlags :: HGLOBAL -> IO GlobalAllocFlags globalFlags mem =   failIf (== gMEM_INVALID_HANDLE) "GlobalFlags" $ c_GlobalFlags mem-foreign import stdcall unsafe "windows.h GlobalFlags"+foreign import WINDOWS_CCONV unsafe "windows.h GlobalFlags"   c_GlobalFlags :: HGLOBAL -> IO GlobalAllocFlags  globalFree :: HGLOBAL -> IO HGLOBAL globalFree mem =   failIfNull "GlobalFree" $ c_GlobalFree mem-foreign import stdcall unsafe "windows.h GlobalFree"+foreign import WINDOWS_CCONV unsafe "windows.h GlobalFree"   c_GlobalFree :: HGLOBAL -> IO HGLOBAL  globalHandle :: Addr -> IO HGLOBAL globalHandle addr =   failIfNull "GlobalHandle" $ c_GlobalHandle addr-foreign import stdcall unsafe "windows.h GlobalHandle"+foreign import WINDOWS_CCONV unsafe "windows.h GlobalHandle"   c_GlobalHandle :: Addr -> IO HGLOBAL  globalLock :: HGLOBAL -> IO Addr globalLock mem =   failIfNull "GlobalLock" $ c_GlobalLock mem-foreign import stdcall unsafe "windows.h GlobalLock"+foreign import WINDOWS_CCONV unsafe "windows.h GlobalLock"   c_GlobalLock :: HGLOBAL -> IO Addr  -- %fun GlobalMemoryStatus :: IO MEMORYSTATUS@@ -107,84 +236,84 @@ globalReAlloc :: HGLOBAL -> DWORD -> GlobalAllocFlags -> IO HGLOBAL globalReAlloc mem size flags =   failIfNull "GlobalReAlloc" $ c_GlobalReAlloc mem size flags-foreign import stdcall unsafe "windows.h GlobalReAlloc"+foreign import WINDOWS_CCONV unsafe "windows.h GlobalReAlloc"   c_GlobalReAlloc :: HGLOBAL -> DWORD -> GlobalAllocFlags -> IO HGLOBAL  globalSize :: HGLOBAL -> IO DWORD globalSize mem =   failIfZero "GlobalSize" $ c_GlobalSize mem-foreign import stdcall unsafe "windows.h GlobalSize"+foreign import WINDOWS_CCONV unsafe "windows.h GlobalSize"   c_GlobalSize :: HGLOBAL -> IO DWORD  globalUnlock :: HGLOBAL -> IO () globalUnlock mem =   failIfFalse_ "GlobalUnlock" $ c_GlobalUnlock mem-foreign import stdcall unsafe "windows.h GlobalUnlock"+foreign import WINDOWS_CCONV unsafe "windows.h GlobalUnlock"   c_GlobalUnlock :: HGLOBAL -> IO Bool  type HeapAllocFlags = DWORD  #{enum HeapAllocFlags,- , hEAP_GENERATE_EXCEPTIONS	= HEAP_GENERATE_EXCEPTIONS- , hEAP_NO_SERIALIZE		= HEAP_NO_SERIALIZE- , hEAP_ZERO_MEMORY		= HEAP_ZERO_MEMORY+ , hEAP_GENERATE_EXCEPTIONS     = HEAP_GENERATE_EXCEPTIONS+ , hEAP_NO_SERIALIZE            = HEAP_NO_SERIALIZE+ , hEAP_ZERO_MEMORY             = HEAP_ZERO_MEMORY  }  heapAlloc :: HANDLE -> HeapAllocFlags -> DWORD -> IO Addr heapAlloc heap flags size =   failIfNull "HeapAlloc" $ c_HeapAlloc heap flags size-foreign import stdcall unsafe "windows.h HeapAlloc"+foreign import WINDOWS_CCONV unsafe "windows.h HeapAlloc"   c_HeapAlloc :: HANDLE -> HeapAllocFlags -> DWORD -> IO Addr  heapCompact :: HANDLE -> HeapAllocFlags -> IO UINT heapCompact heap flags =   failIfZero "HeapCompact" $ c_HeapCompact heap flags-foreign import stdcall unsafe "windows.h HeapCompact"+foreign import WINDOWS_CCONV unsafe "windows.h HeapCompact"   c_HeapCompact :: HANDLE -> HeapAllocFlags -> IO UINT  heapCreate :: HeapAllocFlags -> DWORD -> DWORD -> IO HANDLE heapCreate flags initSize maxSize =   failIfNull "HeapCreate" $ c_HeapCreate flags initSize maxSize-foreign import stdcall unsafe "windows.h HeapCreate"+foreign import WINDOWS_CCONV unsafe "windows.h HeapCreate"   c_HeapCreate :: HeapAllocFlags -> DWORD -> DWORD -> IO HANDLE  heapDestroy :: HANDLE -> IO () heapDestroy heap =   failIfFalse_ "HeapDestroy" $ c_HeapDestroy heap-foreign import stdcall unsafe "windows.h HeapDestroy"+foreign import WINDOWS_CCONV unsafe "windows.h HeapDestroy"   c_HeapDestroy :: HANDLE -> IO Bool  heapFree :: HANDLE -> HeapAllocFlags -> Addr -> IO () heapFree heap flags addr =   failIfFalse_ "HeapFree" $ c_HeapFree heap flags addr-foreign import stdcall unsafe "windows.h HeapFree"+foreign import WINDOWS_CCONV unsafe "windows.h HeapFree"   c_HeapFree :: HANDLE -> HeapAllocFlags -> Addr -> IO Bool  heapLock :: HANDLE -> IO () heapLock heap =   failIfFalse_ "HeapLock" $ c_HeapLock heap-foreign import stdcall unsafe "windows.h HeapLock"+foreign import WINDOWS_CCONV unsafe "windows.h HeapLock"   c_HeapLock :: HANDLE -> IO Bool  heapReAlloc :: HANDLE -> HeapAllocFlags -> Addr -> DWORD -> IO Addr heapReAlloc heap flags addr size =   failIfNull "HeapReAlloc" $ c_HeapReAlloc heap flags addr size-foreign import stdcall unsafe "windows.h HeapReAlloc"+foreign import WINDOWS_CCONV unsafe "windows.h HeapReAlloc"   c_HeapReAlloc :: HANDLE -> HeapAllocFlags -> Addr -> DWORD -> IO Addr  heapSize :: HANDLE -> HeapAllocFlags -> Addr -> IO DWORD heapSize heap flags addr =   failIfZero "HeapSize" $ c_HeapSize heap flags addr-foreign import stdcall unsafe "windows.h HeapSize"+foreign import WINDOWS_CCONV unsafe "windows.h HeapSize"   c_HeapSize :: HANDLE -> HeapAllocFlags -> Addr -> IO DWORD  heapUnlock :: HANDLE -> IO () heapUnlock heap =   failIfFalse_ "HeapUnlock" $ c_HeapUnlock heap-foreign import stdcall unsafe "windows.h HeapUnlock"+foreign import WINDOWS_CCONV unsafe "windows.h HeapUnlock"   c_HeapUnlock :: HANDLE -> IO Bool -foreign import stdcall unsafe "windows.h HeapValidate"+foreign import WINDOWS_CCONV unsafe "windows.h HeapValidate"   heapValidate :: HANDLE -> HeapAllocFlags -> Addr -> IO Bool  type VirtualAllocFlags = DWORD@@ -219,29 +348,31 @@ virtualAlloc :: Addr -> DWORD -> VirtualAllocFlags -> ProtectFlags -> IO Addr virtualAlloc addt size ty flags =   failIfNull "VirtualAlloc" $ c_VirtualAlloc addt size ty flags-foreign import stdcall unsafe "windows.h VirtualAlloc"+foreign import WINDOWS_CCONV unsafe "windows.h VirtualAlloc"   c_VirtualAlloc :: Addr -> DWORD -> DWORD -> DWORD -> IO Addr --- %fun VirtualAllocEx :: HANDLE -> Addr -> DWORD -> VirtualAllocFlags -> ProtectFlags ->IO Addr--- %code extern LPVOID WINAPI VirtualAllocEx(HANDLE,LPVOID,DWORD,DWORD,DWORD);--- %     LPVOID res1=VirtualAllocEx(arg1,arg2,arg3,arg4,arg5);--- %fail {res1==NULL}{ErrorWin("VirtualAllocEx")}+virtualAllocEx :: HANDLE -> Addr -> DWORD -> VirtualAllocFlags -> ProtectFlags -> IO Addr+virtualAllocEx proc addt size ty flags =+  failIfNull "VirtualAllocEx" $ c_VirtualAllocEx proc addt size ty flags+foreign import WINDOWS_CCONV unsafe "windows.h VirtualAllocEx"+  c_VirtualAllocEx :: HANDLE -> Addr -> DWORD -> DWORD -> DWORD -> IO Addr  virtualFree :: Addr -> DWORD -> FreeFlags -> IO () virtualFree addr size flags =   failIfFalse_ "VirtualFree" $ c_VirtualFree addr size flags-foreign import stdcall unsafe "windows.h VirtualFree"+foreign import WINDOWS_CCONV unsafe "windows.h VirtualFree"   c_VirtualFree :: Addr -> DWORD -> FreeFlags -> IO Bool --- %fun VirtualFreeEx :: HANDLE -> Addr -> DWORD -> FreeFlags -> IO ()--- %code extern BOOL WINAPI VirtualFreeEx(HANDLE,LPVOID,DWORD,DWORD);--- %     BOOL res1=VirtualFreeEx(arg1,arg2,arg3,arg4);--- %fail {res1=0}{ErrorWin("VirtualFreeEx")}+virtualFreeEx :: HANDLE -> Addr -> DWORD -> FreeFlags -> IO ()+virtualFreeEx proc addr size flags =+  failIfFalse_ "VirtualFreeEx" $ c_VirtualFreeEx proc addr size flags+foreign import WINDOWS_CCONV unsafe "windows.h VirtualFreeEx"+  c_VirtualFreeEx :: HANDLE -> Addr -> DWORD -> FreeFlags -> IO Bool  virtualLock :: Addr -> DWORD -> IO () virtualLock addr size =   failIfFalse_ "VirtualLock" $ c_VirtualLock addr size-foreign import stdcall unsafe "windows.h VirtualLock"+foreign import WINDOWS_CCONV unsafe "windows.h VirtualLock"   c_VirtualLock :: Addr -> DWORD -> IO Bool  virtualProtect :: Addr -> DWORD -> ProtectFlags -> IO ProtectFlags@@ -249,7 +380,7 @@   alloca $ \ p_old -> do   failIfFalse_ "VirtualProtect" $ c_VirtualProtect addr size new_prot p_old   peek p_old-foreign import stdcall unsafe "windows.h VirtualProtect"+foreign import WINDOWS_CCONV unsafe "windows.h VirtualProtect"   c_VirtualProtect :: Addr -> DWORD -> DWORD -> Ptr DWORD -> IO Bool  virtualProtectEx :: HANDLE -> Addr -> DWORD -> ProtectFlags -> IO ProtectFlags@@ -258,13 +389,17 @@   failIfFalse_ "VirtualProtectEx" $     c_VirtualProtectEx proc addr size new_prot p_old   peek p_old-foreign import stdcall unsafe "windows.h VirtualProtectEx"+foreign import WINDOWS_CCONV unsafe "windows.h VirtualProtectEx"   c_VirtualProtectEx :: HANDLE -> Addr -> DWORD -> DWORD -> Ptr DWORD -> IO Bool --- No VirtualQuery..()+virtualQueryEx :: HANDLE -> LPVOID -> Ptr MEMORY_BASIC_INFORMATION -> SIZE_T -> IO DWORD+virtualQueryEx hProcess lpAddress lpBuffer dwLength =+  failIfZero "VirtualQueryEx" $ c_VirtualQueryEx hProcess lpAddress lpBuffer dwLength+foreign import WINDOWS_CCONV unsafe "windows.h VirtualQueryEx"+  c_VirtualQueryEx :: HANDLE -> LPVOID -> Ptr MEMORY_BASIC_INFORMATION -> SIZE_T -> IO DWORD  virtualUnlock :: Addr -> DWORD -> IO () virtualUnlock addr size =   failIfFalse_ "VirtualUnlock" $ c_VirtualUnlock addr size-foreign import stdcall unsafe "windows.h VirtualUnlock"+foreign import WINDOWS_CCONV unsafe "windows.h VirtualUnlock"   c_VirtualUnlock :: Addr -> DWORD -> IO Bool

+ System/Win32/MinTTY.hsc view

@@ -0,0 +1,245 @@+{-# LANGUAGE ScopedTypeVariables #-}++#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# 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 an old version of MinTTY+-- that emulates a TTY. Note, however, that this does not check for more recent+-- versions of MinTTY that use the native Windows console PTY directly. The old+-- approach (where MinTTY emulates a TTY) sometimes requires different+-- approaches to handling keyboard inputs.+--+-- 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 (isInfixOf)+import Foreign+import Foreign.C.Types++#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 an+-- emulated MinTTY console (e.g., Cygwin or MSYS that use an old version of+-- MinTTY). 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 an emulated MinTTY+-- console (e.g., Cygwin or MSYS that use an old version of MinTTY). 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-" `isInfixOf` fn || "msys-" `isInfixOf` fn) &&+            "-pty" `isInfixOf` 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. As a result, we use `isPrefixOf` to check for "cygwin" and+-- "msys".+--+-- It's unclear if "-master" will always appear in the filepath name. Recent+-- versions of MinTTY have been known to give filepaths like this (#186):+--+--    \msys-dd50a72ab4668b33-pty0-to-master-nat+--+-- Just in case MinTTY ever changes this convention, we don't bother checking+-- for the presence of "-master" in the filepath name at all.++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+      hwnd <- getModuleHandle (Just "ntdll.exe")+      addr <- getProcAddress hwnd "NtQueryObject"+      let c_NtQueryObject = mk_NtQueryObject (castPtrToFunPtr addr)+      _ <- 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_NtQueryObject = HANDLE -> CInt -> Ptr OBJECT_NAME_INFORMATION+                     -> ULONG -> Ptr ULONG -> IO NTSTATUS++foreign import WINDOWS_CCONV "dynamic"+  mk_NtQueryObject :: FunPtr F_NtQueryObject -> F_NtQueryObject++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+          }++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)

System/Win32/NLS.hsc view

@@ -1,6 +1,5 @@-#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Win32.NLS@@ -16,35 +15,70 @@ -----------------------------------------------------------------------------  module System.Win32.NLS  (-	module System.Win32.NLS,+        module System.Win32.NLS,+#if MIN_VERSION_base(4,15,0)+        CodePage,+#endif -	-- defined in System.Win32.Types-	LCID, LANGID, SortID, SubLANGID, PrimaryLANGID,-	mAKELCID, lANGIDFROMLCID, sORTIDFROMLCID,-	mAKELANGID, pRIMARYLANGID, sUBLANGID-	) where+        -- defined in System.Win32.Types+        LCID, LANGID, SortID, SubLANGID, PrimaryLANGID,+        mAKELCID, lANGIDFROMLCID, sORTIDFROMLCID,+        mAKELANGID, pRIMARYLANGID, sUBLANGID+        ) where +import System.Win32.String (withTStringBufferLen) import System.Win32.Types+import System.Win32.Utils (trySized) +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Monad (when)+import Data.IORef (modifyIORef, newIORef, readIORef) import Foreign import Foreign.C+#if MIN_VERSION_base(4,15,0)+import GHC.IO.Encoding.CodePage (CodePage)+#endif+import Text.Printf (printf) +##include "windows_cconv.h"++-- Somewhere, WINVER and _WIN32_WINNT are being defined as less than 0x0600 -+-- that is, before Windows Vista. Support for Windows XP was dropped in+-- GHC 8.0.1 of May 2016. This forces them to be at least 0x0600.+#if WINVER < 0x0600+#undef WINVER+#define WINVER 0x0600+#endif+#if _WIN32_WINNT < 0x0600+#undef _WIN32_WINNT+#define _WIN32_WINNT 0x0600+#endif+ #include <windows.h>+#include "alignment.h" #include "errors.h" #include "win32debug.h"+#include "winnls_compat.h"+#include "winnt_compat.h" +type NLS_FUNCTION = DWORD+ #{enum LCID,  , lOCALE_SYSTEM_DEFAULT = LOCALE_SYSTEM_DEFAULT  , lOCALE_USER_DEFAULT   = LOCALE_USER_DEFAULT  , lOCALE_NEUTRAL        = LOCALE_NEUTRAL  } -foreign import stdcall unsafe "windows.h ConvertDefaultLocale"+foreign import WINDOWS_CCONV unsafe "windows.h ConvertDefaultLocale"   convertDefaultLocale :: LCID -> IO LCID --- ToDo: various enum functions.+-- TODO: various enum functions. +#if !MIN_VERSION_base(4,15,0) type CodePage = UINT+#endif  #{enum CodePage,  , cP_ACP       = CP_ACP@@ -52,74 +86,402 @@  , cP_OEMCP     = CP_OEMCP  } -foreign import stdcall unsafe "windows.h GetACP"+foreign import WINDOWS_CCONV unsafe "windows.h GetACP"   getACP :: IO CodePage -foreign import stdcall unsafe "windows.h SetThreadLocale"+foreign import WINDOWS_CCONV unsafe "windows.h SetThreadLocale"   setThreadLocale :: LCID -> IO ()  type LCTYPE = UINT +-- The following locale information constants are excluded from the `enum` list+-- below, for the reason indicated:+-- LOCALE_IDIALINGCODE -- Introduced in Windows 10 but not supported. Synonym+                       -- for LOCALE_ICOUNTRY.+-- LOCALE_INEGATIVEPERCENT -- Introduced in Windows 7 but not supported.+-- LOCALE_IPOSITIVEPERCENT -- Introduced in Windows 7 but not supported.+-- LOCALE_IREADINGLAYOUT -- Introduced in Windows 7 but not supported.+-- LOCALE_SAM -- Introduced by Windows 10 but not supported. Synonym for+              -- LOCALE_S1159.+-- LOCALE_SENGLISHDISPLAYNAME -- Introduced in Windows 7 but not supported.+-- LOCALE_SIETFLANGUAGE -- Not supported (deprecated from Windows Vista).+-- LOCALE_SNATIVEDISPLAYNAME -- Introduced in Windows 7 but not supported.+-- LOCALE_SNATIVELANGUAGENAME -- Introduced in Windows 7 but not supported.+-- LOCALE_SPERCENT -- Introduced in Windows 7 but not supported.+-- LOCALE_SPM -- Introduced in Windows 10 but not supported. Synonym for+              -- LOCALE_S2359.+-- LOCALE_SSHORTESTAM -- Not supported.+-- LOCALE_SSHORTESTPM -- Not supported.+-- LOCALE_SSHORTTIME -- Introduced in Windows 7 but not supported.++-- The following locale information constant is included in the list below, but+-- note:+-- LOCALE_IINTLCURRDIGITS -- Not supported by Windows 10, use+                          -- LOCALE_ICURRDIGITS.+ #{enum LCTYPE,+ , lOCALE_FONTSIGNATURE = LOCALE_FONTSIGNATURE  , lOCALE_ICALENDARTYPE = LOCALE_ICALENDARTYPE- , lOCALE_SDATE         = LOCALE_SDATE+ , lOCALE_ICENTURY      = LOCALE_ICENTURY+ , lOCALE_ICOUNTRY      = LOCALE_ICOUNTRY  , lOCALE_ICURRDIGITS   = LOCALE_ICURRDIGITS- , lOCALE_SDECIMAL      = LOCALE_SDECIMAL  , lOCALE_ICURRENCY     = LOCALE_ICURRENCY- , lOCALE_SGROUPING     = LOCALE_SGROUPING+ , lOCALE_IDATE         = LOCALE_IDATE+ , lOCALE_IDAYLZERO     = LOCALE_IDAYLZERO+ , lOCALE_IDEFAULTANSICODEPAGE = LOCALE_IDEFAULTANSICODEPAGE+ , lOCALE_IDEFAULTCODEPAGE = LOCALE_IDEFAULTCODEPAGE+ , lOCALE_IDEFAULTCOUNTRY = LOCALE_IDEFAULTCOUNTRY+ , lOCALE_IDEFAULTEBCDICCODEPAGE = LOCALE_IDEFAULTEBCDICCODEPAGE+ , lOCALE_IDEFAULTLANGUAGE = LOCALE_IDEFAULTLANGUAGE+ , lOCALE_IDEFAULTMACCODEPAGE = LOCALE_IDEFAULTMACCODEPAGE  , lOCALE_IDIGITS       = LOCALE_IDIGITS- , lOCALE_SLIST         = LOCALE_SLIST+ , lOCALE_IDIGITSUBSTITUTION = LOCALE_IDIGITSUBSTITUTION  , lOCALE_IFIRSTDAYOFWEEK = LOCALE_IFIRSTDAYOFWEEK- , lOCALE_SLONGDATE     = LOCALE_SLONGDATE  , lOCALE_IFIRSTWEEKOFYEAR = LOCALE_IFIRSTWEEKOFYEAR- , lOCALE_SMONDECIMALSEP = LOCALE_SMONDECIMALSEP+ , lOCALE_IGEOID        = LOCALE_IGEOID+ , lOCALE_IINTLCURRDIGITS = LOCALE_IINTLCURRDIGITS+ , lOCALE_ILANGUAGE     = LOCALE_ILANGUAGE+ , lOCALE_ILDATE        = LOCALE_ILDATE  , lOCALE_ILZERO        = LOCALE_ILZERO- , lOCALE_SMONGROUPING  = LOCALE_SMONGROUPING  , lOCALE_IMEASURE      = LOCALE_IMEASURE- , lOCALE_SMONTHOUSANDSEP = LOCALE_SMONTHOUSANDSEP+ , lOCALE_IMONLZERO     = LOCALE_IMONLZERO  , lOCALE_INEGCURR      = LOCALE_INEGCURR- , lOCALE_SNEGATIVESIGN = LOCALE_SNEGATIVESIGN  , lOCALE_INEGNUMBER    = LOCALE_INEGNUMBER+ , lOCALE_INEGSEPBYSPACE = LOCALE_INEGSEPBYSPACE+ , lOCALE_INEGSIGNPOSN   = LOCALE_INEGSIGNPOSN+ , lOCALE_INEGSYMPRECEDES = LOCALE_INEGSYMPRECEDES+ , lOCALE_IOPTIONALCALENDAR = LOCALE_IOPTIONALCALENDAR+ , lOCALE_PAPERSIZE     = LOCALE_IPAPERSIZE+ , lOCALE_IPOSSEPBYSPACE = LOCALE_IPOSSEPBYSPACE+ , lOCALE_IPOSSIGNPOSN  = LOCALE_IPOSSIGNPOSN+ , lOCALE_IPSSYMPRECEDES = LOCALE_IPOSSYMPRECEDES+ , lOCALE_ITIME         = LOCALE_ITIME+ , lOCALE_ITIMEMARKPOSN = LOCALE_ITIMEMARKPOSN+ , lOCALE_ITLZERO       = LOCALE_ITLZERO+ , lOCALE_RETURN_NUMBER = LOCALE_RETURN_NUMBER+ , lOCALE_S1159         = LOCALE_S1159+ , lOCALE_S2359         = LOCALE_S2359+ , lOCALE_SABBREVCTRYNAME = LOCALE_SABBREVCTRYNAME+ , lOCALE_SABBREVDAYNAME1 = LOCALE_SABBREVDAYNAME1+ , lOCALE_SABBREVDAYNAME2 = LOCALE_SABBREVDAYNAME2+ , lOCALE_SABBREVDAYNAME3 = LOCALE_SABBREVDAYNAME3+ , lOCALE_SABBREVDAYNAME4 = LOCALE_SABBREVDAYNAME4+ , lOCALE_SABBREVDAYNAME5 = LOCALE_SABBREVDAYNAME5+ , lOCALE_SABBREVDAYNAME6 = LOCALE_SABBREVDAYNAME6+ , lOCALE_SABBREVDAYNAME7 = LOCALE_SABBREVDAYNAME7+ , lOCALE_SABBREVLANGNAME = LOCALE_SABBREVLANGNAME+ , lOCALE_SABBREVMONTHNAME1 = LOCALE_SABBREVMONTHNAME1+ , lOCALE_SABBREVMONTHNAME2 = LOCALE_SABBREVMONTHNAME2+ , lOCALE_SABBREVMONTHNAME3 = LOCALE_SABBREVMONTHNAME3+ , lOCALE_SABBREVMONTHNAME4 = LOCALE_SABBREVMONTHNAME4+ , lOCALE_SABBREVMONTHNAME5 = LOCALE_SABBREVMONTHNAME5+ , lOCALE_SABBREVMONTHNAME6 = LOCALE_SABBREVMONTHNAME6+ , lOCALE_SABBREVMONTHNAME7 = LOCALE_SABBREVMONTHNAME7+ , lOCALE_SABBREVMONTHNAME8 = LOCALE_SABBREVMONTHNAME8+ , lOCALE_SABBREVMONTHNAME9 = LOCALE_SABBREVMONTHNAME9+ , lOCALE_SABBREVMONTHNAME10 = LOCALE_SABBREVMONTHNAME10+ , lOCALE_SABBREVMONTHNAME11 = LOCALE_SABBREVMONTHNAME11+ , lOCALE_SABBREVMONTHNAME12 = LOCALE_SABBREVMONTHNAME12+ , lOCALE_SABBREVMONTHNAME13 = LOCALE_SABBREVMONTHNAME13+ , lOCALE_SCONSOLEFALLBACKNAME = LOCALE_SCONSOLEFALLBACKNAME+ , lOCALE_SCURRENCY     = LOCALE_SCURRENCY+ , lOCALE_SDATE         = LOCALE_SDATE+ , lOCALE_SDAYNAME1     = LOCALE_SDAYNAME1+ , lOCALE_SDAYNAME2     = LOCALE_SDAYNAME2+ , lOCALE_SDAYNAME3     = LOCALE_SDAYNAME3+ , lOCALE_SDAYNAME4     = LOCALE_SDAYNAME4+ , lOCALE_SDAYNAME5     = LOCALE_SDAYNAME5+ , lOCALE_SDAYNAME6     = LOCALE_SDAYNAME6+ , lOCALE_SDAYNAME7     = LOCALE_SDAYNAME7+ , lOCALE_SDECIMAL      = LOCALE_SDECIMAL+ , lOCALE_SDURATION     = LOCALE_SDURATION+ , lOCALE_SENGCURRNAME  = LOCALE_SENGCURRNAME+ , lOCALE_SENGLISHCOUNTRYNAME = LOCALE_SENGLISHCOUNTRYNAME+ , lOCALE_SENGLISHLANGUAGENAME = LOCALE_SENGLISHLANGUAGENAME+ , lOCALE_SGROUPING     = LOCALE_SGROUPING+ , lOCALE_SINTLSYMBOL   = LOCALE_SINTLSYMBOL+ , lOCALE_SISO3166CTRYNAME = LOCALE_SISO3166CTRYNAME+ , lOCALE_SISO3166CTRYNAME2 = LOCALE_SISO3166CTRYNAME2+ , lOCALE_SISO639LANGNAME = LOCALE_SISO639LANGNAME+ , lOCALE_SISO639LANGNAME2 = LOCALE_SISO639LANGNAME2+ , lOCALE_SKEYBOARDSTOINSTALL = LOCALE_SKEYBOARDSTOINSTALL+ , lOCALE_SLIST         = LOCALE_SLIST+ , lOCALE_SLONGDATE     = LOCALE_SLONGDATE+ , lOCALE_SMONDECIMALSEP = LOCALE_SMONDECIMALSEP+ , lOCALE_SMONGROUPING  = LOCALE_SMONGROUPING+ , lOCALE_SMONTHNAME1   = LOCALE_SMONTHNAME1+ , lOCALE_SMONTHNAME2   = LOCALE_SMONTHNAME2+ , lOCALE_SMONTHNAME3   = LOCALE_SMONTHNAME3+ , lOCALE_SMONTHNAME4   = LOCALE_SMONTHNAME4+ , lOCALE_SMONTHNAME5   = LOCALE_SMONTHNAME5+ , lOCALE_SMONTHNAME6   = LOCALE_SMONTHNAME6+ , lOCALE_SMONTHNAME7   = LOCALE_SMONTHNAME7+ , lOCALE_SMONTHNAME8   = LOCALE_SMONTHNAME8+ , lOCALE_SMONTHNAME9   = LOCALE_SMONTHNAME9+ , lOCALE_SMONTHNAME10  = LOCALE_SMONTHNAME10+ , lOCALE_SMONTHNAME11  = LOCALE_SMONTHNAME11+ , lOCALE_SMONTHNAME12  = LOCALE_SMONTHNAME12+ , lOCALE_SMONTHNAME13  = LOCALE_SMONTHNAME13+ , lOCALE_SMONTHOUSANDSEP = LOCALE_SMONTHOUSANDSEP+ , lOCALE_SNAME         = LOCALE_SNAME+ , lOCALE_SNAN          = LOCALE_SNAN+ , lOCALE_SNATIVECOUNTRYNAME = LOCALE_SNATIVECOUNTRYNAME+ , lOCALE_SNATIVECURRNAME = LOCALE_SNATIVECURRNAME+ , lOCALE_SNATIVEDIGITS = LOCALE_SNATIVEDIGITS+ , lOCALE_SNEGATIVESIGN = LOCALE_SNEGATIVESIGN+ , lOCALE_SNEGINFINITY  = LOCALE_SNEGINFINITY+ , lOCALE_SPARENT       = LOCALE_SPARENT+ , lOCALE_SPOSINFINITY  = LOCALE_SPOSINFINITY  , lOCALE_SPOSITIVESIGN = LOCALE_SPOSITIVESIGN+ , lOCALE_SSCRIPTS      = LOCALE_SSCRIPTS  , lOCALE_SSHORTDATE    = LOCALE_SSHORTDATE- , lOCALE_ITIME         = LOCALE_ITIME+ , lOCALE_SSHORTESTDAYNAME1 = LOCALE_SSHORTESTDAYNAME1+ , lOCALE_SSHORTESTDAYNAME2 = LOCALE_SSHORTESTDAYNAME2+ , lOCALE_SSHORTESTDAYNAME3 = LOCALE_SSHORTESTDAYNAME3+ , lOCALE_SSHORTESTDAYNAME4 = LOCALE_SSHORTESTDAYNAME4+ , lOCALE_SSHORTESTDAYNAME5 = LOCALE_SSHORTESTDAYNAME5+ , lOCALE_SSHORTESTDAYNAME6 = LOCALE_SSHORTESTDAYNAME6+ , lOCALE_SSHORTESTDAYNAME7 = LOCALE_SSHORTESTDAYNAME7+ , lOCALE_SSORTNAME     = LOCALE_SSORTNAME  , lOCALE_STHOUSAND     = LOCALE_STHOUSAND- , lOCALE_S1159         = LOCALE_S1159  , lOCALE_STIME         = LOCALE_STIME- , lOCALE_S2359         = LOCALE_S2359  , lOCALE_STIMEFORMAT   = LOCALE_STIMEFORMAT- , lOCALE_SCURRENCY     = LOCALE_SCURRENCY+ , lOCALE_SYEARMONTH    = LOCALE_SYEARMONTH  } +-- |Type representing locale data+data LCData+  -- | Data in the form of a Unicode string.+  = LCTextualData !String+  -- | Data in the form of a number. See 'lOCAL_RETURN_NUMBER' and @LOCAL_I*@+  -- locate information constants.+  | LCNumericData !DWORD+  -- | Data in the fomr of a 'LOCALESIGNATURE'. See 'lOCAL_FONTSIGNATURE' locale+  -- information constant.+  | LCSignatureData !LOCALESIGNATURE+  deriving (Eq, Show)++data LOCALESIGNATURE = LOCALESIGNATURE+  { lsUsb :: !UnicodeSubsetBitfield+  , lsCsbDefault :: !DDWORD+  , lsCsbSupported :: !DDWORD+  } deriving (Eq, Show)++instance Storable LOCALESIGNATURE where+  sizeOf = const #{size LOCALESIGNATURE}+  alignment _ = #alignment LOCALESIGNATURE+  peek buf = do+    lsUsb'          <- (#peek LOCALESIGNATURE, lsUsb) buf+    lsCsbDefault'   <- (#peek LOCALESIGNATURE, lsCsbDefault) buf+    lsCsbSupported' <- (#peek LOCALESIGNATURE, lsCsbSupported) buf+    return $ LOCALESIGNATURE lsUsb' lsCsbDefault' lsCsbSupported'+  poke buf info = do+    (#poke LOCALESIGNATURE, lsUsb) buf (lsUsb info)+    (#poke LOCALESIGNATURE, lsCsbDefault) buf (lsCsbDefault info)+    (#poke LOCALESIGNATURE, lsCsbSupported) buf (lsCsbSupported info)++-- | Type representing 128-bit Unicode subset bitfields, as the @base@ package+-- does include a module exporting a 128-bit unsigned integer type.+data UnicodeSubsetBitfield = UnicodeSubsetBitfield+  { usbLow :: !DDWORD+  , usbHigh :: !DDWORD+  } deriving (Eq, Show)++instance Storable UnicodeSubsetBitfield where+  sizeOf _ = 2 * sizeOf (undefined :: DDWORD)+  alignment _ = alignment (undefined :: DWORD)+  peek buf = do+    usbLow'  <- (peekByteOff buf 0 :: IO DDWORD)+    usbHigh' <- (peekByteOff buf (sizeOf (undefined :: DDWORD)) :: IO DDWORD)+    return $ UnicodeSubsetBitfield usbLow' usbHigh'+  poke buf info = do+    pokeByteOff buf 0 (usbLow info)+    pokeByteOff buf (sizeOf (undefined :: DDWORD)) (usbHigh info)++getLocaleInfoEx :: Maybe String -> LCTYPE -> IO LCData+getLocaleInfoEx locale ty+  | ty == lOCALE_FONTSIGNATURE =+      getLocaleInfoEx' LCSignatureData localSigCharCount++  | ty .&. lOCALE_RETURN_NUMBER /= 0 =+      getLocaleInfoEx' LCNumericData dWORDCharCount++  | otherwise = maybeWith withTString locale $ \c_locale ->+      LCTextualData <$> trySized cFuncName (c_GetLocaleInfoEx c_locale ty)+ where+  cFuncName = "GetLocaleInfoEx"+  -- See https://docs.microsoft.com/en-us/windows/win32/api/winnls/nf-winnls-getlocaleinfoex+  localSigCharCount = (#size LOCALESIGNATURE) `div` (#size WCHAR)+  dWORDCharCount = (#size DWORD) `div` (#size WCHAR)++  getLocaleInfoEx' constructor bufSize = maybeWith withTString locale $+    \c_locale -> do+      value <- alloca $ \buf -> do+        _ <- failIfZero cFuncName+          $ c_GetLocaleInfoEx c_locale ty (castPtr buf) bufSize+        peek buf+      return $ constructor value++foreign import WINDOWS_CCONV unsafe "windows.h GetLocaleInfoEx"+  c_GetLocaleInfoEx :: LPCWSTR -> LCTYPE -> LPWSTR -> CInt -> IO CInt+ setLocaleInfo :: LCID -> LCTYPE -> String -> IO () setLocaleInfo locale ty info =   withTString info $ \ c_info ->   failIfFalse_ "SetLocaleInfo" $ c_SetLocaleInfo locale ty c_info-foreign import stdcall unsafe "windows.h SetLocaleInfoW"+foreign import WINDOWS_CCONV unsafe "windows.h SetLocaleInfoW"   c_SetLocaleInfo :: LCID -> LCTYPE -> LPCTSTR -> IO Bool  type LCMapFlags = DWORD  #{enum LCMapFlags,- , lCMAP_BYTEREV        = LCMAP_BYTEREV- , lCMAP_FULLWIDTH      = LCMAP_FULLWIDTH- , lCMAP_HALFWIDTH      = LCMAP_HALFWIDTH- , lCMAP_HIRAGANA       = LCMAP_HIRAGANA- , lCMAP_KATAKANA       = LCMAP_KATAKANA- , lCMAP_LOWERCASE      = LCMAP_LOWERCASE- , lCMAP_SORTKEY        = LCMAP_SORTKEY- , lCMAP_UPPERCASE      = LCMAP_UPPERCASE- , nORM_IGNORECASE      = NORM_IGNORECASE- , nORM_IGNORENONSPACE  = NORM_IGNORENONSPACE- , nORM_IGNOREKANATYPE  = NORM_IGNOREKANATYPE- , nORM_IGNORESYMBOLS   = NORM_IGNORESYMBOLS- , nORM_IGNOREWIDTH     = NORM_IGNOREWIDTH- , sORT_STRINGSORT      = SORT_STRINGSORT- , lCMAP_LINGUISTIC_CASING      = LCMAP_LINGUISTIC_CASING- , lCMAP_SIMPLIFIED_CHINESE     = LCMAP_SIMPLIFIED_CHINESE- , lCMAP_TRADITIONAL_CHINESE    = LCMAP_TRADITIONAL_CHINESE+ , lCMAP_BYTEREV              = LCMAP_BYTEREV+ , lCMAP_FULLWIDTH            = LCMAP_FULLWIDTH+ , lCMAP_HALFWIDTH            = LCMAP_HALFWIDTH+ , lCMAP_HIRAGANA             = LCMAP_HIRAGANA+ , lCMAP_KATAKANA             = LCMAP_KATAKANA+ , lCMAP_LINGUISTIC_CASING    = LCMAP_LINGUISTIC_CASING+ , lCMAP_LOWERCASE            = LCMAP_LOWERCASE+ , lCMAP_SIMPLIFIED_CHINESE   = LCMAP_SIMPLIFIED_CHINESE+ , lCMAP_SORTKEY              = LCMAP_SORTKEY+ , lCMAP_TRADITIONAL_CHINESE  = LCMAP_TRADITIONAL_CHINESE+ , lCMAP_UPPERCASE            = LCMAP_UPPERCASE+ , lINGUISTIC_IGNORECASE      = LINGUISTIC_IGNORECASE+ , lINGUISTIC_IGNOREDIACRITIC = LINGUISTIC_IGNOREDIACRITIC+ , nORM_IGNORECASE            = NORM_IGNORECASE+ , nORM_IGNORENONSPACE        = NORM_IGNORENONSPACE+ , nORM_IGNOREKANATYPE        = NORM_IGNOREKANATYPE+ , nORM_IGNORESYMBOLS         = NORM_IGNORESYMBOLS+ , nORM_IGNOREWIDTH           = NORM_IGNOREWIDTH+ , nORM_LINGUISTIC_CASING     = NORM_LINGUISTIC_CASING+ , sORT_STRINGSORT            = SORT_STRINGSORT  } +data NLSVERSIONINFOEX = NLSVERSIONINFOEX+  { dwNLSVersionInfoSize :: DWORD+  , dwNLSVersion :: DWORD+  , dwDefinedVersion :: DWORD+  , dwEffectiveId :: DWORD+  , guidCustomVersion :: GUID+  } deriving (Eq, Show)++instance Storable NLSVERSIONINFOEX where+  sizeOf = const #{size NLSVERSIONINFOEX}+  alignment _ = #alignment NLSVERSIONINFOEX+  peek buf = do+    dwNLSVersionInfoSize' <- (#peek NLSVERSIONINFOEX, dwNLSVersionInfoSize) buf+    dwNLSVersion' <- (#peek NLSVERSIONINFOEX, dwNLSVersion) buf+    dwDefinedVersion' <- (#peek NLSVERSIONINFOEX, dwDefinedVersion) buf+    dwEffectiveId' <- (#peek NLSVERSIONINFOEX, dwEffectiveId) buf+    guidCustomVersion' <- (#peek NLSVERSIONINFOEX, guidCustomVersion) buf+    return $ NLSVERSIONINFOEX dwNLSVersionInfoSize' dwNLSVersion'+               dwDefinedVersion' dwEffectiveId' guidCustomVersion'+  poke buf info = do+    (#poke NLSVERSIONINFOEX, dwNLSVersionInfoSize) buf+      (dwNLSVersionInfoSize info)+    (#poke NLSVERSIONINFOEX, dwNLSVersion) buf (dwNLSVersion info)+    (#poke NLSVERSIONINFOEX, dwDefinedVersion) buf (dwDefinedVersion info)+    (#poke NLSVERSIONINFOEX, dwEffectiveId) buf (dwEffectiveId info)+    (#poke NLSVERSIONINFOEX, guidCustomVersion) buf (guidCustomVersion info)++-- Based on the `UnpackedUUID` type of package `uuid-types`.+data GUID = GUID+  !Word32+  !Word16+  !Word16+  !Word8+  !Word8+  !Word8+  !Word8+  !Word8+  !Word8+  !Word8+  !Word8+  deriving (Eq)++instance Show GUID where+  show (GUID data1 data2 data3 b1 b2 b3 b4 b5 b6 b7 b8) =+    printf "{%.8x-%.4x-%.4x-%.2x%2x-%.2x%.2x%.2x%.2x%.2x%.2x}" data1 data2 data3 b1 b2 b3 b4 b5 b6 b7 b8++instance Storable GUID where+  sizeOf _ = 16+  alignment _ = 4+  peekByteOff p off = GUID+    <$> peekByteOff p off+    <*> peekByteOff p (off + 4)+    <*> peekByteOff p (off + 6)+    <*> peekByteOff p (off + 8)+    <*> peekByteOff p (off + 9)+    <*> peekByteOff p (off + 10)+    <*> peekByteOff p (off + 11)+    <*> peekByteOff p (off + 12)+    <*> peekByteOff p (off + 13)+    <*> peekByteOff p (off + 14)+    <*> peekByteOff p (off + 15)+  pokeByteOff p off (GUID data1 data2 data3 b1 b2 b3 b4 b5 b6 b7 b8) = do+    pokeByteOff p off data1+    pokeByteOff p (off + 4) data2+    pokeByteOff p (off + 6) data3+    pokeByteOff p (off + 8) b1+    pokeByteOff p (off + 9) b2+    pokeByteOff p (off + 10) b3+    pokeByteOff p (off + 11) b4+    pokeByteOff p (off + 12) b5+    pokeByteOff p (off + 13) b6+    pokeByteOff p (off + 14) b7+    pokeByteOff p (off + 15) b8++getNLSVersionEx :: Maybe String -> IO NLSVERSIONINFOEX+getNLSVersionEx locale = maybeWith withTString locale $ \c_locale ->+  with defaultVersionInfo $ \c_versionInfo -> do+    failIfFalse_ "GetNLSVersionEx" $+      c_GetNLSVersionEx function c_locale c_versionInfo+    peek c_versionInfo+ where+  function = #{const COMPARE_STRING}+  defaultVersionInfo = NLSVERSIONINFOEX+    { dwNLSVersionInfoSize = #{size NLSVERSIONINFOEX}+    , dwNLSVersion = 0+    , dwDefinedVersion = 0+    , dwEffectiveId = 0+    , guidCustomVersion = GUID 0 0 0 0 0 0 0 0 0 0 0+    }+foreign import WINDOWS_CCONV unsafe "windows.h GetNLSVersionEx"+  c_GetNLSVersionEx :: NLS_FUNCTION+                    -> LPCWSTR+                    -> Ptr NLSVERSIONINFOEX+                    -> IO Bool++lCMapStringEx :: Maybe String+              -> LCMapFlags+              -> String+              -> NLSVERSIONINFOEX+              -> IO String+lCMapStringEx locale flags src versionInfo =+  maybeWith withTString locale $ \c_locale ->+    withTStringLen src $ \(c_src, src_len) ->+      with versionInfo $ \c_versionInfo -> do+        let c_src_len = fromIntegral src_len+            c_func s l = c_LCMapStringEx c_locale+                                         flags+                                         c_src c_src_len+                                         s l+                                         c_versionInfo+                                         nullPtr -- Reserved, must be NULL+                                         0 -- Reserved, must be 0+        trySized "LCMapStringEx" c_func+foreign import WINDOWS_CCONV unsafe "windows.h LCMapStringEx"+  c_LCMapStringEx :: LPCWSTR+                  -> LCMapFlags+                  -> LPCWSTR+                  -> CInt+                  -> LPWSTR+                  -> CInt+                  -> Ptr NLSVERSIONINFOEX+                  -> LPVOID+                  -> LPARAM+                  -> IO CInt+ lCMapString :: LCID -> LCMapFlags -> String -> Int -> IO String lCMapString locale flags src dest_size =   withTStringLen src $ \ (c_src, src_len) ->@@ -127,7 +489,7 @@   _ <- failIfZero "LCMapString" $     c_LCMapString locale flags c_src src_len c_dest dest_size   peekTString c_dest-foreign import stdcall unsafe "windows.h LCMapStringW"+foreign import WINDOWS_CCONV unsafe "windows.h LCMapStringW"   c_LCMapString :: LCID -> LCMapFlags -> LPCTSTR -> Int -> LPCTSTR -> Int -> IO Int  type LocaleTestFlags = DWORD@@ -137,28 +499,124 @@  , lCID_SUPPORTED       = LCID_SUPPORTED  } -foreign import stdcall unsafe "windows.h IsValidLocale"+isValidLocaleName :: Maybe String -> IO Bool+isValidLocaleName lpLocaleName =+  maybeWith withTString lpLocaleName c_IsValidLocaleName+foreign import WINDOWS_CCONV unsafe "windows.h IsValidLocaleName"+  c_IsValidLocaleName :: LPCWSTR -> IO Bool++foreign import WINDOWS_CCONV unsafe "windows.h IsValidLocale"   isValidLocale :: LCID -> LocaleTestFlags -> IO Bool -foreign import stdcall unsafe "windows.h IsValidCodePage"+type EnumLocalesFlag = DWORD++-- The following locale enumeration flag constants are excluded from the `enum`+-- list below, for the reason indicated:+-- LOCALE_NEUTRALDATA -- Introduced in Windows 7 but not supported.++#{enum EnumLocalesFlag,+ , lOCALE_ALL             = LOCALE_ALL+ , lOCALE_ALTERNATE_SORTS = LOCALE_ALTERNATE_SORTS+ , lOCALE_REPLACEMENT     = LOCALE_REPLACEMENT+ , lOCALE_SUPPLEMENTAL    = LOCALE_SUPPLEMENTAL+ , lOCALE_WINDOWS         = LOCALE_WINDOWS+ }++type LOCALE_ENUMPROCEX = LPWSTR -> EnumLocalesFlag -> LPARAM -> IO BOOL+foreign import WINDOWS_CCONV "wrapper"+  mkLOCALE_ENUMPROCEX :: LOCALE_ENUMPROCEX -> IO (FunPtr LOCALE_ENUMPROCEX)++enumSystemLocalesEx :: LOCALE_ENUMPROCEX -> EnumLocalesFlag -> LPARAM -> IO ()+enumSystemLocalesEx callback dwFlags lParam = do+  c_callback <- mkLOCALE_ENUMPROCEX callback+  failIfFalse_ "EnumSystemLocalesEx" $+    c_EnumSystemLocalesEx c_callback dwFlags lParam nullPtr+  freeHaskellFunPtr c_callback+foreign import WINDOWS_CCONV safe "windows.h EnumSystemLocalesEx"+  c_EnumSystemLocalesEx :: (FunPtr LOCALE_ENUMPROCEX)+                        -> DWORD+                        -> LPARAM+                        -> LPVOID+                        -> IO Bool++enumSystemLocalesEx' :: EnumLocalesFlag+                     -> Maybe Bool+                     -- ^ Maybe include (or exclude) replacement locales?+                     -> IO [String]+enumSystemLocalesEx' dwFlags mIsReplacement = do+  store <- newIORef []+  let localeEnumProcEx c_locale arg2 _ = do+        locale <- peekTString c_locale+        case mIsReplacement of+          Nothing -> modifyIORef store (locale:)+          Just isReplacement ->+            when (isReplacement == (arg2 .&. lOCALE_REPLACEMENT /= 0)) $+              modifyIORef store (locale:)+        return True+  enumSystemLocalesEx localeEnumProcEx dwFlags 0+  reverse <$> readIORef store++foreign import WINDOWS_CCONV unsafe "windows.h IsValidCodePage"   isValidCodePage :: CodePage -> IO Bool -foreign import stdcall unsafe "windows.h GetUserDefaultLCID"+foreign import WINDOWS_CCONV unsafe "windows.h GetUserDefaultLCID"   getUserDefaultLCID :: LCID -foreign import stdcall unsafe "windows.h GetUserDefaultLangID"+foreign import WINDOWS_CCONV unsafe "windows.h GetUserDefaultLangID"   getUserDefaultLangID :: LANGID -foreign import stdcall unsafe "windows.h GetThreadLocale"+-- #define LOCALE_NAME_INVARIANT L""+lOCALE_NAME_INVARIANT :: Maybe String+lOCALE_NAME_INVARIANT = Just ""++ -- #define LOCALE_NAME_SYSTEM_DEFAULT L"!x-sys-default-locale"+lOCALE_NAME_SYSTEM_DEFAULT :: Maybe String+lOCALE_NAME_SYSTEM_DEFAULT = Just "!x-sys-default-locale"++ -- #define LOCALE_NAME_USER_DEFAULT NULL+lOCALE_NAME_USER_DEFAULT :: Maybe String+lOCALE_NAME_USER_DEFAULT = Nothing++getUserDefaultLocaleName :: IO String+getUserDefaultLocaleName =+  getDefaultLocaleName "GetUserDefaultLocaleName" c_GetUserDefaultLocaleName+foreign import WINDOWS_CCONV unsafe "windows.h GetUserDefaultLocaleName"+  c_GetUserDefaultLocaleName :: LPWSTR -> CInt -> IO CInt++#{enum CInt,+ , lOCALE_NAME_MAX_LENGTH = LOCALE_NAME_MAX_LENGTH+ }++-- |Helper function for use with 'c_GetUserDefaultLocaleName' or+-- 'c_GetSystemDefaultLocaleName'. See 'getUserDefaultLocaleName' and+-- 'getSystemUserDefaultLocaleName'.+getDefaultLocaleName :: String -> (LPWSTR -> CInt -> IO CInt) -> IO String+getDefaultLocaleName cDefaultLocaleFuncName cDefaultLocaleFunc =+  withTStringBufferLen maxLength $ \(buf, len) -> do+    let c_len = fromIntegral len+    c_len' <- failIfZero cDefaultLocaleFuncName $+      cDefaultLocaleFunc buf c_len+    let len' = fromIntegral c_len'+    peekTStringLen (buf, len' - 1) -- Drop final null character+ where+  maxLength = fromIntegral lOCALE_NAME_MAX_LENGTH++foreign import WINDOWS_CCONV unsafe "windows.h GetThreadLocale"   getThreadLocale :: IO LCID -foreign import stdcall unsafe "windows.h GetSystemDefaultLCID"+foreign import WINDOWS_CCONV unsafe "windows.h GetSystemDefaultLCID"   getSystemDefaultLCID :: LCID -foreign import stdcall unsafe "windows.h GetSystemDefaultLangID"+foreign import WINDOWS_CCONV unsafe "windows.h GetSystemDefaultLangID"   getSystemDefaultLangID :: LANGID -foreign import stdcall unsafe "windows.h GetOEMCP"+getSystemDefaultLocaleName :: IO String+getSystemDefaultLocaleName =+  getDefaultLocaleName "GetSystemDefaultLocaleName" c_GetSystemDefaultLocaleName+foreign import WINDOWS_CCONV unsafe "windows.h GetSystemDefaultLocaleName"+  c_GetSystemDefaultLocaleName :: LPWSTR -> CInt -> IO CInt++foreign import WINDOWS_CCONV unsafe "windows.h GetOEMCP"   getOEMCP :: CodePage  #{enum PrimaryLANGID,@@ -343,9 +801,9 @@  -- ---------------------------------------------------------------------------- --- | The `System.IO` input functions (e.g. `getLine`) don't+-- | 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 +-- 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 `getConsoleCP`. @@ -354,7 +812,7 @@      -- MultiByteToWideChar doesn't handle empty strings (#1929) stringToUnicode cp mbstr =   withCAStringLen mbstr $ \(cstr,len) -> do-    wchars <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar +    wchars <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar                 cp                 0                 cstr@@ -362,15 +820,15 @@                 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 stdcall unsafe "MultiByteToWideChar"+foreign import WINDOWS_CCONV unsafe "MultiByteToWideChar"   multiByteToWideChar         :: CodePage         -> DWORD   -- dwFlags,

+ System/Win32/NamedPipes.hsc view

@@ -0,0 +1,276 @@+#include <fcntl.h>+#include <windows.h>++#include "namedpipeapi_compat.h"++{-# LANGUAGE CPP                #-}+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE MultiWayIf         #-}++-- | For full details on the Windows named pipes API see+-- <https://docs.microsoft.com/en-us/windows/desktop/ipc/named-pipes>+--+module System.Win32.NamedPipes (++    -- * Named pipe server APIs+    createNamedPipe,+    pIPE_UNLIMITED_INSTANCES,++    -- ** Parameter types+    LPSECURITY_ATTRIBUTES,+    OpenMode,+    pIPE_ACCESS_DUPLEX,+    pIPE_ACCESS_INBOUND,+    pIPE_ACCESS_OUTBOUND,+    fILE_FLAG_OVERLAPPED,+    PipeMode,+    pIPE_TYPE_BYTE,+    pIPE_TYPE_MESSAGE,+    pIPE_READMODE_BYTE,+    pIPE_READMODE_MESSAGE,+    pIPE_WAIT,+    pIPE_NOWAIT,+    pIPE_ACCEPT_REMOTE_CLIENTS,+    pIPE_REJECT_REMOTE_CLIENTS,++    -- * Named pipe client APIs+    -- ** connect to a named pipe+    connect,++    -- ** waiting for named pipe instances+    waitNamedPipe,++    TimeOut,+    nMPWAIT_USE_DEFAULT_WAIT,+    nMPWAIT_WAIT_FOREVER,+  ) where+++import Control.Exception+import Control.Monad (when)+import Foreign.C.String (withCString)++import System.Win32.Types hiding (try)+import System.Win32.File++-- | The named pipe open mode.+--+-- This must specify one of:+--+-- * 'pIPE_ACCESS_DUPLEX'+-- * 'pIPE_ACCESS_INBOUND'+-- * 'pIPE_ACCESS_OUTBOUND'+--+-- It may also specify:+--+-- * 'fILE_FLAG_WRITE_THROUGH'+-- * 'fILE_FLAG_OVERLAPPED'+--+-- It may also specify any combination of:+--+-- * 'wRITE_DAC'+-- * 'wRITE_OWNER'+-- * 'aCCESS_SYSTEM_SECURITY'+--+type OpenMode = UINT++#{enum OpenMode,+ , pIPE_ACCESS_DUPLEX            = PIPE_ACCESS_DUPLEX+ , pIPE_ACCESS_INBOUND           = PIPE_ACCESS_INBOUND+ , pIPE_ACCESS_OUTBOUND          = PIPE_ACCESS_OUTBOUND+ }++-- | The pipe mode.+--+-- One of the following type modes can be specified. The same type mode must be+-- specified for each instance of the pipe.+--+-- * 'pIPE_TYPE_BYTE'+-- * 'pIPE_TYPE_MESSAGE'+--+-- One of the following read modes can be specified. Different instances of the+-- same pipe can specify different read modes.+--+-- * 'pIPE_READMODE_BYTE'+-- * 'pIPE_READMODE_MESSAGE'+--+-- One of the following wait modes can be specified. Different instances of the+-- same pipe can specify different wait modes.+--+-- * 'pIPE_WAIT'+-- * 'pIPE_NOWAIT'+--+-- One of the following remote-client modes can be specified.  Different+-- instances of the same pipe can specify different remote-client modes.+--+-- * 'pIPE_ACCEPT_REMOTE_CLIENT'+-- * 'pIPE_REJECT_REMOTE_CLIENT'+--+type PipeMode = UINT++#{enum PipeMode,+ , pIPE_TYPE_BYTE                = PIPE_TYPE_BYTE+ , pIPE_TYPE_MESSAGE             = PIPE_TYPE_MESSAGE+ , pIPE_READMODE_BYTE            = PIPE_READMODE_BYTE+ , pIPE_READMODE_MESSAGE         = PIPE_READMODE_MESSAGE+ , pIPE_WAIT                     = PIPE_WAIT+ , pIPE_NOWAIT                   = PIPE_NOWAIT+ , pIPE_ACCEPT_REMOTE_CLIENTS    = PIPE_ACCEPT_REMOTE_CLIENTS+ , pIPE_REJECT_REMOTE_CLIENTS    = PIPE_REJECT_REMOTE_CLIENTS+ }++-- | If the 'createNamedPipe' @nMaxInstances@ parameter is+-- 'pIPE_UNLIMITED_INSTANCES', the number of pipe instances that can be created+-- is limited only by the availability of system resources.+pIPE_UNLIMITED_INSTANCES :: DWORD+pIPE_UNLIMITED_INSTANCES = #const PIPE_UNLIMITED_INSTANCES++-- | Creates an instance of a named pipe and returns a handle for subsequent+-- pipe operations. A named pipe server process uses this function either to+-- create the first instance of a specific named pipe and establish its basic+-- attributes or to create a new instance of an existing named pipe.+--+-- For full details see+-- <https://docs.microsoft.com/en-us/windows/desktop/api/winbase/nf-winbase-createnamedpipea>+--+-- To create a named pipe which can be associate with IO completion port on+-- needs to pass 'fILE_FLAG_OVERLAPPED' to 'OpenMode' argument,+-- e.g.+--+-- >  Win32.createNamedPipe pipeName+-- >                        (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED)+-- >                        (pIPE_TYPE_BYTE .|. pIPE_READMODE_BYTE)+-- >                        pIPE_UNLIMITED_INSTANCES+-- >                        512+-- >                        512+-- >                        0+-- >                        NothinROR+--+--+createNamedPipe :: String   -- ^ A unique pipe name of the form @\\\\.\\pipe\\{pipename}@+                            -- The `pipename` part of the name can include any+                            -- character other than a backslash, including+                            -- numbers and special characters. The entire pipe+                            -- name string can be up to 256 characters long.+                            -- Pipe names are not case sensitive.+                -> OpenMode+                -> PipeMode+                -> DWORD    -- ^ nMaxInstances+                -> DWORD    -- ^ nOutBufferSize+                -> DWORD    -- ^ nInBufferSize+                -> DWORD    -- ^ nDefaultTimeOut+                -> Maybe LPSECURITY_ATTRIBUTES+                -> IO HANDLE+createNamedPipe name openMode pipeMode+                nMaxInstances nOutBufferSize nInBufferSize+                nDefaultTimeOut mb_attr =+  withTString name $ \ c_name ->+    failIf (==iNVALID_HANDLE_VALUE) ("CreateNamedPipe ('" ++ name ++ "')") $+      c_CreateNamedPipe c_name openMode pipeMode+                        nMaxInstances nOutBufferSize nInBufferSize+                        nDefaultTimeOut (maybePtr mb_attr)++foreign import ccall unsafe "windows.h CreateNamedPipeW"+  c_CreateNamedPipe :: LPCTSTR+                    -> DWORD+                    -> DWORD+                    -> DWORD+                    -> DWORD+                    -> DWORD+                    -> DWORD+                    -> LPSECURITY_ATTRIBUTES+                    -> IO HANDLE+++-- | Timeout in milliseconds.+--+-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to+--   'createNamedPipe' should be used.+-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named+--   pipe instance is available.+--+type TimeOut = DWORD+#{enum TimeOut,+ , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT+ , nMPWAIT_WAIT_FOREVER     = NMPWAIT_WAIT_FOREVER+ }+++-- | Wait until a named pipe instance is available.  If there is no instance at+-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e.+-- @invalid argument (The semaphore timeout period has expired)@+--+-- It returns 'True' if there is an available instance, subsequent 'createFile'+-- might still fail, if another thread will take turn and connect before, or if+-- the other end shuts down the name pipe.+--+-- It returns 'False' if timeout fired.+--+waitNamedPipe :: String  -- ^ pipe name+              -> TimeOut -- ^ nTimeOut+              -> IO Bool+waitNamedPipe name timeout =+    withCString name $ \ c_name -> do+      r <- c_WaitNamedPipe c_name timeout+      e <- getLastError+      if | r                      -> pure r+         | e == eRROR_SEM_TIMEOUT -> pure False+         | otherwise              -> failWith "waitNamedPipe" e+++-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import.+foreign import ccall safe "windows.h WaitNamedPipeA"+  c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName+                  -> DWORD  -- nTimeOut+                  -> IO BOOL++-- | A reliable connect call, as designed in+-- <https://docs.microsoft.com/en-us/windows/win32/ipc/named-pipe-client>+--+-- The arguments are passed directly to 'createFile'.+--+-- Note we pick the more familiar posix naming convention, do not confuse this+-- function with 'connectNamedPipe' (which corresponds to posix 'accept')+--+connect :: String                      -- ^ file name+        -> AccessMode                  -- ^ dwDesiredAccess+        -> ShareMode                   -- ^ dwSharedMode+        -> Maybe LPSECURITY_ATTRIBUTES -- ^ lpSecurityAttributes+        -> CreateMode                  -- ^ dwCreationDisposition+        -> FileAttributeOrFlag         -- ^ dwFlagsAndAttributes+        -> Maybe HANDLE                -- ^ hTemplateFile+        -> IO HANDLE+connect fileName dwDesiredAccess dwSharedMode lpSecurityAttributes dwCreationDisposition dwFlagsAndAttributes hTemplateFile = connectLoop+  where+    connectLoop = do+      -- `createFile` checks for `INVALID_HANDLE_VALUE` and retries if this is+      -- caused by `ERROR_SHARING_VIOLATION`.+      mh <- try $+              createFile fileName+                         dwDesiredAccess+                         dwSharedMode+                         lpSecurityAttributes+                         dwCreationDisposition+                         dwFlagsAndAttributes+                         hTemplateFile+      case mh :: Either IOException HANDLE of+        Left e -> do+          errorCode <- getLastError+          when (errorCode /= eRROR_PIPE_BUSY)+            $ throwIO e+          -- all pipe instance were busy, wait 20s and retry; we ignore the+          -- result+          _ <- waitNamedPipe fileName 5000+          connectLoop++        Right h -> pure h+++-- | [ERROR_PIPE_BUSY](https://docs.microsoft.com/en-us/windows/win32/debug/system-error-codes--0-499-#ERROR_PIPE_BUSY):+-- all pipe instances are busy.+--+eRROR_PIPE_BUSY :: ErrCode+eRROR_PIPE_BUSY = #const ERROR_PIPE_BUSY++eRROR_SEM_TIMEOUT :: ErrCode+eRROR_SEM_TIMEOUT = #const ERROR_SEM_TIMEOUT

+ System/Win32/Path.hsc view

@@ -0,0 +1,56 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.Path+-- Copyright   :  (c) Tamar Christina, 1997-2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  Tamar Christina <tamar@zhox.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.Path (+   filepathRelativePathTo+ , pathRelativePathTo+ ) where++import System.Win32.Path.Internal+import System.Win32.Types+import System.Win32.File++import Foreign++##include "windows_cconv.h"++#include <windows.h>++filepathRelativePathTo :: FilePath -> FilePath -> IO FilePath+filepathRelativePathTo from to =+  withTString from $ \p_from ->+  withTString to   $ \p_to   ->+  allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do+    _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from fILE_ATTRIBUTE_DIRECTORY+                                                                         p_to   fILE_ATTRIBUTE_NORMAL)+    path <- peekTString p_AbsPath+    _ <- localFree p_AbsPath+    return path++pathRelativePathTo :: FilePath -> FileAttributeOrFlag -> FilePath -> FileAttributeOrFlag -> IO FilePath+pathRelativePathTo from from_attr to to_attr =+  withTString from $ \p_from ->+  withTString to   $ \p_to   ->+  allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do+    _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from from_attr+                                                                         p_to   to_attr)+    path <- peekTString p_AbsPath+    _ <- localFree p_AbsPath+    return path+

+ System/Win32/Path/Internal.hsc view

@@ -0,0 +1,29 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.Path.Internal+-- Copyright   :  (c) Tamar Christina, 1997-2003+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  Tamar Christina <tamar@zhox.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.Path.Internal where++import System.Win32.Types++##include "windows_cconv.h"++#include <windows.h>++foreign import WINDOWS_CCONV unsafe "Shlwapi.h PathRelativePathToW"+         c_pathRelativePathTo :: LPTSTR -> LPCTSTR -> DWORD -> LPCTSTR -> DWORD -> IO UINT

System/Win32/Process.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -15,25 +17,71 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Process where-import Control.Exception    ( bracket )-import Control.Monad        ( liftM5 )-import Foreign              ( Ptr, peekByteOff, allocaBytes, pokeByteOff-                            , plusPtr )-import System.Win32.File    ( closeHandle )+module System.Win32.Process+    ( -- * Sleeping+      iNFINITE+    , sleep+      -- * Processes pperations+    , ProcessId+    , ProcessHandle+    , ProcessAccessRights+    , pROCESS_ALL_ACCESS+    , pROCESS_CREATE_PROCESS+    , pROCESS_CREATE_THREAD+    , pROCESS_DUP_HANDLE+    , pROCESS_QUERY_INFORMATION+    , pROCESS_SET_QUOTA+    , pROCESS_SET_INFORMATION+    , pROCESS_TERMINATE+    , pROCESS_VM_OPERATION+    , pROCESS_VM_READ+    , pROCESS_VM_WRITE+    , openProcess+    , getProcessId+    , getCurrentProcessId+    , getCurrentProcess+      -- * Terminating+    , terminateProcessById+      -- * Toolhelp32+    , Th32SnapHandle+    , Th32SnapFlags+    , tH32CS_SNAPALL+    , tH32CS_SNAPHEAPLIST+    , tH32CS_SNAPMODULE+    , tH32CS_SNAPMODULE32+    , tH32CS_SNAPMODULE64+    , tH32CS_SNAPPROCESS+    , tH32CS_SNAPTHREAD+    , ProcessEntry32+    , ModuleEntry32+    , createToolhelp32Snapshot+    , withTh32Snap+    , th32SnapEnumProcesses+    , th32SnapEnumModules+    ) where++import Control.Exception     ( bracket )+import Control.Monad         ( liftM5 )+import Foreign               ( Ptr, peekByteOff, allocaBytes, pokeByteOff+                             , plusPtr )+import Foreign.C.Types       ( CUInt(..) )+import System.Win32.File     ( closeHandle )+import System.Win32.DebugApi ( ForeignAddress ) import System.Win32.Types +##include "windows_cconv.h"+ #include <windows.h> #include <tlhelp32.h>+#include "tlhelp32_compat.h"  -- constant to wait for a very long time. iNFINITE :: DWORD iNFINITE = #{const INFINITE} -foreign import stdcall unsafe "windows.h Sleep"+foreign import WINDOWS_CCONV unsafe "windows.h Sleep"   sleep :: DWORD -> IO () - type ProcessId = DWORD type ProcessHandle = HANDLE type ProcessAccessRights = DWORD@@ -49,48 +97,76 @@     , pROCESS_VM_OPERATION          = PROCESS_VM_OPERATION     , pROCESS_VM_READ               = PROCESS_VM_READ     , pROCESS_VM_WRITE              = PROCESS_VM_WRITE-    , sYNCHORNIZE                   = SYNCHRONIZE      } -foreign import stdcall unsafe "windows.h OpenProcess"+foreign import WINDOWS_CCONV unsafe "windows.h OpenProcess"     c_OpenProcess :: ProcessAccessRights -> BOOL -> ProcessId -> IO ProcessHandle - openProcess :: ProcessAccessRights -> BOOL -> ProcessId -> IO ProcessHandle openProcess r inh i = failIfNull "OpenProcess" $ c_OpenProcess r inh i -foreign import stdcall unsafe "windows.h GetProcessId"+foreign import WINDOWS_CCONV unsafe "windows.h GetProcessId"     c_GetProcessId :: ProcessHandle -> IO ProcessId  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++foreign import WINDOWS_CCONV unsafe "windows.h TerminateProcess"+    c_TerminateProcess :: ProcessHandle -> CUInt -> IO Bool++terminateProcessById :: ProcessId -> IO ()+terminateProcessById p = bracket+    (openProcess pROCESS_TERMINATE False p)+    closeHandle+    (\h -> failIfFalse_ "TerminateProcess" $ c_TerminateProcess h 1)+ type Th32SnapHandle = HANDLE type Th32SnapFlags = DWORD -- | ProcessId, number of threads, parent ProcessId, process base priority, path of executable file type ProcessEntry32 = (ProcessId, Int, ProcessId, LONG, String)+type ModuleEntry32 = (ForeignAddress, Int, HMODULE, String, String)  #{enum Th32SnapFlags,     , tH32CS_SNAPALL        = TH32CS_SNAPALL     , tH32CS_SNAPHEAPLIST   = TH32CS_SNAPHEAPLIST     , tH32CS_SNAPMODULE     = TH32CS_SNAPMODULE+    , tH32CS_SNAPMODULE32   = TH32CS_SNAPMODULE32+    , tH32CS_SNAPMODULE64   = (TH32CS_SNAPMODULE | TH32CS_SNAPMODULE32)     , tH32CS_SNAPPROCESS    = TH32CS_SNAPPROCESS     , tH32CS_SNAPTHREAD     = TH32CS_SNAPTHREAD     } {-     , tH32CS_SNAPGETALLMODS = TH32CS_GETALLMODS-    , tH32CS_SNAPNOHEAPS    = TH32CS_SNAPNOHEAPS +    , tH32CS_SNAPNOHEAPS    = TH32CS_SNAPNOHEAPS -} -foreign import stdcall unsafe "tlhelp32.h CreateToolhelp32Snapshot"+foreign import WINDOWS_CCONV unsafe "tlhelp32.h CreateToolhelp32Snapshot"     c_CreateToolhelp32Snapshot :: Th32SnapFlags -> ProcessId -> IO Th32SnapHandle -foreign import stdcall unsafe "tlhelp32.h Process32FirstW"+foreign import WINDOWS_CCONV unsafe "tlhelp32.h Process32FirstW"     c_Process32First :: Th32SnapHandle -> Ptr ProcessEntry32 -> IO BOOL -foreign import stdcall unsafe "tlhelp32.h Process32NextW"+foreign import WINDOWS_CCONV unsafe "tlhelp32.h Process32NextW"     c_Process32Next :: Th32SnapHandle -> Ptr ProcessEntry32 -> IO BOOL +foreign import WINDOWS_CCONV unsafe "tlhelp32.h Module32FirstW"+    c_Module32First :: Th32SnapHandle -> Ptr ModuleEntry32 -> IO BOOL++foreign import WINDOWS_CCONV unsafe "tlhelp32.h Module32NextW"+    c_Module32Next :: Th32SnapHandle -> Ptr ModuleEntry32 -> IO BOOL+ -- | Create a snapshot of specified resources.  Call closeHandle to close snapshot. createToolhelp32Snapshot :: Th32SnapFlags -> Maybe ProcessId -> IO Th32SnapHandle createToolhelp32Snapshot f p@@ -100,19 +176,26 @@ withTh32Snap :: Th32SnapFlags -> Maybe ProcessId -> (Th32SnapHandle -> IO a) -> IO a withTh32Snap f p = bracket (createToolhelp32Snapshot f p) (closeHandle) - peekProcessEntry32 :: Ptr ProcessEntry32 -> IO ProcessEntry32 peekProcessEntry32 buf = liftM5 (,,,,)-    ((#peek PROCESSENTRY32, th32ProcessID) buf)-    ((#peek PROCESSENTRY32, cntThreads) buf)-    ((#peek PROCESSENTRY32, th32ParentProcessID) buf)-    ((#peek PROCESSENTRY32, pcPriClassBase) buf)-    (peekTString $ (#ptr PROCESSENTRY32, szExeFile) buf)+    ((#peek PROCESSENTRY32W, th32ProcessID) buf)+    ((#peek PROCESSENTRY32W, cntThreads) buf)+    ((#peek PROCESSENTRY32W, th32ParentProcessID) buf)+    ((#peek PROCESSENTRY32W, pcPriClassBase) buf)+    (peekTString $ (#ptr PROCESSENTRY32W, szExeFile) buf) +peekModuleEntry32 :: Ptr ModuleEntry32 -> IO ModuleEntry32+peekModuleEntry32 buf = liftM5 (,,,,)+    ((#peek MODULEENTRY32W, modBaseAddr) buf)+    ((#peek MODULEENTRY32W, modBaseSize) buf)+    ((#peek MODULEENTRY32W, hModule) buf)+    (peekTString $ (#ptr MODULEENTRY32W, szModule) buf)+    (peekTString $ (#ptr MODULEENTRY32W, szExePath) buf)+ -- | Enumerate processes using Process32First and Process32Next th32SnapEnumProcesses :: Th32SnapHandle -> IO [ProcessEntry32]-th32SnapEnumProcesses h = allocaBytes (#size PROCESSENTRY32) $ \pe -> do-    (#poke PROCESSENTRY32, dwSize) pe ((#size PROCESSENTRY32)::DWORD)+th32SnapEnumProcesses h = allocaBytes (#size PROCESSENTRY32W) $ \pe -> do+    (#poke PROCESSENTRY32W, dwSize) pe ((#size PROCESSENTRY32W)::DWORD)     ok <- c_Process32First h pe     readAndNext ok pe []     where@@ -125,4 +208,22 @@             | otherwise = do                 entry <- peekProcessEntry32 pe                 ok' <- c_Process32Next h pe+                readAndNext ok' pe (entry:res)++-- | Enumerate modules using Module32First and Module32Next+th32SnapEnumModules :: Th32SnapHandle -> IO [ModuleEntry32]+th32SnapEnumModules h = allocaBytes (#size MODULEENTRY32W) $ \pe -> do+    (#poke MODULEENTRY32W, dwSize) pe ((#size MODULEENTRY32W)::DWORD)+    ok <- c_Module32First h pe+    readAndNext ok pe []+    where+        readAndNext ok pe res+            | not ok    = do+                err <- getLastError+                if err == (#const ERROR_NO_MORE_FILES)+                    then return $ reverse res+                    else failWith "th32SnapEnumModules: Module32First/Module32Next" err+            | otherwise = do+                entry <- peekModuleEntry32 pe+                ok' <- c_Module32Next h pe                 readAndNext ok' pe (entry:res)

System/Win32/Registry.hsc view

@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Win32.Registry@@ -16,42 +14,103 @@ -----------------------------------------------------------------------------  module System.Win32.Registry-		( module System.Win32.Registry-		) where-{- What's really on offer:-	(-	  regCloseKey        -- :: HKEY -> IO ()-	, regConnectRegistry -- :: Maybe String -> HKEY -> IO HKEY-	, regCreateKey       -- :: HKEY -> String -> IO HKEY-	, regCreateKeyEx     -- :: HKEY -> String -> String-	                     -- -> RegCreateOptions -> REGSAM-			     -- -> Maybe LPSECURITY_ATTRIBUTES-			     -- -> IO (HKEY, Bool)-        , regDeleteKey       -- :: HKEY -> String -> IO ()-	, regDeleteValue     -- :: HKEY -> String -> IO ()-	, regEnumKeys	     -- :: HKEY -> IO [String]-	, regEnumKey 	     -- :: HKEY -> DWORD -> Addr -> DWORD -> IO String-	, regEnumKeyValue    -- :: HKEY -> DWORD -> Addr -> DWORD -> Addr -> DWORD -> IO String-	, regFlushKey        -- :: HKEY -> IO ()-	, regLoadKey         -- :: HKEY -> String -> String -> IO ()-	, regNotifyChangeKeyValue -- :: HKEY -> Bool -> RegNotifyOptions-				  -- -> HANDLE -> Bool -> IO ()-	, regOpenKey         -- :: HKEY -> String -> IO HKEY-	, regOpenKeyEx 	     -- :: HKEY -> String -> REGSAM -> IO HKEY-	, regQueryInfoKey    -- :: HKEY -> IO RegInfoKey-	, regQueryValue      -- :: HKEY -> Maybe String -> IO String-	, regQueryValueKey   -- :: HKEY -> Maybe String -> IO String-	, regQueryValueEx    -- :: HKEY -> String -> Addr -> Int -> IO RegValueType-	, regReplaceKey      -- :: HKEY -> String -> String -> String -> IO ()-	, regRestoreKey      -- :: HKEY -> String -> RegRestoreFlags -> IO ()-	, regSaveKey         -- :: HKEY -> String -> Maybe LPSECURITY_ATTRIBUTES -> IO ()-	, regSetValue        -- :: HKEY -> String -> String -> IO ()-	, regSetValueEx      -- :: HKEY -> String -> RegValueType -> LPTSTR -> Int -> IO ()-	, regSetStringValue  -- :: HKEY -> String -> String -> IO ()-	, regUnloadKey       -- :: HKEY -> String -> IO ()-	) where--}+    (+      -- * HKEY+      HKEY+    , hKEY_CLASSES_ROOT+    , hKEY_CURRENT_CONFIG+    , hKEY_CURRENT_USER+    , hKEY_LOCAL_MACHINE+    , hKEY_USERS +      -- * Creation options+    , RegCreateOptions+    , rEG_OPTION_NON_VOLATILE+    , rEG_OPTION_VOLATILE++      -- * REGSAM+    , REGSAM+    , kEY_ALL_ACCESS+    , kEY_CREATE_LINK+    , kEY_CREATE_SUB_KEY+    , kEY_ENUMERATE_SUB_KEYS+    , kEY_EXECUTE+    , kEY_NOTIFY+    , kEY_QUERY_VALUE+    , kEY_READ+    , kEY_SET_VALUE+    , kEY_WRITE++      -- * Registry operations+    , regCloseKey+    , regConnectRegistry+    , regCreateKey+    , regCreateKeyEx+    , regDeleteKey+    , regDeleteValue+    , regEnumKeys+    , regEnumKeyVals+    , regEnumKey+    , regEnumValue+    , regFlushKey+    , regLoadKey+    , regUnLoadKey+    , regNotifyChangeKeyValue+    , RegNotifyOptions+    , rEG_NOTIFY_CHANGE_NAME+    , rEG_NOTIFY_CHANGE_ATTRIBUTES+    , rEG_NOTIFY_CHANGE_LAST_SET+    , rEG_NOTIFY_CHANGE_SECURITY++    , regOpenKey+    , regOpenKeyEx+    , regQueryInfoKey+    , RegInfoKey(..)+    , regQueryValue+    , regQueryValueKey+    , regQueryDefaultValue+    , regQueryValueEx+    , regReplaceKey+    , RegRestoreFlags+    , rEG_WHOLE_HIVE_VOLATILE+    , rEG_REFRESH_HIVE+    , rEG_NO_LAZY_FLUSH+    , regRestoreKey+    , regSaveKey+    , regGetValue+    , RegTypeRestriction+    , rRF_RT_ANY+    , rRF_RT_DWORD+    , rRF_RT_QWORD+    , rRF_RT_REG_BINARY+    , rRF_RT_REG_DWORD+    , rRF_RT_REG_EXPAND_SZ+    , rRF_RT_REG_MULTI_SZ+    , rRF_RT_REG_NONE+    , rRF_RT_REG_QWORD+    , rRF_RT_REG_SZ+    , rRF_NOEXPAND+    , rRF_ZEROONFAILURE+    , rRF_SUBKEY_WOW6464KEY+    , rRF_SUBKEY_WOW6432KEY++    , regSetValue+    , regSetValueEx+    , RegValueType+    , rEG_BINARY+    , rEG_DWORD+    , rEG_DWORD_LITTLE_ENDIAN+    , rEG_DWORD_BIG_ENDIAN+    , rEG_EXPAND_SZ+    , rEG_LINK+    , rEG_MULTI_SZ+    , rEG_NONE+    , rEG_RESOURCE_LIST+    , rEG_SZ++    , regSetStringValue  -- :: HKEY -> String -> String -> IO ()+    ) where+ {-  Registry API omissions: @@ -60,21 +119,32 @@  -} -import System.Win32.Time-import System.Win32.Types-import System.Win32.File+import Data.Word (Word32)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Alloc (alloca, allocaBytes, free, mallocBytes)+import Foreign.Marshal.Array (allocaArray0)+import Foreign.Marshal.Utils (maybeWith, with)+import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Foreign.Storable (peek, peekByteOff, peekElemOff, sizeOf)+import System.IO.Unsafe (unsafePerformIO)+import System.Win32.File (LPSECURITY_ATTRIBUTES)+import System.Win32.Time (FILETIME)+import System.Win32.Types (DWORD, ErrCode, HKEY, LPCTSTR, PKEY, withTString)+import System.Win32.Types (HANDLE, LONG, LPBYTE, newForeignHANDLE, peekTString)+import System.Win32.Types (LPTSTR, TCHAR, LPDWORD, LPVOID, failUnlessSuccess)+import System.Win32.Types (castUINTPtrToPtr, failUnlessSuccessOr, maybePtr) -import System.IO.Unsafe-import Foreign hiding (unsafePerformIO)+##include "windows_cconv.h"  #include <windows.h>+#include "winreg_compat.h" -#{enum HKEY, (unsafePerformIO . newForeignHANDLE . castUINTToPtr)- , hKEY_CLASSES_ROOT    = (UINT)HKEY_CLASSES_ROOT- , hKEY_CURRENT_CONFIG  = (UINT)HKEY_CURRENT_CONFIG- , hKEY_CURRENT_USER    = (UINT)HKEY_CURRENT_USER- , hKEY_LOCAL_MACHINE   = (UINT)HKEY_LOCAL_MACHINE- , hKEY_USERS           = (UINT)HKEY_USERS+#{enum HKEY, (unsafePerformIO . newForeignHANDLE . castUINTPtrToPtr)+ , hKEY_CLASSES_ROOT    = (UINT_PTR)HKEY_CLASSES_ROOT+ , hKEY_CURRENT_CONFIG  = (UINT_PTR)HKEY_CURRENT_CONFIG+ , hKEY_CURRENT_USER    = (UINT_PTR)HKEY_CURRENT_USER+ , hKEY_LOCAL_MACHINE   = (UINT_PTR)HKEY_LOCAL_MACHINE+ , hKEY_USERS           = (UINT_PTR)HKEY_USERS  } -- , PKEYERFORMANCE_DATA  NT only -- , HKEY_DYN_DATA     95/98 only@@ -83,7 +153,7 @@ regCloseKey key =   withForeignPtr key $ \ p_key ->   failUnlessSuccess "RegCloseKey" $ c_RegCloseKey p_key-foreign import stdcall unsafe "windows.h RegCloseKey"+foreign import WINDOWS_CCONV unsafe "windows.h RegCloseKey"   c_RegCloseKey :: PKEY -> IO ErrCode  -- Connects to a predefined registry handle on another computer.@@ -97,7 +167,7 @@     c_RegConnectRegistry c_machine p_key p_out_key   p_new_key <- peek p_out_key   newForeignHANDLE p_new_key-foreign import stdcall unsafe "windows.h RegConnectRegistryW"+foreign import WINDOWS_CCONV unsafe "windows.h RegConnectRegistryW"   c_RegConnectRegistry :: LPCTSTR -> PKEY -> Ptr PKEY -> IO ErrCode  regCreateKey :: HKEY -> String -> IO HKEY@@ -109,7 +179,7 @@     c_RegCreateKey p_key c_subkey p_out_key   p_new_key <- peek p_out_key   newForeignHANDLE p_new_key-foreign import stdcall unsafe "windows.h RegCreateKeyW"+foreign import WINDOWS_CCONV unsafe "windows.h RegCreateKeyW"   c_RegCreateKey :: PKEY -> LPCTSTR -> Ptr PKEY -> IO ErrCode  type RegCreateOptions = DWORD@@ -134,11 +204,11 @@  , kEY_WRITE            = KEY_WRITE  } -regCreateKeyEx :: HKEY -> String -> String -> RegCreateOptions -> REGSAM -> Maybe LPSECURITY_ATTRIBUTES -> IO (HKEY, Bool)+regCreateKeyEx :: HKEY -> String -> Maybe String -> RegCreateOptions -> REGSAM -> Maybe LPSECURITY_ATTRIBUTES -> IO (HKEY, Bool) regCreateKeyEx key subkey cls opts sam mb_attr =   withForeignPtr key $ \ p_key ->   withTString subkey $ \ c_subkey ->-  withTString cls $ \ c_cls ->+  maybeWith withTString cls $ \ c_cls ->   alloca $ \ p_res ->   alloca $ \ p_disp -> do   failUnlessSuccess "RegCreateKeyEx" $@@ -147,7 +217,7 @@   out_key <- newForeignHANDLE p_out_key   disp <- peek p_disp   return (out_key, disp == #{const REG_CREATED_NEW_KEY})-foreign import stdcall unsafe "windows.h RegCreateKeyExW"+foreign import WINDOWS_CCONV unsafe "windows.h RegCreateKeyExW"   c_RegCreateKeyEx :: PKEY -> LPCTSTR -> DWORD -> LPCTSTR -> RegCreateOptions -> REGSAM -> LPSECURITY_ATTRIBUTES -> Ptr PKEY -> Ptr DWORD -> IO ErrCode  regDeleteKey :: HKEY -> String -> IO ()@@ -155,7 +225,7 @@   withForeignPtr key $ \ p_key ->   withTString subkey $ \ c_subkey ->   failUnlessSuccess "RegDeleteKey" $ c_RegDeleteKey p_key c_subkey-foreign import stdcall unsafe "windows.h RegDeleteKeyW"+foreign import WINDOWS_CCONV unsafe "windows.h RegDeleteKeyW"   c_RegDeleteKey :: PKEY -> LPCTSTR -> IO ErrCode  regDeleteValue :: HKEY -> String -> IO ()@@ -163,7 +233,7 @@   withForeignPtr key $ \ p_key ->   withTString name $ \ c_name ->   failUnlessSuccess "RegDeleteValue" $ c_RegDeleteValue p_key c_name-foreign import stdcall unsafe "windows.h RegDeleteValueW"+foreign import WINDOWS_CCONV unsafe "windows.h RegDeleteValueW"   c_RegDeleteValue :: PKEY -> LPCTSTR -> IO ErrCode  -- XXX Not 100% sure this is right, but I think it is.@@ -207,10 +277,10 @@        else do          val <--	   case ty of-	     x | x == rEG_SZ    -> peekTString (castPtr valbuf)-	       | x == rEG_DWORD -> peekElemOff (castPtr valbuf) 0 >>= \ v -> return (show (v :: DWORD))-	       | otherwise      -> return "<<unknown>>"+           case ty of+             x | x == rEG_SZ    -> peekTString (castPtr valbuf)+               | x == rEG_DWORD -> peekElemOff (castPtr valbuf) 0 >>= \ v -> return (show (v :: DWORD))+               | otherwise      -> return "<<unknown>>"          vs <- go (n+1) nmbuf nmlen valbuf vallen         return ((nm,val,ty):vs)@@ -225,7 +295,7 @@     c_RegEnumKey p_key index c_name len   str <- peekTString c_name   return (str, fromEnum no_more)-foreign import stdcall unsafe "windows.h RegEnumKeyW"+foreign import WINDOWS_CCONV unsafe "windows.h RegEnumKeyW"   c_RegEnumKey :: PKEY -> DWORD -> LPTSTR -> DWORD -> IO ErrCode  regEnumValue :: HKEY -> DWORD -> LPTSTR -> DWORD -> LPBYTE -> DWORD -> IO (RegValueType, String, Int)@@ -239,7 +309,7 @@   reg_ty <- peek p_reg_ty   str <- peekTString name   return (reg_ty, str, fromEnum no_more)-foreign import stdcall unsafe "windows.h RegEnumValueW"+foreign import WINDOWS_CCONV unsafe "windows.h RegEnumValueW"   c_RegEnumValue :: PKEY -> DWORD -> LPTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> LPBYTE -> Ptr DWORD -> IO ErrCode  eRROR_NO_MORE_ITEMS :: ErrCode@@ -249,7 +319,7 @@ regFlushKey key =   withForeignPtr key $ \ p_key ->   failUnlessSuccess "RegFlushKey" $ c_RegFlushKey p_key-foreign import stdcall unsafe "windows.h RegFlushKey"+foreign import WINDOWS_CCONV unsafe "windows.h RegFlushKey"   c_RegFlushKey :: PKEY -> IO ErrCode  -- ifdef FOR_WINDOWS_NT@@ -263,7 +333,7 @@   withTString subkey $ \ c_subkey ->   withTString file $ \ c_file ->   failUnlessSuccess "RegLoadKey" $ c_RegLoadKey p_key c_subkey c_file-foreign import stdcall unsafe "windows.h RegLoadKeyW"+foreign import WINDOWS_CCONV unsafe "windows.h RegLoadKeyW"   c_RegLoadKey :: PKEY -> LPCTSTR -> LPCTSTR -> IO ErrCode  -- ifdef FOR_WINDOWS_NT@@ -282,7 +352,7 @@   withForeignPtr key $ \ p_key ->   failUnlessSuccess "RegNotifyChangeKeyValue" $     c_RegNotifyChangeKeyValue p_key watch notifyFilter event async-foreign import stdcall unsafe "windows.h RegNotifyChangeKeyValue"+foreign import WINDOWS_CCONV unsafe "windows.h RegNotifyChangeKeyValue"   c_RegNotifyChangeKeyValue :: PKEY -> Bool -> RegNotifyOptions -> HANDLE -> Bool -> IO ErrCode  -- endif@@ -297,7 +367,7 @@   failUnlessSuccess "RegOpenKey" $ c_RegOpenKey p_key c_subkey p_res   p_res_key <- peek p_res   newForeignHANDLE p_res_key-foreign import stdcall unsafe "windows.h RegOpenKeyW"+foreign import WINDOWS_CCONV unsafe "windows.h RegOpenKeyW"   c_RegOpenKey :: PKEY -> LPCTSTR -> Ptr PKEY -> IO ErrCode  regOpenKeyEx :: HKEY -> String -> REGSAM -> IO HKEY@@ -308,7 +378,7 @@   failUnlessSuccess "RegOpenKeyEx" $ c_RegOpenKeyEx p_key c_subkey 0 sam p_res   p_res_key <- peek p_res   newForeignHANDLE p_res_key-foreign import stdcall unsafe "windows.h RegOpenKeyExW"+foreign import WINDOWS_CCONV unsafe "windows.h RegOpenKeyExW"   c_RegOpenKeyEx :: PKEY -> LPCTSTR -> DWORD -> REGSAM -> Ptr PKEY -> IO ErrCode  data RegInfoKey =@@ -343,68 +413,79 @@     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 stdcall unsafe "windows.h RegQueryInfoKeyW"+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  -- RegQueryMultipleValues :: HKEY -> IO ([VALENT],String) --- RegQueryValue() isn't really that, it just allows you to--- get at the default values of keys, so we provide our own--- (and better!) version of it. If you want RegQueryValue()s--- behaviour, use regQueryValueKey.-+{-# DEPRECATED regQueryValueKey "Use regQueryValue instead." #-} regQueryValueKey :: HKEY -> Maybe String -> IO String regQueryValueKey key mb_subkey =   withForeignPtr key $ \ p_key ->   maybeWith withTString mb_subkey $ \ c_subkey ->   alloca $ \ p_value_len -> do-  failUnlessSuccess "RegQueryValue" $+  failUnlessSuccess "RegQueryValueKey" $     c_RegQueryValue p_key c_subkey nullPtr p_value_len   value_len <- peek p_value_len   allocaArray0 (fromIntegral value_len) $ \ c_value -> do-    failUnlessSuccess "RegQueryValue" $+    failUnlessSuccess "RegQueryValueKey" $       c_RegQueryValue p_key c_subkey c_value p_value_len     peekTString c_value-foreign import stdcall unsafe "windows.h RegQueryValueW"-  c_RegQueryValue :: PKEY -> LPCTSTR -> LPTSTR -> Ptr LONG -> IO ErrCode  regQueryValue :: HKEY -> Maybe String -> IO String regQueryValue key mb_subkey =   withForeignPtr key $ \ p_key ->   maybeWith withTString mb_subkey $ \ c_subkey ->-  alloca $ \ p_ty ->   alloca $ \ p_value_len -> do   failUnlessSuccess "RegQueryValue" $+    c_RegQueryValue p_key c_subkey nullPtr p_value_len+  value_len <- peek p_value_len+  allocaArray0 (fromIntegral value_len) $ \ c_value -> do+    failUnlessSuccess "RegQueryValue" $+      c_RegQueryValue p_key c_subkey c_value p_value_len+    peekTString c_value+foreign import WINDOWS_CCONV unsafe "windows.h RegQueryValueW"+  c_RegQueryValue :: PKEY -> LPCTSTR -> LPTSTR -> Ptr LONG -> IO ErrCode++-- Gets the data associated with the default value of a key (assumed to be of+-- type REG_SZ) using RegQeryValueEx.+regQueryDefaultValue :: HKEY -> String -> IO String+regQueryDefaultValue key mb_subkey =+  withForeignPtr key $ \ p_key ->+  withTString mb_subkey $ \ c_subkey ->+  alloca $ \ p_ty ->+  alloca $ \ p_value_len -> do+  failUnlessSuccess "regQueryDefaultValue" $     c_RegQueryValueEx p_key c_subkey nullPtr p_ty nullPtr p_value_len   ty <- peek p_ty-  failUnlessSuccess "RegQueryValue" $ return (if ty == rEG_SZ then 0 else 1)+  failUnlessSuccess "regQueryDefaultValue" $ return (if ty == rEG_SZ then 0 else 1)   value_len <- peek p_value_len   allocaArray0 (fromIntegral value_len) $ \ c_value -> do-    failUnlessSuccess "RegQueryValue" $+    failUnlessSuccess "regQueryDefaultValue" $       c_RegQueryValueEx p_key c_subkey nullPtr p_ty c_value p_value_len     peekTString (castPtr c_value) @@ -417,18 +498,18 @@   failUnlessSuccess "RegQueryValueEx" $     c_RegQueryValueEx p_key c_name nullPtr p_ty value p_value_len   peek p_ty-foreign import stdcall unsafe "windows.h RegQueryValueExW"+foreign import WINDOWS_CCONV unsafe "windows.h RegQueryValueExW"   c_RegQueryValueEx :: PKEY -> LPCTSTR -> Ptr DWORD -> Ptr DWORD -> LPBYTE -> Ptr DWORD -> IO ErrCode -regReplaceKey :: HKEY -> String -> String -> String -> IO ()+regReplaceKey :: HKEY -> Maybe String -> String -> String -> IO () regReplaceKey key subkey newfile oldfile =   withForeignPtr key $ \ p_key ->-  withTString subkey $ \ c_subkey ->+  maybeWith withTString subkey $ \ c_subkey ->   withTString newfile $ \ c_newfile ->   withTString oldfile $ \ c_oldfile ->   failUnlessSuccess "RegReplaceKey" $     c_RegReplaceKey p_key c_subkey c_newfile c_oldfile-foreign import stdcall unsafe "windows.h RegReplaceKeyW"+foreign import WINDOWS_CCONV unsafe "windows.h RegReplaceKeyW"   c_RegReplaceKey :: PKEY -> LPCTSTR -> LPCTSTR -> LPCTSTR -> IO ErrCode  type RegRestoreFlags = DWORD@@ -444,7 +525,7 @@   withForeignPtr key $ \ p_key ->   withTString file $ \ c_file ->   failUnlessSuccess "RegRestoreKey" $ c_RegRestoreKey p_key c_file flags-foreign import stdcall unsafe "windows.h RegRestoreKeyW"+foreign import WINDOWS_CCONV unsafe "windows.h RegRestoreKeyW"   c_RegRestoreKey :: PKEY -> LPCTSTR -> RegRestoreFlags -> IO ErrCode  regSaveKey :: HKEY -> String -> Maybe LPSECURITY_ATTRIBUTES -> IO ()@@ -452,7 +533,7 @@   withForeignPtr key $ \ p_key ->   withTString file $ \ c_file ->   failUnlessSuccess "RegSaveKey" $ c_RegSaveKey p_key c_file (maybePtr mb_attr)-foreign import stdcall unsafe "windows.h RegSaveKeyW"+foreign import WINDOWS_CCONV unsafe "windows.h RegSaveKeyW"   c_RegSaveKey :: PKEY -> LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO ErrCode  -- ifdef FOR_WINDOWS_NT@@ -463,14 +544,43 @@  -- 3.1 compat. - only allows storage of REG_SZ values. +regGetValue :: HKEY -> Maybe String -> Maybe String -> RegTypeRestriction -> Maybe LPDWORD -> Maybe LPVOID -> Maybe LPDWORD -> IO ()+regGetValue key m_subkey m_valuename flags m_type m_value m_size =+  withForeignPtr key $ \ p_key ->+  maybeWith withTString m_subkey $ \ c_subkey ->+  maybeWith withTString m_valuename $ \ c_valuename ->+  failUnlessSuccess "RegGetValue" $+    c_RegGetValue p_key c_subkey c_valuename flags (maybePtr m_type) (maybePtr m_value) (maybePtr m_size)+foreign import WINDOWS_CCONV unsafe "windows.h RegGetValueW"+  c_RegGetValue :: PKEY -> LPCTSTR -> LPCTSTR -> DWORD -> LPDWORD -> LPVOID -> LPDWORD -> IO ErrCode++type RegTypeRestriction = DWORD++#{enum RegTypeRestriction,+  , rRF_RT_ANY            = RRF_RT_ANY+  , rRF_RT_DWORD          = RRF_RT_DWORD+  , rRF_RT_QWORD          = RRF_RT_QWORD+  , rRF_RT_REG_BINARY     = RRF_RT_REG_BINARY+  , rRF_RT_REG_DWORD      = RRF_RT_REG_DWORD+  , rRF_RT_REG_EXPAND_SZ  = RRF_RT_REG_EXPAND_SZ+  , rRF_RT_REG_MULTI_SZ   = RRF_RT_REG_MULTI_SZ+  , rRF_RT_REG_NONE       = RRF_RT_REG_NONE+  , rRF_RT_REG_QWORD      = RRF_RT_REG_QWORD+  , rRF_RT_REG_SZ         = RRF_RT_REG_SZ+  , rRF_NOEXPAND          = RRF_NOEXPAND+  , rRF_ZEROONFAILURE     = RRF_ZEROONFAILURE+  , rRF_SUBKEY_WOW6464KEY = RRF_SUBKEY_WOW6464KEY+  , rRF_SUBKEY_WOW6432KEY = RRF_SUBKEY_WOW6432KEY+  }+ regSetValue :: HKEY -> String -> String -> IO () regSetValue key subkey value =   withForeignPtr key $ \ p_key ->   withTString subkey $ \ c_subkey ->-  withTStringLen value $ \ (c_value, value_len) ->+  withTString value $ \ c_value ->   failUnlessSuccess "RegSetValue" $-    c_RegSetValue p_key c_subkey rEG_SZ c_value value_len-foreign import stdcall unsafe "windows.h RegSetValueW"+    c_RegSetValue p_key c_subkey rEG_SZ c_value 0 -- cbData is ignored, value needs to be null terminated.+foreign import WINDOWS_CCONV unsafe "windows.h RegSetValueW"   c_RegSetValue :: PKEY -> LPCTSTR -> DWORD -> LPCTSTR -> Int -> IO ErrCode  @@ -495,7 +605,7 @@ regSetStringValue :: HKEY -> String -> String -> IO () regSetStringValue hk key val =   withTString val $ \ v ->-  regSetValueEx hk key rEG_SZ v (length val * sizeOf (undefined::TCHAR))+  regSetValueEx hk key rEG_SZ v ((1+length val) * sizeOf (undefined::TCHAR))  regSetValueEx :: HKEY -> String -> RegValueType -> LPTSTR -> Int -> IO () regSetValueEx key subkey ty value value_len =@@ -503,7 +613,7 @@   withTString subkey $ \ c_subkey ->   failUnlessSuccess "RegSetValueEx" $     c_RegSetValueEx p_key c_subkey 0 ty value value_len-foreign import stdcall unsafe "windows.h RegSetValueExW"+foreign import WINDOWS_CCONV unsafe "windows.h RegSetValueExW"   c_RegSetValueEx :: PKEY -> LPCTSTR -> DWORD -> RegValueType -> LPTSTR -> Int -> IO ErrCode  regUnLoadKey :: HKEY -> String -> IO ()@@ -511,5 +621,5 @@   withForeignPtr key $ \ p_key ->   withTString subkey $ \ c_subkey ->   failUnlessSuccess "RegUnLoadKey" $ c_RegUnLoadKey p_key c_subkey-foreign import stdcall unsafe "windows.h RegUnLoadKeyW"+foreign import WINDOWS_CCONV unsafe "windows.h RegUnLoadKeyW"   c_RegUnLoadKey :: PKEY -> LPCTSTR -> IO ErrCode

System/Win32/Security.hsc view

@@ -1,13 +1,11 @@ {-# OPTIONS_GHC -w #-}--- The above warning supression flag is a temporary kludge.+-- The above warning suppression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See---     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings+--     https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Win32.Security@@ -22,7 +20,7 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Security ( +module System.Win32.Security (         -- * Types         SID, PSID,         ACL, PACL,@@ -57,6 +55,8 @@ -- import Foreign.C import System.Win32.Types +##include "windows_cconv.h"+ #include <windows.h>  -- --------------------------------------------------------------------------@@ -89,88 +89,88 @@ newtype SID = SID SID type PSID = Ptr SID -foreign import stdcall unsafe "windows.h GetSecurityDescriptorControl"+foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorControl"   c_getSecurityDescriptorControl     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> Ptr SECURITY_DESCRIPTOR_CONTROL -- pControl     -> LPDWORD -- lpdwRevision-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h GetSecurityDescriptorDacl"-  c_getSecurityDescriptorDacl +foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorDacl"+  c_getSecurityDescriptorDacl     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> LPBOOL -- lpbDaclPresent     -> Ptr PACL -- pDacl     -> LPBOOL -- lpbDaclDefaulted-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h GetSecurityDescriptorGroup"+foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorGroup"   c_getSecurityDescriptorGroup     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> Ptr PSID -- pGroup     -> LPBOOL -- lpbGroupDefaulted-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h GetSecurityDescriptorLength"+foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorLength"   c_getSecurityDescriptorLength     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor-    -> IO DWORD +    -> IO DWORD -foreign import stdcall unsafe "windows.h GetSecurityDescriptorOwner"+foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorOwner"   c_getSecurityDescriptorOwner     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> Ptr PSID -- pOwner     -> LPBOOL -- lpbOwnerDefaulted-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h GetSecurityDescriptorSacl"+foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorSacl"   c_getSecurityDescriptorSacl     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> LPBOOL -- lpbSaclPresent     -> Ptr PACL -- pSacl     -> LPBOOL -- lpbSaclDefaulted-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h InitializeSecurityDescriptor"+foreign import WINDOWS_CCONV unsafe "windows.h InitializeSecurityDescriptor"   c_initializeSecurityDescriptor     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> DWORD -- dwRevision-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h IsValidSecurityDescriptor"+foreign import WINDOWS_CCONV unsafe "windows.h IsValidSecurityDescriptor"   c_isValidSecurityDescriptor     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h SetSecurityDescriptorDacl"+foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorDacl"   c_setSecurityDescriptorDacl     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> BOOL -- bDaclPresent     -> PACL -- pDacl     -> BOOL -- bDaclDefaulted-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h SetSecurityDescriptorGroup"+foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorGroup"   c_setSecurityDescriptorGroup     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> PSID -- pGroup     -> BOOL -- bGroupDefaulted-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h SetSecurityDescriptorOwner"+foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorOwner"   c_setSecurityDescriptorOwner     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> PSID -- pOwner     -> BOOL -- bOwnerDefaulted-    -> IO BOOL +    -> IO BOOL -foreign import stdcall unsafe "windows.h SetSecurityDescriptorSacl"+foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorSacl"   c_setSecurityDescriptorSacl     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> BOOL -- bSaclPresent     -> PACL -- pSacl     -> BOOL -- bSaclDefaulted-    -> IO BOOL +    -> IO BOOL  -- --------------------------------------------------------------------------- @@ -188,7 +188,7 @@ -- , pROTECTED_DACL_SECURITY_INFORMATION = PROTECTED_DACL_SECURITY_INFORMATION -- , pROTECTED_SACL_SECURITY_INFORMATION = PROTECTED_SACL_SECURITY_INFORMATION -- , uNPROTECTED_DACL_SECURITY_INFORMATION = UNPROTECTED_DACL_SECURITY_INFORMATION--- , uNPROTECTED_SACL_SECURITY_INFORMATION = UNPROTECTED_SACL_SECURITY_INFORMATION +-- , uNPROTECTED_SACL_SECURITY_INFORMATION = UNPROTECTED_SACL_SECURITY_INFORMATION  getFileSecurity     :: String@@ -201,20 +201,20 @@   needed <- peek lpnLengthNeeded   fpSd <- mallocForeignPtrBytes (fromIntegral needed)   withForeignPtr fpSd $ \pSd -> do-  failIfFalse_ "getFileSecurity" $ +  failIfFalse_ "getFileSecurity" $     c_GetFileSecurity lpFileName si pSd needed lpnLengthNeeded   return (SecurityDescriptor fpSd) -foreign import stdcall unsafe "windows.h GetFileSecurityW"+foreign import WINDOWS_CCONV unsafe "windows.h GetFileSecurityW"   c_GetFileSecurity     :: LPCWSTR -- lpFileName     -> SECURITY_INFORMATION -- RequestedInformation     -> PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> DWORD -- nLength     -> LPDWORD -- lpnLengthNeeded-    -> IO BOOL +    -> IO BOOL ---foreign import stdcall unsafe "windows.h AccessCheck"+--foreign import WINDOWS_CCONV unsafe "windows.h AccessCheck" --  c_AccessCheck --    :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor --    -> HANDLE -- ClientToken@@ -226,7 +226,7 @@ --    -> LPBOOL -- AccessStatus --    -> IO BOOL --- foreign import stdcall unsafe "windows.h OpenThreadToken"+-- foreign import WINDOWS_CCONV unsafe "windows.h OpenThreadToken" --    OpenThreadToken --      :: HANDLE -- ThreadHandle --      -> DWORD -- DesiredAccess

+ System/Win32/Semaphore.hsc view

@@ -0,0 +1,146 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.Semaphore+-- Copyright   :  (c) Sam Derbyshire, 2022+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  Sam Derbyshire+-- Stability   :  provisional+-- Portability :  portable+--+-- Windows Semaphore objects and operations+--+-----------------------------------------------------------------------------++module System.Win32.Semaphore+    ( -- * Semaphores+      Semaphore(..)++      -- * Access modes+    , AccessMode+    , sEMAPHORE_ALL_ACCESS+    , sEMAPHORE_MODIFY_STATE++      -- * Managing semaphores+    , createSemaphore+    , openSemaphore+    , releaseSemaphore+    ) where++import System.Win32.File+import System.Win32.Types++import Data.Maybe (fromMaybe)+import Foreign hiding (void)+import Foreign.C (withCAString)++##include "windows_cconv.h"++#include <windows.h>++----------------------------------------------------------------+-- Semaphore access modes+----------------------------------------------------------------++#{enum AccessMode,+    , sEMAPHORE_ALL_ACCESS   = SEMAPHORE_ALL_ACCESS+    , sEMAPHORE_MODIFY_STATE = SEMAPHORE_MODIFY_STATE+    }++----------------------------------------------------------------+-- Semaphores+----------------------------------------------------------------++-- | A Windows semaphore.+--+-- To obtain a 'Semaphore', use 'createSemaphore' to create a new one,+-- or 'openSemaphore' to open an existing one.+--+-- To wait on a semaphore, use 'System.Win32.Event.waitForSingleObject'.+--+-- To release resources on a semaphore, use 'releaseSemaphore'.+--+-- To free a semaphore, use 'System.Win32.File.closeHandle'.+-- The semaphore object is destroyed when its last handle has been closed.+-- Closing the handle does not affect the semaphore count; therefore, be sure to call+-- 'releaseSemaphore' before closing the handle or before the process terminates.+-- Otherwise, pending wait operations will either time out or continue indefinitely,+-- depending on whether a time-out value has been specified.+newtype Semaphore = Semaphore { semaphoreHandle :: HANDLE }++-- | Open a 'Semaphore' with the given name, or create a new semaphore+-- if no such semaphore exists, with initial count @i@ and maximum count @m@.+--+-- The counts must satisfy @i >= 0@, @m > 0@ and @i <= m@.+--+-- The returned 'Bool' is 'True' if the function found an existing semaphore+-- with the given name, in which case a handle to that semaphore is returned+-- and the counts are ignored.+--+-- Use 'openSemaphore' if you don't want to create a new semaphore.+createSemaphore :: Maybe SECURITY_ATTRIBUTES+                -> LONG         -- ^ initial count @i@ with @0 <= i <= m@+                -> LONG         -- ^ maximum count @m > 0@+                -> Maybe String -- ^ (optional) semaphore name+                                -- (case-sensitive, limited to MAX_PATH characters)+                -> IO (Semaphore, Bool)+createSemaphore mb_sec initial_count max_count mb_name =+  maybeWith with mb_sec $ \ c_sec -> do+  maybeWith withCAString mb_name $ \ c_name -> do+  handle <- c_CreateSemaphore c_sec initial_count max_count c_name+  err_code <- getLastError+  already_exists <-+    case err_code of+      (# const ERROR_INVALID_HANDLE) ->+        errorWin $ "createSemaphore: semaphore name '"+                ++ fromMaybe "" mb_name+                ++ "' matches non-semaphore"+      (# const ERROR_ALREADY_EXISTS) ->+        return True+      _                              ->+        return False+  if handle == nullPtr+  then errorWin "createSemaphore"+  else return (Semaphore handle, already_exists)++foreign import WINDOWS_CCONV unsafe "windows.h CreateSemaphoreA"+  c_CreateSemaphore :: LPSECURITY_ATTRIBUTES -> LONG -> LONG -> LPCSTR -> IO HANDLE++-- | Open an existing 'Semaphore'.+openSemaphore :: AccessMode -- ^ desired access mode+              -> Bool       -- ^ should child processes inherit the handle?+              -> String     -- ^ name of the semaphore to open (case-sensitive)+              -> IO Semaphore+openSemaphore amode inherit name =+  withTString name $ \c_name -> do+    handle <- failIfNull ("openSemaphore: '" ++ name ++ "'") $+              c_OpenSemaphore (fromIntegral amode) inherit c_name+    return (Semaphore handle)++foreign import WINDOWS_CCONV unsafe "windows.h OpenSemaphoreW"+  c_OpenSemaphore :: DWORD -> BOOL -> LPCWSTR -> IO HANDLE++-- | Increase the count of the 'Semaphore' by the specified amount.+--+-- Returns the count of the semaphore before the increase.+--+-- Throws an error if the count would exceeded the maximum count+-- of the semaphore.+releaseSemaphore :: Semaphore -> LONG -> IO LONG+releaseSemaphore (Semaphore handle) count =+  with 0 $ \ ptr_prevCount -> do+  failIfFalse_ "releaseSemaphore" $ c_ReleaseSemaphore handle count ptr_prevCount+  peek ptr_prevCount++foreign import WINDOWS_CCONV unsafe "windows.h ReleaseSemaphore"+  c_ReleaseSemaphore :: HANDLE -> LONG -> Ptr LONG -> IO BOOL++----------------------------------------------------------------+-- End+----------------------------------------------------------------

System/Win32/Shell.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701
+#if __GLASGOW_HASKELL__ >= 709
+{-# LANGUAGE Safe #-}
+#else
 {-# LANGUAGE Trustworthy #-}
 #endif
 -----------------------------------------------------------------------------
@@ -22,20 +24,24 @@   cSIDL_APPDATA,
   cSIDL_WINDOWS,
   cSIDL_PERSONAL,
+  cSIDL_LOCAL_APPDATA,
+  cSIDL_DESKTOPDIRECTORY,
   cSIDL_PROGRAM_FILES,
   SHGetFolderPathFlags,
   sHGFP_TYPE_CURRENT,
   sHGFP_TYPE_DEFAULT
  ) where
 
+import System.Win32.Shell.Internal
 import System.Win32.Types
 import Graphics.Win32.GDI.Types (HWND)
 
 import Foreign
 import Foreign.C
 import Control.Monad
-import System.IO.Error
 
+##include "windows_cconv.h"
+
 -- for SHGetFolderPath stuff
 #define _WIN32_IE 0x500
 #include <windows.h>
@@ -54,6 +60,8 @@  , cSIDL_APPDATA  = CSIDL_APPDATA
  , cSIDL_WINDOWS  = CSIDL_WINDOWS
  , cSIDL_PERSONAL = CSIDL_PERSONAL
+ , cSIDL_LOCAL_APPDATA = CSIDL_LOCAL_APPDATA
+ , cSIDL_DESKTOPDIRECTORY = CSIDL_DESKTOPDIRECTORY
  , cSIDL_PROGRAM_FILES = CSIDL_PROGRAM_FILES
  }
 -- XXX there are lots more of these
@@ -71,11 +79,3 @@     r <- c_SHGetFolderPath hwnd csidl hdl flags pstr
     when (r < 0) $ raiseUnsupported "sHGetFolderPath"
     peekTString pstr
-
-raiseUnsupported :: String -> IO ()
-raiseUnsupported loc = 
-   ioError (ioeSetErrorString (mkIOError illegalOperationErrorType loc Nothing Nothing) "unsupported operation")
-
-foreign import stdcall unsafe "SHGetFolderPathW"
-  c_SHGetFolderPath :: HWND -> CInt -> HANDLE -> DWORD -> LPTSTR
-                    -> IO HRESULT

+ System/Win32/Shell/Internal.hsc view

@@ -0,0 +1,50 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.Shell.Internal+-- Copyright   :  (c) The University of Glasgow 2009+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>+-- Stability   :  provisional+-- Portability :  portable+--+-- Win32 stuff from shell32.dll+--+-----------------------------------------------------------------------------++module System.Win32.Shell.Internal (+   c_SHGetFolderPath+ , raiseUnsupported+ ) where++import System.Win32.Types+import Graphics.Win32.GDI.Types (HWND)++import Foreign.C+import System.IO.Error++##include "windows_cconv.h"++-- for SHGetFolderPath stuff+#define _WIN32_IE 0x500+#include <windows.h>+#include <shlobj.h>++----------------------------------------------------------------+-- SHGetFolderPath+--+-- XXX: this is deprecated in Vista and later+----------------------------------------------------------------++raiseUnsupported :: String -> IO ()+raiseUnsupported loc =+   ioError (ioeSetErrorString (mkIOError illegalOperationErrorType loc Nothing Nothing) "unsupported operation")++foreign import WINDOWS_CCONV unsafe "SHGetFolderPathW"+  c_SHGetFolderPath :: HWND -> CInt -> HANDLE -> DWORD -> LPTSTR+                    -> IO HRESULT

System/Win32/SimpleMAPI.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,6 +18,12 @@ ----------------------------------------------------------------------------- module System.Win32.SimpleMAPI where++-- I am not sure why exactly, but with mingw64 mapi.h does not define+-- some of the values we use, e.g. MAPI_LOGOFF_SHARED.+-- mapix.h does define MAPI_LOGOFF_SHARED, but the various flags+-- clash with each other.+ import Control.Exception    ( bracket, handle, finally, onException                             , IOException ) import Control.Monad        ( liftM5 )@@ -27,10 +35,11 @@   -- Apparently, simple MAPI does not support unicode and probably never will,   -- so this module will just mangle any Unicode in your strings import Graphics.Win32.GDI.Types     ( HWND)-import System.Win32.DLL     ( loadLibrary, c_GetProcAddress, freeLibrary-                            , c_FreeLibraryFinaliser )+import System.Win32.DLL     ( loadLibrary, freeLibrary, getProcAddress ) import System.Win32.Types   ( DWORD, LPSTR, HMODULE, failIfNull ) +##include "windows_cconv.h"+ #include "windows.h" #include "mapi.h" @@ -43,8 +52,6 @@     , mAPI_LOGON_UI         = MAPI_LOGON_UI     , mAPI_NEW_SESSION      = MAPI_NEW_SESSION     , mAPI_FORCE_DOWNLOAD   = MAPI_FORCE_DOWNLOAD-    , mAPI_LOGOFF_SHARED    = MAPI_LOGOFF_SHARED-    , mAPI_LOGOFF_UI        = MAPI_LOGOFF_UI     , mAPI_DIALOG           = MAPI_DIALOG     , mAPI_UNREAD_ONLY      = MAPI_UNREAD_ONLY     , mAPI_LONG_MSGID       = MAPI_LONG_MSGID@@ -60,6 +67,19 @@     , mAPI_RECEIPT_REQUESTED = MAPI_RECEIPT_REQUESTED     , mAPI_SENT             = MAPI_SENT     }+-- Have to define enum values outside previous declaration due to+-- hsc2hs bug in --cross-compile mode:+--    https://ghc.haskell.org/trac/ghc/ticket/13620+#ifdef MAPI_LOGOFF_SHARED+#{enum MapiFlag,+    , mAPI_LOGOFF_SHARED    = MAPI_LOGOFF_SHARED+}+#endif+#ifdef MAPI_LOGOFF_UI+#{enum MapiFlag,+    , mAPI_LOGOFF_UI        = MAPI_LOGOFF_UI+}+#endif  mapiErrors :: [(ULONG,String)] mapiErrors =@@ -71,11 +91,13 @@     , ((#const MAPI_E_DISK_FULL)        , "Disk full")     , ((#const MAPI_E_INSUFFICIENT_MEMORY)      , "Not enough memory")     , ((#const MAPI_E_ACCESS_DENIED)    , "Access denied")+#ifdef MAPI_E_BLK_TOO_SMALL     , ((#const MAPI_E_BLK_TOO_SMALL)    , "BLK_TOO_SMALL")+#endif     , ((#const MAPI_E_TOO_MANY_SESSIONS), "Too many open sessions")     , ((#const MAPI_E_TOO_MANY_FILES)   , "Too many open files")     , ((#const MAPI_E_TOO_MANY_RECIPIENTS)      , "Too many recipients")-    , ((#const MAPI_E_ATTACHMENT_NOT_FOUND)     , "Attachemnt not found")+    , ((#const MAPI_E_ATTACHMENT_NOT_FOUND)     , "Attachment not found")     , ((#const MAPI_E_ATTACHMENT_OPEN_FAILURE)  , "Couldn't open attachment")     , ((#const MAPI_E_ATTACHMENT_WRITE_FAILURE) , "Couldn't write attachment")     , ((#const MAPI_E_UNKNOWN_RECIPIENT)        , "Unknown recipient")@@ -85,8 +107,10 @@     , ((#const MAPI_E_TEXT_TOO_LARGE)           , "Text too large")     , ((#const MAPI_E_INVALID_SESSION)          , "Invalid session")     , ((#const MAPI_E_TYPE_NOT_SUPPORTED)       , "Type not supported")-    , ((#const MAPI_E_AMBIGUOUS_RECIPIENT)      , "Ambigious recipient")-    , ((#const MAPI_E_AMBIGUOUS_RECIP)          , "Ambigious recipient")+    , ((#const MAPI_E_AMBIGUOUS_RECIPIENT)      , "Ambiguous recipient")+#ifdef MAPI_E_AMBIGUOUS_RECIP+    , ((#const MAPI_E_AMBIGUOUS_RECIP)          , "Ambiguous recipient")+#endif     , ((#const MAPI_E_MESSAGE_IN_USE)           , "Message in use")     , ((#const MAPI_E_NETWORK_FAILURE)          , "Network failure")     , ((#const MAPI_E_INVALID_EDITFIELDS)       , "Invalid editfields")@@ -109,21 +133,21 @@ mapiFail_ n a = mapiFail n a >> return ()  type MapiLogonType = ULONG -> LPSTR -> LPSTR -> MapiFlag -> ULONG -> Ptr LHANDLE -> IO ULONG-foreign import stdcall "dynamic" mkMapiLogon :: FunPtr MapiLogonType -> MapiLogonType+foreign import WINDOWS_CCONV "dynamic" mkMapiLogon :: FunPtr MapiLogonType -> MapiLogonType  type MapiLogoffType = LHANDLE -> ULONG -> MapiFlag -> ULONG -> IO ULONG-foreign import stdcall "dynamic" mkMapiLogoff :: FunPtr MapiLogoffType -> MapiLogoffType+foreign import WINDOWS_CCONV "dynamic" mkMapiLogoff :: FunPtr MapiLogoffType -> MapiLogoffType  type MapiResolveNameType =     LHANDLE -> ULONG -> LPSTR -> MapiFlag -> ULONG     -> Ptr (Ptr MapiRecipDesc) -> IO ULONG-foreign import stdcall "dynamic" mkMapiResolveName :: FunPtr MapiResolveNameType -> MapiResolveNameType+foreign import WINDOWS_CCONV "dynamic" mkMapiResolveName :: FunPtr MapiResolveNameType -> MapiResolveNameType  type MapiFreeBufferType = Ptr () -> IO ULONG-foreign import stdcall "dynamic" mkMapiFreeBuffer :: FunPtr MapiFreeBufferType -> MapiFreeBufferType+foreign import WINDOWS_CCONV "dynamic" mkMapiFreeBuffer :: FunPtr MapiFreeBufferType -> MapiFreeBufferType  type MapiSendMailType = LHANDLE -> ULONG -> Ptr Message -> MapiFlag -> ULONG -> IO ULONG-foreign import stdcall "dynamic" mkMapiSendMail :: FunPtr MapiSendMailType -> MapiSendMailType+foreign import WINDOWS_CCONV "dynamic" mkMapiSendMail :: FunPtr MapiSendMailType -> MapiSendMailType  data MapiFuncs = MapiFuncs     { mapifLogon    :: MapiLogonType@@ -146,9 +170,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 = do             proc <- failIfNull ("loadMapiDll: " ++ dllname ++ ": " ++ name)-                        $ c_GetProcAddress dll name'+                        $ getProcAddress dll' name             return $ conv $ castPtrToFunPtr proc -- | loadMapiDll :: String -> IO (MapiFuncs, HMODULE)@@ -179,6 +203,11 @@             []  -> fail $ "loadMapi: Failed to load any of DLLs: " ++ show dlls             x:y -> handleIOException (const $ loadOne y) (loadMapiDll x) ++{-# CFILES cbits/HsWin32.c #-}+foreign import ccall "HsWin32.h &FreeLibraryFinaliser"+    c_FreeLibraryFinaliser :: FunPtr (HMODULE -> IO ())+ -- | withMapiLoaded :: MapiLoaded -> (MapiFuncs -> IO a) -> IO a withMapiLoaded (f,m) act = finally (act f) (touchForeignPtr m)@@ -195,12 +224,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+            f (maybeHWND hwnd)+            c_ses c_pw flags 0 out         peek out  -- | End Simple MAPI-session@@ -247,12 +276,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@@ -333,18 +362,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@@ -392,9 +421,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-

+ System/Win32/String.hs view

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

+ System/Win32/SymbolicLink.hsc view

@@ -0,0 +1,93 @@+{-# 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: When using the createSymbolicLink* functions without the
+   SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE flag, 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 manifest file to add
+       \<requestedExecutionLevel level='requireAdministrator' uiAccess='false'/\>.
+
+   Starting from Windows 10 version 1703 (Creators Update), after enabling
+   Developer Mode, users can create symbolic links without requiring the
+   Administrator privilege in the current process. Supply a 'True' flag in
+   addition to the target and link name to enable this behavior.
+-}
+module System.Win32.SymbolicLink
+  ( SymbolicLinkFlags
+  , sYMBOLIC_LINK_FLAG_FILE
+  , sYMBOLIC_LINK_FLAG_DIRECTORY
+  , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
+  , createSymbolicLink
+  , createSymbolicLink'
+  , createSymbolicLinkFile
+  , createSymbolicLinkDirectory
+  ) where
+
+import System.Win32.SymbolicLink.Internal
+import Data.Bits ((.|.))
+import System.Win32.Types
+import System.Win32.File ( failIfFalseWithRetry_ )
+
+##include "windows_cconv.h"
+
+
+-- | createSymbolicLink* functions don't check that file is exist or not.
+--
+-- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatibility 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 -- ^ Target file path
+                       -> FilePath -- ^ Symbolic link name
+                       -> Bool -- ^ Create the symbolic link with the unprivileged mode
+                       -> IO ()
+createSymbolicLinkFile target link unprivileged =
+  createSymbolicLink'
+    link
+    target
+    ( if unprivileged
+        then sYMBOLIC_LINK_FLAG_FILE .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
+        else sYMBOLIC_LINK_FLAG_FILE
+    )
+
+createSymbolicLinkDirectory :: FilePath -- ^ Target file path
+                            -> FilePath -- ^ Symbolic link name
+                            -> Bool -- ^ Create the symbolic link with the unprivileged mode
+                            -> IO ()
+createSymbolicLinkDirectory target link unprivileged =
+  createSymbolicLink'
+    link
+    target
+    ( if unprivileged
+        then
+          sYMBOLIC_LINK_FLAG_DIRECTORY
+            .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
+        else 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
+

+ System/Win32/SymbolicLink/Internal.hsc view

@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+{- |+   Module      :  System.Win32.SymbolicLink.Internal+   Copyright   :  2012 shelarcy+   License     :  BSD-style++   Maintainer  :  shelarcy@gmail.com+   Stability   :  Provisional+   Portability :  Non-portable (Win32 API)+-}+module System.Win32.SymbolicLink.Internal where++import System.Win32.Types++##include "windows_cconv.h"++type SymbolicLinkFlags = DWORD++#{enum SymbolicLinkFlags,+ , sYMBOLIC_LINK_FLAG_FILE      = 0x0+ , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1+ , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2+}++foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW"+  c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL

+ System/Win32/Thread.hs view

@@ -0,0 +1,42 @@+{-# 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
+  , resumeThread
+  , withSuspendedThread
+  , getThreadId
+  , 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

System/Win32/Time.hsc view

@@ -1,4 +1,6 @@-#if __GLASGOW_HASKELL__ >= 701+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -14,164 +16,111 @@ -- A collection of FFI declarations for interfacing with Win32 Time API. -- ------------------------------------------------------------------------------module System.Win32.Time where+module System.Win32.Time+    ( FILETIME(..)+    , SYSTEMTIME(..)+    , TIME_ZONE_INFORMATION(..)+    , TimeZoneId(..)+    , getSystemTime+    , setSystemTime+    , getSystemTimeAsFileTime+    , getLocalTime+    , setLocalTime+    , getSystemTimeAdjustment+    , getTickCount+    , getLastInputInfo+    , getIdleTime+    , setSystemTimeAdjustment+    , getTimeZoneInformation+    , systemTimeToFileTime+    , fileTimeToSystemTime+    , getFileTime+    , setFileTime+    , invalidFileTime+    , fileTimeToLocalFileTime+    , localFileTimeToFileTime+    , queryPerformanceFrequency+    , queryPerformanceCounter+    , GetTimeFormatFlags+    , lOCALE_NOUSEROVERRIDE+    , lOCALE_USE_CP_ACP+    , tIME_NOMINUTESORSECONDS+    , tIME_NOSECONDS+    , tIME_NOTIMEMARKER+    , tIME_FORCE24HOURFORMAT+    , getTimeFormatEx+    , getTimeFormat+    ) where -import System.Win32.Types   ( DWORD, WORD, LONG, BOOL, failIf, failIf_, HANDLE-                            , peekTStringLen, LCID, LPTSTR, LPCTSTR, DDWORD-                            , LARGE_INTEGER, ddwordToDwords, dwordsToDdword )+import System.Win32.Time.Internal+import System.Win32.String  ( peekTStringLen, withTString )+import System.Win32.Types   ( DWORD, HANDLE, LCID+                            , failIf+                            , failIfFalse_, failIf_ )+import System.Win32.Utils   ( trySized ) -import Control.Monad    ( when, liftM3, liftM )-import Data.Word        ( Word8 )-import Foreign          ( Storable(sizeOf, alignment, peekByteOff, peek,-                                   pokeByteOff, poke)-                        , Ptr, nullPtr, castPtr, plusPtr, advancePtr-                        , with, alloca, allocaBytes, copyArray )-import Foreign.C        ( CInt(..), CWchar(..)-                        , peekCWString, withCWStringLen, withCWString )+import Control.Monad    ( liftM3, liftM )+import Foreign          ( Storable(sizeOf, peek)+                        , Ptr, nullPtr, castPtr+                        , with, alloca, allocaBytes )+import Foreign.C        ( CWchar(..)+                        , withCWString )+import Foreign.Marshal.Utils (maybeWith) -#include "windows.h"+##include "windows_cconv.h"+#include <windows.h>+#include "alignment.h"+#include "winnls_compat.h" -------------------------------------------------------------------- data types----------------------------------------------------------------- -newtype FILETIME = FILETIME DDWORD deriving (Show, Eq, Ord)--data SYSTEMTIME = SYSTEMTIME {-    wYear, wMonth, wDayOfWeek, wDay, wHour, wMinute, wSecond, wMilliseconds :: WORD }-    deriving (Show, Eq, Ord)--data TIME_ZONE_INFORMATION = TIME_ZONE_INFORMATION-    { tziBias :: LONG-    , tziStandardName :: String-    , tziStandardDate :: SYSTEMTIME-    , tziStandardBias :: LONG-    , tziDaylightName :: String-    , tziDaylightDate :: SYSTEMTIME-    , tziDaylightBias :: LONG-    } deriving (Show,Eq,Ord)--data TimeZoneId = TzIdUnknown | TzIdStandard | TzIdDaylight-    deriving (Show, Eq, Ord)--------------------------------------------------------------------- Instances-------------------------------------------------------------------instance Storable FILETIME where-    sizeOf = const (#size FILETIME)-    alignment = sizeOf-    poke buf (FILETIME n) = do-        (#poke FILETIME, dwLowDateTime) buf low-        (#poke FILETIME, dwHighDateTime) buf hi-        where (hi,low) = ddwordToDwords n-    peek buf = do-        low <- (#peek FILETIME, dwLowDateTime) buf-        hi <- (#peek FILETIME, dwHighDateTime) buf-        return $ FILETIME $ dwordsToDdword (hi,low)--instance Storable SYSTEMTIME where-    sizeOf _ = #size SYSTEMTIME-    alignment = sizeOf-    poke buf st = do-         (#poke SYSTEMTIME, wYear)          buf (wYear st)-         (#poke SYSTEMTIME, wMonth)         buf (wMonth st)-         (#poke SYSTEMTIME, wDayOfWeek)     buf (wDayOfWeek st)-         (#poke SYSTEMTIME, wDay)           buf (wDay st)-         (#poke SYSTEMTIME, wHour)          buf (wHour st)-         (#poke SYSTEMTIME, wMinute)        buf (wMinute st)-         (#poke SYSTEMTIME, wSecond)        buf (wSecond st)-         (#poke SYSTEMTIME, wMilliseconds)  buf (wMilliseconds st)-    peek buf = do-        year    <- (#peek SYSTEMTIME, wYear)        buf-        month   <- (#peek SYSTEMTIME, wMonth)       buf-        dow     <- (#peek SYSTEMTIME, wDayOfWeek)   buf-        day     <- (#peek SYSTEMTIME, wDay)         buf-        hour    <- (#peek SYSTEMTIME, wHour)        buf-        min     <- (#peek SYSTEMTIME, wMinute)      buf-        sec     <- (#peek SYSTEMTIME, wSecond)      buf-        ms      <- (#peek SYSTEMTIME, wMilliseconds) buf-        return $ SYSTEMTIME year month dow day hour min sec ms--instance Storable TIME_ZONE_INFORMATION where-    sizeOf _ = (#size TIME_ZONE_INFORMATION)-    alignment = sizeOf-    poke buf tzi = do-        (#poke TIME_ZONE_INFORMATION, Bias) buf (tziBias tzi)-        (#poke TIME_ZONE_INFORMATION, StandardDate) buf (tziStandardDate tzi)-        (#poke TIME_ZONE_INFORMATION, StandardBias) buf (tziStandardBias tzi)-        (#poke TIME_ZONE_INFORMATION, DaylightDate) buf (tziDaylightDate tzi)-        (#poke TIME_ZONE_INFORMATION, DaylightBias) buf (tziDaylightBias tzi)-        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-                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-    peek buf = do-        bias <- (#peek TIME_ZONE_INFORMATION, Bias)         buf-        sdat <- (#peek TIME_ZONE_INFORMATION, StandardDate) buf-        sbia <- (#peek TIME_ZONE_INFORMATION, StandardBias) buf-        ddat <- (#peek TIME_ZONE_INFORMATION, DaylightDate) buf-        dbia <- (#peek TIME_ZONE_INFORMATION, DaylightBias) buf-        snam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, StandardName))-        dnam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, DaylightName))-        return $ TIME_ZONE_INFORMATION bias snam sdat sbia dnam ddat dbia--foreign import stdcall "windows.h GetSystemTime"-    c_GetSystemTime :: Ptr SYSTEMTIME -> IO () getSystemTime :: IO SYSTEMTIME getSystemTime = alloca $ \res -> do     c_GetSystemTime res     peek res -foreign import stdcall "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 stdcall "windows.h GetSystemTimeAsFileTime"-    c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO () getSystemTimeAsFileTime :: IO FILETIME getSystemTimeAsFileTime = alloca $ \ret -> do     c_GetSystemTimeAsFileTime ret     peek ret -foreign import stdcall "windows.h GetLocalTime"-    c_GetLocalTime :: Ptr SYSTEMTIME -> IO () getLocalTime :: IO SYSTEMTIME getLocalTime = alloca $ \res -> do     c_GetLocalTime res     peek res -foreign import stdcall "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 stdcall "windows.h GetSystemTimeAdjustment"-    c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL getSystemTimeAdjustment :: IO (Maybe (Int, Int)) 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 stdcall "windows.h GetTickCount" getTickCount :: IO DWORD+getLastInputInfo :: IO DWORD+getLastInputInfo =+  with (LASTINPUTINFO 0) $ \lii_p -> do+  failIfFalse_ "GetLastInputInfo" $ c_GetLastInputInfo lii_p+  LASTINPUTINFO lii <- peek lii_p+  return lii -foreign import stdcall "windows.h SetSystemTimeAdjustment"-    c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL+getIdleTime :: IO Integer+getIdleTime = do+  lii <- getLastInputInfo+  now <- getTickCount+  return $ fromIntegral $ now - lii+ setSystemTimeAdjustment :: Maybe Int -> IO () setSystemTimeAdjustment ta =     failIf_ not "setSystemTimeAjustment: SetSystemTimeAdjustment" $@@ -181,67 +130,63 @@             Nothing -> (0,True)             Just x  -> (fromIntegral x,False) -foreign import stdcall "windows.h GetTimeZoneInformation"-    c_GetTimeZoneInformation :: Ptr TIME_ZONE_INFORMATION -> IO DWORD getTimeZoneInformation :: IO (TimeZoneId, TIME_ZONE_INFORMATION) 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         _                               -> TzIdUnknown   -- to remove warning -foreign import stdcall "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 stdcall "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 stdcall "windows.h GetFileTime"-    c_GetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL getFileTime :: HANDLE -> IO (FILETIME,FILETIME,FILETIME) getFileTime h = alloca $ \crt -> alloca $ \acc -> alloca $ \wrt -> do     failIf_ not "getFileTime: GetFileTime" $ c_GetFileTime h crt acc wrt     liftM3 (,,) (peek crt) (peek acc) (peek wrt) -foreign import stdcall "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+invalidFileTime :: FILETIME+invalidFileTime = FILETIME 0 -foreign import stdcall "windows.h FileTimeToLocalFileTime"-    c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL+setFileTime :: HANDLE -> Maybe FILETIME -> Maybe FILETIME -> Maybe FILETIME -> IO ()+setFileTime h crt acc wrt = withTime crt $+    \c_crt -> withTime acc $+    \c_acc -> withTime wrt $+    \c_wrt -> do+      failIf_ not "setFileTime: SetFileTime" $ c_SetFileTime h c_crt c_acc c_wrt+  where+    withTime :: Maybe FILETIME -> (Ptr FILETIME -> IO a) -> IO a+    withTime Nothing k  = k nullPtr+    withTime (Just t) k = with t k+ 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 stdcall "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  {- -- Windows XP SP1-foreign import stdcall "windows.h GetSystemTimes"+foreign import WINDOWS_CCONV "windows.h GetSystemTimes"     c_GetSystemTimes :: Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL getSystemTimes :: IO (FILETIME,FILETIME,FILETIME) getSystemTimes = alloca $ \idle -> alloca $ \kernel -> alloca $ \user -> do@@ -251,7 +196,7 @@  {- -- Windows XP-foreign import stdcall "windows.h SystemTimeToTzSpecificLocalTime"+foreign import WINDOWS_CCONV "windows.h SystemTimeToTzSpecificLocalTime"     c_SystemTimeToTzSpecificLocalTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL systemTimeToTzSpecificLocalTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME systemTimeToTzSpecificLocalTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do@@ -259,7 +204,7 @@         c_SystemTimeToTzSpecificLocalTime tzi st res     peek res -foreign import stdcall "windows.h TzSpecificLocalTimeToSystemTime"+foreign import WINDOWS_CCONV "windows.h TzSpecificLocalTimeToSystemTime"     c_TzSpecificLocalTimeToSystemTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL tzSpecificLocalTimeToSystemTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME tzSpecificLocalTimeToSystemTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do@@ -268,40 +213,37 @@     peek res -} -foreign import stdcall "windows.h QueryPerformanceFrequency"-    c_QueryPerformanceFrequency :: Ptr LARGE_INTEGER -> IO BOOL queryPerformanceFrequency :: IO Integer queryPerformanceFrequency = alloca $ \res -> do     failIf_ not "queryPerformanceFrequency: QueryPerformanceFrequency" $         c_QueryPerformanceFrequency res     liftM fromIntegral $ peek res -foreign import stdcall "windows.h QueryPerformanceCounter"-    c_QueryPerformanceCounter:: Ptr LARGE_INTEGER -> IO BOOL queryPerformanceCounter:: IO Integer queryPerformanceCounter= alloca $ \res -> do     failIf_ not "queryPerformanceCounter: QueryPerformanceCounter" $         c_QueryPerformanceCounter res     liftM fromIntegral $ peek res -type GetTimeFormatFlags = DWORD-#{enum GetTimeFormatFlags,-    , lOCALE_NOUSEROVERRIDE = LOCALE_NOUSEROVERRIDE-    , lOCALE_USE_CP_ACP     = LOCALE_USE_CP_ACP-    , tIME_NOMINUTESORSECONDS = TIME_NOMINUTESORSECONDS-    , tIME_NOSECONDS        = TIME_NOSECONDS-    , tIME_NOTIMEMARKER     = TIME_NOTIMEMARKER-    , tIME_FORCE24HOURFORMAT= TIME_FORCE24HOURFORMAT-    } -foreign import stdcall "windows.h GetTimeFormatW"-    c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt-getTimeFormat :: LCID -> GetTimeFormatFlags -> SYSTEMTIME -> String -> IO String+getTimeFormatEx :: Maybe String+                -> GetTimeFormatFlags+                -> Maybe SYSTEMTIME+                -> Maybe String+                -> IO String+getTimeFormatEx locale flags st fmt =+    maybeWith withTString locale $ \c_locale ->+        maybeWith with st $ \c_st ->+            maybeWith withTString fmt $ \c_fmt -> do+                let c_func = c_GetTimeFormatEx c_locale flags c_st c_fmt+                trySized "GetTimeFormatEx" c_func++getTimeFormat :: LCID -> GetTimeFormatFlags -> Maybe SYSTEMTIME -> Maybe String -> IO String getTimeFormat locale flags st fmt =-    with st $ \st ->-    withCWString fmt $ \fmt -> do-        size <- c_GetTimeFormat locale flags st fmt nullPtr 0+    maybeWith with st $ \c_st ->+    maybeWith 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')

+ System/Win32/Time/Internal.hsc view

@@ -0,0 +1,245 @@+#if __GLASGOW_HASKELL__ >= 709+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.Time.Internal+-- Copyright   :  (c) Esa Ilari Vuokko, 2006+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of FFI declarations for interfacing with Win32 Time API.+--+-----------------------------------------------------------------------------+module System.Win32.Time.Internal where++import System.Win32.Types   ( BOOL, DDWORD, DWORD, HANDLE, LARGE_INTEGER, LCID+                            , LONG, LPCTSTR, LPCWSTR, LPTSTR, LPWSTR, UINT, WORD+                            , dwordsToDdword, ddwordToDwords+                            )+import Control.Monad    ( when )+import Data.Word        ( Word8 )+import Foreign          ( Storable(sizeOf, alignment, peekByteOff, peek,+                                   pokeByteOff, poke)+                        , Ptr, castPtr, plusPtr, advancePtr+                        , copyArray )+import Foreign.C        ( CInt(..), CWchar(..)+                        , peekCWString, withCWStringLen )++##include "windows_cconv.h"+#include <windows.h>+#include "alignment.h"+#include "winnls_compat.h"++----------------------------------------------------------------+-- data types+----------------------------------------------------------------++newtype FILETIME = FILETIME DDWORD deriving (Show, Eq, Ord)++data SYSTEMTIME = SYSTEMTIME {+    wYear, wMonth, wDayOfWeek, wDay, wHour, wMinute, wSecond, wMilliseconds :: WORD }+    deriving (Show, Eq, Ord)++data TIME_ZONE_INFORMATION = TIME_ZONE_INFORMATION+    { tziBias :: LONG+    , tziStandardName :: String+    , tziStandardDate :: SYSTEMTIME+    , tziStandardBias :: LONG+    , tziDaylightName :: String+    , tziDaylightDate :: SYSTEMTIME+    , tziDaylightBias :: LONG+    } deriving (Show,Eq,Ord)++data TimeZoneId = TzIdUnknown | TzIdStandard | TzIdDaylight+    deriving (Show, Eq, Ord)++data LASTINPUTINFO = LASTINPUTINFO DWORD deriving (Show)++----------------------------------------------------------------+-- Instances+----------------------------------------------------------------++instance Storable FILETIME where+    sizeOf = const (#size FILETIME)+    alignment _ = #alignment FILETIME+    poke buf (FILETIME n) = do+        (#poke FILETIME, dwLowDateTime) buf low+        (#poke FILETIME, dwHighDateTime) buf hi+        where (hi,low) = ddwordToDwords n+    peek buf = do+        low <- (#peek FILETIME, dwLowDateTime) buf+        hi <- (#peek FILETIME, dwHighDateTime) buf+        return $ FILETIME $ dwordsToDdword (hi,low)++instance Storable SYSTEMTIME where+    sizeOf _ = #size SYSTEMTIME+    alignment _ = #alignment SYSTEMTIME+    poke buf st = do+         (#poke SYSTEMTIME, wYear)          buf (wYear st)+         (#poke SYSTEMTIME, wMonth)         buf (wMonth st)+         (#poke SYSTEMTIME, wDayOfWeek)     buf (wDayOfWeek st)+         (#poke SYSTEMTIME, wDay)           buf (wDay st)+         (#poke SYSTEMTIME, wHour)          buf (wHour st)+         (#poke SYSTEMTIME, wMinute)        buf (wMinute st)+         (#poke SYSTEMTIME, wSecond)        buf (wSecond st)+         (#poke SYSTEMTIME, wMilliseconds)  buf (wMilliseconds st)+    peek buf = do+        year    <- (#peek SYSTEMTIME, wYear)        buf+        month   <- (#peek SYSTEMTIME, wMonth)       buf+        dow     <- (#peek SYSTEMTIME, wDayOfWeek)   buf+        day     <- (#peek SYSTEMTIME, wDay)         buf+        hour    <- (#peek SYSTEMTIME, wHour)        buf+        mins    <- (#peek SYSTEMTIME, wMinute)      buf+        sec     <- (#peek SYSTEMTIME, wSecond)      buf+        ms      <- (#peek SYSTEMTIME, wMilliseconds) buf+        return $ SYSTEMTIME year month dow day hour mins sec ms++instance Storable TIME_ZONE_INFORMATION where+    sizeOf _ = (#size TIME_ZONE_INFORMATION)+    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)+        (#poke TIME_ZONE_INFORMATION, StandardBias) buf (tziStandardBias tzi)+        (#poke TIME_ZONE_INFORMATION, DaylightDate) buf (tziDaylightDate tzi)+        (#poke TIME_ZONE_INFORMATION, DaylightBias) buf (tziDaylightBias tzi)+        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 $ \(c_str,len) -> do+                when (len>31) $ fail "Storable TIME_ZONE_INFORMATION.poke: Too long string."+                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+        sbia <- (#peek TIME_ZONE_INFORMATION, StandardBias) buf+        ddat <- (#peek TIME_ZONE_INFORMATION, DaylightDate) buf+        dbia <- (#peek TIME_ZONE_INFORMATION, DaylightBias) buf+        snam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, StandardName))+        dnam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, DaylightName))+        return $ TIME_ZONE_INFORMATION bias snam sdat sbia dnam ddat dbia++instance Storable LASTINPUTINFO where+    sizeOf = const (#size LASTINPUTINFO)+    alignment = sizeOf+    poke buf (LASTINPUTINFO t) = do+        (#poke LASTINPUTINFO, cbSize) buf ((#size LASTINPUTINFO) :: UINT)+        (#poke LASTINPUTINFO, dwTime) buf t+    peek buf = do+        t <- (#peek LASTINPUTINFO, dwTime) buf+        return $ LASTINPUTINFO t++foreign import WINDOWS_CCONV "windows.h GetSystemTime"+    c_GetSystemTime :: Ptr SYSTEMTIME -> IO ()++foreign import WINDOWS_CCONV "windows.h SetSystemTime"+    c_SetSystemTime :: Ptr SYSTEMTIME -> IO BOOL++foreign import WINDOWS_CCONV "windows.h GetSystemTimeAsFileTime"+    c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO ()++foreign import WINDOWS_CCONV "windows.h GetLocalTime"+    c_GetLocalTime :: Ptr SYSTEMTIME -> IO ()++foreign import WINDOWS_CCONV "windows.h SetLocalTime"+    c_SetLocalTime :: Ptr SYSTEMTIME -> IO BOOL++foreign import WINDOWS_CCONV "windows.h GetSystemTimeAdjustment"+    c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL++foreign import WINDOWS_CCONV "windows.h GetTickCount" getTickCount :: IO DWORD++foreign import WINDOWS_CCONV unsafe "windows.h GetLastInputInfo"+  c_GetLastInputInfo :: Ptr LASTINPUTINFO -> IO Bool++foreign import WINDOWS_CCONV "windows.h SetSystemTimeAdjustment"+    c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL++foreign import WINDOWS_CCONV "windows.h GetTimeZoneInformation"+    c_GetTimeZoneInformation :: Ptr TIME_ZONE_INFORMATION -> IO DWORD++foreign import WINDOWS_CCONV "windows.h SystemTimeToFileTime"+    c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL++foreign import WINDOWS_CCONV "windows.h FileTimeToSystemTime"+    c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL++foreign import WINDOWS_CCONV "windows.h GetFileTime"+    c_GetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL++foreign import WINDOWS_CCONV "windows.h SetFileTime"+    c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL++foreign import WINDOWS_CCONV "windows.h FileTimeToLocalFileTime"+    c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL++foreign import WINDOWS_CCONV "windows.h LocalFileTimeToFileTime"+    c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL++{-+-- Windows XP SP1+foreign import WINDOWS_CCONV "windows.h GetSystemTimes"+    c_GetSystemTimes :: Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL+getSystemTimes :: IO (FILETIME,FILETIME,FILETIME)+getSystemTimes = alloca $ \idle -> alloca $ \kernel -> alloca $ \user -> do+    failIf not "getSystemTimes: GetSystemTimes" $ c_GetSystemTimes idle kernel user+    liftM3 (,,) (peek idle) (peek kernel) (peek user)+-}++{-+-- Windows XP+foreign import WINDOWS_CCONV "windows.h SystemTimeToTzSpecificLocalTime"+    c_SystemTimeToTzSpecificLocalTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL+systemTimeToTzSpecificLocalTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME+systemTimeToTzSpecificLocalTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do+    failIf not "systemTimeToTzSpecificLocalTime: SystemTimeToTzSpecificLocalTime" $+        c_SystemTimeToTzSpecificLocalTime tzi st res+    peek res++foreign import WINDOWS_CCONV "windows.h TzSpecificLocalTimeToSystemTime"+    c_TzSpecificLocalTimeToSystemTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL+tzSpecificLocalTimeToSystemTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME+tzSpecificLocalTimeToSystemTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do+    failIf not "tzSpecificLocalTimeToSystemTime: TzSpecificLocalTimeToSystemTime" $+        c_TzSpecificLocalTimeToSystemTime tzi st res+    peek res+-}++foreign import WINDOWS_CCONV "windows.h QueryPerformanceFrequency"+    c_QueryPerformanceFrequency :: Ptr LARGE_INTEGER -> IO BOOL++foreign import WINDOWS_CCONV "windows.h QueryPerformanceCounter"+    c_QueryPerformanceCounter:: Ptr LARGE_INTEGER -> IO BOOL++type GetTimeFormatFlags = DWORD+#{enum GetTimeFormatFlags,+    , lOCALE_NOUSEROVERRIDE = LOCALE_NOUSEROVERRIDE+    , lOCALE_USE_CP_ACP     = LOCALE_USE_CP_ACP+    , tIME_NOMINUTESORSECONDS = TIME_NOMINUTESORSECONDS+    , tIME_NOSECONDS        = TIME_NOSECONDS+    , tIME_NOTIMEMARKER     = TIME_NOTIMEMARKER+    , tIME_FORCE24HOURFORMAT= TIME_FORCE24HOURFORMAT+    }++foreign import WINDOWS_CCONV "windows.h GetTimeFormatEx"+    c_GetTimeFormatEx :: LPCWSTR+                      -> GetTimeFormatFlags+                      -> Ptr SYSTEMTIME+                      -> LPCWSTR+                      -> LPWSTR+                      -> CInt+                      -> IO CInt++foreign import WINDOWS_CCONV "windows.h GetTimeFormatW"+    c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt

− System/Win32/Types.hs

@@ -1,307 +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 Data.Maybe-import Foreign hiding (unsafePerformIO)-import Foreign.C-import Control.Exception-import System.IO.Error-import System.IO.Unsafe-import Data.Char-import Numeric (showHex)--------------------------------------------------------------------- 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---- Not really a basic type, but used in many places-type DDWORD        = Word64--------------------------------------------------------------------type MbString      = Maybe String-type MbINT         = Maybe INT--type ATOM          = UINT-type WPARAM        = UINT-type LPARAM        = LONG-type LRESULT       = LONG-type SIZE_T        = DWORD--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-handleToWord = castPtrToUINT--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 = castUINTToPtr 0xffffffff--------------------------------------------------------------------- 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'-  throw 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` bitSize (undefined::DWORD))-        ,fromIntegral (n .&. fromIntegral (maxBound :: DWORD)))--dwordsToDdword:: (DWORD,DWORD) -> DDWORD-dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL`bitSize hi)--------------------------------------------------------------------- Primitives-------------------------------------------------------------------{-# CFILES cbits/HsWin32.c #-}-foreign import ccall "HsWin32.h &DeleteObjectFinaliser"-  deleteObjectFinaliser :: FunPtr (Ptr a -> IO ())--foreign import stdcall unsafe "windows.h LocalFree"-  localFree :: Ptr a -> IO (Ptr a)--foreign import stdcall 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"-  castUINTToPtr :: UINT -> Ptr a--foreign import ccall unsafe "HsWin32.h"-  castPtrToUINT :: Ptr s -> UINT--foreign import ccall unsafe "HsWin32.h"-  castFunPtrToLONG :: FunPtr a -> LONG--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-----------------------------------------------------------------

+ System/Win32/Types.hsc view

@@ -0,0 +1,578 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- 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.Concurrent.MVar (readMVar)+import Control.Exception (bracket, throwIO)+import Data.Bits (shiftL, shiftR, (.|.), (.&.))+import Data.Char (isSpace)+import Data.Int (Int32, Int64, Int16)+import Data.Maybe (fromMaybe)+import Data.Typeable (cast)+import Data.Word (Word8, Word16, Word32, Word64)+import Foreign.C.Error (Errno(..), errnoToIOError)+import Foreign.C.String (newCWString, withCWStringLen, CWString)+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, ptrToIntPtr)+import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr)+import Foreign (allocaArray)+import GHC.IO.Exception+import GHC.IO.FD (FD(..))+import GHC.IO.Handle.FD (fdToHandle)+import GHC.IO.Handle.Types (Handle(..), Handle__(..))+import Numeric (showHex)+import qualified System.IO as IO ()+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++##if defined(__IO_MANAGER_WINIO__)+import Control.Monad (when, liftM2)+import Foreign.C.Types (CUIntPtr(..))+import Foreign.Marshal.Utils (fromBool, with)+import Foreign (peek)+import Foreign.Ptr (ptrToWordPtr)+import GHC.IO.SubSystem ((<!>))+import GHC.IO.Handle.Windows+import GHC.IO.IOMode+import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle(), ConsoleHandle(),+                              toHANDLE, handleToMode, optimizeFileAccess)+import qualified GHC.Event.Windows as Mgr+import GHC.IO.Device (IODeviceType(..), devType)+##endif++#include <fcntl.h>+#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 INT_PTR       = Ptr CInt+type ULONG         = Word32+type UINT_PTR      = Word+type LONG_PTR      = CIntPtr+type ULONG_PTR     = CUIntPtr+type DWORD_PTR     = ULONG_PTR+#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+withFilePath   :: FilePath -> (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+withFilePath path = useAsCWStringSafe path+withTStringLen = withCWStringLen+peekTString    = peekCWString+peekTStringLen = peekCWStringLen+newTString     = newCWString++{- ANSI version:+type TCHAR     = CChar+withTString    = withCString+withTStringLen = withCStringLen+peekTString    = peekCString+peekTStringLen = peekCStringLen+newTString     = newCString+-}++-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL codepoints as these are+-- disallowed in Windows filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660+useAsCWStringSafe :: FilePath -> (CWString -> IO a) -> IO a+useAsCWStringSafe path f =+    if '\NUL' `elem` path+    then ioError err+    else withCWString path f+  where+    err =+        IOError+          { ioe_handle = Nothing+          , ioe_type = InvalidArgument+          , ioe_location = "useAsCWStringSafe"+          , ioe_description = "Windows filepaths must not contain internal NUL codepoints."+          , ioe_errno = Nothing+          , ioe_filename = Just path+          }+++----------------------------------------------------------------+-- 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++nullHINSTANCE :: HINSTANCE+nullHINSTANCE = nullPtr++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 maxBound++iNVALID_SET_FILE_POINTER :: DWORD+iNVALID_SET_FILE_POINTER = #const INVALID_SET_FILE_POINTER++foreign import ccall "_open_osfhandle"+  _open_osfhandle :: CIntPtr -> CInt -> IO CInt++-- | Create a Haskell 'Handle' from a Windows 'HANDLE'.+--+-- Beware that this function allocates a new file descriptor. A consequence of+-- this is that calling 'hANDLEToHandle' on the standard Windows handles will+-- not give you 'IO.stdin', 'IO.stdout', or 'IO.stderr'. For example, if you+-- run this code:+--+-- @+-- import Graphics.Win32.Misc+-- stdoutHANDLE <- getStdHandle sTD_OUTPUT_HANDLE+-- stdout2 <- 'hANDLEToHandle' stdoutHANDLE+-- @+--+-- Then although you can use @stdout2@ to write to standard output, it is not+-- the case that @'IO.stdout' == stdout2@.+hANDLEToHandle :: HANDLE -> IO Handle+hANDLEToHandle handle = posix+##if defined(__IO_MANAGER_WINIO__)+     <!> native+##endif+  where+##if defined(__IO_MANAGER_WINIO__)+    native = do+      -- Attach the handle to the I/O manager's CompletionPort.  This allows the+      -- I/O manager to service requests for this Handle.+      Mgr.associateHandle' handle+      let hwnd = fromHANDLE handle :: Io NativeHandle+      _type <- devType hwnd++      -- Use the rts to enforce any file locking we may need.+      mode <- handleToMode handle+      let write_lock = mode /= ReadMode++      case _type of+        -- Regular files need to be locked.+        -- See also Note [RTS File locking]+        RegularFile -> do+          optimizeFileAccess handle -- Set a few optimization flags on file handles.+          (unique_dev, unique_ino) <- getUniqueFileInfo handle+          r <- internal_lockFile+                  (fromIntegral $ ptrToWordPtr handle) unique_dev unique_ino+                  (fromBool write_lock)+          when (r == -1)  $+               ioException (IOError Nothing ResourceBusy "hANDLEToHandle"+                                  "file is locked" Nothing Nothing)++        -- I don't see a reason for blocking directories.  So unlike the FD+        -- implementation I'll allow it.+        _ -> return ()+      mkHandleFromHANDLE hwnd Stream ("hwnd:" ++ show handle) mode Nothing++    -- | getUniqueFileInfo assumes the C call to getUniqueFileInfo+    -- succeeds.+    getUniqueFileInfo :: HANDLE -> IO (Word64, Word64)+    getUniqueFileInfo hnl = do+      with 0 $ \devptr -> do+        with 0 $ \inoptr -> do+          internal_getUniqueFileInfo hnl devptr inoptr+          liftM2 (,) (peek devptr) (peek inoptr)+##endif+    posix = _open_osfhandle (fromIntegral (ptrToIntPtr handle))+                            (#const _O_BINARY) >>= fdToHandle++##if defined(__IO_MANAGER_WINIO__)+foreign import ccall unsafe "lockFile"+  internal_lockFile :: CUIntPtr -> Word64 -> Word64 -> CInt -> IO CInt++-- | Returns -1 on error. Otherwise writes two values representing+-- the file into the given ptrs.+foreign import ccall unsafe "get_unique_file_info_hwnd"+  internal_getUniqueFileInfo :: HANDLE -> Ptr Word64 -> Ptr Word64 -> IO ()+##endif++foreign import ccall unsafe "_get_osfhandle"+  c_get_osfhandle :: CInt -> IO HANDLE++-- | Extract a Windows 'HANDLE' from a Haskell 'Handle' and perform+-- an action on it.++-- Originally authored by Max Bolingbroke in the ansi-terminal library+withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a+##if defined(__IO_MANAGER_WINIO__)+withHandleToHANDLE = withHandleToHANDLEPosix <!> withHandleToHANDLENative+##else+withHandleToHANDLE = withHandleToHANDLEPosix+##endif++##if defined(__IO_MANAGER_WINIO__)+withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a+withHandleToHANDLENative haskell_handle action =+    -- Create a stable pointer to the Handle. This prevents the garbage collector+    -- getting to it while we are doing horrible manipulations with it, and hence+    -- stops it being finalized (and closed).+    withStablePtr haskell_handle $ const $ do+        -- Grab the write handle variable from the Handle+        let write_handle_mvar = case haskell_handle of+                FileHandle _ handle_mvar     -> handle_mvar+                DuplexHandle _ _ handle_mvar -> handle_mvar++        -- This is "write" MVar, we could also take the "read" one+        windows_handle <- readMVar write_handle_mvar >>= handle_ToHANDLE++        -- Do what the user originally wanted+        action windows_handle+  where+    -- | Turn an existing Handle into a Win32 HANDLE. This function throws an+    -- IOError if the Handle does not reference a HANDLE+    handle_ToHANDLE :: Handle__ -> IO HANDLE+    handle_ToHANDLE (Handle__{haDevice = dev}) =+        case (cast dev :: Maybe (Io NativeHandle), cast dev :: Maybe (Io ConsoleHandle)) of+          (Just hwnd, Nothing) -> return $ toHANDLE hwnd+          (Nothing, Just hwnd) -> return $ toHANDLE hwnd+          _                    -> throwErr "not a known HANDLE"++    throwErr msg = ioException $ IOError (Just haskell_handle)+      InappropriateType "withHandleToHANDLENative" msg Nothing Nothing+##endif++withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a+withHandleToHANDLEPosix haskell_handle action =+    -- Create a stable pointer to the Handle. This prevents the garbage collector+    -- getting to it while we are doing horrible manipulations with it, and hence+    -- stops it being finalized (and closed).+    withStablePtr haskell_handle $ const $ do+        -- Grab the write handle variable from the Handle+        let write_handle_mvar = case haskell_handle of+                FileHandle _ handle_mvar     -> handle_mvar+                DuplexHandle _ _ handle_mvar -> handle_mvar+                  -- This is "write" MVar, we could also take the "read" one++        -- Get the FD from the algebraic data type+        Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev))+                 $ readMVar write_handle_mvar++        -- Finally, turn that (C-land) FD into a HANDLE using msvcrt+        windows_handle <- c_get_osfhandle fd+        -- Do what the user originally wanted+        action windows_handle++withStablePtr :: a -> (StablePtr a -> IO b) -> IO b+withStablePtr value = bracket (newStablePtr value) freeStablePtr++----------------------------------------------------------------+-- 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++eERROR_ENVVAR_NOT_FOUND :: ErrCode+eERROR_ENVVAR_NOT_FOUND = #const ERROR_ENVVAR_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+----------------------------------------------------------------

+ System/Win32/Utils.hs view

@@ -0,0 +1,410 @@+{- |
+   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, trySized, try'
+  -- * Maybe values
+  , maybePtr, ptrToMaybe, maybeNum, numToMaybe
+  , peekMaybe, withMaybe
+  -- * Format picture translation
+  , fromDateFormatPicture
+  , fromTimeFormatPicture
+  ) where
+
+import Control.Monad               ( unless )
+import Foreign.C.Types             ( CInt )
+import Foreign.Marshal.Array       ( allocaArray, peekArray )
+import Foreign.Marshal.Utils       ( with )
+import Foreign.Ptr                 ( Ptr, nullPtr )
+import Foreign.Storable            ( Storable(..) )
+import Text.ParserCombinators.ReadP ( ReadP, (<++), between, char, count
+                                    , readP_to_S, satisfy )
+
+
+import System.Win32.String         ( LPTSTR, peekTString, peekTStringLen
+                                   , withTStringBufferLen )
+import System.Win32.Types          ( BOOL, UINT, eRROR_INSUFFICIENT_BUFFER
+                                   , failIfZero, failWith, getLastError
+                                   , maybeNum, maybePtr, numToMaybe
+                                   , ptrToMaybe )
+import qualified System.Win32.Types ( try )
+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
+
+-- | Support for API calls that return the required size, in characters
+-- including a null character, of the buffer when passed a buffer size of zero.
+trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO String
+trySized wh f = do
+    c_len <- failIfZero wh $ f nullPtr 0
+    let len = fromIntegral c_len
+    withTStringBufferLen len $ \(buf', len') -> do
+        let c_len' = fromIntegral len'
+        c_len'' <- failIfZero wh $ f buf' c_len'
+        let len'' = fromIntegral c_len''
+        peekTStringLen (buf', len'' - 1) -- Drop final null character
+
+-- | 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
+
+-- | Type representing components of a Windows API day, month, year and era
+-- format picture.
+data DateFormatPicture
+  = Day
+  | Day0 -- Padded with zeros
+  | DayShort
+  | DayLong
+  | Month
+  | Month0 -- Padded with zeros
+  | MonthShort
+  | MonthLong
+  | YearVeryShort -- Year represented only by the last digit
+  | YearShort
+  | Year
+  | Era
+  | DateOther String
+  deriving (Eq, Show)
+
+fromDFP :: DateFormatPicture -> String
+fromDFP Day = "%-e" -- No padding
+fromDFP Day0 = "%d" -- Padded with zeros
+fromDFP DayShort = "%a" -- eg Tue
+fromDFP DayLong = "%A" -- eg Tuesday
+fromDFP Month = "%-m" -- No padding
+fromDFP Month0 = "%m" -- Padded with zeros
+fromDFP MonthShort = "%b" -- eg Jan
+fromDFP MonthLong = "%B" -- eg January
+fromDFP YearVeryShort = "%-y" -- No direct equivalent of a one digit year, so
+                              -- do not distinguish from a short year without
+                              -- padding
+fromDFP YearShort = "%y"
+fromDFP Year = "%Y"
+fromDFP Era = "" -- No equivalent
+fromDFP (DateOther cs) = escape cs
+
+escape :: String -> String
+escape [] = []
+escape (c:cs) = escape' c ++ escape cs
+ where
+  escape' '%' = "%%"
+  escape' '\t' = "%t"
+  escape' '\n' = "%n"
+  escape' c' = [c']
+
+d :: ReadP Char
+d = char 'd'
+
+day :: ReadP DateFormatPicture
+day = do
+  _ <- d
+  return Day
+
+day0 :: ReadP DateFormatPicture
+day0 = do
+  _ <- count 2 d
+  return Day0
+
+dayShort :: ReadP DateFormatPicture
+dayShort = do
+  _ <- count 3 d
+  return DayShort
+
+dayLong :: ReadP DateFormatPicture
+dayLong = do
+  _ <- count 4 d
+  return DayLong
+
+days :: ReadP DateFormatPicture
+days = dayLong <++ dayShort <++ day0 <++ day
+
+bigM :: ReadP Char
+bigM = char 'M'
+
+month :: ReadP DateFormatPicture
+month = do
+  _ <- bigM
+  return Month
+
+month0 :: ReadP DateFormatPicture
+month0 = do
+  _ <- count 2 bigM
+  return Month0
+
+monthShort :: ReadP DateFormatPicture
+monthShort = do
+  _ <- count 3 bigM
+  return MonthShort
+
+monthLong :: ReadP DateFormatPicture
+monthLong = do
+  _ <- count 4 bigM
+  return MonthLong
+
+months :: ReadP DateFormatPicture
+months = monthLong <++ monthShort <++ month0 <++ month
+
+y :: ReadP Char
+y = char 'y'
+
+yearVeryShort :: ReadP DateFormatPicture
+yearVeryShort = do
+  _ <- y
+  return YearVeryShort
+
+yearShort :: ReadP DateFormatPicture
+yearShort = do
+  _ <- count 2 y
+  return YearShort
+
+year :: ReadP DateFormatPicture
+year = do
+  _ <- count 5 y <++ count 4 y
+  return Year
+
+years :: ReadP DateFormatPicture
+years = year <++ yearShort <++ yearVeryShort
+
+g :: ReadP Char
+g = char 'g'
+
+era :: ReadP DateFormatPicture
+era = do
+  _ <- count 2 g <++ count 1 g
+  return Era
+
+quote :: ReadP Char
+quote = char '\''
+
+notQuote :: ReadP Char
+notQuote = satisfy (/= '\'')
+
+escQuote :: ReadP Char
+escQuote = do
+  _ <- count 2 quote
+  return '\''
+
+quotedChars :: ReadP String
+quotedChars = between quote quote $ greedy (escQuote <++ notQuote)
+
+-- | Although not documented at
+-- https://docs.microsoft.com/en-us/windows/win32/intl/day--month--year--and-era-format-pictures
+-- the format pictures used by Windows do not require all such characters to be
+-- enclosed in single quotation marks.
+nonDateSpecial :: ReadP Char
+nonDateSpecial = satisfy (\c -> c `notElem` ['d', 'M', 'y', 'g', '\''])
+
+nonDateSpecials :: ReadP String
+nonDateSpecials = greedy1 nonDateSpecial
+
+dateOther :: ReadP DateFormatPicture
+dateOther = do
+  chars <- greedy1 (nonDateSpecials <++ quotedChars)
+  return $ DateOther $ concat chars
+
+datePicture :: ReadP [DateFormatPicture]
+datePicture = greedy (days <++ months <++ years <++ era <++ dateOther)
+
+-- | Type representing components of a Windows API hours, minute, and second
+-- format picture.
+data TimeFormatPicture
+  = Hours12
+  | Hours012 -- Padded with zeros
+  | Hours24
+  | Hours024 -- Padded with zeros
+  | Minutes
+  | Minutes0 -- Padded with zeros
+  | Seconds
+  | Seconds0 -- Padded with zeros
+  | TimeMarkerShort -- One-character time marker string, eg "A" and "P"
+  | TimeMarker -- Multi-character time marker string, eg "AM" and "PM"
+  | TimeOther String
+  deriving (Eq, Show)
+
+fromTFP :: TimeFormatPicture -> String
+fromTFP Hours12 = "%-l" -- No padding
+fromTFP Hours012 = "%I" -- Padded with zeros
+fromTFP Hours24 = "%-k" -- No padding
+fromTFP Hours024 = "%H" -- Padded with zeros
+fromTFP Minutes = "%-M" -- No padding
+fromTFP Minutes0 = "%M" -- Padded with zeros
+fromTFP Seconds = "%-S" -- No padding
+fromTFP Seconds0 = "%S" -- Padded with zeros
+fromTFP TimeMarkerShort = "%p" -- No direct equivalent, so do not distinguish
+                               -- from TimeMarker
+fromTFP TimeMarker = "%p"
+fromTFP (TimeOther cs) = escape cs
+
+h :: ReadP Char
+h = char 'h'
+
+hours12 :: ReadP TimeFormatPicture
+hours12 = do
+  _ <- h
+  return Hours12
+
+hours012 :: ReadP TimeFormatPicture
+hours012 = do
+  _ <- count 2 h
+  return Hours012
+
+bigH :: ReadP Char
+bigH = char 'H'
+
+hours24 :: ReadP TimeFormatPicture
+hours24 = do
+  _ <- bigH
+  return Hours24
+
+hours024 :: ReadP TimeFormatPicture
+hours024 = do
+  _ <- count 2 bigH
+  return Hours024
+
+hours :: ReadP TimeFormatPicture
+hours = hours012 <++ hours12 <++ hours024 <++ hours24
+
+m :: ReadP Char
+m = char 'm'
+
+minute :: ReadP TimeFormatPicture
+minute = do
+  _ <- m
+  return Minutes
+
+minute0 :: ReadP TimeFormatPicture
+minute0 = do
+  _ <- count 2 m
+  return Minutes0
+
+minutes :: ReadP TimeFormatPicture
+minutes = minute0 <++ minute
+
+s :: ReadP Char
+s = char 's'
+
+second :: ReadP TimeFormatPicture
+second = do
+  _ <- s
+  return Seconds
+
+second0 :: ReadP TimeFormatPicture
+second0 = do
+  _ <- count 2 s
+  return Seconds0
+
+seconds :: ReadP TimeFormatPicture
+seconds = second0 <++ second
+
+t :: ReadP Char
+t = char 't'
+
+timeMarkerShort :: ReadP TimeFormatPicture
+timeMarkerShort = do
+  _ <- t
+  return TimeMarkerShort
+
+timeMarker :: ReadP TimeFormatPicture
+timeMarker = do
+  _ <- count 2 t
+  return TimeMarker
+
+timeMarkers :: ReadP TimeFormatPicture
+timeMarkers = timeMarker <++ timeMarkerShort
+
+-- | Although not documented at
+-- https://docs.microsoft.com/en-us/windows/win32/intl/hour--minute--and-second-format-pictures
+-- the format pictures used by Windows do not require all such characters to be
+-- enclosed in single quotation marks.
+nonTimeSpecial :: ReadP Char
+nonTimeSpecial = satisfy (\c -> c `notElem` ['h', 'H', 'm', 's', 't', '\''])
+
+nonTimeSpecials :: ReadP String
+nonTimeSpecials = greedy1 nonTimeSpecial
+
+timeOther :: ReadP TimeFormatPicture
+timeOther = do
+  chars <- greedy1 (nonTimeSpecials <++ quotedChars)
+  return $ TimeOther $ concat chars
+
+timePicture :: ReadP [TimeFormatPicture]
+timePicture = greedy (hours <++ minutes <++ seconds <++ timeMarkers <++
+                     timeOther)
+
+greedy :: ReadP a -> ReadP [a]
+greedy p = greedy1 p <++ return []
+
+greedy1 :: ReadP a -> ReadP [a]
+greedy1 p = do
+  first <- p
+  rest <- greedy p
+  return (first : rest)
+
+parseMaybe :: ReadP a -> String -> Maybe a
+parseMaybe parser input =
+  case readP_to_S parser input of
+    [] -> Nothing
+    ((result, _):_) -> Just result
+
+-- | Translate from a Windows API day, month, year, and era format picture to
+-- the closest corresponding format string used by
+-- 'Data.Time.Format.formatTime'.
+fromDateFormatPicture :: String -> Maybe String
+fromDateFormatPicture dfp =
+  fmap (concatMap fromDFP) $ parseMaybe datePicture dfp
+
+-- | Translate from a Windows API hours, minute, and second format picture to
+-- the closest corresponding format string used by
+-- 'Data.Time.Format.formatTime'.
+fromTimeFormatPicture :: String -> Maybe String
+fromTimeFormatPicture tfp =
+  fmap (concatMap fromTFP) $ parseMaybe timePicture tfp

+ System/Win32/WindowsString/Console.hsc view

@@ -0,0 +1,180 @@+{-# LANGUAGE PackageImports #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.WindowsString.Console+-- Copyright   :  (c) University of Glasgow 2023+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>+-- Stability   :  provisional+-- Portability :  portable+--+-- A collection of FFI declarations for interfacing with Win32 Console API (WindowsString variant)+--+-----------------------------------------------------------------------------++module System.Win32.WindowsString.Console (+        -- * Console mode+        getConsoleMode,+        setConsoleMode,+        eNABLE_ECHO_INPUT,+        eNABLE_EXTENDED_FLAGS,+        eNABLE_INSERT_MODE,+        eNABLE_LINE_INPUT,+        eNABLE_MOUSE_INPUT,+        eNABLE_PROCESSED_INPUT,+        eNABLE_QUICK_EDIT_MODE,+        eNABLE_WINDOW_INPUT,+        eNABLE_VIRTUAL_TERMINAL_INPUT,+        eNABLE_PROCESSED_OUTPUT,+        eNABLE_WRAP_AT_EOL_OUTPUT,+        eNABLE_VIRTUAL_TERMINAL_PROCESSING,+        dISABLE_NEWLINE_AUTO_RETURN,+        eNABLE_LVB_GRID_WORLDWIDE,+        -- * Console code pages+        getConsoleCP,+        setConsoleCP,+        getConsoleOutputCP,+        setConsoleOutputCP,+        -- * Ctrl events+        CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT,+        generateConsoleCtrlEvent,+        -- * Command line+        commandLineToArgv,+        getCommandLineW,+        getArgs,+        -- * Screen buffer+        CONSOLE_SCREEN_BUFFER_INFO(..),+        CONSOLE_SCREEN_BUFFER_INFOEX(..),+        COORD(..),+        SMALL_RECT(..),+        COLORREF,+        getConsoleScreenBufferInfo,+        getCurrentConsoleScreenBufferInfo,+        getConsoleScreenBufferInfoEx,+        getCurrentConsoleScreenBufferInfoEx,++        -- * Env+        getEnv,+        getEnvironment+  ) where++#include <windows.h>+#include "alignment.h"+##include "windows_cconv.h"+#include "wincon_compat.h"++import System.Win32.WindowsString.Types+import System.Win32.WindowsString.String (withTStringBufferLen)+import System.Win32.Console.Internal+import System.Win32.Console hiding (getArgs, commandLineToArgv, getEnv, getEnvironment)+import System.OsString.Windows+import System.OsString.Internal.Types++import Foreign.C.Types (CWchar)+import Foreign.C.String (CWString)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Array (peekArray, peekArray0)+import Foreign.Marshal.Alloc (alloca)+import GHC.IO (bracket)+import GHC.IO.Exception (IOException(..), IOErrorType(OtherError))++import Prelude hiding (break, length, tail)+import qualified Prelude as P++#if !MIN_VERSION_filepath(1,5,0)+import Data.Coerce+import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC++tail :: WindowsString -> WindowsString+tail = coerce BC.tail++break :: (WindowsChar -> Bool) -> WindowsString -> (WindowsString, WindowsString)+break = coerce BC.break+#endif+++-- | This function can be used to parse command line arguments and return+--   the split up arguments as elements in a list.+commandLineToArgv :: WindowsString -> IO [WindowsString]+commandLineToArgv arg+  | arg == mempty = return []+  | otherwise = withTString arg $ \c_arg -> do+       alloca $ \c_size -> do+         res <- c_CommandLineToArgvW c_arg c_size+         size <- peek c_size+         args <- peekArray (fromIntegral size) res+         _ <- localFree res+         mapM peekTString args++-- | Based on 'GetCommandLineW'. This behaves slightly different+-- than 'System.Environment.getArgs'. See the online documentation:+-- <https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getcommandlinew>+getArgs :: IO [WindowsString]+getArgs = do+  getCommandLineW >>= peekTString >>= commandLineToArgv+++-- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD+getEnv :: WindowsString -> IO (Maybe WindowsString)+getEnv name =+  withTString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do+    let c_len = fromIntegral len+    c_len' <- c_GetEnvironmentVariableW c_name buf c_len+    case c_len' of+      0 -> do+        err_code <- getLastError+        if err_code  == eERROR_ENVVAR_NOT_FOUND+        then return Nothing+        else errorWin "GetEnvironmentVariableW"+      _ | c_len' > fromIntegral maxLength ->+            -- shouldn't happen, because we provide maxLength+            ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing)+        | otherwise -> do+            let len' = fromIntegral c_len'+            Just <$> peekTStringLen (buf, len')+ where+  -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew+  -- max characters (wide chars): 32767+  -- => bytes = 32767 * 2 = 65534+  -- +1 byte for NUL (although not needed I think)+  maxLength :: Int+  maxLength = 65535+++getEnvironment :: IO [(WindowsString, WindowsString)]+getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do+    strs <- builder lpwstr+    return (divvy <$> strs)+ where+  divvy :: WindowsString -> (WindowsString, WindowsString)+  divvy str =+    case break (== unsafeFromChar '=') str of+      (xs,ys)+        | ys == mempty -> (xs,ys) -- don't barf (like Posix.getEnvironment)+      (name, ys) -> let value = tail ys in (name,value)++  builder :: LPWSTR -> IO [WindowsString]+  builder ptr = go 0+   where+    go :: Int -> IO [WindowsString]+    go off = do+      (str, l) <- peekCWStringOff ptr off+      if l == 0+      then pure []+      else (str:) <$> go (((l + 1) * 2) + off)+++peekCWStringOff :: CWString -> Int -> IO (WindowsString, Int)+peekCWStringOff cp off = do+  cs <- peekArray0 wNUL (cp `plusPtr` off)+  return (cWcharsToChars cs, P.length cs)++wNUL :: CWchar+wNUL = 0++cWcharsToChars :: [CWchar] -> WindowsString+cWcharsToChars = pack . fmap (WindowsChar . fromIntegral)+

+ System/Win32/WindowsString/DLL.hsc view

@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.DLL
+-- 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.WindowsString.DLL
+    ( module System.Win32.WindowsString.DLL
+    , module System.Win32.DLL
+    ) where
+
+import System.Win32.DLL hiding
+  (   disableThreadLibraryCalls
+    , freeLibrary
+    , getModuleFileName
+    , getModuleHandle
+    , getProcAddress
+    , loadLibrary
+    , loadLibraryEx
+    , setDllDirectory
+    , lOAD_LIBRARY_AS_DATAFILE
+    , lOAD_WITH_ALTERED_SEARCH_PATH
+  )
+import System.Win32.DLL.Internal
+import System.Win32.WindowsString.Types
+
+import Foreign
+import Data.Maybe (fromMaybe)
+import System.OsString.Windows
+import GHC.IO.Encoding.UTF16 ( mkUTF16le )
+import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
+
+getModuleFileName :: HMODULE -> IO WindowsString
+getModuleFileName hmod =
+  allocaArray 512 $ \ c_str -> do
+  failIfFalse_ "GetModuleFileName" $ c_GetModuleFileName hmod c_str 512
+  peekTString c_str
+
+getModuleHandle :: Maybe WindowsString -> IO HMODULE
+getModuleHandle mb_name =
+  maybeWith withTString mb_name $ \ c_name ->
+  failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name
+
+loadLibrary :: WindowsString -> IO HMODULE
+loadLibrary name =
+  withTString name $ \ c_name ->
+  failIfNull "LoadLibrary" $ c_LoadLibrary c_name
+
+loadLibraryEx :: WindowsString -> HANDLE -> LoadLibraryFlags -> IO HMODULE
+loadLibraryEx name h flags =
+  withTString name $ \ c_name ->
+  failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags
+
+setDllDirectory :: Maybe WindowsString -> IO ()
+setDllDirectory name =
+  maybeWith withTString name $ \ c_name -> do
+    let nameS = name >>= either (const Nothing) Just . decodeWith (mkUTF16le TransliterateCodingFailure)
+    failIfFalse_ (unwords ["SetDllDirectory", fromMaybe "NULL" nameS]) $ c_SetDllDirectory c_name
+

+ System/Win32/WindowsString/DebugApi.hsc view

@@ -0,0 +1,33 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.WindowsString.DebugApi
+-- Copyright   :  (c) Esa Ilari Vuokko, 2006
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of FFI declarations for using Windows DebugApi.
+--
+-----------------------------------------------------------------------------
+module System.Win32.WindowsString.DebugApi
+    ( module System.Win32.WindowsString.DebugApi
+    , module System.Win32.DebugApi
+    ) where
+
+import System.Win32.DebugApi.Internal
+import System.Win32.DebugApi hiding (outputDebugString)
+import System.Win32.WindowsString.Types   ( withTString )
+import System.OsString.Windows
+
+##include "windows_cconv.h"
+#include "windows.h"
+
+
+--------------------------------------------------------------------------
+-- On process being debugged
+
+outputDebugString :: WindowsString -> IO ()
+outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s
+

+ System/Win32/WindowsString/File.hsc view

@@ -0,0 +1,269 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.File
+-- 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.WindowsString.File
+    ( deleteFile
+    , copyFile
+    , moveFile
+    , moveFileEx
+    , setCurrentDirectory
+    , createDirectory
+    , createDirectoryEx
+    , removeDirectory
+    , getBinaryType
+    , createFile
+    , setFileAttributes
+    , getFileAttributes
+    , getFileAttributesExStandard
+    , getTempFileName
+    , findFirstChangeNotification
+    , getFindDataFileName
+    , findFirstFile
+    , defineDosDevice
+    , getDiskFreeSpace
+    , setVolumeLabel
+    , getFileExInfoStandard
+    , getFileExMaxInfoLevel
+    , replaceFile
+    , module System.Win32.File
+    ) where
+
+import System.Win32.File.Internal
+import System.Win32.File hiding (
+    deleteFile
+  , copyFile
+  , moveFile
+  , moveFileEx
+  , setCurrentDirectory
+  , createDirectory
+  , createDirectoryEx
+  , removeDirectory
+  , getBinaryType
+  , createFile
+  , setFileAttributes
+  , getFileAttributes
+  , getFileAttributesExStandard
+  , getTempFileName
+  , findFirstChangeNotification
+  , getFindDataFileName
+  , findFirstFile
+  , defineDosDevice
+  , getDiskFreeSpace
+  , setVolumeLabel
+  , getFileExInfoStandard
+  , getFileExMaxInfoLevel
+  , replaceFile
+  )
+import System.Win32.WindowsString.Types
+import System.OsString.Windows
+import Unsafe.Coerce (unsafeCoerce)
+import Data.Maybe (fromMaybe)
+
+import Foreign hiding (void)
+
+##include "windows_cconv.h"
+
+#include <windows.h>
+#include "alignment.h"
+
+deleteFile :: WindowsString -> IO ()
+deleteFile name =
+  withFilePath name $ \ c_name ->
+    failIfFalseWithRetry_ (unwords ["DeleteFile",show name]) $
+      c_DeleteFile c_name
+
+copyFile :: WindowsString -> WindowsString -> Bool -> IO ()
+copyFile src dest over =
+  withFilePath src $ \ c_src ->
+  withFilePath dest $ \ c_dest ->
+  failIfFalseWithRetry_ (unwords ["CopyFile",show src,show dest]) $
+    c_CopyFile c_src c_dest over
+
+moveFile :: WindowsString -> WindowsString -> IO ()
+moveFile src dest =
+  withFilePath src $ \ c_src ->
+  withFilePath dest $ \ c_dest ->
+  failIfFalseWithRetry_ (unwords ["MoveFile",show src,show dest]) $
+    c_MoveFile c_src c_dest
+
+moveFileEx :: WindowsString -> Maybe WindowsString -> MoveFileFlag -> IO ()
+moveFileEx src dest flags =
+  withFilePath src $ \ c_src ->
+  maybeWith withFilePath dest $ \ c_dest ->
+  failIfFalseWithRetry_ (unwords ["MoveFileEx",show src,show dest]) $
+    c_MoveFileEx c_src c_dest flags
+
+setCurrentDirectory :: WindowsString -> IO ()
+setCurrentDirectory name =
+  withFilePath name $ \ c_name ->
+  failIfFalse_ (unwords ["SetCurrentDirectory",show name]) $
+    c_SetCurrentDirectory c_name
+
+createDirectory :: WindowsString -> Maybe LPSECURITY_ATTRIBUTES -> IO ()
+createDirectory name mb_attr =
+  withFilePath name $ \ c_name ->
+  failIfFalseWithRetry_ (unwords ["CreateDirectory",show name]) $
+    c_CreateDirectory c_name (maybePtr mb_attr)
+
+createDirectoryEx :: WindowsString -> WindowsString -> Maybe LPSECURITY_ATTRIBUTES -> IO ()
+createDirectoryEx template name mb_attr =
+  withFilePath template $ \ c_template ->
+  withFilePath name $ \ c_name ->
+  failIfFalseWithRetry_ (unwords ["CreateDirectoryEx",show template,show name]) $
+    c_CreateDirectoryEx c_template c_name (maybePtr mb_attr)
+
+removeDirectory :: WindowsString -> IO ()
+removeDirectory name =
+  withFilePath name $ \ c_name ->
+  failIfFalseWithRetry_ (unwords ["RemoveDirectory",show name]) $
+    c_RemoveDirectory c_name
+
+getBinaryType :: WindowsString -> IO BinaryType
+getBinaryType name =
+  withFilePath name $ \ c_name ->
+  alloca $ \ p_btype -> do
+  failIfFalse_ (unwords ["GetBinaryType",show name]) $
+    c_GetBinaryType c_name p_btype
+  peek p_btype
+
+----------------------------------------------------------------
+-- HANDLE operations
+----------------------------------------------------------------
+
+createFile :: WindowsString -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE
+createFile name access share mb_attr mode flag mb_h =
+  withFilePath name $ \ c_name ->
+  failIfWithRetry (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $
+    c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h)
+
+setFileAttributes :: WindowsString -> FileAttributeOrFlag -> IO ()
+setFileAttributes name attr =
+  withFilePath name $ \ c_name ->
+  failIfFalseWithRetry_ (unwords ["SetFileAttributes",show name])
+    $ c_SetFileAttributes c_name attr
+
+getFileAttributes :: WindowsString -> IO FileAttributeOrFlag
+getFileAttributes name =
+  withFilePath name $ \ c_name ->
+  failIfWithRetry (== 0xFFFFFFFF) (unwords ["GetFileAttributes",show name]) $
+    c_GetFileAttributes c_name
+
+getFileAttributesExStandard :: WindowsString -> IO WIN32_FILE_ATTRIBUTE_DATA
+getFileAttributesExStandard name =  alloca $ \res -> do
+  withFilePath name $ \ c_name ->
+    failIfFalseWithRetry_ "getFileAttributesExStandard" $
+      c_GetFileAttributesEx c_name (unsafeCoerce getFileExInfoStandard) res
+  peek res
+
+-- | Get a unique temporary filename.
+--
+-- Calls 'GetTempFileNameW'.
+getTempFileName :: WindowsString     -- ^ directory for the temporary file (must be at most MAX_PATH - 14 characters long)
+                -> WindowsString     -- ^ prefix for the temporary file name
+                -> Maybe UINT        -- ^ if 'Nothing', a unique name is generated
+                                     --   otherwise a non-zero value is used as the unique part
+                -> IO (WindowsString, UINT)
+getTempFileName dir prefix unique = allocaBytes ((#const MAX_PATH) * sizeOf (undefined :: TCHAR)) $ \c_buf -> do
+  uid <- withFilePath dir $ \c_dir ->
+    withFilePath prefix $ \ c_prefix -> do
+      failIfZero "getTempFileName" $
+        c_GetTempFileNameW c_dir c_prefix (fromMaybe 0 unique) c_buf
+  fname <- peekTString c_buf
+  pure (fname, uid)
+
+replaceFile :: WindowsString -> WindowsString -> Maybe WindowsString -> DWORD -> IO ()
+replaceFile replacedFile replacementFile mBackupFile replaceFlags =
+  withFilePath replacedFile $ \ c_replacedFile ->
+    withFilePath replacementFile $ \ c_replacementFile ->
+      let getResult f = 
+            case mBackupFile of
+              Nothing -> f nullPtr
+              Just backupFile -> withFilePath backupFile f
+      in getResult $ \ c_backupFile ->
+           failIfFalse_ "ReplaceFile" $ c_ReplaceFile c_replacedFile c_replacementFile c_backupFile replaceFlags nullPtr nullPtr
+
+----------------------------------------------------------------
+-- File Notifications
+--
+-- Use these to initialise, "increment" and close a HANDLE you can wait
+-- on.
+----------------------------------------------------------------
+
+findFirstChangeNotification :: WindowsString -> Bool -> FileNotificationFlag -> IO HANDLE
+findFirstChangeNotification path watch flag =
+  withFilePath path $ \ c_path ->
+  failIfNull (unwords ["FindFirstChangeNotification",show path]) $
+    c_FindFirstChangeNotification c_path watch flag
+
+
+----------------------------------------------------------------
+-- Directories
+----------------------------------------------------------------
+
+
+getFindDataFileName :: FindData -> IO WindowsString
+getFindDataFileName fd = case unsafeCoerce fd of
+  (FindData fp) ->
+    withForeignPtr fp $ \p ->
+      peekTString ((# ptr WIN32_FIND_DATAW, cFileName ) p)
+
+findFirstFile :: WindowsString -> IO (HANDLE, FindData)
+findFirstFile str = do
+  fp_finddata <- mallocForeignPtrBytes (# const sizeof(WIN32_FIND_DATAW) )
+  withForeignPtr fp_finddata $ \p_finddata -> do
+    handle <- withFilePath str $ \tstr -> do
+                failIf (== iNVALID_HANDLE_VALUE) "findFirstFile" $
+                  c_FindFirstFile tstr p_finddata
+    return (handle, unsafeCoerce (FindData fp_finddata))
+
+
+----------------------------------------------------------------
+-- DOS Device flags
+----------------------------------------------------------------
+
+defineDosDevice :: DefineDosDeviceFlags -> WindowsString -> Maybe WindowsString -> IO ()
+defineDosDevice flags name path =
+  maybeWith withFilePath path $ \ c_path ->
+  withFilePath name $ \ c_name ->
+  failIfFalse_ "DefineDosDevice" $ c_DefineDosDevice flags c_name c_path
+
+----------------------------------------------------------------
+
+
+-- %fun GetDriveType :: Maybe String -> IO DriveType
+
+getDiskFreeSpace :: Maybe WindowsString -> IO (DWORD,DWORD,DWORD,DWORD)
+getDiskFreeSpace path =
+  maybeWith withFilePath path $ \ c_path ->
+  alloca $ \ p_sectors ->
+  alloca $ \ p_bytes ->
+  alloca $ \ p_nfree ->
+  alloca $ \ p_nclusters -> do
+  failIfFalse_ "GetDiskFreeSpace" $
+    c_GetDiskFreeSpace c_path p_sectors p_bytes p_nfree p_nclusters
+  sectors <- peek p_sectors
+  bytes <- peek p_bytes
+  nfree <- peek p_nfree
+  nclusters <- peek p_nclusters
+  return (sectors, bytes, nfree, nclusters)
+
+setVolumeLabel :: Maybe WindowsString -> Maybe WindowsString -> IO ()
+setVolumeLabel path name =
+  maybeWith withFilePath path $ \ c_path ->
+  maybeWith withFilePath name $ \ c_name ->
+  failIfFalse_ "SetVolumeLabel" $ c_SetVolumeLabel c_path c_name
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------

+ System/Win32/WindowsString/FileMapping.hsc view

@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.FileMapping
+-- Copyright   :  (c) Esa Ilari Vuokko, 2006
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of FFI declarations for interfacing with Win32 mapped files.
+--
+-----------------------------------------------------------------------------
+module System.Win32.WindowsString.FileMapping
+    ( module System.Win32.WindowsString.FileMapping
+    , module System.Win32.FileMapping
+    ) where
+
+import System.Win32.FileMapping hiding
+    (
+      mapFile
+    , withMappedFile
+    , createFileMapping
+    , openFileMapping
+    )
+
+import System.Win32.FileMapping.Internal
+import System.Win32.WindowsString.Types   ( HANDLE, BOOL, withTString
+                            , failIf, DDWORD, ddwordToDwords
+                            , iNVALID_HANDLE_VALUE )
+import System.Win32.Mem
+import System.Win32.WindowsString.File
+import System.OsString.Windows
+import System.OsPath.Windows
+
+import Control.Exception        ( mask_, bracket )
+import Foreign                  ( nullPtr, maybeWith
+                                , ForeignPtr, newForeignPtr )
+
+##include "windows_cconv.h"
+
+#include "windows.h"
+
+---------------------------------------------------------------------------
+-- Derived functions
+---------------------------------------------------------------------------
+
+-- | Maps file fully and returns ForeignPtr and length of the mapped area.
+-- The mapped file is opened read-only and shared reading.
+mapFile :: WindowsPath -> IO (ForeignPtr a, Int)
+mapFile path = do
+    bracket
+        (createFile path gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing)
+        (closeHandle)
+        $ \fh -> bracket
+            (createFileMapping (Just fh) pAGE_READONLY 0 Nothing)
+            (closeHandle)
+            $ \fm -> do
+                fi <- getFileInformationByHandle fh
+                fp <- mask_ $ do
+                    ptr <- mapViewOfFile fm fILE_MAP_READ 0 0
+                    newForeignPtr c_UnmapViewOfFileFinaliser ptr
+                return (fp, fromIntegral $ bhfiSize fi)
+
+-- | Opens an existing file and creates mapping object to it.
+withMappedFile
+    :: WindowsPath             -- ^ Path
+    -> Bool                 -- ^ Write? (False = read-only)
+    -> Maybe Bool           -- ^ Sharing mode, no sharing, share read, share read+write
+    -> (Integer -> MappedObject -> IO a) -- ^ Action
+    -> IO a
+withMappedFile path write share act =
+    bracket
+        (createFile path access share' Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing)
+        (closeHandle)
+        $ \fh -> bracket
+            (createFileMapping (Just fh) page 0 Nothing)
+            (closeHandle)
+            $ \fm -> do
+                bhfi <- getFileInformationByHandle fh
+                act (fromIntegral $ bhfiSize bhfi) (MappedObject fh fm mapaccess)
+    where
+        access    = if write then gENERIC_READ+gENERIC_WRITE else gENERIC_READ
+        page      = if write then pAGE_READWRITE else pAGE_READONLY
+        mapaccess = if write then fILE_MAP_ALL_ACCESS else fILE_MAP_READ
+        share' = case share of
+            Nothing     -> fILE_SHARE_NONE
+            Just False  -> fILE_SHARE_READ
+            Just True   -> fILE_SHARE_READ + fILE_SHARE_WRITE
+
+---------------------------------------------------------------------------
+-- API in Haskell
+---------------------------------------------------------------------------
+createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe WindowsString -> IO HANDLE
+createFileMapping mh flags mosize 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 WindowsString -> IO HANDLE
+openFileMapping access inherit name =
+    maybeWith withTString name $ \c_name ->
+        failIf (==nullPtr) "openFileMapping: OpenFileMapping" $
+            c_OpenFileMapping access inherit c_name
+

+ System/Win32/WindowsString/HardLink.hs view

@@ -0,0 +1,47 @@+{-# 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.WindowsString.HardLink
+  ( createHardLink
+  , createHardLink'
+  ) where
+
+import System.Win32.HardLink.Internal
+import System.Win32.WindowsString.File   ( failIfFalseWithRetry_ )
+import System.Win32.WindowsString.String ( withTString )
+import System.Win32.WindowsString.Types  ( nullPtr )
+import System.OsPath.Windows
+
+#include "windows_cconv.h"
+
+-- | NOTE: createHardLink is /flipped arguments/ to provide compatibility for Unix.
+-- 
+-- If you want to create hard link by Windows way, use 'createHardLink'' instead.
+createHardLink :: WindowsPath -- ^ Target file path
+               -> WindowsPath -- ^ Hard link name
+               -> IO ()
+createHardLink = flip createHardLink'
+
+createHardLink' :: WindowsPath -- ^ Hard link name
+                -> WindowsPath -- ^ 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

+ System/Win32/WindowsString/Info.hsc view

@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Info
+-- 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.WindowsString.Info
+    ( module System.Win32.WindowsString.Info
+    , module System.Win32.Info
+    ) where
+
+import System.Win32.Info.Internal
+import System.Win32.Info hiding (
+    getSystemDirectory
+  , getWindowsDirectory
+  , getCurrentDirectory
+  , getTemporaryDirectory
+  , getFullPathName
+  , getLongPathName
+  , getShortPathName
+  , searchPath
+  , getUserName
+  )
+import Control.Exception (catch)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Marshal.Utils (with, maybeWith)
+import Foreign.Marshal.Array (allocaArray)
+import Foreign.Ptr (nullPtr)
+import Foreign.Storable (Storable(..))
+import System.IO.Error (isDoesNotExistError)
+import System.Win32.WindowsString.Types (failIfFalse_, peekTStringLen, withTString, try)
+import System.OsPath.Windows
+
+#if !MIN_VERSION_base(4,6,0)
+import Prelude hiding (catch)
+#endif
+
+##include "windows_cconv.h"
+
+#include <windows.h>
+#include "alignment.h"
+
+----------------------------------------------------------------
+-- Standard Directories
+----------------------------------------------------------------
+
+getSystemDirectory :: IO WindowsString
+getSystemDirectory = try "GetSystemDirectory" c_getSystemDirectory 512
+
+getWindowsDirectory :: IO WindowsString
+getWindowsDirectory = try "GetWindowsDirectory" c_getWindowsDirectory 512
+
+getCurrentDirectory :: IO WindowsString
+getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512
+
+getTemporaryDirectory :: IO WindowsString
+getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512
+
+getFullPathName :: WindowsPath -> IO WindowsPath
+getFullPathName name = do
+  withTString name $ \ c_name ->
+    try "getFullPathName"
+      (\buf len -> c_GetFullPathName c_name len buf nullPtr) 512
+
+getLongPathName :: WindowsPath -> IO WindowsPath
+getLongPathName name = do
+  withTString name $ \ c_name ->
+    try "getLongPathName"
+      (c_GetLongPathName c_name) 512
+
+getShortPathName :: WindowsPath -> IO WindowsPath
+getShortPathName name = do
+  withTString name $ \ c_name ->
+    try "getShortPathName"
+      (c_GetShortPathName c_name) 512
+
+searchPath :: Maybe WindowsString -> WindowsPath -> Maybe WindowsString -> IO (Maybe WindowsPath)
+searchPath path filename ext =
+  maybe ($ nullPtr) withTString path $ \p_path ->
+  withTString filename $ \p_filename ->
+  maybeWith withTString ext      $ \p_ext ->
+  alloca $ \ppFilePart -> (do
+    s <- try "searchPath" (\buf len -> c_SearchPath p_path p_filename p_ext
+                          len buf ppFilePart) 512
+    return (Just s))
+     `catch` \e -> if isDoesNotExistError e
+                       then return Nothing
+                       else ioError e
+
+----------------------------------------------------------------
+-- User name
+----------------------------------------------------------------
+
+-- %fun GetUserName :: IO String
+
+getUserName :: IO WindowsString
+getUserName =
+  allocaArray 512 $ \ c_str ->
+    with 512 $ \ c_len -> do
+        failIfFalse_ "GetUserName" $ c_GetUserName c_str c_len
+        len <- peek c_len
+        peekTStringLen (c_str, fromIntegral len - 1)
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------

+ System/Win32/WindowsString/Path.hsc view

@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Path
+-- Copyright   :  (c) Tamar Christina, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  Tamar Christina <tamar@zhox.com>
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of FFI declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.WindowsString.Path (
+   filepathRelativePathTo
+ , pathRelativePathTo
+ ) where
+
+import System.Win32.Path.Internal
+import System.Win32.WindowsString.Types
+import System.Win32.WindowsString.File
+import System.OsPath.Windows
+
+import Foreign
+
+##include "windows_cconv.h"
+
+#include <windows.h>
+
+filepathRelativePathTo :: WindowsPath -> WindowsPath -> IO WindowsPath
+filepathRelativePathTo from to =
+  withTString from $ \p_from ->
+  withTString to   $ \p_to   ->
+  allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do
+    _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from fILE_ATTRIBUTE_DIRECTORY
+                                                                         p_to   fILE_ATTRIBUTE_NORMAL)
+    path <- peekTString p_AbsPath
+    _ <- localFree p_AbsPath
+    return path
+
+pathRelativePathTo :: WindowsPath -> FileAttributeOrFlag -> WindowsPath -> FileAttributeOrFlag -> IO WindowsPath
+pathRelativePathTo from from_attr to to_attr =
+  withTString from $ \p_from ->
+  withTString to   $ \p_to   ->
+  allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do
+    _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from from_attr
+                                                                         p_to   to_attr)
+    path <- peekTString p_AbsPath
+    _ <- localFree p_AbsPath
+    return path
+

+ System/Win32/WindowsString/Shell.hsc view

@@ -0,0 +1,59 @@+{-# LANGUAGE Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.WindowsString.Shell+-- Copyright   :  (c) The University of Glasgow 2009+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>+-- Stability   :  provisional+-- Portability :  portable+--+-- Win32 stuff from shell32.dll+--+-----------------------------------------------------------------------------++module System.Win32.WindowsString.Shell (+  sHGetFolderPath,+  CSIDL,+  cSIDL_PROFILE,+  cSIDL_APPDATA,+  cSIDL_WINDOWS,+  cSIDL_PERSONAL,+  cSIDL_LOCAL_APPDATA,+  cSIDL_DESKTOPDIRECTORY,+  cSIDL_PROGRAM_FILES,+  SHGetFolderPathFlags,+  sHGFP_TYPE_CURRENT,+  sHGFP_TYPE_DEFAULT+ ) where++import System.OsString.Windows (WindowsString)+import System.Win32.Shell.Internal+import System.Win32.Shell hiding (sHGetFolderPath)+import System.Win32.WindowsString.Types+import Graphics.Win32.GDI.Types (HWND)++import Foreign+import Control.Monad++##include "windows_cconv.h"++-- for SHGetFolderPath stuff+#define _WIN32_IE 0x500+#include <windows.h>+#include <shlobj.h>++----------------------------------------------------------------+-- SHGetFolderPath+--+-- XXX: this is deprecated in Vista and later+----------------------------------------------------------------+++sHGetFolderPath :: HWND -> CSIDL -> HANDLE -> SHGetFolderPathFlags -> IO WindowsString+sHGetFolderPath hwnd csidl hdl flags =+  allocaBytes ((#const MAX_PATH) * (#size TCHAR)) $ \pstr -> do+    r <- c_SHGetFolderPath hwnd csidl hdl flags pstr+    when (r < 0) $ raiseUnsupported "sHGetFolderPath"+    peekTString pstr

+ System/Win32/WindowsString/String.hs view

@@ -0,0 +1,73 @@+{-# LANGUAGE PackageImports #-}
+
+{- |
+   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.WindowsString.String
+  ( LPSTR, LPCSTR, LPWSTR, LPCWSTR
+  , TCHAR, LPTSTR, LPCTSTR, LPCTSTR_
+  , withTString, withTStringLen, peekTString, peekTStringLen
+  , newTString
+  , withTStringBuffer, withTStringBufferLen
+  ) where
+
+import System.Win32.String hiding
+  ( withTStringBuffer
+  , withTStringBufferLen
+  , withTString
+  , withTStringLen
+  , peekTString
+  , peekTStringLen
+  , newTString
+  )
+import System.Win32.WindowsString.Types
+import System.OsString.Internal.Types
+#if MIN_VERSION_filepath(1,5,0)
+import qualified "os-string" System.OsString.Data.ByteString.Short as SBS
+#else
+import qualified "filepath" System.OsPath.Data.ByteString.Short as SBS
+#endif
+import Data.Word (Word8)
+
+-- | 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 = WindowsString $ SBS.pack $ replicate (if even maxLength then maxLength else maxLength + 1) _nul
+    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 = WindowsString $ SBS.pack $ replicate (if even maxLength then maxLength else maxLength + 1) _nul
+    in  withTStringLen dummyBuffer
+
+
+_nul :: Word8
+_nul = 0x00

+ System/Win32/WindowsString/SymbolicLink.hsc view

@@ -0,0 +1,94 @@+{-# 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: When using the createSymbolicLink* functions without the
+   SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE flag, 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'/\>.
+
+   Starting from Windows 10 version 1703 (Creators Update), after enabling
+   Developer Mode, users can create symbolic links without requiring the
+   Administrator privilege in the current process. Supply a 'True' flag in
+   addition to the target and link name to enable this behavior.
+-}
+module System.Win32.WindowsString.SymbolicLink
+  ( SymbolicLinkFlags
+  , sYMBOLIC_LINK_FLAG_FILE
+  , sYMBOLIC_LINK_FLAG_DIRECTORY
+  , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
+  , createSymbolicLink
+  , createSymbolicLink'
+  , createSymbolicLinkFile
+  , createSymbolicLinkDirectory
+  ) where
+
+import System.Win32.SymbolicLink.Internal
+import Data.Bits ((.|.))
+import System.Win32.WindowsString.Types
+import System.Win32.WindowsString.File ( failIfFalseWithRetry_ )
+import System.OsPath.Windows
+import Unsafe.Coerce (unsafeCoerce)
+
+##include "windows_cconv.h"
+
+-- | createSymbolicLink* functions don't check that file is exist or not.
+--
+-- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatibility for Unix,
+-- except 'createSymbolicLink''.
+--
+-- If you want to create symbolic link by Windows way, use 'createSymbolicLink'' instead.
+createSymbolicLink :: WindowsPath -- ^ Target file path
+                   -> WindowsPath -- ^ Symbolic link name
+                   -> SymbolicLinkFlags -> IO ()
+createSymbolicLink = flip createSymbolicLink'
+
+createSymbolicLinkFile :: WindowsPath -- ^ Target file path
+                       -> WindowsPath -- ^ Symbolic link name
+                       -> Bool -- ^ Create the symbolic link with the unprivileged mode
+                       -> IO ()
+createSymbolicLinkFile target link unprivileged =
+  createSymbolicLink'
+    link
+    target
+    ( if unprivileged
+        then sYMBOLIC_LINK_FLAG_FILE .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
+        else sYMBOLIC_LINK_FLAG_FILE
+    )
+
+createSymbolicLinkDirectory :: WindowsPath -- ^ Target file path
+                            -> WindowsPath -- ^ Symbolic link name
+                            -> Bool -- ^ Create the symbolic link with the unprivileged mode
+                            -> IO ()
+createSymbolicLinkDirectory target link unprivileged =
+  createSymbolicLink'
+    link
+    target
+    ( if unprivileged
+        then
+          sYMBOLIC_LINK_FLAG_DIRECTORY
+            .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
+        else sYMBOLIC_LINK_FLAG_DIRECTORY
+    )
+
+createSymbolicLink' :: WindowsPath -- ^ Symbolic link name
+                    -> WindowsPath -- ^ 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 (unsafeCoerce flag)
+

+ System/Win32/WindowsString/Time.hsc view

@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Time
+-- Copyright   :  (c) Esa Ilari Vuokko, 2006
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of FFI declarations for interfacing with Win32 Time API.
+--
+-----------------------------------------------------------------------------
+module System.Win32.WindowsString.Time
+    ( module System.Win32.WindowsString.Time
+    , module System.Win32.Time
+    ) where
+
+import System.Win32.Time.Internal
+import System.Win32.Time hiding (getTimeFormatEx, getTimeFormat)
+
+import System.Win32.WindowsString.String  ( peekTStringLen, withTString )
+import System.Win32.WindowsString.Types   ( LCID, failIf )
+import System.Win32.Utils   ( trySized )
+
+import Foreign          ( Storable(sizeOf)
+                        , nullPtr, castPtr
+                        , with, allocaBytes )
+import Foreign.C        ( CWchar(..)
+                        , withCWString )
+import Foreign.Marshal.Utils (maybeWith)
+import System.OsString.Windows
+
+##include "windows_cconv.h"
+#include <windows.h>
+#include "alignment.h"
+#include "winnls_compat.h"
+
+
+getTimeFormatEx :: Maybe WindowsString
+                -> GetTimeFormatFlags
+                -> Maybe SYSTEMTIME
+                -> Maybe WindowsString
+                -> IO String
+getTimeFormatEx locale flags st fmt =
+    maybeWith withTString locale $ \c_locale ->
+        maybeWith with st $ \c_st ->
+            maybeWith withTString fmt $ \c_fmt -> do
+                let c_func = c_GetTimeFormatEx c_locale flags c_st c_fmt
+                trySized "GetTimeFormatEx" c_func
+
+getTimeFormat :: LCID -> GetTimeFormatFlags -> Maybe SYSTEMTIME -> Maybe String -> IO WindowsString
+getTimeFormat locale flags st fmt =
+    maybeWith with st $ \c_st ->
+    maybeWith 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 c_st c_fmt (castPtr out) size
+            peekTStringLen (out,fromIntegral size')

+ System/Win32/WindowsString/Types.hsc view

@@ -0,0 +1,214 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- 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.WindowsString.Types
+        ( module System.Win32.WindowsString.Types
+        , module System.Win32.Types
+        ) where
+
+import System.Win32.Types hiding (
+    withTString
+  , withTStringLen
+  , peekTString
+  , peekTStringLen
+  , newTString
+  , failIf
+  , failIf_
+  , failIfNeg
+  , failIfNull
+  , failIfZero
+  , failIfFalse_
+  , failUnlessSuccess
+  , failUnlessSuccessOr
+  , errorWin
+  , failWith
+  , try
+  , withFilePath
+  , useAsCWStringSafe
+  )
+
+import Foreign.C.Types (CUIntPtr(..))
+import Foreign.C.String (CWString)
+import qualified System.OsPath.Windows as WS
+import System.OsPath.Windows (WindowsPath)
+import System.OsString.Windows (decodeWith, encodeWith)
+import System.OsString.Internal.Types
+#if MIN_VERSION_filepath(1,5,0)
+import "os-string" System.OsString.Encoding.Internal (decodeWithBaseWindows)
+import qualified "os-string" System.OsString.Data.ByteString.Short.Word16 as SBS
+import "os-string" System.OsString.Data.ByteString.Short.Word16 (
+#else
+import "filepath" System.OsPath.Encoding.Internal (decodeWithBaseWindows)
+import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as SBS
+import "filepath" System.OsPath.Data.ByteString.Short.Word16 (
+#endif
+  packCWString,
+  packCWStringLen,
+  useAsCWString,
+  useAsCWStringLen,
+  newCWString
+  )
+import Data.Bifunctor (first)
+import Data.Char (isSpace)
+import Numeric (showHex)
+import qualified System.IO as IO ()
+import System.IO.Error (ioeSetErrorString)
+import Foreign (allocaArray)
+import Foreign.Ptr ( Ptr )
+import Foreign.C.Error ( errnoToIOError )
+import Control.Exception ( throwIO )
+import qualified Control.Exception as EX
+import GHC.Ptr (castPtr)
+import GHC.IO.Exception
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Word (Word)
+#endif
+
+import GHC.IO.Encoding.UTF16 ( mkUTF16le )
+import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
+
+#include <fcntl.h>
+#include <windows.h>
+#include <wchar.h>
+##include "windows_cconv.h"
+
+
+----------------------------------------------------------------
+-- Chars and strings
+----------------------------------------------------------------
+
+withTString    :: WindowsString -> (LPTSTR -> IO a) -> IO a
+withFilePath   :: WindowsPath -> (LPTSTR -> IO a) -> IO a
+withTStringLen :: WindowsString -> ((LPTSTR, Int) -> IO a) -> IO a
+peekTString    :: LPCTSTR -> IO WindowsString
+peekTStringLen :: (LPCTSTR, Int) -> IO WindowsString
+newTString     :: WindowsString -> IO LPCTSTR
+
+-- UTF-16 version:
+-- the casts are from 'Ptr Word16' to 'Ptr CWchar', which is safe
+withTString (WindowsString str) f    = useAsCWString str (\ptr -> f (castPtr ptr))
+withFilePath path = useAsCWStringSafe path
+withTStringLen (WindowsString str) f = useAsCWStringLen str (\(ptr, len) -> f (castPtr ptr, len))
+peekTString    = fmap WindowsString . packCWString . castPtr
+peekTStringLen = fmap WindowsString . packCWStringLen . first castPtr
+newTString (WindowsString str) = fmap castPtr $ newCWString str
+
+foreign import ccall unsafe "wchar.h wcslen" c_wcslen
+    :: CWString -> IO SIZE_T
+
+-- | Wrapper around 'useAsCString', checking the encoded 'FilePath' for internal NUL codepoints as these are
+-- disallowed in Windows filepaths. See https://gitlab.haskell.org/ghc/ghc/-/issues/13660
+useAsCWStringSafe :: WindowsPath -> (CWString -> IO a) -> IO a
+useAsCWStringSafe wp@(WS path) f = useAsCWString path $ \(castPtr -> ptr) -> do
+    let len = SBS.numWord16 path
+    clen <- c_wcslen ptr
+    if clen == fromIntegral len
+        then f ptr
+        else do
+          path' <- either (const (_toStr wp)) id <$> (EX.try @IOException) (decodeWithBaseWindows path)
+          ioError (err path')
+  where
+    _toStr = fmap WS.toChar . WS.unpack
+    err path' =
+        IOError
+          { ioe_handle = Nothing
+          , ioe_type = InvalidArgument
+          , ioe_location = "useAsCWStringSafe"
+          , ioe_description = "Windows filepaths must not contain internal NUL codepoints."
+          , ioe_errno = Nothing
+          , ioe_filename = Just path'
+          }
+
+----------------------------------------------------------------
+-- Errors
+----------------------------------------------------------------
+
+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
+
+
+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 <- either (fail . show) pure . decodeWith (mkUTF16le TransliterateCodingFailure) =<< if c_msg == nullPtr
+           then either (fail . show) pure . encodeWith (mkUTF16le TransliterateCodingFailure) $ "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
+
+
+-- 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 WindowsString
+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

+ System/Win32/WindowsString/Utils.hs view

@@ -0,0 +1,63 @@+{- |
+   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.WindowsString.Utils
+  ( module System.Win32.WindowsString.Utils
+  , module System.Win32.Utils
+  ) where
+
+import Foreign.C.Types             ( CInt )
+import Foreign.Marshal.Array       ( allocaArray )
+import Foreign.Ptr                 ( nullPtr )
+
+import System.Win32.Utils hiding
+  ( try
+  , tryWithoutNull
+  , trySized
+  )
+import System.Win32.WindowsString.String         ( LPTSTR, peekTString, peekTStringLen
+                                   , withTStringBufferLen )
+import System.Win32.WindowsString.Types          ( UINT
+                                   , failIfZero
+                                  )
+import qualified System.Win32.WindowsString.Types ( try )
+import System.OsString.Windows
+
+
+-- | 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 WindowsString
+try = System.Win32.WindowsString.Types.try
+{-# INLINE try #-}
+
+tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString
+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
+
+-- | Support for API calls that return the required size, in characters
+-- including a null character, of the buffer when passed a buffer size of zero.
+trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO WindowsString
+trySized wh f = do
+    c_len <- failIfZero wh $ f nullPtr 0
+    let len = fromIntegral c_len
+    withTStringBufferLen len $ \(buf', len') -> do
+        let c_len' = fromIntegral len'
+        c_len'' <- failIfZero wh $ f buf' c_len'
+        let len'' = fromIntegral c_len''
+        peekTStringLen (buf', len'' - 1) -- Drop final null character

+ System/Win32/Word.hs view

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

Win32.cabal view

@@ -1,25 +1,59 @@-name:		Win32-version:	2.2.2.0-license:	BSD3-license-file:	LICENSE-author:		Alastair Reid-copyright:	Alastair Reid, 1999-2003-maintainer:	Bryan O'Sullivan <bos@serpentine.com>+cabal-version:  2.0+name:           Win32+version:        2.14.2.2+license:        BSD3+license-file:   LICENSE+author:         Alastair Reid, shelarcy, Tamar Christina+copyright:      Alastair Reid, 1999-2003; shelarcy, 2012-2013; Tamar Christina, 2016-2020+maintainer:     Haskell Libraries <libraries@haskell.org> bug-reports:    https://github.com/haskell/win32/issues homepage:       https://github.com/haskell/win32-category:	System, Graphics-synopsis:	A binding to part of the Win32 library-description:	A binding to part of the Win32 library.+category:       System, Graphics+synopsis:       A binding to Windows Win32 API.+description:    This library contains direct bindings to the Windows Win32 APIs for Haskell. build-type:     Simple-cabal-version:  >=1.6 extra-source-files:-	include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h-	include/gettime.h include/Win32Aux.h include/win32debug.h+    include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h+    include/Win32Aux.h include/win32debug.h include/alignment.h+extra-doc-files:+    changelog.md+tested-with:+    GHC == 9.2.7,+    GHC == 9.4.5,+    GHC == 9.6.7,+    GHC == 9.8.4,+    GHC == 9.10.1,+    GHC == 9.12.1 +flag os-string+  description: Use the new os-string package+  default: False+  manual: False+ Library-    build-depends:	base >= 3 && < 5, bytestring-    ghc-options:    -Wall -fno-warn-name-shadowing-    cc-options:     -fno-strict-aliasing+    default-language: Haskell2010+    default-extensions: ForeignFunctionInterface, CPP+    if impl(ghc >= 7.1)+        default-extensions: NondecreasingIndentation++    if !os(windows)+        -- This package requires Windows to build+        build-depends: unbuildable<0+        buildable: False++    build-depends:      base >= 4.5 && < 5++    -- AFPP support+    if impl(ghc >= 8.0)+      if flag(os-string)+        build-depends: filepath >= 1.5.0.0, os-string >= 2.0.0+      else+        build-depends: filepath >= 1.4.100.0 && < 1.5.0.0++    -- Black list hsc2hs 0.68.6 which is horribly broken.+    build-tool-depends: hsc2hs:hsc2hs > 0 && < 0.68.6 || > 0.68.6+    ghc-options:        -Wall -fno-warn-name-shadowing+    cc-options:         -fno-strict-aliasing     exposed-modules:         Graphics.Win32.GDI         Graphics.Win32.GDI.Bitmap@@ -43,13 +77,27 @@         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+        System.Win32.Event         System.Win32.File         System.Win32.FileMapping+        System.Win32.NamedPipes         System.Win32.Info+        System.Win32.Path         System.Win32.Mem+        System.Win32.MinTTY         System.Win32.NLS         System.Win32.Process         System.Win32.Registry@@ -57,16 +105,63 @@         System.Win32.Time         System.Win32.Console         System.Win32.Security+        System.Win32.Semaphore         System.Win32.Types         System.Win32.Shell-    extensions: ForeignFunctionInterface, CPP-    if impl(ghc >= 7.1)-        extensions: NondecreasingIndentation+        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++    -- AFPP support+    if impl(ghc >= 8.0)+        exposed-modules:+            System.Win32.WindowsString.Console+            System.Win32.WindowsString.Types+            System.Win32.WindowsString.DebugApi+            System.Win32.WindowsString.DLL+            System.Win32.WindowsString.Shell+            System.Win32.WindowsString.String+            System.Win32.WindowsString.File+            System.Win32.WindowsString.Time+            System.Win32.WindowsString.Info+            System.Win32.WindowsString.FileMapping+            System.Win32.WindowsString.HardLink+            System.Win32.WindowsString.Path+            System.Win32.WindowsString.SymbolicLink+            System.Win32.WindowsString.Utils++    other-modules:+        System.Win32.Console.Internal+        System.Win32.DebugApi.Internal+        System.Win32.DLL.Internal+        System.Win32.File.Internal+        System.Win32.FileMapping.Internal+        System.Win32.HardLink.Internal+        System.Win32.Info.Internal+        System.Win32.Path.Internal+        System.Win32.Shell.Internal+        System.Win32.SymbolicLink.Internal+        System.Win32.Time.Internal+     extra-libraries:-        "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder"-    include-dirs: 	include-    includes:	"HsWin32.h", "HsGDI.h", "WndProc.h"-    install-includes:	"HsWin32.h", "HsGDI.h", "WndProc.h"+        "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder", "shlwapi", "msimg32", "imm32"+    ghc-options:      -Wall+    include-dirs:     include+    install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h", "windows_cconv.h", "alphablend.h", "wincon_compat.h", "winternl_compat.h", "winuser_compat.h", "winreg_compat.h", "tlhelp32_compat.h", "winnls_compat.h", "winnt_compat.h", "namedpipeapi_compat.h"     c-sources:         cbits/HsGDI.c         cbits/HsWin32.c@@ -75,7 +170,9 @@         cbits/dumpBMP.c         cbits/ellipse.c         cbits/errors.c+        cbits/alphablend.c+    cc-options: -Wall  source-repository head     type:     git-    location: git://github.com/haskell/win32+    location: https://github.com/haskell/win32

cbits/WndProc.c view

@@ -71,7 +71,7 @@     LRESULT lr;      if (hwnd) {-	LONG wndprocptr = GetWindowLong(hwnd,GWL_USERDATA);+	LONG_PTR wndprocptr = GetWindowLongPtr(hwnd,GWLP_USERDATA); 	if (wndprocptr) { 	    lr = ((LRESULT (*)(HWND,UINT,WPARAM,LPARAM))(wndprocptr))(hwnd,msg,wParam,lParam); #if 0

+ cbits/alphablend.c view

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

cbits/dumpBMP.c view

@@ -38,7 +38,6 @@ {     HANDLE      hFile;     HBITMAP     hTmpBmp, hBmpOld;-    BOOL        bSuccess;     BITMAPFILEHEADER    bfh;     LPBITMAPINFO pbmi;     PBYTE       pBits;@@ -48,7 +47,6 @@ 	DWORD 		dwBytesWritten;  -    bSuccess = TRUE; #if 0     if (ghPal) {         SelectPalette(hDC, ghPal, FALSE);@@ -66,7 +64,7 @@     // if BitCount != 0, color table will be retrieved     //     bmi.bmiHeader.biSize = 0x28;              // GDI need this to work-    bmi.bmiHeader.biBitCount = 0;             // dont get the color table+    bmi.bmiHeader.biBitCount = 0;             // don't get the color table     if ((GetDIBits(hDC, hBmp, 0, 0, (LPSTR)NULL, &bmi, DIB_RGB_COLORS)) == 0) {         fprintf(stderr, "GetDIBits failed!");         return;@@ -83,7 +81,7 @@     }      //-    // Note: 24 bits per pixel has no color table.  So, we dont have to+    // Note: 24 bits per pixel has no color table.  So, we don't have to     // allocate memory for retrieving that.  Otherwise, we do.     //     pbmi = &bmi;                                      // assume no color table@@ -112,11 +110,10 @@         //         if ((pbmi = (LPBITMAPINFO)GlobalAlloc(GMEM_FIXED | GMEM_ZEROINIT, sizBMI )) == NULL) {             fprintf(stderr, "Failed in Memory Allocation for pbmi!");-            bSuccess = FALSE;             goto ErrExit1;         }         //-        // Now that weve a bigger chunk of memory, lets copy the Bitmap+        // Now that we've a bigger chunk of memory, lets copy the Bitmap         // info header data over         //         pjTmp = (PBYTE)pbmi;@@ -153,7 +150,6 @@     //     if (WriteFile(hFile, (LPCVOID)&bfh, sizeof(BITMAPFILEHEADER), &dwBytesWritten, NULL) == -1) {         fprintf(stderr, "Failed in WriteFile!");-        bSuccess = FALSE;         goto ErrExit3;     } @@ -167,12 +163,10 @@         hBmpOld = SelectObject(hDC, hTmpBmp);         if ((GetDIBits(hDC, hBmp, 0, pbmi->bmiHeader.biHeight, (LPSTR)pBits, pbmi, DIB_RGB_COLORS))==0){             fprintf(stderr, "Failed in GetDIBits!");-            bSuccess = FALSE;             goto ErrExit4;         }     } else {         fprintf(stderr, "Failed in creating bitmap!");-        bSuccess = FALSE;         goto ErrExit3;     } @@ -181,7 +175,6 @@     //     if (WriteFile(hFile, (LPCVOID)pbmi, sizBMI, &dwBytesWritten, NULL) == -1) {         fprintf(stderr, "Failed in WriteFile!");-        bSuccess = FALSE;         goto ErrExit4;     } @@ -190,7 +183,6 @@     //     if (WriteFile(hFile, (LPCVOID)pBits, pbmi->bmiHeader.biSizeImage, &dwBytesWritten, NULL) == -1) {         fprintf(stderr, "Failed in WriteFile!");-        bSuccess = FALSE;         goto ErrExit4;     }

+ changelog.md view

@@ -0,0 +1,246 @@+# Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32)++## 2.14.2.2 May 2026++* Fix version bounds for older GHC and drop numeric underscore++## 2.14.2.1 June 2025++* Fix compilation of `ReplaceFileW` on some GHC versions [#245](https://github.com/haskell/win32/issues/245)++## 2.14.2.0 May 2025++* Add ReplaceFileW+* Add support for Windows on Arm+* Add ReadConsoleInput++## 2.14.1.0 November 2024++* Add getTempFileName+* Add WindowsString variant for getEnv etc+* Implement getEnv and getEnvironment++## 2.14.0.0 January 2023++* Add support for named pipes [#220](https://github.com/haskell/win32/pull/220)+* Ensure that FilePaths don't contain interior NULs wrt [#218](https://github.com/haskell/win32/pull/218)+* Add support for GetCommandLineW [#218](https://github.com/haskell/win32/pull/221)+* Support filepath >= 1.5.0.0 and os-string [#226](https://github.com/haskell/win32/pull/226)+* Remove unused imports [#225](https://github.com/haskell/win32/pull/225)++## 2.13.4.0 October 2022++* Add support for semaphores with `System.Win32.Semaphore` (See #214).+* Add function `createFile_NoRetry` (see #208)+* The type signatures for `loadLibrary` and `loadLibraryEx` now refer to+  `HMODULE` instead of `HINSTANCE` for consistency with the official Win32+  API documentation. Note that `HMODULE` and `HINSTANCE` are both type synonyms+  for the same thing, so this only changes the presentation of these functions'+  type signatures, not their behavior.++## 2.13.3.0 July 2022++* Add AFPP support (see #198)++## 2.13.2.1 July 2022++* Add function `createIcon` (see #194)+* Add `WindowMessage` value `wM_SETICON` (see #194)+* Add `WPARAM` values `iCON_SMALL`, `iCON_BIG` (see #194)+* Add functions `getConsoleScreenBufferInfoEx` and+  `getCurrentConsoleScreenBufferInfoEx`++## 2.13.2.0 November 2021++* Set maximum string size for getComputerName. (See #190)+* Update withHandleToHANDLENative to handle duplex and console handles (See #191)++## 2.13.1.0 November 2021++* Fix a bug in which `System.Win32.MinTTY.isMinTTY` would incorrectly return+  `False` on recent versions of MinTTY. (See #187)+* Add all flags for CreateToolhelp32Snapshot.  (See #185)++## 2.13.0.0 August 2021++* Fix type of c_SetWindowLongPtr. See #180++## 2.12.0.1 June 2021++* A small fix for WinIO usage. See #177++## 2.12.0.0 March 2021++* Win32 for GHC 9.2.x+* Add export lists to all modules, hiding numerous internal `c_` bindings.+* Update the type of `setFileTime` to reflect the fact that the `FILETIME`+  arguments are in fact `Maybe`s.++## 2.11.1.0 February 2021++* Make `System.Win32.NLS` re-export `CodePage` from `GHC.IO.Encoding.CodePage`+  in `base` when compiled with `base-4.15` or later.++## 2.11.0.0 January 2021++* Remove function `mapFileBs`.++## 2.10.1.0 October 2020++* Add `System.Win32.Event` module+* Add function `openEvent`+* Add function `createEvent`+* Add function `duplicateHandle`+* Add function `setEvent`+* Add function `resetEvent`+* Add function `pulseEvent`+* Add function `signalObjectAndWait`+* Add function `waitForSingleObject`+* Add function `waitForSingleObjectEx`+* Add function `waitForMultipleObjects`+* Add function `waitForMultipleObjectsEx`+* Add enums `DUPLICATE_CLOSE_SOURCE`, `DUPLICATE_SAME_ACCESS`,+  `EVENT_ALL_ACCESS`, `EVENT_MODIFY_STATE`, `WAIT_ABANDONED`,+  `WAIT_IO_COMPLETION`, `WAIT_OBJECT_0`, `WAIT_TIMEOUT` and `WAIT_FAILED`.+* Add struct `SECURITY_ATTRIBUTES`++## 2.10.0.0 September 2020++* Add function `isWindowVisible`+* Add function `getLastInputInfo`+* Add function `getTickCount`+* Add function `getIdleTime`+* Add `enumSystemLocalesEx`, `enumSystemLocalesEx'`,+  `getSystemDefaultLocaleName`, `getUserDefaultLocaleName`, `isValidLocaleName`,+  `getLocaleInfoEx`, `getTimeFormatEx` and `lCMapStringEx`+* Add `trySized` - similar to `try` but for API calls that return the required+  size of the buffer when passed a buffer size of zero.+* Add `fromDateFormatPciture` and `fromTimeFormatPicture`, to translate from+  Windows date and time format pictures to format strings used by the `time`+  package.+* Renamed fields of `COORD` and `SMALL_RECT` to avoid name clashes. (See #157)++## 2.9.0.0 June 2020++* `setWindowClosure` now returns the old window closure.+* `defWindowProc` now assumes the data stored in `GWLP\_USERDATA`+  is the window closure (in line with `setWindowClosure` and+  the supplied C `genericWndProc`)+* `defWindowProc` now frees the window closure+* `getMessage` and `peekMessage` test for -1 to identify the error condition+* Support creating symbolic links without Administrator privilege (See #147)+* Support for `winio` the new Windows I/O manager.++## 2.8.5.0 Dec 2019++* Add `getConsoleMode` and `setConsoleMode` (See #137)++## 2.8.4.0 *Oct 2019*++* Added function `getWindowText`+* Added function `getWindowTextLength`++## 2.8.3.0 *Feb 2019*++* Add `Module32FirstW` and `Module32NextW` (See #121)+* Add `Virtual[Alloc/Free]Ex` (See #124)++## 2.8.2.0 *Dec 2018*++* Drop use of NegativeLiterals (See #118)++## 2.8.1.0 *Nov 2018*++* Fix broken links (See #116)+* Remove unused CPP Lower bounds (See #114)+* GHC 8.8 release++## 2.8.0.0 *May 2018*++* Deprecated `regQueryValueKey`. (See #105, #108)+* Updated `regQueryValue` signature (See #108)+* Add `regQueryDefaultValue` (See #108)+* Add `regGetValue` and `RegTypeRestriction` (See #109)+* Remove `sYNCHRONIZE` from System.Win32.Process, use System.Win32.File instead. (See #110)++## 2.7.1.0 *April 2018*++* Fixed `MOUSEINPUT` storable instance. (See #106)++## 2.7.0.0 *March 2018*++* Fixed `DWORD_PTR` type (See #99)+* Add `lockFile` and `unlockFile` (See #103)++## 2.6.2.0 *December 2017*++* Add `setFilePointerEx` (See #94)+* Add `getConsoleScreenBufferInfo` and `getCurrentConsoleScreenBufferInfo` (See #95)++## 2.6.1.0 *November 2017*++* Add `terminateProcessById` (See #91)++## 2.6.0.0 *September 2017*++* Make cabal error out on compilation on non-Windows OSes. (See #80)+* Update cabal format to 1.10 and set language+  default to Haskell2010. (See #81)+* Use `Maybe` in wrappers for functions with nullable pointer parameters (See #83)+* Improve cross compilation support. (See #87)++## 2.5.4.1 *April 2017*++* Fixed GetWindowLong on 32-bit Windows++## 2.5.3.0 *March 2017*++* Fix buffer overflow in `regSetValue`. (See #39)+* Added `getPixel`. (See #37)+* Drop dependency on `ntdll` because of incorrect import library on x86. (See #79)++## 2.5.2.0 *March 2017*++* Fix constant underflows with (-1) and unsigned numbers.+* Add `commandLineToArgv`++## 2.5.1.0 *Feb 2017*++* Add `withHandleToHANDLE` (originally found in the `ansi-terminal` library)+* fixed `PokeTZI` test++## 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

include/HsWin32.h view

@@ -12,9 +12,8 @@ # endif #endif -INLINE UINT castPtrToUINT(void *p) { return (UINT)p; }-INLINE void *castUINTToPtr(UINT n) { return (void *)n; }-INLINE LONG castFunPtrToLONG(void *p) { return (LONG)p; }+INLINE UINT_PTR castPtrToUINTPtr(void *p) { return (UINT_PTR)p; }+INLINE void *castUINTPtrToPtr(UINT_PTR n) { return (void *)n; } INLINE WORD hIWORD(DWORD w) { return HIWORD(w); } INLINE WORD lOWORD(DWORD w) { return LOWORD(w); }

+ include/alignment.h view

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

+ include/alphablend.h view

@@ -0,0 +1,10 @@+#ifndef _ALPHABLEND_H+#define _ALPHABLEND_H++#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 */

− include/gettime.h

@@ -1,5 +0,0 @@-#include <windows.h>--/* Prototype missing from Cygwin B20.1 */--extern DWORD WINAPI timeGetTime();

+ include/namedpipeapi_compat.h view

@@ -0,0 +1,16 @@+/* The version of wincon.h provided by the version of MSYS2 included with x86+ * versions of GHC before GHC 7.10 excludes certain components introduced with+ * Windows Vista.+ */++#ifndef NAMEDPIPEAPI_COMPAT_H+#define NAMEDPIPEAPI_COMPAT_H++#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708+#+#else++#define PIPE_ACCEPT_REMOTE_CLIENTS 0x0+#define PIPE_REJECT_REMOTE_CLIENTS 0x8+#endif /* GHC version check */+#endif /* NAMEDPIPEAPI_COMPAT_H */

+ include/tlhelp32_compat.h view

@@ -0,0 +1,26 @@+#ifndef TLHELP32_COMPAT_H+#define TLHELP32_COMPAT_H+ /*+ * tlhelp32.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 __GLASGOW_HASKELL__ >= 710+#else+// Declarations from tlhelp32.h that Win32 requires+#include <windows.h>++// CreateToolhelp32Snapshot Flags+// https://docs.microsoft.com/en-us/windows/win32/api/tlhelp32/nf-tlhelp32-createtoolhelp32snapshot++#define TH32CS_INHERIT      0x80000000++#define TH32CS_SNAPHEAPLIST 0x00000001+#define TH32CS_SNAPPROCESS  0x00000002+#define TH32CS_SNAPTHREAD   0x00000004+#define TH32CS_SNAPMODULE   0x00000008+#define TH32CS_SNAPMODULE32 0x00000010++#define TH32CS_SNAPALL (TH32CS_SNAPHEAPLIST|TH32CS_SNAPPROCESS|TH32CS_SNAPTHREAD|TH32CS_SNAPMODULE)++#endif+#endif /* TLHELP32_COMPAT_H */

+ include/wincon_compat.h view

@@ -0,0 +1,26 @@+/* The version of wincon.h provided by the version of MSYS2 included with x86+ * versions of GHC before GHC 7.10 excludes certain components introduced with+ * Windows Vista.+ */++#ifndef WINCON_COMPAT_H+#define WINCON_COMPAT_H++#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708+#+#else++typedef struct _CONSOLE_SCREEN_BUFFER_INFOEX {+  ULONG      cbSize;+  COORD      dwSize;+  COORD      dwCursorPosition;+  WORD       wAttributes;+  SMALL_RECT srWindow;+  COORD      dwMaximumWindowSize;+  WORD       wPopupAttributes;+  WINBOOL    bFullscreenSupported;+  COLORREF   ColorTable[16];+} CONSOLE_SCREEN_BUFFER_INFOEX, *PCONSOLE_SCREEN_BUFFER_INFOEX;++#endif /* GHC version check */+#endif /* WINCON_COMPAT_H */

+ include/windows_cconv.h view

@@ -0,0 +1,13 @@+#ifndef __WINDOWS_CCONV_H+#define __WINDOWS_CCONV_H++#if defined(i386_HOST_ARCH)+# define WINDOWS_CCONV stdcall+#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH)+# define WINDOWS_CCONV ccall+#else+# error Unknown mingw32 arch+#endif++#endif+

+ include/winnls_compat.h view

@@ -0,0 +1,105 @@+/* The version of winnls.h provided by the version of MSYS2 included with+ * versions of GHC before GHC 7.10 excludes certain components introduced with+ * Windows Vista.+ */++#ifndef WINNLS_COMPAT_H+#define WINNLS_COMPAT_H++#if __GLASGOW_HASKELL__ < 710+// Locale information constants+#define LOCALE_IGEOID 0x0000005b+#define LOCALE_SCONSOLEFALLBACKNAME 0x0000006e+#define LOCALE_SDURATION 0x0000005d+#define LOCALE_SENGLISHCOUNTRYNAME 0x00001002+#define LOCALE_SENGLISHLANGUAGENAME 0x00001001+#define LOCALE_SISO3166CTRYNAME2 0x00000068+#define LOCALE_SISO639LANGNAME2 0x00000067+#define LOCALE_SKEYBOARDSTOINSTALL 0x0000005e+#define LOCALE_SNAME 0x0000005c+#define LOCALE_SNAN 0x00000069+#define LOCALE_SNATIVECOUNTRYNAME 0x00000008+#define LOCALE_SNEGINFINITY 0x0000006b+#define LOCALE_SPARENT 0x0000006d+#define LOCALE_SPOSINFINITY 0x0000006a+#define LOCALE_SSCRIPTS 0x0000006c+#define LOCALE_SSHORTESTDAYNAME1 0x00000060+#define LOCALE_SSHORTESTDAYNAME2 0x00000061+#define LOCALE_SSHORTESTDAYNAME3 0x00000062+#define LOCALE_SSHORTESTDAYNAME4 0x00000063+#define LOCALE_SSHORTESTDAYNAME5 0x00000064+#define LOCALE_SSHORTESTDAYNAME6 0x00000065+#define LOCALE_SSHORTESTDAYNAME7 0x00000066+// Locale map flag constants+#define LINGUISTIC_IGNORECASE 0x00000010+#define LINGUISTIC_IGNOREDIACRITIC 0x00000020+#define NORM_LINGUISTIC_CASING 0x08000000+// Locale enumeration flag constants+#define LOCALE_ALL                  0+#define LOCALE_ALTERNATE_SORTS      0x00000004+#define LOCALE_REPLACEMENT          0x00000008+#define LOCALE_SUPPLEMENTAL         0x00000002+#define LOCALE_WINDOWS              0x00000001+// Other+WINBASEAPI WINBOOL WINAPI IsValidLocaleName (LPCWSTR lpLocaleName);+#endif++#if __GLASGOW_HASKELL__ < 710 && defined(i386_HOST_ARCH)+// Locale information constants+#define LOCALE_IDEFAULTMACCODEPAGE 0x00001011+// Other+typedef struct _nlsversioninfoex {+  DWORD dwNLSVersionInfoSize;+  DWORD dwNLSVersion;+  DWORD dwDefinedVersion;+  DWORD dwEffectiveId;+  GUID  guidCustomVersion;+} NLSVERSIONINFOEX, *LPNLSVERSIONINFOEX;++WINBASEAPI int WINAPI GetLocaleInfoEx(+  LPCWSTR lpLocaleName,+  LCTYPE LCType,+  LPWSTR lpLCData,+  int cchData+);++WINBASEAPI WINBOOL WINAPI GetNLSVersionEx(+  NLS_FUNCTION function,+  LPCWSTR lpLocaleName,+  LPNLSVERSIONINFOEX lpVersionInformation+);++WINBASEAPI int WINAPI LCMapStringEx(+  LPCWSTR lpLocaleName,+  DWORD dwMapFlags,+  LPCWSTR lpSrcStr,+  int cchSrc,+  LPWSTR lpDestStr,+  int cchDest,+  LPNLSVERSIONINFO lpVersionInformation,+  LPVOID lpReserved,+  LPARAM lParam+);+++WINBASEAPI int WINAPI GetTimeFormatEx(+  LPCWSTR lpLocaleName,+  DWORD dwFlags,+  const SYSTEMTIME *lpTime,+  LPCWSTR lpFormat,+  LPWSTR lpTimeStr,+  int cchTime+);++WINBASEAPI int WINAPI GetSystemDefaultLocaleName(+  LPWSTR lpLocaleName,+  int cchLocaleName+);++WINBASEAPI int WINAPI GetUserDefaultLocaleName(+  LPWSTR lpLocaleName,+  int cchLocaleName+);+#endif++#endif /* #ifndef WINNLS_COMPAT_H */

+ include/winnt_compat.h view

@@ -0,0 +1,13 @@+/* The version of winnt.h provided by the version of MSYS2 included with+ * versions of GHC before GHC 7.10 excludes certain components introduced with+ * Windows Vista.+ */++#ifndef WINNT_COMPAT_H+#define WINNT_COMPAT_H++#if __GLASGOW_HASKELL__ < 710 && defined(i386_HOST_ARCH)+#define LOCALE_NAME_MAX_LENGTH 85+#endif++#endif /* #ifndef WINNT_COMPAT_H */

+ include/winreg_compat.h view

@@ -0,0 +1,32 @@+#ifndef WINREG_COMPAT_H+#define WINREG_COMPAT_H++#if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708+#+#else+#define RRF_RT_REG_NONE 0x00000001+#define RRF_RT_REG_SZ 0x00000002+#define RRF_RT_REG_EXPAND_SZ 0x00000004+#define RRF_RT_REG_BINARY 0x00000008+#define RRF_RT_REG_DWORD 0x00000010+#define RRF_RT_REG_MULTI_SZ 0x00000020+#define RRF_RT_REG_QWORD 0x00000040++#define RRF_RT_DWORD (RRF_RT_REG_BINARY | RRF_RT_REG_DWORD)+#define RRF_RT_QWORD (RRF_RT_REG_BINARY | RRF_RT_REG_QWORD)+#define RRF_RT_ANY 0x0000ffff++#define RRF_NOEXPAND 0x10000000+#define RRF_ZEROONFAILURE 0x20000000++#endif++#ifndef RRF_SUBKEY_WOW6464KEY+#define RRF_SUBKEY_WOW6464KEY 0x00010000+#endif++#ifndef RRF_SUBKEY_WOW6432KEY+#define RRF_SUBKEY_WOW6432KEY 0x00020000+#endif++#endif /* WINREG_COMPAT_H */

+ include/winternl_compat.h view

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

+ include/winuser_compat.h view

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