packages feed

Win32 2.12.0.1 → 2.14.2.2

raw patch · 61 files changed

Files

Graphics/Win32/GDI.hs view
@@ -16,7 +16,7 @@ -----------------------------------------------------------------------------  {-# 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 --     https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
Graphics/Win32/GDI/Graphics2D.hs view
@@ -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/Icon.hs view
@@ -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/LayeredWindow.hsc view
@@ -14,7 +14,6 @@ import Control.Monad   ( void )
 import Data.Bits       ( (.|.) )
 import Foreign.Ptr     ( Ptr )
-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_GetWindowLongPtr, c_SetWindowLongPtr )
@@ -27,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
Graphics/Win32/Message.hsc view
@@ -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
@@ -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/Window.hsc view
@@ -23,8 +23,8 @@ import Foreign.Marshal.Utils (maybeWith) import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Array (allocaArray)-import Foreign.Ptr (FunPtr, Ptr, castFunPtrToPtr, castPtr, nullPtr)-import Foreign.Ptr (intPtrToPtr, castPtrToFunPtr, freeHaskellFunPtr)+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)@@ -204,6 +204,9 @@ foreign import WINDOWS_CCONV "wrapper"   mkWindowClosure :: WindowClosure -> IO (FunPtr WindowClosure) +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'.@@ -218,10 +221,10 @@ setWindowClosure wnd closure = do   fp <- mkWindowClosure closure   fpOld <- c_SetWindowLongPtr wnd (#{const GWLP_USERDATA})-                              (castPtr (castFunPtrToPtr fp))-  if fpOld == nullPtr +                              (mkCIntPtr fp)+  if fpOld == 0      then return Nothing-     else return $ Just $ castPtrToFunPtr fpOld+     else return $ Just $ castPtrToFunPtr $ intPtrToPtr $ fromIntegral fpOld  {- Note [SetWindowLongPtrW] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -235,16 +238,16 @@ -} #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)+#elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) foreign import WINDOWS_CCONV unsafe "windows.h GetWindowLongPtrW" #else # error Unknown mingw32 arch@@ -752,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/Console.hsc view
@@ -1,5 +1,5 @@ #if __GLASGOW_HASKELL__ >= 709
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 #else
 {-# LANGUAGE Trustworthy #-}
 #endif
@@ -45,34 +45,54 @@         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 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 GetConsoleMode"
-        c_GetConsoleMode :: HANDLE -> LPDWORD -> IO BOOL
 
-foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode"
-        c_SetConsoleMode :: HANDLE -> DWORD -> IO BOOL
-
 getConsoleMode :: HANDLE -> IO DWORD
 getConsoleMode h = alloca $ \ptr -> do
     failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h ptr
@@ -101,37 +121,13 @@ dISABLE_NEWLINE_AUTO_RETURN = 8
 eNABLE_LVB_GRID_WORLDWIDE = 16
 
-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
-    }
-
 generateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO ()
 generateConsoleCtrlEvent e p
     = failIfFalse_
         "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 []
