├── cabal.project ├── prologue.txt ├── include ├── Win32Aux.h ├── alignment.h ├── ellipse.h ├── dumpBMP.h ├── WndProc.h ├── win32debug.h ├── windows_cconv.h ├── alphablend.h ├── winnt_compat.h ├── namedpipeapi_compat.h ├── errors.h ├── wincon_compat.h ├── diatemp.h ├── tlhelp32_compat.h ├── winreg_compat.h ├── winternl_compat.h ├── HsWin32.h ├── HsGDI.h ├── winuser_compat.h └── winnls_compat.h ├── doc └── Makefile ├── cbits ├── HsGDI.c ├── HsWin32.c ├── alphablend.c ├── errors.c ├── ellipse.c ├── WndProc.c ├── diatemp.c └── dumpBMP.c ├── .gitignore ├── System ├── Win32 │ ├── Automation.hs │ ├── Word.hs │ ├── SymbolicLink │ │ └── Internal.hsc │ ├── Path │ │ └── Internal.hsc │ ├── HardLink │ │ └── Internal.hs │ ├── WindowsString │ │ ├── DebugApi.hsc │ │ ├── HardLink.hs │ │ ├── Shell.hsc │ │ ├── Path.hsc │ │ ├── DLL.hsc │ │ ├── Time.hsc │ │ ├── Utils.hs │ │ ├── String.hs │ │ ├── SymbolicLink.hsc │ │ ├── Info.hsc │ │ ├── FileMapping.hsc │ │ └── Console.hsc │ ├── Thread.hs │ ├── Console │ │ ├── HWND.hs │ │ ├── Title.hsc │ │ └── CtrlHandler.hs │ ├── Shell │ │ └── Internal.hsc │ ├── String.hs │ ├── Automation │ │ ├── Input │ │ │ ├── Key.hsc │ │ │ └── Mouse.hsc │ │ └── Input.hsc │ ├── DLL │ │ └── Internal.hsc │ ├── Path.hsc │ ├── Shell.hsc │ ├── DLL.hsc │ ├── FileMapping │ │ └── Internal.hsc │ ├── Exception │ │ └── Unsupported.hs │ ├── DebugApi │ │ └── Internal.hsc │ ├── HardLink.hs │ ├── SymbolicLink.hsc │ ├── Encoding.hs │ ├── Semaphore.hsc │ └── FileMapping.hsc └── Win32.hs ├── .github ├── ISSUE_TEMPLATE.md ├── PULL_REQUEST_TEMPLATE.md └── workflows │ └── validate.yml ├── examples ├── Makefile └── hello.lhs ├── Graphics ├── Win32 │ ├── Window │ │ ├── AnimateWindow.hsc │ │ ├── ForegroundWindow.hs │ │ ├── PostMessage.hsc │ │ ├── HotKey.hsc │ │ └── IMM.hsc │ ├── GDI │ │ ├── Palette.hsc │ │ ├── Brush.hsc │ │ ├── AlphaBlend.hsc │ │ ├── Path.hs │ │ ├── Pen.hsc │ │ ├── Region.hs │ │ └── Clip.hsc │ ├── GDI.hs │ ├── Icon.hs │ ├── LayeredWindow.hsc │ └── Resource.hsc └── Win32.hs ├── README.md ├── LICENSE ├── Media └── Win32.hs └── Win32.cabal /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /prologue.txt: -------------------------------------------------------------------------------- 1 | A Haskell binding to the Win32 API. 2 | -------------------------------------------------------------------------------- /include/Win32Aux.h: -------------------------------------------------------------------------------- 1 | /* We define OEMRESOURCE so that we can get the OBM_ constants */ 2 | 3 | #define OEMRESOURCE 4 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | TOP = ../.. 2 | include $(TOP)/mk/boilerplate.mk 3 | 4 | XML_DOC = HSWin32 5 | 6 | include $(TOP)/mk/target.mk 7 | -------------------------------------------------------------------------------- /cbits/HsGDI.c: -------------------------------------------------------------------------------- 1 | // Out-of-line versions of all the inline functions from HsGDI.h 2 | #define INLINE /* nothing */ 3 | #include "HsGDI.h" 4 | -------------------------------------------------------------------------------- /include/alignment.h: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ < 711 2 | #define hsc_alignment(t ) hsc_printf ( "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__)); 3 | #endif -------------------------------------------------------------------------------- /include/ellipse.h: -------------------------------------------------------------------------------- 1 | #ifndef __ELLIPSE_H 2 | #define __ELLIPSE_H 3 | 4 | #include 5 | 6 | extern int transformedEllipse(HDC, LONG, LONG, LONG, LONG, LONG, LONG); 7 | 8 | #endif /* __ELLIPSE_H */ 9 | -------------------------------------------------------------------------------- /include/dumpBMP.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | /* There's currently no #define that indicate whether we're 4 | compiling a .hc file. */ 5 | 6 | extern void CreateBMPFile(LPCTSTR pszFileName, HBITMAP hBmp, HDC hDC); 7 | -------------------------------------------------------------------------------- /include/WndProc.h: -------------------------------------------------------------------------------- 1 | #ifndef __WNDPROC_H 2 | #define __WNDPROC_H 3 | 4 | #define UNICODE 5 | #include 6 | 7 | extern LRESULT CALLBACK genericWndProc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam); 8 | 9 | #endif /* __WNDPROC_H */ 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Specific generated files 2 | .cabal-sandbox/ 3 | GNUmakefile 4 | ghc.mk 5 | dist/ 6 | dist-newstyle/ 7 | *.hi 8 | *.o 9 | *.a 10 | 11 | # The Haskell Tool Stack-related 12 | .stack-work/ 13 | stack.yaml 14 | stack.yaml.lock 15 | 16 | # IDEs 17 | .vscode 18 | -------------------------------------------------------------------------------- /include/win32debug.h: -------------------------------------------------------------------------------- 1 | #ifndef __WIN32_LIB_DEBUG_H 2 | /* prefix WIN32_LIB to give it a better chance of being unique */ 3 | #define __WIN32_LIB_DEBUG_H 4 | 5 | #if defined(TARGET_GHC) && defined(WIN32_LIB_DEBUG) 6 | extern char* __current_fun__; 7 | #endif 8 | 9 | #endif /* __WIN32_LIB_DEBUG_H */ 10 | -------------------------------------------------------------------------------- /include/windows_cconv.h: -------------------------------------------------------------------------------- 1 | #ifndef __WINDOWS_CCONV_H 2 | #define __WINDOWS_CCONV_H 3 | 4 | #if defined(i386_HOST_ARCH) 5 | # define WINDOWS_CCONV stdcall 6 | #elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) 7 | # define WINDOWS_CCONV ccall 8 | #else 9 | # error Unknown mingw32 arch 10 | #endif 11 | 12 | #endif 13 | 14 | -------------------------------------------------------------------------------- /include/alphablend.h: -------------------------------------------------------------------------------- 1 | #ifndef _ALPHABLEND_H 2 | #define _ALPHABLEND_H 3 | 4 | #include 5 | 6 | BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest 7 | , HDC hdcSrc, int nXOriginSrc, int nYOriginSrc, int nWidthSrc, int nHeightSrc 8 | , PBLENDFUNCTION pblendFunction); 9 | 10 | #endif /* _ALPHABLEND_H */ 11 | -------------------------------------------------------------------------------- /include/winnt_compat.h: -------------------------------------------------------------------------------- 1 | /* The version of winnt.h provided by the version of MSYS2 included with 2 | * versions of GHC before GHC 7.10 excludes certain components introduced with 3 | * Windows Vista. 4 | */ 5 | 6 | #ifndef WINNT_COMPAT_H 7 | #define WINNT_COMPAT_H 8 | 9 | #if __GLASGOW_HASKELL__ < 710 && defined(i386_HOST_ARCH) 10 | #define LOCALE_NAME_MAX_LENGTH 85 11 | #endif 12 | 13 | #endif /* #ifndef WINNT_COMPAT_H */ 14 | -------------------------------------------------------------------------------- /cbits/HsWin32.c: -------------------------------------------------------------------------------- 1 | // Out-of-line versions of all the inline functions from HsWin32.h 2 | #define INLINE /* nothing */ 3 | #include "HsWin32.h" 4 | 5 | void UnmapViewOfFileFinaliser(void * p) { 6 | UnmapViewOfFile(p); 7 | } 8 | 9 | void CloseHandleFinaliser(HANDLE h) { 10 | CloseHandle(h); 11 | } 12 | 13 | void FreeLibraryFinaliser(HMODULE m) { 14 | FreeLibrary(m); 15 | } 16 | 17 | void DeleteObjectFinaliser(HGDIOBJ h) { 18 | DeleteObject(h); 19 | } 20 | -------------------------------------------------------------------------------- /System/Win32/Automation.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : System.Win32.Automation 3 | Copyright : 2013 shelarcy 4 | License : BSD-style 5 | 6 | Maintainer : shelarcy@gmail.com 7 | Stability : Provisional 8 | Portability : Non-portable (Win32 API) 9 | 10 | Provide sendInput function and INPUT types. 11 | -} 12 | module System.Win32.Automation 13 | ( module System.Win32.Automation.Input 14 | ) where 15 | import System.Win32.Automation.Input 16 | -------------------------------------------------------------------------------- /include/namedpipeapi_compat.h: -------------------------------------------------------------------------------- 1 | /* The version of wincon.h provided by the version of MSYS2 included with x86 2 | * versions of GHC before GHC 7.10 excludes certain components introduced with 3 | * Windows Vista. 4 | */ 5 | 6 | #ifndef NAMEDPIPEAPI_COMPAT_H 7 | #define NAMEDPIPEAPI_COMPAT_H 8 | 9 | #if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708 10 | # 11 | #else 12 | 13 | #define PIPE_ACCEPT_REMOTE_CLIENTS 0x0 14 | #define PIPE_REJECT_REMOTE_CLIENTS 0x8 15 | #endif /* GHC version check */ 16 | #endif /* NAMEDPIPEAPI_COMPAT_H */ 17 | -------------------------------------------------------------------------------- /include/errors.h: -------------------------------------------------------------------------------- 1 | #ifndef _MY_ERRORS_H 2 | #define _MY_ERRORS_H 3 | 4 | #include 5 | 6 | /* There's two ways we can generate error messages - with different tradeoffs: 7 | * If we do a function call, we have to use a static buffer. 8 | * If we use a macro and ANSI C's string splicing, we have to use constant 9 | * strings - and accept a certain amount of overhead from inserting the 10 | * boilerplate text. 11 | */ 12 | 13 | /* result should be freed using LocalFree */ 14 | extern LPTSTR getErrorMessage(DWORD err); 15 | 16 | #endif /* _MY_ERRORS_H */ 17 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | ## Current Behavior 4 | 5 | 6 | 7 | ## Steps to Reproduce (for bugs) 8 | 9 | 10 | 1. 11 | 2. 12 | 3. 13 | 4. 14 | 15 | ## Your Environment 16 | 17 | * Version used: 18 | * Operating System and version: 19 | -------------------------------------------------------------------------------- /System/Win32/Word.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : System.Win32.Word 3 | Copyright : 2013 shelarcy 4 | License : BSD-style 5 | 6 | Maintainer : shelarcy@gmail.com 7 | Stability : Provisional 8 | Portability : Non-portable (Win32 API) 9 | 10 | Windows' unsigned integer types and pointer type. 11 | -} 12 | module System.Win32.Word 13 | ( WORD, DWORD, PDWORD, LPDWORD 14 | , DWORDLONG, DDWORD 15 | , DWORD32, DWORD64, DWORD_PTR 16 | ) where 17 | import Data.Word ( Word64 ) 18 | import Foreign.Ptr ( Ptr ) 19 | import System.Win32.Types ( WORD, DWORD, LPDWORD, DDWORD, 20 | DWORD32, DWORD64, DWORD_PTR ) 21 | 22 | type PDWORD = Ptr DWORD 23 | type DWORDLONG = Word64 24 | -------------------------------------------------------------------------------- /System/Win32/SymbolicLink/Internal.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.SymbolicLink.Internal 4 | Copyright : 2012 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | -} 11 | module System.Win32.SymbolicLink.Internal where 12 | 13 | import System.Win32.Types 14 | 15 | ##include "windows_cconv.h" 16 | 17 | type SymbolicLinkFlags = DWORD 18 | 19 | #{enum SymbolicLinkFlags, 20 | , sYMBOLIC_LINK_FLAG_FILE = 0x0 21 | , sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1 22 | , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2 23 | } 24 | 25 | foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW" 26 | c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL 27 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | # $Id: Makefile,v 1.1 2004/09/14 07:40:51 mthomas Exp $ 3 | 4 | TOP = ../.. 5 | include $(TOP)/mk/boilerplate.mk 6 | 7 | # 8 | # Disable 'make boot' 9 | # 10 | NO_BOOT_TARGET=YES 11 | 12 | WAYS= 13 | 14 | # ----------------------------------------------------------------------------- 15 | 16 | EXAMPLES := $(wildcard *.lhs) 17 | BINS := $(EXAMPLES:.lhs=$(exeext)) 18 | CLEAN_FILES += $(BINS) 19 | 20 | HC = $(GHC_INPLACE) 21 | MKDEPENDHS = $(GHC_INPLACE) 22 | SRC_HC_OPTS += -package Win32 23 | 24 | all:: $(BINS) 25 | 26 | $(BINS): %$(exeext): %.lhs 27 | $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $< 28 | 29 | # ----------------------------------------------------------------------------- 30 | 31 | include $(TOP)/mk/target.mk 32 | -------------------------------------------------------------------------------- /include/wincon_compat.h: -------------------------------------------------------------------------------- 1 | /* The version of wincon.h provided by the version of MSYS2 included with x86 2 | * versions of GHC before GHC 7.10 excludes certain components introduced with 3 | * Windows Vista. 4 | */ 5 | 6 | #ifndef WINCON_COMPAT_H 7 | #define WINCON_COMPAT_H 8 | 9 | #if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708 10 | # 11 | #else 12 | 13 | typedef struct _CONSOLE_SCREEN_BUFFER_INFOEX { 14 | ULONG cbSize; 15 | COORD dwSize; 16 | COORD dwCursorPosition; 17 | WORD wAttributes; 18 | SMALL_RECT srWindow; 19 | COORD dwMaximumWindowSize; 20 | WORD wPopupAttributes; 21 | WINBOOL bFullscreenSupported; 22 | COLORREF ColorTable[16]; 23 | } CONSOLE_SCREEN_BUFFER_INFOEX, *PCONSOLE_SCREEN_BUFFER_INFOEX; 24 | 25 | #endif /* GHC version check */ 26 | #endif /* WINCON_COMPAT_H */ 27 | -------------------------------------------------------------------------------- /cbits/alphablend.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest 4 | , HDC hdcSrc, int nXOriginSrc, int nYOriginSrc, int nWidthSrc, int nHeightSrc 5 | , PBLENDFUNCTION pblendFunction) 6 | { 7 | BLENDFUNCTION blendFunction; 8 | blendFunction.BlendOp = pblendFunction->BlendOp; 9 | blendFunction.BlendFlags = pblendFunction->BlendFlags; 10 | blendFunction.SourceConstantAlpha = pblendFunction->SourceConstantAlpha; 11 | blendFunction.AlphaFormat = pblendFunction->AlphaFormat; 12 | return AlphaBlend ( hdcDest, nXOriginDest, nYOriginDest, nWidthDest, hHeightDest 13 | , hdcSrc, nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc 14 | , blendFunction); 15 | } 16 | -------------------------------------------------------------------------------- /include/diatemp.h: -------------------------------------------------------------------------------- 1 | #ifndef _DIATEMP_H_ 2 | #define _DIATEMP_H_ 3 | 4 | #include 5 | 6 | typedef struct { 7 | LPDLGTEMPLATE dtemplate; 8 | unsigned int bytes_left; /* bytes left in the chunk that 'dtemplate' points to. */ 9 | unsigned int bytes_alloced; 10 | LPDLGITEMTEMPLATE next_dia_item; 11 | } DIA_TEMPLATE; 12 | 13 | extern LPDLGTEMPLATE getFinalDialog(DIA_TEMPLATE* dt); 14 | 15 | extern DIA_TEMPLATE* mkDiaTemplate 16 | ( UINT size, int x, int y, int cx, int cy 17 | , DWORD style, DWORD exstyle 18 | , LPCWSTR menu, LPCWSTR class 19 | , LPCWSTR caption, LPCWSTR font 20 | , int height 21 | ); 22 | extern DIA_TEMPLATE* addDiaControl 23 | ( DIA_TEMPLATE* dia 24 | , LPCWSTR text, short id 25 | , LPCWSTR classname, DWORD style 26 | , int x, int y, int cx, int cy 27 | , DWORD exstyle 28 | ); 29 | 30 | #endif 31 | -------------------------------------------------------------------------------- /include/tlhelp32_compat.h: -------------------------------------------------------------------------------- 1 | #ifndef TLHELP32_COMPAT_H 2 | #define TLHELP32_COMPAT_H 3 | /* 4 | * tlhelp32.h is not included in MinGW, which was shipped with the 32-bit 5 | * Windows version of GHC prior to the 7.10.3 release. 6 | */ 7 | #if __GLASGOW_HASKELL__ >= 710 8 | #else 9 | // Declarations from tlhelp32.h that Win32 requires 10 | #include 11 | 12 | // CreateToolhelp32Snapshot Flags 13 | // https://docs.microsoft.com/en-us/windows/win32/api/tlhelp32/nf-tlhelp32-createtoolhelp32snapshot 14 | 15 | #define TH32CS_INHERIT 0x80000000 16 | 17 | #define TH32CS_SNAPHEAPLIST 0x00000001 18 | #define TH32CS_SNAPPROCESS 0x00000002 19 | #define TH32CS_SNAPTHREAD 0x00000004 20 | #define TH32CS_SNAPMODULE 0x00000008 21 | #define TH32CS_SNAPMODULE32 0x00000010 22 | 23 | #define TH32CS_SNAPALL (TH32CS_SNAPHEAPLIST|TH32CS_SNAPPROCESS|TH32CS_SNAPTHREAD|TH32CS_SNAPMODULE) 24 | 25 | #endif 26 | #endif /* TLHELP32_COMPAT_H */ 27 | -------------------------------------------------------------------------------- /include/winreg_compat.h: -------------------------------------------------------------------------------- 1 | #ifndef WINREG_COMPAT_H 2 | #define WINREG_COMPAT_H 3 | 4 | #if defined(x86_64_HOST_ARCH) || __GLASGOW_HASKELL__ > 708 5 | # 6 | #else 7 | #define RRF_RT_REG_NONE 0x00000001 8 | #define RRF_RT_REG_SZ 0x00000002 9 | #define RRF_RT_REG_EXPAND_SZ 0x00000004 10 | #define RRF_RT_REG_BINARY 0x00000008 11 | #define RRF_RT_REG_DWORD 0x00000010 12 | #define RRF_RT_REG_MULTI_SZ 0x00000020 13 | #define RRF_RT_REG_QWORD 0x00000040 14 | 15 | #define RRF_RT_DWORD (RRF_RT_REG_BINARY | RRF_RT_REG_DWORD) 16 | #define RRF_RT_QWORD (RRF_RT_REG_BINARY | RRF_RT_REG_QWORD) 17 | #define RRF_RT_ANY 0x0000ffff 18 | 19 | #define RRF_NOEXPAND 0x10000000 20 | #define RRF_ZEROONFAILURE 0x20000000 21 | 22 | #endif 23 | 24 | #ifndef RRF_SUBKEY_WOW6464KEY 25 | #define RRF_SUBKEY_WOW6464KEY 0x00010000 26 | #endif 27 | 28 | #ifndef RRF_SUBKEY_WOW6432KEY 29 | #define RRF_SUBKEY_WOW6432KEY 0x00020000 30 | #endif 31 | 32 | #endif /* WINREG_COMPAT_H */ 33 | -------------------------------------------------------------------------------- /System/Win32/Path/Internal.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Win32.Path.Internal 9 | -- Copyright : (c) Tamar Christina, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Tamar Christina 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module System.Win32.Path.Internal where 21 | 22 | import System.Win32.Types 23 | 24 | ##include "windows_cconv.h" 25 | 26 | #include 27 | 28 | foreign import WINDOWS_CCONV unsafe "Shlwapi.h PathRelativePathToW" 29 | c_pathRelativePathTo :: LPTSTR -> LPCTSTR -> DWORD -> LPCTSTR -> DWORD -> IO UINT 30 | -------------------------------------------------------------------------------- /cbits/errors.c: -------------------------------------------------------------------------------- 1 | #define UNICODE 2 | #include 3 | #include 4 | #include 5 | #include "errors.h" 6 | 7 | /* There's two ways we can generate error messages - with different tradeoffs: 8 | * If we do a function call, we have to use a static buffer. 9 | * If we use a macro and ANSI C's string splicing, we have to use constant 10 | * strings - and accept a certain amount of overhead from inserting the 11 | * boilerplate text. 12 | * 13 | * Why the concern about performance? Error messages are only generated 14 | * in exceptional situations -- sof 9/98 15 | * 16 | * sof 9/98 : Removed use of non-standard (and wimpy :-) snprintf(). 17 | */ 18 | 19 | LPTSTR getErrorMessage(DWORD err) 20 | { 21 | LPTSTR what; 22 | 23 | FormatMessage( 24 | (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER) , 25 | NULL, 26 | err, 27 | MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */ 28 | (LPTSTR) &what, 29 | 0, 30 | NULL 31 | ); 32 | return what; 33 | } 34 | -------------------------------------------------------------------------------- /System/Win32/HardLink/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.HardLink.Internal 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Handling hard link using Win32 API. [NTFS only] 12 | 13 | Note: You should worry about file system type when use this module's function in your application: 14 | 15 | * NTFS only supprts this functionality. 16 | 17 | * ReFS doesn't support hard link currently. 18 | -} 19 | module System.Win32.HardLink.Internal where 20 | 21 | import System.Win32.File ( LPSECURITY_ATTRIBUTES ) 22 | import System.Win32.String ( LPCTSTR ) 23 | import System.Win32.Types ( BOOL ) 24 | 25 | #include "windows_cconv.h" 26 | 27 | foreign import WINDOWS_CCONV unsafe "windows.h CreateHardLinkW" 28 | c_CreateHardLink :: LPCTSTR -- ^ Hard link name 29 | -> LPCTSTR -- ^ Target file path 30 | -> LPSECURITY_ATTRIBUTES -- ^ This parameter is reserved. You should pass just /nullPtr/. 31 | -> IO BOOL 32 | -------------------------------------------------------------------------------- /.github/PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | ## Description 4 | 5 | 6 | ## Motivation and Context 7 | 8 | 9 | 10 | ## Types of changes 11 | 12 | - [ ] Bug fix (non-breaking change which fixes an issue) 13 | - [ ] New feature (non-breaking change which adds functionality) 14 | - [ ] Breaking change (fix or feature that would cause existing functionality to change) 15 | 16 | ## Checklist: 17 | 18 | 19 | - [ ] My code follows the code style of this project. 20 | - [ ] I have updated the documentation accordingly. 21 | - [ ] I have not added a new Haskell dependency. 22 | - [ ] I have included a changelog entry. 23 | - [ ] I have not modified the version of the package in `Win32.cabal`. 24 | -------------------------------------------------------------------------------- /include/winternl_compat.h: -------------------------------------------------------------------------------- 1 | #ifndef WINTERNL_COMPAT_H 2 | #define WINTERNL_COMPAT_H 3 | 4 | /* 5 | * winternl.h is not included in MinGW, which was shipped with the 32-bit 6 | * Windows version of GHC prior to the 7.10.3 release. 7 | */ 8 | #if defined(x86_64_HOST_ARCH) || \ 9 | __GLASGOW_HASKELL__ >= 711 || \ 10 | (__GLASGOW_HASKELL__ == 710 && \ 11 | defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \ 12 | __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2) 13 | # include 14 | #else 15 | // Some declarations from winternl.h that we need in Win32 16 | # include 17 | 18 | typedef enum _OBJECT_INFORMATION_CLASS { 19 | ObjectBasicInformation, 20 | ObjectNameInformation, 21 | ObjectTypeInformation, 22 | ObjectAllInformation, 23 | ObjectDataInformation 24 | } OBJECT_INFORMATION_CLASS, *POBJECT_INFORMATION_CLASS; 25 | 26 | typedef LONG NTSTATUS, *PNTSTATUS; 27 | 28 | typedef struct _UNICODE_STRING { 29 | USHORT Length; 30 | USHORT MaximumLength; 31 | PWSTR Buffer; 32 | } UNICODE_STRING, *PUNICODE_STRING; 33 | 34 | typedef struct _OBJECT_NAME_INFORMATION { 35 | UNICODE_STRING Name; 36 | } OBJECT_NAME_INFORMATION, *POBJECT_NAME_INFORMATION; 37 | #endif 38 | 39 | #endif /* WINTERNL_COMPAT_H */ 40 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/DebugApi.hsc: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Win32.WindowsString.DebugApi 4 | -- Copyright : (c) Esa Ilari Vuokko, 2006 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : Esa Ilari Vuokko 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- A collection of FFI declarations for using Windows DebugApi. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | module System.Win32.WindowsString.DebugApi 15 | ( module System.Win32.WindowsString.DebugApi 16 | , module System.Win32.DebugApi 17 | ) where 18 | 19 | import System.Win32.DebugApi.Internal 20 | import System.Win32.DebugApi hiding (outputDebugString) 21 | import System.Win32.WindowsString.Types ( withTString ) 22 | import System.OsString.Windows 23 | 24 | ##include "windows_cconv.h" 25 | #include "windows.h" 26 | 27 | 28 | -------------------------------------------------------------------------- 29 | -- On process being debugged 30 | 31 | outputDebugString :: WindowsString -> IO () 32 | outputDebugString s = withTString s $ \c_s -> c_OutputDebugString c_s 33 | 34 | -------------------------------------------------------------------------------- /include/HsWin32.h: -------------------------------------------------------------------------------- 1 | #ifndef __HSWIN32_H 2 | #define __HSWIN32_H 3 | 4 | #define UNICODE 5 | #include 6 | 7 | #ifndef INLINE 8 | # if defined(_MSC_VER) 9 | # define INLINE extern __inline 10 | # else 11 | # define INLINE extern inline 12 | # endif 13 | #endif 14 | 15 | INLINE UINT_PTR castPtrToUINTPtr(void *p) { return (UINT_PTR)p; } 16 | INLINE void *castUINTPtrToPtr(UINT_PTR n) { return (void *)n; } 17 | INLINE WORD hIWORD(DWORD w) { return HIWORD(w); } 18 | INLINE WORD lOWORD(DWORD w) { return LOWORD(w); } 19 | 20 | INLINE LANGID prim_LANGIDFROMLCID(LCID id) { 21 | return LANGIDFROMLCID(id); 22 | } 23 | INLINE LANGID prim_MAKELANGID(LANGID primary, LANGID sub) { 24 | return MAKELANGID(primary, sub); 25 | } 26 | INLINE LCID prim_MAKELCID(LANGID id, WORD sort) { 27 | return MAKELCID(id, sort); 28 | } 29 | INLINE LANGID prim_PRIMARYLANGID(LANGID id) { 30 | return PRIMARYLANGID(id); 31 | } 32 | INLINE LANGID prim_SUBLANGID(LCID id) { 33 | return SUBLANGID(id); 34 | } 35 | INLINE WORD prim_SORTIDFROMLCID(LCID id) { 36 | return SORTIDFROMLCID(id); 37 | } 38 | 39 | void UnmapViewOfFileFinaliser(void *); 40 | 41 | void CloseHandleFinaliser(HANDLE); 42 | 43 | void FreeLibraryFinaliser(HMODULE); 44 | 45 | void DeleteObjectFinaliser(HGDIOBJ); 46 | 47 | #endif /* __HSWIN32_H */ 48 | -------------------------------------------------------------------------------- /System/Win32/Thread.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.Thread 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | This modules provides just thread control APIs. 12 | This modules doesn't provide thread register control APIs. Because these APIs are used for Debugging. 13 | -} 14 | module System.Win32.Thread 15 | ( THANDLE, TID 16 | , getCurrentThread 17 | , suspendThread 18 | , resumeThread 19 | , withSuspendedThread 20 | , getThreadId 21 | , getCurrentThreadId 22 | ) where 23 | 24 | import System.Win32.DebugApi 25 | import System.Win32.Types ( failIfZero ) 26 | 27 | #include "windows_cconv.h" 28 | 29 | getThreadId :: THANDLE -> IO TID 30 | getThreadId = failIfZero "GetThreadId" . c_GetThreadId 31 | 32 | getCurrentThreadId :: IO TID 33 | getCurrentThreadId = failIfZero "GetThreadId" c_GetCurrentThreadId 34 | 35 | foreign import WINDOWS_CCONV "windows.h GetCurrentThread" 36 | getCurrentThread :: IO THANDLE 37 | 38 | foreign import WINDOWS_CCONV "windows.h GetThreadId" 39 | c_GetThreadId :: THANDLE -> IO TID 40 | 41 | foreign import WINDOWS_CCONV "windows.h GetCurrentThreadId" 42 | c_GetCurrentThreadId :: IO TID 43 | -------------------------------------------------------------------------------- /Graphics/Win32/Window/AnimateWindow.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : Graphics.Win32.Window.AnimateWindow 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Provide AnimatedWindow function and flags. 12 | -} 13 | module Graphics.Win32.Window.AnimateWindow where 14 | import Graphics.Win32.GDI.Types ( HWND ) 15 | import System.Win32.Types ( DWORD, BOOL, failIfFalse_ ) 16 | 17 | #include 18 | ##include "windows_cconv.h" 19 | #include "winuser_compat.h" 20 | 21 | type AnimateWindowType = DWORD 22 | 23 | #{enum AnimateWindowType, 24 | , aW_SLIDE = AW_SLIDE 25 | , aW_ACTIVATE = AW_ACTIVATE 26 | , aW_BLEND = AW_BLEND 27 | , aW_HIDE = AW_HIDE 28 | , aW_CENTER = AW_CENTER 29 | , aW_HOR_POSITIVE = AW_HOR_POSITIVE 30 | , aW_HOR_NEGATIVE = AW_HOR_NEGATIVE 31 | , aW_VER_POSITIVE = AW_VER_POSITIVE 32 | , aW_VER_NEGATIVE = AW_VER_NEGATIVE 33 | } 34 | 35 | animateWindow :: HWND -> DWORD -> AnimateWindowType -> IO () 36 | animateWindow hwnd dwTime dwFlags 37 | = failIfFalse_ "AnimateWindow" $ c_AnimateWindow hwnd dwTime dwFlags 38 | 39 | foreign import WINDOWS_CCONV "windows.h AnimateWindow" 40 | c_AnimateWindow :: HWND -> DWORD -> AnimateWindowType -> IO BOOL 41 | -------------------------------------------------------------------------------- /include/HsGDI.h: -------------------------------------------------------------------------------- 1 | #ifndef __HSGDI_H 2 | #define __HSGDI_H 3 | 4 | #define UNICODE 5 | #include 6 | 7 | #ifndef INLINE 8 | # if defined(_MSC_VER) 9 | # define INLINE extern __inline 10 | # else 11 | # define INLINE extern inline 12 | # endif 13 | #endif 14 | 15 | INLINE COLORREF rgb(BYTE r, BYTE g, BYTE b) { return RGB(r, g, b); } 16 | INLINE BYTE getRValue(COLORREF color) { return GetRValue(color); } 17 | INLINE BYTE getGValue(COLORREF color) { return GetGValue(color); } 18 | INLINE BYTE getBValue(COLORREF color) { return GetBValue(color); } 19 | 20 | INLINE COLORREF pALETTERGB(BYTE r, BYTE g, BYTE b) { 21 | return PALETTERGB(r, g, b); 22 | } 23 | INLINE COLORREF pALETTEINDEX(WORD w) { 24 | return PALETTEINDEX(w); 25 | } 26 | 27 | #ifdef __WINE_WINDOWS_H 28 | INLINE UINT mAKEROP4(UINT op1, UINT op2) { return 0; } 29 | #else 30 | INLINE UINT mAKEROP4(UINT op1, UINT op2) { return MAKEROP4(op1, op2); } 31 | #endif 32 | 33 | INLINE UINT prim_MenuItemFromPoint(HWND wnd, HMENU menu, LPPOINT p_pt) { 34 | return MenuItemFromPoint(wnd, menu, *p_pt); 35 | } 36 | INLINE HWND prim_ChildWindowFromPoint(HWND parent, LPPOINT p_pt) { 37 | return ChildWindowFromPoint(parent, *p_pt); 38 | } 39 | INLINE HWND prim_ChildWindowFromPointEx(HWND parent, LPPOINT p_pt, UINT flags) { 40 | return ChildWindowFromPointEx(parent, *p_pt, flags); 41 | } 42 | 43 | INLINE INT SelectObjectInt(HANDLE h) { 44 | return DeleteObject(h); 45 | } 46 | 47 | #endif /* __HSGDI_H */ 48 | -------------------------------------------------------------------------------- /System/Win32/Console/HWND.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : System.Win32.Console.HWND 3 | Copyright : 2009 Balazs Komuves, 2013 shelarcy 4 | License : BSD-style 5 | 6 | Maintainer : shelarcy@gmail.com 7 | Stability : Provisional 8 | Portability : Non-portable (Win32 API) 9 | 10 | Get the handle of the current console window. 11 | -} 12 | module System.Win32.Console.HWND (getConsoleHWND) where 13 | import Control.Concurrent ( threadDelay ) 14 | import Control.Exception ( bracket ) 15 | import Foreign.Ptr ( nullPtr ) 16 | import Graphics.Win32.Window ( c_FindWindow ) 17 | import Graphics.Win32.GDI.Types ( HWND ) 18 | import System.Win32.Console.Title ( getConsoleTitle, setConsoleTitle ) 19 | import System.Win32.Process ( getCurrentProcessId ) 20 | import System.Win32.String ( withTString ) 21 | import System.Win32.Time ( getTickCount ) 22 | 23 | -- | Get the handle of the current console window by using window's title. 24 | -- See: 25 | getConsoleHWND :: IO HWND 26 | getConsoleHWND 27 | = bracket getConsoleTitle setConsoleTitle $ \_ -> do 28 | time <- getTickCount 29 | pid <- getCurrentProcessId 30 | let unique = show time ++ show pid 31 | setConsoleTitle unique 32 | threadDelay (42*1000) 33 | withTString unique $ \punique -> 34 | c_FindWindow nullPtr punique 35 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | The `Win32` Package 2 | ===================== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/Win32.svg)](https://hackage.haskell.org/package/Win32) [![PyPI](https://img.shields.io/pypi/l/Django.svg)]() [![Windows build status](https://ci.appveyor.com/api/projects/status/b8dfn205r791rxw5/branch/master?svg=true)](https://ci.appveyor.com/project/Mistuke/win32-5ec4k/branch/master) 5 | 6 | See [`Win32` on Hackage](http://hackage.haskell.org/package/Win32) for 7 | more information. 8 | 9 | Installing from Git 10 | ------------------- 11 | 12 | This package requires no special installation instructions. 13 | 14 | To install use `cabal install` 15 | 16 | Documentation 17 | ------------------- 18 | This library is just a direct binding to Windows API calls and 19 | as such contains no documentation. The documentation for functions 20 | can be found in the equivalently named functions on MSDN 21 | https://msdn.microsoft.com/library/windows/desktop/hh920508.aspx 22 | 23 | Getting Started 24 | --------------- 25 | The `Win32` library is a core GHC library and as such aims to have an 26 | as little as possible footprint when it comes to dependencies. 27 | 28 | When submitting new requests think hard if any new `Haskell` dependencies are 29 | actually needed. (note that this does not apply to `C` dependencies.) 30 | 31 | The best way to get started is using `cabal new-build` and `cabal sandboxes`: 32 | 33 | ``` 34 | git clone git@github.com:haskell/win32.git 35 | cd win32 36 | cabal v2-repl 37 | ``` 38 | -------------------------------------------------------------------------------- /cbits/ellipse.c: -------------------------------------------------------------------------------- 1 | #define UNICODE 2 | #include 3 | #include 4 | 5 | /* 6 | * Rotatable Ellipse hack 7 | * 8 | * Win95 (Win32?) doesn't support rotating ellipses - so we 9 | * implement them with polygons. 10 | * 11 | * We use a fixed number of edges rather than varying the number 12 | * according to the radius of the ellipse. 13 | * If anyone feels like improving the code (to vary the number), 14 | * they should place a fixed upper bound on the number of edges 15 | * since it takes a relatively long time to draw 1000 edges. 16 | */ 17 | 18 | int transformedEllipse( 19 | HDC hdc, LONG x0, LONG y0, LONG x1, LONG y1, LONG x2, LONG y2) { 20 | static BOOL firstTime = 1; 21 | static double sins[20]; 22 | static double coss[20]; 23 | 24 | int i; 25 | POINT pts[20]; 26 | 27 | double x = (x1 + x2) / 2; /* centre of parallelogram */ 28 | double y = (y1 + y2) / 2; 29 | 30 | double dx1 = (x1 - x0) / 2; /* distance to corners from centre */ 31 | double dy1 = (y1 - y0) / 2; 32 | double dx2 = (x2 - x0) / 2; 33 | double dy2 = (y2 - y0) / 2; 34 | 35 | if (firstTime) { 36 | double a = 0.0; 37 | double da = 2.0*3.14159 / 20; 38 | for (i=0; i < 20; ++i, a+=da) { 39 | sins[i] = sin(a); 40 | coss[i] = cos(a); 41 | } 42 | firstTime = 0; 43 | } 44 | for(i=0; i < 20; ++i) { 45 | double c = coss[i]; 46 | double s = sins[i]; 47 | pts[i].x = x + c*dx1 + s*dx2; 48 | pts[i].y = y + c*dy1 + s*dy2; 49 | } 50 | return Polygon(hdc,pts,20); 51 | } 52 | -------------------------------------------------------------------------------- /.github/workflows/validate.yml: -------------------------------------------------------------------------------- 1 | name: Validate 2 | 3 | # See: https://docs.github.com/en/actions/reference/workflow-syntax-for-github-actions#concurrency. 4 | concurrency: 5 | group: ${{ github.ref }}-${{ github.workflow }} 6 | cancel-in-progress: true 7 | 8 | on: 9 | - push 10 | - pull_request 11 | 12 | jobs: 13 | validate: 14 | name: Validate ${{ matrix.sys.os }} ghc-${{ matrix.ghc }} 15 | runs-on: ${{ matrix.sys.os }} 16 | strategy: 17 | fail-fast: false 18 | matrix: 19 | sys: 20 | - { os: windows-latest, shell: "C:/msys64/usr/bin/bash.exe -e {0}" } 21 | ghc: 22 | [ 23 | "9.12.2", 24 | "9.10.1", 25 | "9.8.4", 26 | "9.6.7", 27 | "9.4.8", 28 | "9.2.8", 29 | "9.0.2", 30 | "8.10.7", 31 | "8.8.4", 32 | "8.6.5", 33 | ] 34 | defaults: 35 | run: 36 | shell: ${{ matrix.sys.shell }} 37 | steps: 38 | - name: "WIN: Setup TMP environment variable" 39 | run: | 40 | echo "TMP=${{ runner.temp }}" >> "$GITHUB_ENV" 41 | 42 | - uses: actions/checkout@v4 43 | 44 | - uses: haskell-actions/setup@v2 45 | id: setup-haskell 46 | with: 47 | ghc-version: ${{ matrix.ghc }} 48 | cabal-version: 3.12.1.0 49 | ghcup-release-channel: https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml 50 | 51 | - name: Validate build 52 | run: cabal build 53 | -------------------------------------------------------------------------------- /System/Win32/Console/Title.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.Console.Title 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Get/Set the title for the current console window. 12 | -} 13 | module System.Win32.Console.Title 14 | ( getConsoleTitle 15 | , setConsoleTitle 16 | ) where 17 | 18 | import System.Win32.String ( LPTSTR, LPCTSTR 19 | , withTStringBufferLen, withTString, peekTStringLen ) 20 | import System.Win32.Types ( BOOL, failIfFalse_, failIfZero ) 21 | import System.Win32.Word ( DWORD ) 22 | 23 | #include 24 | ##include "windows_cconv.h" 25 | 26 | getConsoleTitle :: IO String 27 | getConsoleTitle = 28 | withTStringBufferLen maxLength $ \(buf, len) -> do 29 | len' <- failIfZero "GetConsoleTitle" 30 | $ c_GetConsoleTitle buf (fromIntegral len) 31 | peekTStringLen (buf, (fromIntegral len')) 32 | where 33 | maxLength = #const MAX_PATH 34 | 35 | setConsoleTitle :: String -> IO () 36 | setConsoleTitle title = 37 | withTString title $ \buf -> 38 | failIfFalse_ (unwords ["SetConsoleTitle", title]) 39 | $ c_SetConsoleTitle buf 40 | 41 | foreign import WINDOWS_CCONV "windows.h GetConsoleTitleW" 42 | c_GetConsoleTitle :: LPTSTR -> DWORD -> IO DWORD 43 | 44 | foreign import WINDOWS_CCONV "windows.h SetConsoleTitleW" 45 | c_SetConsoleTitle :: LPCTSTR -> IO BOOL 46 | 47 | -------------------------------------------------------------------------------- /System/Win32/Shell/Internal.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Win32.Shell.Internal 9 | -- Copyright : (c) The University of Glasgow 2009 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- Win32 stuff from shell32.dll 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module System.Win32.Shell.Internal ( 21 | c_SHGetFolderPath 22 | , raiseUnsupported 23 | ) where 24 | 25 | import System.Win32.Types 26 | import Graphics.Win32.GDI.Types (HWND) 27 | 28 | import Foreign.C 29 | import System.IO.Error 30 | 31 | ##include "windows_cconv.h" 32 | 33 | -- for SHGetFolderPath stuff 34 | #define _WIN32_IE 0x500 35 | #include 36 | #include 37 | 38 | ---------------------------------------------------------------- 39 | -- SHGetFolderPath 40 | -- 41 | -- XXX: this is deprecated in Vista and later 42 | ---------------------------------------------------------------- 43 | 44 | raiseUnsupported :: String -> IO () 45 | raiseUnsupported loc = 46 | ioError (ioeSetErrorString (mkIOError illegalOperationErrorType loc Nothing Nothing) "unsupported operation") 47 | 48 | foreign import WINDOWS_CCONV unsafe "SHGetFolderPathW" 49 | c_SHGetFolderPath :: HWND -> CInt -> HANDLE -> DWORD -> LPTSTR 50 | -> IO HRESULT 51 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 1997-2003, Alastair Reid 2 | Copyright (c) 2006, Esa Ilari Vuokko 3 | Copyright (c) 2012-2013, shelarcy 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | - Redistributions of source code must retain the above copyright notice, 10 | this list of conditions and the following disclaimer. 11 | 12 | - Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | - Neither names of the copyright holders nor the names of the contributors 17 | may be used to endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 22 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 23 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 25 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 27 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 31 | DAMAGE. 32 | -------------------------------------------------------------------------------- /Media/Win32.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : Media.Win32 4 | Copyright : 2012 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Multimedia API. TODO: provide more functions ... 12 | -} 13 | 14 | module Media.Win32 15 | ( module Media.Win32 16 | ) where 17 | import Control.Monad ( unless ) 18 | import Prelude hiding ( ioError, userError ) 19 | import System.IO.Error ( ioError, userError ) 20 | import System.Win32.Encoding ( encodeMultiByte, getCurrentCodePage ) 21 | import System.Win32.Types 22 | import System.Win32.String ( withTStringBufferLen ) 23 | 24 | type MCIERROR = DWORD 25 | 26 | #include "windows_cconv.h" 27 | 28 | mciSendString :: String -> IO () 29 | mciSendString cmd 30 | = withTString cmd $ \sendCmd -> do 31 | err <- c_mciSendString sendCmd nullPtr 0 nullPtr 32 | unless (err == 0) 33 | $ mciGetErrorString err 34 | 35 | foreign import WINDOWS_CCONV safe "windows.h mciSendStringW" 36 | c_mciSendString :: LPCTSTR -> LPTSTR -> UINT -> HANDLE -> IO MCIERROR 37 | 38 | mciGetErrorString :: MCIERROR -> IO () 39 | mciGetErrorString err 40 | = withTStringBufferLen 256 $ \(cstr, len) -> do 41 | failIfFalse_ (unwords ["mciGetErrorString", show err]) $ 42 | c_mciGetErrorString err cstr $ fromIntegral len 43 | msg <- peekTString cstr 44 | cp <- getCurrentCodePage 45 | ioError $ userError $ encodeMultiByte cp msg 46 | 47 | foreign import WINDOWS_CCONV unsafe "windows.h mciGetErrorStringW" 48 | c_mciGetErrorString :: MCIERROR -> LPTSTR -> UINT -> IO BOOL 49 | -------------------------------------------------------------------------------- /Graphics/Win32/GDI/Palette.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Graphics.Win32.GDI.Palette 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Graphics.Win32.GDI.Palette where 21 | 22 | import System.Win32.Types 23 | import Graphics.Win32.GDI.Types 24 | 25 | ##include "windows_cconv.h" 26 | #include 27 | 28 | ---------------------------------------------------------------- 29 | -- Palettes 30 | ---------------------------------------------------------------- 31 | 32 | type StockPalette = WORD 33 | 34 | #{enum StockPalette, 35 | , dEFAULT_PALETTE = DEFAULT_PALETTE 36 | } 37 | 38 | getStockPalette :: StockPalette -> IO HPALETTE 39 | getStockPalette sp = 40 | failIfNull "GetStockPalette" $ c_GetStockPalette sp 41 | foreign import WINDOWS_CCONV unsafe "windows.h GetStockObject" 42 | c_GetStockPalette :: StockPalette -> IO HPALETTE 43 | 44 | deletePalette :: HPALETTE -> IO () 45 | deletePalette p = 46 | failIfFalse_ "DeletePalette" $ c_DeletePalette p 47 | foreign import WINDOWS_CCONV unsafe "windows.h DeleteObject" 48 | c_DeletePalette :: HPALETTE -> IO Bool 49 | 50 | ---------------------------------------------------------------- 51 | -- End 52 | ---------------------------------------------------------------- 53 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/HardLink.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.HardLink 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Handling hard link using Win32 API. [NTFS only] 12 | 13 | Note: You should worry about file system type when use this module's function in your application: 14 | 15 | * NTFS only supprts this functionality. 16 | 17 | * ReFS doesn't support hard link currently. 18 | -} 19 | module System.Win32.WindowsString.HardLink 20 | ( createHardLink 21 | , createHardLink' 22 | ) where 23 | 24 | import System.Win32.HardLink.Internal 25 | import System.Win32.WindowsString.File ( failIfFalseWithRetry_ ) 26 | import System.Win32.WindowsString.String ( withTString ) 27 | import System.Win32.WindowsString.Types ( nullPtr ) 28 | import System.OsPath.Windows 29 | 30 | #include "windows_cconv.h" 31 | 32 | -- | NOTE: createHardLink is /flipped arguments/ to provide compatibility for Unix. 33 | -- 34 | -- If you want to create hard link by Windows way, use 'createHardLink'' instead. 35 | createHardLink :: WindowsPath -- ^ Target file path 36 | -> WindowsPath -- ^ Hard link name 37 | -> IO () 38 | createHardLink = flip createHardLink' 39 | 40 | createHardLink' :: WindowsPath -- ^ Hard link name 41 | -> WindowsPath -- ^ Target file path 42 | -> IO () 43 | createHardLink' link target = 44 | withTString target $ \c_target -> 45 | withTString link $ \c_link -> 46 | failIfFalseWithRetry_ (unwords ["CreateHardLinkW",show link,show target]) $ 47 | c_CreateHardLink c_link c_target nullPtr 48 | -------------------------------------------------------------------------------- /Graphics/Win32/Window/ForegroundWindow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : Graphics.Win32.Window.ForegroundWindow 4 | Copyright : 2012 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Get/Set Foreground Window. 12 | -} 13 | 14 | module Graphics.Win32.Window.ForegroundWindow 15 | ( getForegroundWindow 16 | , setForegroundWindow 17 | , c_SetForegroundWindow 18 | , allowSetForegroundWindow 19 | , c_AllowSetForegroundWindow 20 | ) where 21 | 22 | import Control.Monad ( void ) 23 | import Graphics.Win32.GDI.Types ( HWND ) 24 | import Graphics.Win32.Window ( getForegroundWindow ) 25 | import System.Win32.Process ( ProcessId ) 26 | 27 | #include "windows_cconv.h" 28 | 29 | ---------------------------------------------------------------- 30 | -- | Setting Window to Foreground. 31 | -- See: , 32 | -- . 33 | ---------------------------------------------------------------- 34 | setForegroundWindow :: HWND -> IO Bool 35 | setForegroundWindow = c_SetForegroundWindow 36 | 37 | foreign import WINDOWS_CCONV safe "windows.h SetForegroundWindow" 38 | c_SetForegroundWindow :: HWND -> IO Bool 39 | 40 | ---------------------------------------------------------------- 41 | -- | Allow other process to set Window to Foreground 42 | -- by using 'setForegroundWindow' function. 43 | allowSetForegroundWindow :: ProcessId -> IO () 44 | allowSetForegroundWindow = void . c_AllowSetForegroundWindow 45 | 46 | foreign import WINDOWS_CCONV safe "windows.h AllowSetForegroundWindow" 47 | c_AllowSetForegroundWindow :: ProcessId -> IO Bool 48 | -------------------------------------------------------------------------------- /Graphics/Win32/Window/PostMessage.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : Graphics.Win32.Window.PostMessage 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Provide PostMessage function and friends. 12 | -} 13 | module Graphics.Win32.Window.PostMessage where 14 | 15 | import Foreign.C.Types ( CIntPtr(..) ) 16 | import Graphics.Win32.GDI.Types ( HWND, MbHWND ) 17 | import Graphics.Win32.Message ( WindowMessage ) 18 | import System.Win32.Types ( DWORD, WPARAM, LPARAM, BOOL 19 | , maybePtr, castUINTPtrToPtr, failIfFalse_ ) 20 | 21 | #include 22 | ##include "windows_cconv.h" 23 | 24 | postMessage :: MbHWND -> WindowMessage -> WPARAM -> LPARAM -> IO () 25 | postMessage mb_wnd msg w l = 26 | failIfFalse_ (unwords ["PostMessage", show mb_wnd, show msg, show w, show l]) $ 27 | c_PostMessage (maybePtr mb_wnd) msg w l 28 | 29 | foreign import WINDOWS_CCONV "windows.h PostMessageW" 30 | c_PostMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO BOOL 31 | 32 | foreign import WINDOWS_CCONV "windows.h PostQuitMessage" 33 | postQuitMessage :: Int -> IO () 34 | 35 | postThreadMessage :: DWORD -> WindowMessage -> WPARAM -> LPARAM -> IO () 36 | postThreadMessage tId msg w l = 37 | failIfFalse_ (unwords ["PostThreadMessage", show tId, show msg, show w, show l]) $ 38 | c_PostThreadMessage tId msg w l 39 | 40 | foreign import WINDOWS_CCONV "windows.h PostThreadMessageW" 41 | c_PostThreadMessage :: DWORD -> WindowMessage -> WPARAM -> LPARAM -> IO BOOL 42 | 43 | #{enum HWND, castUINTPtrToPtr 44 | , hWND_BROADCAST = (UINT_PTR)HWND_BROADCAST 45 | } 46 | 47 | foreign import WINDOWS_CCONV "windows.h InSendMessage" 48 | inSendMessage :: IO Bool 49 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/Shell.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : System.Win32.WindowsString.Shell 5 | -- Copyright : (c) The University of Glasgow 2009 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : Esa Ilari Vuokko 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- Win32 stuff from shell32.dll 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module System.Win32.WindowsString.Shell ( 17 | sHGetFolderPath, 18 | CSIDL, 19 | cSIDL_PROFILE, 20 | cSIDL_APPDATA, 21 | cSIDL_WINDOWS, 22 | cSIDL_PERSONAL, 23 | cSIDL_LOCAL_APPDATA, 24 | cSIDL_DESKTOPDIRECTORY, 25 | cSIDL_PROGRAM_FILES, 26 | SHGetFolderPathFlags, 27 | sHGFP_TYPE_CURRENT, 28 | sHGFP_TYPE_DEFAULT 29 | ) where 30 | 31 | import System.OsString.Windows (WindowsString) 32 | import System.Win32.Shell.Internal 33 | import System.Win32.Shell hiding (sHGetFolderPath) 34 | import System.Win32.WindowsString.Types 35 | import Graphics.Win32.GDI.Types (HWND) 36 | 37 | import Foreign 38 | import Control.Monad 39 | 40 | ##include "windows_cconv.h" 41 | 42 | -- for SHGetFolderPath stuff 43 | #define _WIN32_IE 0x500 44 | #include 45 | #include 46 | 47 | ---------------------------------------------------------------- 48 | -- SHGetFolderPath 49 | -- 50 | -- XXX: this is deprecated in Vista and later 51 | ---------------------------------------------------------------- 52 | 53 | 54 | sHGetFolderPath :: HWND -> CSIDL -> HANDLE -> SHGetFolderPathFlags -> IO WindowsString 55 | sHGetFolderPath hwnd csidl hdl flags = 56 | allocaBytes ((#const MAX_PATH) * (#size TCHAR)) $ \pstr -> do 57 | r <- c_SHGetFolderPath hwnd csidl hdl flags pstr 58 | when (r < 0) $ raiseUnsupported "sHGetFolderPath" 59 | peekTString pstr 60 | -------------------------------------------------------------------------------- /Graphics/Win32/GDI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Graphics.Win32.GDI 5 | -- Copyright : (c) Alastair Reid, 1997-2003 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : Esa Ilari Vuokko 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- An interface to the Microsoft Windows graphics device interface (GDI). 13 | -- See under /Graphics and Multimedia/ 14 | -- for more details of the underlying library. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | {-# OPTIONS_GHC -w #-} 19 | -- The above warning suppression flag is a temporary kludge. 20 | -- While working on this module you are encouraged to remove it and fix 21 | -- any warnings in the module. See 22 | -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings 23 | -- for details 24 | 25 | module Graphics.Win32.GDI ( 26 | module Graphics.Win32.GDI.Bitmap, 27 | module Graphics.Win32.GDI.Brush, 28 | module Graphics.Win32.GDI.Clip, 29 | module Graphics.Win32.GDI.Font, 30 | module Graphics.Win32.GDI.Graphics2D, 31 | module Graphics.Win32.GDI.HDC, 32 | module Graphics.Win32.GDI.Palette, 33 | module Graphics.Win32.GDI.Path, 34 | module Graphics.Win32.GDI.Pen, 35 | module Graphics.Win32.GDI.Region, 36 | module Graphics.Win32.GDI.Types 37 | ) where 38 | 39 | import Graphics.Win32.GDI.Bitmap 40 | import Graphics.Win32.GDI.Brush 41 | import Graphics.Win32.GDI.Clip 42 | import Graphics.Win32.GDI.Font 43 | import Graphics.Win32.GDI.Graphics2D 44 | import Graphics.Win32.GDI.HDC 45 | import Graphics.Win32.GDI.Palette 46 | import Graphics.Win32.GDI.Path 47 | import Graphics.Win32.GDI.Pen 48 | import Graphics.Win32.GDI.Region 49 | import Graphics.Win32.GDI.Types 50 | -------------------------------------------------------------------------------- /System/Win32/String.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : System.Win32.String 3 | Copyright : 2013 shelarcy 4 | License : BSD-style 5 | 6 | Maintainer : shelarcy@gmail.com 7 | Stability : Provisional 8 | Portability : Non-portable (Win32 API) 9 | 10 | Utilities for primitive marshalling of Windows' C strings. 11 | -} 12 | module System.Win32.String 13 | ( LPSTR, LPCSTR, LPWSTR, LPCWSTR 14 | , TCHAR, LPTSTR, LPCTSTR, LPCTSTR_ 15 | , withTString, withTStringLen, peekTString, peekTStringLen 16 | , newTString 17 | , withTStringBuffer, withTStringBufferLen 18 | ) where 19 | import System.Win32.Types 20 | 21 | -- | Marshal a dummy Haskell string into a NUL terminated C wide string 22 | -- using temporary storage. 23 | -- 24 | -- * the Haskell string is created by length parameter. And the Haskell 25 | -- string contains /only/ NUL characters. 26 | -- 27 | -- * the memory is freed when the subcomputation terminates (either 28 | -- normally or via an exception), so the pointer to the temporary 29 | -- storage must /not/ be used after this. 30 | -- 31 | withTStringBuffer :: Int -> (LPTSTR -> IO a) -> IO a 32 | withTStringBuffer maxLength 33 | = let dummyBuffer = replicate maxLength '\0' 34 | in withTString dummyBuffer 35 | 36 | -- | Marshal a dummy Haskell string into a C wide string (i.e. wide 37 | -- character array) in temporary storage, with explicit length 38 | -- information. 39 | -- 40 | -- * the Haskell string is created by length parameter. And the Haskell 41 | -- string contains /only/ NUL characters. 42 | -- 43 | -- * the memory is freed when the subcomputation terminates (either 44 | -- normally or via an exception), so the pointer to the temporary 45 | -- storage must /not/ be used after this. 46 | -- 47 | withTStringBufferLen :: Int -> ((LPTSTR, Int) -> IO a) -> IO a 48 | withTStringBufferLen maxLength 49 | = let dummyBuffer = replicate maxLength '\0' 50 | in withTStringLen dummyBuffer 51 | 52 | -------------------------------------------------------------------------------- /System/Win32/Automation/Input/Key.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.Automation.Input.Key 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Keyboard input events 12 | -} 13 | module System.Win32.Automation.Input.Key where 14 | import Foreign.Ptr ( Ptr ) 15 | import Foreign.Storable ( Storable(..) ) 16 | import System.Win32.Types ( ULONG_PTR ) 17 | import System.Win32.Word ( DWORD, WORD ) 18 | 19 | #include 20 | #include "winuser_compat.h" 21 | #include "alignment.h" 22 | 23 | type PKEYBDINPUT = Ptr KEYBDINPUT 24 | 25 | data KEYBDINPUT = KEYBDINPUT 26 | { wVk :: WORD 27 | , wScan :: WORD 28 | , dwFlags :: DWORD 29 | , time :: DWORD 30 | , dwExtraInfo :: ULONG_PTR 31 | } deriving Show 32 | 33 | instance Storable KEYBDINPUT where 34 | sizeOf = const #{size KEYBDINPUT} 35 | alignment _ = #alignment KEYBDINPUT 36 | poke buf input = do 37 | (#poke KEYBDINPUT, wVk) buf (wVk input) 38 | (#poke KEYBDINPUT, wScan) buf (wScan input) 39 | (#poke KEYBDINPUT, dwFlags) buf (dwFlags input) 40 | (#poke KEYBDINPUT, time) buf (time input) 41 | (#poke KEYBDINPUT, dwExtraInfo) buf (dwExtraInfo input) 42 | peek buf = do 43 | wVk' <- (#peek KEYBDINPUT, wVk) buf 44 | wScan' <- (#peek KEYBDINPUT, wScan) buf 45 | dwFlags' <- (#peek KEYBDINPUT, dwFlags) buf 46 | time' <- (#peek KEYBDINPUT, time) buf 47 | dwExtraInfo' <- (#peek KEYBDINPUT, dwExtraInfo) buf 48 | return $ KEYBDINPUT wVk' wScan' dwFlags' time' dwExtraInfo' 49 | 50 | #{enum DWORD, 51 | , kEYEVENTF_EXTENDEDKEY = KEYEVENTF_EXTENDEDKEY 52 | , kEYEVENTF_KEYUP = KEYEVENTF_KEYUP 53 | , kEYEVENTF_SCANCODE = KEYEVENTF_SCANCODE 54 | , kEYEVENTF_UNICODE = KEYEVENTF_UNICODE 55 | } 56 | -------------------------------------------------------------------------------- /System/Win32/DLL/Internal.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Win32.DLL.Internal 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module System.Win32.DLL.Internal where 21 | 22 | import System.Win32.Types 23 | 24 | ##include "windows_cconv.h" 25 | 26 | #include 27 | 28 | foreign import WINDOWS_CCONV unsafe "windows.h DisableThreadLibraryCalls" 29 | c_DisableThreadLibraryCalls :: HMODULE -> IO Bool 30 | 31 | foreign import WINDOWS_CCONV unsafe "windows.h FreeLibrary" 32 | c_FreeLibrary :: HMODULE -> IO Bool 33 | 34 | foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" 35 | c_GetModuleFileName :: HMODULE -> LPTSTR -> Int -> IO Bool 36 | 37 | foreign import WINDOWS_CCONV unsafe "windows.h GetModuleHandleW" 38 | c_GetModuleHandle :: LPCTSTR -> IO HMODULE 39 | 40 | foreign import WINDOWS_CCONV unsafe "windows.h GetProcAddress" 41 | c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr 42 | 43 | foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryW" 44 | c_LoadLibrary :: LPCTSTR -> IO HMODULE 45 | 46 | type LoadLibraryFlags = DWORD 47 | 48 | #{enum LoadLibraryFlags, 49 | , lOAD_LIBRARY_AS_DATAFILE = LOAD_LIBRARY_AS_DATAFILE 50 | , lOAD_WITH_ALTERED_SEARCH_PATH = LOAD_WITH_ALTERED_SEARCH_PATH 51 | } 52 | 53 | foreign import WINDOWS_CCONV unsafe "windows.h LoadLibraryExW" 54 | c_LoadLibraryEx :: LPCTSTR -> HANDLE -> LoadLibraryFlags -> IO HMODULE 55 | 56 | foreign import WINDOWS_CCONV unsafe "windows.h SetDllDirectoryW" 57 | c_SetDllDirectory :: LPTSTR -> IO BOOL 58 | -------------------------------------------------------------------------------- /System/Win32/Path.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Win32.Path 9 | -- Copyright : (c) Tamar Christina, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Tamar Christina 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module System.Win32.Path ( 21 | filepathRelativePathTo 22 | , pathRelativePathTo 23 | ) where 24 | 25 | import System.Win32.Path.Internal 26 | import System.Win32.Types 27 | import System.Win32.File 28 | 29 | import Foreign 30 | 31 | ##include "windows_cconv.h" 32 | 33 | #include 34 | 35 | filepathRelativePathTo :: FilePath -> FilePath -> IO FilePath 36 | filepathRelativePathTo from to = 37 | withTString from $ \p_from -> 38 | withTString to $ \p_to -> 39 | allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do 40 | _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from fILE_ATTRIBUTE_DIRECTORY 41 | p_to fILE_ATTRIBUTE_NORMAL) 42 | path <- peekTString p_AbsPath 43 | _ <- localFree p_AbsPath 44 | return path 45 | 46 | pathRelativePathTo :: FilePath -> FileAttributeOrFlag -> FilePath -> FileAttributeOrFlag -> IO FilePath 47 | pathRelativePathTo from from_attr to to_attr = 48 | withTString from $ \p_from -> 49 | withTString to $ \p_to -> 50 | allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do 51 | _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from from_attr 52 | p_to to_attr) 53 | path <- peekTString p_AbsPath 54 | _ <- localFree p_AbsPath 55 | return path 56 | 57 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/Path.hsc: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Win32.Path 4 | -- Copyright : (c) Tamar Christina, 1997-2003 5 | -- License : BSD-style (see the file libraries/base/LICENSE) 6 | -- 7 | -- Maintainer : Tamar Christina 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- A collection of FFI declarations for interfacing with Win32. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module System.Win32.WindowsString.Path ( 16 | filepathRelativePathTo 17 | , pathRelativePathTo 18 | ) where 19 | 20 | import System.Win32.Path.Internal 21 | import System.Win32.WindowsString.Types 22 | import System.Win32.WindowsString.File 23 | import System.OsPath.Windows 24 | 25 | import Foreign 26 | 27 | ##include "windows_cconv.h" 28 | 29 | #include 30 | 31 | filepathRelativePathTo :: WindowsPath -> WindowsPath -> IO WindowsPath 32 | filepathRelativePathTo from to = 33 | withTString from $ \p_from -> 34 | withTString to $ \p_to -> 35 | allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do 36 | _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from fILE_ATTRIBUTE_DIRECTORY 37 | p_to fILE_ATTRIBUTE_NORMAL) 38 | path <- peekTString p_AbsPath 39 | _ <- localFree p_AbsPath 40 | return path 41 | 42 | pathRelativePathTo :: WindowsPath -> FileAttributeOrFlag -> WindowsPath -> FileAttributeOrFlag -> IO WindowsPath 43 | pathRelativePathTo from from_attr to to_attr = 44 | withTString from $ \p_from -> 45 | withTString to $ \p_to -> 46 | allocaArray ((#const MAX_PATH) * (#size TCHAR)) $ \p_AbsPath -> do 47 | _ <- failIfZero "PathRelativePathTo" (c_pathRelativePathTo p_AbsPath p_from from_attr 48 | p_to to_attr) 49 | path <- peekTString p_AbsPath 50 | _ <- localFree p_AbsPath 51 | return path 52 | 53 | -------------------------------------------------------------------------------- /System/Win32/Console/CtrlHandler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.Console.CtrlHandler 4 | Copyright : 2008-2013 Judah Jacobson, 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Set handlers of console Ctrl events. 12 | -} 13 | module System.Win32.Console.CtrlHandler 14 | ( CtrlEvent, Handler, PHANDLER_ROUTINE 15 | , withConsoleCtrlHandler 16 | , setConsoleCtrlHandler, c_SetConsoleCtrlHandler 17 | , mkHandler 18 | , cTRL_C_EVENT, cTRL_BREAK_EVENT 19 | ) where 20 | 21 | import Control.Exception ( bracket ) 22 | import Control.Monad ( void ) 23 | import Foreign.Ptr ( FunPtr ) 24 | import System.Win32.Console ( CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT ) 25 | import System.Win32.Types ( BOOL, failIfFalse_ ) 26 | 27 | #include "windows_cconv.h" 28 | 29 | type Handler = CtrlEvent -> IO BOOL 30 | -- type HandlerRoutine = Handler 31 | type PHANDLER_ROUTINE = FunPtr Handler 32 | 33 | withConsoleCtrlHandler :: Handler -> IO a -> IO a 34 | withConsoleCtrlHandler handler io 35 | = bracket (do hd <- mkHandler handler 36 | -- don't fail if we can't set the Ctrl-C handler 37 | -- for example, we might not be attached to a console? 38 | void $ c_SetConsoleCtrlHandler hd True 39 | return hd) 40 | (\hd -> void $ c_SetConsoleCtrlHandler hd False) 41 | $ const io 42 | 43 | -- | This function isn't suitable when we want to set the cTRL_C_EVENT handler. 44 | -- If you want to set the cTRL_C_EVENT handler, use 'c_SetConsoleCtrlHandler' instead. 45 | setConsoleCtrlHandler :: PHANDLER_ROUTINE -> BOOL -> IO () 46 | setConsoleCtrlHandler handler flag 47 | = failIfFalse_ "SetConsoleCtrlHandler" 48 | $ c_SetConsoleCtrlHandler handler flag 49 | 50 | foreign import WINDOWS_CCONV "wrapper" mkHandler :: Handler -> IO PHANDLER_ROUTINE 51 | foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler" 52 | c_SetConsoleCtrlHandler :: PHANDLER_ROUTINE -> BOOL -> IO BOOL 53 | -------------------------------------------------------------------------------- /Graphics/Win32.hs: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Graphics.Win32 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- An interface to the Microsoft Windows user interface. 17 | -- See under /User Interface Design 18 | -- and Development/ and then /Windows User Interface/ for more details 19 | -- of the underlying library. 20 | -- 21 | ----------------------------------------------------------------------------- 22 | 23 | module Graphics.Win32 ( 24 | module System.Win32.Types, 25 | module Graphics.Win32.Control, 26 | module Graphics.Win32.Dialogue, 27 | module Graphics.Win32.GDI, 28 | module Graphics.Win32.Icon, 29 | module Graphics.Win32.Key, 30 | module Graphics.Win32.Menu, 31 | module Graphics.Win32.Message, 32 | module Graphics.Win32.Misc, 33 | module Graphics.Win32.Resource, 34 | module Graphics.Win32.Window, 35 | module Graphics.Win32.LayeredWindow, 36 | module Graphics.Win32.Window.AnimateWindow, 37 | module Graphics.Win32.Window.ForegroundWindow, 38 | module Graphics.Win32.Window.IMM, 39 | module Graphics.Win32.Window.PostMessage 40 | ) where 41 | 42 | import System.Win32.Types 43 | import Graphics.Win32.Control 44 | import Graphics.Win32.Dialogue 45 | import Graphics.Win32.GDI 46 | import Graphics.Win32.Icon 47 | import Graphics.Win32.Key 48 | import Graphics.Win32.Menu 49 | import Graphics.Win32.Message 50 | import Graphics.Win32.Misc 51 | import Graphics.Win32.Resource 52 | import Graphics.Win32.Window 53 | import Graphics.Win32.LayeredWindow 54 | import Graphics.Win32.Window.AnimateWindow 55 | import Graphics.Win32.Window.ForegroundWindow 56 | import Graphics.Win32.Window.IMM 57 | import Graphics.Win32.Window.PostMessage 58 | -------------------------------------------------------------------------------- /Graphics/Win32/Icon.hs: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Graphics.Win32.Icon 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Graphics.Win32.Icon where 21 | 22 | import Foreign (Ptr) 23 | import Graphics.Win32.GDI.Types 24 | import System.Win32.Types 25 | 26 | #include "windows_cconv.h" 27 | 28 | ---------------------------------------------------------------- 29 | -- Icons 30 | ---------------------------------------------------------------- 31 | 32 | createIcon :: HINSTANCE -> Int -> Int -> BYTE -> BYTE -> Ptr BYTE -> Ptr BYTE -> IO HICON 33 | createIcon instance_ width height planes bitsPixel andBits xorBits = 34 | failIfNull "CreateIcon" $ c_CreateIcon instance_ width height planes bitsPixel andBits xorBits 35 | foreign import WINDOWS_CCONV unsafe "windows.h CreateIcon" 36 | c_CreateIcon :: HINSTANCE -> Int -> Int -> BYTE -> BYTE -> Ptr BYTE -> Ptr BYTE -> IO HICON 37 | 38 | copyIcon :: HICON -> IO HICON 39 | copyIcon icon = 40 | failIfNull "CopyIcon" $ c_CopyIcon icon 41 | foreign import WINDOWS_CCONV unsafe "windows.h CopyIcon" 42 | c_CopyIcon :: HICON -> IO HICON 43 | 44 | drawIcon :: HDC -> Int -> Int -> HICON -> IO () 45 | drawIcon dc x y icon = 46 | failIfFalse_ "DrawIcon" $ c_DrawIcon dc x y icon 47 | foreign import WINDOWS_CCONV unsafe "windows.h DrawIcon" 48 | c_DrawIcon :: HDC -> Int -> Int -> HICON -> IO Bool 49 | 50 | destroyIcon :: HICON -> IO () 51 | destroyIcon icon = 52 | failIfFalse_ "DestroyIcon" $ c_DestroyIcon icon 53 | foreign import WINDOWS_CCONV unsafe "windows.h DestroyIcon" 54 | c_DestroyIcon :: HICON -> IO Bool 55 | 56 | ---------------------------------------------------------------- 57 | -- End 58 | ---------------------------------------------------------------- 59 | -------------------------------------------------------------------------------- /Graphics/Win32/LayeredWindow.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : Graphics.Win32.LayeredWindow 4 | Copyright : 2012-2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Provides LayeredWindow functionality. 12 | -} 13 | module Graphics.Win32.LayeredWindow (module Graphics.Win32.LayeredWindow, Graphics.Win32.Window.c_GetWindowLongPtr ) where 14 | import Control.Monad ( void ) 15 | import Data.Bits ( (.|.) ) 16 | import Foreign.Ptr ( Ptr ) 17 | import Graphics.Win32.GDI.AlphaBlend ( BLENDFUNCTION ) 18 | import Graphics.Win32.GDI.Types ( COLORREF, HDC, SIZE, SIZE, POINT ) 19 | import Graphics.Win32.Window ( WindowStyleEx, c_GetWindowLongPtr, c_SetWindowLongPtr ) 20 | import System.Win32.Types ( DWORD, HANDLE, BYTE, BOOL, INT ) 21 | 22 | #include 23 | ##include "windows_cconv.h" 24 | #include "winuser_compat.h" 25 | 26 | toLayeredWindow :: HANDLE -> IO () 27 | toLayeredWindow w = do 28 | flg <- c_GetWindowLongPtr w gWL_EXSTYLE 29 | void $ c_SetWindowLongPtr w gWL_EXSTYLE (flg .|. (fromIntegral wS_EX_LAYERED)) 30 | 31 | -- test w = c_SetLayeredWindowAttributes w 0 128 lWA_ALPHA 32 | 33 | gWL_EXSTYLE :: INT 34 | gWL_EXSTYLE = #const GWL_EXSTYLE 35 | 36 | wS_EX_LAYERED :: WindowStyleEx 37 | wS_EX_LAYERED = #const WS_EX_LAYERED 38 | 39 | lWA_COLORKEY, lWA_ALPHA :: DWORD 40 | lWA_COLORKEY = #const LWA_COLORKEY 41 | lWA_ALPHA = #const LWA_ALPHA 42 | 43 | foreign import WINDOWS_CCONV unsafe "windows.h SetLayeredWindowAttributes" 44 | c_SetLayeredWindowAttributes :: HANDLE -> COLORREF -> BYTE -> DWORD -> IO BOOL 45 | 46 | foreign import WINDOWS_CCONV unsafe "windows.h GetLayeredWindowAttributes" 47 | c_GetLayeredWindowAttributes :: HANDLE -> COLORREF -> Ptr BYTE -> Ptr DWORD -> IO BOOL 48 | 49 | foreign import WINDOWS_CCONV unsafe "windows.h UpdateLayeredWindow" 50 | c_UpdateLayeredWindow :: HANDLE -> HDC -> Ptr POINT -> Ptr SIZE -> HDC -> Ptr POINT -> COLORREF -> Ptr BLENDFUNCTION -> DWORD -> IO BOOL 51 | 52 | #{enum DWORD, 53 | , uLW_ALPHA = ULW_ALPHA 54 | , uLW_COLORKEY = ULW_COLORKEY 55 | , uLW_OPAQUE = ULW_OPAQUE 56 | } 57 | 58 | -------------------------------------------------------------------------------- /Graphics/Win32/Window/HotKey.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : Graphics.Win32.Window.HotKey 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | An FFI binding to the hot key part of the Win32 API. 12 | -} 13 | module Graphics.Win32.Window.HotKey where 14 | 15 | import Data.Bits ( (.|.) ) 16 | import Graphics.Win32.GDI.Types ( HWND, MbHWND ) 17 | import Graphics.Win32.Key ( VKey ) 18 | import Graphics.Win32.Message ( WindowMessage ) 19 | import System.Win32.Types ( UINT, BOOL, maybePtr, failIfFalse_ ) 20 | import System.Win32.Exception.Unsupported ( unsupportedVal, upgradeWindowsOS ) 21 | import System.Win32.Info.Version ( is7OrLater ) 22 | 23 | #include 24 | ##include "windows_cconv.h" 25 | 26 | type FsModifiers = [FsModifier] 27 | type FsModifier = UINT 28 | 29 | #{enum FsModifier, 30 | , mOD_ALT = MOD_ALT 31 | , mOD_CONTROL = MOD_CONTROL 32 | , mOD_SHIFT = MOD_SHIFT 33 | , mOD_WIN = MOD_WIN 34 | } 35 | 36 | -- | This parameter requires to use Windows 7 or later. 37 | mOD_NOREPEAT :: FsModifier 38 | mOD_NOREPEAT 39 | = unsupportedVal "MOD_NOREPEAT" 40 | is7OrLater (upgradeWindowsOS "Windows 7") 0x4000 41 | {- 42 | , mOD_NOREPEAT = MOD_NOREPEAT 43 | -} 44 | 45 | wM_HOTKEY :: WindowMessage 46 | wM_HOTKEY = #const WM_HOTKEY 47 | 48 | joinModifiers :: FsModifiers -> FsModifier 49 | joinModifiers = foldr (.|.) 0 50 | 51 | registerHotKey :: MbHWND -> Int -> FsModifier -> VKey -> IO () 52 | registerHotKey mb_wnd kid md vkey = 53 | failIfFalse_ (unwords ["RegisterHotKey", show mb_wnd, show kid, show md, show vkey]) 54 | $ c_RegisterHotKey (maybePtr mb_wnd) kid md vkey 55 | 56 | foreign import WINDOWS_CCONV "windows.h RegisterHotKey" 57 | c_RegisterHotKey :: HWND -> Int -> UINT -> VKey -> IO BOOL 58 | 59 | unregisterHotKey :: MbHWND -> Int -> IO () 60 | unregisterHotKey mb_wnd kid = 61 | failIfFalse_ (unwords ["UnregisterHotKey", show mb_wnd, show kid]) 62 | $ c_UnregisterHotKey (maybePtr mb_wnd) kid 63 | 64 | foreign import WINDOWS_CCONV "windows.h UnregisterHotKey" 65 | c_UnregisterHotKey :: HWND -> Int -> IO BOOL 66 | -------------------------------------------------------------------------------- /cbits/WndProc.c: -------------------------------------------------------------------------------- 1 | #include "WndProc.h" 2 | #include 3 | 4 | 5 | /* Debugging code - might come in handy. */ 6 | #if 0 7 | HWND 8 | mkWin(long l) 9 | { 10 | static char appN[] = "TestWin"; 11 | HWND hw; 12 | WNDCLASSEX wndclass; 13 | 14 | wndclass.cbSize = sizeof(wndclass); 15 | wndclass.style = CS_HREDRAW | CS_VREDRAW; 16 | wndclass.lpfnWndProc = genericWndProc; 17 | wndclass.cbClsExtra = 0; 18 | wndclass.cbWndExtra = 0; 19 | wndclass.hInstance = GetModuleHandle(NULL); 20 | wndclass.hIcon = LoadIcon(NULL, IDI_APPLICATION); 21 | wndclass.hCursor = LoadCursor(NULL, IDC_ARROW); 22 | wndclass.hbrBackground = (HBRUSH)GetStockObject(WHITE_BRUSH); 23 | wndclass.lpszMenuName = NULL; 24 | wndclass.lpszClassName = appN; 25 | wndclass.hIconSm = LoadIcon(NULL, IDI_APPLICATION); 26 | 27 | RegisterClassEx(&wndclass); 28 | 29 | hw = CreateWindow(appN, "test", WS_OVERLAPPEDWINDOW,100,100,100,100, NULL, NULL, GetModuleHandle(NULL),NULL); 30 | //ShowWindow (hw, SW_SHOWNORMAL); 31 | //UpdateWindow (hw); 32 | /*WndPump();*/ 33 | //SetWindowLong( hw, GWL_USERDATA,l); 34 | return hw; 35 | } 36 | 37 | void 38 | WndPump() 39 | { 40 | MSG msg; 41 | 42 | fprintf(stderr, "Getting..\n"); 43 | while (GetMessage(&msg, NULL, 0,0) != 0) { 44 | fprintf(stderr, "..got,\n"); 45 | TranslateMessage(&msg); 46 | fprintf(stderr, "delivering.\n"); 47 | DispatchMessage(&msg); 48 | fprintf(stderr, "Getting..\n"); 49 | } 50 | } 51 | #endif 52 | 53 | #ifdef DEBUG 54 | char* __current_fun__ = NULL; 55 | #endif 56 | 57 | void 58 | WndPump () 59 | { 60 | MSG msg; 61 | while(1) { 62 | GetMessage(&msg,NULL, 0,0); 63 | TranslateMessage(&msg); 64 | DispatchMessage(&msg); 65 | } 66 | return; 67 | } 68 | 69 | LRESULT CALLBACK genericWndProc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) 70 | { 71 | LRESULT lr; 72 | 73 | if (hwnd) { 74 | LONG_PTR wndprocptr = GetWindowLongPtr(hwnd,GWLP_USERDATA); 75 | if (wndprocptr) { 76 | lr = ((LRESULT (*)(HWND,UINT,WPARAM,LPARAM))(wndprocptr))(hwnd,msg,wParam,lParam); 77 | #if 0 78 | if (lr == -1) { 79 | return DefWindowProc(hwnd, msg, wParam, lParam); 80 | } else { 81 | return lr; 82 | } 83 | #else 84 | return lr; 85 | #endif 86 | } 87 | } 88 | return DefWindowProc(hwnd, msg, wParam, lParam); 89 | } 90 | 91 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/DLL.hsc: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Win32.DLL 4 | -- Copyright : (c) Alastair Reid, 1997-2003 5 | -- License : BSD-style (see the file libraries/base/LICENSE) 6 | -- 7 | -- Maintainer : Esa Ilari Vuokko 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- A collection of FFI declarations for interfacing with Win32. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module System.Win32.WindowsString.DLL 16 | ( module System.Win32.WindowsString.DLL 17 | , module System.Win32.DLL 18 | ) where 19 | 20 | import System.Win32.DLL hiding 21 | ( disableThreadLibraryCalls 22 | , freeLibrary 23 | , getModuleFileName 24 | , getModuleHandle 25 | , getProcAddress 26 | , loadLibrary 27 | , loadLibraryEx 28 | , setDllDirectory 29 | , lOAD_LIBRARY_AS_DATAFILE 30 | , lOAD_WITH_ALTERED_SEARCH_PATH 31 | ) 32 | import System.Win32.DLL.Internal 33 | import System.Win32.WindowsString.Types 34 | 35 | import Foreign 36 | import Data.Maybe (fromMaybe) 37 | import System.OsString.Windows 38 | import GHC.IO.Encoding.UTF16 ( mkUTF16le ) 39 | import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) 40 | 41 | getModuleFileName :: HMODULE -> IO WindowsString 42 | getModuleFileName hmod = 43 | allocaArray 512 $ \ c_str -> do 44 | failIfFalse_ "GetModuleFileName" $ c_GetModuleFileName hmod c_str 512 45 | peekTString c_str 46 | 47 | getModuleHandle :: Maybe WindowsString -> IO HMODULE 48 | getModuleHandle mb_name = 49 | maybeWith withTString mb_name $ \ c_name -> 50 | failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name 51 | 52 | loadLibrary :: WindowsString -> IO HMODULE 53 | loadLibrary name = 54 | withTString name $ \ c_name -> 55 | failIfNull "LoadLibrary" $ c_LoadLibrary c_name 56 | 57 | loadLibraryEx :: WindowsString -> HANDLE -> LoadLibraryFlags -> IO HMODULE 58 | loadLibraryEx name h flags = 59 | withTString name $ \ c_name -> 60 | failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags 61 | 62 | setDllDirectory :: Maybe WindowsString -> IO () 63 | setDllDirectory name = 64 | maybeWith withTString name $ \ c_name -> do 65 | let nameS = name >>= either (const Nothing) Just . decodeWith (mkUTF16le TransliterateCodingFailure) 66 | failIfFalse_ (unwords ["SetDllDirectory", fromMaybe "NULL" nameS]) $ c_SetDllDirectory c_name 67 | 68 | -------------------------------------------------------------------------------- /System/Win32/Shell.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Win32.Shell 9 | -- Copyright : (c) The University of Glasgow 2009 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- Win32 stuff from shell32.dll 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module System.Win32.Shell ( 21 | sHGetFolderPath, 22 | CSIDL, 23 | cSIDL_PROFILE, 24 | cSIDL_APPDATA, 25 | cSIDL_WINDOWS, 26 | cSIDL_PERSONAL, 27 | cSIDL_LOCAL_APPDATA, 28 | cSIDL_DESKTOPDIRECTORY, 29 | cSIDL_PROGRAM_FILES, 30 | SHGetFolderPathFlags, 31 | sHGFP_TYPE_CURRENT, 32 | sHGFP_TYPE_DEFAULT 33 | ) where 34 | 35 | import System.Win32.Shell.Internal 36 | import System.Win32.Types 37 | import Graphics.Win32.GDI.Types (HWND) 38 | 39 | import Foreign 40 | import Foreign.C 41 | import Control.Monad 42 | 43 | ##include "windows_cconv.h" 44 | 45 | -- for SHGetFolderPath stuff 46 | #define _WIN32_IE 0x500 47 | #include 48 | #include 49 | 50 | ---------------------------------------------------------------- 51 | -- SHGetFolderPath 52 | -- 53 | -- XXX: this is deprecated in Vista and later 54 | ---------------------------------------------------------------- 55 | 56 | type CSIDL = CInt 57 | 58 | #{enum CSIDL, 59 | , cSIDL_PROFILE = CSIDL_PROFILE 60 | , cSIDL_APPDATA = CSIDL_APPDATA 61 | , cSIDL_WINDOWS = CSIDL_WINDOWS 62 | , cSIDL_PERSONAL = CSIDL_PERSONAL 63 | , cSIDL_LOCAL_APPDATA = CSIDL_LOCAL_APPDATA 64 | , cSIDL_DESKTOPDIRECTORY = CSIDL_DESKTOPDIRECTORY 65 | , cSIDL_PROGRAM_FILES = CSIDL_PROGRAM_FILES 66 | } 67 | -- XXX there are lots more of these 68 | 69 | type SHGetFolderPathFlags = DWORD 70 | 71 | #{enum SHGetFolderPathFlags, 72 | , sHGFP_TYPE_CURRENT = SHGFP_TYPE_CURRENT 73 | , sHGFP_TYPE_DEFAULT = SHGFP_TYPE_DEFAULT 74 | } 75 | 76 | sHGetFolderPath :: HWND -> CSIDL -> HANDLE -> SHGetFolderPathFlags -> IO String 77 | sHGetFolderPath hwnd csidl hdl flags = 78 | allocaBytes ((#const MAX_PATH) * (#size TCHAR)) $ \pstr -> do 79 | r <- c_SHGetFolderPath hwnd csidl hdl flags pstr 80 | when (r < 0) $ raiseUnsupported "sHGetFolderPath" 81 | peekTString pstr 82 | -------------------------------------------------------------------------------- /System/Win32.hs: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Win32 9 | -- Copyright : (c) Alastair Reid, 1999-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- An FFI binding to the system part of the Win32 API. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module System.Win32 21 | ( module System.Win32.DLL 22 | , module System.Win32.Event 23 | , module System.Win32.File 24 | , module System.Win32.FileMapping 25 | , module System.Win32.Info 26 | , module System.Win32.Mem 27 | , module System.Win32.MinTTY 28 | , module System.Win32.NLS 29 | , module System.Win32.Process 30 | , module System.Win32.Registry 31 | , module System.Win32.Time 32 | , module System.Win32.Console 33 | , module System.Win32.Security 34 | , module System.Win32.Types 35 | , module System.Win32.Shell 36 | , module System.Win32.Automation 37 | , module System.Win32.HardLink 38 | , module System.Win32.SymbolicLink 39 | , module System.Win32.Thread 40 | , module System.Win32.Utils 41 | ) where 42 | 43 | import System.Win32.DLL 44 | import System.Win32.Event 45 | import System.Win32.File 46 | import System.Win32.FileMapping 47 | import System.Win32.Info 48 | import System.Win32.Mem 49 | import System.Win32.MinTTY 50 | import System.Win32.NLS hiding ( LCID, LANGID, SortID, SubLANGID 51 | , PrimaryLANGID, mAKELCID, lANGIDFROMLCID 52 | , sORTIDFROMLCID, mAKELANGID, pRIMARYLANGID 53 | , sUBLANGID ) 54 | import System.Win32.Process 55 | import System.Win32.Registry 56 | import System.Win32.Time 57 | import System.Win32.Console 58 | import System.Win32.Types 59 | import System.Win32.Security 60 | import System.Win32.Shell 61 | 62 | import System.Win32.Automation 63 | import System.Win32.HardLink 64 | import System.Win32.SymbolicLink 65 | import System.Win32.Thread 66 | import System.Win32.Utils hiding ( try ) 67 | 68 | ---------------------------------------------------------------- 69 | -- End 70 | ---------------------------------------------------------------- 71 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/Time.hsc: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Win32.Time 4 | -- Copyright : (c) Esa Ilari Vuokko, 2006 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : Esa Ilari Vuokko 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- A collection of FFI declarations for interfacing with Win32 Time API. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | module System.Win32.WindowsString.Time 15 | ( module System.Win32.WindowsString.Time 16 | , module System.Win32.Time 17 | ) where 18 | 19 | import System.Win32.Time.Internal 20 | import System.Win32.Time hiding (getTimeFormatEx, getTimeFormat) 21 | 22 | import System.Win32.WindowsString.String ( peekTStringLen, withTString ) 23 | import System.Win32.WindowsString.Types ( LCID, failIf ) 24 | import System.Win32.Utils ( trySized ) 25 | 26 | import Foreign ( Storable(sizeOf) 27 | , nullPtr, castPtr 28 | , with, allocaBytes ) 29 | import Foreign.C ( CWchar(..) 30 | , withCWString ) 31 | import Foreign.Marshal.Utils (maybeWith) 32 | import System.OsString.Windows 33 | 34 | ##include "windows_cconv.h" 35 | #include 36 | #include "alignment.h" 37 | #include "winnls_compat.h" 38 | 39 | 40 | getTimeFormatEx :: Maybe WindowsString 41 | -> GetTimeFormatFlags 42 | -> Maybe SYSTEMTIME 43 | -> Maybe WindowsString 44 | -> IO String 45 | getTimeFormatEx locale flags st fmt = 46 | maybeWith withTString locale $ \c_locale -> 47 | maybeWith with st $ \c_st -> 48 | maybeWith withTString fmt $ \c_fmt -> do 49 | let c_func = c_GetTimeFormatEx c_locale flags c_st c_fmt 50 | trySized "GetTimeFormatEx" c_func 51 | 52 | getTimeFormat :: LCID -> GetTimeFormatFlags -> Maybe SYSTEMTIME -> Maybe String -> IO WindowsString 53 | getTimeFormat locale flags st fmt = 54 | maybeWith with st $ \c_st -> 55 | maybeWith withCWString fmt $ \c_fmt -> do 56 | size <- c_GetTimeFormat locale flags c_st c_fmt nullPtr 0 57 | allocaBytes ((fromIntegral size) * (sizeOf (undefined::CWchar))) $ \out -> do 58 | size' <- failIf (==0) "getTimeFormat: GetTimeFormat" $ 59 | c_GetTimeFormat locale flags c_st c_fmt (castPtr out) size 60 | peekTStringLen (out,fromIntegral size') 61 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/Utils.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module : System.Win32.Utils 3 | Copyright : 2009 Balazs Komuves, 2013 shelarcy 4 | License : BSD-style 5 | 6 | Maintainer : shelarcy@gmail.com 7 | Stability : Provisional 8 | Portability : Non-portable (Win32 API) 9 | 10 | Utilities for calling Win32 API 11 | -} 12 | module System.Win32.WindowsString.Utils 13 | ( module System.Win32.WindowsString.Utils 14 | , module System.Win32.Utils 15 | ) where 16 | 17 | import Foreign.C.Types ( CInt ) 18 | import Foreign.Marshal.Array ( allocaArray ) 19 | import Foreign.Ptr ( nullPtr ) 20 | 21 | import System.Win32.Utils hiding 22 | ( try 23 | , tryWithoutNull 24 | , trySized 25 | ) 26 | import System.Win32.WindowsString.String ( LPTSTR, peekTString, peekTStringLen 27 | , withTStringBufferLen ) 28 | import System.Win32.WindowsString.Types ( UINT 29 | , failIfZero 30 | ) 31 | import qualified System.Win32.WindowsString.Types ( try ) 32 | import System.OsString.Windows 33 | 34 | 35 | -- | Support for API calls that are passed a fixed-size buffer and tell 36 | -- you via the return value if the buffer was too small. In that 37 | -- case, we extend the buffer size and try again. 38 | try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString 39 | try = System.Win32.WindowsString.Types.try 40 | {-# INLINE try #-} 41 | 42 | tryWithoutNull :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString 43 | tryWithoutNull loc f n = do 44 | e <- allocaArray (fromIntegral n) $ \lptstr -> do 45 | r <- failIfZero loc $ f lptstr n 46 | if r > n then return (Left r) else do 47 | str <- peekTString lptstr 48 | return (Right str) 49 | case e of 50 | Left r' -> tryWithoutNull loc f r' 51 | Right str -> return str 52 | 53 | -- | Support for API calls that return the required size, in characters 54 | -- including a null character, of the buffer when passed a buffer size of zero. 55 | trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO WindowsString 56 | trySized wh f = do 57 | c_len <- failIfZero wh $ f nullPtr 0 58 | let len = fromIntegral c_len 59 | withTStringBufferLen len $ \(buf', len') -> do 60 | let c_len' = fromIntegral len' 61 | c_len'' <- failIfZero wh $ f buf' c_len' 62 | let len'' = fromIntegral c_len'' 63 | peekTStringLen (buf', len'' - 1) -- Drop final null character 64 | -------------------------------------------------------------------------------- /System/Win32/DLL.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Win32.DLL 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module System.Win32.DLL 21 | ( disableThreadLibraryCalls 22 | , freeLibrary 23 | , getModuleFileName 24 | , getModuleHandle 25 | , getProcAddress 26 | , loadLibrary 27 | , loadLibraryEx 28 | , setDllDirectory 29 | , LoadLibraryFlags 30 | , lOAD_LIBRARY_AS_DATAFILE 31 | , lOAD_WITH_ALTERED_SEARCH_PATH 32 | ) where 33 | 34 | import System.Win32.DLL.Internal 35 | import System.Win32.Types 36 | 37 | import Foreign 38 | import Foreign.C 39 | import Data.Maybe (fromMaybe) 40 | 41 | disableThreadLibraryCalls :: HMODULE -> IO () 42 | disableThreadLibraryCalls hmod = 43 | failIfFalse_ "DisableThreadLibraryCalls" $ c_DisableThreadLibraryCalls hmod 44 | 45 | freeLibrary :: HMODULE -> IO () 46 | freeLibrary hmod = 47 | failIfFalse_ "FreeLibrary" $ c_FreeLibrary hmod 48 | 49 | getModuleFileName :: HMODULE -> IO String 50 | getModuleFileName hmod = 51 | allocaArray 512 $ \ c_str -> do 52 | failIfFalse_ "GetModuleFileName" $ c_GetModuleFileName hmod c_str 512 53 | peekTString c_str 54 | 55 | getModuleHandle :: Maybe String -> IO HMODULE 56 | getModuleHandle mb_name = 57 | maybeWith withTString mb_name $ \ c_name -> 58 | failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name 59 | 60 | getProcAddress :: HMODULE -> String -> IO Addr 61 | getProcAddress hmod procname = 62 | withCAString procname $ \ c_procname -> 63 | failIfNull "GetProcAddress" $ c_GetProcAddress hmod c_procname 64 | 65 | loadLibrary :: String -> IO HMODULE 66 | loadLibrary name = 67 | withTString name $ \ c_name -> 68 | failIfNull "LoadLibrary" $ c_LoadLibrary c_name 69 | 70 | loadLibraryEx :: String -> HANDLE -> LoadLibraryFlags -> IO HMODULE 71 | loadLibraryEx name h flags = 72 | withTString name $ \ c_name -> 73 | failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags 74 | 75 | setDllDirectory :: Maybe String -> IO () 76 | setDllDirectory name = 77 | maybeWith withTString name $ \ c_name -> 78 | failIfFalse_ (unwords ["SetDllDirectory", fromMaybe "NULL" name]) $ c_SetDllDirectory c_name 79 | 80 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/String.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | {- | 4 | Module : System.Win32.String 5 | Copyright : 2013 shelarcy 6 | License : BSD-style 7 | 8 | Maintainer : shelarcy@gmail.com 9 | Stability : Provisional 10 | Portability : Non-portable (Win32 API) 11 | 12 | Utilities for primitive marshalling of Windows' C strings. 13 | -} 14 | module System.Win32.WindowsString.String 15 | ( LPSTR, LPCSTR, LPWSTR, LPCWSTR 16 | , TCHAR, LPTSTR, LPCTSTR, LPCTSTR_ 17 | , withTString, withTStringLen, peekTString, peekTStringLen 18 | , newTString 19 | , withTStringBuffer, withTStringBufferLen 20 | ) where 21 | 22 | import System.Win32.String hiding 23 | ( withTStringBuffer 24 | , withTStringBufferLen 25 | , withTString 26 | , withTStringLen 27 | , peekTString 28 | , peekTStringLen 29 | , newTString 30 | ) 31 | import System.Win32.WindowsString.Types 32 | import System.OsString.Internal.Types 33 | #if MIN_VERSION_filepath(1,5,0) 34 | import qualified "os-string" System.OsString.Data.ByteString.Short as SBS 35 | #else 36 | import qualified "filepath" System.OsPath.Data.ByteString.Short as SBS 37 | #endif 38 | import Data.Word (Word8) 39 | 40 | -- | Marshal a dummy Haskell string into a NUL terminated C wide string 41 | -- using temporary storage. 42 | -- 43 | -- * the Haskell string is created by length parameter. And the Haskell 44 | -- string contains /only/ NUL characters. 45 | -- 46 | -- * the memory is freed when the subcomputation terminates (either 47 | -- normally or via an exception), so the pointer to the temporary 48 | -- storage must /not/ be used after this. 49 | -- 50 | withTStringBuffer :: Int -> (LPTSTR -> IO a) -> IO a 51 | withTStringBuffer maxLength 52 | = let dummyBuffer = WindowsString $ SBS.pack $ replicate (if even maxLength then maxLength else maxLength + 1) _nul 53 | in withTString dummyBuffer 54 | 55 | -- | Marshal a dummy Haskell string into a C wide string (i.e. wide 56 | -- character array) in temporary storage, with explicit length 57 | -- information. 58 | -- 59 | -- * the Haskell string is created by length parameter. And the Haskell 60 | -- string contains /only/ NUL characters. 61 | -- 62 | -- * the memory is freed when the subcomputation terminates (either 63 | -- normally or via an exception), so the pointer to the temporary 64 | -- storage must /not/ be used after this. 65 | -- 66 | withTStringBufferLen :: Int -> ((LPTSTR, Int) -> IO a) -> IO a 67 | withTStringBufferLen maxLength 68 | = let dummyBuffer = WindowsString $ SBS.pack $ replicate (if even maxLength then maxLength else maxLength + 1) _nul 69 | in withTStringLen dummyBuffer 70 | 71 | 72 | _nul :: Word8 73 | _nul = 0x00 74 | -------------------------------------------------------------------------------- /System/Win32/FileMapping/Internal.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Win32.FileMapping.Internal 9 | -- Copyright : (c) Esa Ilari Vuokko, 2006 10 | -- License : BSD-style (see the file LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32 mapped files. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | module System.Win32.FileMapping.Internal where 20 | 21 | import System.Win32.Types ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR ) 22 | 23 | import Foreign ( Ptr, FunPtr ) 24 | import Foreign.C.Types (CUIntPtr(..)) 25 | 26 | ##include "windows_cconv.h" 27 | 28 | #include "windows.h" 29 | 30 | --------------------------------------------------------------------------- 31 | -- Derived functions 32 | --------------------------------------------------------------------------- 33 | 34 | data MappedObject = MappedObject HANDLE HANDLE FileMapAccess 35 | 36 | 37 | --------------------------------------------------------------------------- 38 | -- Enums 39 | --------------------------------------------------------------------------- 40 | type ProtectSectionFlags = DWORD 41 | #{enum ProtectSectionFlags, 42 | , sEC_COMMIT = SEC_COMMIT 43 | , sEC_IMAGE = SEC_IMAGE 44 | , sEC_NOCACHE = SEC_NOCACHE 45 | , sEC_RESERVE = SEC_RESERVE 46 | } 47 | type FileMapAccess = DWORD 48 | #{enum FileMapAccess, 49 | , fILE_MAP_ALL_ACCESS = FILE_MAP_ALL_ACCESS 50 | , fILE_MAP_COPY = FILE_MAP_COPY 51 | , fILE_MAP_READ = FILE_MAP_READ 52 | , fILE_MAP_WRITE = FILE_MAP_WRITE 53 | } 54 | 55 | --------------------------------------------------------------------------- 56 | -- Imports 57 | --------------------------------------------------------------------------- 58 | foreign import WINDOWS_CCONV "windows.h OpenFileMappingW" 59 | c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE 60 | 61 | foreign import WINDOWS_CCONV "windows.h CreateFileMappingW" 62 | c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE 63 | 64 | foreign import WINDOWS_CCONV "windows.h MapViewOfFileEx" 65 | c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b) 66 | 67 | foreign import WINDOWS_CCONV "windows.h UnmapViewOfFile" 68 | c_UnmapViewOfFile :: Ptr a -> IO BOOL 69 | 70 | {-# CFILES cbits/HsWin32.c #-} 71 | foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser" 72 | c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ()) 73 | -------------------------------------------------------------------------------- /Graphics/Win32/GDI/Brush.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Graphics.Win32.GDI.Brush 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Graphics.Win32.GDI.Brush where 21 | 22 | import System.Win32.Types 23 | import Graphics.Win32.GDI.Types 24 | 25 | ##include "windows_cconv.h" 26 | 27 | #include 28 | 29 | ---------------------------------------------------------------- 30 | -- Brush 31 | ---------------------------------------------------------------- 32 | 33 | createSolidBrush :: COLORREF -> IO HBRUSH 34 | createSolidBrush color = 35 | failIfNull "CreateSolidBrush" $ c_CreateSolidBrush color 36 | foreign import WINDOWS_CCONV unsafe "windows.h CreateSolidBrush" 37 | c_CreateSolidBrush :: COLORREF -> IO HBRUSH 38 | 39 | createHatchBrush :: HatchStyle -> COLORREF -> IO HBRUSH 40 | createHatchBrush style color = 41 | failIfNull "CreateHatchBrush" $ c_CreateHatchBrush style color 42 | foreign import WINDOWS_CCONV unsafe "windows.h CreateHatchBrush" 43 | c_CreateHatchBrush :: HatchStyle -> COLORREF -> IO HBRUSH 44 | 45 | createPatternBrush :: HBITMAP -> IO HBRUSH 46 | createPatternBrush bitmap = 47 | failIfNull "CreatePatternBrush" $ c_CreatePatternBrush bitmap 48 | foreign import WINDOWS_CCONV unsafe "windows.h CreatePatternBrush" 49 | c_CreatePatternBrush :: HBITMAP -> IO HBRUSH 50 | 51 | deleteBrush :: HBRUSH -> IO () 52 | deleteBrush brush = 53 | failIfFalse_ "DeleteBrush" $ c_DeleteBrush brush 54 | foreign import WINDOWS_CCONV unsafe "windows.h DeleteObject" 55 | c_DeleteBrush :: HBRUSH -> IO Bool 56 | 57 | ---------------------------------------------------------------- 58 | 59 | type StockBrush = INT 60 | 61 | #{enum StockBrush, 62 | , wHITE_BRUSH = WHITE_BRUSH 63 | , lTGRAY_BRUSH = LTGRAY_BRUSH 64 | , gRAY_BRUSH = GRAY_BRUSH 65 | , dKGRAY_BRUSH = DKGRAY_BRUSH 66 | , bLACK_BRUSH = BLACK_BRUSH 67 | , nULL_BRUSH = NULL_BRUSH 68 | , hOLLOW_BRUSH = HOLLOW_BRUSH 69 | } 70 | 71 | getStockBrush :: StockBrush -> IO HBRUSH 72 | getStockBrush sb = 73 | failIfNull "GetStockBrush" $ c_GetStockBrush sb 74 | foreign import WINDOWS_CCONV unsafe "windows.h GetStockObject" 75 | c_GetStockBrush :: StockBrush -> IO HBRUSH 76 | 77 | ---------------------------------------------------------------- 78 | -- End 79 | ---------------------------------------------------------------- 80 | -------------------------------------------------------------------------------- /System/Win32/Exception/Unsupported.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {- | 3 | Module : System.Win32.Exception.Unsupported 4 | Copyright : 2012 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Exception handling if using unsupported Win32 API. 12 | -} 13 | 14 | module System.Win32.Exception.Unsupported 15 | ( module System.Win32.Exception.Unsupported 16 | ) where 17 | 18 | import Control.Exception ( Exception(..), throwIO ) 19 | import Data.Typeable ( Typeable ) 20 | import Foreign.Ptr ( Ptr, nullPtr ) 21 | import Foreign.Marshal.Unsafe ( unsafeLocalState ) 22 | 23 | ---------------------------------------------------------------- 24 | -- Exception type of Unsupported 25 | ---------------------------------------------------------------- 26 | data Unsupported = MissingLibrary FilePath String 27 | | MissingFunction String String 28 | | MissingValue String String 29 | deriving Typeable 30 | 31 | instance Show Unsupported where 32 | show (MissingLibrary name reason) 33 | = "Can't load library \"" ++ name ++ "\". " ++ reason 34 | show (MissingFunction name reason) 35 | = "Can't find \"" ++ name ++ "\" function. " ++ reason 36 | show (MissingValue name reason) 37 | = "Can't use \"" ++ name ++ "\" value. " ++ reason 38 | 39 | instance Exception Unsupported 40 | 41 | missingLibrary :: FilePath -> Unsupported 42 | missingFunction, missingValue :: String -> Unsupported 43 | missingLibrary name = MissingLibrary name "" 44 | missingFunction name = MissingFunction name "" 45 | missingValue name = MissingValue name "" 46 | 47 | missingWin32Function, missingWin32Value :: String -> String -> Unsupported 48 | missingWin32Function name reason = MissingFunction name $ doesn'tSupport ++ '\n':reason 49 | missingWin32Value name reason = MissingValue name $ doesn'tSupport ++ '\n':reason 50 | 51 | doesn'tSupport, upgradeVista, removed :: String 52 | doesn'tSupport = "Because it's not supported on this OS." 53 | upgradeVista = upgradeWindowsOS "Windows Vista" 54 | removed = "It's removed. " 55 | 56 | upgradeWindowsOS :: String -> String 57 | upgradeWindowsOS ver 58 | = "If you want to use it, please upgrade your OS to " 59 | ++ ver ++ " or higher." 60 | 61 | unsupportedIfNull :: Unsupported -> IO (Ptr a) -> IO (Ptr a) 62 | unsupportedIfNull wh act = do 63 | v <- act 64 | if v /= nullPtr then return v else throwIO wh 65 | 66 | unsupportedVal :: String -> IO Bool -> String -> a -> a 67 | unsupportedVal name checkVer reason val = unsafeLocalState $ do 68 | cv <- checkVer 69 | if cv then return val else throwIO $ MissingValue name reason 70 | 71 | -------------------------------------------------------------------------------- /System/Win32/Automation/Input/Mouse.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.Automation.Input.Mouse 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Mouse input events 12 | -} 13 | module System.Win32.Automation.Input.Mouse where 14 | import Foreign.Ptr ( Ptr ) 15 | import Foreign.Storable ( Storable(..) ) 16 | import System.Win32.Types ( LONG, ULONG_PTR ) 17 | import System.Win32.Word ( DWORD ) 18 | 19 | #include 20 | #include "winuser_compat.h" 21 | #include "alignment.h" 22 | 23 | type PMOUSEINPUT = Ptr MOUSEINPUT 24 | 25 | data MOUSEINPUT = MOUSEINPUT 26 | { dx :: LONG 27 | , dy :: LONG 28 | , mouseData :: DWORD 29 | , dwFlags :: DWORD 30 | , time :: DWORD 31 | , dwExtraInfo :: ULONG_PTR 32 | } deriving Show 33 | 34 | instance Storable MOUSEINPUT where 35 | sizeOf = const #{size MOUSEINPUT} 36 | alignment _ = #alignment MOUSEINPUT 37 | poke buf input = do 38 | (#poke MOUSEINPUT, dx) buf (dx input) 39 | (#poke MOUSEINPUT, dy) buf (dy input) 40 | (#poke MOUSEINPUT, mouseData) buf (mouseData input) 41 | (#poke MOUSEINPUT, dwFlags) buf (dwFlags input) 42 | (#poke MOUSEINPUT, time) buf (time input) 43 | (#poke MOUSEINPUT, dwExtraInfo) buf (dwExtraInfo input) 44 | peek buf = do 45 | dx' <- (#peek MOUSEINPUT, dx) buf 46 | dy' <- (#peek MOUSEINPUT, dy) buf 47 | mouseData' <- (#peek MOUSEINPUT, mouseData) buf 48 | dwFlags' <- (#peek MOUSEINPUT, dwFlags) buf 49 | time' <- (#peek MOUSEINPUT, time) buf 50 | dwExtraInfo' <- (#peek MOUSEINPUT, dwExtraInfo) buf 51 | return $ MOUSEINPUT dx' dy' mouseData' dwFlags' time' dwExtraInfo' 52 | 53 | #{enum DWORD, 54 | , xBUTTON1 = XBUTTON1 55 | , xBUTTON2 = XBUTTON2 56 | } 57 | 58 | #{enum DWORD, 59 | , mOUSEEVENTF_ABSOLUTE = MOUSEEVENTF_ABSOLUTE 60 | , mOUSEEVENTF_MOVE = MOUSEEVENTF_MOVE 61 | , mOUSEEVENTF_LEFTDOWN = MOUSEEVENTF_LEFTDOWN 62 | , mOUSEEVENTF_LEFTUP = MOUSEEVENTF_LEFTUP 63 | , mOUSEEVENTF_RIGHTDOWN = MOUSEEVENTF_RIGHTDOWN 64 | , mOUSEEVENTF_RIGHTUP = MOUSEEVENTF_RIGHTUP 65 | , mOUSEEVENTF_MIDDLEDOWN = MOUSEEVENTF_MIDDLEDOWN 66 | , mOUSEEVENTF_MIDDLEUP = MOUSEEVENTF_MIDDLEUP 67 | , mOUSEEVENTF_WHEEL = MOUSEEVENTF_WHEEL 68 | , mOUSEEVENTF_XDOWN = MOUSEEVENTF_XDOWN 69 | , mOUSEEVENTF_XUP = MOUSEEVENTF_XUP 70 | } 71 | 72 | {- 73 | , mOUSEEVENTF_VIRTUALDESK = MOUSEEVENTF_VIRTUALDESK -- I don't know why we can't find this 74 | , mOUSEEVENTF_HWHEEL = MOUSEEVENTF_HWHEEL 75 | , mOUSEEVENTF_MOVE_NOCOALESCE = MOUSEEVENTF_MOVE_NOCOALESCE 76 | -} 77 | -------------------------------------------------------------------------------- /Graphics/Win32/GDI/AlphaBlend.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : Graphics.Win32.GDI.AlphaBlend 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Provides alpha blending functionality. 12 | -} 13 | module Graphics.Win32.GDI.AlphaBlend where 14 | import Foreign.Storable ( Storable(..) ) 15 | import Foreign.Ptr ( Ptr ) 16 | import Graphics.Win32.GDI.Types ( HDC ) 17 | import System.Win32.Types ( BOOL, BYTE, UINT ) 18 | 19 | #include 20 | #include "alignment.h" 21 | ##include "windows_cconv.h" 22 | 23 | foreign import ccall unsafe "alphablend.h" 24 | c_AlphaBlend :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> PBLENDFUNCTION -> IO BOOL 25 | {- 26 | We use C wrapper function to call this API. 27 | Because foreign stacall/ccall/capi doesn't work with non-pointer user defined type. 28 | 29 | We think that capi should support that when user defined type has Storable class instance 30 | and using CTYPE pragma in the scope. 31 | 32 | {-# LANGUAGE CApiFFI #-} 33 | 34 | data {-# CTYPE "windows.h" "BLENDFUNCTION" #-} BLENDFUNCTION = 35 | 36 | foreign import capi unsafe "windows.h AlphaBlend" 37 | c_AlphaBlend :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> BLENDFUNCTION -> IO BOOL 38 | -} 39 | 40 | foreign import WINDOWS_CCONV unsafe "windows.h TransparentBlt" 41 | c_TransparentBlt :: HDC -> Int -> Int -> Int -> Int -> HDC -> Int -> Int -> Int -> Int -> UINT -> IO BOOL 42 | 43 | aC_SRC_OVER :: BYTE 44 | aC_SRC_OVER = #const AC_SRC_OVER 45 | 46 | aC_SRC_ALPHA :: BYTE 47 | aC_SRC_ALPHA = #const AC_SRC_ALPHA 48 | 49 | type PBLENDFUNCTION = Ptr BLENDFUNCTION 50 | type LPBLENDFUNCTION = Ptr BLENDFUNCTION 51 | 52 | data BLENDFUNCTION = BLENDFUNCTION 53 | { blendOp :: BYTE 54 | , blendFlags :: BYTE 55 | , sourceConstantAlpha :: BYTE 56 | , alphaFormat :: BYTE 57 | } deriving (Show) 58 | 59 | instance Storable BLENDFUNCTION where 60 | sizeOf = const #size BLENDFUNCTION 61 | alignment _ = #alignment BLENDFUNCTION 62 | poke buf func = do 63 | (#poke BLENDFUNCTION, BlendOp) buf (blendOp func) 64 | (#poke BLENDFUNCTION, BlendFlags) buf (blendFlags func) 65 | (#poke BLENDFUNCTION, SourceConstantAlpha) buf (sourceConstantAlpha func) 66 | (#poke BLENDFUNCTION, AlphaFormat) buf (alphaFormat func) 67 | 68 | peek buf = do 69 | blendOp' <- (#peek BLENDFUNCTION, BlendOp) buf 70 | blendFlags' <- (#peek BLENDFUNCTION, BlendFlags) buf 71 | sourceConstantAlpha' <- 72 | (#peek BLENDFUNCTION, SourceConstantAlpha) buf 73 | alphaFormat' <- (#peek BLENDFUNCTION, AlphaFormat) buf 74 | return $ BLENDFUNCTION blendOp' blendFlags' sourceConstantAlpha' alphaFormat' 75 | -------------------------------------------------------------------------------- /System/Win32/DebugApi/Internal.hsc: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Win32.WindowsString.DebugApi.Internal 4 | -- Copyright : (c) Esa Ilari Vuokko, 2006 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : Esa Ilari Vuokko 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- A collection of FFI declarations for using Windows DebugApi. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module System.Win32.DebugApi.Internal where 16 | 17 | import Data.Word ( Word8, Word32 ) 18 | import Foreign ( Ptr ) 19 | import System.Win32.Types ( BOOL, DWORD, HANDLE, LPTSTR ) 20 | 21 | ##include "windows_cconv.h" 22 | #include "windows.h" 23 | 24 | type PID = DWORD 25 | type TID = DWORD 26 | type DebugEventId = (PID, TID) 27 | type ForeignAddress = Word32 28 | 29 | type PHANDLE = Ptr () 30 | type THANDLE = Ptr () 31 | 32 | type ThreadInfo = (THANDLE, ForeignAddress, ForeignAddress) -- handle to thread, thread local, thread start 33 | type ImageInfo = (HANDLE, ForeignAddress, DWORD, DWORD, ForeignAddress) 34 | type ExceptionInfo = (Bool, Bool, ForeignAddress) -- First chance, continuable, address 35 | 36 | -------------------------------------------------------------------------- 37 | -- Raw imports 38 | 39 | foreign import WINDOWS_CCONV "windows.h SuspendThread" 40 | c_SuspendThread :: THANDLE -> IO DWORD 41 | 42 | foreign import WINDOWS_CCONV "windows.h ResumeThread" 43 | c_ResumeThread :: THANDLE -> IO DWORD 44 | 45 | foreign import WINDOWS_CCONV "windows.h WaitForDebugEvent" 46 | c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL 47 | 48 | foreign import WINDOWS_CCONV "windows.h ContinueDebugEvent" 49 | c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL 50 | 51 | foreign import WINDOWS_CCONV "windows.h DebugActiveProcess" 52 | c_DebugActiveProcess :: DWORD -> IO Bool 53 | 54 | -- Windows XP 55 | -- foreign import WINDOWS_CCONV "windows.h DebugActiveProcessStop" 56 | -- c_DebugActiveProcessStop :: DWORD -> IO Bool 57 | 58 | foreign import WINDOWS_CCONV "windows.h ReadProcessMemory" c_ReadProcessMemory :: 59 | PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL 60 | 61 | foreign import WINDOWS_CCONV "windows.h WriteProcessMemory" c_WriteProcessMemory :: 62 | PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL 63 | 64 | foreign import WINDOWS_CCONV "windows.h GetThreadContext" 65 | c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL 66 | 67 | foreign import WINDOWS_CCONV "windows.h SetThreadContext" 68 | c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL 69 | 70 | --foreign import WINDOWS_CCONV "windows.h GetThreadId" 71 | -- c_GetThreadId :: THANDLE -> IO TID 72 | 73 | foreign import WINDOWS_CCONV "windows.h OutputDebugStringW" 74 | c_OutputDebugString :: LPTSTR -> IO () 75 | 76 | foreign import WINDOWS_CCONV "windows.h IsDebuggerPresent" 77 | isDebuggerPresent :: IO BOOL 78 | 79 | foreign import WINDOWS_CCONV "windows.h DebugBreak" 80 | debugBreak :: IO () 81 | -------------------------------------------------------------------------------- /Graphics/Win32/GDI/Path.hs: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Graphics.Win32.GDI.Path 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Graphics.Win32.GDI.Path 21 | ( beginPath, closeFigure, endPath, fillPath, flattenPath 22 | , pathToRegion, strokeAndFillPath, strokePath, widenPath 23 | ) where 24 | 25 | import Graphics.Win32.GDI.Types 26 | import System.Win32.Types 27 | 28 | #include "windows_cconv.h" 29 | 30 | ---------------------------------------------------------------- 31 | -- Paths 32 | ---------------------------------------------------------------- 33 | 34 | -- AbortPath :: HDC -> IO () 35 | 36 | beginPath :: HDC -> IO () 37 | beginPath dc = 38 | failIfFalse_ "BeginPath" $ c_BeginPath dc 39 | foreign import WINDOWS_CCONV unsafe "windows.h BeginPath" 40 | c_BeginPath :: HDC -> IO Bool 41 | 42 | closeFigure :: HDC -> IO () 43 | closeFigure dc = 44 | failIfFalse_ "CloseFigure" $ c_CloseFigure dc 45 | foreign import WINDOWS_CCONV unsafe "windows.h CloseFigure" 46 | c_CloseFigure :: HDC -> IO Bool 47 | 48 | endPath :: HDC -> IO () 49 | endPath dc = 50 | failIfFalse_ "EndPath" $ c_EndPath dc 51 | foreign import WINDOWS_CCONV unsafe "windows.h EndPath" 52 | c_EndPath :: HDC -> IO Bool 53 | 54 | fillPath :: HDC -> IO () 55 | fillPath dc = 56 | failIfFalse_ "FillPath" $ c_FillPath dc 57 | foreign import WINDOWS_CCONV unsafe "windows.h FillPath" 58 | c_FillPath :: HDC -> IO Bool 59 | 60 | flattenPath :: HDC -> IO () 61 | flattenPath dc = 62 | failIfFalse_ "FlattenPath" $ c_FlattenPath dc 63 | foreign import WINDOWS_CCONV unsafe "windows.h FlattenPath" 64 | c_FlattenPath :: HDC -> IO Bool 65 | 66 | pathToRegion :: HDC -> IO HRGN 67 | pathToRegion dc = do 68 | ptr <- failIfNull "PathToRegion" $ c_PathToRegion dc 69 | newForeignHANDLE ptr 70 | foreign import WINDOWS_CCONV unsafe "windows.h PathToRegion" 71 | c_PathToRegion :: HDC -> IO PRGN 72 | 73 | strokeAndFillPath :: HDC -> IO () 74 | strokeAndFillPath dc = 75 | failIfFalse_ "StrokeAndFillPath" $ c_StrokeAndFillPath dc 76 | foreign import WINDOWS_CCONV unsafe "windows.h StrokeAndFillPath" 77 | c_StrokeAndFillPath :: HDC -> IO Bool 78 | 79 | strokePath :: HDC -> IO () 80 | strokePath dc = 81 | failIfFalse_ "StrokePath" $ c_StrokePath dc 82 | foreign import WINDOWS_CCONV unsafe "windows.h StrokePath" 83 | c_StrokePath :: HDC -> IO Bool 84 | 85 | widenPath :: HDC -> IO () 86 | widenPath dc = 87 | failIfFalse_ "WidenPath" $ c_WidenPath dc 88 | foreign import WINDOWS_CCONV unsafe "windows.h WidenPath" 89 | c_WidenPath :: HDC -> IO Bool 90 | 91 | ---------------------------------------------------------------- 92 | -- End 93 | ---------------------------------------------------------------- 94 | -------------------------------------------------------------------------------- /include/winuser_compat.h: -------------------------------------------------------------------------------- 1 | #ifndef WINUSER_COMPAT_H 2 | #define WINUSER_COMPAT_H 3 | 4 | /* 5 | * winuser.h is missing some includes in MinGW, which was shipped with the 32-bit 6 | * Windows version of GHC prior to the 7.10.3 release. 7 | */ 8 | #if defined(x86_64_HOST_ARCH) || \ 9 | __GLASGOW_HASKELL__ >= 711 || \ 10 | (__GLASGOW_HASKELL__ == 710 && \ 11 | defined(__GLASGOW_HASKELL_PATCHLEVEL1__) && \ 12 | __GLASGOW_HASKELL_PATCHLEVEL1__ >= 2) 13 | #else 14 | // Some declarations from winuser.h that we need in Win32 15 | # include 16 | 17 | #define VK_XBUTTON1 0x05 18 | #define VK_XBUTTON2 0x06 19 | 20 | #define VK_BROWSER_BACK 0xA6 21 | #define VK_BROWSER_FORWARD 0xA7 22 | #define VK_BROWSER_REFRESH 0xA8 23 | #define VK_BROWSER_STOP 0xA9 24 | #define VK_BROWSER_SEARCH 0xAA 25 | #define VK_BROWSER_FAVORITES 0xAB 26 | #define VK_BROWSER_HOME 0xAC 27 | #define VK_VOLUME_MUTE 0xAD 28 | #define VK_VOLUME_DOWN 0xAE 29 | #define VK_VOLUME_UP 0xAF 30 | #define VK_MEDIA_NEXT_TRACK 0xB0 31 | #define VK_MEDIA_PREV_TRACK 0xB1 32 | #define VK_MEDIA_STOP 0xB2 33 | #define VK_MEDIA_PLAY_PAUSE 0xB3 34 | #define VK_LAUNCH_MAIL 0xB4 35 | #define VK_LAUNCH_MEDIA_SELECT 0xB5 36 | #define VK_LAUNCH_APP1 0xB6 37 | #define VK_LAUNCH_APP2 0xB7 38 | 39 | #define VK_OEM_PLUS 0xBB 40 | #define VK_OEM_COMMA 0xBC 41 | #define VK_OEM_MINUS 0xBD 42 | #define VK_OEM_PERIOD 0xBE 43 | #define VK_OEM_102 0xE2 44 | 45 | #define VK_PACKET 0xE7 46 | 47 | #define LWA_COLORKEY 0x00000001 48 | #define LWA_ALPHA 0x00000002 49 | 50 | #define ULW_COLORKEY 0x00000001 51 | #define ULW_ALPHA 0x00000002 52 | #define ULW_OPAQUE 0x00000004 53 | #define ULW_EX_NORESIZE 0x00000008 54 | 55 | #define AW_HOR_POSITIVE 0x00000001 56 | #define AW_HOR_NEGATIVE 0x00000002 57 | #define AW_VER_POSITIVE 0x00000004 58 | #define AW_VER_NEGATIVE 0x00000008 59 | #define AW_CENTER 0x00000010 60 | #define AW_HIDE 0x00010000 61 | #define AW_ACTIVATE 0x00020000 62 | #define AW_SLIDE 0x00040000 63 | #define AW_BLEND 0x00080000 64 | 65 | #define INPUT_MOUSE 0 66 | #define INPUT_KEYBOARD 1 67 | #define INPUT_HARDWARE 2 68 | 69 | #define KEYEVENTF_UNICODE 0x0004 70 | #define KEYEVENTF_SCANCODE 0x0008 71 | 72 | #define MOUSEEVENTF_XDOWN 0x0080 73 | #define MOUSEEVENTF_XUP 0x0100 74 | 75 | #define XBUTTON1 0x0001 76 | #define XBUTTON2 0x0002 77 | 78 | #if __GLASGOW_HASKELL__ < 710 79 | typedef struct tagMOUSEINPUT { 80 | LONG dx; 81 | LONG dy; 82 | DWORD mouseData; 83 | DWORD dwFlags; 84 | DWORD time; 85 | ULONG_PTR dwExtraInfo; 86 | } MOUSEINPUT, *PMOUSEINPUT, *LPMOUSEINPUT; 87 | 88 | typedef struct tagKEYBDINPUT { 89 | WORD wVk; 90 | WORD wScan; 91 | DWORD dwFlags; 92 | DWORD time; 93 | ULONG_PTR dwExtraInfo; 94 | } KEYBDINPUT, *PKEYBDINPUT, *LPKEYBDINPUT; 95 | 96 | typedef struct tagHARDWAREINPUT { 97 | DWORD uMsg; 98 | WORD wParamL; 99 | WORD wParamH; 100 | } HARDWAREINPUT, *PHARDWAREINPUT, *LPHARDWAREINPUT; 101 | 102 | typedef struct tagINPUT { 103 | DWORD type; 104 | union { 105 | MOUSEINPUT mi; 106 | KEYBDINPUT ki; 107 | HARDWAREINPUT hi; 108 | } DUMMYUNIONNAME; 109 | } INPUT, *PINPUT, *LPINPUT; 110 | #endif 111 | 112 | #endif /* GHC Version check */ 113 | #endif /* WINUSER_COMPAT_H */ 114 | -------------------------------------------------------------------------------- /include/winnls_compat.h: -------------------------------------------------------------------------------- 1 | /* The version of winnls.h provided by the version of MSYS2 included with 2 | * versions of GHC before GHC 7.10 excludes certain components introduced with 3 | * Windows Vista. 4 | */ 5 | 6 | #ifndef WINNLS_COMPAT_H 7 | #define WINNLS_COMPAT_H 8 | 9 | #if __GLASGOW_HASKELL__ < 710 10 | // Locale information constants 11 | #define LOCALE_IGEOID 0x0000005b 12 | #define LOCALE_SCONSOLEFALLBACKNAME 0x0000006e 13 | #define LOCALE_SDURATION 0x0000005d 14 | #define LOCALE_SENGLISHCOUNTRYNAME 0x00001002 15 | #define LOCALE_SENGLISHLANGUAGENAME 0x00001001 16 | #define LOCALE_SISO3166CTRYNAME2 0x00000068 17 | #define LOCALE_SISO639LANGNAME2 0x00000067 18 | #define LOCALE_SKEYBOARDSTOINSTALL 0x0000005e 19 | #define LOCALE_SNAME 0x0000005c 20 | #define LOCALE_SNAN 0x00000069 21 | #define LOCALE_SNATIVECOUNTRYNAME 0x00000008 22 | #define LOCALE_SNEGINFINITY 0x0000006b 23 | #define LOCALE_SPARENT 0x0000006d 24 | #define LOCALE_SPOSINFINITY 0x0000006a 25 | #define LOCALE_SSCRIPTS 0x0000006c 26 | #define LOCALE_SSHORTESTDAYNAME1 0x00000060 27 | #define LOCALE_SSHORTESTDAYNAME2 0x00000061 28 | #define LOCALE_SSHORTESTDAYNAME3 0x00000062 29 | #define LOCALE_SSHORTESTDAYNAME4 0x00000063 30 | #define LOCALE_SSHORTESTDAYNAME5 0x00000064 31 | #define LOCALE_SSHORTESTDAYNAME6 0x00000065 32 | #define LOCALE_SSHORTESTDAYNAME7 0x00000066 33 | // Locale map flag constants 34 | #define LINGUISTIC_IGNORECASE 0x00000010 35 | #define LINGUISTIC_IGNOREDIACRITIC 0x00000020 36 | #define NORM_LINGUISTIC_CASING 0x08000000 37 | // Locale enumeration flag constants 38 | #define LOCALE_ALL 0 39 | #define LOCALE_ALTERNATE_SORTS 0x00000004 40 | #define LOCALE_REPLACEMENT 0x00000008 41 | #define LOCALE_SUPPLEMENTAL 0x00000002 42 | #define LOCALE_WINDOWS 0x00000001 43 | // Other 44 | WINBASEAPI WINBOOL WINAPI IsValidLocaleName (LPCWSTR lpLocaleName); 45 | #endif 46 | 47 | #if __GLASGOW_HASKELL__ < 710 && defined(i386_HOST_ARCH) 48 | // Locale information constants 49 | #define LOCALE_IDEFAULTMACCODEPAGE 0x00001011 50 | // Other 51 | typedef struct _nlsversioninfoex { 52 | DWORD dwNLSVersionInfoSize; 53 | DWORD dwNLSVersion; 54 | DWORD dwDefinedVersion; 55 | DWORD dwEffectiveId; 56 | GUID guidCustomVersion; 57 | } NLSVERSIONINFOEX, *LPNLSVERSIONINFOEX; 58 | 59 | WINBASEAPI int WINAPI GetLocaleInfoEx( 60 | LPCWSTR lpLocaleName, 61 | LCTYPE LCType, 62 | LPWSTR lpLCData, 63 | int cchData 64 | ); 65 | 66 | WINBASEAPI WINBOOL WINAPI GetNLSVersionEx( 67 | NLS_FUNCTION function, 68 | LPCWSTR lpLocaleName, 69 | LPNLSVERSIONINFOEX lpVersionInformation 70 | ); 71 | 72 | WINBASEAPI int WINAPI LCMapStringEx( 73 | LPCWSTR lpLocaleName, 74 | DWORD dwMapFlags, 75 | LPCWSTR lpSrcStr, 76 | int cchSrc, 77 | LPWSTR lpDestStr, 78 | int cchDest, 79 | LPNLSVERSIONINFO lpVersionInformation, 80 | LPVOID lpReserved, 81 | LPARAM lParam 82 | ); 83 | 84 | 85 | WINBASEAPI int WINAPI GetTimeFormatEx( 86 | LPCWSTR lpLocaleName, 87 | DWORD dwFlags, 88 | const SYSTEMTIME *lpTime, 89 | LPCWSTR lpFormat, 90 | LPWSTR lpTimeStr, 91 | int cchTime 92 | ); 93 | 94 | WINBASEAPI int WINAPI GetSystemDefaultLocaleName( 95 | LPWSTR lpLocaleName, 96 | int cchLocaleName 97 | ); 98 | 99 | WINBASEAPI int WINAPI GetUserDefaultLocaleName( 100 | LPWSTR lpLocaleName, 101 | int cchLocaleName 102 | ); 103 | #endif 104 | 105 | #endif /* #ifndef WINNLS_COMPAT_H */ 106 | -------------------------------------------------------------------------------- /System/Win32/HardLink.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.HardLink 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Handling hard link using Win32 API. [NTFS only] 12 | 13 | Note: You should worry about file system type when use this module's function in your application: 14 | 15 | * NTFS only supports this functionality. 16 | 17 | * ReFS doesn't support hard link currently. 18 | -} 19 | module System.Win32.HardLink 20 | ( createHardLink 21 | , createHardLink' 22 | ) where 23 | 24 | import System.Win32.HardLink.Internal 25 | import System.Win32.File ( failIfFalseWithRetry_ ) 26 | import System.Win32.String ( withTString ) 27 | import System.Win32.Types ( nullPtr ) 28 | 29 | #include "windows_cconv.h" 30 | 31 | -- | NOTE: createHardLink is /flipped arguments/ to provide compatibility for Unix. 32 | -- 33 | -- If you want to create hard link by Windows way, use 'createHardLink'' instead. 34 | createHardLink :: FilePath -- ^ Target file path 35 | -> FilePath -- ^ Hard link name 36 | -> IO () 37 | createHardLink = flip createHardLink' 38 | 39 | createHardLink' :: FilePath -- ^ Hard link name 40 | -> FilePath -- ^ Target file path 41 | -> IO () 42 | createHardLink' link target = 43 | withTString target $ \c_target -> 44 | withTString link $ \c_link -> 45 | failIfFalseWithRetry_ (unwords ["CreateHardLinkW",show link,show target]) $ 46 | c_CreateHardLink c_link c_target nullPtr 47 | 48 | 49 | {- 50 | -- We plan to check file system type internally. 51 | 52 | -- We are thinking about API design, currently... 53 | data VolumeInformation = VolumeInformation 54 | { volumeName :: String 55 | , volumeSerialNumber :: DWORD 56 | , maximumComponentLength :: DWORD 57 | , fileSystemFlags :: DWORD 58 | , fileSystemName :: String 59 | } deriving Show 60 | 61 | getVolumeInformation :: Maybe String -> IO VolumeInformation 62 | getVolumeInformation drive = 63 | maybeWith withTString drive $ \c_drive -> 64 | withTStringBufferLen 256 $ \(vnBuf, vnLen) -> 65 | alloca $ \serialNum -> 66 | alloca $ \maxLen -> 67 | alloca $ \fsFlags -> 68 | withTStringBufferLen 256 $ \(fsBuf, fsLen) -> do 69 | failIfFalse_ (unwords ["GetVolumeInformationW", drive]) $ 70 | c_GetVolumeInformation c_drive vnBuf (fromIntegral vnLen) 71 | serialNum maxLen fsFlags 72 | fsBuf (fromIntegral fsLen) 73 | return VolumeInformation 74 | <*> peekTString vnBuf 75 | <*> peek serialNum 76 | <*> peek maxLen 77 | <*> peek fsFlags 78 | <*> peekTString fsBuf 79 | 80 | -- Which is better? 81 | getVolumeFileType :: String -> IO String 82 | getVolumeFileType drive = fileSystemName <$> getVolumeInformation drive 83 | 84 | getVolumeFileType :: String -> IO String 85 | getVolumeFileType drive = 86 | withTString drive $ \c_drive -> 87 | withTStringBufferLen 256 $ \(buf, len) -> do 88 | failIfFalse_ (unwords ["GetVolumeInformationW", drive]) $ 89 | c_GetVolumeInformation c_drive nullPtr 0 nullPtr nullPtr nullPtr buf (fromIntegral len) 90 | peekTString buf 91 | 92 | foreign import WINDOWS_CCONV unsafe "windows.h GetVolumeInformationW" 93 | c_GetVolumeInformation :: LPCTSTR -> LPTSTR -> DWORD -> LPDWORD -> LPDWORD -> LPDWORD -> LPTSTR -> DWORD -> IO BOOL 94 | -} 95 | -------------------------------------------------------------------------------- /Graphics/Win32/GDI/Pen.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Graphics.Win32.GDI.Pen 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Graphics.Win32.GDI.Pen where 21 | 22 | import System.Win32.Types 23 | import Graphics.Win32.GDI.Types 24 | 25 | ##include "windows_cconv.h" 26 | 27 | #include 28 | 29 | ---------------------------------------------------------------- 30 | -- Stock Objects 31 | ---------------------------------------------------------------- 32 | 33 | type StockPen = INT 34 | 35 | #{enum StockPen, 36 | , wHITE_PEN = WHITE_PEN 37 | , bLACK_PEN = BLACK_PEN 38 | , nULL_PEN = NULL_PEN 39 | } 40 | 41 | getStockPen :: StockPen -> IO HPEN 42 | getStockPen stockpen = 43 | failIfNull "GetStockPen" $ c_GetStockPen stockpen 44 | foreign import WINDOWS_CCONV unsafe "windows.h GetStockObject" 45 | c_GetStockPen :: StockPen -> IO HPEN 46 | 47 | deletePen :: HPEN -> IO () 48 | deletePen pen = 49 | failIfFalse_ "DeletePen" $ c_DeletePen pen 50 | foreign import WINDOWS_CCONV unsafe "windows.h DeleteObject" 51 | c_DeletePen :: HPEN -> IO Bool 52 | 53 | ---------------------------------------------------------------- 54 | -- Creating pens 55 | ---------------------------------------------------------------- 56 | 57 | type PenStyle = INT 58 | 59 | #{enum PenStyle, 60 | , pS_SOLID = PS_SOLID // default 61 | , pS_DASH = PS_DASH // ------- 62 | , pS_DOT = PS_DOT // ....... 63 | , pS_DASHDOT = PS_DASHDOT // _._._._ 64 | , pS_DASHDOTDOT = PS_DASHDOTDOT // _.._.._ 65 | , pS_NULL = PS_NULL 66 | , pS_INSIDEFRAME = PS_INSIDEFRAME 67 | , pS_USERSTYLE = PS_USERSTYLE 68 | , pS_ALTERNATE = PS_ALTERNATE 69 | , pS_STYLE_MASK = PS_STYLE_MASK // all the above 70 | } 71 | 72 | #{enum PenStyle, 73 | , pS_ENDCAP_ROUND = PS_ENDCAP_ROUND // default 74 | , pS_ENDCAP_SQUARE = PS_ENDCAP_SQUARE 75 | , pS_ENDCAP_FLAT = PS_ENDCAP_FLAT 76 | , pS_ENDCAP_MASK = PS_ENDCAP_MASK // all the above 77 | } 78 | 79 | #{enum PenStyle, 80 | , pS_JOIN_ROUND = PS_JOIN_ROUND // default 81 | , pS_JOIN_BEVEL = PS_JOIN_BEVEL 82 | , pS_JOIN_MITER = PS_JOIN_MITER 83 | } 84 | -- , pS_JOIN_MASK = PS_JOIN_MASK 85 | {- 86 | If PS_JOIN_MASK is not defined with your GNU Windows32 header files, 87 | you'll have to define it. 88 | -} 89 | 90 | #{enum PenStyle, 91 | , pS_COSMETIC = PS_COSMETIC // default 92 | , pS_GEOMETRIC = PS_GEOMETRIC 93 | , pS_TYPE_MASK = PS_TYPE_MASK // all the above 94 | } 95 | 96 | createPen :: PenStyle -> INT -> COLORREF -> IO HPEN 97 | createPen style n color = 98 | failIfNull "CreatePen" $ c_CreatePen style n color 99 | foreign import WINDOWS_CCONV unsafe "windows.h CreatePen" 100 | c_CreatePen :: PenStyle -> INT -> COLORREF -> IO HPEN 101 | 102 | -- Not very well supported on Win'95 103 | -- %fun NullHANDLE ExtCreatePen :: PenStyle -> INT -> LOGBRUSH -> [StyleBit] -> IO HPEN 104 | 105 | -- ToDo: CreatePenIndirect 106 | 107 | ---------------------------------------------------------------- 108 | -- End 109 | ---------------------------------------------------------------- 110 | -------------------------------------------------------------------------------- /System/Win32/SymbolicLink.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.SymbolicLink 4 | Copyright : 2012 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Handling symbolic link using Win32 API. [Vista of later and desktop app only] 12 | 13 | Note: When using the createSymbolicLink* functions without the 14 | SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE flag, you should worry about UAC 15 | (User Account Control) when use this module's function in your application: 16 | 17 | * require to use 'Run As Administrator' to run your application. 18 | 19 | * or modify your application's manifest file to add 20 | \. 21 | 22 | Starting from Windows 10 version 1703 (Creators Update), after enabling 23 | Developer Mode, users can create symbolic links without requiring the 24 | Administrator privilege in the current process. Supply a 'True' flag in 25 | addition to the target and link name to enable this behavior. 26 | -} 27 | module System.Win32.SymbolicLink 28 | ( SymbolicLinkFlags 29 | , sYMBOLIC_LINK_FLAG_FILE 30 | , sYMBOLIC_LINK_FLAG_DIRECTORY 31 | , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 32 | , createSymbolicLink 33 | , createSymbolicLink' 34 | , createSymbolicLinkFile 35 | , createSymbolicLinkDirectory 36 | ) where 37 | 38 | import System.Win32.SymbolicLink.Internal 39 | import Data.Bits ((.|.)) 40 | import System.Win32.Types 41 | import System.Win32.File ( failIfFalseWithRetry_ ) 42 | 43 | ##include "windows_cconv.h" 44 | 45 | 46 | -- | createSymbolicLink* functions don't check that file is exist or not. 47 | -- 48 | -- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatibility for Unix, 49 | -- except 'createSymbolicLink''. 50 | -- 51 | -- If you want to create symbolic link by Windows way, use 'createSymbolicLink'' instead. 52 | createSymbolicLink :: FilePath -- ^ Target file path 53 | -> FilePath -- ^ Symbolic link name 54 | -> SymbolicLinkFlags -> IO () 55 | createSymbolicLink = flip createSymbolicLink' 56 | 57 | createSymbolicLinkFile :: FilePath -- ^ Target file path 58 | -> FilePath -- ^ Symbolic link name 59 | -> Bool -- ^ Create the symbolic link with the unprivileged mode 60 | -> IO () 61 | createSymbolicLinkFile target link unprivileged = 62 | createSymbolicLink' 63 | link 64 | target 65 | ( if unprivileged 66 | then sYMBOLIC_LINK_FLAG_FILE .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 67 | else sYMBOLIC_LINK_FLAG_FILE 68 | ) 69 | 70 | createSymbolicLinkDirectory :: FilePath -- ^ Target file path 71 | -> FilePath -- ^ Symbolic link name 72 | -> Bool -- ^ Create the symbolic link with the unprivileged mode 73 | -> IO () 74 | createSymbolicLinkDirectory target link unprivileged = 75 | createSymbolicLink' 76 | link 77 | target 78 | ( if unprivileged 79 | then 80 | sYMBOLIC_LINK_FLAG_DIRECTORY 81 | .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 82 | else sYMBOLIC_LINK_FLAG_DIRECTORY 83 | ) 84 | 85 | createSymbolicLink' :: FilePath -- ^ Symbolic link name 86 | -> FilePath -- ^ Target file path 87 | -> SymbolicLinkFlags -> IO () 88 | createSymbolicLink' link target flag = do 89 | withTString link $ \c_link -> 90 | withTString target $ \c_target -> 91 | failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $ 92 | c_CreateSymbolicLink c_link c_target flag 93 | 94 | -------------------------------------------------------------------------------- /System/Win32/Encoding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.Encoding 4 | Copyright : 2012 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Enocode/Decode mutibyte character using Win32 API. 12 | -} 13 | 14 | module System.Win32.Encoding 15 | ( getCurrentCodePage 16 | , encodeMultiByte 17 | , encodeMultiByteIO 18 | , decodeMultiByte 19 | , decodeMultiByteIO 20 | , wideCharToMultiByte 21 | , multiByteToWideChar 22 | ) where 23 | 24 | import Foreign.C.Types (CInt(..)) 25 | import Foreign.C.String (peekCAStringLen, withCWStringLen) 26 | import Foreign.Marshal.Array (allocaArray) 27 | import Foreign.Marshal.Unsafe (unsafeLocalState) 28 | import System.Win32.Console 29 | import System.Win32.NLS 30 | import System.Win32.Types 31 | 32 | #include "windows_cconv.h" 33 | 34 | -- note CodePage = UInt which might not work on Win64. But the Win32 package 35 | -- also has this issue. 36 | getCurrentCodePage :: IO DWORD 37 | getCurrentCodePage = do 38 | conCP <- getConsoleCP 39 | if conCP > 0 40 | then return conCP 41 | else getACP 42 | 43 | -- | The "System.IO" output functions (e.g., `putStr`) don't 44 | -- automatically convert to multibyte string on Windows, so this 45 | -- function is provided to make the conversion from a Unicode string 46 | -- in the given code page to a proper multibyte string. To get the 47 | -- code page for the console, use `getCurrentCodePage`. 48 | -- 49 | encodeMultiByte :: CodePage -> String -> String 50 | encodeMultiByte cp = unsafeLocalState . encodeMultiByteIO cp 51 | 52 | encodeMultiByteIO :: CodePage -> String -> IO String 53 | encodeMultiByteIO _ "" = return "" 54 | -- WideCharToMultiByte doesn't handle empty strings 55 | encodeMultiByteIO cp wstr = 56 | withCWStringLen wstr $ \(cwstr,len) -> do 57 | mbchars' <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte 58 | cp 59 | 0 60 | cwstr 61 | (fromIntegral len) 62 | nullPtr 0 63 | nullPtr nullPtr 64 | -- mbchar' is the length of buffer required 65 | allocaArray (fromIntegral mbchars') $ \mbstr -> do 66 | mbchars <- failIfZero "WideCharToMultiByte" $ wideCharToMultiByte 67 | cp 68 | 0 69 | cwstr 70 | (fromIntegral len) 71 | mbstr mbchars' 72 | nullPtr nullPtr 73 | peekCAStringLen (mbstr,fromIntegral mbchars) -- converts [Char] to UTF-16 74 | 75 | foreign import WINDOWS_CCONV "WideCharToMultiByte" 76 | wideCharToMultiByte 77 | :: CodePage 78 | -> DWORD -- dwFlags, 79 | -> LPCWSTR -- lpWideCharStr 80 | -> CInt -- cchWideChar 81 | -> LPSTR -- lpMultiByteStr 82 | -> CInt -- cbMultiByte 83 | -> LPCSTR -- lpMultiByteStr 84 | -> LPBOOL -- lpbFlags 85 | -> IO CInt 86 | 87 | -- | The "System.IO" input functions (e.g. `getLine`) don't 88 | -- automatically convert to Unicode, so this function is provided to 89 | -- make the conversion from a multibyte string in the given code page 90 | -- to a proper Unicode string. To get the code page for the console, 91 | -- use `getCurrentCodePage`. 92 | decodeMultiByte :: CodePage -> String -> String 93 | decodeMultiByte cp = unsafeLocalState . decodeMultiByteIO cp 94 | 95 | -- | Because of `stringToUnicode` is unclear name, we use `decodeMultiByteIO` 96 | -- for alias of `stringToUnicode`. 97 | decodeMultiByteIO :: CodePage -> String -> IO String 98 | decodeMultiByteIO = stringToUnicode 99 | {-# INLINE decodeMultiByteIO #-} 100 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/SymbolicLink.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.SymbolicLink 4 | Copyright : 2012 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Handling symbolic link using Win32 API. [Vista of later and desktop app only] 12 | 13 | Note: When using the createSymbolicLink* functions without the 14 | SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE flag, you should worry about UAC 15 | (User Account Control) when use this module's function in your application: 16 | 17 | * require to use 'Run As Administrator' to run your application. 18 | 19 | * or modify your application's manifect file to add 20 | \. 21 | 22 | Starting from Windows 10 version 1703 (Creators Update), after enabling 23 | Developer Mode, users can create symbolic links without requiring the 24 | Administrator privilege in the current process. Supply a 'True' flag in 25 | addition to the target and link name to enable this behavior. 26 | -} 27 | module System.Win32.WindowsString.SymbolicLink 28 | ( SymbolicLinkFlags 29 | , sYMBOLIC_LINK_FLAG_FILE 30 | , sYMBOLIC_LINK_FLAG_DIRECTORY 31 | , sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 32 | , createSymbolicLink 33 | , createSymbolicLink' 34 | , createSymbolicLinkFile 35 | , createSymbolicLinkDirectory 36 | ) where 37 | 38 | import System.Win32.SymbolicLink.Internal 39 | import Data.Bits ((.|.)) 40 | import System.Win32.WindowsString.Types 41 | import System.Win32.WindowsString.File ( failIfFalseWithRetry_ ) 42 | import System.OsPath.Windows 43 | import Unsafe.Coerce (unsafeCoerce) 44 | 45 | ##include "windows_cconv.h" 46 | 47 | -- | createSymbolicLink* functions don't check that file is exist or not. 48 | -- 49 | -- NOTE: createSymbolicLink* functions are /flipped arguments/ to provide compatibility for Unix, 50 | -- except 'createSymbolicLink''. 51 | -- 52 | -- If you want to create symbolic link by Windows way, use 'createSymbolicLink'' instead. 53 | createSymbolicLink :: WindowsPath -- ^ Target file path 54 | -> WindowsPath -- ^ Symbolic link name 55 | -> SymbolicLinkFlags -> IO () 56 | createSymbolicLink = flip createSymbolicLink' 57 | 58 | createSymbolicLinkFile :: WindowsPath -- ^ Target file path 59 | -> WindowsPath -- ^ Symbolic link name 60 | -> Bool -- ^ Create the symbolic link with the unprivileged mode 61 | -> IO () 62 | createSymbolicLinkFile target link unprivileged = 63 | createSymbolicLink' 64 | link 65 | target 66 | ( if unprivileged 67 | then sYMBOLIC_LINK_FLAG_FILE .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 68 | else sYMBOLIC_LINK_FLAG_FILE 69 | ) 70 | 71 | createSymbolicLinkDirectory :: WindowsPath -- ^ Target file path 72 | -> WindowsPath -- ^ Symbolic link name 73 | -> Bool -- ^ Create the symbolic link with the unprivileged mode 74 | -> IO () 75 | createSymbolicLinkDirectory target link unprivileged = 76 | createSymbolicLink' 77 | link 78 | target 79 | ( if unprivileged 80 | then 81 | sYMBOLIC_LINK_FLAG_DIRECTORY 82 | .|. sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 83 | else sYMBOLIC_LINK_FLAG_DIRECTORY 84 | ) 85 | 86 | createSymbolicLink' :: WindowsPath -- ^ Symbolic link name 87 | -> WindowsPath -- ^ Target file path 88 | -> SymbolicLinkFlags -> IO () 89 | createSymbolicLink' link target flag = do 90 | withTString link $ \c_link -> 91 | withTString target $ \c_target -> 92 | failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show link,show target]) $ 93 | c_CreateSymbolicLink c_link c_target (unsafeCoerce flag) 94 | 95 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/Info.hsc: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Win32.Info 4 | -- Copyright : (c) Alastair Reid, 1997-2003 5 | -- License : BSD-style (see the file libraries/base/LICENSE) 6 | -- 7 | -- Maintainer : Esa Ilari Vuokko 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- A collection of FFI declarations for interfacing with Win32. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module System.Win32.WindowsString.Info 16 | ( module System.Win32.WindowsString.Info 17 | , module System.Win32.Info 18 | ) where 19 | 20 | import System.Win32.Info.Internal 21 | import System.Win32.Info hiding ( 22 | getSystemDirectory 23 | , getWindowsDirectory 24 | , getCurrentDirectory 25 | , getTemporaryDirectory 26 | , getFullPathName 27 | , getLongPathName 28 | , getShortPathName 29 | , searchPath 30 | , getUserName 31 | ) 32 | import Control.Exception (catch) 33 | import Foreign.Marshal.Alloc (alloca) 34 | import Foreign.Marshal.Utils (with, maybeWith) 35 | import Foreign.Marshal.Array (allocaArray) 36 | import Foreign.Ptr (nullPtr) 37 | import Foreign.Storable (Storable(..)) 38 | import System.IO.Error (isDoesNotExistError) 39 | import System.Win32.WindowsString.Types (failIfFalse_, peekTStringLen, withTString, try) 40 | import System.OsPath.Windows 41 | 42 | #if !MIN_VERSION_base(4,6,0) 43 | import Prelude hiding (catch) 44 | #endif 45 | 46 | ##include "windows_cconv.h" 47 | 48 | #include 49 | #include "alignment.h" 50 | 51 | ---------------------------------------------------------------- 52 | -- Standard Directories 53 | ---------------------------------------------------------------- 54 | 55 | getSystemDirectory :: IO WindowsString 56 | getSystemDirectory = try "GetSystemDirectory" c_getSystemDirectory 512 57 | 58 | getWindowsDirectory :: IO WindowsString 59 | getWindowsDirectory = try "GetWindowsDirectory" c_getWindowsDirectory 512 60 | 61 | getCurrentDirectory :: IO WindowsString 62 | getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512 63 | 64 | getTemporaryDirectory :: IO WindowsString 65 | getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512 66 | 67 | getFullPathName :: WindowsPath -> IO WindowsPath 68 | getFullPathName name = do 69 | withTString name $ \ c_name -> 70 | try "getFullPathName" 71 | (\buf len -> c_GetFullPathName c_name len buf nullPtr) 512 72 | 73 | getLongPathName :: WindowsPath -> IO WindowsPath 74 | getLongPathName name = do 75 | withTString name $ \ c_name -> 76 | try "getLongPathName" 77 | (c_GetLongPathName c_name) 512 78 | 79 | getShortPathName :: WindowsPath -> IO WindowsPath 80 | getShortPathName name = do 81 | withTString name $ \ c_name -> 82 | try "getShortPathName" 83 | (c_GetShortPathName c_name) 512 84 | 85 | searchPath :: Maybe WindowsString -> WindowsPath -> Maybe WindowsString -> IO (Maybe WindowsPath) 86 | searchPath path filename ext = 87 | maybe ($ nullPtr) withTString path $ \p_path -> 88 | withTString filename $ \p_filename -> 89 | maybeWith withTString ext $ \p_ext -> 90 | alloca $ \ppFilePart -> (do 91 | s <- try "searchPath" (\buf len -> c_SearchPath p_path p_filename p_ext 92 | len buf ppFilePart) 512 93 | return (Just s)) 94 | `catch` \e -> if isDoesNotExistError e 95 | then return Nothing 96 | else ioError e 97 | 98 | ---------------------------------------------------------------- 99 | -- User name 100 | ---------------------------------------------------------------- 101 | 102 | -- %fun GetUserName :: IO String 103 | 104 | getUserName :: IO WindowsString 105 | getUserName = 106 | allocaArray 512 $ \ c_str -> 107 | with 512 $ \ c_len -> do 108 | failIfFalse_ "GetUserName" $ c_GetUserName c_str c_len 109 | len <- peek c_len 110 | peekTStringLen (c_str, fromIntegral len - 1) 111 | 112 | ---------------------------------------------------------------- 113 | -- End 114 | ---------------------------------------------------------------- 115 | -------------------------------------------------------------------------------- /Graphics/Win32/Window/IMM.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : Graphics.Win32.Window.IMM 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | An FFI binding to the IMM (Input Method Manager) part of the Win32 API. 12 | -} 13 | module Graphics.Win32.Window.IMM where 14 | import Foreign.Marshal.Alloc ( alloca ) 15 | import Foreign.Marshal.Utils ( fromBool ) 16 | import Foreign.Ptr ( Ptr ) 17 | import Foreign.Storable ( peek ) 18 | import Graphics.Win32.GDI.Types ( HWND ) 19 | import Graphics.Win32.Key ( VKey ) 20 | import System.Win32.Types ( UINT, DWORD, LPDWORD, BOOL, failIfFalse_ ) 21 | 22 | #include 23 | ##include "windows_cconv.h" 24 | 25 | type HIMC = Ptr () 26 | 27 | foreign import WINDOWS_CCONV "windows.h ImmGetContext" 28 | immGetContext :: HWND -> IO HIMC 29 | 30 | foreign import WINDOWS_CCONV "windows.h ImmGetOpenStatus" 31 | immGetOpenStatus :: HIMC -> IO BOOL 32 | 33 | immSetOpenStatus :: HIMC -> BOOL -> IO () 34 | immSetOpenStatus imc flg = 35 | failIfFalse_ (unwords ["ImmSetOpenStatus", show imc, show flg]) 36 | $ c_ImmSetOpenStatus imc (fromBool flg) 37 | 38 | foreign import WINDOWS_CCONV "windows.h ImmSetOpenStatus" 39 | c_ImmSetOpenStatus :: HIMC -> UINT -> IO BOOL 40 | 41 | 42 | data IMEMode = IMEMode DWORD DWORD 43 | 44 | immGetConversionStatus :: HIMC -> IO IMEMode 45 | immGetConversionStatus imc = 46 | alloca $ \lpConv -> 47 | alloca $ \lpStnc -> do 48 | failIfFalse_ (unwords ["ImmGetConversionStatus", show imc, show lpConv, show lpStnc]) $ 49 | c_ImmGetConversionStatus imc lpConv lpStnc 50 | conv <- peek lpConv 51 | stnc <- peek lpStnc 52 | return $ IMEMode conv stnc 53 | 54 | foreign import WINDOWS_CCONV "windows.h ImmGetConversionStatus" 55 | c_ImmGetConversionStatus :: HIMC -> LPDWORD -> LPDWORD -> IO BOOL 56 | 57 | immSetConversionStatus :: HIMC -> IMEMode -> IO () 58 | immSetConversionStatus imc (IMEMode conv stnc) = 59 | failIfFalse_ (unwords ["ImmSetConversionStatus", show imc, show conv, show stnc]) 60 | $ c_ImmSetConversionStatus imc conv stnc 61 | 62 | foreign import WINDOWS_CCONV "windows.h ImmSetConversionStatus" 63 | c_ImmSetConversionStatus :: HIMC -> DWORD -> DWORD -> IO BOOL 64 | 65 | -- iMN_SETCONVERSIONSTATUS = #const IMN_SETCONVERSIONSTATUS 66 | 67 | #{enum DWORD, 68 | , iME_CMODE_ALPHANUMERIC = IME_CMODE_ALPHANUMERIC 69 | , iME_CMODE_CHARCODE = IME_CMODE_CHARCODE 70 | , iME_CMODE_EUDC = IME_CMODE_EUDC 71 | , iME_CMODE_FIXED = IME_CMODE_FIXED 72 | , iME_CMODE_FULLSHAPE = IME_CMODE_FULLSHAPE 73 | , iME_CMODE_HANJACONVERT = IME_CMODE_HANJACONVERT 74 | , iME_CMODE_KATAKANA = IME_CMODE_KATAKANA 75 | , iME_CMODE_NATIVE = IME_CMODE_NATIVE 76 | , iME_CMODE_NOCONVERSION = IME_CMODE_NOCONVERSION 77 | , iME_CMODE_ROMAN = IME_CMODE_ROMAN 78 | , iME_CMODE_SOFTKBD = IME_CMODE_SOFTKBD 79 | , iME_CMODE_SYMBOL = IME_CMODE_SYMBOL 80 | } 81 | 82 | #{enum DWORD, 83 | , iME_SMODE_AUTOMATIC = IME_SMODE_AUTOMATIC 84 | , iME_SMODE_NONE = IME_SMODE_NONE 85 | , iME_SMODE_PHRASEPREDICT = IME_SMODE_PHRASEPREDICT 86 | , iME_SMODE_PLAURALCLAUSE = IME_SMODE_PLAURALCLAUSE 87 | , iME_SMODE_SINGLECONVERT = IME_SMODE_SINGLECONVERT 88 | } 89 | {- 90 | , iME_SMODE_CONVERSATION = IME_SMODE_CONVERSATION 91 | -} 92 | 93 | immReleaseContext :: HWND -> HIMC -> IO () 94 | immReleaseContext wnd imc = 95 | failIfFalse_ (unwords ["ImmSetOpenStatus", show wnd, show imc]) 96 | $ c_ImmReleaseContext wnd imc 97 | 98 | foreign import WINDOWS_CCONV "windows.h ImmReleaseContext" 99 | c_ImmReleaseContext :: HWND -> HIMC -> IO BOOL 100 | 101 | foreign import WINDOWS_CCONV "windows.h ImmGetVirtualKey" 102 | immGetVirtualKey :: HWND -> IO VKey 103 | 104 | immSimulateHotKey :: HWND -> DWORD -> IO () 105 | immSimulateHotKey hwd hkey = 106 | failIfFalse_ (unwords ["ImmSimulateHotKey", show hwd, show hkey]) 107 | $ c_ImmSimulateHotKey hwd hkey 108 | 109 | foreign import WINDOWS_CCONV "windows.h ImmSimulateHotKey" 110 | c_ImmSimulateHotKey :: HWND -> DWORD -> IO BOOL 111 | -------------------------------------------------------------------------------- /examples/hello.lhs: -------------------------------------------------------------------------------- 1 | % 2 | % (c) sof, 1999 3 | % 4 | 5 | Haskell version of "Hello, World" using the Win32 library. 6 | Demonstrates how the Win32 library can be put to use. 7 | 8 | \begin{code} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | module Main(main) where 11 | 12 | import Control.Monad (when, void) 13 | import Control.Exception (SomeException, bracket, try) 14 | import Foreign.Ptr (nullPtr) 15 | import System.Win32.DLL (getModuleHandle) 16 | import qualified Graphics.Win32 17 | 18 | \end{code} 19 | 20 | Toplevel main just creates a window and pumps messages. 21 | The window procedure (wndProc) we pass in is partially 22 | applied with the user action that takes care of responding 23 | to repaint messages (WM_PAINT). 24 | 25 | \begin{code} 26 | main :: IO () 27 | main = 28 | Graphics.Win32.allocaPAINTSTRUCT $ \ lpps -> do 29 | hwnd <- createWindow 200 200 (wndProc lpps onPaint) 30 | messagePump hwnd 31 | 32 | {- 33 | OnPaint handler for a window - draw a string centred 34 | inside it. 35 | -} 36 | onPaint :: Graphics.Win32.RECT -> Graphics.Win32.HDC -> IO () 37 | onPaint (_,_,w,h) hdc = do 38 | Graphics.Win32.setBkMode hdc Graphics.Win32.tRANSPARENT 39 | Graphics.Win32.setTextColor hdc (Graphics.Win32.rgb 255 255 0) 40 | let y | h==10 = 0 41 | | otherwise = ((h-10) `div` 2) 42 | x | w==50 = 0 43 | | otherwise = (w-50) `div` 2 44 | Graphics.Win32.textOut hdc x y "Hello, world" 45 | return () 46 | \end{code} 47 | 48 | Simple window procedure - one way to improve and generalise it would be to pass 49 | it a message map (represented as a finite map from WindowMessages to actions, 50 | perhaps). Note we use defWindowProcSafe to ensure the closure is correctly 51 | freed; otherwise, lpps and onPaint action would be kept in memory. 52 | 53 | \begin{code} 54 | 55 | wndProc :: Graphics.Win32.LPPAINTSTRUCT 56 | -> (Graphics.Win32.RECT -> Graphics.Win32.HDC -> IO ()) -- on paint action 57 | -> Graphics.Win32.HWND 58 | -> Graphics.Win32.WindowMessage 59 | -> Graphics.Win32.WPARAM 60 | -> Graphics.Win32.LPARAM 61 | -> IO Graphics.Win32.LRESULT 62 | wndProc lpps onPaint hwnd wmsg wParam lParam 63 | | wmsg == Graphics.Win32.wM_DESTROY = do 64 | Graphics.Win32.sendMessage hwnd Graphics.Win32.wM_QUIT 1 0 65 | return 0 66 | | wmsg == Graphics.Win32.wM_PAINT && hwnd /= nullPtr = do 67 | r <- Graphics.Win32.getClientRect hwnd 68 | paintWith lpps hwnd (onPaint r) 69 | return 0 70 | | otherwise = 71 | Graphics.Win32.defWindowProcSafe (Just hwnd) wmsg wParam lParam 72 | 73 | createWindow :: Int -> Int -> Graphics.Win32.WindowClosure -> IO Graphics.Win32.HWND 74 | createWindow width height wndProc = do 75 | let winClass = Graphics.Win32.mkClassName "Hello" 76 | icon <- Graphics.Win32.loadIcon Nothing Graphics.Win32.iDI_APPLICATION 77 | cursor <- Graphics.Win32.loadCursor Nothing Graphics.Win32.iDC_ARROW 78 | bgBrush <- Graphics.Win32.createSolidBrush (Graphics.Win32.rgb 0 0 255) 79 | mainInstance <- getModuleHandle Nothing 80 | Graphics.Win32.registerClass 81 | ( Graphics.Win32.cS_VREDRAW + Graphics.Win32.cS_HREDRAW 82 | , mainInstance 83 | , Just icon 84 | , Just cursor 85 | , Just bgBrush 86 | , Nothing 87 | , winClass 88 | ) 89 | w <- Graphics.Win32.createWindow 90 | winClass 91 | "Hello, World example" 92 | Graphics.Win32.wS_OVERLAPPEDWINDOW 93 | Nothing Nothing -- leave it to the shell to decide the position 94 | -- at where to put the window initially 95 | (Just width) 96 | (Just height) 97 | Nothing -- no parent, i.e, root window is the parent. 98 | Nothing -- no menu handle 99 | mainInstance 100 | wndProc 101 | Graphics.Win32.showWindow w Graphics.Win32.sW_SHOWNORMAL 102 | Graphics.Win32.updateWindow w 103 | return w 104 | 105 | messagePump :: Graphics.Win32.HWND -> IO () 106 | messagePump hwnd = Graphics.Win32.allocaMessage $ \msg -> 107 | let pump = do 108 | r :: Either SomeException Bool 109 | <- Control.Exception.try $ Graphics.Win32.getMessage msg (Just hwnd) 110 | when (either (const False) id r) $ do 111 | () <$ Graphics.Win32.translateMessage msg 112 | () <$ Graphics.Win32.dispatchMessage msg 113 | pump 114 | in pump 115 | 116 | paintWith :: Graphics.Win32.LPPAINTSTRUCT -> Graphics.Win32.HWND -> (Graphics.Win32.HDC -> IO a) -> IO a 117 | paintWith lpps hwnd p = 118 | bracket 119 | (Graphics.Win32.beginPaint hwnd lpps) 120 | (const $ Graphics.Win32.endPaint hwnd lpps) 121 | p 122 | 123 | \end{code} 124 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/FileMapping.hsc: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : System.Win32.FileMapping 4 | -- Copyright : (c) Esa Ilari Vuokko, 2006 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : Esa Ilari Vuokko 8 | -- Stability : provisional 9 | -- Portability : portable 10 | -- 11 | -- A collection of FFI declarations for interfacing with Win32 mapped files. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | module System.Win32.WindowsString.FileMapping 15 | ( module System.Win32.WindowsString.FileMapping 16 | , module System.Win32.FileMapping 17 | ) where 18 | 19 | import System.Win32.FileMapping hiding 20 | ( 21 | mapFile 22 | , withMappedFile 23 | , createFileMapping 24 | , openFileMapping 25 | ) 26 | 27 | import System.Win32.FileMapping.Internal 28 | import System.Win32.WindowsString.Types ( HANDLE, BOOL, withTString 29 | , failIf, DDWORD, ddwordToDwords 30 | , iNVALID_HANDLE_VALUE ) 31 | import System.Win32.Mem 32 | import System.Win32.WindowsString.File 33 | import System.OsString.Windows 34 | import System.OsPath.Windows 35 | 36 | import Control.Exception ( mask_, bracket ) 37 | import Foreign ( nullPtr, maybeWith 38 | , ForeignPtr, newForeignPtr ) 39 | 40 | ##include "windows_cconv.h" 41 | 42 | #include "windows.h" 43 | 44 | --------------------------------------------------------------------------- 45 | -- Derived functions 46 | --------------------------------------------------------------------------- 47 | 48 | -- | Maps file fully and returns ForeignPtr and length of the mapped area. 49 | -- The mapped file is opened read-only and shared reading. 50 | mapFile :: WindowsPath -> IO (ForeignPtr a, Int) 51 | mapFile path = do 52 | bracket 53 | (createFile path gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing) 54 | (closeHandle) 55 | $ \fh -> bracket 56 | (createFileMapping (Just fh) pAGE_READONLY 0 Nothing) 57 | (closeHandle) 58 | $ \fm -> do 59 | fi <- getFileInformationByHandle fh 60 | fp <- mask_ $ do 61 | ptr <- mapViewOfFile fm fILE_MAP_READ 0 0 62 | newForeignPtr c_UnmapViewOfFileFinaliser ptr 63 | return (fp, fromIntegral $ bhfiSize fi) 64 | 65 | -- | Opens an existing file and creates mapping object to it. 66 | withMappedFile 67 | :: WindowsPath -- ^ Path 68 | -> Bool -- ^ Write? (False = read-only) 69 | -> Maybe Bool -- ^ Sharing mode, no sharing, share read, share read+write 70 | -> (Integer -> MappedObject -> IO a) -- ^ Action 71 | -> IO a 72 | withMappedFile path write share act = 73 | bracket 74 | (createFile path access share' Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing) 75 | (closeHandle) 76 | $ \fh -> bracket 77 | (createFileMapping (Just fh) page 0 Nothing) 78 | (closeHandle) 79 | $ \fm -> do 80 | bhfi <- getFileInformationByHandle fh 81 | act (fromIntegral $ bhfiSize bhfi) (MappedObject fh fm mapaccess) 82 | where 83 | access = if write then gENERIC_READ+gENERIC_WRITE else gENERIC_READ 84 | page = if write then pAGE_READWRITE else pAGE_READONLY 85 | mapaccess = if write then fILE_MAP_ALL_ACCESS else fILE_MAP_READ 86 | share' = case share of 87 | Nothing -> fILE_SHARE_NONE 88 | Just False -> fILE_SHARE_READ 89 | Just True -> fILE_SHARE_READ + fILE_SHARE_WRITE 90 | 91 | --------------------------------------------------------------------------- 92 | -- API in Haskell 93 | --------------------------------------------------------------------------- 94 | createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe WindowsString -> IO HANDLE 95 | createFileMapping mh flags mosize name = 96 | maybeWith withTString name $ \c_name -> 97 | failIf (==nullPtr) "createFileMapping: CreateFileMapping" $ c_CreateFileMapping handle nullPtr flags moshi moslow c_name 98 | where 99 | (moshi,moslow) = ddwordToDwords mosize 100 | handle = maybe iNVALID_HANDLE_VALUE id mh 101 | 102 | openFileMapping :: FileMapAccess -> BOOL -> Maybe WindowsString -> IO HANDLE 103 | openFileMapping access inherit name = 104 | maybeWith withTString name $ \c_name -> 105 | failIf (==nullPtr) "openFileMapping: OpenFileMapping" $ 106 | c_OpenFileMapping access inherit c_name 107 | 108 | -------------------------------------------------------------------------------- /System/Win32/Automation/Input.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {- | 3 | Module : System.Win32.Automation.Input 4 | Copyright : 2013 shelarcy 5 | License : BSD-style 6 | 7 | Maintainer : shelarcy@gmail.com 8 | Stability : Provisional 9 | Portability : Non-portable (Win32 API) 10 | 11 | Provide sendInput function and INPUT types. 12 | -} 13 | module System.Win32.Automation.Input 14 | ( sendInput 15 | , sendInputPtr 16 | , makeKeyboardInput 17 | , PINPUT 18 | , LPINPUT 19 | , INPUT(..) 20 | , PHARDWAREINPUT 21 | , HARDWAREINPUT(..) 22 | , getMessageExtraInfo 23 | , setMessageExtraInfo 24 | , module System.Win32.Automation.Input.Key 25 | , module System.Win32.Automation.Input.Mouse 26 | ) where 27 | 28 | import Data.Bits ( (.|.) ) 29 | import Foreign.Ptr ( Ptr ) 30 | import Foreign.Storable ( Storable(..) ) 31 | import Foreign.Marshal.Array ( withArrayLen ) 32 | import Foreign.C.Types ( CIntPtr(..) ) 33 | import Graphics.Win32.Key ( VKey, c_MapVirtualKey ) 34 | import System.Win32.Automation.Input.Key 35 | import System.Win32.Automation.Input.Mouse ( MOUSEINPUT ) 36 | import System.Win32.Automation.Input.Mouse hiding ( MOUSEINPUT(..) ) 37 | import System.Win32.Types ( UINT, LPARAM, failIfZero ) 38 | import System.Win32.Word ( DWORD, WORD ) 39 | 40 | #include 41 | #include "alignment.h" 42 | ##include "windows_cconv.h" 43 | #include "winuser_compat.h" 44 | 45 | sendInput :: [INPUT] -> IO UINT 46 | sendInput input 47 | = withArrayLen input $ \len c_input -> 48 | sendInputPtr len c_input 49 | 50 | {-# INLINE sendInputPtr #-} 51 | -- | Raw pointer of array version of 'sendInput'. 52 | -- Use this function to support non-list sequence. 53 | sendInputPtr :: Int -> Ptr INPUT -> IO UINT 54 | sendInputPtr len c_input 55 | = failIfZero "SendInput" $ 56 | c_SendInput (fromIntegral len) c_input $ sizeOf (undefined :: INPUT) 57 | 58 | foreign import WINDOWS_CCONV unsafe "windows.h SendInput" 59 | c_SendInput :: UINT -> LPINPUT -> Int -> IO UINT 60 | 61 | makeKeyboardInput :: VKey -> Maybe DWORD -> IO INPUT 62 | makeKeyboardInput vkey flag = do 63 | let flag' = maybe kEYEVENTF_EXTENDEDKEY (kEYEVENTF_EXTENDEDKEY .|.) flag 64 | scan <- c_MapVirtualKey vkey 0 65 | dwExtraInfo' <- getMessageExtraInfo 66 | return $ Keyboard 67 | $ KEYBDINPUT { 68 | wVk = fromIntegral vkey 69 | , wScan = fromIntegral scan 70 | , dwFlags = flag' 71 | , time = 0 72 | , dwExtraInfo = fromIntegral $ dwExtraInfo' 73 | } 74 | 75 | type PINPUT = Ptr INPUT 76 | type LPINPUT = Ptr INPUT 77 | 78 | data INPUT = Mouse MOUSEINPUT | Keyboard KEYBDINPUT | OtherHardware HARDWAREINPUT 79 | deriving Show 80 | 81 | instance Storable INPUT where 82 | sizeOf = const #{size INPUT} 83 | alignment _ = #alignment INPUT 84 | 85 | poke buf (Mouse mouse) = do 86 | (#poke INPUT, type) buf (#{const INPUT_MOUSE}:: DWORD) 87 | (#poke INPUT, mi) buf mouse 88 | poke buf (Keyboard key) = do 89 | (#poke INPUT, type) buf (#{const INPUT_KEYBOARD} :: DWORD) 90 | (#poke INPUT, ki) buf key 91 | poke buf (OtherHardware hard) = do 92 | (#poke INPUT, type) buf (#{const INPUT_HARDWARE} :: DWORD) 93 | (#poke INPUT, hi) buf hard 94 | 95 | peek buf = do 96 | type' <- (#peek INPUT, type) buf :: IO DWORD 97 | case type' of 98 | #{const INPUT_MOUSE} -> 99 | Mouse `fmap` (#peek INPUT, mi) buf 100 | #{const INPUT_KEYBOARD} -> 101 | Keyboard `fmap` (#peek INPUT, ki) buf 102 | _ -> OtherHardware `fmap` (#peek INPUT, hi) buf 103 | 104 | 105 | type PHARDWAREINPUT = Ptr HARDWAREINPUT 106 | 107 | data HARDWAREINPUT = HARDWAREINPUT 108 | { uMsg :: DWORD 109 | , wParamL :: WORD 110 | , wParamH :: WORD 111 | } deriving Show 112 | 113 | instance Storable HARDWAREINPUT where 114 | sizeOf = const #{size HARDWAREINPUT} 115 | alignment _ = #alignment HARDWAREINPUT 116 | poke buf input = do 117 | (#poke HARDWAREINPUT, uMsg) buf (uMsg input) 118 | (#poke HARDWAREINPUT, wParamL) buf (wParamL input) 119 | (#poke HARDWAREINPUT, wParamH) buf (wParamH input) 120 | peek buf = do 121 | uMsg' <- (#peek HARDWAREINPUT, uMsg) buf 122 | wParamL' <- (#peek HARDWAREINPUT, wParamL) buf 123 | wParamH' <- (#peek HARDWAREINPUT, wParamH) buf 124 | return $ HARDWAREINPUT uMsg' wParamL' wParamH' 125 | 126 | foreign import WINDOWS_CCONV unsafe "windows.h GetMessageExtraInfo" 127 | getMessageExtraInfo :: IO LPARAM 128 | 129 | foreign import WINDOWS_CCONV unsafe "windows.h SetMessageExtraInfo" 130 | setMessageExtraInfo :: LPARAM -> IO LPARAM 131 | -------------------------------------------------------------------------------- /cbits/diatemp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Helper functions for filling in DLG(ITEM)TEMPLATEs - 3 | * closely based on code provided Rector & Newcomer 4 | * in their book, Win32 programming. 5 | * 6 | * The only change here is to make it possible to 7 | * add any number of controls to the dialog without 8 | * having to worry about overrunning the chunk of 9 | * memory that we're writing all this info into. 10 | * 11 | */ 12 | 13 | #define UNICODE 14 | #include 15 | #include 16 | #include 17 | #include "diatemp.h" 18 | 19 | #define DLGTEMPLATE_WORKING_SIZE 4096 20 | 21 | LPDLGTEMPLATE getFinalDialog(DIA_TEMPLATE* dt) 22 | { 23 | LPDLGTEMPLATE ptr = dt->dtemplate; 24 | free(dt); 25 | return ptr; 26 | } 27 | 28 | LPWORD 29 | appendString (LPWORD ptr, LPCWSTR text) 30 | { 31 | LPWSTR str = (LPWSTR)ptr; 32 | wcscpy(str, text); 33 | ptr = (LPWORD)(str + wcslen(str) + 1); 34 | return ptr; 35 | } 36 | 37 | LPWORD 38 | setClassAtom(LPDLGITEMTEMPLATE item, WORD classatom) 39 | { 40 | LPWORD ptr = (LPWORD)&item[1]; 41 | *ptr++ = 0xffff; 42 | *ptr++ = classatom; 43 | return ptr; 44 | } 45 | 46 | LPWORD 47 | setClassName(LPDLGITEMTEMPLATE item, LPCWSTR classname) 48 | { 49 | LPWORD ptr = (LPWORD)&item[1]; 50 | ptr = appendString(ptr, classname); 51 | return ptr; 52 | } 53 | 54 | LPWORD 55 | setResourceID(LPWORD ptr, WORD id) 56 | { 57 | *ptr++ = 0xffff; 58 | *ptr++ = (WORD)id; 59 | return ptr; 60 | } 61 | 62 | DIA_TEMPLATE* 63 | mkDiaTemplate 64 | ( UINT size, int x, int y, int cx, int cy 65 | , DWORD style, DWORD exstyle 66 | , LPCWSTR menu, LPCWSTR class 67 | , LPCWSTR caption, LPCWSTR font 68 | , int height 69 | ) 70 | { 71 | LPDLGTEMPLATE dlg; 72 | LPWORD ptr; 73 | DIA_TEMPLATE* dtemp; 74 | 75 | if ( size == 0 ) { 76 | size = DLGTEMPLATE_WORKING_SIZE; 77 | } 78 | dlg = (LPDLGTEMPLATE)malloc(size); 79 | if (dlg == NULL) { 80 | return NULL; 81 | } 82 | 83 | dlg->x = x; 84 | dlg->y = y; 85 | dlg->cx = cx; 86 | dlg->cy = cy; 87 | 88 | dlg->cdit = 0; 89 | 90 | dlg->style = style; 91 | if (font == NULL) { 92 | dlg->style &= ~ DS_SETFONT; 93 | } else { 94 | dlg->style |= DS_SETFONT; 95 | } 96 | dlg->dwExtendedStyle = exstyle; 97 | 98 | ptr= (LPWORD)&dlg[1]; 99 | if (menu == NULL) { 100 | *ptr++ = 0; 101 | } else if (HIWORD(menu) == 0) { 102 | ptr = setResourceID(ptr, LOWORD(menu)); 103 | } else { 104 | ptr = appendString(ptr, menu); 105 | } 106 | 107 | if ( class == NULL ) { 108 | *ptr++ = 0; 109 | } else if ( HIWORD(class) == 0 ) { 110 | ptr = setResourceID(ptr, LOWORD(class)); 111 | } else { 112 | ptr = appendString(ptr, class); 113 | } 114 | 115 | ptr = appendString(ptr, (caption == NULL ? L"" : caption)); 116 | 117 | if ( font != NULL ) { 118 | *ptr++ = height; 119 | ptr = appendString(ptr, font); 120 | } 121 | 122 | dtemp = (DIA_TEMPLATE*)malloc(sizeof(DIA_TEMPLATE)); 123 | if ( dtemp == NULL ) 124 | return NULL; 125 | 126 | dtemp->dtemplate = dlg; 127 | dtemp->next_dia_item = (LPDLGITEMTEMPLATE)ptr; 128 | dtemp->bytes_left = (unsigned int)(((char*)dlg + size) - (char*)ptr); 129 | dtemp->bytes_alloced = size; 130 | 131 | return dtemp; 132 | } 133 | 134 | static 135 | DIA_TEMPLATE* 136 | check_if_enough_mem(DIA_TEMPLATE* dia, LPCWSTR text, LPCWSTR classname) 137 | { 138 | unsigned int sz = 0; 139 | 140 | sz += sizeof(DLGITEMTEMPLATE); 141 | 142 | if ( HIWORD(classname) == 0 ) { 143 | sz += sizeof(WORD); 144 | } else { 145 | sz += wcslen(classname) + 1; 146 | } 147 | if ( HIWORD(text) == 0 ) { 148 | sz += sizeof(WORD); 149 | } else { 150 | sz += wcslen(text) + 1; 151 | } 152 | 153 | if ( sz >= dia->bytes_left ) { 154 | unsigned int diff; 155 | dia->bytes_left = dia->bytes_left + dia->bytes_alloced; 156 | dia->bytes_alloced *= 2; 157 | /* Being defensive here.. */ 158 | diff = (unsigned int)((char*)dia->next_dia_item - (char*)dia->dtemplate); 159 | dia->dtemplate = (LPDLGTEMPLATE)realloc((void*)dia->dtemplate, dia->bytes_alloced); 160 | if ( dia->dtemplate == NULL ) 161 | return NULL; 162 | dia->next_dia_item = (LPDLGITEMTEMPLATE)((char*)dia->dtemplate + diff); 163 | return dia; 164 | } else { 165 | return dia; 166 | } 167 | } 168 | 169 | static 170 | LPWORD noParms (LPDLGITEMTEMPLATE item, LPWORD ptr) 171 | { 172 | *ptr++ = 0; 173 | if ( (((LPWORD)item) - ptr) & 0x1) 174 | *ptr++ = 0; 175 | 176 | return ptr; 177 | } 178 | 179 | DIA_TEMPLATE* 180 | addDiaControl 181 | ( DIA_TEMPLATE* dia 182 | , LPCWSTR text, short id 183 | , LPCWSTR classname, DWORD style 184 | , int x, int y, int cx, int cy 185 | , DWORD exstyle 186 | ) 187 | { 188 | LPWORD ptr; 189 | LPDLGITEMTEMPLATE item; 190 | 191 | dia = check_if_enough_mem(dia, text, classname); 192 | 193 | ptr = (LPWORD)&(dia->next_dia_item[1]); 194 | 195 | item = dia->next_dia_item; 196 | 197 | item->style = WS_CHILD | style; 198 | item->dwExtendedStyle = exstyle; 199 | item->x = x; 200 | item->y = y; 201 | item->cx = cx; 202 | item->cy = cy; 203 | item->id = (WORD)id; 204 | 205 | if ( HIWORD(classname) != 0 ) { 206 | ptr = setClassName(item, classname); 207 | } else { 208 | ptr = setResourceID(ptr, LOWORD(classname)); 209 | } 210 | 211 | if ( HIWORD(text) != 0 ) { 212 | ptr = appendString(ptr, text); 213 | } else { 214 | ptr = setResourceID(ptr, (short)(LOWORD(text))); 215 | } 216 | 217 | ptr = noParms(item, ptr); 218 | 219 | dia->bytes_left -= ((char*)ptr - ((char*)dia->next_dia_item)); 220 | dia->next_dia_item = (LPDLGITEMTEMPLATE)ptr; 221 | 222 | return dia; 223 | } 224 | 225 | -------------------------------------------------------------------------------- /System/Win32/Semaphore.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | 7 | ----------------------------------------------------------------------------- 8 | -- | 9 | -- Module : System.Win32.Semaphore 10 | -- Copyright : (c) Sam Derbyshire, 2022 11 | -- License : BSD-style (see the file libraries/base/LICENSE) 12 | -- 13 | -- Maintainer : Sam Derbyshire 14 | -- Stability : provisional 15 | -- Portability : portable 16 | -- 17 | -- Windows Semaphore objects and operations 18 | -- 19 | ----------------------------------------------------------------------------- 20 | 21 | module System.Win32.Semaphore 22 | ( -- * Semaphores 23 | Semaphore(..) 24 | 25 | -- * Access modes 26 | , AccessMode 27 | , sEMAPHORE_ALL_ACCESS 28 | , sEMAPHORE_MODIFY_STATE 29 | 30 | -- * Managing semaphores 31 | , createSemaphore 32 | , openSemaphore 33 | , releaseSemaphore 34 | ) where 35 | 36 | import System.Win32.File 37 | import System.Win32.Types 38 | 39 | import Data.Maybe (fromMaybe) 40 | import Foreign hiding (void) 41 | import Foreign.C (withCAString) 42 | 43 | ##include "windows_cconv.h" 44 | 45 | #include 46 | 47 | ---------------------------------------------------------------- 48 | -- Semaphore access modes 49 | ---------------------------------------------------------------- 50 | 51 | #{enum AccessMode, 52 | , sEMAPHORE_ALL_ACCESS = SEMAPHORE_ALL_ACCESS 53 | , sEMAPHORE_MODIFY_STATE = SEMAPHORE_MODIFY_STATE 54 | } 55 | 56 | ---------------------------------------------------------------- 57 | -- Semaphores 58 | ---------------------------------------------------------------- 59 | 60 | -- | A Windows semaphore. 61 | -- 62 | -- To obtain a 'Semaphore', use 'createSemaphore' to create a new one, 63 | -- or 'openSemaphore' to open an existing one. 64 | -- 65 | -- To wait on a semaphore, use 'System.Win32.Event.waitForSingleObject'. 66 | -- 67 | -- To release resources on a semaphore, use 'releaseSemaphore'. 68 | -- 69 | -- To free a semaphore, use 'System.Win32.File.closeHandle'. 70 | -- The semaphore object is destroyed when its last handle has been closed. 71 | -- Closing the handle does not affect the semaphore count; therefore, be sure to call 72 | -- 'releaseSemaphore' before closing the handle or before the process terminates. 73 | -- Otherwise, pending wait operations will either time out or continue indefinitely, 74 | -- depending on whether a time-out value has been specified. 75 | newtype Semaphore = Semaphore { semaphoreHandle :: HANDLE } 76 | 77 | -- | Open a 'Semaphore' with the given name, or create a new semaphore 78 | -- if no such semaphore exists, with initial count @i@ and maximum count @m@. 79 | -- 80 | -- The counts must satisfy @i >= 0@, @m > 0@ and @i <= m@. 81 | -- 82 | -- The returned 'Bool' is 'True' if the function found an existing semaphore 83 | -- with the given name, in which case a handle to that semaphore is returned 84 | -- and the counts are ignored. 85 | -- 86 | -- Use 'openSemaphore' if you don't want to create a new semaphore. 87 | createSemaphore :: Maybe SECURITY_ATTRIBUTES 88 | -> LONG -- ^ initial count @i@ with @0 <= i <= m@ 89 | -> LONG -- ^ maximum count @m > 0@ 90 | -> Maybe String -- ^ (optional) semaphore name 91 | -- (case-sensitive, limited to MAX_PATH characters) 92 | -> IO (Semaphore, Bool) 93 | createSemaphore mb_sec initial_count max_count mb_name = 94 | maybeWith with mb_sec $ \ c_sec -> do 95 | maybeWith withCAString mb_name $ \ c_name -> do 96 | handle <- c_CreateSemaphore c_sec initial_count max_count c_name 97 | err_code <- getLastError 98 | already_exists <- 99 | case err_code of 100 | (# const ERROR_INVALID_HANDLE) -> 101 | errorWin $ "createSemaphore: semaphore name '" 102 | ++ fromMaybe "" mb_name 103 | ++ "' matches non-semaphore" 104 | (# const ERROR_ALREADY_EXISTS) -> 105 | return True 106 | _ -> 107 | return False 108 | if handle == nullPtr 109 | then errorWin "createSemaphore" 110 | else return (Semaphore handle, already_exists) 111 | 112 | foreign import WINDOWS_CCONV unsafe "windows.h CreateSemaphoreA" 113 | c_CreateSemaphore :: LPSECURITY_ATTRIBUTES -> LONG -> LONG -> LPCSTR -> IO HANDLE 114 | 115 | -- | Open an existing 'Semaphore'. 116 | openSemaphore :: AccessMode -- ^ desired access mode 117 | -> Bool -- ^ should child processes inherit the handle? 118 | -> String -- ^ name of the semaphore to open (case-sensitive) 119 | -> IO Semaphore 120 | openSemaphore amode inherit name = 121 | withTString name $ \c_name -> do 122 | handle <- failIfNull ("openSemaphore: '" ++ name ++ "'") $ 123 | c_OpenSemaphore (fromIntegral amode) inherit c_name 124 | return (Semaphore handle) 125 | 126 | foreign import WINDOWS_CCONV unsafe "windows.h OpenSemaphoreW" 127 | c_OpenSemaphore :: DWORD -> BOOL -> LPCWSTR -> IO HANDLE 128 | 129 | -- | Increase the count of the 'Semaphore' by the specified amount. 130 | -- 131 | -- Returns the count of the semaphore before the increase. 132 | -- 133 | -- Throws an error if the count would exceeded the maximum count 134 | -- of the semaphore. 135 | releaseSemaphore :: Semaphore -> LONG -> IO LONG 136 | releaseSemaphore (Semaphore handle) count = 137 | with 0 $ \ ptr_prevCount -> do 138 | failIfFalse_ "releaseSemaphore" $ c_ReleaseSemaphore handle count ptr_prevCount 139 | peek ptr_prevCount 140 | 141 | foreign import WINDOWS_CCONV unsafe "windows.h ReleaseSemaphore" 142 | c_ReleaseSemaphore :: HANDLE -> LONG -> Ptr LONG -> IO BOOL 143 | 144 | ---------------------------------------------------------------- 145 | -- End 146 | ---------------------------------------------------------------- 147 | -------------------------------------------------------------------------------- /Graphics/Win32/GDI/Region.hs: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Graphics.Win32.GDI.Region 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Graphics.Win32.GDI.Region where 21 | 22 | import System.Win32.Types 23 | import Graphics.Win32.GDI.Types 24 | 25 | import Foreign 26 | 27 | #include "windows_cconv.h" 28 | 29 | ---------------------------------------------------------------- 30 | -- Regions 31 | ---------------------------------------------------------------- 32 | 33 | badRegion :: RegionType -> Bool 34 | badRegion n = n == 0 || n == gDI_ERROR 35 | 36 | combineRgn :: HRGN -> HRGN -> HRGN -> ClippingMode -> IO RegionType 37 | combineRgn dest src1 src2 mode = 38 | withForeignPtr dest $ \ p_dest -> 39 | withForeignPtr src1 $ \ p_src1 -> 40 | withForeignPtr src2 $ \ p_src2 -> 41 | failIf badRegion "CombineRgn" $ c_CombineRgn p_dest p_src1 p_src2 mode 42 | foreign import WINDOWS_CCONV unsafe "windows.h CombineRgn" 43 | c_CombineRgn :: PRGN -> PRGN -> PRGN -> ClippingMode -> IO RegionType 44 | 45 | offsetRgn :: HRGN -> INT -> INT -> IO RegionType 46 | offsetRgn rgn xoff yoff = 47 | withForeignPtr rgn $ \ p_rgn -> 48 | failIf badRegion "OffsetRgn" $ c_OffsetRgn p_rgn xoff yoff 49 | foreign import WINDOWS_CCONV unsafe "windows.h OffsetRgn" 50 | c_OffsetRgn :: PRGN -> INT -> INT -> IO RegionType 51 | 52 | getRgnBox :: HRGN -> LPRECT -> IO RegionType 53 | getRgnBox rgn p_rect = 54 | withForeignPtr rgn $ \ p_rgn -> 55 | failIf badRegion "GetRgnBox" $ c_GetRgnBox p_rgn p_rect 56 | foreign import WINDOWS_CCONV unsafe "windows.h GetRgnBox" 57 | c_GetRgnBox :: PRGN -> LPRECT -> IO RegionType 58 | 59 | createEllipticRgn :: INT -> INT -> INT -> INT -> IO HRGN 60 | createEllipticRgn x0 y0 x1 y1 = do 61 | ptr <- failIfNull "CreateEllipticRgn" $ c_CreateEllipticRgn x0 y0 x1 y1 62 | newForeignHANDLE ptr 63 | foreign import WINDOWS_CCONV unsafe "windows.h CreateEllipticRgn" 64 | c_CreateEllipticRgn :: INT -> INT -> INT -> INT -> IO PRGN 65 | 66 | createEllipticRgnIndirect :: LPRECT -> IO HRGN 67 | createEllipticRgnIndirect rp = do 68 | ptr <- failIfNull "CreateEllipticRgnIndirect" $ c_CreateEllipticRgnIndirect rp 69 | newForeignHANDLE ptr 70 | foreign import WINDOWS_CCONV unsafe "windows.h CreateEllipticRgnIndirect" 71 | c_CreateEllipticRgnIndirect :: LPRECT -> IO PRGN 72 | 73 | createRectRgn :: INT -> INT -> INT -> INT -> IO HRGN 74 | createRectRgn x0 y0 x1 y1 = do 75 | ptr <- failIfNull "CreateRectRgn" $ c_CreateRectRgn x0 y0 x1 y1 76 | newForeignHANDLE ptr 77 | foreign import WINDOWS_CCONV unsafe "windows.h CreateRectRgn" 78 | c_CreateRectRgn :: INT -> INT -> INT -> INT -> IO PRGN 79 | 80 | createRectRgnIndirect :: LPRECT -> IO HRGN 81 | createRectRgnIndirect rp = do 82 | ptr <- failIfNull "CreateRectRgnIndirect" $ c_CreateRectRgnIndirect rp 83 | newForeignHANDLE ptr 84 | foreign import WINDOWS_CCONV unsafe "windows.h CreateRectRgnIndirect" 85 | c_CreateRectRgnIndirect :: LPRECT -> IO PRGN 86 | 87 | createRoundRectRgn :: INT -> INT -> INT -> INT -> INT -> INT -> IO HRGN 88 | createRoundRectRgn x0 y0 x1 y1 h w = do 89 | ptr <- failIfNull "CreateRoundRectRgn" $ c_CreateRoundRectRgn x0 y0 x1 y1 h w 90 | newForeignHANDLE ptr 91 | foreign import WINDOWS_CCONV unsafe "windows.h CreateRoundRectRgn" 92 | c_CreateRoundRectRgn :: INT -> INT -> INT -> INT -> INT -> INT -> IO PRGN 93 | 94 | createPolygonRgn :: [POINT] -> PolyFillMode -> IO HRGN 95 | createPolygonRgn ps mode = 96 | withPOINTArray ps $ \ point_array npoints -> do 97 | ptr <- failIfNull "CreatePolygonRgn" $ 98 | c_CreatePolygonRgn point_array npoints mode 99 | newForeignHANDLE ptr 100 | foreign import WINDOWS_CCONV unsafe "windows.h CreatePolygonRgn" 101 | c_CreatePolygonRgn :: Ptr POINT -> Int -> PolyFillMode -> IO PRGN 102 | 103 | -- Needs to do proper error test for EqualRgn; GSL ??? 104 | 105 | foreign import WINDOWS_CCONV unsafe "windows.h EqualRgn" 106 | equalRgn :: PRGN -> PRGN -> IO Bool 107 | 108 | fillRgn :: HDC -> HRGN -> HBRUSH -> IO () 109 | fillRgn dc rgn brush = 110 | withForeignPtr rgn $ \ p_rgn -> 111 | failIfFalse_ "FillRgn" $ c_FillRgn dc p_rgn brush 112 | foreign import WINDOWS_CCONV unsafe "windows.h FillRgn" 113 | c_FillRgn :: HDC -> PRGN -> HBRUSH -> IO Bool 114 | 115 | invertRgn :: HDC -> HRGN -> IO () 116 | invertRgn dc rgn = 117 | withForeignPtr rgn $ \ p_rgn -> 118 | failIfFalse_ "InvertRgn" $ c_InvertRgn dc p_rgn 119 | foreign import WINDOWS_CCONV unsafe "windows.h InvertRgn" 120 | c_InvertRgn :: HDC -> PRGN -> IO Bool 121 | 122 | paintRgn :: HDC -> HRGN -> IO () 123 | paintRgn dc rgn = 124 | withForeignPtr rgn $ \ p_rgn -> 125 | failIfFalse_ "PaintRgn" $ c_PaintRgn dc p_rgn 126 | foreign import WINDOWS_CCONV unsafe "windows.h PaintRgn" 127 | c_PaintRgn :: HDC -> PRGN -> IO Bool 128 | 129 | frameRgn :: HDC -> HRGN -> HBRUSH -> Int -> Int -> IO () 130 | frameRgn dc rgn brush w h = 131 | withForeignPtr rgn $ \ p_rgn -> 132 | failIfFalse_ "FrameRgn" $ c_FrameRgn dc p_rgn brush w h 133 | foreign import WINDOWS_CCONV unsafe "windows.h FrameRgn" 134 | c_FrameRgn :: HDC -> PRGN -> HBRUSH -> Int -> Int -> IO Bool 135 | 136 | ptInRegion :: HRGN -> Int -> Int -> IO Bool 137 | ptInRegion rgn x y = 138 | withForeignPtr rgn $ \ p_rgn -> 139 | c_PtInRegion p_rgn x y 140 | foreign import WINDOWS_CCONV unsafe "windows.h PtInRegion" 141 | c_PtInRegion :: PRGN -> Int -> Int -> IO Bool 142 | 143 | rectInRegion :: HRGN -> RECT -> IO Bool 144 | rectInRegion rgn rect = 145 | withForeignPtr rgn $ \ p_rgn -> 146 | withRECT rect $ c_RectInRegion p_rgn 147 | foreign import WINDOWS_CCONV unsafe "windows.h RectInRegion" 148 | c_RectInRegion :: PRGN -> Ptr RECT -> IO Bool 149 | 150 | ---------------------------------------------------------------- 151 | -- End 152 | ---------------------------------------------------------------- 153 | -------------------------------------------------------------------------------- /Graphics/Win32/Resource.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Graphics.Win32.Resource 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Graphics.Win32.Resource where 21 | 22 | import System.Win32.Types 23 | 24 | import Foreign 25 | 26 | ##include "windows_cconv.h" 27 | 28 | #include 29 | 30 | beginUpdateResource :: String -> Bool -> IO HANDLE 31 | beginUpdateResource name del = 32 | withTString name $ \ c_name -> 33 | failIfNull "BeginUpdateResource" $ c_BeginUpdateResource c_name del 34 | foreign import WINDOWS_CCONV unsafe "windows.h BeginUpdateResourceW" 35 | c_BeginUpdateResource :: LPCTSTR -> Bool -> IO HANDLE 36 | 37 | type ResourceImageType = UINT 38 | 39 | type HRSRC = Ptr () 40 | 41 | type HGLOBAL = Ptr () 42 | 43 | #{enum ResourceImageType, 44 | , iMAGE_BITMAP = IMAGE_BITMAP 45 | , iMAGE_ICON = IMAGE_ICON 46 | , iMAGE_CURSOR = IMAGE_CURSOR 47 | } 48 | 49 | copyImage :: HANDLE -> ResourceImageType -> Int -> Int -> UINT -> IO HANDLE 50 | copyImage h ty x y flags = 51 | failIfNull "CopyImage" $ c_CopyImage h ty x y flags 52 | foreign import WINDOWS_CCONV unsafe "windows.h CopyImage" 53 | c_CopyImage :: HANDLE -> ResourceImageType -> Int -> Int -> UINT -> IO HANDLE 54 | 55 | endUpdateResource :: HANDLE -> BOOL -> IO () 56 | endUpdateResource h discard = 57 | failIfFalse_ "EndUpdateResource" $ c_EndUpdateResource h discard 58 | foreign import WINDOWS_CCONV unsafe "windows.h EndUpdateResourceW" 59 | c_EndUpdateResource :: HANDLE -> BOOL -> IO Bool 60 | 61 | type ResourceType = LPCTSTR 62 | 63 | #{enum ResourceType, castUINTPtrToPtr 64 | , rT_ACCELERATOR = (UINT_PTR)RT_ACCELERATOR // Accelerator table 65 | , rT_ANICURSOR = (UINT_PTR)RT_ANICURSOR // Animated cursor 66 | , rT_ANIICON = (UINT_PTR)RT_ANIICON // Animated icon 67 | , rT_BITMAP = (UINT_PTR)RT_BITMAP // Bitmap resource 68 | , rT_CURSOR = (UINT_PTR)RT_CURSOR // Hardware-dependent cursor resource 69 | , rT_DIALOG = (UINT_PTR)RT_DIALOG // Dialog box 70 | , rT_FONT = (UINT_PTR)RT_FONT // Font resource 71 | , rT_FONTDIR = (UINT_PTR)RT_FONTDIR // Font directory resource 72 | , rT_GROUP_CURSOR = (UINT_PTR)RT_GROUP_CURSOR // Hardware-independent cursor resource 73 | , rT_GROUP_ICON = (UINT_PTR)RT_GROUP_ICON // Hardware-independent icon resource 74 | , rT_HTML = (UINT_PTR)RT_HTML // HTML document 75 | , rT_ICON = (UINT_PTR)RT_ICON // Hardware-dependent icon resource 76 | , rT_MENU = (UINT_PTR)RT_MENU // Menu resource 77 | , rT_MESSAGETABLE = (UINT_PTR)RT_MESSAGETABLE // Message-table entry 78 | , rT_RCDATA = (UINT_PTR)RT_RCDATA // Application-defined resource (raw data) 79 | , rT_STRING = (UINT_PTR)RT_STRING // String-table entry 80 | , rT_VERSION = (UINT_PTR)RT_VERSION // Version resource 81 | } 82 | 83 | findResource :: HMODULE -> String -> ResourceType -> IO HRSRC 84 | findResource hmod name ty = 85 | withTString name $ \ c_name -> 86 | failIfNull "FindResource" $ c_FindResource hmod c_name ty 87 | foreign import WINDOWS_CCONV unsafe "windows.h FindResourceW" 88 | c_FindResource :: HMODULE -> LPCTSTR -> LPCTSTR -> IO HRSRC 89 | 90 | -- was: LPCTSTR_ 91 | findResourceEx :: HMODULE -> String -> ResourceType -> WORD -> IO HRSRC 92 | findResourceEx hmod name ty lang = 93 | withTString name $ \ c_name -> 94 | failIfNull "FindResourceEx" $ c_FindResourceEx hmod c_name ty lang 95 | foreign import WINDOWS_CCONV unsafe "windows.h FindResourceExW" 96 | c_FindResourceEx :: HMODULE -> LPCTSTR -> LPCTSTR -> WORD -> IO HRSRC 97 | 98 | type ResourceSize = Int 99 | 100 | lR_DEFAULTSIZE :: ResourceSize 101 | lR_DEFAULTSIZE = #{const LR_DEFAULTSIZE} 102 | 103 | type LoadImageFlags = UINT 104 | 105 | #{enum LoadImageFlags, 106 | , lR_DEFAULTCOLOR = LR_DEFAULTCOLOR 107 | , lR_CREATEDIBSECTION = LR_CREATEDIBSECTION 108 | , lR_LOADFROMFILE = LR_LOADFROMFILE 109 | , lR_LOADMAP3DCOLORS = LR_LOADMAP3DCOLORS 110 | , lR_LOADTRANSPARENT = LR_LOADTRANSPARENT 111 | , lR_MONOCHROME = LR_MONOCHROME 112 | , lR_SHARED = LR_SHARED 113 | } 114 | 115 | -- , LR_VGACOLOR (Not in mingw-20001111 headers) 116 | 117 | -- was: LPCTSTR_ 118 | loadImage :: HINSTANCE -> String -> ResourceImageType -> ResourceSize -> ResourceSize -> LoadImageFlags -> IO HANDLE 119 | loadImage inst name ty x y load = 120 | withTString name $ \ c_name -> 121 | failIfNull "LoadImage" $ c_LoadImage inst c_name ty x y load 122 | foreign import WINDOWS_CCONV unsafe "windows.h LoadImageW" 123 | c_LoadImage :: HINSTANCE -> LPCTSTR -> ResourceImageType -> ResourceSize -> ResourceSize -> LoadImageFlags -> IO HANDLE 124 | 125 | loadResource :: HMODULE -> HRSRC -> IO HGLOBAL 126 | loadResource hmod res = 127 | failIfNull "LoadResource" $ c_LoadResource hmod res 128 | foreign import WINDOWS_CCONV unsafe "windows.h LoadResource" 129 | c_LoadResource :: HMODULE -> HRSRC -> IO HGLOBAL 130 | 131 | lockResource :: HGLOBAL -> IO Addr 132 | lockResource res = 133 | failIfNull "LockResource" $ c_LockResource res 134 | foreign import WINDOWS_CCONV unsafe "windows.h LockResource" 135 | c_LockResource :: HGLOBAL -> IO Addr 136 | 137 | sizeofResource :: HMODULE -> HRSRC -> IO DWORD 138 | sizeofResource hmod res = 139 | failIfZero "SizeofResource" $ c_SizeofResource hmod res 140 | foreign import WINDOWS_CCONV unsafe "windows.h SizeofResource" 141 | c_SizeofResource :: HMODULE -> HRSRC -> IO DWORD 142 | 143 | -- was: LPCTSTR_ 144 | updateResource :: HANDLE -> ResourceType -> String -> WORD -> Addr -> DWORD -> IO () 145 | updateResource h ty name lang p_data data_len = 146 | withTString name $ \ c_name -> 147 | failIfFalse_ "UpdateResource" $ 148 | c_UpdateResource h ty c_name lang p_data data_len 149 | foreign import WINDOWS_CCONV unsafe "windows.h UpdateResourceW" 150 | c_UpdateResource :: HANDLE -> LPCTSTR -> LPCTSTR -> WORD -> Addr -> DWORD -> IO Bool 151 | -------------------------------------------------------------------------------- /System/Win32/FileMapping.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : System.Win32.FileMapping 9 | -- Copyright : (c) Esa Ilari Vuokko, 2006 10 | -- License : BSD-style (see the file LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32 mapped files. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | module System.Win32.FileMapping 20 | ( mapFile 21 | , MappedObject(..) 22 | , withMappedFile 23 | , withMappedArea 24 | -- * Enums 25 | -- ** Section protection flags 26 | , ProtectSectionFlags 27 | , sEC_COMMIT 28 | , sEC_IMAGE 29 | , sEC_NOCACHE 30 | , sEC_RESERVE 31 | -- ** Access falgs 32 | , FileMapAccess 33 | , fILE_MAP_ALL_ACCESS 34 | , fILE_MAP_COPY 35 | , fILE_MAP_READ 36 | , fILE_MAP_WRITE 37 | , fILE_SHARE_WRITE 38 | 39 | -- * Mapping files 40 | , createFileMapping 41 | , openFileMapping 42 | , mapViewOfFileEx 43 | , mapViewOfFile 44 | , unmapViewOfFile 45 | ) where 46 | 47 | 48 | import System.Win32.FileMapping.Internal 49 | import System.Win32.Types ( HANDLE, BOOL, SIZE_T, withTString 50 | , failIf, failIfNull, DDWORD, ddwordToDwords 51 | , iNVALID_HANDLE_VALUE ) 52 | import System.Win32.Mem 53 | import System.Win32.File 54 | import System.Win32.Info 55 | 56 | import Control.Exception ( mask_, bracket ) 57 | import Foreign ( Ptr, nullPtr, plusPtr, maybeWith 58 | , ForeignPtr, newForeignPtr ) 59 | 60 | ##include "windows_cconv.h" 61 | 62 | #include "windows.h" 63 | 64 | --------------------------------------------------------------------------- 65 | -- Derived functions 66 | --------------------------------------------------------------------------- 67 | 68 | -- | Maps file fully and returns ForeignPtr and length of the mapped area. 69 | -- The mapped file is opened read-only and shared reading. 70 | mapFile :: FilePath -> IO (ForeignPtr a, Int) 71 | mapFile path = do 72 | bracket 73 | (createFile path gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing) 74 | (closeHandle) 75 | $ \fh -> bracket 76 | (createFileMapping (Just fh) pAGE_READONLY 0 Nothing) 77 | (closeHandle) 78 | $ \fm -> do 79 | fi <- getFileInformationByHandle fh 80 | fp <- mask_ $ do 81 | ptr <- mapViewOfFile fm fILE_MAP_READ 0 0 82 | newForeignPtr c_UnmapViewOfFileFinaliser ptr 83 | return (fp, fromIntegral $ bhfiSize fi) 84 | 85 | -- | Opens an existing file and creates mapping object to it. 86 | withMappedFile 87 | :: FilePath -- ^ Path 88 | -> Bool -- ^ Write? (False = read-only) 89 | -> Maybe Bool -- ^ Sharing mode, no sharing, share read, share read+write 90 | -> (Integer -> MappedObject -> IO a) -- ^ Action 91 | -> IO a 92 | withMappedFile path write share act = 93 | bracket 94 | (createFile path access share' Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing) 95 | (closeHandle) 96 | $ \fh -> bracket 97 | (createFileMapping (Just fh) page 0 Nothing) 98 | (closeHandle) 99 | $ \fm -> do 100 | bhfi <- getFileInformationByHandle fh 101 | act (fromIntegral $ bhfiSize bhfi) (MappedObject fh fm mapaccess) 102 | where 103 | access = if write then gENERIC_READ+gENERIC_WRITE else gENERIC_READ 104 | page = if write then pAGE_READWRITE else pAGE_READONLY 105 | mapaccess = if write then fILE_MAP_ALL_ACCESS else fILE_MAP_READ 106 | share' = case share of 107 | Nothing -> fILE_SHARE_NONE 108 | Just False -> fILE_SHARE_READ 109 | Just True -> fILE_SHARE_READ + fILE_SHARE_WRITE 110 | 111 | -- | Maps area into memory. 112 | withMappedArea 113 | :: MappedObject -- ^ Mapped object, from withMappedFile 114 | -> Integer -- ^ Position in file 115 | -> Int -- ^ Size of mapped area 116 | -> (Ptr a -> IO b) -- ^ Action 117 | -> IO b 118 | withMappedArea (MappedObject _ mh access) pos size act = do 119 | si <- getSystemInfo 120 | let gran = fromIntegral $ siAllocationGranularity si 121 | (blocks, offset) = divMod pos gran 122 | start = blocks*gran 123 | size' = fromIntegral $ size + fromIntegral (pos - start) 124 | bracket 125 | (mapViewOfFileEx mh access (fromIntegral start) size' nullPtr) 126 | (unmapViewOfFile) 127 | (act . flip plusPtr (fromIntegral offset)) 128 | 129 | --------------------------------------------------------------------------- 130 | -- API in Haskell 131 | --------------------------------------------------------------------------- 132 | createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> IO HANDLE 133 | createFileMapping mh flags mosize name = 134 | maybeWith withTString name $ \c_name -> 135 | failIf (==nullPtr) "createFileMapping: CreateFileMapping" $ c_CreateFileMapping handle nullPtr flags moshi moslow c_name 136 | where 137 | (moshi,moslow) = ddwordToDwords mosize 138 | handle = maybe iNVALID_HANDLE_VALUE id mh 139 | 140 | openFileMapping :: FileMapAccess -> BOOL -> Maybe String -> IO HANDLE 141 | openFileMapping access inherit name = 142 | maybeWith withTString name $ \c_name -> 143 | failIf (==nullPtr) "openFileMapping: OpenFileMapping" $ 144 | c_OpenFileMapping access inherit c_name 145 | 146 | mapViewOfFileEx :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> Ptr a -> IO (Ptr b) 147 | mapViewOfFileEx h access offset size base = 148 | failIfNull "mapViewOfFile(Ex): c_MapViewOfFileEx" $ 149 | c_MapViewOfFileEx h access ohi olow size base 150 | where 151 | (ohi,olow) = ddwordToDwords offset 152 | 153 | mapViewOfFile :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> IO (Ptr a) 154 | mapViewOfFile h a o s = mapViewOfFileEx h a o s nullPtr 155 | 156 | unmapViewOfFile :: Ptr a -> IO () 157 | unmapViewOfFile v = c_UnmapViewOfFile v >> return () 158 | 159 | -------------------------------------------------------------------------------- /Win32.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | name: Win32 3 | version: 2.14.2.1 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Alastair Reid, shelarcy, Tamar Christina 7 | copyright: Alastair Reid, 1999-2003; shelarcy, 2012-2013; Tamar Christina, 2016-2020 8 | maintainer: Haskell Libraries 9 | bug-reports: https://github.com/haskell/win32/issues 10 | homepage: https://github.com/haskell/win32 11 | category: System, Graphics 12 | synopsis: A binding to Windows Win32 API. 13 | description: This library contains direct bindings to the Windows Win32 APIs for Haskell. 14 | build-type: Simple 15 | extra-source-files: 16 | include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h 17 | include/Win32Aux.h include/win32debug.h include/alignment.h 18 | extra-doc-files: 19 | changelog.md 20 | tested-with: 21 | GHC == 9.2.7, 22 | GHC == 9.4.5, 23 | GHC == 9.6.7, 24 | GHC == 9.8.4, 25 | GHC == 9.10.1, 26 | GHC == 9.12.1 27 | 28 | flag os-string 29 | description: Use the new os-string package 30 | default: False 31 | manual: False 32 | 33 | Library 34 | default-language: Haskell2010 35 | default-extensions: ForeignFunctionInterface, CPP 36 | if impl(ghc >= 7.1) 37 | default-extensions: NondecreasingIndentation 38 | 39 | if !os(windows) 40 | -- This package requires Windows to build 41 | build-depends: unbuildable<0 42 | buildable: False 43 | 44 | build-depends: base >= 4.5 && < 5 45 | 46 | -- AFPP support 47 | if impl(ghc >= 8.0) 48 | if flag(os-string) 49 | build-depends: filepath >= 1.5.0.0, os-string >= 2.0.0 50 | else 51 | build-depends: filepath >= 1.4.100.0 && < 1.5.0.0 52 | 53 | -- Black list hsc2hs 0.68.6 which is horribly broken. 54 | build-tool-depends: hsc2hs:hsc2hs > 0 && < 0.68.6 || > 0.68.6 55 | ghc-options: -Wall -fno-warn-name-shadowing 56 | cc-options: -fno-strict-aliasing 57 | exposed-modules: 58 | Graphics.Win32.GDI 59 | Graphics.Win32.GDI.Bitmap 60 | Graphics.Win32.GDI.Brush 61 | Graphics.Win32.GDI.Clip 62 | Graphics.Win32.GDI.Font 63 | Graphics.Win32.GDI.Graphics2D 64 | Graphics.Win32.GDI.HDC 65 | Graphics.Win32.GDI.Palette 66 | Graphics.Win32.GDI.Path 67 | Graphics.Win32.GDI.Pen 68 | Graphics.Win32.GDI.Region 69 | Graphics.Win32.GDI.Types 70 | Graphics.Win32 71 | Graphics.Win32.Control 72 | Graphics.Win32.Dialogue 73 | Graphics.Win32.Icon 74 | Graphics.Win32.Key 75 | Graphics.Win32.Menu 76 | Graphics.Win32.Message 77 | Graphics.Win32.Misc 78 | Graphics.Win32.Resource 79 | Graphics.Win32.Window 80 | Graphics.Win32.LayeredWindow 81 | Graphics.Win32.GDI.AlphaBlend 82 | Graphics.Win32.Window.AnimateWindow 83 | Graphics.Win32.Window.HotKey 84 | Graphics.Win32.Window.IMM 85 | Graphics.Win32.Window.ForegroundWindow 86 | Graphics.Win32.Window.PostMessage 87 | 88 | Media.Win32 89 | 90 | System.Win32 91 | System.Win32.DebugApi 92 | System.Win32.DLL 93 | System.Win32.Event 94 | System.Win32.File 95 | System.Win32.FileMapping 96 | System.Win32.NamedPipes 97 | System.Win32.Info 98 | System.Win32.Path 99 | System.Win32.Mem 100 | System.Win32.MinTTY 101 | System.Win32.NLS 102 | System.Win32.Process 103 | System.Win32.Registry 104 | System.Win32.SimpleMAPI 105 | System.Win32.Time 106 | System.Win32.Console 107 | System.Win32.Security 108 | System.Win32.Semaphore 109 | System.Win32.Types 110 | System.Win32.Shell 111 | System.Win32.Automation 112 | System.Win32.Automation.Input 113 | System.Win32.Automation.Input.Key 114 | System.Win32.Automation.Input.Mouse 115 | System.Win32.Console.CtrlHandler 116 | System.Win32.Console.HWND 117 | System.Win32.Console.Title 118 | System.Win32.Encoding 119 | System.Win32.Exception.Unsupported 120 | System.Win32.HardLink 121 | System.Win32.Info.Computer 122 | System.Win32.Info.Version 123 | System.Win32.String 124 | System.Win32.SymbolicLink 125 | System.Win32.Thread 126 | System.Win32.Utils 127 | System.Win32.Word 128 | 129 | -- AFPP support 130 | if impl(ghc >= 8.0) 131 | exposed-modules: 132 | System.Win32.WindowsString.Console 133 | System.Win32.WindowsString.Types 134 | System.Win32.WindowsString.DebugApi 135 | System.Win32.WindowsString.DLL 136 | System.Win32.WindowsString.Shell 137 | System.Win32.WindowsString.String 138 | System.Win32.WindowsString.File 139 | System.Win32.WindowsString.Time 140 | System.Win32.WindowsString.Info 141 | System.Win32.WindowsString.FileMapping 142 | System.Win32.WindowsString.HardLink 143 | System.Win32.WindowsString.Path 144 | System.Win32.WindowsString.SymbolicLink 145 | System.Win32.WindowsString.Utils 146 | 147 | other-modules: 148 | System.Win32.Console.Internal 149 | System.Win32.DebugApi.Internal 150 | System.Win32.DLL.Internal 151 | System.Win32.File.Internal 152 | System.Win32.FileMapping.Internal 153 | System.Win32.HardLink.Internal 154 | System.Win32.Info.Internal 155 | System.Win32.Path.Internal 156 | System.Win32.Shell.Internal 157 | System.Win32.SymbolicLink.Internal 158 | System.Win32.Time.Internal 159 | 160 | extra-libraries: 161 | "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder", "shlwapi", "msimg32", "imm32" 162 | ghc-options: -Wall 163 | include-dirs: include 164 | install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h", "windows_cconv.h", "alphablend.h", "wincon_compat.h", "winternl_compat.h", "winuser_compat.h", "winreg_compat.h", "tlhelp32_compat.h", "winnls_compat.h", "winnt_compat.h", "namedpipeapi_compat.h" 165 | c-sources: 166 | cbits/HsGDI.c 167 | cbits/HsWin32.c 168 | cbits/WndProc.c 169 | cbits/diatemp.c 170 | cbits/dumpBMP.c 171 | cbits/ellipse.c 172 | cbits/errors.c 173 | cbits/alphablend.c 174 | cc-options: -Wall 175 | 176 | source-repository head 177 | type: git 178 | location: git://github.com/haskell/win32 179 | -------------------------------------------------------------------------------- /Graphics/Win32/GDI/Clip.hsc: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 709 2 | {-# LANGUAGE Safe #-} 3 | #else 4 | {-# LANGUAGE Trustworthy #-} 5 | #endif 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Graphics.Win32.GDI.Clip 9 | -- Copyright : (c) Alastair Reid, 1997-2003 10 | -- License : BSD-style (see the file libraries/base/LICENSE) 11 | -- 12 | -- Maintainer : Esa Ilari Vuokko 13 | -- Stability : provisional 14 | -- Portability : portable 15 | -- 16 | -- A collection of FFI declarations for interfacing with Win32. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Graphics.Win32.GDI.Clip where 21 | 22 | import Control.Monad 23 | import Graphics.Win32.GDI.Types 24 | import System.Win32.Types 25 | import Graphics.Win32.Message ( WindowMessage ) 26 | 27 | import Foreign 28 | 29 | ##include "windows_cconv.h" 30 | 31 | #undef WINVER 32 | #define WINVER 0x0600 33 | #undef _WIN32_WINNT 34 | #define _WIN32_WINNT 0x0600 35 | 36 | #include 37 | 38 | type ClipboardFormat = UINT 39 | 40 | #{enum ClipboardFormat, 41 | , cF_BITMAP = CF_BITMAP 42 | , cF_DIB = CF_DIB 43 | , cF_DIF = CF_DIF 44 | , cF_DSPBITMAP = CF_DSPBITMAP 45 | , cF_DSPENHMETAFILE = CF_DSPENHMETAFILE 46 | , cF_DSPMETAFILEPICT = CF_DSPMETAFILEPICT 47 | , cF_DSPTEXT = CF_DSPTEXT 48 | , cF_ENHMETAFILE = CF_ENHMETAFILE 49 | , cF_GDIOBJFIRST = CF_GDIOBJFIRST 50 | , cF_HDROP = CF_HDROP 51 | , cF_LOCALE = CF_LOCALE 52 | , cF_METAFILEPICT = CF_METAFILEPICT 53 | , cF_OEMTEXT = CF_OEMTEXT 54 | , cF_OWNERDISPLAY = CF_OWNERDISPLAY 55 | , cF_PALETTE = CF_PALETTE 56 | , cF_PENDATA = CF_PENDATA 57 | , cF_PRIVATEFIRST = CF_PRIVATEFIRST 58 | , cF_PRIVATELAST = CF_PRIVATELAST 59 | , cF_RIFF = CF_RIFF 60 | , cF_SYLK = CF_SYLK 61 | , cF_TEXT = CF_TEXT 62 | , cF_WAVE = CF_WAVE 63 | , cF_TIFF = CF_TIFF 64 | , cF_DIBV5 = CF_DIBV5 65 | , cF_GDIOBJLAST = CF_GDIOBJLAST 66 | , cF_UNICODETEXT = CF_UNICODETEXT 67 | } 68 | 69 | wM_CLIPBOARDUPDATE :: WindowMessage 70 | wM_CLIPBOARDUPDATE = 0x031D -- #const WM_CLIPBOARDUPDATE -- Can't use constant due to GHC 7.8.x support. 71 | 72 | -- % , CF_UNICODETEXT -- WinNT only 73 | 74 | foreign import WINDOWS_CCONV unsafe "windows.h ChangeClipboardChain" 75 | changeClipboardChain :: HWND -> HWND -> IO Bool 76 | 77 | closeClipboard :: IO () 78 | closeClipboard = 79 | failIfFalse_ "CloseClipboard" c_CloseClipboard 80 | foreign import WINDOWS_CCONV unsafe "windows.h CloseClipboard" 81 | c_CloseClipboard :: IO BOOL 82 | 83 | foreign import WINDOWS_CCONV unsafe "windows.h CountClipboardFormats" 84 | countClipboardFormats :: IO Int 85 | 86 | emptyClipboard :: IO () 87 | emptyClipboard = 88 | failIfFalse_ "EmptyClipboard" c_EmptyClipboard 89 | foreign import WINDOWS_CCONV unsafe "windows.h EmptyClipboard" 90 | c_EmptyClipboard :: IO BOOL 91 | 92 | -- original also tested GetLastError() != NO_ERROR 93 | 94 | enumClipboardFormats :: ClipboardFormat -> IO ClipboardFormat 95 | enumClipboardFormats format = do 96 | format' <- c_EnumClipboardFormats format 97 | when (format' == 0) $ 98 | failUnlessSuccess "EnumClipboardFormats" getLastError 99 | return format' 100 | foreign import WINDOWS_CCONV unsafe "windows.h EnumClipboardFormats" 101 | c_EnumClipboardFormats :: ClipboardFormat -> IO ClipboardFormat 102 | 103 | getClipboardData :: ClipboardFormat -> IO HANDLE 104 | getClipboardData format = 105 | failIfNull "GetClipboardData" $ c_GetClipboardData format 106 | foreign import WINDOWS_CCONV unsafe "windows.h GetClipboardData" 107 | c_GetClipboardData :: ClipboardFormat -> IO HANDLE 108 | 109 | getClipboardFormatName :: ClipboardFormat -> IO String 110 | getClipboardFormatName format = 111 | allocaArray 256 $ \ c_name -> do 112 | len <- failIfZero "GetClipboardFormatName" $ 113 | c_GetClipboardFormatName format c_name 256 114 | peekTStringLen (c_name, len) 115 | foreign import WINDOWS_CCONV unsafe "windows.h GetClipboardFormatNameW" 116 | c_GetClipboardFormatName :: ClipboardFormat -> LPTSTR -> Int -> IO Int 117 | 118 | getClipboardOwner :: IO HWND 119 | getClipboardOwner = 120 | failIfNull "GetClipboardOwner" c_GetClipboardOwner 121 | foreign import WINDOWS_CCONV unsafe "windows.h GetClipboardOwner" 122 | c_GetClipboardOwner :: IO HWND 123 | 124 | getClipboardViewer :: IO HWND 125 | getClipboardViewer = 126 | failIfNull "GetClipboardViewer" c_GetClipboardViewer 127 | foreign import WINDOWS_CCONV unsafe "windows.h GetClipboardViewer" 128 | c_GetClipboardViewer :: IO HWND 129 | 130 | getOpenClipboardWindow :: IO HWND 131 | getOpenClipboardWindow = 132 | failIfNull "GetClipboardWindow" c_GetOpenClipboardWindow 133 | foreign import WINDOWS_CCONV unsafe "windows.h GetOpenClipboardWindow" 134 | c_GetOpenClipboardWindow :: IO HWND 135 | 136 | getPriorityClipboardFormat :: [ClipboardFormat] -> IO Int 137 | getPriorityClipboardFormat formats = 138 | withArray formats $ \ format_array -> 139 | failIf (== -1) "GetPriorityClipboardFormat" $ 140 | c_GetPriorityClipboardFormat format_array (length formats) 141 | foreign import WINDOWS_CCONV unsafe "windows.h GetPriorityClipboardFormat" 142 | c_GetPriorityClipboardFormat :: Ptr UINT -> Int -> IO Int 143 | 144 | foreign import WINDOWS_CCONV unsafe "windows.h IsClipboardFormatAvailable" 145 | isClipboardFormatAvailable :: ClipboardFormat -> IO BOOL 146 | 147 | openClipboard :: HWND -> IO () 148 | openClipboard wnd = 149 | failIfFalse_ "OpenClipboard" $ c_OpenClipboard wnd 150 | foreign import WINDOWS_CCONV unsafe "windows.h OpenClipboard" 151 | c_OpenClipboard :: HWND -> IO BOOL 152 | 153 | registerClipboardFormat :: String -> IO ClipboardFormat 154 | registerClipboardFormat name = 155 | withTString name $ \ c_name -> 156 | failIfZero "RegisterClipboardFormat" $ 157 | c_RegisterClipboardFormat c_name 158 | foreign import WINDOWS_CCONV unsafe "windows.h RegisterClipboardFormatW" 159 | c_RegisterClipboardFormat :: LPCTSTR -> IO ClipboardFormat 160 | 161 | setClipboardData :: ClipboardFormat -> HANDLE -> IO HANDLE 162 | setClipboardData format mem = 163 | failIfNull "SetClipboardData" $ c_SetClipboardData format mem 164 | foreign import WINDOWS_CCONV unsafe "windows.h SetClipboardData" 165 | c_SetClipboardData :: ClipboardFormat -> HANDLE -> IO HANDLE 166 | 167 | setClipboardViewer :: HWND -> IO HWND 168 | setClipboardViewer wnd = 169 | failIfNull "SetClipboardViewer" $ c_SetClipboardViewer wnd 170 | foreign import WINDOWS_CCONV unsafe "windows.h SetClipboardViewer" 171 | c_SetClipboardViewer :: HWND -> IO HWND 172 | -------------------------------------------------------------------------------- /cbits/dumpBMP.c: -------------------------------------------------------------------------------- 1 | /******************************Module*Header*******************************\ 2 | * Module Name: savebmp.c 3 | * 4 | * 5 | * Created: 06-Jan-1992 10:59:36 6 | * 7 | * Copyright (C) 1993-1995 Microsoft Corporation 8 | * 9 | * Contains the main routine, SaveBitmapFile, for saving a DDB into file 10 | * in DIB format. 11 | * 12 | * Dependencies: 13 | * 14 | * (#defines) 15 | * (#includes) 16 | * #include 17 | * 18 | \**************************************************************************/ 19 | #define UNICODE 20 | #include 21 | #include 22 | #include "dumpBMP.h" 23 | 24 | /******************************Public*Routine******************************\ 25 | * SaveBitmapFile 26 | * 27 | * 28 | * Effects: Save pInfo->hBmpSaved into disk specified by pszFileName 29 | * 30 | * Warnings: assumes hBmpSaved is not selected into window's DC other than 31 | * pInfo->hwnd's DC 32 | * 33 | \**************************************************************************/ 34 | 35 | //typedef LPBITMAPINFO PBITMAPINFO; // hack to keep cygwin32b17 happy 36 | 37 | void CreateBMPFile(LPCTSTR pszFileName, HBITMAP hBmp, HDC hDC) 38 | { 39 | HANDLE hFile; 40 | HBITMAP hTmpBmp, hBmpOld; 41 | BITMAPFILEHEADER bfh; 42 | LPBITMAPINFO pbmi; 43 | PBYTE pBits; 44 | BITMAPINFO bmi; 45 | PBYTE pjTmp, pjTmpBmi; 46 | ULONG sizBMI; 47 | DWORD dwBytesWritten; 48 | 49 | 50 | #if 0 51 | if (ghPal) { 52 | SelectPalette(hDC, ghPal, FALSE); 53 | RealizePalette(hDC); 54 | } 55 | #endif 56 | if (!hBmp) { 57 | fprintf(stderr, "There's no Bitmap to save!"); 58 | return; 59 | } 60 | 61 | // 62 | // Let the graphics engine to retrieve the dimension of the bitmap for us 63 | // GetDIBits uses the size to determine if its BITMAPCOREINFO or BITMAPINFO 64 | // if BitCount != 0, color table will be retrieved 65 | // 66 | bmi.bmiHeader.biSize = 0x28; // GDI need this to work 67 | bmi.bmiHeader.biBitCount = 0; // don't get the color table 68 | if ((GetDIBits(hDC, hBmp, 0, 0, (LPSTR)NULL, &bmi, DIB_RGB_COLORS)) == 0) { 69 | fprintf(stderr, "GetDIBits failed!"); 70 | return; 71 | } 72 | 73 | // 74 | // Now that we know the size of the image, alloc enough memory to retrieve 75 | // the actual bits 76 | // 77 | if ((pBits = (PBYTE)GlobalAlloc(GMEM_FIXED | GMEM_ZEROINIT, 78 | bmi.bmiHeader.biSizeImage)) == NULL) { 79 | fprintf(stderr, "Failed in Memory Allocation for pBits!"); 80 | return; 81 | } 82 | 83 | // 84 | // Note: 24 bits per pixel has no color table. So, we don't have to 85 | // allocate memory for retrieving that. Otherwise, we do. 86 | // 87 | pbmi = &bmi; // assume no color table 88 | 89 | switch (bmi.bmiHeader.biBitCount) { 90 | case 24: // has color table 91 | sizBMI = sizeof(BITMAPINFOHEADER); 92 | break; 93 | case 16: 94 | case 32: 95 | sizBMI = sizeof(BITMAPINFOHEADER)+sizeof(DWORD)*3; 96 | break; 97 | default: 98 | sizBMI = sizeof(BITMAPINFOHEADER)+sizeof(RGBQUAD)*(1<bmiHeader.biSizeImage; 144 | bfh.bfReserved1 = 145 | bfh.bfReserved2 = 0; 146 | bfh.bfOffBits = sizeof(BITMAPFILEHEADER)+sizBMI; 147 | 148 | // 149 | // Write out the file header now 150 | // 151 | if (WriteFile(hFile, (LPCVOID)&bfh, sizeof(BITMAPFILEHEADER), &dwBytesWritten, NULL) == -1) { 152 | fprintf(stderr, "Failed in WriteFile!"); 153 | goto ErrExit3; 154 | } 155 | 156 | // 157 | // Bitmap cant be selected into a DC when calling GetDIBits 158 | // Assume that the hDC is the DC where the bitmap would have been selected 159 | // if indeed it has been selected 160 | // 161 | hTmpBmp = CreateCompatibleBitmap(hDC, pbmi->bmiHeader.biWidth, pbmi->bmiHeader.biHeight); 162 | if (hTmpBmp) { 163 | hBmpOld = SelectObject(hDC, hTmpBmp); 164 | if ((GetDIBits(hDC, hBmp, 0, pbmi->bmiHeader.biHeight, (LPSTR)pBits, pbmi, DIB_RGB_COLORS))==0){ 165 | fprintf(stderr, "Failed in GetDIBits!"); 166 | goto ErrExit4; 167 | } 168 | } else { 169 | fprintf(stderr, "Failed in creating bitmap!"); 170 | goto ErrExit3; 171 | } 172 | 173 | // 174 | // Now write out the BitmapInfoHeader and color table, if any 175 | // 176 | if (WriteFile(hFile, (LPCVOID)pbmi, sizBMI, &dwBytesWritten, NULL) == -1) { 177 | fprintf(stderr, "Failed in WriteFile!"); 178 | goto ErrExit4; 179 | } 180 | 181 | // 182 | // write the bits also 183 | // 184 | if (WriteFile(hFile, (LPCVOID)pBits, pbmi->bmiHeader.biSizeImage, &dwBytesWritten, NULL) == -1) { 185 | fprintf(stderr, "Failed in WriteFile!"); 186 | goto ErrExit4; 187 | } 188 | 189 | 190 | ErrExit4: 191 | SelectObject(hDC, hBmpOld); 192 | DeleteObject(hTmpBmp); 193 | ErrExit3: 194 | CloseHandle(hFile); 195 | ErrExit2: 196 | GlobalFree(pbmi); 197 | ErrExit1: 198 | GlobalFree(pBits); 199 | return; 200 | } 201 | 202 | -------------------------------------------------------------------------------- /System/Win32/WindowsString/Console.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : System.Win32.WindowsString.Console 6 | -- Copyright : (c) University of Glasgow 2023 7 | -- License : BSD-style (see the file LICENSE) 8 | -- 9 | -- Maintainer : Esa Ilari Vuokko 10 | -- Stability : provisional 11 | -- Portability : portable 12 | -- 13 | -- A collection of FFI declarations for interfacing with Win32 Console API (WindowsString variant) 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module System.Win32.WindowsString.Console ( 18 | -- * Console mode 19 | getConsoleMode, 20 | setConsoleMode, 21 | eNABLE_ECHO_INPUT, 22 | eNABLE_EXTENDED_FLAGS, 23 | eNABLE_INSERT_MODE, 24 | eNABLE_LINE_INPUT, 25 | eNABLE_MOUSE_INPUT, 26 | eNABLE_PROCESSED_INPUT, 27 | eNABLE_QUICK_EDIT_MODE, 28 | eNABLE_WINDOW_INPUT, 29 | eNABLE_VIRTUAL_TERMINAL_INPUT, 30 | eNABLE_PROCESSED_OUTPUT, 31 | eNABLE_WRAP_AT_EOL_OUTPUT, 32 | eNABLE_VIRTUAL_TERMINAL_PROCESSING, 33 | dISABLE_NEWLINE_AUTO_RETURN, 34 | eNABLE_LVB_GRID_WORLDWIDE, 35 | -- * Console code pages 36 | getConsoleCP, 37 | setConsoleCP, 38 | getConsoleOutputCP, 39 | setConsoleOutputCP, 40 | -- * Ctrl events 41 | CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT, 42 | generateConsoleCtrlEvent, 43 | -- * Command line 44 | commandLineToArgv, 45 | getCommandLineW, 46 | getArgs, 47 | -- * Screen buffer 48 | CONSOLE_SCREEN_BUFFER_INFO(..), 49 | CONSOLE_SCREEN_BUFFER_INFOEX(..), 50 | COORD(..), 51 | SMALL_RECT(..), 52 | COLORREF, 53 | getConsoleScreenBufferInfo, 54 | getCurrentConsoleScreenBufferInfo, 55 | getConsoleScreenBufferInfoEx, 56 | getCurrentConsoleScreenBufferInfoEx, 57 | 58 | -- * Env 59 | getEnv, 60 | getEnvironment 61 | ) where 62 | 63 | #include 64 | #include "alignment.h" 65 | ##include "windows_cconv.h" 66 | #include "wincon_compat.h" 67 | 68 | import System.Win32.WindowsString.Types 69 | import System.Win32.WindowsString.String (withTStringBufferLen) 70 | import System.Win32.Console.Internal 71 | import System.Win32.Console hiding (getArgs, commandLineToArgv, getEnv, getEnvironment) 72 | import System.OsString.Windows 73 | import System.OsString.Internal.Types 74 | 75 | import Foreign.C.Types (CWchar) 76 | import Foreign.C.String (CWString) 77 | import Foreign.Ptr (plusPtr) 78 | import Foreign.Storable (Storable(..)) 79 | import Foreign.Marshal.Array (peekArray, peekArray0) 80 | import Foreign.Marshal.Alloc (alloca) 81 | import GHC.IO (bracket) 82 | import GHC.IO.Exception (IOException(..), IOErrorType(OtherError)) 83 | 84 | import Prelude hiding (break, length, tail) 85 | import qualified Prelude as P 86 | 87 | #if !MIN_VERSION_filepath(1,5,0) 88 | import Data.Coerce 89 | import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC 90 | 91 | tail :: WindowsString -> WindowsString 92 | tail = coerce BC.tail 93 | 94 | break :: (WindowsChar -> Bool) -> WindowsString -> (WindowsString, WindowsString) 95 | break = coerce BC.break 96 | #endif 97 | 98 | 99 | -- | This function can be used to parse command line arguments and return 100 | -- the split up arguments as elements in a list. 101 | commandLineToArgv :: WindowsString -> IO [WindowsString] 102 | commandLineToArgv arg 103 | | arg == mempty = return [] 104 | | otherwise = withTString arg $ \c_arg -> do 105 | alloca $ \c_size -> do 106 | res <- c_CommandLineToArgvW c_arg c_size 107 | size <- peek c_size 108 | args <- peekArray (fromIntegral size) res 109 | _ <- localFree res 110 | mapM peekTString args 111 | 112 | -- | Based on 'GetCommandLineW'. This behaves slightly different 113 | -- than 'System.Environment.getArgs'. See the online documentation: 114 | -- 115 | getArgs :: IO [WindowsString] 116 | getArgs = do 117 | getCommandLineW >>= peekTString >>= commandLineToArgv 118 | 119 | 120 | -- c_GetEnvironmentVariableW :: LPCWSTR -> LPWSTR -> DWORD -> IO DWORD 121 | getEnv :: WindowsString -> IO (Maybe WindowsString) 122 | getEnv name = 123 | withTString name $ \c_name -> withTStringBufferLen maxLength $ \(buf, len) -> do 124 | let c_len = fromIntegral len 125 | c_len' <- c_GetEnvironmentVariableW c_name buf c_len 126 | case c_len' of 127 | 0 -> do 128 | err_code <- getLastError 129 | if err_code == eERROR_ENVVAR_NOT_FOUND 130 | then return Nothing 131 | else errorWin "GetEnvironmentVariableW" 132 | _ | c_len' > fromIntegral maxLength -> 133 | -- shouldn't happen, because we provide maxLength 134 | ioError (IOError Nothing OtherError "GetEnvironmentVariableW" ("Unexpected return code: " <> show c_len') Nothing Nothing) 135 | | otherwise -> do 136 | let len' = fromIntegral c_len' 137 | Just <$> peekTStringLen (buf, len') 138 | where 139 | -- according to https://learn.microsoft.com/en-us/windows/win32/api/processenv/nf-processenv-getenvironmentvariablew 140 | -- max characters (wide chars): 32767 141 | -- => bytes = 32767 * 2 = 65534 142 | -- +1 byte for NUL (although not needed I think) 143 | maxLength :: Int 144 | maxLength = 65535 145 | 146 | 147 | getEnvironment :: IO [(WindowsString, WindowsString)] 148 | getEnvironment = bracket c_GetEnvironmentStringsW c_FreeEnvironmentStrings $ \lpwstr -> do 149 | strs <- builder lpwstr 150 | return (divvy <$> strs) 151 | where 152 | divvy :: WindowsString -> (WindowsString, WindowsString) 153 | divvy str = 154 | case break (== unsafeFromChar '=') str of 155 | (xs,ys) 156 | | ys == mempty -> (xs,ys) -- don't barf (like Posix.getEnvironment) 157 | (name, ys) -> let value = tail ys in (name,value) 158 | 159 | builder :: LPWSTR -> IO [WindowsString] 160 | builder ptr = go 0 161 | where 162 | go :: Int -> IO [WindowsString] 163 | go off = do 164 | (str, l) <- peekCWStringOff ptr off 165 | if l == 0 166 | then pure [] 167 | else (str:) <$> go (((l + 1) * 2) + off) 168 | 169 | 170 | peekCWStringOff :: CWString -> Int -> IO (WindowsString, Int) 171 | peekCWStringOff cp off = do 172 | cs <- peekArray0 wNUL (cp `plusPtr` off) 173 | return (cWcharsToChars cs, P.length cs) 174 | 175 | wNUL :: CWchar 176 | wNUL = 0 177 | 178 | cWcharsToChars :: [CWchar] -> WindowsString 179 | cWcharsToChars = pack . fmap (WindowsChar . fromIntegral) 180 | 181 | --------------------------------------------------------------------------------