packages feed

Win32-extras (empty) → 0.1.0.0

raw patch · 21 files changed

+1359/−0 lines, 21 filesdep +Win32dep +basesetup-changed

Dependencies added: Win32, base

Files

+ Graphics/Win32/Compat.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE CApiFFI #-}
+{- |
+   Module      :  Graphics.Win32.Compat
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Provide 64 bit compatible functions.
+-}
+
+module Graphics.Win32.Compat
+  ( c_SetWindowLongPtr
+  , c_GetWindowLongPtr
+  ) where
+import Graphics.Win32            ( HWND )
+import System.Win32.Types        ( INT )
+import System.Win32.Types.Compat ( LONG_PTR )
+
+-- | We should use this instead of "Graphics.Win32.Window" module's one.
+-- "Graphics.Win32.Window" module's function type is wrong.
+foreign import capi "windows.h SetWindowLongPtrW"
+  c_SetWindowLongPtr :: HWND -> INT -> LONG_PTR -> IO LONG_PTR
+
+foreign import capi "windows.h GetWindowLongPtrW"
+  c_GetWindowLongPtr :: HWND -> INT -> IO LONG_PTR
+ Graphics/Win32/GDI/AlphaBlend.hsc view
@@ -0,0 +1,60 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  Graphics.Win32.GDI.AlphaBlend
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Provides alpha blending  functionality.
+-}
+module Graphics.Win32.GDI.AlphaBlend where
+import Foreign.Storable         ( Storable(..) )
+import Foreign.Ptr              ( Ptr )
+import Graphics.Win32.GDI.Types ( HDC )
+import System.Win32.Types       ( BOOL, BYTE, UINT )
+
+#include <windows.h>
+
+{-
+foreign import WINDOWS_CCONV unsafe "windows.h AlphaBlend"
+  c_AlphaBlend :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> BLENDFUNCTION -> IO BOOL
+-}
+
+foreign import WINDOWS_CCONV unsafe "windows.h TransparentBlt"
+  c_TransparentBlt :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> UINT -> IO BOOL
+
+aC_SRC_OVER :: BYTE
+aC_SRC_OVER = #const AC_SRC_OVER
+
+aC_SRC_ALPHA :: BYTE
+aC_SRC_ALPHA = #const AC_SRC_ALPHA
+
+type PBLENDFUNCTION  = Ptr BLENDFUNCTION
+type LPBLENDFUNCTION = Ptr BLENDFUNCTION
+
+data BLENDFUNCTION = BLENDFUNCTION
+    { blendOp     :: BYTE
+    , blendFlags  :: BYTE
+    , sourceConstantAlpha :: BYTE
+    , alphaFormat :: BYTE
+    } deriving (Show)
+
+instance Storable BLENDFUNCTION where
+    sizeOf = const #size BLENDFUNCTION
+    alignment = sizeOf
+    poke buf func = do
+        (#poke BLENDFUNCTION, BlendOp)     buf (blendOp func)
+        (#poke BLENDFUNCTION, BlendFlags)  buf (blendFlags func)
+        (#poke BLENDFUNCTION, SourceConstantAlpha) buf (sourceConstantAlpha func)
+        (#poke BLENDFUNCTION, AlphaFormat) buf (alphaFormat func)
+
+    peek buf = do
+        blendOp     <- (#peek BLENDFUNCTION, BlendOp) buf
+        blendFlags  <- (#peek BLENDFUNCTION, BlendFlags) buf
+        sourceConstantAlpha <-
+            (#peek BLENDFUNCTION, SourceConstantAlpha) buf
+        alphaFormat <- (#peek BLENDFUNCTION, AlphaFormat) buf
+        return $ BLENDFUNCTION blendOp blendFlags sourceConstantAlpha alphaFormat
+ Graphics/Win32/LayeredWindow.hsc view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  Graphics.Win32.LayeredWindow
+   Copyright   :  2012-2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Provides LayeredWindow functionality.
+-}
+module Graphics.Win32.LayeredWindow where
+import Control.Monad    ( void )
+import Data.Bits        ( (.|.) )
+import Foreign.Ptr      ( Ptr )
+import Graphics.Win32.GDI.AlphaBlend ( BLENDFUNCTION )
+import Graphics.Win32 hiding ( c_SetWindowLongPtr )
+import Graphics.Win32.Compat ( c_SetWindowLongPtr, c_GetWindowLongPtr )
+
+#define _WIN32_WINNT 0x0500
+#include <windows.h>
+
+toLayerdWindow :: HWND -> IO ()
+toLayerdWindow w = do
+  flg <- c_GetWindowLongPtr w gWL_EXSTYLE
+  void $ c_SetWindowLongPtr w gWL_EXSTYLE (flg .|. (fromIntegral wS_EX_LAYERED))
+
+-- test w =  c_SetLayeredWindowAttributes w 0 128 lWA_ALPHA
+
+gWL_EXSTYLE :: INT
+gWL_EXSTYLE = #const GWL_EXSTYLE
+
+wS_EX_LAYERED :: WindowStyleEx
+wS_EX_LAYERED = #const WS_EX_LAYERED
+
+lWA_COLORKEY, lWA_ALPHA :: DWORD
+lWA_COLORKEY = #const LWA_COLORKEY
+lWA_ALPHA    = #const LWA_ALPHA
+
+foreign import WINDOWS_CCONV unsafe "windows.h SetLayeredWindowAttributes"
+  c_SetLayeredWindowAttributes :: HWND -> COLORREF -> BYTE -> DWORD -> IO BOOL
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetLayeredWindowAttributes"
+  c_GetLayeredWindowAttributes :: HWND -> COLORREF -> Ptr BYTE -> Ptr DWORD -> IO BOOL
+
+foreign import WINDOWS_CCONV unsafe "windows.h UpdateLayeredWindow"
+  c_UpdateLayeredWindow :: HWND -> HDC -> Ptr POINT -> Ptr SIZE ->  HDC -> Ptr POINT -> COLORREF -> Ptr BLENDFUNCTION -> DWORD -> IO BOOL
+
+#{enum DWORD,
+ , uLW_ALPHA    = ULW_ALPHA
+ , uLW_COLORKEY = ULW_COLORKEY
+ , uLW_OPAQUE   = ULW_OPAQUE
+ }
+ Graphics/Win32/SafeImport.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  Graphics.Win32.SafeImport
+   Copyright   :  2012 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Import Win32 API safety way.
+-}
+
+module Graphics.Win32.SafeImport
+  ( messageBox
+  , c_MessageBox
+  ) where
+import Graphics.Win32.Misc      ( MBStyle, MBStatus )
+import Graphics.Win32.GDI.Types ( HWND )
+import System.Win32.Types       ( LPCTSTR, withTString )
+import System.Win32.Error       ( failIfZero )
+
+----------------------------------------------------------------
+-- Safe version of MessageBox Function
+----------------------------------------------------------------
+
+-- | When you want to make MessageBox, use this version instead of
+-- "Graphics.Win32.Misc"'s one. See: <https://github.com/haskell/win32/pull/5>
+messageBox :: HWND -> String -> String -> MBStyle -> IO MBStatus
+messageBox wnd text caption style =
+  withTString text $ \ c_text ->
+  withTString caption $ \ c_caption ->
+  failIfZero "MessageBox" $ c_MessageBox wnd c_text c_caption style
+foreign import WINDOWS_CCONV safe "windows.h MessageBoxW"
+  c_MessageBox :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus
+ Graphics/Win32/Window/ForegroundWindow.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  Graphics.Win32.Window.ForegroundWindow
+   Copyright   :  2012 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Get/Set Foreground Window.
+-}
+
+module Graphics.Win32.Window.ForegroundWindow
+  ( getForegroundWindow
+  , setForegroundWindow
+  , c_SetForegroundWindow
+  ) where
+import Graphics.Win32.GDI.Types ( HWND )
+import Graphics.Win32.Window    ( getForegroundWindow )
+
+----------------------------------------------------------------
+-- | Setting Window to Foreground.
+-- See: <https://github.com/haskell/win32/pull/9>,
+-- <http://stackoverflow.com/questions/14297146/win32-setforegroundwindow-in-haskell>.
+----------------------------------------------------------------
+setForegroundWindow :: HWND -> IO Bool
+setForegroundWindow = c_SetForegroundWindow
+
+foreign import WINDOWS_CCONV safe "windows.h SetForegroundWindow"
+    c_SetForegroundWindow :: HWND -> IO Bool
+
+----------------------------------------------------------------
+ Graphics/Win32/Window/HotKey.hsc view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  Graphics.Win32.Window.HotKey
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   An FFI binding to the hot key part of the Win32 API.
+-}
+module Graphics.Win32.Window.HotKey where
+import Data.Bits                ( (.|.) )
+import Graphics.Win32.GDI.Types ( HWND, MbHWND )
+import Graphics.Win32.Key       ( VKey )
+import Graphics.Win32.Message   ( WindowMessage )
+import System.Win32.Types       ( UINT, BOOL, maybePtr )
+import System.Win32.Error       ( failIfFalse_ )
+
+#include <windows.h>
+
+type FsModifiers = [FsModifier]
+type FsModifier  = UINT
+
+#{enum FsModifier,
+ , mOD_ALT      = MOD_ALT
+ , mOD_CONTROL  = MOD_CONTROL
+ , mOD_SHIFT    = MOD_SHIFT
+ , mOD_WIN      = MOD_WIN
+}
+
+{-
+ -- This parameter requires to use Windows 7 or later.
+ , mOD_NOREPEAT = MOD_NOREPEAT
+-}
+
+wM_HOTKEY :: WindowMessage
+wM_HOTKEY = #const WM_HOTKEY
+
+joinModifiers :: FsModifiers -> FsModifier
+joinModifiers = foldr (.|.) 0
+
+registerHotKey :: MbHWND -> Int -> FsModifier -> VKey -> IO ()
+registerHotKey mb_wnd id md vkey =
+  failIfFalse_ (unwords ["RegisterHotKey", show mb_wnd, show id, show md, show vkey])
+    $ c_RegisterHotKey (maybePtr mb_wnd) id 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
+
+foreign import WINDOWS_CCONV "windows.h UnregisterHotKey"
+  c_UnregisterHotKey :: HWND -> Int -> IO BOOL
+ Graphics/Win32/Window/IMM.hsc view
@@ -0,0 +1,110 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  Graphics.Win32.Window.IMM
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   An FFI binding to the IMM (Input Method Manager) part of the Win32 API.
+-}
+module Graphics.Win32.Window.IMM where
+import Foreign.Marshal.Alloc    ( alloca )
+import Foreign.Marshal.Utils    ( fromBool )
+import Foreign.Ptr              ( Ptr )
+import Foreign.Storable         ( peek )
+import Graphics.Win32.GDI.Types ( HWND )
+import Graphics.Win32.Key       ( VKey )
+import System.Win32.Types       ( UINT, DWORD, LPDWORD, BOOL )
+import System.Win32.Error       ( failIfFalse_ )
+
+#include <windows.h>
+
+type HIMC = Ptr ()
+
+foreign import WINDOWS_CCONV "windows.h ImmGetContext"
+  immGetContext     :: HWND -> IO HIMC
+
+foreign import WINDOWS_CCONV "windows.h ImmGetOpenStatus"
+  immGetOpenStatus :: HIMC -> IO BOOL
+
+immSetOpenStatus :: HIMC -> BOOL -> IO ()
+immSetOpenStatus imc flg =
+  failIfFalse_ (unwords ["ImmSetOpenStatus", show imc, show flg])
+    $ c_ImmSetOpenStatus imc (fromBool flg)
+
+foreign import WINDOWS_CCONV "windows.h ImmSetOpenStatus"
+  c_ImmSetOpenStatus  :: HIMC -> UINT -> IO BOOL
+
+
+data IMEMode = IMEMode DWORD DWORD
+
+immGetConversionStatus :: HIMC -> IO IMEMode
+immGetConversionStatus imc =
+  alloca $ \lpConv ->
+  alloca $ \lpStnc -> do
+    failIfFalse_ (unwords ["ImmGetConversionStatus", show imc, show lpConv, show lpStnc]) $
+      c_ImmGetConversionStatus imc lpConv lpStnc
+    conv <- peek lpConv
+    stnc <- peek lpStnc
+    return $ IMEMode conv stnc
+
+foreign import WINDOWS_CCONV "windows.h ImmGetConversionStatus"
+  c_ImmGetConversionStatus :: HIMC -> LPDWORD ->  LPDWORD -> IO BOOL
+
+immSetConversionStatus :: HIMC -> IMEMode -> IO ()
+immSetConversionStatus imc (IMEMode conv stnc) =
+  failIfFalse_ (unwords ["ImmSetConversionStatus", show imc, show conv, show stnc])
+    $ c_ImmSetConversionStatus imc conv stnc
+
+foreign import WINDOWS_CCONV "windows.h ImmSetConversionStatus"
+  c_ImmSetConversionStatus :: HIMC -> DWORD -> DWORD -> IO BOOL
+
+-- iMN_SETCONVERSIONSTATUS = #const IMN_SETCONVERSIONSTATUS
+
+#{enum DWORD,
+ , iME_CMODE_ALPHANUMERIC  = IME_CMODE_ALPHANUMERIC
+ , iME_CMODE_CHARCODE      = IME_CMODE_CHARCODE
+ , iME_CMODE_EUDC          = IME_CMODE_EUDC
+ , iME_CMODE_FIXED         = IME_CMODE_FIXED
+ , iME_CMODE_FULLSHAPE     = IME_CMODE_FULLSHAPE
+ , iME_CMODE_HANJACONVERT  = IME_CMODE_HANJACONVERT
+ , iME_CMODE_KATAKANA      = IME_CMODE_KATAKANA
+ , iME_CMODE_NATIVE        = IME_CMODE_NATIVE
+ , iME_CMODE_NOCONVERSION  = IME_CMODE_NOCONVERSION
+ , iME_CMODE_ROMAN         = IME_CMODE_ROMAN
+ , iME_CMODE_SOFTKBD       = IME_CMODE_SOFTKBD
+ , iME_CMODE_SYMBOL        = IME_CMODE_SYMBOL
+ }
+
+#{enum DWORD,
+ , iME_SMODE_AUTOMATIC     = IME_SMODE_AUTOMATIC
+ , iME_SMODE_NONE          = IME_SMODE_NONE
+ , iME_SMODE_PHRASEPREDICT = IME_SMODE_PHRASEPREDICT
+ , iME_SMODE_PLAURALCLAUSE = IME_SMODE_PLAURALCLAUSE
+ , iME_SMODE_SINGLECONVERT = IME_SMODE_SINGLECONVERT
+ }
+{-
+ , iME_SMODE_CONVERSATION  = IME_SMODE_CONVERSATION
+-}
+
+immReleaseContext :: HWND -> HIMC -> IO ()
+immReleaseContext wnd imc =
+  failIfFalse_ (unwords ["ImmSetOpenStatus", show wnd, show imc])
+    $ c_ImmReleaseContext wnd imc
+
+foreign import WINDOWS_CCONV "windows.h ImmReleaseContext"
+  c_ImmReleaseContext :: HWND -> HIMC -> IO BOOL
+
+foreign import WINDOWS_CCONV "windows.h ImmGetVirtualKey"
+  immGetVirtualKey :: HWND -> IO VKey
+
+immSimulateHotKey :: HWND -> DWORD -> IO ()
+immSimulateHotKey hwd hkey =
+  failIfFalse_ (unwords ["ImmSimulateHotKey", show hwd, show hkey])
+    $ c_ImmSimulateHotKey hwd hkey
+
+foreign import WINDOWS_CCONV "windows.h ImmSimulateHotKey"
+  c_ImmSimulateHotKey :: HWND -> DWORD -> IO BOOL
+ Graphics/Win32/Window/PostMessage.hsc view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  Graphics.Win32.Window.PostMessage
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Provide PostMessage function and friends.
+-}
+module Graphics.Win32.Window.PostMessage where
+import Graphics.Win32.GDI.Types ( HWND, MbHWND )
+import Graphics.Win32.Message   ( WindowMessage )
+import System.Win32.Types       ( DWORD, WPARAM, LPARAM, BOOL
+                                , maybePtr, castUINTPtrToPtr )
+import System.Win32.Error       ( failIfFalse_ )
+
+#include <windows.h>
+
+postMessage :: MbHWND -> WindowMessage -> WPARAM -> LPARAM -> IO ()
+postMessage mb_wnd msg w l =
+  failIfFalse_ (unwords ["PostMessage", show mb_wnd, show msg, show w, show l]) $
+    c_PostMessage (maybePtr mb_wnd) msg w l
+
+foreign import WINDOWS_CCONV "windows.h PostMessageW"
+  c_PostMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO BOOL
+
+foreign import WINDOWS_CCONV "windows.h PostQuitMessage"
+  postQuitMessage :: Int -> IO ()
+
+postThreadMessage :: DWORD -> WindowMessage -> WPARAM -> LPARAM -> IO ()
+postThreadMessage tId msg w l =
+  failIfFalse_ (unwords ["PostThreadMessage", show tId, show msg, show w, show l]) $
+    c_PostThreadMessage tId msg w l
+
+foreign import WINDOWS_CCONV "windows.h PostThreadMessageW"
+  c_PostThreadMessage :: DWORD -> WindowMessage -> WPARAM -> LPARAM -> IO BOOL
+
+#{enum HWND, castUINTPtrToPtr
+ , hWND_BROADCAST = (UINT_PTR)HWND_BROADCAST
+ }
+
+foreign import WINDOWS_CCONV "windows.h InSendMessage"
+  inSendMessage :: IO Bool
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012-2013, shelarcy
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of shelarcy nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Media/Win32.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  Media.Win32
+   Copyright   :  2012 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Multimedia API. TODO: provide more functions ...
+-}
+
+module Media.Win32
+  ( module Media.Win32
+  ) where
+import Control.Monad                ( unless )
+import Prelude               hiding ( ioError, userError )
+import System.IO.Error              ( ioError, userError )
+import System.Win32.Error           ( failIfFalse_ )
+import System.Win32.Encoding        ( encodeMultiByte, getCurrentCodePage )
+import System.Win32.Types hiding    ( failIfFalse_ )
+import System.Win32.String          ( withTStringBufferLen )
+
+type MCIERROR = DWORD
+
+mciSendString :: String -> IO ()
+mciSendString cmd
+ = withTString cmd $ \sendCmd -> do
+     err <- c_mciSendString sendCmd nullPtr 0 nullPtr
+     unless (err == 0)
+       $ mciGetErrorString err
+
+foreign import WINDOWS_CCONV safe "windows.h mciSendStringW"
+  c_mciSendString :: LPCTSTR -> LPTSTR -> UINT -> HANDLE -> IO MCIERROR
+
+mciGetErrorString :: MCIERROR -> IO ()
+mciGetErrorString err
+  = withTStringBufferLen 256 $ \(cstr, len) ->  do
+      failIfFalse_ "mciGetErrorString" $
+        c_mciGetErrorString err cstr $ fromIntegral len
+      msg <- peekTString cstr
+      cp  <- getCurrentCodePage
+      ioError $ userError $ encodeMultiByte cp msg
+
+foreign import WINDOWS_CCONV unsafe "windows.h mciGetErrorStringW"
+  c_mciGetErrorString :: MCIERROR -> LPTSTR -> UINT -> IO BOOL
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ System/Win32/DLL/LoadFunction.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.DLL.LoadFunction
+   Copyright   :  2012 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Load a DLL's function.
+-}
+module System.Win32.DLL.LoadFunction
+  ( module System.Win32.DLL.LoadFunction
+  ) where
+import Control.Exception            ( bracket, mask, finally )
+import Foreign.C.String             ( withCAString )
+import Foreign.Ptr                  ( FunPtr, castPtrToFunPtr )
+import System.Win32.Error           ( failIfFalse_ )
+import System.Win32.Exception.Unsupported
+import System.Win32.DLL             ( c_GetProcAddress, c_LoadLibrary, freeLibrary, getModuleHandle )
+import System.Win32.Types hiding    ( failIfFalse_ )
+----------------------------------------------------------------
+-- LoadFunctions
+----------------------------------------------------------------
+loadFunction :: HMODULE -> String -> (FunPtr a -> IO b) -> IO b
+loadFunction dll name conv
+  = withCAString name $ \c_name -> do
+        proc <- unsupportedIfNull (missingFunction name)
+                    $ c_GetProcAddress dll c_name
+        conv $ castPtrToFunPtr proc
+
+loadSystemFunction :: HMODULE -> String -> (FunPtr a -> IO b) -> IO b
+loadSystemFunction dll name conv
+  = withCAString name $ \c_name -> do
+        -- Is failIfNull suitable or not?
+        proc <- unsupportedIfNull (missingWin32Function name)
+                    $ c_GetProcAddress dll c_name
+        conv $ castPtrToFunPtr proc
+
+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 =
+  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)
+{-
+    result <- restore $
+                catch (loadFunction dllname dll name conv)
+                  (\e -> case e of
+                           MissingFunction _ _ -> do freeLibrary dll
+                                                     throwIO e
+                           _ -> throwIO e)
+    _      <- freeLibrary a
+    return result
+-}
+
+withLoadSystemFunction :: String -> String -> (FunPtr a -> IO b) -> IO b
+withLoadSystemFunction dllname name conv
+  = bracket (getModuleHandle (Just dllname)) (\_ -> return ())
+      $ \dll -> loadSystemFunction dll name conv
+
+-- portable version
+setSearchPathMode :: SearchPathModeFlags -> IO ()
+setSearchPathMode flag =
+  withLoadSystemFunction "Kernel32.dll" "SetSearchPathMode" $ \c_SetSearchPathMode ->
+    failIfFalse_ "SetDllDirectory" $ convSetSearchPathMode c_SetSearchPathMode flag
+
+type SearchPathModeFlags = DWORD
+bASE_SEARCH_PATH_ENABLE_SAFE_SEARCHMODE, bASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE, bASE_SEARCH_PATH_PERMANENT :: SearchPathModeFlags
+bASE_SEARCH_PATH_ENABLE_SAFE_SEARCHMODE = 0x00000001
+bASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE = 0x00010000
+bASE_SEARCH_PATH_PERMANENT = 0x00008000
+
+foreign import WINDOWS_CCONV unsafe "dynamic" convSetSearchPathMode ::
+   FunPtr (SearchPathModeFlags -> IO BOOL) -> (SearchPathModeFlags -> IO BOOL)
+{-
+-- non portable version.
+setSearchPathMode :: SearchPathModeFlags -> IO ()
+setSearchPathMode flag =
+  failIfFalse_ "SetDllDirectory" $ c_SetSearchPathMode flag
+
+foreign import WINDOWS_CCONV unsafe "windows.h SetSearchPathMode"
+  c_SetSearchPathMode :: SearchPathModeFlags -> IO BOOL
+
+{enum SearchPathModeFlags,
+ , bASE_SEARCH_PATH_ENABLE_SAFE_SEARCHMODE  = BASE_SEARCH_PATH_ENABLE_SAFE_SEARCHMODE
+ , bASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE = BASE_SEARCH_PATH_DISABLE_SAFE_SEARCHMODE
+ , bASE_SEARCH_PATH_PERMANENT               = BASE_SEARCH_PATH_PERMANENT
+ }
+-}
+
+setDllDirectory :: String -> IO ()
+setDllDirectory name =
+  withTString name $ \ c_name ->
+  failIfFalse_ "SetDllDirectory" $ c_SetDllDirectory c_name
+
+foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW"
+  c_SetDllDirectory :: LPTSTR -> IO BOOL
+ System/Win32/Encoding.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.Encoding
+   Copyright   :  2012 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Enocode/Decode mutibyte charactor using Win32 API.
+-}
+
+module System.Win32.Encoding
+  ( getCurrentCodePage
+  , encodeMultiByte
+  , encodeMultiByteIO
+  , decodeMultiByte
+  , decodeMultiByteIO
+  ) where
+
+import Foreign.C.Types        (CInt(..))
+import Foreign.C.String       (peekCAStringLen, withCWStringLen)
+import Foreign.Marshal.Array  (allocaArray)
+import Foreign.Marshal.Unsafe (unsafeLocalState)
+import System.Win32.Console
+import System.Win32.NLS
+import System.Win32.Types
+
+-- note CodePage = UInt which might not work on Win64.  But the Win32 package
+-- also has this issue.
+getCurrentCodePage :: IO DWORD
+getCurrentCodePage = do
+    conCP <- getConsoleCP
+    if conCP > 0
+        then return conCP
+        else getACP
+
+-- | The "System.IO" output functions (e.g. `putStr`) don't
+-- automatically convert to multibyte string on Windows, so this
+-- function is provided to make the conversion from a Unicode string
+-- in the given code page to a proper multibyte string.  To get the
+-- code page for the console, use `getCurrentCodePage`.
+--
+encodeMultiByte :: CodePage -> String -> String
+encodeMultiByte cp = unsafeLocalState . encodeMultiByteIO cp
+
+encodeMultiByteIO :: CodePage -> String -> IO String
+encodeMultiByteIO _ "" = return ""
+  -- WideCharToMultiByte doesn't handle empty strings
+encodeMultiByteIO cp wstr =
+  withCWStringLen wstr $ \(cwstr,len) -> do
+    mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte 
+                cp
+                0
+                cwstr
+                (fromIntegral len)
+                nullPtr 0
+                nullPtr nullPtr
+    -- mbchars is the length of buffer required
+    allocaArray (fromIntegral mbchars) $ \mbstr -> do
+      mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte 
+                 cp
+                 0
+                 cwstr
+                 (fromIntegral len)
+                 mbstr mbchars
+                 nullPtr nullPtr
+      peekCAStringLen (mbstr,fromIntegral mbchars)  -- converts [Char] to UTF-16
+
+foreign import WINDOWS_CCONV "WideCharToMultiByte"
+  wideCharToMultiByte
+        :: CodePage
+        -> DWORD   -- dwFlags,
+        -> LPCWSTR -- lpWideCharStr
+        -> CInt    -- cchWideChar
+        -> LPSTR   -- lpMultiByteStr
+        -> CInt    -- cbMultiByte
+        -> LPCSTR  -- lpMultiByteStr
+        -> LPBOOL  -- lpbFlags
+        -> IO CInt
+
+-- | The "System.IO" input functions (e.g. `getLine`) don't
+-- automatically convert to Unicode, so this function is provided to
+-- make the conversion from a multibyte string in the given code page 
+-- to a proper Unicode string.  To get the code page for the console,
+-- use `getCurrentCodePage`.
+decodeMultiByte :: CodePage -> String -> String
+decodeMultiByte cp = unsafeLocalState . decodeMultiByteIO cp
+
+-- | Because of `stringToUnicode` is unclear name, we use `decodeMultiByteIO`
+-- for alias of `stringToUnicode`. 
+decodeMultiByteIO :: CodePage -> String -> IO String
+decodeMultiByteIO = stringToUnicode
+{-# INLINE decodeMultiByteIO #-}
+ System/Win32/Error.hs view
@@ -0,0 +1,31 @@+{-# 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/MultiByte.hsc view
@@ -0,0 +1,121 @@+{- |
+   Module      :  System.Win32.Error.MutiByte
+   Copyright   :  2012 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   MutiByte support version of error handling for foreign calls to the Win32 API.
+-}
+module System.Win32.Error.MultiByte where
+import Control.Concurrent        ( threadDelay)
+import Control.Exception         ( throwIO )
+import Control.Monad             ( void )
+import Data.Char                 ( isSpace )
+import Foreign.C.Error           ( getErrno, errnoToIOError )
+import Foreign.Ptr               ( Ptr )
+import qualified Numeric         ( showHex )
+import System.IO.Error           ( ioeSetErrorString )
+import System.Win32.Types hiding ( failIf, failIf_, failIfNull
+                                 , failIfZero, failIfFalse_
+                                 , failUnlessSuccess, failUnlessSuccessOr
+                                 , errorWin, failWith)
+import System.Win32.Encoding
+
+#include <windows.h>
+
+----------------------------------------------------------------
+-- MultiByte version of 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 ()
+
+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
+  cp <- getCurrentCodePage
+  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
+  msg <- if c_msg == nullPtr
+           then return $ "Error 0x" ++ Numeric.showHex err_code ""
+           else do msg <- peekTString c_msg
+                   -- We ignore failure of freeing c_msg, given we're already failing
+                   _ <- localFree c_msg
+                   return msg
+  c_maperrno -- turn GetLastError() into errno, which errnoToIOError knows
+             -- how to convert to an IOException we can throw.
+             -- XXX we should really do this directly.
+  errno <- getErrno
+  let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n
+  msg'' <- conv msg' -- convert to multibytes message
+  let ioerror = errnoToIOError fn_name errno Nothing Nothing
+                  `ioeSetErrorString` msg''
+  throwIO ioerror
+
+-- | like failIfFalse_, but retried on sharing violations.
+-- This is necessary for many file operations; see
+--   <http://support.microsoft.com/kb/316609>
+--
+failIfWithRetry :: (a -> Bool) -> String -> IO a -> IO a
+failIfWithRetry cond msg action = retryOrFail retries
+  where
+    delay   = 100*1000 -- in ms, we use threadDelay
+    retries = 20 :: Int
+      -- KB article recommends 250/5
+
+    -- retryOrFail :: Int -> IO a
+    retryOrFail times
+      | times <= 0 = errorWin msg
+      | otherwise  = do
+         ret <- action
+         if not (cond ret)
+            then return ret
+            else do
+              err_code <- getLastError
+              if err_code == (# const ERROR_SHARING_VIOLATION)
+                then do threadDelay delay; retryOrFail (times - 1)
+                else errorWin msg
+
+failIfWithRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
+failIfWithRetry_ cond msg action = void $ failIfWithRetry cond msg action
+
+failIfFalseWithRetry_ :: String -> IO Bool -> IO ()
+failIfFalseWithRetry_ = failIfWithRetry_ not
+ System/Win32/Exception/Unsupported.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveDataTypeable #-}
+{- |
+   Module      :  System.Win32.Exception.Unsupported
+   Copyright   :  2012 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Exception handling if using unsupported Win32 API.
+-}
+
+module System.Win32.Exception.Unsupported
+  ( module System.Win32.Exception.Unsupported
+  ) where
+
+import Control.Exception ( Exception(..), throwIO )
+import Data.Typeable     ( Typeable )
+import Foreign.Ptr       ( Ptr, nullPtr )
+
+----------------------------------------------------------------
+-- Exception type of Unsupported
+----------------------------------------------------------------
+data Unsupported = MissingLibrary  FilePath String
+                 | MissingFunction String   String
+                 | MissingValue    String   String
+                 deriving Typeable
+
+instance Show Unsupported where
+  show (MissingLibrary  name reason)
+    = "Can't load library \"" ++ name ++ "\". "  ++ reason
+  show (MissingFunction name reason)
+    = "Can't find \"" ++ name ++ "\" function. " ++ reason
+  show (MissingValue name reason)
+    = "Can't find \"" ++ name ++ "\" value. "    ++ reason
+
+instance Exception Unsupported
+
+missingLibrary,  missingValue, missingWin32Value :: String -> Unsupported
+missingFunction, missingWin32Function            :: FilePath -> 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
+
+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. "
+
+unsupportedIfNull :: Unsupported -> IO (Ptr a) -> IO (Ptr a)
+unsupportedIfNull wh act = do
+  v <- act
+  if v == nullPtr then throwIO wh else return v
+ System/Win32/Info/Computer.hsc view
@@ -0,0 +1,225 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.Info.Computer
+   Copyright   :  2012 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Information about your computer.
+-}
+module System.Win32.Info.Computer where
+import Data.Word             ( Word64 )
+import Foreign.Ptr           ( Ptr )
+import Foreign.Marshal.Alloc ( alloca )
+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
+                             , peekTString, peekTStringLen )
+import System.Win32.Types    ( BOOL, WORD, DWORD, LPDWORD, BYTE )
+
+#define _WIN32_WINNT 0x0500
+#include <windows.h>
+#include <Lmcons.h>
+
+getComputerName :: IO String
+getComputerName =
+  withTStringBuffer  maxLength  $ \buf ->
+  with (fromIntegral maxLength) $ \len -> do
+      failIfFalse_ "GetComputerName"
+        $ c_GetComputerName buf len
+      len' <- peek len
+      peekTStringLen (buf, (fromIntegral len'))
+  where
+    maxLength = #const MAX_COMPUTERNAME_LENGTH
+
+foreign import WINDOWS_CCONV unsafe "GetComputerNameW"
+  c_GetComputerName :: LPTSTR -> LPDWORD -> IO Bool
+
+setComputerName :: String -> IO ()
+setComputerName name =
+  withTString name $ \buf ->
+      failIfFalse_ "SetComputerName"
+        $ c_SetComputerName buf
+
+foreign import WINDOWS_CCONV unsafe "SetComputerNameW"
+  c_SetComputerName :: LPTSTR -> IO Bool
+{-
+type COMPUTER_NAME_FORMAT = UINT
+{enum COMPUTER_NAME_FORMAT,
+ , computerNameNetBIOS                   = ComputerNameNetBIOS
+ , computerNameDnsHostname               = ComputerNameDnsHostname
+ , computerNameDnsDomain                 = ComputerNameDnsDomain
+ , computerNameDnsFullyQualified         = ComputerNameDnsFullyQualified
+ , computerNamePhysicalNetBIOS           = ComputerNamePhysicalNetBIOS
+ , computerNamePhysicalDnsHostname       = ComputerNamePhysicalDnsHostname
+ , computerNamePhysicalDnsDomain         = ComputerNamePhysicalDnsFullyQualified
+ , computerNamePhysicalDnsFullyQualified = ComputerNamePhysicalDnsFullyQualified
+ , computerNameMax                       = ComputerNameMax
+ }
+-}
+
+foreign import WINDOWS_CCONV unsafe "GetSystemMetrics"
+  getSystemMetrics :: SMSetting -> IO Int
+
+#{enum SMSetting,
+ , sM_CMONITORS           = SM_CMONITORS
+ , sM_IMMENABLED          = SM_IMMENABLED
+ , sM_MOUSEWHEELPRESENT   = SM_MOUSEWHEELPRESENT
+ , sM_REMOTESESSION       = SM_REMOTESESSION
+ , sM_SAMEDISPLAYFORMAT   = SM_SAMEDISPLAYFORMAT
+ , sM_XVIRTUALSCREEN      = SM_XVIRTUALSCREEN
+ , sM_YVIRTUALSCREEN      = SM_YVIRTUALSCREEN
+ , sM_SERVERR2            = SM_SERVERR2
+ , sM_MEDIACENTER         = SM_MEDIACENTER
+ , sM_STARTER             = SM_STARTER
+ , sM_TABLETPC            = SM_TABLETPC
+ }
+
+----------------------------------------------------------------
+-- User name
+----------------------------------------------------------------
+
+-- | Get user name. See: <https://github.com/haskell/win32/issues/8>, <http://lpaste.net/41521>
+getUserName :: IO String
+getUserName =
+  withTStringBuffer  maxLength  $ \buf ->
+  with (fromIntegral maxLength) $ \len -> do
+      failIfFalse_ "GetComputerName"
+        $ c_GetUserName buf len
+      -- GetUserNameW includes NUL charactor.
+      peekTString buf
+  where
+    -- This requires Lmcons.h
+    maxLength = #const UNLEN
+
+foreign import WINDOWS_CCONV unsafe "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"
+  isProcessorFeaturePresent :: ProcessorFeature -> IO BOOL
+
+type ProcessorFeature   = DWORD
+
+#{enum ProcessorFeature,
+ , pF_3DNOW_INSTRUCTIONS_AVAILABLE     = PF_3DNOW_INSTRUCTIONS_AVAILABLE
+ , pF_COMPARE_EXCHANGE_DOUBLE          = PF_COMPARE_EXCHANGE_DOUBLE
+ , pF_FLOATING_POINT_EMULATED          = PF_FLOATING_POINT_EMULATED
+ , pF_FLOATING_POINT_PRECISION_ERRATA  = PF_FLOATING_POINT_PRECISION_ERRATA
+ , pF_MMX_INSTRUCTIONS_AVAILABLE       = PF_MMX_INSTRUCTIONS_AVAILABLE
+ , pF_PAE_ENABLED                      = PF_PAE_ENABLED
+ , pF_RDTSC_INSTRUCTION_AVAILABLE      = PF_RDTSC_INSTRUCTION_AVAILABLE
+ , pF_XMMI_INSTRUCTIONS_AVAILABLE      = PF_XMMI_INSTRUCTIONS_AVAILABLE
+ , pF_XMMI64_INSTRUCTIONS_AVAILABLE    = PF_XMMI64_INSTRUCTIONS_AVAILABLE
+ }
+
+{-
+ , pF_CHANNELS_ENABLED                 = PF_CHANNELS_ENABLED
+ , pF_NX_ENABLED                       = PF_NX_ENABLED
+ , pF_COMPARE_EXCHANGE128              = PF_COMPARE_EXCHANGE128
+ , pF_COMPARE64_EXCHANGE128            = PF_COMPARE64_EXCHANGE128
+ , pF_SECOND_LEVEL_ADDRESS_TRANSLATION = PF_SECOND_LEVEL_ADDRESS_TRANSLATION
+ , pF_SSE3_INSTRUCTIONS_AVAILABLE      = PF_SSE3_INSTRUCTIONS_AVAILABLE
+ , pF_VIRT_FIRMWARE_ENABLED            = PF_VIRT_FIRMWARE_ENABLED
+ , pF_XSAVE_ENABLED                    = PF_XSAVE_ENABLED
+-}
+ System/Win32/String.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.String
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Utilities for primitive marshalling of Windows' C strings.
+-}
+module  System.Win32.String
+  ( LPSTR, LPCSTR, LPWSTR, LPCWSTR
+  , TCHAR, LPTSTR, LPCTSTR, LPCTSTR_
+  , withTString, withTStringLen, peekTString, peekTStringLen
+  , newTString
+  , withTStringBuffer, withTStringBufferLen
+  ) where
+import System.Win32.Types
+
+-- | Marshal a dummy Haskell string into a NUL terminated C wide string
+-- using temporary storage.
+--
+-- * the Haskell string is created by length parameter. And the Haskell
+--   string contains contains /only/ NUL characters.
+--
+-- * the memory is freed when the subcomputation terminates (either
+--   normally or via an exception), so the pointer to the temporary
+--   storage must /not/ be used after this.
+--
+withTStringBuffer :: Int -> (LPTSTR -> IO a) -> IO a
+withTStringBuffer maxLength
+  = let dummyBuffer = replicate maxLength '\0'
+    in  withTString dummyBuffer
+
+-- | Marshal a dummy Haskell string into a C wide string (i.e. wide
+-- character array) in temporary storage, with explicit length
+-- information.
+--
+-- * the Haskell string is created by length parameter. And the Haskell
+--   string contains contains /only/ NUL characters.
+--
+-- * the memory is freed when the subcomputation terminates (either
+--   normally or via an exception), so the pointer to the temporary
+--   storage must /not/ be used after this.
+--
+withTStringBufferLen :: Int -> ((LPTSTR, Int) -> IO a) -> IO a
+withTStringBufferLen maxLength
+  = let dummyBuffer = replicate maxLength '\0'
+    in  withTStringLen dummyBuffer
+
+ System/Win32/SymbolicLink.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}
+{- |
+   Module      :  System.Win32.SymbolicLink
+   Copyright   :  2012 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Handling symbolic link using Win32 API. [Vista of later and desktop app only]
+
+   Note: You should worry about UAC (User Account Control) when use this module function in your application:
+
+     * require to use 'Run As Administrator' to run your application.
+
+     * or modify your application's manifect file to add
+       \<requestedExecutionLevel level='requireAdministrator' uiAccess='false'/\>.
+-}
+module System.Win32.SymbolicLink
+  ( module System.Win32.SymbolicLink
+  ) where
+import Foreign.Ptr                  ( FunPtr )
+import System.Win32.DLL.LoadFunction
+import System.Win32.Error ( failIfFalseWithRetry_ )
+import System.Win32.Types
+
+
+-- | createSymbolicLink* doesn't check that file is exist or not.
+createSymbolicLink :: FilePath -> FilePath -> SymbolicLinkFlags -> IO ()
+createSymbolicLink = flip createSymbolicLink'
+
+createSymbolicLinkFile :: FilePath -> FilePath -> IO ()
+createSymbolicLinkFile src target = createSymbolicLink' target src sYMBOLIC_LINK_FLAG_FILE
+
+createSymbolicLinkDirectory :: FilePath -> FilePath -> IO ()
+createSymbolicLinkDirectory src target = createSymbolicLink' target src sYMBOLIC_LINK_FLAG_DIRECTORY
+
+-- portable version
+type SymbolicLinkFlags = DWORD
+sYMBOLIC_LINK_FLAG_FILE, sYMBOLIC_LINK_FLAG_DIRECTORY :: SymbolicLinkFlags
+sYMBOLIC_LINK_FLAG_FILE = 0x0
+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
+
+foreign import WINDOWS_CCONV unsafe "dynamic" convCreateSymbolicLink ::
+   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
+
+{enum SymbolicLinkFlags,
+ , sYMBOLIC_LINK_FLAG_FILE      = SYMBOLIC_LINK_FLAG_FILE
+ , sYMBOLIC_LINK_FLAG_DIRECTORY = SYMBOLIC_LINK_FLAG_DIRECTORY
+ }
+
+foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW"
+  c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL
+-}
+ System/Win32/Types/Compat.hsc view
@@ -0,0 +1,47 @@+{- |
+   Module      :  System.Win32.Types.Compat
+   Copyright   :  2013 shelarcy
+   License     :  BSD-style
+
+   Maintainer  :  shelarcy@gmail.com
+   Stability   :  Provisional
+   Portability :  Non-portable (Win32 API)
+
+   Provide 64 bit compatible types.
+   We should use this module's types to make bindings.
+
+   We should use this module's types instead of "System.Win32.Types" module's one.
+   Because "System.Win32.Types" module's types are hard-corded. So, some types are not
+   compatible with Windows 64 bit environment.
+-}
+module System.Win32.Types.Compat where
+import Data.Word
+import Data.Int
+import Foreign.C.Types (CSize(..))
+
+#include <windows.h>
+
+type DWORD32 = Word32
+type DWORD64 = Word64
+type INT32   = Int32
+type INT64   = Int64
+type LONG32  = #type LONG32
+type LONG64  = #type LONG64
+type UINT32  = Word32
+type UINT64  = Word64
+type ULONG32 = #type ULONG32
+type ULONG64 = #type ULONG64
+
+type DWORD_PTR = #type DWORD_PTR
+type HALF_PTR  = #type HALF_PTR
+type INT_PTR   = #type INT_PTR
+type LONG_PTR  = #type LONG_PTR
+-- | We should use this instead of "System.Win32.Types" module's one.
+-- "System.Win32.Types" module's type is wrong.
+type SIZE_T    = CSize
+type SSIZE_T   = #type SSIZE_T
+type UHALF_PTR = #type UHALF_PTR
+-- | We should use this instead of "System.Win32.Types" module's one.
+-- "System.Win32.Types" module's type is wrong.
+type UINT_PTR  = #type UINT_PTR
+type ULONG_PTR = #type ULONG_PTR
+ Win32-extras.cabal view
@@ -0,0 +1,51 @@+name:                Win32-extras
+version:             0.1.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.
+license:             BSD3
+license-file:        LICENSE
+author:              shelarcy
+maintainer:          shelarcy@gmail.com
+copyright:           (c) 2012-2013 shelarcy
+category:            System, Graphics
+build-type:          Simple
+cabal-version:       >=1.10
+bug-reports:         http://hub.darcs.net/shelarcy/Win32-extras/issues
+
+source-repository head
+   type: darcs
+   location: http://hub.darcs.net/shelarcy/Win32-extras
+
+library
+  exposed-modules:     Graphics.Win32.Compat
+                       Graphics.Win32.LayeredWindow
+                       Graphics.Win32.SafeImport
+                       Graphics.Win32.GDI.AlphaBlend
+                       Graphics.Win32.Window.HotKey
+                       Graphics.Win32.Window.IMM
+                       Graphics.Win32.Window.ForegroundWindow
+                       Graphics.Win32.Window.PostMessage
+
+                       Media.Win32
+
+                       System.Win32.DLL.LoadFunction
+                       System.Win32.Encoding
+                       System.Win32.Error
+                       System.Win32.Exception.Unsupported
+                       System.Win32.Info.Computer
+                       System.Win32.String
+                       System.Win32.SymbolicLink
+                       System.Win32.Types.Compat
+
+  other-modules:       System.Win32.Error.MultiByte
+  build-depends:       base < 5, Win32
+  default-language: Haskell2010
+  if os(windows) && arch(i386)
+   cpp-options: "-DWINDOWS_CCONV=stdcall"
+  else
+   cpp-options: "-DWINDOWS_CCONV=ccall"
+  extra-libraries: msimg32, imm32
+  ghc-options    : -Wall -fno-warn-name-shadowing