@@ -144,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
-    { 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
+-- | 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
@@ -219,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/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/DLL.hsc view
@@ -31,76 +31,49 @@     , 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  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
@@ -54,14 +54,22 @@     , useAllRegs     , withThreadContext -#if __i386__+#if defined(i386_HOST_ARCH)     , eax, ebx, ecx, edx, esi, edi, ebp, eip, esp-#elif __x86_64__+#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@@ -70,31 +78,20 @@     , 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@@ -342,7 +339,7 @@             (act buf)  -#if __i386__+#if defined(i386_HOST_ARCH) eax, ebx, ecx, edx :: Int esi, edi :: Int ebp, eip, esp :: Int@@ -355,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@@ -368,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)@@ -391,6 +427,7 @@     6 -> (#offset CONTEXT, Dr6)     7 -> (#offset CONTEXT, Dr7)     _ -> undefined+#endif  setReg :: Ptr a -> Int -> DWORD -> IO () setReg = pokeByteOff@@ -416,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/File.hsc view
@@ -189,9 +189,12 @@     , createDirectoryEx     , removeDirectory     , getBinaryType+    , getTempFileName+    , replaceFile        -- * HANDLE operations     , createFile+    , createFile_NoRetry     , closeHandle     , getFileType     , flushFileBuffers@@ -238,12 +241,13 @@     , unlockFile     ) where +import System.Win32.File.Internal import System.Win32.Types-import System.Win32.Time  import Foreign hiding (void) import Control.Monad import Control.Concurrent+import Data.Maybe (fromMaybe)  ##include "windows_cconv.h" @@ -251,319 +255,12 @@ #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 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 ---------------------------------------------------------------- --- | 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@@ -593,183 +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 -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-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- --Sigh - I give up & prefix win32_ to the next two to avoid -- senseless Prelude name clashes. --sof. @@ -778,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@@ -806,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 ->@@ -841,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@@ -859,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@@ -873,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 ->@@ -920,16 +535,12 @@   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@@ -951,10 +562,6 @@          ovlp  = OVERLAPPED 0 0 o_low o_hi nullPtr      with ovlp $ \ptr -> c_LockFileEx hwnd mode 0 s_low s_hi ptr -foreign import WINDOWS_CCONV unsafe "LockFileEx"-  c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED-               -> IO BOOL- -- | 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@@ -969,9 +576,6 @@          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--foreign import WINDOWS_CCONV unsafe "UnlockFileEx"-  c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL  ---------------------------------------------------------------- -- 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
@@ -44,7 +44,9 @@     , unmapViewOfFile     ) where -import System.Win32.Types   ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR, withTString++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@@ -52,9 +54,8 @@ import System.Win32.Info  import Control.Exception        ( mask_, bracket )-import Foreign                  ( Ptr, nullPtr, plusPtr, maybeWith, FunPtr+import Foreign                  ( Ptr, nullPtr, plusPtr, maybeWith                                 , ForeignPtr, newForeignPtr )-import Foreign.C.Types (CUIntPtr(..))  ##include "windows_cconv.h" @@ -81,8 +82,6 @@                     newForeignPtr c_UnmapViewOfFileFinaliser ptr                 return (fp, fromIntegral $ bhfiSize fi) -data MappedObject = MappedObject HANDLE HANDLE FileMapAccess- -- | Opens an existing file and creates mapping object to it. withMappedFile     :: FilePath             -- ^ Path@@ -128,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@@ -175,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,7 +12,7 @@ 
    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.
 -}
@@ -21,9 +21,10 @@   , 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"
 
