packages feed

Win32 2.6.2.1 → 2.14.2.2

raw patch · 92 files changed

Files

Graphics/Win32.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/Control.hsc view
@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Win32.Control
Graphics/Win32/Dialogue.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI.hs view
@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Win32.GDI@@ -18,10 +16,10 @@ -----------------------------------------------------------------------------  {-# 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 (
Graphics/Win32/GDI/Bitmap.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Brush.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Clip.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Font.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Graphics2D.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -102,7 +102,7 @@ -- 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 ()
Graphics/Win32/GDI/HDC.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Palette.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Path.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Pen.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Region.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/GDI/Types.hsc view
@@ -1,6 +1,4 @@-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Win32.GDI.Types
Graphics/Win32/Icon.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -19,6 +19,7 @@  module Graphics.Win32.Icon where +import Foreign (Ptr) import Graphics.Win32.GDI.Types import System.Win32.Types @@ -27,6 +28,12 @@ ---------------------------------------------------------------- -- 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 =
Graphics/Win32/Key.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/LayeredWindow.hsc view
@@ -10,17 +10,14 @@ 
    Provides LayeredWindow functionality.
 -}
-module Graphics.Win32.LayeredWindow where
+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 Foreign.C.Types ( CIntPtr(..) )
-import Foreign.Marshal.Utils ( with )
 import Graphics.Win32.GDI.AlphaBlend ( BLENDFUNCTION )
 import Graphics.Win32.GDI.Types      ( COLORREF, HDC, SIZE, SIZE, POINT )
-import Graphics.Win32.Window         ( WindowStyleEx, c_SetWindowLongPtr,  )
-import System.Win32.Types ( DWORD, HANDLE, BYTE, BOOL,
-                            LONG_PTR, INT )
+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"
@@ -29,7 +26,7 @@ toLayeredWindow :: HANDLE -> IO ()
 toLayeredWindow w = do
   flg <- c_GetWindowLongPtr w gWL_EXSTYLE
-  void $ with (fromIntegral $ flg .|. (fromIntegral wS_EX_LAYERED)) $ c_SetWindowLongPtr w gWL_EXSTYLE
+  void $ c_SetWindowLongPtr w gWL_EXSTYLE (flg .|. (fromIntegral wS_EX_LAYERED))
 
 -- test w =  c_SetLayeredWindowAttributes w 0 128 lWA_ALPHA
 
@@ -52,16 +49,9 @@ 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
 
-#if defined(x86_64_HOST_ARCH)
-foreign import WINDOWS_CCONV "windows.h GetWindowLongPtrW"
-  c_GetWindowLongPtr :: HANDLE -> INT -> IO LONG_PTR
-#else
-foreign import WINDOWS_CCONV "windows.h GetWindowLongW"
-  c_GetWindowLongPtr :: HANDLE -> INT -> IO LONG_PTR
-#endif
-
 #{enum DWORD,
  , uLW_ALPHA    = ULW_ALPHA
  , uLW_COLORKEY = ULW_COLORKEY
  , uLW_OPAQUE   = ULW_OPAQUE
  }
+
Graphics/Win32/Menu.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/Message.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -158,6 +158,7 @@  , wM_QUEUESYNC         = WM_QUEUESYNC  , wM_USER              = WM_USER  , wM_APP               = WM_APP+ , wM_SETICON           = WM_SETICON  }  registerWindowMessage :: String -> IO WindowMessage@@ -173,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,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -268,7 +268,7 @@  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
Graphics/Win32/Resource.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
Graphics/Win32/Window.hsc view
@@ -1,8 +1,5 @@ {-# LANGUAGE CApiFFI #-}-{-# LANGUAGE NegativeLiterals #-}-#if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Graphics.Win32.Window@@ -19,13 +16,15 @@  module Graphics.Win32.Window where -import Control.Monad (liftM)+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.Ptr (FunPtr, Ptr, castFunPtrToPtr, castPtr, nullPtr)+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)@@ -33,12 +32,13 @@ 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)+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 (HINSTANCE, LPARAM, LPCTSTR, LPVOID, withTString)-import System.Win32.Types (failIf, failIf_, failIfFalse_, failIfNull, maybeNum)+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)  ##include "windows_cconv.h" @@ -54,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@@ -204,12 +204,27 @@ 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_SetWindowLongPtr wnd (#{const GWLP_USERDATA})-                              (castPtr (castFunPtrToPtr fp))-  return ()+  fpOld <- c_SetWindowLongPtr wnd (#{const GWLP_USERDATA})+                              (mkCIntPtr fp)+  if fpOld == 0+     then return Nothing+     else return $ Just $ castPtrToFunPtr $ intPtrToPtr $ fromIntegral fpOld  {- Note [SetWindowLongPtrW] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -223,13 +238,27 @@ -} #if defined(i386_HOST_ARCH) foreign import WINDOWS_CCONV unsafe "windows.h SetWindowLongW"-#elif defined(x86_64_HOST_ARCH)+#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 -> Ptr LONG -> IO (Ptr LONG)+  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 ->@@ -238,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@@ -252,7 +285,7 @@     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 WINDOWS_CCONV "windows.h CreateWindowExW"   c_CreateWindowEx@@ -263,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++-- | 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@@ -325,6 +389,41 @@   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 ---------------------------------------------------------------- @@ -375,6 +474,9 @@ foreign import WINDOWS_CCONV "windows.h ShowWindow"   showWindow :: HWND  -> ShowWindowControl  -> IO Bool +foreign import WINDOWS_CCONV "windows.h IsWindowVisible"+  isWindowVisible :: HWND -> IO Bool+ ---------------------------------------------------------------- -- Misc ----------------------------------------------------------------@@ -511,7 +613,7 @@  foreign import WINDOWS_CCONV unsafe "windows.h GetForegroundWindow"   getForegroundWindow :: IO HWND-+   getParent :: HWND -> IO HWND getParent wnd =   failIfNull "GetParent" $ c_GetParent wnd@@ -653,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
− Setup.hs 
@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMainWithHooks autoconfUserHooks
System/Win32.hs view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -19,6 +19,7 @@  module System.Win32         ( module System.Win32.DLL+        , module System.Win32.Event         , module System.Win32.File         , module System.Win32.FileMapping         , module System.Win32.Info@@ -40,6 +41,7 @@         ) where  import System.Win32.DLL+import System.Win32.Event import System.Win32.File import System.Win32.FileMapping import System.Win32.Info
System/Win32/Automation/Input.hsc view
@@ -11,7 +11,16 @@    Provide sendInput function and INPUT types.
 -}
 module System.Win32.Automation.Input
