packages feed

Win32-extras 0.1.0.0 → 0.2.0.0

raw patch · 24 files changed

+913/−216 lines, 24 filesdep ~Win32dep ~base

Dependency ranges changed: Win32, base

Files

Graphics/Win32/GDI/AlphaBlend.hsc view
@@ -18,8 +18,20 @@ 
 #include <windows.h>
 
+foreign import ccall unsafe "alphablend.h"
+  c_AlphaBlend :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> PBLENDFUNCTION -> IO BOOL
 {-
-foreign import WINDOWS_CCONV unsafe "windows.h AlphaBlend"
+We use C wrapper function to call this API.
+Because foreign stacall/ccall/capi doesn't work with non-pointer user defined type.
+
+We think that capi should support that when user defined type has Storable class instance
+and using CTYPE pragma in the scope.
+
+{-# LANGUAGE CApiFFI #-}
+
+data {-# CTYPE "windows.h" "BLENDFUNCTION" #-} BLENDFUNCTION =
+
+foreign import capi unsafe "windows.h AlphaBlend"
   c_AlphaBlend :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> BLENDFUNCTION -> IO BOOL
 -}
 
@@ -52,9 +64,9 @@         (#poke BLENDFUNCTION, AlphaFormat) buf (alphaFormat func)
 
     peek buf = do
-        blendOp     <- (#peek BLENDFUNCTION, BlendOp) buf
-        blendFlags  <- (#peek BLENDFUNCTION, BlendFlags) buf
-        sourceConstantAlpha <-
+        blendOp'     <- (#peek BLENDFUNCTION, BlendOp) buf
+        blendFlags'  <- (#peek BLENDFUNCTION, BlendFlags) buf
+        sourceConstantAlpha' <-
             (#peek BLENDFUNCTION, SourceConstantAlpha) buf
-        alphaFormat <- (#peek BLENDFUNCTION, AlphaFormat) buf
-        return $ BLENDFUNCTION blendOp blendFlags sourceConstantAlpha alphaFormat
+        alphaFormat' <- (#peek BLENDFUNCTION, AlphaFormat) buf
+        return $ BLENDFUNCTION blendOp' blendFlags' sourceConstantAlpha' alphaFormat'
Graphics/Win32/LayeredWindow.hsc view
@@ -21,8 +21,8 @@ #define _WIN32_WINNT 0x0500
 #include <windows.h>
 
-toLayerdWindow :: HWND -> IO ()
-toLayerdWindow w = do
+toLayeredWindow :: HWND -> IO ()
+toLayeredWindow w = do
   flg <- c_GetWindowLongPtr w gWL_EXSTYLE
   void $ c_SetWindowLongPtr w gWL_EXSTYLE (flg .|. (fromIntegral wS_EX_LAYERED))
Graphics/Win32/Window/HotKey.hsc view
@@ -11,12 +11,14 @@    An FFI binding to the hot key part of the Win32 API.
 -}
 module Graphics.Win32.Window.HotKey where
-import Data.Bits                ( (.|.) )
-import Graphics.Win32.GDI.Types ( HWND, MbHWND )
-import Graphics.Win32.Key       ( VKey )
-import Graphics.Win32.Message   ( WindowMessage )
-import System.Win32.Types       ( UINT, BOOL, maybePtr )
-import System.Win32.Error       ( failIfFalse_ )
+import Data.Bits                 ( (.|.) )
+import Graphics.Win32.GDI.Types  ( HWND, MbHWND )
+import Graphics.Win32.Key        ( VKey )
+import Graphics.Win32.Message    ( WindowMessage )
+import System.Win32.Types        ( UINT, BOOL, maybePtr )
+import System.Win32.Error        ( failIfFalse_ )
+import System.Win32.Exception.Unsupported ( unsupportedVal, upgradeWindowsOS )
+import System.Win32.Info.Version ( is7OrLater )
 
 #include <windows.h>
 
@@ -30,8 +32,12 @@  , mOD_WIN      = MOD_WIN
 }
 
+-- | This parameter requires to use Windows 7 or later.
+mOD_NOREPEAT :: FsModifier
+mOD_NOREPEAT
+  = unsupportedVal "MOD_NOREPEAT"
+      is7OrLater (upgradeWindowsOS "Windows 7") 0x4000
 {-
- -- This parameter requires to use Windows 7 or later.
  , mOD_NOREPEAT = MOD_NOREPEAT
 -}
 
@@ -42,17 +48,17 @@ joinModifiers = foldr (.|.) 0
 
 registerHotKey :: MbHWND -> Int -> FsModifier -> VKey -> IO ()
-registerHotKey mb_wnd id md vkey =
-  failIfFalse_ (unwords ["RegisterHotKey", show mb_wnd, show id, show md, show vkey])
-    $ c_RegisterHotKey (maybePtr mb_wnd) id md vkey
+registerHotKey mb_wnd kid md vkey =
+  failIfFalse_ (unwords ["RegisterHotKey", show mb_wnd, show kid, show md, show vkey])
+    $ c_RegisterHotKey (maybePtr mb_wnd) kid md vkey
 
 foreign import WINDOWS_CCONV "windows.h RegisterHotKey"
   c_RegisterHotKey :: HWND -> Int -> UINT -> VKey -> IO BOOL
 
 unregisterHotKey :: MbHWND -> Int -> IO ()
-unregisterHotKey mb_wnd id =
-  failIfFalse_ (unwords ["UnregisterHotKey", show mb_wnd, show id])
-    $ c_UnregisterHotKey (maybePtr mb_wnd) id
+unregisterHotKey mb_wnd kid =
+  failIfFalse_ (unwords ["UnregisterHotKey", show mb_wnd, show kid])
+    $ c_UnregisterHotKey (maybePtr mb_wnd) kid
 
 foreign import WINDOWS_CCONV "windows.h UnregisterHotKey"
   c_UnregisterHotKey :: HWND -> Int -> IO BOOL
Media/Win32.hs view
@@ -37,7 +37,7 @@ mciGetErrorString :: MCIERROR -> IO ()
 mciGetErrorString err
   = withTStringBufferLen 256 $ \(cstr, len) ->  do
-      failIfFalse_ "mciGetErrorString" $
+      failIfFalse_ (unwords ["mciGetErrorString", show err]) $
         c_mciGetErrorString err cstr $ fromIntegral len
       msg <- peekTString cstr
       cp  <- getCurrentCodePage
+ System/Win32/Console/CtrlHandler.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.Console.CtrlHandler
+   Copyright   :  2008-2013 Judah Jacobson, 2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Set handlers of console Ctrl events.
+-}
+module System.Win32.Console.CtrlHandler 
+  ( CtrlEvent, Handler, PHANDLER_ROUTINE
+  , withConsoleCtrlHandler
+  , setConsoleCtrlHandler, c_SetConsoleCtrlHandler
+  , mkHandler
+  , cTRL_C_EVENT, cTRL_BREAK_EVENT
+  ) where
+import Control.Exception    ( bracket )
+import Control.Monad        ( void )
+import Foreign.Ptr          ( FunPtr )
+import System.Win32.Console ( CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT )
+import System.Win32.Error   ( failIfFalse_ )
+import System.Win32.Types   ( BOOL )
+
+type Handler = CtrlEvent -> IO BOOL
+-- type HandlerRoutine = Handler
+type PHANDLER_ROUTINE = FunPtr Handler
+
+withConsoleCtrlHandler :: Handler -> IO a -> IO a
+withConsoleCtrlHandler handler io
+  = bracket (do hd <- mkHandler handler
+                -- don't fail if we can't set the Ctrl-C handler
+                -- for example, we might not be attached to a console?
+                void $ c_SetConsoleCtrlHandler hd True
+                return hd)
+            (\hd -> void $ c_SetConsoleCtrlHandler hd False)
+            $ const io
+
+-- | This function isn't suitable when we want to set the cTRL_C_EVENT handler.
+-- If you want to set the cTRL_C_EVENT handler, use 'c_SetConsoleCtrlHandler' instead.
+setConsoleCtrlHandler :: PHANDLER_ROUTINE -> BOOL -> IO ()
+setConsoleCtrlHandler handler flag
+  = failIfFalse_ "SetConsoleCtrlHandler"
+      $ c_SetConsoleCtrlHandler handler flag
+
+foreign import WINDOWS_CCONV "wrapper" mkHandler :: Handler -> IO PHANDLER_ROUTINE
+foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler"
+  c_SetConsoleCtrlHandler :: PHANDLER_ROUTINE -> BOOL -> IO BOOL
+ System/Win32/Console/HWND.hs view
@@ -0,0 +1,34 @@+{- |
+   Module      :  System.Win32.Console.HWND
+   Copyright   :  2009 Balazs Komuves, 2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Get the handle of the current console window.
+-}
+module System.Win32.Console.HWND where
+import Control.Concurrent           ( threadDelay )
+import Control.Exception            ( bracket )
+import Foreign.Ptr                  ( nullPtr )
+import Graphics.Win32.Window        ( c_FindWindow )
+import Graphics.Win32.GDI.Types     ( HWND )
+import System.Win32.Console.Title   ( getConsoleTitle, setConsoleTitle )
+import System.Win32.Process.Current ( getCurrentProcessId )
+import System.Win32.String          ( withTString )
+import System.Win32.Time            ( getTickCount )
+
+-- | Get the handle of the current console window by using window's title.
+-- See: <http://support.microsoft.com/kb/124103>
+getConsoleHWND :: IO HWND
+getConsoleHWND
+  = bracket getConsoleTitle setConsoleTitle $ \_ -> do
+        time   <- getTickCount
+        pid    <- getCurrentProcessId
+        let unique = show time ++ show pid
+        setConsoleTitle unique
+        threadDelay (42*1000)
+        withTString unique $ \punique ->
+            c_FindWindow nullPtr punique
+ System/Win32/Console/Title.hsc view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.Console.Title
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Get/Set the title for the current console window.
+-}
+module System.Win32.Console.Title where
+import System.Win32.Error  ( failIfFalse_, failIfZero )
+import System.Win32.String ( LPTSTR, LPCTSTR
+                           , withTStringBufferLen, withTString, peekTStringLen )
+import System.Win32.Types  ( BOOL )
+import System.Win32.Word   ( DWORD )
+
+#include <windows.h>
+
+getConsoleTitle :: IO String
+getConsoleTitle =
+  withTStringBufferLen maxLength $ \(buf, len) -> do
+      len' <- failIfZero "GetConsoleTitle"
+        $ c_GetConsoleTitle buf (fromIntegral len)
+      peekTStringLen (buf, (fromIntegral len'))
+  where
+    maxLength = #const MAX_PATH
+
+setConsoleTitle :: String -> IO ()
+setConsoleTitle title =
+  withTString title $ \buf ->
+      failIfFalse_ (unwords ["SetConsoleTitle", title])
+        $ c_SetConsoleTitle buf
+
+foreign import WINDOWS_CCONV "windows.h GetConsoleTitleW"
+  c_GetConsoleTitle :: LPTSTR -> DWORD -> IO DWORD
+
+foreign import WINDOWS_CCONV "windows.h SetConsoleTitleW"
+  c_SetConsoleTitle :: LPCTSTR -> IO BOOL
+
System/Win32/DLL/LoadFunction.hs view
@@ -23,32 +23,55 @@ ----------------------------------------------------------------
 -- LoadFunctions
 ----------------------------------------------------------------
-loadFunction :: HMODULE -> String -> (FunPtr a -> IO b) -> IO b
-loadFunction dll name conv
+-- | This function is not stable yet.
+-- If you worry about compatibility, use 'loadFunction'' instead.
+loadFunction :: HMODULE
+             -> String -- ^ Function name
+             -> String -- ^ Advice to use function when user can't load function.
+             -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
+             -> IO b
+loadFunction dll name reason conv
   = withCAString name $ \c_name -> do
-        proc <- unsupportedIfNull (missingFunction name)
+        proc <- unsupportedIfNull (MissingFunction name reason)
                     $ c_GetProcAddress dll c_name
         conv $ castPtrToFunPtr proc
 
-loadSystemFunction :: HMODULE -> String -> (FunPtr a -> IO b) -> IO b
-loadSystemFunction dll name conv
+loadFunction' :: HMODULE
+              -> String -- ^ Function name
+              -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
+              -> IO b
+loadFunction' dll name conv = loadFunction dll name "" conv
+
+-- | This function is not stable yet.
+-- If you worry about compatibility, use 'loadSystemFunction'' instead.
+loadSystemFunction :: HMODULE -> String -> String -> (FunPtr a -> IO b) -> IO b
+loadSystemFunction dll name reason conv
   = withCAString name $ \c_name -> do
         -- Is failIfNull suitable or not?
-        proc <- unsupportedIfNull (missingWin32Function name)
+        proc <- unsupportedIfNull (missingWin32Function name reason)
                     $ c_GetProcAddress dll c_name
         conv $ castPtrToFunPtr proc
 
+loadSystemFunction' :: HMODULE -> String -> (FunPtr a -> IO b) -> IO b
+loadSystemFunction' dll name conv = loadSystemFunction dll name "" conv
+
 loadLibrary' :: FilePath -> IO HINSTANCE
 loadLibrary' name =
   withTString name $ \ c_name ->
   unsupportedIfNull (missingLibrary name) $ c_LoadLibrary c_name
 
-withLoadFunction :: FilePath -> String -> (FunPtr a -> IO b) -> IO b
-withLoadFunction dllname name conv =
+-- | This function is not stable yet.
+-- If you worry about compatibility, use 'withLoadFunction'' instead.
+withLoadFunction :: FilePath -- ^ DLL path
+                 -> String   -- ^ Function name
+                 -> String   -- ^ Advice to use function when user can't load function.
+                 -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
+                 -> IO b
+withLoadFunction dllname name reason conv =
   mask $ \restore -> do
     -- loadLibrry is better than c_getModuleHandle when load non-system library.
     dll    <- loadLibrary' dllname
-    restore $ finally (loadFunction dll name conv) (freeLibrary dll)
+    restore $ finally (loadFunction dll name reason conv) (freeLibrary dll)
 {-
     result <- restore $
                 catch (loadFunction dllname dll name conv)
@@ -59,17 +82,60 @@     _      <- freeLibrary a
     return result
 -}
+withLoadFunction' :: FilePath -- ^ DLL path
+                  -> String   -- ^ Function name
+                  -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
+                  -> IO b
+withLoadFunction' dllname name conv = withLoadFunction dllname name "" conv
 
-withLoadSystemFunction :: String -> String -> (FunPtr a -> IO b) -> IO b
-withLoadSystemFunction dllname name conv
+-- | This function is not stable yet.
+-- If you worry about compatibility, use 'withLoadSystemFunction'' instead.
+withLoadSystemFunction :: String -- ^ System's DLL name
+                       -> String -- ^ Function name
+                       -> String -- ^ Advice to use function when user can't load function.
+                       -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
+                       -> IO b
+withLoadSystemFunction dllname name reason conv
   = bracket (getModuleHandle (Just dllname)) (\_ -> return ())
-      $ \dll -> loadSystemFunction dll name conv
+      $ \dll -> loadSystemFunction dll name reason conv
 
+withLoadSystemFunction' :: String -- ^ System's DLL name
+                        -> String -- ^ Function name
+                        -> (FunPtr a -> IO b) -- ^ Process with using loaded function.
+                        -> IO b
+withLoadSystemFunction' dllname name conv = withLoadSystemFunction dllname name "" conv
+
+{-
+-- Should we provide Maybe version's function to provide fallback functionality?
+
+getModuleHandle :: String -> IO (Maybe HMODULE)
+getModuleHandle moduleName = do
+    ptr <- withTString moduleName c_GetModuleHandle
+    if ptr == nullPtr
+      then do
+        err <- getLastError
+        if err == eRROR_MOD_NOT_FOUND
+          then return Nothing
+          else failWith "GetModuleHandle" err
+      else return $ Just ptr
+
+getProcAddress :: HMODULE -> String -> IO (Maybe (FunPtr a))
+getProcAddress hModule procName = do
+    ptr <- withCAString procName $ c_GetProcAddress hModule
+    if ptr == nullPtr
+      then do
+        err <- getLastError
+        if err == eRROR_PROC_NOT_FOUND
+          then return Nothing
+          else failWith "GetProcAddress" err
+      else return $ Just $ castPtrToFunPtr ptr
+-}
+
 -- portable version
 setSearchPathMode :: SearchPathModeFlags -> IO ()
 setSearchPathMode flag =
-  withLoadSystemFunction "Kernel32.dll" "SetSearchPathMode" $ \c_SetSearchPathMode ->
-    failIfFalse_ "SetDllDirectory" $ convSetSearchPathMode c_SetSearchPathMode flag
+  withLoadSystemFunction "Kernel32.dll" "SetSearchPathMode" "" $ \c_SetSearchPathMode ->
+    failIfFalse_ "SetDllDirectory" $ mkSetSearchPathMode c_SetSearchPathMode flag
 
 type SearchPathModeFlags = DWORD
 bASE_SEARCH_PATH_ENABLE_SAFE_SEARCHMODE, bASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE, bASE_SEARCH_PATH_PERMANENT :: SearchPathModeFlags
@@ -77,7 +143,7 @@ bASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE = 0x00010000
 bASE_SEARCH_PATH_PERMANENT = 0x00008000
 
-foreign import WINDOWS_CCONV unsafe "dynamic" convSetSearchPathMode ::
+foreign import WINDOWS_CCONV unsafe "dynamic" mkSetSearchPathMode ::
    FunPtr (SearchPathModeFlags -> IO BOOL) -> (SearchPathModeFlags -> IO BOOL)
 {-
 -- non portable version.
@@ -98,7 +164,7 @@ setDllDirectory :: String -> IO ()
 setDllDirectory name =
   withTString name $ \ c_name ->
-  failIfFalse_ "SetDllDirectory" $ c_SetDllDirectory c_name
+  failIfFalse_ (unwords ["SetDllDirectory", name]) $ c_SetDllDirectory c_name
 
 foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW"
   c_SetDllDirectory :: LPTSTR -> IO BOOL
System/Win32/Encoding.hs view
@@ -17,6 +17,8 @@   , encodeMultiByteIO
   , decodeMultiByte
   , decodeMultiByteIO
+  , wideCharToMultiByte
+  , multiByteToWideChar
   ) where
 
 import Foreign.C.Types        (CInt(..))
@@ -50,21 +52,21 @@   -- WideCharToMultiByte doesn't handle empty strings
 encodeMultiByteIO cp wstr =
   withCWStringLen wstr $ \(cwstr,len) -> do
-    mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte 
+    mbchars' <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte 
                 cp
                 0
                 cwstr
                 (fromIntegral len)
                 nullPtr 0
                 nullPtr nullPtr
-    -- mbchars is the length of buffer required
-    allocaArray (fromIntegral mbchars) $ \mbstr -> do
+    -- mbchar' is the length of buffer required
+    allocaArray (fromIntegral mbchars') $ \mbstr -> do
       mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte 
                  cp
                  0
                  cwstr
                  (fromIntegral len)
-                 mbstr mbchars
+                 mbstr mbchars'
                  nullPtr nullPtr
       peekCAStringLen (mbstr,fromIntegral mbchars)  -- converts [Char] to UTF-16
− System/Win32/Error.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE CPP #-}
-{- |
-   Module      :  System.Win32.Error
-   Copyright   :  2013 shelarcy
-   License     :  BSD-style
-
-   Maintainer  :  shelarcy@gmail.com
-   Stability   :  Provisional
-   Portability :  Non-portable (Win32 API)
-
-   Error handling for foreign calls to the Win32 API.
-
-   This module
-
-   * reorganize Win32 package's error handling functions.
-
-   * supports to show non-UTF MutiByte error message without using GHC 7.8.1.
--}
-module  System.Win32.Error
-  ( failIf, failIf_, failIfNull
-  , failIfZero, failIfFalse_
-  , failUnlessSuccess, failUnlessSuccessOr
-  , errorWin, failWith
-  , failIfWithRetry, failIfWithRetry_, failIfFalseWithRetry_
-  ) where
-#if __GLASGOW_HASKELL__ >= 707
-import System.Win32.File  ( failIfWithRetry, failIfWithRetry_, failIfFalseWithRetry_ )
-import System.Win32.Types
-#else
-import System.Win32.Error.MultiByte
-#endif
+ System/Win32/Error.hsc view
@@ -0,0 +1,49 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.Error
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Error handling for foreign calls to the Win32 API.
+
+   This module
+
+   * reorganize Win32 package's error handling functions.
+
+   * supports to show non-UTF MutiByte error message without using GHC 7.8.1.
+-}
+module System.Win32.Error
+  ( failIf, failIf_, failIfNull
+  , failIfZero, failIfZero_, failIfFalse_
+  , failUnlessSuccess, failUnlessSuccessOr
+  , failIfWithRetry, failIfWithRetry_, failIfFalseWithRetry_
+  , errorWin, getLastError, failWith
+  , eRROR_INSUFFICIENT_BUFFER
+  , eRROR_MOD_NOT_FOUND
+  , eRROR_PROC_NOT_FOUND
+  ) where
+#if __GLASGOW_HASKELL__ >= 707
+import System.Win32.File  ( failIfWithRetry, failIfWithRetry_, failIfFalseWithRetry_ )
+import System.Win32.Types
+#else
+import System.Win32.Error.MultiByte
+import System.Win32.Types ( getLastError, ErrCode )
+#endif
+
+#include <windows.h>
+
+failIfZero_ :: (Eq a, Num a) => String -> IO a -> IO ()
+failIfZero_ = failIf_ (== 0)
+
+eRROR_INSUFFICIENT_BUFFER :: ErrCode
+eRROR_INSUFFICIENT_BUFFER = #const ERROR_INSUFFICIENT_BUFFER
+
+eRROR_MOD_NOT_FOUND :: ErrCode
+eRROR_MOD_NOT_FOUND = #const ERROR_MOD_NOT_FOUND
+
+eRROR_PROC_NOT_FOUND :: ErrCode
+eRROR_PROC_NOT_FOUND = #const ERROR_PROC_NOT_FOUND
System/Win32/Error/MultiByte.hsc view
@@ -72,8 +72,8 @@   failWithInternal getErrorMessage (encodeMultiByteIO cp) fn_name err_code
 
 failWithInternal :: (ErrCode -> IO LPWSTR) -> (String -> IO String) -> String -> ErrCode -> IO a
-failWithInternal msg conv fn_name err_code = do
-  c_msg <- msg err_code
+failWithInternal msg_fun conv fn_name err_code = do
+  c_msg <- msg_fun err_code
   msg <- if c_msg == nullPtr
            then return $ "Error 0x" ++ Numeric.showHex err_code ""
            else do msg <- peekTString c_msg
System/Win32/Exception/Unsupported.hs view
@@ -15,9 +15,10 @@   ( module System.Win32.Exception.Unsupported
   ) where
 
-import Control.Exception ( Exception(..), throwIO )
-import Data.Typeable     ( Typeable )
-import Foreign.Ptr       ( Ptr, nullPtr )
+import Control.Exception      ( Exception(..), throwIO )
+import Data.Typeable          ( Typeable )
+import Foreign.Ptr            ( Ptr, nullPtr )
+import Foreign.Marshal.Unsafe ( unsafeLocalState )
 
 ----------------------------------------------------------------
 -- Exception type of Unsupported
@@ -32,25 +33,38 @@     = "Can't load library \"" ++ name ++ "\". "  ++ reason
   show (MissingFunction name reason)
     = "Can't find \"" ++ name ++ "\" function. " ++ reason
-  show (MissingValue name reason)
-    = "Can't find \"" ++ name ++ "\" value. "    ++ reason
+  show (MissingValue    name reason)
+    = "Can't use \""  ++ name ++ "\" value. "    ++ reason
 
 instance Exception Unsupported
 
-missingLibrary,  missingValue, missingWin32Value :: String -> Unsupported
-missingFunction, missingWin32Function            :: FilePath -> Unsupported
+missingLibrary                          :: FilePath -> Unsupported
+missingFunction,      missingValue      :: String -> Unsupported
 missingLibrary  name = MissingLibrary  name ""
 missingFunction name = MissingFunction name ""
 missingValue    name = MissingValue    name ""
-missingWin32Function name = MissingFunction name $ doesn'tSupport ++ '\n':upgradeVista
-missingWin32Value    name = MissingValue    name $ doesn'tSupport ++ '\n':upgradeVista
 
+missingWin32Function, missingWin32Value :: String -> String -> Unsupported
+missingWin32Function name reason = MissingFunction name $ doesn'tSupport ++ '\n':reason
+missingWin32Value    name reason = MissingValue    name $ doesn'tSupport ++ '\n':reason
+
 doesn'tSupport, upgradeVista, removed :: String
 doesn'tSupport = "Because it's not supported on this OS."
-upgradeVista   = "If you want to use this function, please upgrade your OS to Windows Vista or higher."
-removed = "This function is removed. "
+upgradeVista   = upgradeWindowsOS "Windows Vista"
+removed = "It's removed. "
 
+upgradeWindowsOS :: String -> String
+upgradeWindowsOS ver
+  =  "If you want to use it, please upgrade your OS to "
+  ++ ver ++ " or higher."
+
 unsupportedIfNull :: Unsupported -> IO (Ptr a) -> IO (Ptr a)
 unsupportedIfNull wh act = do
   v <- act
-  if v == nullPtr then throwIO wh else return v
+  if v /= nullPtr then return v else throwIO wh
+
+unsupportedVal :: String -> IO Bool -> String -> a -> a
+unsupportedVal name checkVer reason val = unsafeLocalState $ do
+  cv <- checkVer
+  if cv then return val else throwIO $ MissingValue name reason
+
+ System/Win32/HardLink.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.HardLink
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Handling hard link using Win32 API. [NTFS only]
+
+   Note: You should worry about file system type when use this module's function in your application:
+
+     * NTFS only supprts this functionality.
+
+     * ReFS doesn't support hard link currently.
+-}
+module System.Win32.HardLink
+  ( module System.Win32.HardLink
+  ) where
+import System.Win32.Error  ( failIfFalseWithRetry_ )
+import System.Win32.File   ( LPSECURITY_ATTRIBUTES )
+import System.Win32.String ( LPCTSTR, withTString )
+import System.Win32.Types  ( BOOL, nullPtr )
+
+-- | NOTE: createHardLink is /flipped arguments/ to provide compatiblity for Unix.
+-- 
+-- If you want to create hard link by Windows way, use 'createHardLink'' instead.
+createHardLink :: FilePath -- ^ Target file path
+               -> FilePath -- ^ Hard link name
+               -> IO ()
+createHardLink = flip createHardLink'
+
+createHardLink' :: FilePath -- ^ Hard link name
+                -> FilePath -- ^ Target file path
+                -> IO ()
+createHardLink' link target =
+   withTString target $ \c_target ->
+   withTString link   $ \c_link ->
+        failIfFalseWithRetry_ (unwords ["CreateHardLinkW",show link,show target]) $
+          c_CreateHardLink c_link c_target nullPtr
+
+foreign import WINDOWS_CCONV unsafe "windows.h CreateHardLinkW"
+  c_CreateHardLink :: LPCTSTR -- ^ Hard link name
+                   -> LPCTSTR -- ^ Target file path
+                   -> LPSECURITY_ATTRIBUTES -- ^ This parameter is reserved. You should pass just /nullPtr/.
+                   -> IO BOOL
+
+{-
+-- We plan to check file system type internally.
+
+-- We are thinking about API design, currently...
+data VolumeInformation = VolumeInformation
+      { volumeName         :: String
+      , volumeSerialNumber :: DWORD
+      , maximumComponentLength :: DWORD
+      , fileSystemFlags    :: DWORD
+      , fileSystemName     :: String
+      } deriving Show
+
+getVolumeInformation :: String -> IO VolumeInformation
+getVolumeInformation drive =
+   withTString drive        $ \c_drive ->
+   withTStringBufferLen 256 $ \(vnBuf, vnLen) ->
+   alloca $ \serialNum ->
+   alloca $ \maxLen ->
+   alloca $ \fsFlags ->
+   withTStringBufferLen 256 $ \(fsBuf, fsLen) -> do
+       failIfFalse_ (unwords ["GetVolumeInformationW", drive]) $
+         c_GetVolumeInformation c_drive vnBuf (fromIntegral vnLen)
+                                serialNum maxLen fsFlags
+                                fsBuf (fromIntegral fsLen)
+       return VolumeInformation
+         <*> peekTString vnBuf
+         <*> peek serialNum
+         <*> peek maxLen
+         <*> peek fsFlags
+         <*> peekTString fsBuf
+
+-- Which is better?
+getVolumeFileType :: String -> IO String
+getVolumeFileType drive = fileSystemName <$> getVolumeInformation drive
+
+getVolumeFileType :: String -> IO String
+getVolumeFileType drive =
+   withTString drive        $ \c_drive ->
+   withTStringBufferLen 256 $ \(buf, len) -> do
+       failIfFalse_ (unwords ["GetVolumeInformationW", drive]) $
+         c_GetVolumeInformation c_drive nullPtr 0 nullPtr nullPtr nullPtr buf (fromIntegral len)
+       peekTString buf
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetVolumeInformationW"
+  c_GetVolumeInformation :: LPCTSTR -> LPTSTR -> DWORD -> LPDWORD -> LPDWORD -> LPDWORD -> LPTSTR -> DWORD -> IO BOOL
+-}
System/Win32/Info/Computer.hsc view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-}
 {- |
    Module      :  System.Win32.Info.Computer
-   Copyright   :  2012 shelarcy
+   Copyright   :  2012-2013 shelarcy
    License     :  BSD-style
 
    Maintainer  :  shelarcy@gmail.com
@@ -10,22 +10,80 @@ 
    Information about your computer.
 -}
-module System.Win32.Info.Computer where
-import Data.Word             ( Word64 )
-import Foreign.Ptr           ( Ptr )
-import Foreign.Marshal.Alloc ( alloca )
+module System.Win32.Info.Computer
+  ( -- * Environment Strings
+    expandEnvironmentStrings, c_ExpandEnvironmentStrings
+
+    -- * Computer Name
+  , getComputerName, setComputerName
+  , c_GetComputerName, c_SetComputerName
+
+    -- * System metrics
+  , getSystemMetrics
+  , sM_CMONITORS
+  , sM_IMMENABLED
+  , sM_MOUSEWHEELPRESENT
+  , sM_REMOTESESSION
+  , sM_SAMEDISPLAYFORMAT
+  , sM_XVIRTUALSCREEN
+  , sM_YVIRTUALSCREEN
+  , sM_SERVERR2
+  , sM_MEDIACENTER
+  , sM_STARTER
+  , sM_TABLETPC
+
+  -- * User name
+  , getUserName, c_GetUserName
+
+  -- * Version Info
+  , OSVERSIONINFOEX(..), POSVERSIONINFOEX, LPOSVERSIONINFOEX
+  , ProductType(..)
+  , getVersionEx, c_GetVersionEx
+
+  -- * Processor features
+  , ProcessorFeature
+  , isProcessorFeaturePresent
+  , pF_3DNOW_INSTRUCTIONS_AVAILABLE
+  , pF_COMPARE_EXCHANGE_DOUBLE
+  , pF_FLOATING_POINT_EMULATED
+  , pF_FLOATING_POINT_PRECISION_ERRATA
+  , pF_MMX_INSTRUCTIONS_AVAILABLE
+  , pF_PAE_ENABLED
+  , pF_RDTSC_INSTRUCTION_AVAILABLE
+  , pF_XMMI_INSTRUCTIONS_AVAILABLE
+  , pF_XMMI64_INSTRUCTIONS_AVAILABLE
+  ) where
 import Foreign.Marshal.Utils ( with )
 import Foreign.Storable      ( Storable(..) )
 import System.Win32.Error    ( failIfFalse_ )
 import System.Win32.Info     ( SMSetting )
-import System.Win32.String   ( LPTSTR, withTString, withTStringBuffer
+import System.Win32.Info.Version
+import System.Win32.String   ( LPCTSTR, LPTSTR, withTString, withTStringBuffer
                              , peekTString, peekTStringLen )
-import System.Win32.Types    ( BOOL, WORD, DWORD, LPDWORD, BYTE )
+import System.Win32.Types    ( BOOL )
+import System.Win32.Utils    ( tryWithoutNull )
+import System.Win32.Word     ( DWORD, LPDWORD )
 
 #define _WIN32_WINNT 0x0500
 #include <windows.h>
 #include <Lmcons.h>
 
+----------------------------------------------------------------
+-- Environment Strings
+----------------------------------------------------------------
+expandEnvironmentStrings :: String -> IO String
+expandEnvironmentStrings name =
+  withTString name $ \ c_name ->
+    tryWithoutNull (unwords ["ExpandEnvironmentStrings", name])
+      (\buf len -> c_ExpandEnvironmentStrings c_name buf len) 512
+
+foreign import WINDOWS_CCONV unsafe "windows.h ExpandEnvironmentStringsW"
+  c_ExpandEnvironmentStrings :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD
+
+----------------------------------------------------------------
+-- Computer Name
+----------------------------------------------------------------
+
 getComputerName :: IO String
 getComputerName =
   withTStringBuffer  maxLength  $ \buf ->
@@ -43,7 +101,7 @@ setComputerName :: String -> IO ()
 setComputerName name =
   withTString name $ \buf ->
-      failIfFalse_ "SetComputerName"
+      failIfFalse_ (unwords ["SetComputerName", name])
         $ c_SetComputerName buf
 
 foreign import WINDOWS_CCONV unsafe "SetComputerNameW"
@@ -63,7 +121,52 @@  }
 -}
 
-foreign import WINDOWS_CCONV unsafe "GetSystemMetrics"
+----------------------------------------------------------------
+-- Hardware Profiles
+----------------------------------------------------------------
+{-
+-- TODO: Deside HW_PROFILE_INFO type design
+
+type LPHW_PROFILE_INFO = Ptr HW_PROFILE_INFO
+
+data HW_PROFILE_INFO = HW_PROFILE_INFO
+     { dwDockInfo       :: DWORD
+     , szHwProfileGuid  :: String -- Should we use GUID type instead of String?
+     , szHwProfileName  :: String
+     } deriving Show
+
+instance Storable HW_PROFILE_INFO where
+    sizeOf = const #{size HW_PROFILE_INFOW}
+    alignment = sizeOf
+    poke buf info = do
+        (#poke HW_PROFILE_INFOW, dwDockInfo) buf (dwDockInfo info)
+        withTString (szHwProfileGuid info) $ \szHwProfileGuid' ->
+          (#poke HW_PROFILE_INFOW, szHwProfileGuid) buf szHwProfileGuid'
+        withTString (szHwProfileName info) $ \szHwProfileName' ->
+          (#poke HW_PROFILE_INFOW, szHwProfileName) buf szHwProfileName'
+
+    peek buf = do
+        dockInfo       <- (#peek HW_PROFILE_INFOW, dwDockInfo) buf
+        hwProfileGuid  <- peekTString $ (#ptr HW_PROFILE_INFOW, szHwProfileGuid) buf
+        hwProfileName  <- peekTString $ (#ptr HW_PROFILE_INFOW, szHwProfileName) buf
+        return $ HW_PROFILE_INFO dockInfo hwProfileGuid hwProfileName
+
+getCurrentHwProfile :: IO HW_PROFILE_INFO
+getCurrentHwProfile =
+  alloca $ \buf -> do
+    failIfFalse_ "GetCurrentHwProfile"
+      $ c_GetCurrentHwProfile buf
+    peek buf
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentHwProfileW"
+  c_GetCurrentHwProfile :: LPHW_PROFILE_INFO -> IO Bool
+-}
+
+----------------------------------------------------------------
+-- System metrics
+----------------------------------------------------------------
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetSystemMetrics"
   getSystemMetrics :: SMSetting -> IO Int
 
 #{enum SMSetting,
@@ -97,106 +200,14 @@     -- This requires Lmcons.h
     maxLength = #const UNLEN
 
-foreign import WINDOWS_CCONV unsafe "GetUserNameW"
+foreign import WINDOWS_CCONV unsafe "windows.h GetUserNameW"
   c_GetUserName :: LPTSTR -> LPDWORD -> IO Bool
 
 ----------------------------------------------------------------
--- Version Info
-----------------------------------------------------------------
-getVersionEx :: IO OSVERSIONINFOEX
-getVersionEx =
-  alloca $ \buf -> do
-    (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf
-      (#{size OSVERSIONINFOEXW}::DWORD)
-    failIfFalse_ "GetVersionEx"
-      $ c_GetVersionEx buf
-    peek buf
-
-foreign import WINDOWS_CCONV unsafe "GetVersionExW"
-  c_GetVersionEx :: LPOSVERSIONINFOEX -> IO BOOL
-
-{-
-foreign import WINDOWS_CCONV unsafe "VerifyVersionInfoW"
-  verifyVersionInfo :: LPOSVERSIONINFOEX -> DWORD -> DWORDLONG -> IO BOOL
--}
-
-type DWORDLONG = Word64
-
-data ProductType = VerUnknow BYTE | VerNTWorkStation | VerNTDomainControler | VerNTServer
-    deriving (Show,Eq)
-
-instance Storable ProductType where
-    sizeOf    _ = sizeOf    (undefined::BYTE)
-    alignment _ = alignment (undefined::BYTE)
-    poke buf v = pokeByteOff buf 0 $ case v of
-        VerUnknow w          -> w
-        VerNTWorkStation     -> #const VER_NT_WORKSTATION
-        VerNTDomainControler -> #const VER_NT_DOMAIN_CONTROLLER
-        VerNTServer          -> #const VER_NT_SERVER
-    peek buf = do
-        v <- peekByteOff buf 0
-        return $ case v of
-            (#const VER_NT_WORKSTATION)       -> VerNTWorkStation
-            (#const VER_NT_DOMAIN_CONTROLLER) -> VerNTDomainControler
-            (#const VER_NT_SERVER)            -> VerNTServer
-            w                                 -> VerUnknow w
-
-type POSVERSIONINFOEX = Ptr OSVERSIONINFOEX
-type LPOSVERSIONINFOEX = Ptr OSVERSIONINFOEX
-
-data OSVERSIONINFOEX = OSVERSIONINFOEX
-     { dwMajorVersion    :: DWORD
-     , dwMinorVersion    :: DWORD
-     , dwBuildNumber     :: DWORD
-     , dwPlatformId      :: DWORD
-     , szCSDVersion      :: String
-     , wServicePackMajor :: WORD
-     , wServicePackMinor :: WORD
-     , wSuiteMask        :: WORD
-     , wProductType      :: ProductType
-     , wReserved         :: BYTE
-     } deriving Show
-
-instance Storable OSVERSIONINFOEX where
-    sizeOf = const #{size struct _OSVERSIONINFOEXW}
-    alignment = sizeOf
-    poke buf info = do
-      (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf
-         $ sizeOf (undefined::OSVERSIONINFOEX)
-      (#poke OSVERSIONINFOEXW, dwMajorVersion) buf (dwMajorVersion info)
-      (#poke OSVERSIONINFOEXW, dwMinorVersion) buf (dwMinorVersion info)
-      (#poke OSVERSIONINFOEXW, dwBuildNumber)  buf (dwBuildNumber info)
-      (#poke OSVERSIONINFOEXW, dwPlatformId) buf (dwPlatformId info)
-      withTString (szCSDVersion info) $ \szCSDVersion' ->
-        (#poke OSVERSIONINFOEXW, szCSDVersion) buf szCSDVersion'
-      (#poke OSVERSIONINFOEXW, wServicePackMajor) buf (wServicePackMajor info)
-      (#poke OSVERSIONINFOEXW, wServicePackMinor) buf (wServicePackMinor info)
-      (#poke OSVERSIONINFOEXW, wSuiteMask)   buf (wSuiteMask info)
-      (#poke OSVERSIONINFOEXW, wProductType) buf (wProductType info)
-      (#poke OSVERSIONINFOEXW, wReserved)    buf (wReserved info)
-
-    peek buf = do
-        dwMajorVersion      <- (#peek OSVERSIONINFOEXW, dwMajorVersion) buf
-        dwMinorVersion      <- (#peek OSVERSIONINFOEXW, dwMinorVersion) buf
-        dwBuildNumber       <- (#peek OSVERSIONINFOEXW, dwBuildNumber) buf
-        dwPlatformId        <- (#peek OSVERSIONINFOEXW, dwPlatformId) buf
-        szCSDVersion'       <- (#peek OSVERSIONINFOEXW, szCSDVersion) buf
-        szCSDVersion        <- peekTString szCSDVersion'
-        wServicePackMajor   <- (#peek OSVERSIONINFOEXW, wServicePackMajor) buf
-        wServicePackMinor   <- (#peek OSVERSIONINFOEXW, wServicePackMinor) buf
-        wSuiteMask          <- (#peek OSVERSIONINFOEXW, wSuiteMask) buf
-        wProductType        <- (#peek OSVERSIONINFOEXW, wProductType) buf
-        wReserved           <- (#peek OSVERSIONINFOEXW, wReserved) buf
-        return $ OSVERSIONINFOEX dwMajorVersion dwMinorVersion
-                                 dwBuildNumber dwPlatformId szCSDVersion
-                                 wServicePackMajor wServicePackMinor
-                                 wSuiteMask wProductType wReserved
-
-----------------------------------------------------------------
 -- Processor features
 ----------------------------------------------------------------
 
-foreign import WINDOWS_CCONV unsafe "IsProcessorFeaturePresent"
+foreign import WINDOWS_CCONV unsafe "windows.h IsProcessorFeaturePresent"
   isProcessorFeaturePresent :: ProcessorFeature -> IO BOOL
 
 type ProcessorFeature   = DWORD
+ System/Win32/Info/Version.hsc view
@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.Info.Version
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Version information about your computer.
+-}
+module System.Win32.Info.Version
+  ( -- * Version Info
+    OSVERSIONINFOEX(..), POSVERSIONINFOEX, LPOSVERSIONINFOEX
+  , ProductType(..)
+  , getVersionEx, c_GetVersionEx
+  
+    -- * Verify OS version
+  , isVistaOrLater, is7OrLater
+  ) where
+import Foreign.Ptr           ( Ptr, plusPtr )
+import Foreign.Marshal.Alloc ( alloca )
+import Foreign.Storable      ( Storable(..) )
+import System.Win32.Error    ( failIfFalse_ )
+import System.Win32.String   ( withTString, peekTString )
+import System.Win32.Types    ( BOOL, BYTE )
+import System.Win32.Word     ( WORD, DWORD )
+
+#define _WIN32_WINNT 0x0500
+#include <windows.h>
+
+----------------------------------------------------------------
+-- Version Info
+----------------------------------------------------------------
+getVersionEx :: IO OSVERSIONINFOEX
+getVersionEx =
+  alloca $ \buf -> do
+    (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf
+      $ sizeOf (undefined::OSVERSIONINFOEX)
+    failIfFalse_ "GetVersionEx"
+      $ c_GetVersionEx buf
+    peek buf
+
+data ProductType = VerUnknow BYTE | VerNTWorkStation | VerNTDomainControler | VerNTServer
+    deriving (Show,Eq)
+
+instance Storable ProductType where
+    sizeOf    _ = sizeOf    (undefined::BYTE)
+    alignment _ = alignment (undefined::BYTE)
+    poke buf v = pokeByteOff buf 0 $ case v of
+        VerUnknow w          -> w
+        VerNTWorkStation     -> #const VER_NT_WORKSTATION
+        VerNTDomainControler -> #const VER_NT_DOMAIN_CONTROLLER
+        VerNTServer          -> #const VER_NT_SERVER
+    peek buf = do
+        v <- peekByteOff buf 0
+        return $ case v of
+            (#const VER_NT_WORKSTATION)       -> VerNTWorkStation
+            (#const VER_NT_DOMAIN_CONTROLLER) -> VerNTDomainControler
+            (#const VER_NT_SERVER)            -> VerNTServer
+            w                                 -> VerUnknow w
+
+type POSVERSIONINFOEX = Ptr OSVERSIONINFOEX
+type LPOSVERSIONINFOEX = Ptr OSVERSIONINFOEX
+
+data OSVERSIONINFOEX = OSVERSIONINFOEX
+     { dwMajorVersion    :: DWORD
+     , dwMinorVersion    :: DWORD
+     , dwBuildNumber     :: DWORD
+     , dwPlatformId      :: DWORD
+     , szCSDVersion      :: String
+     , wServicePackMajor :: WORD
+     , wServicePackMinor :: WORD
+     , wSuiteMask        :: WORD
+     , wProductType      :: ProductType
+     } deriving Show
+
+instance Storable OSVERSIONINFOEX where
+    sizeOf = const #{size struct _OSVERSIONINFOEXW}
+    alignment = sizeOf
+    poke buf info = do
+        (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf (sizeOf info)
+        (#poke OSVERSIONINFOEXW, dwMajorVersion) buf (dwMajorVersion info)
+        (#poke OSVERSIONINFOEXW, dwMinorVersion) buf (dwMinorVersion info)
+        (#poke OSVERSIONINFOEXW, dwBuildNumber)  buf (dwBuildNumber info)
+        (#poke OSVERSIONINFOEXW, dwPlatformId) buf (dwPlatformId info)
+        withTString (szCSDVersion info) $ \szCSDVersion' ->
+          (#poke OSVERSIONINFOEXW, szCSDVersion) buf szCSDVersion'
+        (#poke OSVERSIONINFOEXW, wServicePackMajor) buf (wServicePackMajor info)
+        (#poke OSVERSIONINFOEXW, wServicePackMinor) buf (wServicePackMinor info)
+        (#poke OSVERSIONINFOEXW, wSuiteMask)   buf (wSuiteMask info)
+        (#poke OSVERSIONINFOEXW, wProductType) buf (wProductType info)
+        (#poke OSVERSIONINFOEXW, wReserved)    buf (0::BYTE)
+
+    peek buf = do
+        majorVersion     <- (#peek OSVERSIONINFOEXW, dwMajorVersion) buf
+        minorVersion     <- (#peek OSVERSIONINFOEXW, dwMinorVersion) buf
+        buildNumber      <- (#peek OSVERSIONINFOEXW, dwBuildNumber) buf
+        platformId       <- (#peek OSVERSIONINFOEXW, dwPlatformId) buf
+        cSDVersion       <- peekTString $ (#ptr OSVERSIONINFOEXW, szCSDVersion) buf
+        servicePackMajor <- (#peek OSVERSIONINFOEXW, wServicePackMajor) buf
+        servicePackMinor <- (#peek OSVERSIONINFOEXW, wServicePackMinor) buf
+        suiteMask        <- (#peek OSVERSIONINFOEXW, wSuiteMask) buf
+        productType      <- (#peek OSVERSIONINFOEXW, wProductType) buf
+        return $ OSVERSIONINFOEX majorVersion minorVersion
+                                 buildNumber platformId cSDVersion
+                                 servicePackMajor servicePackMinor
+                                 suiteMask productType
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetVersionExW"
+  c_GetVersionEx :: LPOSVERSIONINFOEX -> IO BOOL
+
+----------------------------------------------------------------
+-- Verify OS version
+----------------------------------------------------------------
+-- See: http://msdn.microsoft.com/en-us/library/windows/desktop/ms724833(v=vs.85).aspx
+
+isVistaOrLater, is7OrLater :: IO Bool
+isVistaOrLater = do
+  ver <- getVersionEx
+  return $ 6 <= dwMajorVersion ver
+
+is7OrLater = do
+  ver <- getVersionEx
+  return $  6 <= dwMajorVersion ver
+         && 1 <= dwMinorVersion ver
+
+{-
+We don't use VerifyVersionInfo function to above functions.
+
+Because VerifyVersionInfo is more difficult than GetVersionEx and accessing field in Haskell.
+
+-- | See: http://support.microsoft.com/kb/225013/
+-- http://msdn.microsoft.com/en-us/library/windows/desktop/ms725491(v=vs.85).aspx
+
+bIsWindowsVersionOK :: DWORD -> DWORD -> WORD -> IO BOOL
+bIsWindowsVersionOK dwMajor dwMinor dwSPMajor =
+  alloca $ \buf -> do
+    zeroMemory buf
+      (#{size OSVERSIONINFOEXW}::DWORD)
+    (#poke OSVERSIONINFOEXW, dwOSVersionInfoSize) buf
+      (#{size OSVERSIONINFOEXW}::DWORD)
+    (#poke OSVERSIONINFOEXW, dwMajorVersion)    buf dwMajor
+    (#poke OSVERSIONINFOEXW, dwMinorVersion)    buf dwMinor
+    (#poke OSVERSIONINFOEXW, wServicePackMajor) buf dwSPMajor
+    --  Set up the condition mask.
+    let dwlConditionMask = 0
+        flag =    #const VER_MAJORVERSION
+             .|.  #const VER_MINORVERSION
+             .|.  #const VER_SERVICEPACKMAJOR
+    dwlConditionMask'   <- vER_SET_CONDITION dwlConditionMask   #{const VER_MAJORVERSION} #{const VER_GREATER_EQUAL}
+    dwlConditionMask''  <- vER_SET_CONDITION dwlConditionMask'  #{const VER_MINORVERSION} #{const VER_MINORVERSION}
+    dwlConditionMask''' <- vER_SET_CONDITION dwlConditionMask'' #{const VER_SERVICEPACKMAJOR} #{const VER_SERVICEPACKMAJOR}
+    verifyVersionInfo buf flag dwlConditionMask'''
+
+type ULONGLONG = DWORDLONG
+
+foreign import capi unsafe "windows.h VER_SET_CONDITION"
+  vER_SET_CONDITION :: ULONGLONG -> DWORD -> BYTE -> IO ULONGLONG
+
+foreign import WINDOWS_CCONV unsafe "windows.h VerifyVersionInfoW"
+  verifyVersionInfo :: LPOSVERSIONINFOEX -> DWORD -> DWORDLONG -> IO BOOL
+-}
+ System/Win32/Process/Current.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.Process.Current
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Get current process handle or id.
+-}
+module System.Win32.Process.Current where
+import System.Win32.Process ( ProcessHandle, ProcessId )
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentProcess"
+    getCurrentProcess :: IO ProcessHandle 
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetCurrentProcessId"
+    getCurrentProcessId :: IO ProcessId
System/Win32/String.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-}
 {- |
    Module      :  System.Win32.String
    Copyright   :  2013 shelarcy
@@ -10,7 +9,7 @@ 
    Utilities for primitive marshalling of Windows' C strings.
 -}
-module  System.Win32.String
+module System.Win32.String
   ( LPSTR, LPCSTR, LPWSTR, LPCWSTR
   , TCHAR, LPTSTR, LPCTSTR, LPCTSTR_
   , withTString, withTStringLen, peekTString, peekTStringLen
@@ -23,7 +22,7 @@ -- using temporary storage.
 --
 -- * the Haskell string is created by length parameter. And the Haskell
---   string contains contains /only/ NUL characters.
+--   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
@@ -39,7 +38,7 @@ -- information.
 --
 -- * the Haskell string is created by length parameter. And the Haskell
---   string contains contains /only/ NUL characters.
+--   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
System/Win32/SymbolicLink.hs view
@@ -10,7 +10,7 @@ 
    Handling symbolic link using Win32 API. [Vista of later and desktop app only]
 
-   Note: You should worry about UAC (User Account Control) when use this module function in your application:
+   Note: You should worry about UAC (User Account Control) when use this module's function in your application:
 
      * require to use 'Run As Administrator' to run your application.
 
@@ -23,18 +23,26 @@ import Foreign.Ptr                  ( FunPtr )
 import System.Win32.DLL.LoadFunction
 import System.Win32.Error ( failIfFalseWithRetry_ )
+import System.Win32.Exception.Unsupported ( upgradeVista )
 import System.Win32.Types
 
 
--- | createSymbolicLink* doesn't check that file is exist or not.
-createSymbolicLink :: FilePath -> FilePath -> SymbolicLinkFlags -> IO ()
+-- | createSymbolicLink* functions don't check that file is exist or not.
+--
+-- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatiblity for Unix,
+-- except 'createSymbolicLink''.
+-- 
+-- If you want to create symbolic link by Windows way, use 'createSymbolicLink'' instead.
+createSymbolicLink :: FilePath -- ^ Target file path
+                   -> FilePath -- ^ Symbolic link name
+                   -> SymbolicLinkFlags -> IO ()
 createSymbolicLink = flip createSymbolicLink'
 
 createSymbolicLinkFile :: FilePath -> FilePath -> IO ()
-createSymbolicLinkFile src target = createSymbolicLink' target src sYMBOLIC_LINK_FLAG_FILE
+createSymbolicLinkFile target link = createSymbolicLink' link target sYMBOLIC_LINK_FLAG_FILE
 
 createSymbolicLinkDirectory :: FilePath -> FilePath -> IO ()
-createSymbolicLinkDirectory src target = createSymbolicLink' target src sYMBOLIC_LINK_FLAG_DIRECTORY
+createSymbolicLinkDirectory target link = createSymbolicLink' link target sYMBOLIC_LINK_FLAG_DIRECTORY
 
 -- portable version
 type SymbolicLinkFlags = DWORD
@@ -43,25 +51,29 @@ sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1
 
 -- portable version
-createSymbolicLink' :: String -> String -> SymbolicLinkFlags -> IO ()
-createSymbolicLink' target src flag =
-  withLoadSystemFunction "Kernel32.dll" "CreateSymbolicLinkW" $ \c_CreateSymbolicLink ->
-    withTString target $ \c_target ->
-      withTString src  $ \c_src ->
-        failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show target,show src]) $
-          convCreateSymbolicLink c_CreateSymbolicLink c_target c_src flag
+createSymbolicLink' :: FilePath -- ^ Symbolic link name
+                    -> FilePath -- ^ Target file path
+                    -> SymbolicLinkFlags -> IO ()
+createSymbolicLink' link target flag =
+  withLoadSystemFunction "Kernel32.dll" "CreateSymbolicLinkW" upgradeVista $ \c_CreateSymbolicLink ->
+    withTString link $ \c_link ->
+      withTString target $ \c_target ->
+        failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $
+          mkCreateSymbolicLink c_CreateSymbolicLink c_link c_target flag
 
-foreign import WINDOWS_CCONV unsafe "dynamic" convCreateSymbolicLink ::
+foreign import WINDOWS_CCONV unsafe "dynamic" mkCreateSymbolicLink ::
    FunPtr (LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL)
    -> (LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL)
 {-
 -- non portable version.
-createSymbolicLink' :: String -> String -> SymbolicLinkFlags -> IO ()
-createSymbolicLink' target src flag = do
-    withTString target $ \c_target ->
-      withTString src  $ \c_src ->
-        failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show target,show src]) $
-          c_CreateSymbolicLink c_target c_src flag
+createSymbolicLink' :: FilePath -- ^ Symbolic link name
+                    -> FilePath -- ^ Target file path
+                    -> SymbolicLinkFlags -> IO ()
+createSymbolicLink' link target flag = do
+    withTString link $ \c_link ->
+      withTString target $ \c_target ->
+        failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $
+          c_CreateSymbolicLink c_link c_target flag
 
 {enum SymbolicLinkFlags,
  , sYMBOLIC_LINK_FLAG_FILE      = SYMBOLIC_LINK_FLAG_FILE
+ System/Win32/Utils.hs view
@@ -0,0 +1,77 @@+{- |
+   Module      :  System.Win32.Utils
+   Copyright   :  2009 Balazs Komuves, 2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Utilities for calling Win32 API
+-}
+module System.Win32.Utils
+  ( try, tryWithoutNull, try'
+  -- * Maybe values
+  , maybePtr, ptrToMaybe, maybeNum, numToMaybe
+  , peekMaybe, withMaybe
+  ) where
+import Control.Monad               ( unless )
+import Data.Functor                ( (<$>) )
+import Foreign.Marshal.Array       ( allocaArray, peekArray )
+import Foreign.Marshal.Utils       ( with )
+import Foreign.Ptr                 ( Ptr, nullPtr )
+import Foreign.Storable            ( Storable(..) )
+import System.Win32.Error          ( failIfZero
+                                   , failWith, getLastError, eRROR_INSUFFICIENT_BUFFER )
+import qualified System.Win32.Info ( try )
+import System.Win32.String         ( LPTSTR, peekTString )
+import System.Win32.Types          ( BOOL, UINT, maybePtr, ptrToMaybe, maybeNum, numToMaybe )
+import System.Win32.Word           ( DWORD, PDWORD )
+
+
+-- | Support for API calls that are passed a fixed-size buffer and tell
+-- you via the return value if the buffer was too small.  In that
+-- case, we extend the buffer size and try again.
+try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
+try = System.Win32.Info.try
+{-# INLINE try #-}
+
+tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
+tryWithoutNull loc f n = do
+   e <- allocaArray (fromIntegral n) $ \lptstr -> do
+          r <- failIfZero loc $ f lptstr n
+          if (r > n) then return (Left r) else do
+            str <- peekTString lptstr
+            return (Right str)
+   case e of
+        Left r'   -> tryWithoutNull loc f r'
+        Right str -> return str
+
+try' :: Storable a => String -> (Ptr a -> PDWORD -> IO BOOL) -> DWORD -> IO [a]
+try' loc f n =
+   with n $ \n' -> do
+   e <- allocaArray (fromIntegral n) $ \lptstr -> do
+          flg <- f lptstr n'
+          unless flg $ do
+            err_code <- getLastError
+            unless (err_code == eRROR_INSUFFICIENT_BUFFER)
+              $ failWith loc err_code
+          r   <- peek n'
+          if (r > n) then return (Left r) else do
+            str <- peekArray (fromIntegral r) lptstr
+            return (Right str)
+   case e of
+        Left r'   -> try' loc f r'
+        Right str -> return str
+
+-- | See also: 'Foreign.Marshal.Utils.maybePeek' function.
+peekMaybe :: Storable a => Ptr a -> IO (Maybe a)
+peekMaybe p = 
+  if p == nullPtr
+    then return Nothing
+    else Just <$> peek p
+
+-- | See also: 'Foreign.Marshal.Utils.maybeWith' function.
+withMaybe :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b
+withMaybe Nothing  action = action nullPtr
+withMaybe (Just x) action = with x action
+ System/Win32/Word.hs view
@@ -0,0 +1,23 @@+{- |
+   Module      :  System.Win32.Word
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Windows' unsigned integer types and pointer type.
+-}
+module System.Win32.Word
+  ( WORD, DWORD, PDWORD, LPDWORD
+  , DWORDLONG, DDWORD
+  , DWORD32, DWORD64, DWORD_PTR
+  ) where
+import Data.Word                 ( Word64 )
+import Foreign.Ptr               ( Ptr )
+import System.Win32.Types        ( WORD, DWORD, LPDWORD, DDWORD )
+import System.Win32.Types.Compat ( DWORD32, DWORD64, DWORD_PTR )
+
+type PDWORD = Ptr DWORD
+type DWORDLONG = Word64
Win32-extras.cabal view
@@ -1,10 +1,10 @@ name:                Win32-extras
-version:             0.1.0.0
+version:             0.2.0.0
 synopsis:            Provides missing Win32 API
 description:         This package provides missing features of Win32 package.
                      .
                      This should be part of Win32 package. But it seems that Win32 package is not active development now.
-                     So, I made an separated package for solving today problem.
+                     So, I made a separated package for solving today problem.
 license:             BSD3
 license-file:        LICENSE
 author:              shelarcy
@@ -13,7 +13,9 @@ category:            System, Graphics
 build-type:          Simple
 cabal-version:       >=1.10
+homepage:            http://hub.darcs.net/shelarcy/Win32-extras/
 bug-reports:         http://hub.darcs.net/shelarcy/Win32-extras/issues
+extra-source-files:  changelog
 
 source-repository head
    type: darcs
@@ -31,14 +33,22 @@ 
                        Media.Win32
 
+                       System.Win32.Console.CtrlHandler
+                       System.Win32.Console.HWND
+                       System.Win32.Console.Title
                        System.Win32.DLL.LoadFunction
                        System.Win32.Encoding
                        System.Win32.Error
                        System.Win32.Exception.Unsupported
+                       System.Win32.HardLink
                        System.Win32.Info.Computer
+                       System.Win32.Info.Version
+                       System.Win32.Process.Current
                        System.Win32.String
                        System.Win32.SymbolicLink
                        System.Win32.Types.Compat
+                       System.Win32.Utils
+                       System.Win32.Word
 
   other-modules:       System.Win32.Error.MultiByte
   build-depends:       base < 5, Win32
@@ -48,4 +58,7 @@   else
    cpp-options: "-DWINDOWS_CCONV=ccall"
   extra-libraries: msimg32, imm32
-  ghc-options    : -Wall -fno-warn-name-shadowing
+  ghc-options    : -Wall
+  include-dirs:  include
+  includes:      alphablend.h
+  c-sources:     cbits/alphablend.c
+ cbits/alphablend.c view
@@ -0,0 +1,15 @@+#include <alphablend.h>++BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest+                  , HDC hdcSrc, int nXOriginSrc, int nYOriginSrc, int nWidthSrc, int nHeightSrc+                  , PBLENDFUNCTION pblendFunction)+{+    BLENDFUNCTION blendFunction;+    blendFunction.BlendOp             = pblendFunction->BlendOp;+    blendFunction.BlendFlags          = pblendFunction->BlendFlags;+    blendFunction.SourceConstantAlpha = pblendFunction->SourceConstantAlpha;+    blendFunction.AlphaFormat         = pblendFunction->AlphaFormat;+    AlphaBlend ( hdcDest, nXOriginDest, nYOriginDest, nWidthDest, hHeightDest+               , hdcSrc, nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc+               , blendFunction);+}
+ changelog view
@@ -0,0 +1,24 @@+0.2.0.0 Nov 13 2013+    * Add mOD_NOREPEAT value to Graphics.Win32.Window.HotKey+    * Fix typo of toLayeredWindow function name in Graphics.Win32.LayeredWindow+    * Add System.Win32.Console.CtrlHandler module+    * Add System.Win32.Console.Title module+    * Add System.Win32.Console.HWND module+    * Export wideCharToMultiByte function from System.Win32.Encoding+    * Re-export multiByteToWideChar function from System.Win32.Encoding+    * Add failIfZero_, eRROR_INSUFFICIENT_BUFFER, eRROR_MOD_NOT_FOUND and eRROR_PROC_NOT_FOUND to System.Win32.Error+    * Re-export getLastError function from System.Win32.Error+    * Add upgradeWindowsOS function to System.Win32.Exception.Unsupported+    * Add upgradeWindowsOS and unsupportedVal function to System.Win32.Exception.Unsupported+    * Change missingWin32Function and missingWin32Value's types+    * Add System.Win32.HardLink module+    * Add expandEnvironmentStrings function to System.Win32.Info.Computer+    * Add System.Win32.Info.Version module+    * Change and fix OSVERSIONINFOEX type's definition+    * Change loadFunction, loadSystemFunction, withLoadFunction and withLoadSystemFunction types+    * Add System.Win32.Process.Current module+    * Add System.Win32.Utils module+    * Add System.Win32.Word module to re-export WORD types++0.1.0.0 Sep 29 2013+    * First release