@@ -44,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
@@ -129,14 +129,14 @@     , 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)@@ -175,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 ---------------------------------------------------------------- @@ -256,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  ----------------------------------------------------------------@@ -468,9 +244,6 @@ ----------------------------------------------------------------  -- %fun GetUserName :: IO String--foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW"-  c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool  getUserName :: IO String getUserName =
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/MinTTY.hsc view
@@ -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
System/Win32/NLS.hsc view
@@ -74,7 +74,7 @@ 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@@ -101,7 +101,7 @@ -- 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. Synonyn for+-- 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).@@ -801,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
@@ -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
@@ -210,7 +210,7 @@                 ok' <- c_Process32Next h pe                 readAndNext ok' pe (entry:res) --- | Enumerate moduless using Module32First and Module32Next+-- | Enumerate modules using Module32First and Module32Next th32SnapEnumModules :: Th32SnapHandle -> IO [ModuleEntry32] th32SnapEnumModules h = allocaBytes (#size MODULEENTRY32W) $ \pe -> do     (#poke MODULEENTRY32W, dwSize) pe ((#size MODULEENTRY32W)::DWORD)
System/Win32/Security.hsc view
@@ -1,5 +1,5 @@ {-# 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 --     https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+ 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
@@ -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
@@ -107,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")
System/Win32/SymbolicLink.hsc view
@@ -16,7 +16,7 @@ 
      * 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
@@ -35,20 +35,14 @@   , 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
- , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2
-}
-
 -- | createSymbolicLink* functions don't check that file is exist or not.
 --
 -- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatibility for Unix,
@@ -97,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/Time.hsc view
@@ -52,21 +52,19 @@     , getTimeFormat     ) where +import System.Win32.Time.Internal import System.Win32.String  ( peekTStringLen, withTString )-import System.Win32.Types   ( BOOL, DDWORD, DWORD, HANDLE, LARGE_INTEGER, LCID-                            , LONG, LPCTSTR, LPCWSTR, LPTSTR, LPWSTR, UINT, WORD-                            , dwordsToDdword, ddwordToDwords, failIf+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"@@ -74,145 +72,30 @@ #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 () 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" $@@ -225,10 +108,6 @@             return $ Just (fromIntegral ta', fromIntegral ti')         else return Nothing -foreign import WINDOWS_CCONV "windows.h GetTickCount" getTickCount :: IO DWORD--foreign import WINDOWS_CCONV unsafe "windows.h GetLastInputInfo"-  c_GetLastInputInfo :: Ptr LASTINPUTINFO -> IO Bool getLastInputInfo :: IO DWORD getLastInputInfo =   with (LASTINPUTINFO 0) $ \lii_p -> do@@ -242,8 +121,6 @@   now <- getTickCount   return $ fromIntegral $ now - lii -foreign import WINDOWS_CCONV "windows.h SetSystemTimeAdjustment"-    c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL setSystemTimeAdjustment :: Maybe Int -> IO () setSystemTimeAdjustment ta =     failIf_ not "setSystemTimeAjustment: SetSystemTimeAdjustment" $@@ -253,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" $@@ -266,24 +141,18 @@         (#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@@ -292,8 +161,6 @@ invalidFileTime :: FILETIME invalidFileTime = FILETIME 0 -foreign import WINDOWS_CCONV "windows.h SetFileTime"-    c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL setFileTime :: HANDLE -> Maybe FILETIME -> Maybe FILETIME -> Maybe FILETIME -> IO () setFileTime h crt acc wrt = withTime crt $     \c_crt -> withTime acc $@@ -305,16 +172,12 @@     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"@@ -350,31 +213,18 @@     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-    }  getTimeFormatEx :: Maybe String                 -> GetTimeFormatFlags@@ -387,17 +237,7 @@             maybeWith withTString fmt $ \c_fmt -> do                 let c_func = c_GetTimeFormatEx c_locale flags c_st c_fmt                 trySized "GetTimeFormatEx" c_func-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 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
@@ -28,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__(..))@@ -57,12 +58,18 @@ #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.Windows.Handle (fromHANDLE, Io(), NativeHandle(),-                              handleToMode, optimizeFileAccess)+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(..))+import GHC.IO.Device (IODeviceType(..), devType) ##endif  #include <fcntl.h>@@ -173,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@@ -181,6 +189,7 @@ -- UTF-16 version: type TCHAR     = CWchar withTString    = withCWString+withFilePath path = useAsCWStringSafe path withTStringLen = withCWStringLen peekTString    = peekCWString peekTStringLen = peekCWStringLen@@ -195,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 ----------------------------------------------------------------@@ -231,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 @@ -260,15 +291,53 @@       -- 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-      optimizeFileAccess handle       let hwnd = fromHANDLE handle :: Io NativeHandle-      -- Not sure if I need to use devType here..+      _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 @@ -290,9 +359,28 @@     -- getting to it while we are doing horrible manipulations with it, and hence     -- stops it being finalized (and closed).     withStablePtr haskell_handle $ const $ do-        windows_handle <- handleToHANDLE haskell_handle+        -- Grab the write handle variable from the Handle+        let write_handle_mvar = case haskell_handle of+                FileHandle _ handle_mvar     -> handle_mvar+                DuplexHandle _ _ handle_mvar -> handle_mvar++        -- This is "write" MVar, we could also take the "read" one+        windows_handle <- readMVar write_handle_mvar >>= handle_ToHANDLE+         -- Do what the user originally wanted         action windows_handle+  where+    -- | Turn an existing Handle into a Win32 HANDLE. This function throws an+    -- IOError if the Handle does not reference a HANDLE+    handle_ToHANDLE :: Handle__ -> IO HANDLE+    handle_ToHANDLE (Handle__{haDevice = dev}) =+        case (cast dev :: Maybe (Io NativeHandle), cast dev :: Maybe (Io ConsoleHandle)) of+          (Just hwnd, Nothing) -> return $ toHANDLE hwnd+          (Nothing, Just hwnd) -> return $ toHANDLE hwnd+          _                    -> throwErr "not a known HANDLE"++    throwErr msg = ioException $ IOError (Just haskell_handle)+      InappropriateType "withHandleToHANDLENative" msg Nothing Nothing ##endif  withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a@@ -368,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/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,5 +1,6 @@+cabal-version:  2.0 name:           Win32-version:        2.12.0.1+version:        2.14.2.2 license:        BSD3 license-file:   LICENSE author:         Alastair Reid, shelarcy, Tamar Christina@@ -11,12 +12,24 @@ 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:  >= 2.0 extra-source-files:     include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h     include/Win32Aux.h include/win32debug.h include/alignment.h+extra-doc-files:     changelog.md+tested-with:+    GHC == 9.2.7,+    GHC == 9.4.5,+    GHC == 9.6.7,+    GHC == 9.8.4,+    GHC == 9.10.1,+    GHC == 9.12.1 +flag os-string+  description: Use the new os-string package+  default: False+  manual: False+ Library     default-language: Haskell2010     default-extensions: ForeignFunctionInterface, CPP@@ -28,7 +41,15 @@         build-depends: unbuildable<0         buildable: False -    build-depends:      base >= 4.5 && < 5, filepath+    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@@ -72,6 +93,7 @@         System.Win32.Event         System.Win32.File         System.Win32.FileMapping+        System.Win32.NamedPipes         System.Win32.Info         System.Win32.Path         System.Win32.Mem@@ -83,6 +105,7 @@         System.Win32.Time         System.Win32.Console         System.Win32.Security+        System.Win32.Semaphore         System.Win32.Types         System.Win32.Shell         System.Win32.Automation@@ -103,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", "winreg_compat.h", "tlhelp32_compat.h", "winnls_compat.h", "winnt_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@@ -122,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,5 +1,70 @@ # Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) +## 2.14.2.2 May 2026++* Fix version bounds for older GHC and drop numeric underscore++## 2.14.2.1 June 2025++* Fix compilation of `ReplaceFileW` on some GHC versions [#245](https://github.com/haskell/win32/issues/245)++## 2.14.2.0 May 2025++* Add ReplaceFileW+* Add support for Windows on Arm+* Add ReadConsoleInput++## 2.14.1.0 November 2024++* Add getTempFileName+* Add WindowsString variant for getEnv etc+* Implement getEnv and getEnvironment++## 2.14.0.0 January 2023++* Add support for named pipes [#220](https://github.com/haskell/win32/pull/220)+* Ensure that FilePaths don't contain interior NULs wrt [#218](https://github.com/haskell/win32/pull/218)+* Add support for GetCommandLineW [#218](https://github.com/haskell/win32/pull/221)+* Support filepath >= 1.5.0.0 and os-string [#226](https://github.com/haskell/win32/pull/226)+* Remove unused imports [#225](https://github.com/haskell/win32/pull/225)++## 2.13.4.0 October 2022++* Add support for semaphores with `System.Win32.Semaphore` (See #214).+* Add function `createFile_NoRetry` (see #208)+* The type signatures for `loadLibrary` and `loadLibraryEx` now refer to+  `HMODULE` instead of `HINSTANCE` for consistency with the official Win32+  API documentation. Note that `HMODULE` and `HINSTANCE` are both type synonyms+  for the same thing, so this only changes the presentation of these functions'+  type signatures, not their behavior.++## 2.13.3.0 July 2022++* Add AFPP support (see #198)++## 2.13.2.1 July 2022++* Add function `createIcon` (see #194)+* Add `WindowMessage` value `wM_SETICON` (see #194)+* Add `WPARAM` values `iCON_SMALL`, `iCON_BIG` (see #194)+* Add functions `getConsoleScreenBufferInfoEx` and+  `getCurrentConsoleScreenBufferInfoEx`++## 2.13.2.0 November 2021++* Set maximum string size for getComputerName. (See #190)+* Update withHandleToHANDLENative to handle duplex and console handles (See #191)++## 2.13.1.0 November 2021++* Fix a bug in which `System.Win32.MinTTY.isMinTTY` would incorrectly return+  `False` on recent versions of MinTTY. (See #187)+* Add all flags for CreateToolhelp32Snapshot.  (See #185)++## 2.13.0.0 August 2021++* Fix type of c_SetWindowLongPtr. See #180+ ## 2.12.0.1 June 2021  * A small fix for WinIO usage. See #177
+ 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
@@ -4,12 +4,23 @@  * 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__ > 708+#if __GLASGOW_HASKELL__ >= 710 #else-// Some declarations from tlhelp32.h that we need in Win32+// 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