-  ( 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
System/Win32/Automation/Input/Mouse.hsc view
@@ -36,7 +36,7 @@     alignment _ = #alignment MOUSEINPUT
     poke buf input = do
         (#poke MOUSEINPUT, dx) buf (dx input)
-        (#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)
System/Win32/Console.hsc view
@@ -1,7 +1,7 @@ #if __GLASGOW_HASKELL__ >= 709
-{-# LANGUAGE Safe #-}
-#elif __GLASGOW_HASKELL__ >= 701
 {-# LANGUAGE Trustworthy #-}
+#else
+{-# LANGUAGE Trustworthy #-}
 #endif
 -----------------------------------------------------------------------------
 -- |
@@ -18,6 +18,23 @@ -----------------------------------------------------------------------------
 
 module System.Win32.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,
@@ -28,45 +45,81 @@         generateConsoleCtrlEvent,
         -- * Command line
         commandLineToArgv,
+        getCommandLineW,
+        getArgs,
         -- * Screen buffer
         CONSOLE_SCREEN_BUFFER_INFO(..),
+        CONSOLE_SCREEN_BUFFER_INFOEX(..),
         COORD(..),
         SMALL_RECT(..),
+        COLORREF,
         getConsoleScreenBufferInfo,
-        getCurrentConsoleScreenBufferInfo
+        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 Graphics.Win32.Misc 
+import System.Win32.String
+import System.Win32.Console.Internal
+import Graphics.Win32.Misc
+import Graphics.Win32.GDI.Types (COLORREF)
 
-import Foreign.C.Types (CInt(..))
+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.Ptr (Ptr)
 import Foreign.Storable (Storable(..))
-import Foreign.Marshal.Array (peekArray)
+import Foreign.Marshal.Array (peekArray, peekArray0)
 import Foreign.Marshal.Alloc (alloca)
 
-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
+getConsoleMode :: HANDLE -> IO DWORD
+getConsoleMode h = alloca $ \ptr -> do
+    failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h ptr
+    peek ptr
 
-foreign import WINDOWS_CCONV 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
@@ -74,13 +127,7 @@         "generateConsoleCtrlEvent"
         $ c_GenerateConsoleCtrlEvent e p
 
-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)
-
--- | This function can be used to parse commandline arguments and return
+-- | 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 []
@@ -93,71 +140,12 @@          _ <- localFree res
          mapM peekTString args
 
-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 COORD = COORD
-    { x :: SHORT
-    , y :: 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 (x coord)
-        (#poke COORD, Y) buf (y coord)
-
-data SMALL_RECT = SMALL_RECT
-    { left   :: SHORT
-    , top    :: SHORT
-    , right  :: SHORT
-    , bottom :: 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 (left small_rect)
-        (#poke SMALL_RECT, Top) buf (top small_rect)
-        (#poke SMALL_RECT, Right) buf (right small_rect)
-        (#poke SMALL_RECT, Bottom) buf (bottom small_rect)
-
-foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfo"
-    c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL
+-- | 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
@@ -168,3 +156,97 @@ 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/HWND.hs view
@@ -9,7 +9,7 @@ 
    Get the handle of the current console window.
 -}
-module System.Win32.Console.HWND where
+module System.Win32.Console.HWND (getConsoleHWND) where
 import Control.Concurrent           ( threadDelay )
 import Control.Exception            ( bracket )
 import Foreign.Ptr                  ( nullPtr )
+ 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
@@ -10,7 +10,10 @@ 
    Get/Set the title for the current console window.
 -}
-module System.Win32.Console.Title where
+module System.Win32.Console.Title
+    ( getConsoleTitle
+    , setConsoleTitle
+    ) where
 
 import System.Win32.String ( LPTSTR, LPCTSTR
                            , withTStringBufferLen, withTString, peekTStringLen )
System/Win32/DLL.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,81 +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 import Data.Maybe (fromMaybe) -##include "windows_cconv.h"--#include <windows.h>- disableThreadLibraryCalls :: HMODULE -> IO () disableThreadLibraryCalls hmod =   failIfFalse_ "DisableThreadLibraryCalls" $ c_DisableThreadLibraryCalls hmod-foreign import WINDOWS_CCONV unsafe "windows.h DisableThreadLibraryCalls"-  c_DisableThreadLibraryCalls :: HMODULE -> IO Bool  freeLibrary :: HMODULE -> IO () freeLibrary hmod =   failIfFalse_ "FreeLibrary" $ c_FreeLibrary hmod-foreign import WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 -foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW"-  c_SetDllDirectory :: LPTSTR -> IO BOOL
+ 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,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,33 +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@@ -66,7 +115,7 @@     | SingleStep     | StackOverflow     deriving (Show)-    + data DebugEventInfo     = UnknownDebugEvent     | Exception         ExceptionInfo Exception@@ -94,7 +143,7 @@     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'@@ -121,7 +170,7 @@                 (#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@@ -141,16 +190,16 @@             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 +            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'@@ -158,7 +207,7 @@             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 $ +            return $                 LoadDll (file, imgbase, dbgoff, dbgsize, imgname)--, unicode/=wZero)          rest (#const OUTPUT_DEBUG_STRING_EVENT) p' = do@@ -166,7 +215,7 @@             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 @@ -290,7 +339,7 @@             (act buf)  -#if __i386__+#if defined(i386_HOST_ARCH) eax, ebx, ecx, edx :: Int esi, edi :: Int ebp, eip, esp :: Int@@ -303,7 +352,7 @@ ebp = (#offset CONTEXT, Ebp) eip = (#offset CONTEXT, Eip) esp = (#offset CONTEXT, Esp)-#elif __x86_64__+#elif defined(x86_64_HOST_ARCH) rax, rbx, rcx, rdx :: Int rsi, rdi :: Int rbp, rip, rsp :: Int@@ -316,10 +365,49 @@ 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 Unsupported architecture+#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)@@ -339,7 +427,8 @@     6 -> (#offset CONTEXT, Dr6)     7 -> (#offset CONTEXT, Dr7)     _ -> undefined-    +#endif+ setReg :: Ptr a -> Int -> DWORD -> IO () setReg = pokeByteOff @@ -364,48 +453,3 @@ outputDebugString :: String -> IO () outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s ------------------------------------------------------------------------------ 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/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
@@ -8,7 +8,7 @@    Stability   :  Provisional
    Portability :  Non-portable (Win32 API)
 
-   Enocode/Decode mutibyte charactor using Win32 API.
+   Enocode/Decode mutibyte character using Win32 API.
 -}
 
 module System.Win32.Encoding
@@ -40,7 +40,7 @@         then return conCP
         else getACP
 
--- | The "System.IO" output functions (e.g. `putStr`) don't
+-- | 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
+ 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/File.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -18,311 +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_cconv.h"--#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- }+    ( -- * 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_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- }+      -- * 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--#{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- }+      -- * Move file flags+    , MoveFileFlag+    , mOVEFILE_REPLACE_EXISTING+    , mOVEFILE_COPY_ALLOWED+    , mOVEFILE_DELAY_UNTIL_REBOOT -----------------------------------------------------------------+      -- * File pointer directions+    , FilePtrDirection+    , fILE_BEGIN+    , fILE_CURRENT+    , fILE_END -type BinaryType = DWORD+      -- * Drive types+    , DriveType+    , dRIVE_UNKNOWN+    , dRIVE_NO_ROOT_DIR+    , dRIVE_REMOVABLE+    , dRIVE_FIXED+    , dRIVE_REMOTE+    , dRIVE_CDROM+    , dRIVE_RAMDISK -#{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- }+      -- * Define DOS device flags+    , DefineDosDeviceFlags+    , dDD_RAW_TARGET_PATH+    , dDD_REMOVE_DEFINITION+    , dDD_EXACT_MATCH_ON_REMOVE -----------------------------------------------------------------+      -- * Binary types+    , BinaryType+    , sCS_32BIT_BINARY+    , sCS_DOS_BINARY+    , sCS_WOW_BINARY+    , sCS_PIF_BINARY+    , sCS_POSIX_BINARY+    , sCS_OS216_BINARY -type FileNotificationFlag = DWORD+      -- * 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 -#{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- }+      -- * File types+    , FileType+    , fILE_TYPE_UNKNOWN+    , fILE_TYPE_DISK+    , fILE_TYPE_CHAR+    , fILE_TYPE_PIPE+    , fILE_TYPE_REMOTE -----------------------------------------------------------------+      -- * Lock modes+    , LockMode+    , lOCKFILE_EXCLUSIVE_LOCK+    , lOCKFILE_FAIL_IMMEDIATELY -type FileType = DWORD+      -- * GetFileEx information levels+    , GET_FILEEX_INFO_LEVELS+    , getFileExInfoStandard+    , getFileExMaxInfoLevel -#{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- }+      -- * Security attributes+    , SECURITY_ATTRIBUTES(..)+    , PSECURITY_ATTRIBUTES+    , LPSECURITY_ATTRIBUTES+    , MbLPSECURITY_ATTRIBUTES -----------------------------------------------------------------+      -- * BY_HANDLE file information+    , BY_HANDLE_FILE_INFORMATION(..) -newtype GET_FILEEX_INFO_LEVELS = GET_FILEEX_INFO_LEVELS (#type GET_FILEEX_INFO_LEVELS)-    deriving (Eq, Ord)+      -- * Win32 file attribute data+    , WIN32_FILE_ATTRIBUTE_DATA(..) -#{enum GET_FILEEX_INFO_LEVELS, GET_FILEEX_INFO_LEVELS- , getFileExInfoStandard = GetFileExInfoStandard- , getFileExMaxInfoLevel = GetFileExMaxInfoLevel- }+      -- * Helpers+    , failIfWithRetry+    , failIfWithRetry_+    , failIfFalseWithRetry_+      -- * File operations+    , deleteFile+    , copyFile+    , moveFile+    , moveFileEx+    , setCurrentDirectory+    , createDirectory+    , createDirectoryEx+    , removeDirectory+    , getBinaryType+    , getTempFileName+    , replaceFile -----------------------------------------------------------------+      -- * HANDLE operations+    , createFile+    , createFile_NoRetry+    , closeHandle+    , getFileType+    , flushFileBuffers+    , setEndOfFile+    , setFileAttributes+    , getFileAttributes+    , getFileAttributesExStandard+    , getFileInformationByHandle -type LPSECURITY_ATTRIBUTES = Ptr ()-type MbLPSECURITY_ATTRIBUTES = Maybe LPSECURITY_ATTRIBUTES+      -- ** Reading/writing+      -- | Some operations below bear the @win32_@ prefix to avoid shadowing+      -- operations from "Prelude".+    , OVERLAPPED(..)+    , LPOVERLAPPED+    , MbLPOVERLAPPED+    , win32_ReadFile+    , win32_WriteFile+    , setFilePointerEx -------------------------------------------------------------------- Other types-----------------------------------------------------------------+      -- * File notifications+    , findFirstChangeNotification+    , findNextChangeNotification+    , findCloseChangeNotification -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)+      -- * Directories+    , FindData+    , getFindDataFileName+    , findFirstFile+    , findNextFile+    , findClose -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+      -- * DOS device flags+    , defineDosDevice+    , areFileApisANSI+    , setFileApisToOEM+    , setFileApisToANSI+    , setHandleCount+    , getLogicalDrives+    , getDiskFreeSpace+    , setVolumeLabel -    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))+      -- * File locks+    , lockFile+    , unlockFile+    ) where -----------------------------------------------------------------+import System.Win32.File.Internal+import System.Win32.Types -data WIN32_FILE_ATTRIBUTE_DATA = WIN32_FILE_ATTRIBUTE_DATA-    { fadFileAttributes :: DWORD-    , fadCreationTime , fadLastAccessTime , fadLastWriteTime :: FILETIME-    , fadFileSize :: DDWORD-    } deriving (Show)+import Foreign hiding (void)+import Control.Monad+import Control.Concurrent+import Data.Maybe (fromMaybe) -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+##include "windows_cconv.h" -    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))+#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@@ -352,166 +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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV unsafe "windows.h MoveFileW"-  c_MoveFile :: LPCTSTR -> LPCTSTR -> IO Bool  moveFileEx :: String -> Maybe String -> MoveFileFlag -> IO () moveFileEx src dest flags =-  withTString src $ \ c_src ->-  maybeWith 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV unsafe "windows.h GetFileType"-  getFileType :: HANDLE -> IO FileType --Apparently no error code  flushFileBuffers :: HANDLE -> IO () flushFileBuffers h =   failIfFalse_ "FlushFileBuffers" $ c_FlushFileBuffers h-foreign import WINDOWS_CCONV unsafe "windows.h FlushFileBuffers"-  c_FlushFileBuffers :: HANDLE -> IO Bool  setEndOfFile :: HANDLE -> IO () setEndOfFile h =   failIfFalse_ "SetEndOfFile" $ c_SetEndOfFile h-foreign import WINDOWS_CCONV 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 WINDOWS_CCONV 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 WINDOWS_CCONV unsafe "windows.h GetFileAttributesW"-  c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag  getFileAttributesExStandard :: String -> IO WIN32_FILE_ATTRIBUTE_DATA getFileAttributesExStandard name =  alloca $ \res -> do-  withTString name $ \ c_name ->+  withFilePath name $ \ c_name ->     failIfFalseWithRetry_ "getFileAttributesExStandard" $       c_GetFileAttributesEx c_name getFileExInfoStandard res   peek res-foreign import WINDOWS_CCONV unsafe "windows.h GetFileAttributesExW"-  c_GetFileAttributesEx :: LPCTSTR -> GET_FILEEX_INFO_LEVELS -> Ptr a -> IO BOOL  getFileInformationByHandle :: HANDLE -> IO BY_HANDLE_FILE_INFORMATION getFileInformationByHandle h = alloca $ \res -> do     failIfFalseWithRetry_ "GetFileInformationByHandle" $ c_GetFileInformationByHandle h res     peek res-foreign import WINDOWS_CCONV 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. @@ -520,24 +436,18 @@   alloca $ \ p_n -> do   failIfFalse_ "ReadFile" $ c_ReadFile h buf n p_n (maybePtr mb_over)   peek p_n-foreign import WINDOWS_CCONV 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 WINDOWS_CCONV unsafe "windows.h WriteFile"-  c_WriteFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool  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-foreign import WINDOWS_CCONV unsafe "windows.h SetFilePointerEx"-  c_SetFilePointerEx :: HANDLE -> LARGE_INTEGER -> Ptr LARGE_INTEGER -> FilePtrDirection -> IO Bool  ---------------------------------------------------------------- -- File Notifications@@ -548,32 +458,22 @@  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 WINDOWS_CCONV unsafe "windows.h FindFirstChangeNotificationW"-  c_FindFirstChangeNotification :: LPCTSTR -> Bool -> FileNotificationFlag -> IO HANDLE  findNextChangeNotification :: HANDLE -> IO () findNextChangeNotification h =   failIfFalse_ "FindNextChangeNotification" $ c_FindNextChangeNotification h-foreign import WINDOWS_CCONV unsafe "windows.h FindNextChangeNotification"-  c_FindNextChangeNotification :: HANDLE -> IO Bool  findCloseChangeNotification :: HANDLE -> IO () findCloseChangeNotification h =   failIfFalse_ "FindCloseChangeNotification" $ c_FindCloseChangeNotification h-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)- getFindDataFileName :: FindData -> IO FilePath getFindDataFileName (FindData fp) =   withForeignPtr fp $ \p ->@@ -583,12 +483,10 @@ findFirstFile str = do   fp_finddata <- mallocForeignPtrBytes (# const sizeof(WIN32_FIND_DATAW) )   withForeignPtr fp_finddata $ \p_finddata -> do-    handle <- withTString str $ \tstr -> do+    handle <- withFilePath str $ \tstr -> do                 failIf (== iNVALID_HANDLE_VALUE) "findFirstFile" $                   c_FindFirstFile tstr p_finddata     return (handle, FindData fp_finddata)-foreign import WINDOWS_CCONV 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@@ -601,13 +499,9 @@              if err_code == (# const ERROR_NO_MORE_FILES )                 then return False                 else failWith "findNextFile" err_code-foreign import WINDOWS_CCONV 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 WINDOWS_CCONV unsafe "windows.h FindClose"-  c_FindClose :: HANDLE -> IO BOOL  ---------------------------------------------------------------- -- DOS Device flags@@ -615,42 +509,21 @@  defineDosDevice :: DefineDosDeviceFlags -> String -> Maybe String -> IO () defineDosDevice flags name path =-  maybeWith 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 WINDOWS_CCONV 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 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------------------------------------------------------------------- getLogicalDrives :: IO DWORD getLogicalDrives =   failIfZero "GetLogicalDrives" $ c_GetLogicalDrives-foreign import WINDOWS_CCONV 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 ->@@ -662,16 +535,47 @@   nfree <- peek p_nfree   nclusters <- peek p_nclusters   return (sectors, bytes, nfree, nclusters)-foreign import WINDOWS_CCONV unsafe "windows.h GetDiskFreeSpaceW"-  c_GetDiskFreeSpace :: LPCTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> IO Bool  setVolumeLabel :: Maybe String -> Maybe String -> IO () setVolumeLabel path name =-  maybeWith withTString path $ \ c_path ->-  maybeWith withTString name $ \ c_name ->+  maybeWith withFilePath path $ \ c_path ->+  maybeWith withFilePath name $ \ c_name ->   failIfFalse_ "SetVolumeLabel" $ c_SetVolumeLabel c_path c_name-foreign import WINDOWS_CCONV 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,8 @@ 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 )-import Foreign.C.Types (CUIntPtr(..))  ##include "windows_cconv.h" @@ -55,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@@ -108,24 +127,6 @@         (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@@ -143,7 +144,7 @@             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@@ -155,21 +156,3 @@ unmapViewOfFile :: Ptr a -> IO () unmapViewOfFile v = c_UnmapViewOfFile v >> return () ------------------------------------------------------------------------------- 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/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
@@ -12,20 +12,23 @@ 
    Note: You should worry about file system type when use this module's function in your application:
 
-     * NTFS only supprts this functionality.
+     * NTFS only supports this functionality.
 
      * ReFS doesn't support hard link currently.
 -}
 module System.Win32.HardLink
-  ( module System.Win32.HardLink
+  ( createHardLink
+  , createHardLink'
   ) where
-import System.Win32.File   ( LPSECURITY_ATTRIBUTES, failIfFalseWithRetry_ )
-import System.Win32.String ( LPCTSTR, withTString )
-import System.Win32.Types  ( BOOL, nullPtr )
 
+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 compatiblity for Unix.
+-- | 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
@@ -42,11 +45,6 @@         failIfFalseWithRetry_ (unwords ["CreateHardLinkW",show link,show target]) $
           c_CreateHardLink c_link c_target nullPtr
 
-foreign import WINDOWS_CCONV unsafe "windows.h CreateHardLinkW"
-  c_CreateHardLink :: LPCTSTR -- ^ Hard link name
-                   -> LPCTSTR -- ^ Target file path
-                   -> LPSECURITY_ATTRIBUTES -- ^ This parameter is reserved. You should pass just /nullPtr/.
-                   -> IO BOOL
 
 {-
 -- We plan to check file system type internally.
+ 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,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,16 +17,126 @@ -- ----------------------------------------------------------------------------- -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 +      -- * Standard directories+    , getSystemDirectory+    , getWindowsDirectory+    , getCurrentDirectory+    , getTemporaryDirectory+    , getFullPathName+    , getLongPathName+    , getShortPathName+    , searchPath++      -- * 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 Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (with, maybeWith) import Foreign.Marshal.Array (allocaArray)-import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Ptr (nullPtr) import Foreign.Storable (Storable(..)) import System.IO.Error (isDoesNotExistError)-import System.Win32.Types (DWORD, LPDWORD, LPCTSTR, LPTSTR, LPVOID, UINT, WORD) import System.Win32.Types (failIfFalse_, peekTStringLen, withTString, try)  #if !MIN_VERSION_base(4,6,0)@@ -65,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 ---------------------------------------------------------------- @@ -111,6 +186,7 @@  getCurrentDirectory :: IO String getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512+ getTemporaryDirectory :: IO String getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512 @@ -145,204 +221,15 @@                        then return Nothing                        else ioError e -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 ()- 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  ----------------------------------------------------------------@@ -358,12 +245,9 @@  -- %fun GetUserName :: IO String -foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW"-  c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool-   getUserName :: IO String-getUserName =     -  allocaArray 512 $ \ c_str -> +getUserName =+  allocaArray 512 $ \ c_str ->     with 512 $ \ c_len -> do         failIfFalse_ "GetUserName" $ c_GetUserName c_str c_len         len <- peek c_len
System/Win32/Info/Computer.hsc view
@@ -94,7 +94,7 @@       len' <- peek len
       peekTStringLen (buf, (fromIntegral len'))
   where
-    maxLength = #const MAX_COMPUTERNAME_LENGTH
+    maxLength = #const MAX_PATH
 
 foreign import WINDOWS_CCONV unsafe "GetComputerNameW"
   c_GetComputerName :: LPTSTR -> LPDWORD -> IO Bool
@@ -126,7 +126,7 @@ -- Hardware Profiles
 ----------------------------------------------------------------
 {-
--- TODO: Deside HW_PROFILE_INFO type design
+-- TODO: Decide HW_PROFILE_INFO type design
 
 type LPHW_PROFILE_INFO = Ptr HW_PROFILE_INFO
 
@@ -195,7 +195,7 @@   with (fromIntegral maxLength) $ \len -> do
       failIfFalse_ "GetComputerName"
         $ c_GetUserName buf len
-      -- GetUserNameW includes NUL charactor.
+      -- GetUserNameW includes NUL character.
       peekTString buf
   where
     -- This requires Lmcons.h
+ 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
@@ -19,6 +19,7 @@     -- * Verify OS version
   , isVistaOrLater, is7OrLater
   ) where
+
 import Foreign.Ptr           ( Ptr, plusPtr )
 import Foreign.Marshal.Alloc ( alloca )
 import Foreign.Storable      ( Storable(..) )
System/Win32/Mem.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,8 +17,91 @@ -- ----------------------------------------------------------------------------- -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@@ -268,10 +351,11 @@ 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 =@@ -279,10 +363,11 @@ 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 =
System/Win32/MinTTY.hsc view
@@ -2,7 +2,7 @@  #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -15,7 +15,12 @@ -- Stability   :  provisional -- Portability :  portable ----- A function to check if the current terminal uses MinTTY.+-- 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. --@@ -31,10 +36,9 @@ #if MIN_VERSION_base(4,6,0) import Control.Exception (catch) #endif-import Data.List (isPrefixOf, isInfixOf, isSuffixOf)+import Data.List (isInfixOf) import Foreign import Foreign.C.Types-import System.FilePath (takeFileName)  #if __GLASGOW_HASKELL__ < 711 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)@@ -51,8 +55,9 @@ #include <windows.h> #include "winternl_compat.h" --- | Returns 'True' if the current process's standard error is attached to a--- MinTTY console (e.g., Cygwin or MSYS). Returns 'False' otherwise.+-- | 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@@ -62,8 +67,9 @@        then return False        else isMinTTYHandle h --- | Returns 'True' is the given handle is attached to a MinTTY console--- (e.g., Cygwin or MSYS). Returns 'False' otherwise.+-- | 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@@ -91,11 +97,8 @@     return False  cygwinMSYSCheck :: String -> Bool-cygwinMSYSCheck fn = ("cygwin-" `isPrefixOf` fn' || "msys-" `isPrefixOf` fn') &&-            "-pty" `isInfixOf` fn' &&-            "-master" `isSuffixOf` fn'-  where-    fn' = takeFileName fn+cygwinMSYSCheck fn = ("cygwin-" `isInfixOf` fn || "msys-" `isInfixOf` fn) &&+            "-pty" `isInfixOf` fn -- Note that GetFileInformationByHandleEx might return a filepath like: -- --    \msys-dd50a72ab4668b33-pty1-to-master@@ -105,8 +108,16 @@ --    \Device\NamedPipe\msys-dd50a72ab4668b33-pty1-to-master -- -- This means we can't rely on "\cygwin-" or "\msys-" being at the very start--- of the filepath. Therefore, we must take care to first call takeFileName--- before checking for "cygwin" or "msys" at the start using `isPrefixOf`.+-- 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@@ -153,7 +164,7 @@  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
System/Win32/NLS.hsc view
@@ -1,6 +1,5 @@-#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  System.Win32.NLS@@ -17,6 +16,9 @@  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,@@ -24,17 +26,45 @@         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@@ -44,9 +74,11 @@ 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@@ -62,37 +94,237 @@  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 ->@@ -103,25 +335,153 @@ 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) ->@@ -139,9 +499,63 @@  , lCID_SUPPORTED       = LCID_SUPPORTED  } +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 +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 @@ -151,6 +565,42 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetUserDefaultLangID"   getUserDefaultLangID :: LANGID +-- #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 @@ -160,6 +610,12 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetSystemDefaultLangID"   getSystemDefaultLangID :: LANGID +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 @@ -345,7 +801,7 @@  -- ---------------------------------------------------------------------------- --- | 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 -- to a proper Unicode string.  To get the code page for the console,
+ 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
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -22,6 +22,7 @@  , pathRelativePathTo  ) where +import System.Win32.Path.Internal import System.Win32.Types import System.Win32.File @@ -53,5 +54,3 @@     _ <- localFree p_AbsPath     return path -foreign import WINDOWS_CCONV unsafe "Shlwapi.h PathRelativePathToW" -         c_pathRelativePathTo :: LPTSTR -> LPCTSTR -> DWORD -> LPCTSTR -> DWORD -> IO UINT
+ 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,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -17,19 +17,63 @@ -- ----------------------------------------------------------------------------- -module System.Win32.Process 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 )+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@@ -38,7 +82,6 @@ foreign import WINDOWS_CCONV unsafe "windows.h Sleep"   sleep :: DWORD -> IO () - type ProcessId = DWORD type ProcessHandle = HANDLE type ProcessAccessRights = DWORD@@ -54,13 +97,11 @@     , pROCESS_VM_OPERATION          = PROCESS_VM_OPERATION     , pROCESS_VM_READ               = PROCESS_VM_READ     , pROCESS_VM_WRITE              = PROCESS_VM_WRITE-    , sYNCHORNIZE                   = SYNCHRONIZE      }  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 @@ -71,7 +112,7 @@ getProcessId h = failIfZero "GetProcessId" $ c_GetProcessId h  foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentProcess"-    c_GetCurrentProcess :: IO ProcessHandle +    c_GetCurrentProcess :: IO ProcessHandle  foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentProcessId"     c_GetCurrentProcessId :: IO ProcessId@@ -95,17 +136,20 @@ 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 WINDOWS_CCONV unsafe "tlhelp32.h CreateToolhelp32Snapshot"@@ -117,6 +161,12 @@ 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@@ -126,7 +176,6 @@ 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 PROCESSENTRY32W, th32ProcessID) buf)@@ -135,6 +184,14 @@     ((#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 PROCESSENTRY32W) $ \pe -> do@@ -151,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 -> Maybe 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 -> String -> IO String-        , regQueryValueKey   -- :: HKEY -> String -> IO String-        , regQueryValueEx    -- :: HKEY -> String -> Addr -> Int -> IO RegValueType-        , regReplaceKey      -- :: HKEY -> Maybe 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: @@ -72,12 +131,13 @@ 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, failUnlessSuccess)+import System.Win32.Types (LPTSTR, TCHAR, LPDWORD, LPVOID, failUnlessSuccess) import System.Win32.Types (castUINTPtrToPtr, failUnlessSuccessOr, maybePtr)  ##include "windows_cconv.h"  #include <windows.h>+#include "winreg_compat.h"  #{enum HKEY, (unsafePerformIO . newForeignHANDLE . castUINTPtrToPtr)  , hKEY_CLASSES_ROOT    = (UINT_PTR)HKEY_CLASSES_ROOT@@ -382,16 +442,25 @@  -- 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.--regQueryValueKey :: HKEY -> String -> IO String+{-# DEPRECATED regQueryValueKey "Use regQueryValue instead." #-}+regQueryValueKey :: HKEY -> Maybe String -> IO String regQueryValueKey key mb_subkey =   withForeignPtr key $ \ p_key ->-  withTString mb_subkey $ \ c_subkey ->+  maybeWith withTString mb_subkey $ \ c_subkey ->   alloca $ \ p_value_len -> do+  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 "RegQueryValueKey" $+      c_RegQueryValue p_key c_subkey c_value p_value_len+    peekTString c_value++regQueryValue :: HKEY -> Maybe String -> IO String+regQueryValue key mb_subkey =+  withForeignPtr key $ \ p_key ->+  maybeWith withTString mb_subkey $ \ c_subkey ->+  alloca $ \ p_value_len -> do   failUnlessSuccess "RegQueryValue" $     c_RegQueryValue p_key c_subkey nullPtr p_value_len   value_len <- peek p_value_len@@ -402,19 +471,21 @@ foreign import WINDOWS_CCONV unsafe "windows.h RegQueryValueW"   c_RegQueryValue :: PKEY -> LPCTSTR -> LPTSTR -> Ptr LONG -> IO ErrCode -regQueryValue :: HKEY -> String -> IO String-regQueryValue key mb_subkey =+-- 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 "RegQueryValue" $+  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) @@ -472,6 +543,35 @@ -- endif  -- 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 =
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,@@ -96,34 +94,34 @@     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> Ptr SECURITY_DESCRIPTOR_CONTROL -- pControl     -> LPDWORD -- lpdwRevision-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorDacl"-  c_getSecurityDescriptorDacl +  c_getSecurityDescriptorDacl     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> LPBOOL -- lpbDaclPresent     -> Ptr PACL -- pDacl     -> LPBOOL -- lpbDaclDefaulted-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorGroup"   c_getSecurityDescriptorGroup     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> Ptr PSID -- pGroup     -> LPBOOL -- lpbGroupDefaulted-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorLength"   c_getSecurityDescriptorLength     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor-    -> IO DWORD +    -> IO DWORD  foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorOwner"   c_getSecurityDescriptorOwner     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> Ptr PSID -- pOwner     -> LPBOOL -- lpbOwnerDefaulted-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h GetSecurityDescriptorSacl"   c_getSecurityDescriptorSacl@@ -131,18 +129,18 @@     -> LPBOOL -- lpbSaclPresent     -> Ptr PACL -- pSacl     -> LPBOOL -- lpbSaclDefaulted-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h InitializeSecurityDescriptor"   c_initializeSecurityDescriptor     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> DWORD -- dwRevision-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h IsValidSecurityDescriptor"   c_isValidSecurityDescriptor     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorDacl"   c_setSecurityDescriptorDacl@@ -150,21 +148,21 @@     -> BOOL -- bDaclPresent     -> PACL -- pDacl     -> BOOL -- bDaclDefaulted-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorGroup"   c_setSecurityDescriptorGroup     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> PSID -- pGroup     -> BOOL -- bGroupDefaulted-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorOwner"   c_setSecurityDescriptorOwner     :: PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> PSID -- pOwner     -> BOOL -- bOwnerDefaulted-    -> IO BOOL +    -> IO BOOL  foreign import WINDOWS_CCONV unsafe "windows.h SetSecurityDescriptorSacl"   c_setSecurityDescriptorSacl@@ -172,7 +170,7 @@     -> BOOL -- bSaclPresent     -> PACL -- pSacl     -> BOOL -- bSaclDefaulted-    -> IO BOOL +    -> IO BOOL  -- --------------------------------------------------------------------------- @@ -190,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@@ -203,7 +201,7 @@   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) @@ -214,7 +212,7 @@     -> PSECURITY_DESCRIPTOR -- pSecurityDescriptor     -> DWORD -- nLength     -> LPDWORD -- lpnLengthNeeded-    -> IO BOOL +    -> IO BOOL  --foreign import WINDOWS_CCONV unsafe "windows.h AccessCheck" --  c_AccessCheck
+ 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,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709
 {-# LANGUAGE Safe #-}
-#elif __GLASGOW_HASKELL__ >= 701
+#else
 {-# LANGUAGE Trustworthy #-}
 #endif
 -----------------------------------------------------------------------------
@@ -32,13 +32,13 @@   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"
 
@@ -79,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 WINDOWS_CCONV 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,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -35,8 +35,7 @@   -- 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"@@ -98,7 +97,7 @@     , ((#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")@@ -108,9 +107,9 @@     , ((#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_RECIPIENT)      , "Ambiguous recipient") #ifdef MAPI_E_AMBIGUOUS_RECIP-    , ((#const MAPI_E_AMBIGUOUS_RECIP)          , "Ambigious recipient")+    , ((#const MAPI_E_AMBIGUOUS_RECIP)          , "Ambiguous recipient") #endif     , ((#const MAPI_E_MESSAGE_IN_USE)           , "Message in use")     , ((#const MAPI_E_NETWORK_FAILURE)          , "Network failure")@@ -171,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)@@ -204,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)@@ -224,7 +228,7 @@     maybeWith withCAString pw   $ \c_pw  ->     alloca                      $ \out   -> do         mapiFail_ "MAPILogon: " $ mapifLogon-            f (maybeHWND hwnd) +            f (maybeHWND hwnd)             c_ses c_pw flags 0 out         peek out
System/Win32/SymbolicLink.hsc view
@@ -10,45 +10,77 @@ 
    Handling symbolic link using Win32 API. [Vista of later and desktop app only]
 
-   Note: You should worry about UAC (User Account Control) when use this module's function in your application:
+   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
+     * 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
-  ( 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"
 
-type SymbolicLinkFlags = DWORD
 
-#{enum SymbolicLinkFlags,
- , sYMBOLIC_LINK_FLAG_FILE      = 0x0
- , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1
-}
-
 -- | createSymbolicLink* functions don't check that file is exist or not.
 --
--- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatiblity for Unix,
+-- 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 -> FilePath -> IO ()
-createSymbolicLinkFile target link = createSymbolicLink' link target sYMBOLIC_LINK_FLAG_FILE
+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 -> FilePath -> IO ()
-createSymbolicLinkDirectory target link = createSymbolicLink' link target sYMBOLIC_LINK_FLAG_DIRECTORY
+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
@@ -59,5 +91,3 @@         failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $
           c_CreateSymbolicLink c_link c_target flag
 
-foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW"
-  c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL
+ 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
@@ -15,14 +15,10 @@   ( THANDLE, TID
   , getCurrentThread
   , suspendThread
-  , c_SuspendThread
   , resumeThread
-  , c_ResumeThread
   , withSuspendedThread
   , getThreadId
-  , c_GetThreadId
   , getCurrentThreadId
-  , c_GetCurrentThreadId
   ) where
 
 import System.Win32.DebugApi
System/Win32/Time.hsc view
@@ -1,6 +1,6 @@ #if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-}-#elif __GLASGOW_HASKELL__ >= 701+#else {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------@@ -16,153 +16,86 @@ -- 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_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 _ = #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--foreign import WINDOWS_CCONV "windows.h GetSystemTime"-    c_GetSystemTime :: Ptr SYSTEMTIME -> IO () getSystemTime :: IO SYSTEMTIME getSystemTime = alloca $ \res -> do     c_GetSystemTime res     peek res -foreign import WINDOWS_CCONV "windows.h SetSystemTime"-    c_SetSystemTime :: Ptr SYSTEMTIME -> IO BOOL setSystemTime :: SYSTEMTIME -> IO () setSystemTime st = with st $ \c_st -> failIf_ not "setSystemTime: SetSystemTime" $     c_SetSystemTime c_st -foreign import WINDOWS_CCONV "windows.h GetSystemTimeAsFileTime"-    c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO () getSystemTimeAsFileTime :: IO FILETIME getSystemTimeAsFileTime = alloca $ \ret -> do     c_GetSystemTimeAsFileTime ret     peek ret -foreign import WINDOWS_CCONV "windows.h GetLocalTime"-    c_GetLocalTime :: Ptr SYSTEMTIME -> IO () getLocalTime :: IO SYSTEMTIME getLocalTime = alloca $ \res -> do     c_GetLocalTime res     peek res -foreign import WINDOWS_CCONV "windows.h SetLocalTime"-    c_SetLocalTime :: Ptr SYSTEMTIME -> IO BOOL setLocalTime :: SYSTEMTIME -> IO () setLocalTime st = with st $ \c_st -> failIf_ not "setLocalTime: SetLocalTime" $     c_SetLocalTime c_st -foreign import WINDOWS_CCONV "windows.h GetSystemTimeAdjustment"-    c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL getSystemTimeAdjustment :: IO (Maybe (Int, Int)) getSystemTimeAdjustment = alloca $ \ta -> alloca $ \ti -> alloca $ \enabled -> do     failIf_ not "getSystemTimeAdjustment: GetSystemTimeAdjustment" $@@ -175,10 +108,19 @@             return $ Just (fromIntegral ta', fromIntegral ti')         else return Nothing -foreign import WINDOWS_CCONV "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 WINDOWS_CCONV "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" $@@ -188,8 +130,6 @@             Nothing -> (0,True)             Just x  -> (fromIntegral x,False) -foreign import WINDOWS_CCONV "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" $@@ -201,48 +141,43 @@         (#const TIME_ZONE_ID_DAYLIGHT)  -> TzIdDaylight         _                               -> TzIdUnknown   -- to remove warning -foreign import WINDOWS_CCONV "windows.h SystemTimeToFileTime"-    c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL systemTimeToFileTime :: SYSTEMTIME -> IO FILETIME systemTimeToFileTime s = with s $ \c_s -> alloca $ \ret -> do     failIf_ not "systemTimeToFileTime: SystemTimeToFileTime" $         c_SystemTimeToFileTime c_s ret     peek ret -foreign import WINDOWS_CCONV "windows.h FileTimeToSystemTime"-    c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL fileTimeToSystemTime :: FILETIME -> IO SYSTEMTIME fileTimeToSystemTime s = with s $ \c_s -> alloca $ \ret -> do     failIf_ not "fileTimeToSystemTime: FileTimeToSystemTime" $         c_FileTimeToSystemTime c_s ret     peek ret -foreign import WINDOWS_CCONV "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 WINDOWS_CCONV "windows.h SetFileTime"-    c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL-setFileTime :: HANDLE -> FILETIME -> FILETIME -> FILETIME -> IO ()-setFileTime h crt acc wrt = with crt $-    \c_crt -> with acc $-    \c_acc -> with wrt $+invalidFileTime :: FILETIME+invalidFileTime = FILETIME 0++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 -foreign import WINDOWS_CCONV "windows.h FileTimeToLocalFileTime"-    c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL fileTimeToLocalFileTime :: FILETIME -> IO FILETIME fileTimeToLocalFileTime ft = with ft $ \c_ft -> alloca $ \res -> do     failIf_ not "fileTimeToLocalFileTime: FileTimeToLocalFileTime"         $ c_FileTimeToLocalFileTime c_ft res     peek res -foreign import WINDOWS_CCONV "windows.h LocalFileTimeToFileTime"-    c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL localFileTimeToFileTime :: FILETIME -> IO FILETIME localFileTimeToFileTime ft = with ft $ \c_ft -> alloca $ \res -> do     failIf_ not "localFileTimeToFileTime: LocalFileTimeToFileTime"@@ -278,34 +213,31 @@     peek res -} -foreign import WINDOWS_CCONV "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 WINDOWS_CCONV "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 WINDOWS_CCONV "windows.h GetTimeFormatW"-    c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt+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 =     maybeWith with st $ \c_st ->
+ 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.hsc view
@@ -1,7 +1,5 @@-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif {-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module      :  System.Win32.Types@@ -30,13 +28,14 @@ import Data.Typeable (cast) import Data.Word (Word8, Word16, Word32, Word64) import Foreign.C.Error (Errno(..), errnoToIOError)-import Foreign.C.String (newCWString, withCWStringLen)+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__(..))@@ -58,6 +57,21 @@ 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"@@ -94,12 +108,12 @@ type ULONG64       = Word64 type SHORT         = Int16 -type DWORD_PTR     = Ptr DWORD32 type INT_PTR       = Ptr CInt type ULONG         = Word32 type UINT_PTR      = Word type LONG_PTR      = CIntPtr type ULONG_PTR     = CUIntPtr+type DWORD_PTR     = ULONG_PTR #ifdef _WIN64 type HALF_PTR      = Ptr INT32 #else@@ -166,6 +180,7 @@ ----------------------------------------------------------------  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@@ -174,6 +189,7 @@ -- UTF-16 version: type TCHAR     = CWchar withTString    = withCWString+withFilePath path = useAsCWStringSafe path withTStringLen = withCWStringLen peekTString    = peekCWString peekTStringLen = peekCWStringLen@@ -188,6 +204,25 @@ 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 ----------------------------------------------------------------@@ -224,6 +259,9 @@ 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 @@ -243,9 +281,63 @@ -- 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 =-  _open_osfhandle (fromIntegral (ptrToIntPtr handle)) (#const _O_BINARY) >>= fdToHandle+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 @@ -254,7 +346,15 @@  -- Originally authored by Max Bolingbroke in the ansi-terminal library withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a-withHandleToHANDLE haskell_handle action =+##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).@@ -263,6 +363,36 @@         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@@ -271,7 +401,6 @@          -- 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 @@ -327,6 +456,8 @@ 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
System/Win32/Utils.hs view
@@ -10,24 +10,34 @@    Utilities for calling Win32 API
 -}
 module System.Win32.Utils
-  ( try, tryWithoutNull, try'
+  ( 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 System.Win32.Types          ( failIfZero
-                                   , failWith, getLastError, eRROR_INSUFFICIENT_BUFFER )
+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.String         ( LPTSTR, peekTString )
-import System.Win32.Types          ( BOOL, UINT, maybePtr, ptrToMaybe, maybeNum, numToMaybe )
 import System.Win32.Word           ( DWORD, PDWORD )
 
-
 -- | Support for API calls that are passed a fixed-size buffer and tell
 -- you via the return value if the buffer was too small.  In that
 -- case, we extend the buffer size and try again.
@@ -39,7 +49,7 @@ 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
+          if r > n then return (Left r) else do
             str <- peekTString lptstr
             return (Right str)
    case e of
@@ -56,16 +66,28 @@             unless (err_code == eRROR_INSUFFICIENT_BUFFER)
               $ failWith loc err_code
           r   <- peek n'
-          if (r > n) then return (Left r) else do
+          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 = 
+peekMaybe p =
   if p == nullPtr
     then return Nothing
     else Just `fmap` peek p
@@ -74,3 +96,315 @@ 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
Win32.cabal view
@@ -1,22 +1,35 @@-name:		Win32-version:	2.6.2.1-license:	BSD3-license-file:	LICENSE-author:		Alastair Reid, shelarcy, Tamar Christina-copyright:	Alastair Reid, 1999-2003; shelarcy, 2012-2013; Tamar Christina, 2016-2018-maintainer:	Haskell Libraries <libraries@haskell.org>+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 Windows Win32 API.-description:	This library contains direct bindings to the Windows Win32 APIs for Haskell.+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.10 extra-source-files:     include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h     include/Win32Aux.h include/win32debug.h include/alignment.h-        changelog.md+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     default-language: Haskell2010     default-extensions: ForeignFunctionInterface, CPP@@ -28,9 +41,19 @@         build-depends: unbuildable<0         buildable: False -    build-depends:	base >= 4.5 && < 5, bytestring, filepath-    ghc-options:    -Wall -fno-warn-name-shadowing-    cc-options:     -fno-strict-aliasing+    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@@ -67,8 +90,10 @@         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@@ -80,6 +105,7 @@         System.Win32.Time         System.Win32.Console         System.Win32.Security+        System.Win32.Semaphore         System.Win32.Types         System.Win32.Shell         System.Win32.Automation@@ -100,12 +126,42 @@         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", "shlwapi", "msimg32", "imm32"     ghc-options:      -Wall     include-dirs:     include-    includes:         "alphablend.h", "diatemp.h", "dumpBMP.h", "ellipse.h", "errors.h", "HsGDI.h", "HsWin32.h", "Win32Aux.h", "win32debug.h", "windows_cconv.h", "WndProc.h", "alignment.h"-    install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h", "windows_cconv.h", "alphablend.h", "winternl_compat.h", "winuser_compat.h"+    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@@ -119,4 +175,4 @@  source-repository head     type:     git-    location: git://github.com/haskell/win32+    location: https://github.com/haskell/win32
cbits/dumpBMP.c view
@@ -64,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;@@ -81,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@@ -113,7 +113,7 @@             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;
changelog.md view
@@ -1,8 +1,176 @@ # Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) -## 2.6.2.1 *August 2021*+## 2.14.2.2 May 2026 -* Fix `registery001` test (See #181)+* 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*
include/alphablend.h view
@@ -1,6 +1,6 @@ #ifndef _ALPHABLEND_H #define _ALPHABLEND_H-#define WINVER 0x0500+ #include <windows.h>  BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest
+ 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
@@ -3,7 +3,7 @@  #if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall-#elif defined(x86_64_HOST_ARCH)+#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) # define WINDOWS_CCONV ccall #else # error Unknown mingw32 arch
+ 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 */