Win32 (empty) → 2.1
raw patch · 46 files changed
+9332/−0 lines, 46 filesdep +basebuild-type:Customsetup-changed
Dependencies added: base
Files
- Graphics/Win32.hs +42/−0
- Graphics/Win32/Control.hsc +340/−0
- Graphics/Win32/Dialogue.hsc +329/−0
- Graphics/Win32/GDI.hs +41/−0
- Graphics/Win32/GDI/Bitmap.hsc +416/−0
- Graphics/Win32/GDI/Brush.hsc +72/−0
- Graphics/Win32/GDI/Clip.hsc +148/−0
- Graphics/Win32/GDI/Font.hsc +203/−0
- Graphics/Win32/GDI/Graphics2D.hs +222/−0
- Graphics/Win32/GDI/HDC.hs +298/−0
- Graphics/Win32/GDI/Palette.hsc +46/−0
- Graphics/Win32/GDI/Path.hs +86/−0
- Graphics/Win32/GDI/Pen.hsc +102/−0
- Graphics/Win32/GDI/Region.hs +145/−0
- Graphics/Win32/GDI/Types.hsc +394/−0
- Graphics/Win32/Icon.hs +44/−0
- Graphics/Win32/Key.hsc +120/−0
- Graphics/Win32/Menu.hsc +471/−0
- Graphics/Win32/Message.hsc +173/−0
- Graphics/Win32/Misc.hsc +294/−0
- Graphics/Win32/Resource.hsc +143/−0
- Graphics/Win32/Window.hsc +689/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- System/Win32.hs +46/−0
- System/Win32/Console.hsc +55/−0
- System/Win32/DLL.hsc +81/−0
- System/Win32/DebugApi.hsc +387/−0
- System/Win32/File.hsc +514/−0
- System/Win32/FileMapping.hsc +168/−0
- System/Win32/Info.hsc +342/−0
- System/Win32/Mem.hsc +267/−0
- System/Win32/NLS.hsc +338/−0
- System/Win32/Process.hsc +124/−0
- System/Win32/Registry.hsc +506/−0
- System/Win32/SimpleMAPI.hsc +389/−0
- System/Win32/Time.hsc +305/−0
- System/Win32/Types.hs +278/−0
- Win32.cabal +62/−0
- cbits/HsGDI.c +3/−0
- cbits/HsWin32.c +15/−0
- cbits/WndProc.c +90/−0
- cbits/diatemp.c +223/−0
- cbits/dumpBMP.c +207/−0
- cbits/ellipse.c +50/−0
- cbits/errors.c +32/−0
+ Graphics/Win32.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- An interface to the Microsoft Windows user interface.+-- See <http://msdn.microsoft.com/library/> under /User Interface Design+-- and Development/ and then /Windows User Interface/ for more details+-- of the underlying library.+--+-----------------------------------------------------------------------------++module Graphics.Win32 (+ module System.Win32.Types,+ module Graphics.Win32.Control,+ module Graphics.Win32.Dialogue,+ module Graphics.Win32.GDI,+ module Graphics.Win32.Icon,+ module Graphics.Win32.Key,+ module Graphics.Win32.Menu,+ module Graphics.Win32.Message,+ module Graphics.Win32.Misc,+ module Graphics.Win32.Resource,+ module Graphics.Win32.Window+ ) where++import System.Win32.Types+import Graphics.Win32.Control+import Graphics.Win32.Dialogue+import Graphics.Win32.GDI+import Graphics.Win32.Icon+import Graphics.Win32.Key+import Graphics.Win32.Menu+import Graphics.Win32.Message+import Graphics.Win32.Misc+import Graphics.Win32.Resource+import Graphics.Win32.Window
+ Graphics/Win32/Control.hsc view
@@ -0,0 +1,340 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.Control+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- FFI bindings to the various standard Win32 controls.+--+-----------------------------------------------------------------------------++module Graphics.Win32.Control where++import Graphics.Win32.GDI.Types+import Graphics.Win32.Window+import System.Win32.Types+import Graphics.Win32.Message++import Foreign++#include <windows.h>+#include <commctrl.h>++-- == Command buttons++type ButtonStyle = WindowStyle++#{enum ButtonStyle,+ , bS_PUSHBUTTON = BS_PUSHBUTTON+ , bS_DEFPUSHBUTTON = BS_DEFPUSHBUTTON+ , bS_CHECKBOX = BS_CHECKBOX+ , bS_AUTOCHECKBOX = BS_AUTOCHECKBOX+ , bS_RADIOBUTTON = BS_RADIOBUTTON+ , bS_3STATE = BS_3STATE+ , bS_AUTO3STATE = BS_AUTO3STATE+ , bS_GROUPBOX = BS_GROUPBOX+ , bS_AUTORADIOBUTTON = BS_AUTORADIOBUTTON+ , bS_OWNERDRAW = BS_OWNERDRAW+ , bS_LEFTTEXT = BS_LEFTTEXT+ , bS_USERBUTTON = BS_USERBUTTON+ }++createButton+ :: String -> WindowStyle -> ButtonStyle+ -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos+ -> Maybe HWND -> Maybe HMENU -> HANDLE+ -> IO HWND+createButton nm wstyle bstyle mb_x mb_y mb_w mb_h mb_parent mb_menu h =+ withTString nm $ \ c_nm ->+ failIfNull "CreateButton" $+ c_CreateWindowEx 0 buttonStyle c_nm (wstyle .|. bstyle)+ (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)+ (maybePtr mb_parent) (maybePtr mb_menu) h nullPtr++buttonStyle :: ClassName+buttonStyle = unsafePerformIO (newTString "BUTTON")++type ButtonState = UINT++#{enum ButtonState,+ , bST_CHECKED = BST_CHECKED+ , bST_INDETERMINATE = BST_INDETERMINATE+ , bST_UNCHECKED = BST_UNCHECKED+ }++checkDlgButton :: HWND -> Int -> ButtonState -> IO ()+checkDlgButton dialog button check =+ failIfFalse_ "CheckDlgButton" $ c_CheckDlgButton dialog button check+foreign import stdcall unsafe "windows.h CheckDlgButton"+ c_CheckDlgButton :: HWND -> Int -> ButtonState -> IO Bool++checkRadioButton :: HWND -> Int -> Int -> Int -> IO ()+checkRadioButton dialog first_button last_button check =+ failIfFalse_ "CheckRadioButton" $+ c_CheckRadioButton dialog first_button last_button check+foreign import stdcall unsafe "windows.h CheckRadioButton"+ c_CheckRadioButton :: HWND -> Int -> Int -> Int -> IO Bool++isDlgButtonChecked :: HWND -> Int -> IO ButtonState+isDlgButtonChecked wnd button =+ failIfZero "IsDlgButtonChecked" $ c_IsDlgButtonChecked wnd button+foreign import stdcall unsafe "windows.h IsDlgButtonChecked"+ c_IsDlgButtonChecked :: HWND -> Int -> IO ButtonState+++-- == ComboBoxes aka. pop up list boxes/selectors.++type ComboBoxStyle = WindowStyle++#{enum ComboBoxStyle,+ , cBS_SIMPLE = CBS_SIMPLE+ , cBS_DROPDOWN = CBS_DROPDOWN+ , cBS_DROPDOWNLIST = CBS_DROPDOWNLIST+ , cBS_OWNERDRAWFIXED = CBS_OWNERDRAWFIXED+ , cBS_OWNERDRAWVARIABLE = CBS_OWNERDRAWVARIABLE+ , cBS_AUTOHSCROLL = CBS_AUTOHSCROLL+ , cBS_OEMCONVERT = CBS_OEMCONVERT+ , cBS_SORT = CBS_SORT+ , cBS_HASSTRINGS = CBS_HASSTRINGS+ , cBS_NOINTEGRALHEIGHT = CBS_NOINTEGRALHEIGHT+ , cBS_DISABLENOSCROLL = CBS_DISABLENOSCROLL+ }++createComboBox+ :: String -> WindowStyle -> ComboBoxStyle+ -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos+ -> HWND -> Maybe HMENU -> HANDLE+ -> IO HWND+createComboBox nm wstyle cstyle mb_x mb_y mb_w mb_h parent mb_menu h =+ withTString nm $ \ c_nm ->+ failIfNull "CreateComboBox" $+ c_CreateWindowEx 0 comboBoxStyle c_nm (wstyle .|. cstyle)+ (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)+ parent (maybePtr mb_menu) h nullPtr++comboBoxStyle :: ClassName+comboBoxStyle = unsafePerformIO (newTString "COMBOBOX")++-- see comment about freeing windowNames in System.Win32.Window.createWindow+-- %end free(nm)+++--- == Edit controls++----------------------------------------------------------------++type EditStyle = WindowStyle++#{enum EditStyle,+ , eS_LEFT = ES_LEFT+ , eS_CENTER = ES_CENTER+ , eS_RIGHT = ES_RIGHT+ , eS_MULTILINE = ES_MULTILINE+ , eS_UPPERCASE = ES_UPPERCASE+ , eS_LOWERCASE = ES_LOWERCASE+ , eS_PASSWORD = ES_PASSWORD+ , eS_AUTOVSCROLL = ES_AUTOVSCROLL+ , eS_AUTOHSCROLL = ES_AUTOHSCROLL+ , eS_NOHIDESEL = ES_NOHIDESEL+ , eS_OEMCONVERT = ES_OEMCONVERT+ , eS_READONLY = ES_READONLY+ , eS_WANTRETURN = ES_WANTRETURN+ }++createEditWindow+ :: String -> WindowStyle -> EditStyle+ -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos+ -> HWND -> Maybe HMENU -> HANDLE+ -> IO HWND+createEditWindow nm wstyle estyle mb_x mb_y mb_w mb_h parent mb_menu h =+ withTString nm $ \ c_nm ->+ failIfNull "CreateEditWindow" $+ c_CreateWindowEx 0 editStyle c_nm (wstyle .|. estyle)+ (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)+ parent (maybePtr mb_menu) h nullPtr++editStyle :: ClassName+editStyle = unsafePerformIO (newTString "EDIT")++-- see comment about freeing windowNames in System.Win32.Window.createWindow+-- %end free(nm)++-- == List boxes+++----------------------------------------------------------------++type ListBoxStyle = WindowStyle++#{enum ListBoxStyle,+ , lBS_NOTIFY = LBS_NOTIFY+ , lBS_SORT = LBS_SORT+ , lBS_NOREDRAW = LBS_NOREDRAW+ , lBS_MULTIPLESEL = LBS_MULTIPLESEL+ , lBS_OWNERDRAWFIXED = LBS_OWNERDRAWFIXED+ , lBS_OWNERDRAWVARIABLE = LBS_OWNERDRAWVARIABLE+ , lBS_HASSTRINGS = LBS_HASSTRINGS+ , lBS_USETABSTOPS = LBS_USETABSTOPS+ , lBS_NOINTEGRALHEIGHT = LBS_NOINTEGRALHEIGHT+ , lBS_MULTICOLUMN = LBS_MULTICOLUMN+ , lBS_WANTKEYBOARDINPUT = LBS_WANTKEYBOARDINPUT+ , lBS_DISABLENOSCROLL = LBS_DISABLENOSCROLL+ , lBS_STANDARD = LBS_STANDARD+ }++createListBox+ :: String -> WindowStyle -> ListBoxStyle+ -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos+ -> HWND -> Maybe HMENU -> HANDLE+ -> IO HWND+createListBox nm wstyle lstyle mb_x mb_y mb_w mb_h parent mb_menu h =+ withTString nm $ \ c_nm ->+ failIfNull "CreateListBox" $+ c_CreateWindowEx 0 listBoxStyle c_nm (wstyle .|. lstyle)+ (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)+ parent (maybePtr mb_menu) h nullPtr++listBoxStyle :: ClassName+listBoxStyle = unsafePerformIO (newTString "LISTBOX")++-- see comment about freeing windowNames in System.Win32.Window.createWindow+-- %end free(nm)++-- == Scrollbars+++----------------------------------------------------------------++type ScrollbarStyle = WindowStyle++#{enum ScrollbarStyle,+ , sBS_HORZ = SBS_HORZ+ , sBS_TOPALIGN = SBS_TOPALIGN+ , sBS_BOTTOMALIGN = SBS_BOTTOMALIGN+ , sBS_VERT = SBS_VERT+ , sBS_LEFTALIGN = SBS_LEFTALIGN+ , sBS_RIGHTALIGN = SBS_RIGHTALIGN+ , sBS_SIZEBOX = SBS_SIZEBOX+ , sBS_SIZEBOXTOPLEFTALIGN = SBS_SIZEBOXTOPLEFTALIGN+ , sBS_SIZEBOXBOTTOMRIGHTALIGN = SBS_SIZEBOXBOTTOMRIGHTALIGN+ }++createScrollbar+ :: String -> WindowStyle -> ScrollbarStyle+ -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos+ -> HWND -> Maybe HMENU -> HANDLE+ -> IO HWND+createScrollbar nm wstyle sstyle mb_x mb_y mb_w mb_h parent mb_menu h =+ withTString nm $ \ c_nm ->+ failIfNull "CreateScrollbar" $+ c_CreateWindowEx 0 scrollBarStyle c_nm (wstyle .|. sstyle)+ (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)+ parent (maybePtr mb_menu) h nullPtr++scrollBarStyle :: ClassName+scrollBarStyle = unsafePerformIO (newTString "SCROLLBAR")++-- see comment about freeing windowNames in System.Win32.Window.createWindow+-- %end free(nm)++-- == Static controls aka. labels+++----------------------------------------------------------------++type StaticControlStyle = WindowStyle++#{enum StaticControlStyle,+ , sS_LEFT = SS_LEFT+ , sS_CENTER = SS_CENTER+ , sS_RIGHT = SS_RIGHT+ , sS_ICON = SS_ICON+ , sS_BLACKRECT = SS_BLACKRECT+ , sS_GRAYRECT = SS_GRAYRECT+ , sS_WHITERECT = SS_WHITERECT+ , sS_BLACKFRAME = SS_BLACKFRAME+ , sS_GRAYFRAME = SS_GRAYFRAME+ , sS_WHITEFRAME = SS_WHITEFRAME+ , sS_SIMPLE = SS_SIMPLE+ , sS_LEFTNOWORDWRAP = SS_LEFTNOWORDWRAP+ , sS_NOPREFIX = SS_NOPREFIX+ }++createStaticWindow+ :: String -> WindowStyle -> StaticControlStyle+ -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos+ -> HWND -> Maybe HMENU -> HANDLE+ -> IO HWND+createStaticWindow nm wstyle sstyle mb_x mb_y mb_w mb_h parent mb_menu h =+ withTString nm $ \ c_nm ->+ failIfNull "CreateStaticWindow" $+ c_CreateWindowEx 0 staticStyle c_nm (wstyle .|. sstyle)+ (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)+ parent (maybePtr mb_menu) h nullPtr++staticStyle :: ClassName+staticStyle = unsafePerformIO (newTString "STATIC")++-- see comment about freeing windowNames in System.Win32.Window.createWindow+-- %end free(nm)++#if 0+UNTESTED - leave out++type CommonControl = Ptr ()++#{enum CommonControl,+ , toolTipsControl = TOOLTIPS_CLASS+ , trackBarControl = TRACKBAR_CLASS+ , upDownControl = UPDOWN_CLASS+ , progressBarControl = PROGRESS_CLASS+ , hotKeyControl = HOTKEY_CLASS+ , animateControl = ANIMATE_CLASS+ , statusControl = STATUSCLASSNAME+ , headerControl = WC_HEADER+ , listViewControl = WC_LISTVIEW+ , tabControl = WC_TABCONTROL+ , treeViewControl = WC_TREEVIEW+ , monthCalControl = MONTHCAL_CLASS+ , dateTimePickControl = DATETIMEPICK_CLASS+ , reBarControl = REBARCLASSNAME+ }+-- Not supplied in mingw-20001111+-- , comboBoxExControl = WC_COMBOBOXEX+-- , iPAddressControl = WC_IPADDRESS+-- , pageScrollerControl = WC_PAGESCROLLER++createCommonControl+ :: CommonControl -> WindowStyle -> String -> WindowStyle+ -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos+ -> Maybe HWND -> Maybe HMENU -> HANDLE+ -> IO HWND+createCommonControl c estyle nm wstyle mb_x mb_y mb_w mb_h mb_parent mb_menu h =+ withTString nm $ \ c_nm -> do+ failIfNull "CreateCommonControl" $+ c_CreateWindowEx c estyle c_nm wstyle+ (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)+ (maybePtr mb_parent) (maybePtr mb_menu) h nullPtr++foreign import stdcall unsafe "windows.h InitCommonControls"+ initCommonControls :: IO ()++#endif++#{enum WindowMessage,+ , pBM_DELTAPOS = PBM_DELTAPOS+ , pBM_SETPOS = PBM_SETPOS+ , pBM_SETRANGE = PBM_SETRANGE+ , pBM_SETSTEP = PBM_SETSTEP+ , pBM_STEPIT = PBM_STEPIT+ }++-- % , PBM_GETRANGE+-- % , PBM_GETPOS+-- % , PBM_SETBARCOLOR+-- % , PBM_SETBKCOLOR+-- % , PBM_SETRANGE32
+ Graphics/Win32/Dialogue.hsc view
@@ -0,0 +1,329 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.Dialogue+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.Dialogue where++import Graphics.Win32.GDI.Types+import Graphics.Win32.Control+import Graphics.Win32.Message+import Graphics.Win32.Window+import System.Win32.Types++import Foreign+import Foreign.C++#include <windows.h>++type DTemplate = LPCTSTR++type DTemplateMem = Ptr Stub_DTM+newtype Stub_DTM = Stub_DTM DTemplateMem++newtype DIA_TEMPLATE = DIA_TEMPLATE (Ptr DIA_TEMPLATE)++type DialogStyle = WindowStyle++mkDialogTemplate :: String -> IO DTemplate+mkDialogTemplate = newTString++type ResourceID = Int++mkResource :: ResourceID -> IO (Ptr a)+mkResource res = return (castUINTToPtr (fromIntegral res))++mkDialogTemplateFromResource :: Int -> IO DTemplate+mkDialogTemplateFromResource = mkResource++type DialogProc = HWND -> WindowMessage -> WPARAM -> LPARAM -> IO Int++marshall_dialogProc_ :: DialogProc -> IO (FunPtr DialogProc)+marshall_dialogProc_ cl = mkDialogClosure cl++-- ToDo: this was declared as a stdcall not a ccall - let's+-- hope and pray that it makes no difference - ADR+foreign import ccall "wrapper"+ mkDialogClosure :: DialogProc -> IO (FunPtr DialogProc)++dialogBox :: HINSTANCE -> DTemplate -> Maybe HWND -> DialogProc -> IO Int+dialogBox inst template mb_parent dia_fn =+ dialogBoxParam inst template mb_parent dia_fn 0++dialogBoxParam :: HINSTANCE -> DTemplate -> Maybe HWND -> DialogProc -> LPARAM -> IO Int+dialogBoxParam inst template mb_parent dia_fn init_val = do+ c_dia_fn <- mkDialogClosure dia_fn+ failIf (== -1) "DialogBoxParam" $+ c_DialogBoxParam inst template (maybePtr mb_parent) c_dia_fn init_val+foreign import stdcall "windows.h DialogBoxParamW"+ c_DialogBoxParam :: HINSTANCE -> DTemplate -> HWND -> FunPtr DialogProc -> LPARAM -> IO Int++dialogBoxIndirect :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> IO Int+dialogBoxIndirect inst template mb_parent dia_fn =+ dialogBoxIndirectParam inst template mb_parent dia_fn 0++dialogBoxIndirectParam :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> LPARAM -> IO Int+dialogBoxIndirectParam inst template mb_parent dia_fn init_val = do+ c_dia_fn <- mkDialogClosure dia_fn+ failIf (== -1) "DialogBoxIndirectParam" $+ c_DialogBoxIndirectParam inst template (maybePtr mb_parent) c_dia_fn init_val+foreign import stdcall "windows.h DialogBoxIndirectParamW"+ c_DialogBoxIndirectParam :: HINSTANCE -> DTemplateMem -> HWND -> FunPtr DialogProc -> LPARAM -> IO Int+++data DialogTemplate+ = DialogTemplate+ Int Int Int Int -- x, y, cx, cy+ WindowStyle+ DWORD+ (Either ResourceID String) -- menu+ (Either ResourceID String) -- class+ (Either ResourceID String) -- caption+ (Either ResourceID String) -- fontname+ Int -- font height+ [DialogControl]++data DialogControl+ = DialogControl+ Int Int Int Int -- x,y, cx, cy+ (Either ResourceID String) -- text+ (Either ResourceID String) -- classname+ WindowStyle+ DWORD+ Int -- dia_id++mkDialogFromTemplate :: DialogTemplate -> IO DTemplateMem+mkDialogFromTemplate (DialogTemplate x y cx cy+ wstyle extstyle+ mb_menu mb_class caption+ font font_height+ controls) = do+ prim_hmenu <- marshall_res mb_menu+ prim_class <- marshall_res mb_class+ prim_caption <- marshall_res caption+ prim_font <- marshall_res font+ dtemp <- mkDiaTemplate 0 x y cx cy wstyle extstyle+ prim_hmenu prim_class+ prim_caption prim_font+ font_height+ mapM_ (addControl dtemp) controls+ getFinalDialog dtemp++pushButtonControl :: Int -> Int -> Int -> Int+ -> DWORD -> DWORD -> Int+ -> String+ -> DialogControl+pushButtonControl x y cx cy style estyle dia_id lab =+ DialogControl x y cx cy (Left 0x0080) (Right lab)+ (style + bS_DEFPUSHBUTTON) estyle dia_id++labelControl :: Int -> Int -> Int -> Int+ -> DWORD -> DWORD -> Int+ -> String+ -> DialogControl+labelControl x y cx cy style estyle dia_id lab =+ DialogControl x y cx cy (Left 0x0082) (Right lab)+ (style + sS_LEFT) estyle dia_id++listBoxControl :: Int -> Int -> Int -> Int+ -> DWORD -> DWORD -> Int+ -> String+ -> DialogControl+listBoxControl x y cx cy style estyle dia_id lab =+ DialogControl x y cx cy (Left 0x0083) (Right lab)+ (style) estyle dia_id++comboBoxControl :: Int -> Int -> Int -> Int+ -> DWORD -> DWORD -> Int+ -> String+ -> DialogControl+comboBoxControl x y cx cy style estyle dia_id lab =+ DialogControl x y cx cy (Left 0x0085) (Right lab)+ (style) estyle dia_id++editControl :: Int -> Int -> Int -> Int+ -> DWORD -> DWORD -> Int+ -> String+ -> DialogControl+editControl x y cx cy style estyle dia_id lab =+ DialogControl x y cx cy (Left 0x0081) (Right lab)+ (style + eS_LEFT) estyle dia_id++scrollBarControl :: Int -> Int -> Int -> Int+ -> DWORD -> DWORD -> Int+ -> String+ -> DialogControl+scrollBarControl x y cx cy style estyle dia_id lab =+ DialogControl x y cx cy (Left 0x0084) (Right lab)+ (style) estyle dia_id++foreign import ccall unsafe "diatemp.h getFinalDialog"+ getFinalDialog :: Ptr DIA_TEMPLATE -> IO DTemplateMem++foreign import ccall unsafe "diatemp.h mkDiaTemplate"+ mkDiaTemplate :: Int -> Int -> Int -> Int -> Int -> WindowStyle -> DWORD ->+ LPCWSTR -> LPCWSTR -> LPCWSTR -> LPCWSTR -> Int -> IO (Ptr DIA_TEMPLATE)++addControl :: Ptr DIA_TEMPLATE -> DialogControl -> IO ()+addControl dtemp (DialogControl x y cx cy mb_text mb_class+ style exstyle+ dia_id) = do+ prim_text <- marshall_res mb_text+ prim_class <- marshall_res mb_class+ addDiaControl dtemp prim_text dia_id prim_class style+ x y cx cy exstyle+ return ()++foreign import ccall unsafe "diatemp.h addDiaControl"+ addDiaControl :: Ptr DIA_TEMPLATE -> LPCWSTR -> Int -> LPCWSTR -> DWORD ->+ Int -> Int -> Int -> Int -> DWORD -> IO (Ptr DIA_TEMPLATE)++{-# CFILES cbits/diatemp.c #-}++marshall_res :: Either ResourceID String -> IO LPCWSTR+marshall_res (Left r) = mkResource r+marshall_res (Right s) = newCWString s++-- modeless dialogs++createDialog :: HINSTANCE -> DTemplate -> Maybe HWND -> DialogProc -> IO HWND+createDialog inst template mb_parent dia_fn =+ createDialogParam inst template mb_parent dia_fn 0++createDialogParam :: HINSTANCE -> DTemplate -> Maybe HWND -> DialogProc -> LPARAM -> IO HWND+createDialogParam inst template mb_parent dia_fn init_val = do+ c_dia_fn <- mkDialogClosure dia_fn+ failIfNull "CreateDialogParam" $+ c_CreateDialogParam inst template (maybePtr mb_parent) c_dia_fn init_val+foreign import stdcall "windows.h CreateDialogParamW"+ c_CreateDialogParam :: HINSTANCE -> DTemplate -> HWND -> FunPtr DialogProc -> LPARAM -> IO HWND++createDialogIndirect :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> IO HWND+createDialogIndirect inst template mb_parent dia_fn =+ createDialogIndirectParam inst template mb_parent dia_fn 0++createDialogIndirectParam :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> LPARAM -> IO HWND+createDialogIndirectParam inst template mb_parent dia_fn init_val = do+ c_dia_fn <- mkDialogClosure dia_fn+ failIfNull "CreateDialogIndirectParam" $+ c_CreateDialogIndirectParam inst template (maybePtr mb_parent) c_dia_fn init_val+foreign import stdcall "windows.h CreateDialogIndirectParamW"+ c_CreateDialogIndirectParam :: HINSTANCE -> DTemplateMem -> HWND -> FunPtr DialogProc -> LPARAM -> IO HWND++foreign import stdcall "windows.h DefDlgProcW"+ defDlgProc :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT++endDialog :: HWND -> Int -> IO ()+endDialog dlg res =+ failIfFalse_ "EndDialog" $ c_EndDialog dlg res+foreign import stdcall "windows.h EndDialog"+ c_EndDialog :: HWND -> Int -> IO BOOL++foreign import stdcall unsafe "windows.h GetDialogBaseUnits"+ getDialogBaseUnits :: IO LONG++getDlgCtrlID :: HWND -> IO Int+getDlgCtrlID ctl =+ failIfZero "GetDlgCtrlID" $ c_GetDlgCtrlID ctl+foreign import stdcall unsafe "windows.h GetDlgCtrlID"+ c_GetDlgCtrlID :: HWND -> IO Int++getDlgItem :: HWND -> Int -> IO HWND+getDlgItem dlg item =+ failIfNull "GetDlgItem" $ c_GetDlgItem dlg item+foreign import stdcall unsafe "windows.h GetDlgItem"+ c_GetDlgItem :: HWND -> Int -> IO HWND++getDlgItemInt :: HWND -> Int -> Bool -> IO Int+getDlgItemInt dlg item signed =+ alloca $ \ p_trans -> do+ res <- c_GetDlgItemInt dlg item p_trans signed+ failIfFalse_ "GetDlgItemInt" $ peek p_trans+ return (fromIntegral res)+foreign import stdcall "windows.h GetDlgItemInt"+ c_GetDlgItemInt :: HWND -> Int -> Ptr Bool -> Bool -> IO UINT++getDlgItemText :: HWND -> Int -> Int -> IO String+getDlgItemText dlg item size =+ allocaArray size $ \ p_buf -> do+ failIfZero "GetDlgItemInt" $ c_GetDlgItemText dlg item p_buf size+ peekTString p_buf+foreign import stdcall "windows.h GetDlgItemTextW"+ c_GetDlgItemText :: HWND -> Int -> LPTSTR -> Int -> IO Int++getNextDlgGroupItem :: HWND -> HWND -> BOOL -> IO HWND+getNextDlgGroupItem dlg ctl previous =+ failIfNull "GetNextDlgGroupItem" $ c_GetNextDlgGroupItem dlg ctl previous+foreign import stdcall unsafe "windows.h GetNextDlgGroupItem"+ c_GetNextDlgGroupItem :: HWND -> HWND -> BOOL -> IO HWND++getNextDlgTabItem :: HWND -> HWND -> BOOL -> IO HWND+getNextDlgTabItem dlg ctl previous =+ failIfNull "GetNextDlgTabItem" $ c_GetNextDlgTabItem dlg ctl previous+foreign import stdcall unsafe "windows.h GetNextDlgTabItem"+ c_GetNextDlgTabItem :: HWND -> HWND -> BOOL -> IO HWND++foreign import stdcall "windows.h IsDialogMessageW"+ isDialogMessage :: HWND -> LPMSG -> IO BOOL++mapDialogRect :: HWND -> LPRECT -> IO ()+mapDialogRect dlg p_rect =+ failIfFalse_ "MapDialogRect" $ c_MapDialogRect dlg p_rect+foreign import stdcall unsafe "windows.h MapDialogRect"+ c_MapDialogRect :: HWND -> LPRECT -> IO Bool++-- No MessageBox* funs in here just yet.++foreign import stdcall "windows.h SendDlgItemMessageW"+ sendDlgItemMessage :: HWND -> Int -> WindowMessage -> WPARAM -> LPARAM -> IO LONG++setDlgItemInt :: HWND -> Int -> UINT -> BOOL -> IO ()+setDlgItemInt dlg item value signed =+ failIfFalse_ "SetDlgItemInt" $ c_SetDlgItemInt dlg item value signed+foreign import stdcall "windows.h SetDlgItemInt"+ c_SetDlgItemInt :: HWND -> Int -> UINT -> BOOL -> IO Bool++setDlgItemText :: HWND -> Int -> String -> IO ()+setDlgItemText dlg item str =+ withTString str $ \ c_str ->+ failIfFalse_ "SetDlgItemText" $ c_SetDlgItemText dlg item c_str+foreign import stdcall "windows.h SetDlgItemTextW"+ c_SetDlgItemText :: HWND -> Int -> LPCTSTR -> IO Bool++#{enum WindowStyle,+ , dS_3DLOOK = DS_3DLOOK+ , dS_ABSALIGN = DS_ABSALIGN+ , dS_CENTER = DS_CENTER+ , dS_CENTERMOUSE = DS_CENTERMOUSE+ , dS_CONTEXTHELP = DS_CONTEXTHELP+ , dS_CONTROL = DS_CONTROL+ , dS_FIXEDSYS = DS_FIXEDSYS+ , dS_LOCALEDIT = DS_LOCALEDIT+ , dS_MODALFRAME = DS_MODALFRAME+ , dS_NOFAILCREATE = DS_NOFAILCREATE+ , dS_NOIDLEMSG = DS_NOIDLEMSG+ , dS_SETFONT = DS_SETFONT+ , dS_SETFOREGROUND = DS_SETFOREGROUND+ , dS_SYSMODAL = DS_SYSMODAL+ }++#{enum WindowMessage,+ , dM_GETDEFID = DM_GETDEFID+ , dM_REPOSITION = DM_REPOSITION+ , dM_SETDEFID = DM_SETDEFID+ , wM_CTLCOLORDLG = WM_CTLCOLORDLG+ , wM_CTLCOLORMSGBOX = WM_CTLCOLORMSGBOX+ }++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- An interface to the Microsoft Windows graphics device interface (GDI).+-- See <http://msdn.microsoft.com/library/> under /Graphics and Multimedia/+-- for more details of the underlying library.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI (+ module Graphics.Win32.GDI.Bitmap,+ module Graphics.Win32.GDI.Brush,+ module Graphics.Win32.GDI.Clip,+ module Graphics.Win32.GDI.Font,+ module Graphics.Win32.GDI.Graphics2D,+ module Graphics.Win32.GDI.HDC,+ module Graphics.Win32.GDI.Palette,+ module Graphics.Win32.GDI.Path,+ module Graphics.Win32.GDI.Pen,+ module Graphics.Win32.GDI.Region,+ module Graphics.Win32.GDI.Types+ ) where++import Graphics.Win32.GDI.Bitmap+import Graphics.Win32.GDI.Brush+import Graphics.Win32.GDI.Clip+import Graphics.Win32.GDI.Font+import Graphics.Win32.GDI.Graphics2D+import Graphics.Win32.GDI.HDC+import Graphics.Win32.GDI.Palette+import Graphics.Win32.GDI.Path+import Graphics.Win32.GDI.Pen+import Graphics.Win32.GDI.Region+import Graphics.Win32.GDI.Types
+ Graphics/Win32/GDI/Bitmap.hsc view
@@ -0,0 +1,416 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Bitmap+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Bitmap(+ RasterOp3,+ RasterOp4,+ sRCCOPY,+ sRCPAINT,+ sRCAND,+ sRCINVERT,+ sRCERASE,+ nOTSRCCOPY,+ nOTSRCERASE,+ mERGECOPY,+ mERGEPAINT,+ pATCOPY,+ pATPAINT,+ pATINVERT,+ dSTINVERT,+ bLACKNESS,+ wHITENESS,++ mAKEROP4,++ BITMAP,+ LPBITMAP,+ setBITMAP,+ deleteBitmap,+ createCompatibleBitmap,+ createBitmap,+ createBitmapIndirect,+ createDIBPatternBrushPt,+ getBitmapDimensionEx,+ setBitmapDimensionEx,+ getBitmapInfo,++ BitmapCompression,+ bI_RGB,+ bI_RLE8,+ bI_RLE4,+ bI_BITFIELDS,++ ColorFormat,+ dIB_PAL_COLORS,+ dIB_RGB_COLORS,++ LPBITMAPINFO,+ BITMAPINFOHEADER,+ LPBITMAPINFOHEADER,+ getBITMAPINFOHEADER_,++ BITMAPFILEHEADER,+ LPBITMAPFILEHEADER,+ getBITMAPFILEHEADER,++ sizeofBITMAP,+ sizeofBITMAPINFO,+ sizeofBITMAPINFOHEADER,+ sizeofBITMAPFILEHEADER,+ sizeofLPBITMAPFILEHEADER,++ createBMPFile,+ cBM_INIT,+ getDIBits,+ setDIBits,+ createDIBitmap++ ) where++import System.Win32.Types+import Graphics.Win32.GDI.Types++import Control.Monad (liftM)+import Foreign+import Foreign.C++#include "Win32Aux.h"+#include <windows.h>++----------------------------------------------------------------+-- Resources+----------------------------------------------------------------++-- Yoiks - name clash+-- %dis bitmap x = ptr ({LPTSTR} x)+--+-- type Bitmap = LPCTSTR+--+-- intToBitmap :: Int -> Bitmap+-- intToBitmap i = makeIntResource (toWord i)+--+-- %fun LoadBitmap :: MbHINSTANCE -> Bitmap -> IO HBITMAP+-- %fail { res1 == 0 } { ErrorString("LoadBitmap") }+--+-- %const Bitmap+-- % [ OBM_CLOSE = { MAKEINTRESOURCE(OBM_CLOSE) }+-- % , OBM_UPARROW = { MAKEINTRESOURCE(OBM_UPARROW) }+-- % , OBM_DNARROW = { MAKEINTRESOURCE(OBM_DNARROW) }+-- % , OBM_RGARROW = { MAKEINTRESOURCE(OBM_RGARROW) }+-- % , OBM_LFARROW = { MAKEINTRESOURCE(OBM_LFARROW) }+-- % , OBM_REDUCE = { MAKEINTRESOURCE(OBM_REDUCE) }+-- % , OBM_ZOOM = { MAKEINTRESOURCE(OBM_ZOOM) }+-- % , OBM_RESTORE = { MAKEINTRESOURCE(OBM_RESTORE) }+-- % , OBM_REDUCED = { MAKEINTRESOURCE(OBM_REDUCED) }+-- % , OBM_ZOOMD = { MAKEINTRESOURCE(OBM_ZOOMD) }+-- % , OBM_RESTORED = { MAKEINTRESOURCE(OBM_RESTORED) }+-- % , OBM_UPARROWD = { MAKEINTRESOURCE(OBM_UPARROWD) }+-- % , OBM_DNARROWD = { MAKEINTRESOURCE(OBM_DNARROWD) }+-- % , OBM_RGARROWD = { MAKEINTRESOURCE(OBM_RGARROWD) }+-- % , OBM_LFARROWD = { MAKEINTRESOURCE(OBM_LFARROWD) }+-- % , OBM_MNARROW = { MAKEINTRESOURCE(OBM_MNARROW) }+-- % , OBM_COMBO = { MAKEINTRESOURCE(OBM_COMBO) }+-- % , OBM_UPARROWI = { MAKEINTRESOURCE(OBM_UPARROWI) }+-- % , OBM_DNARROWI = { MAKEINTRESOURCE(OBM_DNARROWI) }+-- % , OBM_RGARROWI = { MAKEINTRESOURCE(OBM_RGARROWI) }+-- % , OBM_LFARROWI = { MAKEINTRESOURCE(OBM_LFARROWI) }+-- % , OBM_OLD_CLOSE = { MAKEINTRESOURCE(OBM_OLD_CLOSE) }+-- % , OBM_SIZE = { MAKEINTRESOURCE(OBM_SIZE) }+-- % , OBM_OLD_UPARROW = { MAKEINTRESOURCE(OBM_OLD_UPARROW) }+-- % , OBM_OLD_DNARROW = { MAKEINTRESOURCE(OBM_OLD_DNARROW) }+-- % , OBM_OLD_RGARROW = { MAKEINTRESOURCE(OBM_OLD_RGARROW) }+-- % , OBM_OLD_LFARROW = { MAKEINTRESOURCE(OBM_OLD_LFARROW) }+-- % , OBM_BTSIZE = { MAKEINTRESOURCE(OBM_BTSIZE) }+-- % , OBM_CHECK = { MAKEINTRESOURCE(OBM_CHECK) }+-- % , OBM_CHECKBOXES = { MAKEINTRESOURCE(OBM_CHECKBOXES) }+-- % , OBM_BTNCORNERS = { MAKEINTRESOURCE(OBM_BTNCORNERS) }+-- % , OBM_OLD_REDUCE = { MAKEINTRESOURCE(OBM_OLD_REDUCE) }+-- % , OBM_OLD_ZOOM = { MAKEINTRESOURCE(OBM_OLD_ZOOM) }+-- % , OBM_OLD_RESTORE = { MAKEINTRESOURCE(OBM_OLD_RESTORE) }+-- % ]++----------------------------------------------------------------+-- Raster Ops+----------------------------------------------------------------++#{enum RasterOp3,+ , sRCCOPY = SRCCOPY+ , sRCPAINT = SRCPAINT+ , sRCAND = SRCAND+ , sRCINVERT = SRCINVERT+ , sRCERASE = SRCERASE+ , nOTSRCCOPY = NOTSRCCOPY+ , nOTSRCERASE = NOTSRCERASE+ , mERGECOPY = MERGECOPY+ , mERGEPAINT = MERGEPAINT+ , pATCOPY = PATCOPY+ , pATPAINT = PATPAINT+ , pATINVERT = PATINVERT+ , dSTINVERT = DSTINVERT+ , bLACKNESS = BLACKNESS+ , wHITENESS = WHITENESS+ }++----------------------------------------------------------------+-- BITMAP+----------------------------------------------------------------++type BITMAP =+ ( INT -- bmType+ , INT -- bmWidth+ , INT -- bmHeight+ , INT -- bmWidthBytes+ , WORD -- bmPlanes+ , WORD -- bmBitsPixel+ , LPVOID -- bmBits+ )++peekBITMAP :: Ptr BITMAP -> IO BITMAP+peekBITMAP p = do+ ty <- #{peek BITMAP,bmType} p+ width <- #{peek BITMAP,bmWidth} p+ height <- #{peek BITMAP,bmHeight} p+ wbytes <- #{peek BITMAP,bmWidthBytes} p+ planes <- #{peek BITMAP,bmPlanes} p+ pixel <- #{peek BITMAP,bmBitsPixel} p+ bits <- #{peek BITMAP,bmBits} p+ return (ty, width, height, wbytes, planes, pixel, bits)++pokeBITMAP :: Ptr BITMAP -> BITMAP -> IO ()+pokeBITMAP p (ty, width, height, wbytes, planes, pixel, bits) = do+ #{poke BITMAP,bmType} p ty+ #{poke BITMAP,bmWidth} p width+ #{poke BITMAP,bmHeight} p height+ #{poke BITMAP,bmWidthBytes} p wbytes+ #{poke BITMAP,bmPlanes} p planes+ #{poke BITMAP,bmBitsPixel} p pixel+ #{poke BITMAP,bmBits} p bits++type LPBITMAP = Ptr BITMAP++setBITMAP :: LPBITMAP -> BITMAP -> IO ()+setBITMAP = pokeBITMAP++----------------------------------------------------------------+-- Misc+----------------------------------------------------------------++deleteBitmap :: HBITMAP -> IO ()+deleteBitmap bitmap =+ failIfFalse_ "DeleteBitmap" $ c_DeleteBitmap bitmap+foreign import stdcall unsafe "windows.h DeleteObject"+ c_DeleteBitmap :: HBITMAP -> IO Bool++createBitmap :: INT -> INT -> UINT -> UINT -> Maybe LPVOID -> IO HBITMAP+createBitmap w h planes bits mb_color_data =+ failIfNull "CreateBitmap" $+ c_CreateBitmap w h planes bits (maybePtr mb_color_data)+foreign import stdcall unsafe "windows.h CreateBitmap"+ c_CreateBitmap :: INT -> INT -> UINT -> UINT -> LPVOID -> IO HBITMAP++createBitmapIndirect :: LPBITMAP -> IO HBITMAP+createBitmapIndirect p_bm =+ failIfNull "CreateBitmapIndirect" $ c_CreateBitmapIndirect p_bm+foreign import stdcall unsafe "windows.h CreateBitmapIndirect"+ c_CreateBitmapIndirect :: LPBITMAP -> IO HBITMAP++createCompatibleBitmap :: HDC -> Int32 -> Int32 -> IO HBITMAP+createCompatibleBitmap dc w h =+ failIfNull "CreateCompatibleBitmap" $ c_CreateCompatibleBitmap dc w h+foreign import stdcall unsafe "windows.h CreateCompatibleBitmap"+ c_CreateCompatibleBitmap :: HDC -> Int32 -> Int32 -> IO HBITMAP++createDIBPatternBrushPt :: LPVOID -> ColorFormat -> IO HBRUSH+createDIBPatternBrushPt bm usage =+ failIfNull "CreateDIBPatternBrushPt" $ c_CreateDIBPatternBrushPt bm usage+foreign import stdcall unsafe "windows.h CreateDIBPatternBrushPt"+ c_CreateDIBPatternBrushPt :: LPVOID -> ColorFormat -> IO HBRUSH++----------------------------------------------------------------+-- Querying+----------------------------------------------------------------++getBitmapDimensionEx :: HBITMAP -> IO SIZE+getBitmapDimensionEx bm =+ allocaSIZE $ \ p_size -> do+ failIfFalse_ "GetBitmapDimensionEx" $ c_GetBitmapDimensionEx bm p_size+ peekSIZE p_size+foreign import stdcall unsafe "windows.h GetBitmapDimensionEx"+ c_GetBitmapDimensionEx :: HBITMAP -> Ptr SIZE -> IO Bool++setBitmapDimensionEx :: HBITMAP -> SIZE -> IO SIZE+setBitmapDimensionEx bm (cx,cy) =+ allocaSIZE $ \ p_size -> do+ failIfFalse_ "SetBitmapDimensionEx" $ do+ c_SetBitmapDimensionEx bm cx cy p_size+ peekSIZE p_size+foreign import stdcall unsafe "windows.h SetBitmapDimensionEx"+ c_SetBitmapDimensionEx :: HBITMAP -> LONG -> LONG -> Ptr SIZE -> IO Bool++getBitmapInfo :: HBITMAP -> IO BITMAP+getBitmapInfo bm =+ allocaBytes (fromIntegral sizeofBITMAP) $ \ p_bm -> do+ failIfFalse_ "GetBitmapInfo" $ c_GetBitmapInfo bm sizeofBITMAP p_bm+ peekBITMAP p_bm+foreign import stdcall unsafe "windows.h GetObjectW"+ c_GetBitmapInfo :: HBITMAP -> DWORD -> LPBITMAP -> IO Bool++----------------------------------------------------------------+--+----------------------------------------------------------------++type BitmapCompression = DWORD++#{enum BitmapCompression,+ , bI_RGB = BI_RGB+ , bI_RLE8 = BI_RLE8+ , bI_RLE4 = BI_RLE4+ , bI_BITFIELDS = BI_BITFIELDS+ }++type ColorFormat = DWORD++#{enum ColorFormat,+ , dIB_PAL_COLORS = DIB_PAL_COLORS+ , dIB_RGB_COLORS = DIB_RGB_COLORS+ }++----------------------------------------------------------------+-- BITMAPINFO+----------------------------------------------------------------++type LPBITMAPINFO = Ptr ()++----------------------------------------------------------------+-- BITMAPINFOHEADER+----------------------------------------------------------------++type BITMAPINFOHEADER =+ ( DWORD -- biSize -- sizeof(BITMAPINFOHEADER)+ , LONG -- biWidth+ , LONG -- biHeight+ , WORD -- biPlanes+ , WORD -- biBitCount -- 1, 4, 8, 16, 24 or 32+ , BitmapCompression -- biCompression+ , DWORD -- biSizeImage+ , LONG -- biXPelsPerMeter+ , LONG -- biYPelsPerMeter+ , Maybe DWORD -- biClrUsed+ , Maybe DWORD -- biClrImportant+ )++peekBITMAPINFOHEADER :: Ptr BITMAPINFOHEADER -> IO BITMAPINFOHEADER+peekBITMAPINFOHEADER p = do+ size <- #{peek BITMAPINFOHEADER,biSize} p+ width <- #{peek BITMAPINFOHEADER,biWidth} p+ height <- #{peek BITMAPINFOHEADER,biHeight} p+ planes <- #{peek BITMAPINFOHEADER,biPlanes} p+ nbits <- #{peek BITMAPINFOHEADER,biBitCount} p+ comp <- #{peek BITMAPINFOHEADER,biCompression} p+ imsize <- #{peek BITMAPINFOHEADER,biSizeImage} p+ xDensity <- #{peek BITMAPINFOHEADER,biXPelsPerMeter} p+ yDensity <- #{peek BITMAPINFOHEADER,biYPelsPerMeter} p+ clrUsed <- liftM numToMaybe $ #{peek BITMAPINFOHEADER,biClrUsed} p+ clrImp <- liftM numToMaybe $ #{peek BITMAPINFOHEADER,biClrImportant} p+ return (size, width, height, planes, nbits, comp, imsize,+ xDensity, yDensity, clrUsed, clrImp)++type LPBITMAPINFOHEADER = Ptr BITMAPINFOHEADER++getBITMAPINFOHEADER_ :: LPBITMAPINFOHEADER -> IO BITMAPINFOHEADER+getBITMAPINFOHEADER_ = peekBITMAPINFOHEADER++----------------------------------------------------------------+-- BITMAPFILEHEADER+----------------------------------------------------------------++type BITMAPFILEHEADER =+ ( WORD -- bfType -- "BM" == 0x4d42+ , DWORD -- bfSize -- number of bytes in file+ , WORD -- bfReserved1 -- == 0+ , WORD -- bfReserved2 -- == 0+ , DWORD -- bfOffBits -- == (char*) bits - (char*) filehdr+ )++peekBITMAPFILEHEADER :: Ptr BITMAPFILEHEADER -> IO BITMAPFILEHEADER+peekBITMAPFILEHEADER p = do+ ty <- #{peek BITMAPFILEHEADER,bfType} p+ size <- #{peek BITMAPFILEHEADER,bfSize} p+ res1 <- #{peek BITMAPFILEHEADER,bfReserved1} p+ res2 <- #{peek BITMAPFILEHEADER,bfReserved2} p+ offset <- #{peek BITMAPFILEHEADER,bfOffBits} p+ return (ty, size, res1, res2, offset)++type LPBITMAPFILEHEADER = Ptr BITMAPFILEHEADER++getBITMAPFILEHEADER :: LPBITMAPFILEHEADER -> IO BITMAPFILEHEADER+getBITMAPFILEHEADER = peekBITMAPFILEHEADER++sizeofBITMAP :: Word32+sizeofBITMAP = #{size BITMAP}+sizeofBITMAPINFO :: Word32+sizeofBITMAPINFO = #{size BITMAPINFO}+sizeofBITMAPINFOHEADER :: Word32+sizeofBITMAPINFOHEADER = #{size BITMAPINFOHEADER}+sizeofBITMAPFILEHEADER :: Word32+sizeofBITMAPFILEHEADER = #{size BITMAPFILEHEADER}+sizeofLPBITMAPFILEHEADER :: Word32+sizeofLPBITMAPFILEHEADER = #{size BITMAPFILEHEADER}++----------------------------------------------------------------+-- CreateBMPFile+----------------------------------------------------------------++-- A (large) helper function - courtesy of Microsoft++createBMPFile :: String -> HBITMAP -> HDC -> IO ()+createBMPFile name bm dc =+ withCString name $ \ c_name ->+ c_CreateBMPFile c_name bm dc+foreign import ccall unsafe "dumpBMP.h CreateBMPFile"+ c_CreateBMPFile :: LPCSTR -> HBITMAP -> HDC -> IO ()++{-# CFILES cbits/dumpBMP.c #-}++----------------------------------------------------------------+-- Device Independent Bitmaps+----------------------------------------------------------------++#{enum DWORD,+ , cBM_INIT = CBM_INIT+ }++getDIBits :: HDC -> HBITMAP -> INT -> INT -> Maybe LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT+getDIBits dc bm start nlines mb_bits info usage =+ failIfZero "GetDIBits" $+ c_GetDIBits dc bm start nlines (maybePtr mb_bits) info usage+foreign import stdcall unsafe "windows.h GetDIBits"+ c_GetDIBits :: HDC -> HBITMAP -> INT -> INT -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT++setDIBits :: HDC -> HBITMAP -> INT -> INT -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT+setDIBits dc bm start nlines bits info use =+ failIfZero "SetDIBits" $ c_SetDIBits dc bm start nlines bits info use+foreign import stdcall unsafe "windows.h SetDIBits"+ c_SetDIBits :: HDC -> HBITMAP -> INT -> INT -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT++createDIBitmap :: HDC -> LPBITMAPINFOHEADER -> DWORD -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO HBITMAP+createDIBitmap dc hdr option init_val info usage =+ failIfNull "CreateDIBitmap" $+ c_CreateDIBitmap dc hdr option init_val info usage+foreign import stdcall unsafe "windows.h CreateDIBitmap"+ c_CreateDIBitmap :: HDC -> LPBITMAPINFOHEADER -> DWORD -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO HBITMAP++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI/Brush.hsc view
@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Brush+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Brush where++import System.Win32.Types+import Graphics.Win32.GDI.Types++#include <windows.h>++----------------------------------------------------------------+-- Brush+----------------------------------------------------------------++createSolidBrush :: COLORREF -> IO HBRUSH+createSolidBrush color =+ failIfNull "CreateSolidBrush" $ c_CreateSolidBrush color+foreign import stdcall unsafe "windows.h CreateSolidBrush"+ c_CreateSolidBrush :: COLORREF -> IO HBRUSH++createHatchBrush :: HatchStyle -> COLORREF -> IO HBRUSH+createHatchBrush style color =+ failIfNull "CreateHatchBrush" $ c_CreateHatchBrush style color+foreign import stdcall unsafe "windows.h CreateHatchBrush"+ c_CreateHatchBrush :: HatchStyle -> COLORREF -> IO HBRUSH++createPatternBrush :: HBITMAP -> IO HBRUSH+createPatternBrush bitmap =+ failIfNull "CreatePatternBrush" $ c_CreatePatternBrush bitmap+foreign import stdcall unsafe "windows.h CreatePatternBrush"+ c_CreatePatternBrush :: HBITMAP -> IO HBRUSH++deleteBrush :: HBRUSH -> IO ()+deleteBrush brush =+ failIfFalse_ "DeleteBrush" $ c_DeleteBrush brush+foreign import stdcall unsafe "windows.h DeleteObject"+ c_DeleteBrush :: HBRUSH -> IO Bool++----------------------------------------------------------------++type StockBrush = INT++#{enum StockBrush,+ , wHITE_BRUSH = WHITE_BRUSH+ , lTGRAY_BRUSH = LTGRAY_BRUSH+ , gRAY_BRUSH = GRAY_BRUSH+ , dKGRAY_BRUSH = DKGRAY_BRUSH+ , bLACK_BRUSH = BLACK_BRUSH+ , nULL_BRUSH = NULL_BRUSH+ , hOLLOW_BRUSH = HOLLOW_BRUSH+ }++getStockBrush :: StockBrush -> IO HBRUSH+getStockBrush sb =+ failIfNull "GetStockBrush" $ c_GetStockBrush sb+foreign import stdcall unsafe "windows.h GetStockObject"+ c_GetStockBrush :: StockBrush -> IO HBRUSH++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI/Clip.hsc view
@@ -0,0 +1,148 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Clip+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Clip where++import Graphics.Win32.GDI.Types+import System.Win32.Types++import Foreign++#include <windows.h>++type ClipboardFormat = UINT++#{enum ClipboardFormat,+ , cF_BITMAP = CF_BITMAP+ , cF_DIB = CF_DIB+ , cF_DIF = CF_DIF+ , cF_DSPBITMAP = CF_DSPBITMAP+ , cF_DSPENHMETAFILE = CF_DSPENHMETAFILE+ , cF_DSPMETAFILEPICT = CF_DSPMETAFILEPICT+ , cF_DSPTEXT = CF_DSPTEXT+ , cF_ENHMETAFILE = CF_ENHMETAFILE+ , cF_GDIOBJFIRST = CF_GDIOBJFIRST+ , cF_HDROP = CF_HDROP+ , cF_LOCALE = CF_LOCALE+ , cF_METAFILEPICT = CF_METAFILEPICT+ , cF_OEMTEXT = CF_OEMTEXT+ , cF_OWNERDISPLAY = CF_OWNERDISPLAY+ , cF_PALETTE = CF_PALETTE+ , cF_PENDATA = CF_PENDATA+ , cF_PRIVATEFIRST = CF_PRIVATEFIRST+ , cF_PRIVATELAST = CF_PRIVATELAST+ , cF_RIFF = CF_RIFF+ , cF_SYLK = CF_SYLK+ , cF_TEXT = CF_TEXT+ , cF_WAVE = CF_WAVE+ , cF_TIFF = CF_TIFF+ }++-- % , CF_UNICODETEXT -- WinNT only++foreign import stdcall unsafe "windows.h ChangeClipboardChain"+ changeClipboardChain :: HWND -> HWND -> IO Bool++closeClipboard :: IO ()+closeClipboard =+ failIfFalse_ "CloseClipboard" c_CloseClipboard+foreign import stdcall unsafe "windows.h CloseClipboard"+ c_CloseClipboard :: IO BOOL++foreign import stdcall unsafe "windows.h CountClipboardFormats"+ countClipboardFormats :: IO Int++emptyClipboard :: IO ()+emptyClipboard =+ failIfFalse_ "EmptyClipboard" c_EmptyClipboard+foreign import stdcall unsafe "windows.h EmptyClipboard"+ c_EmptyClipboard :: IO BOOL++-- original also tested GetLastError() != NO_ERROR++enumClipboardFormats :: ClipboardFormat -> IO ClipboardFormat+enumClipboardFormats format =+ failIfZero "EnumClipboardFormats" $ c_EnumClipboardFormats format+foreign import stdcall unsafe "windows.h EnumClipboardFormats"+ c_EnumClipboardFormats :: ClipboardFormat -> IO ClipboardFormat++getClipboardData :: ClipboardFormat -> IO HANDLE+getClipboardData format =+ failIfNull "GetClipboardData" $ c_GetClipboardData format+foreign import stdcall unsafe "windows.h GetClipboardData"+ c_GetClipboardData :: ClipboardFormat -> IO HANDLE++getClipboardFormatName :: ClipboardFormat -> IO String+getClipboardFormatName format =+ allocaArray 256 $ \ c_name -> do+ len <- failIfZero "GetClipboardFormatName" $+ c_GetClipboardFormatName format c_name 256+ peekTStringLen (c_name, len)+foreign import stdcall unsafe "windows.h GetClipboardFormatNameW"+ c_GetClipboardFormatName :: ClipboardFormat -> LPTSTR -> Int -> IO Int++getClipboardOwner :: IO HWND+getClipboardOwner =+ failIfNull "GetClipboardOwner" c_GetClipboardOwner+foreign import stdcall unsafe "windows.h GetClipboardOwner"+ c_GetClipboardOwner :: IO HWND++getClipboardViewer :: IO HWND+getClipboardViewer =+ failIfNull "GetClipboardViewer" c_GetClipboardViewer+foreign import stdcall unsafe "windows.h GetClipboardViewer"+ c_GetClipboardViewer :: IO HWND++getOpenClipboardWindow :: IO HWND+getOpenClipboardWindow =+ failIfNull "GetClipboardWindow" c_GetOpenClipboardWindow+foreign import stdcall unsafe "windows.h GetOpenClipboardWindow"+ c_GetOpenClipboardWindow :: IO HWND++getPriorityClipboardFormat :: [ClipboardFormat] -> IO Int+getPriorityClipboardFormat formats =+ withArray formats $ \ format_array ->+ failIf (== -1) "GetPriorityClipboardFormat" $+ c_GetPriorityClipboardFormat format_array (length formats)+foreign import stdcall unsafe "windows.h GetPriorityClipboardFormat"+ c_GetPriorityClipboardFormat :: Ptr UINT -> Int -> IO Int++foreign import stdcall unsafe "windows.h IsClipboardFormatAvailable"+ isClipboardFormatAvailable :: ClipboardFormat -> IO BOOL++openClipboard :: HWND -> IO ()+openClipboard wnd =+ failIfFalse_ "OpenClipboard" $ c_OpenClipboard wnd+foreign import stdcall unsafe "windows.h OpenClipboard"+ c_OpenClipboard :: HWND -> IO BOOL++registerClipboardFormat :: String -> IO ClipboardFormat+registerClipboardFormat name =+ withTString name $ \ c_name ->+ failIfZero "RegisterClipboardFormat" $+ c_RegisterClipboardFormat c_name+foreign import stdcall unsafe "windows.h RegisterClipboardFormatW"+ c_RegisterClipboardFormat :: LPCTSTR -> IO ClipboardFormat++setClipboardData :: ClipboardFormat -> HANDLE -> IO HANDLE+setClipboardData format mem =+ failIfNull "SetClipboardData" $ c_SetClipboardData format mem+foreign import stdcall unsafe "windows.h SetClipboardData"+ c_SetClipboardData :: ClipboardFormat -> HANDLE -> IO HANDLE++setClipboardViewer :: HWND -> IO HWND+setClipboardViewer wnd =+ failIfNull "SetClipboardViewer" $ c_SetClipboardViewer wnd+foreign import stdcall unsafe "windows.h SetClipboardViewer"+ c_SetClipboardViewer :: HWND -> IO HWND
+ Graphics/Win32/GDI/Font.hsc view
@@ -0,0 +1,203 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Font+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Font+{-+ ( CharSet+ , PitchAndFamily+ , OutPrecision+ , ClipPrecision+ , FontQuality+ , FontWeight++ , createFont, deleteFont++ , StockFont, getStockFont+ , oEM_FIXED_FONT, aNSI_FIXED_FONT, aNSI_VAR_FONT, sYSTEM_FONT+ , dEVICE_DEFAULT_FONT, sYSTEM_FIXED_FONT+ ) where+-}+ where++import System.Win32.Types+import Graphics.Win32.GDI.Types++import Foreign++#include <windows.h>++----------------------------------------------------------------+-- Types+----------------------------------------------------------------++type CharSet = UINT+type PitchAndFamily = UINT+type OutPrecision = UINT+type ClipPrecision = UINT+type FontQuality = UINT+type FontWeight = Word32+type FaceName = String++-- A FaceName is a string no more that LF_FACESIZE in length+-- (including null terminator).+-- %const Int LF_FACESIZE # == 32+-- %sentinel_array : FaceName : CHAR : char : $0 = '\0' : ('\0' == $0) : LF_FACESIZE++----------------------------------------------------------------+-- Constants+----------------------------------------------------------------++#{enum CharSet,+ , aNSI_CHARSET = ANSI_CHARSET+ , dEFAULT_CHARSET = DEFAULT_CHARSET+ , sYMBOL_CHARSET = SYMBOL_CHARSET+ , sHIFTJIS_CHARSET = SHIFTJIS_CHARSET+ , hANGEUL_CHARSET = HANGEUL_CHARSET+ , cHINESEBIG5_CHARSET = CHINESEBIG5_CHARSET+ , oEM_CHARSET = OEM_CHARSET+ }++#{enum PitchAndFamily,+ , dEFAULT_PITCH = DEFAULT_PITCH+ , fIXED_PITCH = FIXED_PITCH+ , vARIABLE_PITCH = VARIABLE_PITCH+ , fF_DONTCARE = FF_DONTCARE+ , fF_ROMAN = FF_ROMAN+ , fF_SWISS = FF_SWISS+ , fF_MODERN = FF_MODERN+ , fF_SCRIPT = FF_SCRIPT+ , fF_DECORATIVE = FF_DECORATIVE+ }++familyMask, pitchMask :: PitchAndFamily+familyMask = 0xF0+pitchMask = 0x0F++#{enum OutPrecision,+ , oUT_DEFAULT_PRECIS = OUT_DEFAULT_PRECIS+ , oUT_STRING_PRECIS = OUT_STRING_PRECIS+ , oUT_CHARACTER_PRECIS = OUT_CHARACTER_PRECIS+ , oUT_STROKE_PRECIS = OUT_STROKE_PRECIS+ , oUT_TT_PRECIS = OUT_TT_PRECIS+ , oUT_DEVICE_PRECIS = OUT_DEVICE_PRECIS+ , oUT_RASTER_PRECIS = OUT_RASTER_PRECIS+ , oUT_TT_ONLY_PRECIS = OUT_TT_ONLY_PRECIS+ }++#{enum ClipPrecision,+ , cLIP_DEFAULT_PRECIS = CLIP_DEFAULT_PRECIS+ , cLIP_CHARACTER_PRECIS = CLIP_CHARACTER_PRECIS+ , cLIP_STROKE_PRECIS = CLIP_STROKE_PRECIS+ , cLIP_MASK = CLIP_MASK+ , cLIP_LH_ANGLES = CLIP_LH_ANGLES+ , cLIP_TT_ALWAYS = CLIP_TT_ALWAYS+ , cLIP_EMBEDDED = CLIP_EMBEDDED+ }++#{enum FontQuality,+ , dEFAULT_QUALITY = DEFAULT_QUALITY+ , dRAFT_QUALITY = DRAFT_QUALITY+ , pROOF_QUALITY = PROOF_QUALITY+ }++#{enum FontWeight,+ , fW_DONTCARE = FW_DONTCARE+ , fW_THIN = FW_THIN+ , fW_EXTRALIGHT = FW_EXTRALIGHT+ , fW_LIGHT = FW_LIGHT+ , fW_NORMAL = FW_NORMAL+ , fW_MEDIUM = FW_MEDIUM+ , fW_SEMIBOLD = FW_SEMIBOLD+ , fW_BOLD = FW_BOLD+ , fW_EXTRABOLD = FW_EXTRABOLD+ , fW_HEAVY = FW_HEAVY+ , fW_REGULAR = FW_REGULAR+ , fW_ULTRALIGHT = FW_ULTRALIGHT+ , fW_DEMIBOLD = FW_DEMIBOLD+ , fW_ULTRABOLD = FW_ULTRABOLD+ , fW_BLACK = FW_BLACK+ }++----------------------------------------------------------------+-- Functions+----------------------------------------------------------------++-- was: ErrorMsg("CreateFont","NullHandle")++createFont+ :: INT -> INT -> INT -> INT+ -> FontWeight -> Bool -> Bool -> Bool+ -> CharSet -> OutPrecision -> ClipPrecision+ -> FontQuality -> PitchAndFamily -> FaceName+ -> IO HFONT+createFont h w esc orient wt ital under strike cset out clip q pf face =+ withTString face $ \ c_face ->+ failIfNull "CreateFont" $+ c_CreateFont h w esc orient wt ital under strike cset out clip q pf c_face+foreign import stdcall unsafe "windows.h CreateFontW"+ c_CreateFont+ :: INT -> INT -> INT -> INT+ -> FontWeight -> Bool -> Bool -> Bool+ -> CharSet -> OutPrecision -> ClipPrecision+ -> FontQuality -> PitchAndFamily -> LPCTSTR+ -> IO HFONT++-- test :: IO ()+-- test = do+-- f <- createFont_adr (100,100) 0 False False "Arial"+-- putStrLn "Created first font"+-- f <- createFont_adr (100,100) (-90) False False "Bogus"+-- putStrLn "Created second font"+--+-- createFont_adr (width, height) escapement bold italic family =+-- createFont height width+-- (round (escapement * 1800/pi))+-- 0 -- orientation+-- weight+-- italic False False -- italic, underline, strikeout+-- aNSI_CHARSET+-- oUT_DEFAULT_PRECIS+-- cLIP_DEFAULT_PRECIS+-- dEFAULT_QUALITY+-- dEFAULT_PITCH+-- family+-- where+-- weight | bold = fW_BOLD+-- | otherwise = fW_NORMAL+++-- missing CreateFontIndirect from WinFonts.ss; GSL ???++foreign import stdcall unsafe "windows.h DeleteObject"+ deleteFont :: HFONT -> IO ()++----------------------------------------------------------------++type StockFont = WORD++#{enum StockFont,+ , oEM_FIXED_FONT = OEM_FIXED_FONT+ , aNSI_FIXED_FONT = ANSI_FIXED_FONT+ , aNSI_VAR_FONT = ANSI_VAR_FONT+ , sYSTEM_FONT = SYSTEM_FONT+ , dEVICE_DEFAULT_FONT = DEVICE_DEFAULT_FONT+ , sYSTEM_FIXED_FONT = SYSTEM_FIXED_FONT+ }++foreign import stdcall unsafe "windows.h GetStockObject"+ getStockFont :: StockFont -> IO HFONT++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI/Graphics2D.hs view
@@ -0,0 +1,222 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Graphics2D+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- 2D graphics operations+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Graphics2D+ where++import System.Win32.Types+import Graphics.Win32.GDI.Types+import Graphics.Win32.GDI.Bitmap++import Foreign++----------------------------------------------------------------+-- Lines and Curves+----------------------------------------------------------------++moveToEx :: HDC -> Int32 -> Int32 -> IO POINT+moveToEx dc x y =+ allocaPOINT $ \ p_point -> do+ failIfFalse_ "MoveToEx" $ c_MoveToEx dc x y p_point+ peekPOINT p_point+foreign import stdcall unsafe "windows.h MoveToEx"+ c_MoveToEx :: HDC -> Int32 -> Int32 -> Ptr POINT -> IO Bool++lineTo :: HDC -> Int32 -> Int32 -> IO ()+lineTo dc x y =+ failIfFalse_ "LineTo" $ c_LineTo dc x y+foreign import stdcall unsafe "windows.h LineTo"+ c_LineTo :: HDC -> Int32 -> Int32 -> IO Bool++polyline :: HDC -> [POINT] -> IO ()+polyline dc points =+ withPOINTArray points $ \ pount_array npoints ->+ failIfFalse_ "Polyline" $ c_Polyline dc pount_array npoints+foreign import stdcall unsafe "windows.h Polyline"+ c_Polyline :: HDC -> Ptr POINT -> Int -> IO Bool++polylineTo :: HDC -> [POINT] -> IO ()+polylineTo dc points =+ withPOINTArray points $ \ pount_array npoints ->+ failIfFalse_ "PolylineTo" $ c_PolylineTo dc pount_array npoints+foreign import stdcall unsafe "windows.h PolylineTo"+ c_PolylineTo :: HDC -> Ptr POINT -> Int -> IO Bool++polygon :: HDC -> [POINT] -> IO ()+polygon dc points =+ withPOINTArray points $ \ pount_array npoints ->+ failIfFalse_ "Polygon" $ c_Polygon dc pount_array npoints+foreign import stdcall unsafe "windows.h Polygon"+ c_Polygon :: HDC -> Ptr POINT -> Int -> IO Bool++polyBezier :: HDC -> [POINT] -> IO ()+polyBezier dc points =+ withPOINTArray points $ \ pount_array npoints ->+ failIfFalse_ "PolyBezier" $ c_PolyBezier dc pount_array npoints+foreign import stdcall unsafe "windows.h PolyBezier"+ c_PolyBezier :: HDC -> Ptr POINT -> Int -> IO Bool++polyBezierTo :: HDC -> [POINT] -> IO ()+polyBezierTo dc points =+ withPOINTArray points $ \ pount_array npoints ->+ failIfFalse_ "PolyBezierTo" $ c_PolyBezierTo dc pount_array npoints+foreign import stdcall unsafe "windows.h PolyBezierTo"+ c_PolyBezierTo :: HDC -> Ptr POINT -> Int -> IO Bool++arc :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO ()+arc dc left top right bottom x1 y1 x2 y2 =+ failIfFalse_ "Arc" $ c_Arc dc left top right bottom x1 y1 x2 y2+foreign import stdcall unsafe "windows.h Arc"+ c_Arc :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool++arcTo :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO ()+arcTo dc left top right bottom x1 y1 x2 y2 =+ failIfFalse_ "ArcTo" $ c_ArcTo dc left top right bottom x1 y1 x2 y2+foreign import stdcall unsafe "windows.h ArcTo"+ c_ArcTo :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool++angleArc :: HDC -> Int32 -> Int32 -> WORD -> Double -> Double -> IO ()+angleArc dc x y r start sweep =+ failIfFalse_ "AngleArc" $ c_AngleArc dc x y r start sweep+foreign import stdcall unsafe "windows.h AngleArc"+ c_AngleArc :: HDC -> Int32 -> Int32 -> WORD -> Double -> Double -> IO Bool++----------------------------------------------------------------+-- Filled Shapes+----------------------------------------------------------------++-- ToDo: We ought to be able to specify a colour instead of the+-- Brush by adding 1 to colour number.++fillRect :: HDC -> RECT -> HBRUSH -> IO ()+fillRect dc rect brush =+ withRECT rect $ \ c_rect ->+ failIfFalse_ "FillRect" $ c_FillRect dc c_rect brush+foreign import stdcall unsafe "windows.h FillRect"+ c_FillRect :: HDC -> Ptr RECT -> HBRUSH -> IO Bool++frameRect :: HDC -> RECT -> HBRUSH -> IO ()+frameRect dc rect brush =+ withRECT rect $ \ c_rect ->+ failIfFalse_ "FrameRect" $ c_FrameRect dc c_rect brush+foreign import stdcall unsafe "windows.h FrameRect"+ c_FrameRect :: HDC -> Ptr RECT -> HBRUSH -> IO Bool++invertRect :: HDC -> RECT -> IO ()+invertRect dc rect =+ withRECT rect $ \ c_rect ->+ failIfFalse_ "InvertRect" $ c_InvertRect dc c_rect+foreign import stdcall unsafe "windows.h InvertRect"+ c_InvertRect :: HDC -> Ptr RECT -> IO Bool++rectangle :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> IO ()+rectangle dc left top right bottom =+ failIfFalse_ "Rectangle" $ c_Rectangle dc left top right bottom+foreign import stdcall unsafe "windows.h Rectangle"+ c_Rectangle :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool++roundRect :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO ()+roundRect dc left top right bottom w h =+ failIfFalse_ "RoundRect" $ c_RoundRect dc left top right bottom w h+foreign import stdcall unsafe "windows.h RoundRect"+ c_RoundRect :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool++ellipse :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> IO ()+ellipse dc left top right bottom =+ failIfFalse_ "Ellipse" $ c_Ellipse dc left top right bottom+foreign import stdcall unsafe "windows.h Ellipse"+ c_Ellipse :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool++chord :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO ()+chord dc left top right bottom x1 y1 x2 y2 =+ failIfFalse_ "Chord" $ c_Chord dc left top right bottom x1 y1 x2 y2+foreign import stdcall unsafe "windows.h Chord"+ c_Chord :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool++pie :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO ()+pie dc left top right bottom x1 y1 x2 y2 =+ failIfFalse_ "Pie" $ c_Pie dc left top right bottom x1 y1 x2 y2+foreign import stdcall unsafe "windows.h Pie"+ c_Pie :: HDC -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> IO Bool++----------------------------------------------------------------+-- Bitmaps+----------------------------------------------------------------++bitBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> RasterOp3 -> IO ()+bitBlt dcDest xDest yDest w h dcSrc xSrc ySrc rop =+ failIfFalse_ "BitBlt" $ c_BitBlt dcDest xDest yDest w h dcSrc xSrc ySrc rop+foreign import stdcall unsafe "windows.h BitBlt"+ c_BitBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> RasterOp3 -> IO Bool++maskBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> HBITMAP -> INT -> INT -> RasterOp4 -> IO ()+maskBlt dcDest xDest yDest w h dcSrc xSrc ySrc bm xMask yMask rop =+ failIfFalse_ "MaskBlt" $+ c_MaskBlt dcDest xDest yDest w h dcSrc xSrc ySrc bm xMask yMask rop+foreign import stdcall unsafe "windows.h MaskBlt"+ c_MaskBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> HBITMAP -> INT -> INT -> RasterOp4 -> IO Bool++stretchBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> INT -> INT -> RasterOp3 -> IO ()+stretchBlt dcDest xDest yDest wDest hDest hdcSrc xSrc ySrc wSrc hSrc rop =+ failIfFalse_ "StretchBlt" $+ c_StretchBlt dcDest xDest yDest wDest hDest hdcSrc xSrc ySrc wSrc hSrc rop+foreign import stdcall unsafe "windows.h StretchBlt"+ c_StretchBlt :: HDC -> INT -> INT -> INT -> INT -> HDC -> INT -> INT -> INT -> INT -> RasterOp3 -> IO Bool++-- We deviate slightly from the Win32 interface++-- %C typedef POINT ThreePts[3];++-- Old 2nd line:+-- %start POINT vertices[3];++plgBlt :: HDC -> POINT -> POINT -> POINT -> HDC -> INT -> INT -> INT -> INT -> MbHBITMAP -> INT -> INT -> IO ()+plgBlt hdDest p1 p2 p3 hdSrc x y w h mb_bm xMask yMask =+ withPOINTArray [p1,p2,p3] $ \ vertices _ ->+ failIfFalse_ "PlgBlt" $+ c_PlgBlt hdDest vertices hdSrc x y w h (maybePtr mb_bm) xMask yMask+foreign import stdcall unsafe "windows.h PlgBlt"+ c_PlgBlt :: HDC -> Ptr POINT -> HDC -> INT -> INT -> INT -> INT -> HBITMAP -> INT -> INT -> IO Bool++----------------------------------------------------------------+-- Fonts and Text+----------------------------------------------------------------++textOut :: HDC -> INT -> INT -> String -> IO ()+textOut dc x y str =+ withTStringLen str $ \ (c_str, len) ->+ failIfFalse_ "TextOut" $ c_TextOut dc x y c_str len+foreign import stdcall unsafe "windows.h TextOutW"+ c_TextOut :: HDC -> INT -> INT -> LPCTSTR -> Int -> IO Bool++-- missing TabbedTextOut from WinFonts.ss; GSL ???++getTextExtentPoint32 :: HDC -> String -> IO SIZE+getTextExtentPoint32 dc str =+ withTStringLen str $ \ (c_str, len) ->+ allocaSIZE $ \ p_size -> do+ failIfFalse_ "GetTextExtentPoint32" $+ c_GetTextExtentPoint32 dc c_str len p_size+ peekSIZE p_size+foreign import stdcall unsafe "windows.h GetTextExtentPoint32W"+ c_GetTextExtentPoint32 :: HDC -> LPCTSTR -> Int -> Ptr SIZE -> IO Bool++-- missing getTabbedTextExtent from WinFonts.ss; GSL ???+-- missing SetTextJustification from WinFonts.ss; GSL ???+-- missing a whole family of techandfamily functionality; GSL ???+-- missing DrawText and DrawTextFormat in WinFonts.ss; GSL ???++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI/HDC.hs view
@@ -0,0 +1,298 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.HDC+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.HDC+ ( module Graphics.Win32.GDI.HDC+ ) where++import System.Win32.Types+import Graphics.Win32.GDI.Types++import Foreign++----------------------------------------------------------------++setArcDirection :: HDC -> ArcDirection -> IO ArcDirection+setArcDirection dc dir =+ failIfZero "SetArcDirection" $ c_SetArcDirection dc dir+foreign import stdcall unsafe "windows.h SetArcDirection"+ c_SetArcDirection :: HDC -> ArcDirection -> IO ArcDirection++getArcDirection :: HDC -> IO ArcDirection+getArcDirection dc =+ failIfZero "GetArcDirection" $ c_GetArcDirection dc+foreign import stdcall unsafe "windows.h GetArcDirection"+ c_GetArcDirection :: HDC -> IO ArcDirection++setPolyFillMode :: HDC -> PolyFillMode -> IO PolyFillMode+setPolyFillMode dc mode =+ failIfZero "SetPolyFillMode" $ c_SetPolyFillMode dc mode+foreign import stdcall unsafe "windows.h SetPolyFillMode"+ c_SetPolyFillMode :: HDC -> PolyFillMode -> IO PolyFillMode++getPolyFillMode :: HDC -> IO PolyFillMode+getPolyFillMode dc =+ failIfZero "GetPolyFillMode" $ c_GetPolyFillMode dc+foreign import stdcall unsafe "windows.h GetPolyFillMode"+ c_GetPolyFillMode :: HDC -> IO PolyFillMode++setGraphicsMode :: HDC -> GraphicsMode -> IO GraphicsMode+setGraphicsMode dc mode =+ failIfZero "SetGraphicsMode" $ c_SetGraphicsMode dc mode+foreign import stdcall unsafe "windows.h SetGraphicsMode"+ c_SetGraphicsMode :: HDC -> GraphicsMode -> IO GraphicsMode++getGraphicsMode :: HDC -> IO GraphicsMode+getGraphicsMode dc =+ failIfZero "GetGraphicsMode" $ c_GetGraphicsMode dc+foreign import stdcall unsafe "windows.h GetGraphicsMode"+ c_GetGraphicsMode :: HDC -> IO GraphicsMode++setStretchBltMode :: HDC -> StretchBltMode -> IO StretchBltMode+setStretchBltMode dc mode =+ failIfZero "SetStretchBltMode" $ c_SetStretchBltMode dc mode+foreign import stdcall unsafe "windows.h SetStretchBltMode"+ c_SetStretchBltMode :: HDC -> StretchBltMode -> IO StretchBltMode++getStretchBltMode :: HDC -> IO StretchBltMode+getStretchBltMode dc =+ failIfZero "GetStretchBltMode" $ c_GetStretchBltMode dc+foreign import stdcall unsafe "windows.h GetStretchBltMode"+ c_GetStretchBltMode :: HDC -> IO StretchBltMode++setBkColor :: HDC -> COLORREF -> IO COLORREF+setBkColor dc color =+ failIfZero "SetBkColor" $ c_SetBkColor dc color+foreign import stdcall unsafe "windows.h SetBkColor"+ c_SetBkColor :: HDC -> COLORREF -> IO COLORREF++getBkColor :: HDC -> IO COLORREF+getBkColor dc =+ failIfZero "GetBkColor" $ c_GetBkColor dc+foreign import stdcall unsafe "windows.h GetBkColor"+ c_GetBkColor :: HDC -> IO COLORREF++setTextColor :: HDC -> COLORREF -> IO COLORREF+setTextColor dc color =+ failIf (== cLR_INVALID) "SetTextColor" $ c_SetTextColor dc color+foreign import stdcall unsafe "windows.h SetTextColor"+ c_SetTextColor :: HDC -> COLORREF -> IO COLORREF++getTextColor :: HDC -> IO COLORREF+getTextColor dc =+ failIf (== cLR_INVALID) "GetTextColor" $ c_GetTextColor dc+foreign import stdcall unsafe "windows.h GetTextColor"+ c_GetTextColor :: HDC -> IO COLORREF++setBkMode :: HDC -> BackgroundMode -> IO BackgroundMode+setBkMode dc mode =+ failIfZero "SetBkMode" $ c_SetBkMode dc mode+foreign import stdcall unsafe "windows.h SetBkMode"+ c_SetBkMode :: HDC -> BackgroundMode -> IO BackgroundMode++getBkMode :: HDC -> IO BackgroundMode+getBkMode dc =+ failIfZero "GetBkMode" $ c_GetBkMode dc+foreign import stdcall unsafe "windows.h GetBkMode"+ c_GetBkMode :: HDC -> IO BackgroundMode++setBrushOrgEx :: HDC -> Int -> Int -> IO POINT+setBrushOrgEx dc x y =+ allocaPOINT $ \ pt -> do+ failIfFalse_ "SetBrushOrgEx" $ c_SetBrushOrgEx dc x y pt+ peekPOINT pt+foreign import stdcall unsafe "windows.h SetBrushOrgEx"+ c_SetBrushOrgEx :: HDC -> Int -> Int -> Ptr POINT -> IO Bool++getBrushOrgEx :: HDC -> IO POINT+getBrushOrgEx dc =+ allocaPOINT $ \ pt -> do+ failIfFalse_ "GetBrushOrgEx" $ c_GetBrushOrgEx dc pt+ peekPOINT pt+foreign import stdcall unsafe "windows.h GetBrushOrgEx"+ c_GetBrushOrgEx :: HDC -> Ptr POINT -> IO Bool++setTextAlign :: HDC -> TextAlignment -> IO TextAlignment+setTextAlign dc align =+ failIf (== gDI_ERROR) "SetTextAlign" $ c_SetTextAlign dc align+foreign import stdcall unsafe "windows.h SetTextAlign"+ c_SetTextAlign :: HDC -> TextAlignment -> IO TextAlignment++getTextAlign :: HDC -> IO TextAlignment+getTextAlign dc =+ failIf (== gDI_ERROR) "GetTextAlign" $ c_GetTextAlign dc+foreign import stdcall unsafe "windows.h GetTextAlign"+ c_GetTextAlign :: HDC -> IO TextAlignment++setTextCharacterExtra :: HDC -> Int -> IO Int+setTextCharacterExtra dc extra =+ failIf (== 0x80000000) "SetTextCharacterExtra" $+ c_SetTextCharacterExtra dc extra+foreign import stdcall unsafe "windows.h SetTextCharacterExtra"+ c_SetTextCharacterExtra :: HDC -> Int -> IO Int++getTextCharacterExtra :: HDC -> IO Int+getTextCharacterExtra dc =+ failIf (== 0x80000000) "GetTextCharacterExtra" $ c_GetTextCharacterExtra dc+foreign import stdcall unsafe "windows.h GetTextCharacterExtra"+ c_GetTextCharacterExtra :: HDC -> IO Int++getMiterLimit :: HDC -> IO Float+getMiterLimit dc =+ alloca $ \ p_res -> do+ failIfFalse_ "GetMiterLimit" $ c_GetMiterLimit dc p_res+ peek p_res+foreign import stdcall unsafe "windows.h GetMiterLimit"+ c_GetMiterLimit :: HDC -> Ptr FLOAT -> IO Bool++setMiterLimit :: HDC -> Float -> IO Float+setMiterLimit dc new_limit =+ alloca $ \ p_old_limit -> do+ failIfFalse_ "SetMiterLimit" $ c_SetMiterLimit dc new_limit p_old_limit+ peek p_old_limit+foreign import stdcall unsafe "windows.h SetMiterLimit"+ c_SetMiterLimit :: HDC -> FLOAT -> Ptr FLOAT -> IO Bool++----------------------------------------------------------------++saveDC :: HDC -> IO Int+saveDC dc =+ failIfZero "SaveDC" $ c_SaveDC dc+foreign import stdcall unsafe "windows.h SaveDC"+ c_SaveDC :: HDC -> IO Int++restoreDC :: HDC -> Int -> IO ()+restoreDC dc saved =+ failIfFalse_ "RestoreDC" $ c_RestoreDC dc saved+foreign import stdcall unsafe "windows.h RestoreDC"+ c_RestoreDC :: HDC -> Int -> IO Bool++----------------------------------------------------------------++getCurrentBitmap :: HDC -> IO HBITMAP+getCurrentBitmap dc =+ failIfNull "GetCurrentBitmap" $ c_GetCurrentBitmap dc oBJ_BITMAP+foreign import stdcall unsafe "windows.h GetCurrentObject"+ c_GetCurrentBitmap :: HDC -> UINT -> IO HBITMAP++getCurrentBrush :: HDC -> IO HBRUSH+getCurrentBrush dc =+ failIfNull "GetCurrentBrush" $ c_GetCurrentBrush dc oBJ_BRUSH+foreign import stdcall unsafe "windows.h GetCurrentObject"+ c_GetCurrentBrush :: HDC -> UINT -> IO HBRUSH++getCurrentFont :: HDC -> IO HFONT+getCurrentFont dc =+ failIfNull "GetCurrentFont" $ c_GetCurrentFont dc oBJ_FONT+foreign import stdcall unsafe "windows.h GetCurrentObject"+ c_GetCurrentFont :: HDC -> UINT -> IO HFONT++getCurrentPalette :: HDC -> IO HPALETTE+getCurrentPalette dc =+ failIfNull "GetCurrentPalette" $ c_GetCurrentPalette dc oBJ_PAL+foreign import stdcall unsafe "windows.h GetCurrentObject"+ c_GetCurrentPalette :: HDC -> UINT -> IO HPALETTE++getCurrentPen :: HDC -> IO HPEN+getCurrentPen dc =+ failIfNull "GetCurrentPen" $ c_GetCurrentPen dc oBJ_PEN+foreign import stdcall unsafe "windows.h GetCurrentObject"+ c_GetCurrentPen :: HDC -> UINT -> IO HPEN++selectBitmap :: HDC -> HBITMAP -> IO HBITMAP+selectBitmap dc bitmap =+ failIfNull "SelectBitmap" $ c_SelectBitmap dc bitmap+foreign import stdcall unsafe "windows.h SelectObject"+ c_SelectBitmap :: HDC -> HBITMAP -> IO HBITMAP++selectBrush :: HDC -> HBRUSH -> IO HBRUSH+selectBrush dc brush =+ failIfNull "SelectBrush" $ c_SelectBrush dc brush+foreign import stdcall unsafe "windows.h SelectObject"+ c_SelectBrush :: HDC -> HBRUSH -> IO HBRUSH++selectFont :: HDC -> HFONT -> IO HFONT+selectFont dc font =+ failIfNull "SelectFont" $ c_SelectFont dc font+foreign import stdcall unsafe "windows.h SelectObject"+ c_SelectFont :: HDC -> HFONT -> IO HFONT++selectPen :: HDC -> HPEN -> IO HPEN+selectPen dc pen =+ failIfNull "SelectPen" $ c_SelectPen dc pen+foreign import stdcall unsafe "windows.h SelectObject"+ c_SelectPen :: HDC -> HPEN -> IO HPEN++----------------------------------------------------------------+--+----------------------------------------------------------------++selectPalette :: HDC -> HPALETTE -> Bool -> IO HPALETTE+selectPalette dc palette force_bg =+ failIfNull "SelectPalette" $ c_SelectPalette dc palette force_bg+foreign import stdcall unsafe "windows.h SelectPalette"+ c_SelectPalette :: HDC -> HPALETTE -> Bool -> IO HPALETTE++selectRgn :: HDC -> HRGN -> IO RegionType+selectRgn dc rgn =+ withForeignPtr rgn $ \ p_rgn ->+ failIf (== gDI_ERROR) "SelectRgn" $ c_SelectRgn dc p_rgn+foreign import stdcall unsafe "windows.h SelectObject"+ c_SelectRgn :: HDC -> PRGN -> IO RegionType++selectClipRgn :: HDC -> Maybe HRGN -> IO RegionType+selectClipRgn dc mb_rgn =+ maybeWith withForeignPtr mb_rgn $ \ p_rgn ->+ failIfZero "SelectClipRgn" $ c_SelectClipRgn dc p_rgn+foreign import stdcall unsafe "windows.h SelectClipRgn"+ c_SelectClipRgn :: HDC -> PRGN -> IO RegionType++extSelectClipRgn :: HDC -> Maybe HRGN -> ClippingMode -> IO RegionType+extSelectClipRgn dc mb_rgn mode =+ maybeWith withForeignPtr mb_rgn $ \ p_rgn ->+ failIfZero "ExtSelectClipRgn" $ c_ExtSelectClipRgn dc p_rgn mode+foreign import stdcall unsafe "windows.h ExtSelectClipRgn"+ c_ExtSelectClipRgn :: HDC -> PRGN -> ClippingMode -> IO RegionType++selectClipPath :: HDC -> ClippingMode -> IO RegionType+selectClipPath dc mode =+ failIfZero "SelectClipPath" $ c_SelectClipPath dc mode+foreign import stdcall unsafe "windows.h SelectClipPath"+ c_SelectClipPath :: HDC -> ClippingMode -> IO RegionType++----------------------------------------------------------------+-- Misc+----------------------------------------------------------------++cancelDC :: HDC -> IO ()+cancelDC dc =+ failIfFalse_ "CancelDC" $ c_CancelDC dc+foreign import stdcall unsafe "windows.h CancelDC"+ c_CancelDC :: HDC -> IO Bool++createCompatibleDC :: Maybe HDC -> IO HDC+createCompatibleDC mb_dc =+ failIfNull "CreateCompatibleDC" $ c_CreateCompatibleDC (maybePtr mb_dc)+foreign import stdcall unsafe "windows.h CreateCompatibleDC"+ c_CreateCompatibleDC :: HDC -> IO HDC++deleteDC :: HDC -> IO ()+deleteDC dc =+ failIfFalse_ "DeleteDC" $ c_DeleteDC dc+foreign import stdcall unsafe "windows.h DeleteDC"+ c_DeleteDC :: HDC -> IO Bool++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI/Palette.hsc view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Palette+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Palette where++import System.Win32.Types+import Graphics.Win32.GDI.Types++#include <windows.h>++----------------------------------------------------------------+-- Palettes+----------------------------------------------------------------++type StockPalette = WORD++#{enum StockPalette,+ , dEFAULT_PALETTE = DEFAULT_PALETTE+ }++getStockPalette :: StockPalette -> IO HPALETTE+getStockPalette sp =+ failIfNull "GetStockPalette" $ c_GetStockPalette sp+foreign import stdcall unsafe "windows.h GetStockObject"+ c_GetStockPalette :: StockPalette -> IO HPALETTE++deletePalette :: HPALETTE -> IO ()+deletePalette p =+ failIfFalse_ "DeletePalette" $ c_DeletePalette p+foreign import stdcall unsafe "windows.h DeleteObject"+ c_DeletePalette :: HPALETTE -> IO Bool++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI/Path.hs view
@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Path+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Path+ ( beginPath, closeFigure, endPath, fillPath, flattenPath+ , pathToRegion, strokeAndFillPath, strokePath, widenPath+ ) where++import Graphics.Win32.GDI.Types+import System.Win32.Types++----------------------------------------------------------------+-- Paths+----------------------------------------------------------------++-- AbortPath :: HDC -> IO ()++beginPath :: HDC -> IO ()+beginPath dc =+ failIfFalse_ "BeginPath" $ c_BeginPath dc+foreign import stdcall unsafe "windows.h BeginPath"+ c_BeginPath :: HDC -> IO Bool++closeFigure :: HDC -> IO ()+closeFigure dc =+ failIfFalse_ "CloseFigure" $ c_CloseFigure dc+foreign import stdcall unsafe "windows.h CloseFigure"+ c_CloseFigure :: HDC -> IO Bool++endPath :: HDC -> IO ()+endPath dc =+ failIfFalse_ "EndPath" $ c_EndPath dc+foreign import stdcall unsafe "windows.h EndPath"+ c_EndPath :: HDC -> IO Bool++fillPath :: HDC -> IO ()+fillPath dc =+ failIfFalse_ "FillPath" $ c_FillPath dc+foreign import stdcall unsafe "windows.h FillPath"+ c_FillPath :: HDC -> IO Bool++flattenPath :: HDC -> IO ()+flattenPath dc =+ failIfFalse_ "FlattenPath" $ c_FlattenPath dc+foreign import stdcall unsafe "windows.h FlattenPath"+ c_FlattenPath :: HDC -> IO Bool++pathToRegion :: HDC -> IO HRGN+pathToRegion dc = do+ ptr <- failIfNull "PathToRegion" $ c_PathToRegion dc+ newForeignHANDLE ptr+foreign import stdcall unsafe "windows.h PathToRegion"+ c_PathToRegion :: HDC -> IO PRGN++strokeAndFillPath :: HDC -> IO ()+strokeAndFillPath dc =+ failIfFalse_ "StrokeAndFillPath" $ c_StrokeAndFillPath dc+foreign import stdcall unsafe "windows.h StrokeAndFillPath"+ c_StrokeAndFillPath :: HDC -> IO Bool++strokePath :: HDC -> IO ()+strokePath dc =+ failIfFalse_ "StrokePath" $ c_StrokePath dc+foreign import stdcall unsafe "windows.h StrokePath"+ c_StrokePath :: HDC -> IO Bool++widenPath :: HDC -> IO ()+widenPath dc =+ failIfFalse_ "WidenPath" $ c_WidenPath dc+foreign import stdcall unsafe "windows.h WidenPath"+ c_WidenPath :: HDC -> IO Bool++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI/Pen.hsc view
@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Pen+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Pen where++import System.Win32.Types+import Graphics.Win32.GDI.Types++#include <windows.h>++----------------------------------------------------------------+-- Stock Objects+----------------------------------------------------------------++type StockPen = INT++#{enum StockPen,+ , wHITE_PEN = WHITE_PEN+ , bLACK_PEN = BLACK_PEN+ , nULL_PEN = NULL_PEN+ }++getStockPen :: StockPen -> IO HPEN+getStockPen stockpen =+ failIfNull "GetStockPen" $ c_GetStockPen stockpen+foreign import stdcall unsafe "windows.h GetStockObject"+ c_GetStockPen :: StockPen -> IO HPEN++deletePen :: HPEN -> IO ()+deletePen pen =+ failIfFalse_ "DeletePen" $ c_DeletePen pen+foreign import stdcall unsafe "windows.h DeleteObject"+ c_DeletePen :: HPEN -> IO Bool++----------------------------------------------------------------+-- Creating pens+----------------------------------------------------------------++type PenStyle = INT++#{enum PenStyle, // Pick one of these+ , pS_SOLID = PS_SOLID // default+ , pS_DASH = PS_DASH // -------+ , pS_DOT = PS_DOT // .......+ , pS_DASHDOT = PS_DASHDOT // _._._._+ , pS_DASHDOTDOT = PS_DASHDOTDOT // _.._.._+ , pS_NULL = PS_NULL+ , pS_INSIDEFRAME = PS_INSIDEFRAME+ , pS_USERSTYLE = PS_USERSTYLE+ , pS_ALTERNATE = PS_ALTERNATE+ , pS_STYLE_MASK = PS_STYLE_MASK // all the above+ }++#{enum PenStyle , // "or" with one of these+ , pS_ENDCAP_ROUND = PS_ENDCAP_ROUND // default+ , pS_ENDCAP_SQUARE = PS_ENDCAP_SQUARE+ , pS_ENDCAP_FLAT = PS_ENDCAP_FLAT+ , pS_ENDCAP_MASK = PS_ENDCAP_MASK // all the above+ }++#{enum PenStyle, // "or" with one of these+ , pS_JOIN_ROUND = PS_JOIN_ROUND // default+ , pS_JOIN_BEVEL = PS_JOIN_BEVEL+ , pS_JOIN_MITER = PS_JOIN_MITER+ }+-- , pS_JOIN_MASK = PS_JOIN_MASK+{-+If PS_JOIN_MASK is not defined with your GNU Windows32 header files,+you'll have to define it.+-}++#{enum PenStyle, // "or" with one of these+ , pS_COSMETIC = PS_COSMETIC // default+ , pS_GEOMETRIC = PS_GEOMETRIC+ , pS_TYPE_MASK = PS_TYPE_MASK // all the above+ }++createPen :: PenStyle -> INT -> COLORREF -> IO HPEN+createPen style n color =+ failIfNull "CreatePen" $ c_CreatePen style n color+foreign import stdcall unsafe "windows.h CreatePen"+ c_CreatePen :: PenStyle -> INT -> COLORREF -> IO HPEN++-- Not very well supported on Win'95+-- %fun NullHANDLE ExtCreatePen :: PenStyle -> INT -> LOGBRUSH -> [StyleBit] -> IO HPEN++-- ToDo: CreatePenIndirect++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI/Region.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Region+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Region where++import System.Win32.Types+import Graphics.Win32.GDI.Types++import Foreign++----------------------------------------------------------------+-- Regions+----------------------------------------------------------------++badRegion :: RegionType -> Bool+badRegion n = n == 0 || n == gDI_ERROR++combineRgn :: HRGN -> HRGN -> HRGN -> ClippingMode -> IO RegionType+combineRgn dest src1 src2 mode =+ withForeignPtr dest $ \ p_dest ->+ withForeignPtr src1 $ \ p_src1 ->+ withForeignPtr src2 $ \ p_src2 ->+ failIf badRegion "CombineRgn" $ c_CombineRgn p_dest p_src1 p_src2 mode+foreign import stdcall unsafe "windows.h CombineRgn"+ c_CombineRgn :: PRGN -> PRGN -> PRGN -> ClippingMode -> IO RegionType++offsetRgn :: HRGN -> INT -> INT -> IO RegionType+offsetRgn rgn xoff yoff =+ withForeignPtr rgn $ \ p_rgn ->+ failIf badRegion "OffsetRgn" $ c_OffsetRgn p_rgn xoff yoff+foreign import stdcall unsafe "windows.h OffsetRgn"+ c_OffsetRgn :: PRGN -> INT -> INT -> IO RegionType++getRgnBox :: HRGN -> LPRECT -> IO RegionType+getRgnBox rgn p_rect =+ withForeignPtr rgn $ \ p_rgn ->+ failIf badRegion "GetRgnBox" $ c_GetRgnBox p_rgn p_rect+foreign import stdcall unsafe "windows.h GetRgnBox"+ c_GetRgnBox :: PRGN -> LPRECT -> IO RegionType++createEllipticRgn :: INT -> INT -> INT -> INT -> IO HRGN+createEllipticRgn x0 y0 x1 y1 = do+ ptr <- failIfNull "CreateEllipticRgn" $ c_CreateEllipticRgn x0 y0 x1 y1+ newForeignHANDLE ptr+foreign import stdcall unsafe "windows.h CreateEllipticRgn"+ c_CreateEllipticRgn :: INT -> INT -> INT -> INT -> IO PRGN++createEllipticRgnIndirect :: LPRECT -> IO HRGN+createEllipticRgnIndirect rp = do+ ptr <- failIfNull "CreateEllipticRgnIndirect" $ c_CreateEllipticRgnIndirect rp+ newForeignHANDLE ptr+foreign import stdcall unsafe "windows.h CreateEllipticRgnIndirect"+ c_CreateEllipticRgnIndirect :: LPRECT -> IO PRGN++createRectRgn :: INT -> INT -> INT -> INT -> IO HRGN+createRectRgn x0 y0 x1 y1 = do+ ptr <- failIfNull "CreateRectRgn" $ c_CreateRectRgn x0 y0 x1 y1+ newForeignHANDLE ptr+foreign import stdcall unsafe "windows.h CreateRectRgn"+ c_CreateRectRgn :: INT -> INT -> INT -> INT -> IO PRGN++createRectRgnIndirect :: LPRECT -> IO HRGN+createRectRgnIndirect rp = do+ ptr <- failIfNull "CreateRectRgnIndirect" $ c_CreateRectRgnIndirect rp+ newForeignHANDLE ptr+foreign import stdcall unsafe "windows.h CreateRectRgnIndirect"+ c_CreateRectRgnIndirect :: LPRECT -> IO PRGN++createRoundRectRgn :: INT -> INT -> INT -> INT -> INT -> INT -> IO HRGN+createRoundRectRgn x0 y0 x1 y1 h w = do+ ptr <- failIfNull "CreateRoundRectRgn" $ c_CreateRoundRectRgn x0 y0 x1 y1 h w+ newForeignHANDLE ptr+foreign import stdcall unsafe "windows.h CreateRoundRectRgn"+ c_CreateRoundRectRgn :: INT -> INT -> INT -> INT -> INT -> INT -> IO PRGN++createPolygonRgn :: [POINT] -> PolyFillMode -> IO HRGN+createPolygonRgn ps mode =+ withPOINTArray ps $ \ point_array npoints -> do+ ptr <- failIfNull "CreatePolygonRgn" $+ c_CreatePolygonRgn point_array npoints mode+ newForeignHANDLE ptr+foreign import stdcall unsafe "windows.h CreatePolygonRgn"+ c_CreatePolygonRgn :: Ptr POINT -> Int -> PolyFillMode -> IO PRGN++-- Needs to do proper error test for EqualRgn; GSL ???++foreign import stdcall unsafe "windows.h EqualRgn"+ equalRgn :: PRGN -> PRGN -> IO Bool++fillRgn :: HDC -> HRGN -> HBRUSH -> IO ()+fillRgn dc rgn brush =+ withForeignPtr rgn $ \ p_rgn ->+ failIfFalse_ "FillRgn" $ c_FillRgn dc p_rgn brush+foreign import stdcall unsafe "windows.h FillRgn"+ c_FillRgn :: HDC -> PRGN -> HBRUSH -> IO Bool++invertRgn :: HDC -> HRGN -> IO ()+invertRgn dc rgn =+ withForeignPtr rgn $ \ p_rgn ->+ failIfFalse_ "InvertRgn" $ c_InvertRgn dc p_rgn+foreign import stdcall unsafe "windows.h InvertRgn"+ c_InvertRgn :: HDC -> PRGN -> IO Bool++paintRgn :: HDC -> HRGN -> IO ()+paintRgn dc rgn =+ withForeignPtr rgn $ \ p_rgn ->+ failIfFalse_ "PaintRgn" $ c_PaintRgn dc p_rgn+foreign import stdcall unsafe "windows.h PaintRgn"+ c_PaintRgn :: HDC -> PRGN -> IO Bool++frameRgn :: HDC -> HRGN -> HBRUSH -> Int -> Int -> IO ()+frameRgn dc rgn brush w h =+ withForeignPtr rgn $ \ p_rgn ->+ failIfFalse_ "FrameRgn" $ c_FrameRgn dc p_rgn brush w h+foreign import stdcall unsafe "windows.h FrameRgn"+ c_FrameRgn :: HDC -> PRGN -> HBRUSH -> Int -> Int -> IO Bool++ptInRegion :: HRGN -> Int -> Int -> IO Bool+ptInRegion rgn x y =+ withForeignPtr rgn $ \ p_rgn ->+ c_PtInRegion p_rgn x y+foreign import stdcall unsafe "windows.h PtInRegion"+ c_PtInRegion :: PRGN -> Int -> Int -> IO Bool++rectInRegion :: HRGN -> RECT -> IO Bool+rectInRegion rgn rect =+ withForeignPtr rgn $ \ p_rgn ->+ withRECT rect $ c_RectInRegion p_rgn+foreign import stdcall unsafe "windows.h RectInRegion"+ c_RectInRegion :: PRGN -> Ptr RECT -> IO Bool++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/GDI/Types.hsc view
@@ -0,0 +1,394 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.GDI.Types+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.GDI.Types+{- -- still incomplete+ ( POINT, marshall_point, unmarshall_point+ , ListPOINT, marshall_ListPOINT_+ , ListLenPOINT, marshall_ListLenPOINT_+ , RECT, marshall_rect, unmarshall_rect+ , SIZE, marshall_size, unmarshall_size+ , nullPtr+ , HBITMAP , MbHBITMAP+ , HFONT , MbHFONT+ , HCURSOR , MbHCURSOR+ , HICON , MbHICON+ , HRGN , MbHRGN+ , PRGN+ , HPALETTE , MbHPALETTE+ , HBRUSH , MbHBRUSH+ , HPEN , MbHPEN+ , HACCEL --, MbHACCEL+ , HDC , MbHDC+ , HDWP , MbHDWP+ , HWND , MbHWND+ , HMENU , MbHMENU+ , PolyFillMode+ , ArcDirection+ , MbArcDirection+ , GraphicsMode+ , MbGraphicsMode+ , BackgroundMode+ , HatchStyle+ , StretchBltMode+ , COLORREF+ , TextAlignment+ , ClippingMode+ , RegionType+ , gDI_ERROR+ )+-}+ where++import System.Win32.Types++import Control.Monad( zipWithM_ )+import Foreign++#include <windows.h>++{-# CFILES cbits/HsGDI.c #-}++----------------------------------------------------------------+--+----------------------------------------------------------------++type POINT =+ ( LONG -- x+ , LONG -- y+ )++sizeofPOINT :: Int+sizeofPOINT = #{size POINT}++allocaPOINT :: (Ptr POINT -> IO a) -> IO a+allocaPOINT =+ allocaBytes sizeofPOINT++peekPOINT :: Ptr POINT -> IO POINT+peekPOINT p = do+ x <- #{peek POINT,x} p+ y <- #{peek POINT,y} p+ return (x,y)++pokePOINT :: Ptr POINT -> POINT -> IO ()+pokePOINT p (x,y) = do+ #{poke POINT,x} p x+ #{poke POINT,y} p y++withPOINT :: POINT -> (Ptr POINT -> IO a) -> IO a+withPOINT p f =+ allocaPOINT $ \ ptr -> do+ pokePOINT ptr p+ f ptr++type RECT =+ ( LONG -- left+ , LONG -- top+ , LONG -- right+ , LONG -- bottom+ )++allocaRECT :: (Ptr RECT -> IO a) -> IO a+allocaRECT =+ allocaBytes (#{size RECT})++peekRECT :: Ptr RECT -> IO RECT+peekRECT p = do+ left <- #{peek RECT,left} p+ top <- #{peek RECT,top} p+ right <- #{peek RECT,right} p+ bottom <- #{peek RECT,bottom} p+ return (left, top, right, bottom)++pokeRECT :: Ptr RECT -> RECT -> IO ()+pokeRECT p (left, top, right, bottom) = do+ #{poke RECT,left} p left+ #{poke RECT,top} p top+ #{poke RECT,right} p right+ #{poke RECT,bottom} p bottom++type SIZE =+ ( LONG -- cx+ , LONG -- cy+ )++allocaSIZE :: (Ptr SIZE -> IO a) -> IO a+allocaSIZE =+ allocaBytes (#{size SIZE})++peekSIZE :: Ptr SIZE -> IO SIZE+peekSIZE p = do+ cx <- #{peek SIZE,cx} p+ cy <- #{peek SIZE,cy} p+ return (cx,cy)++pokeSIZE :: Ptr SIZE -> SIZE -> IO ()+pokeSIZE p (cx,cy) = do+ #{poke SIZE,cx} p cx+ #{poke SIZE,cy} p cy++----------------------------------------------------------------++withPOINTArray :: [POINT] -> (Ptr POINT -> Int -> IO a) -> IO a+withPOINTArray xs f = allocaBytes (sizeofPOINT * len) $ \ ptr -> do+ pokePOINTArray ptr xs+ f ptr len+ where+ len = length xs++pokePOINTArray :: Ptr POINT -> [POINT] -> IO ()+pokePOINTArray ptr xs = zipWithM_ (setPOINT ptr) [0..] xs++setPOINT :: Ptr POINT -> Int -> POINT -> IO ()+setPOINT ptr off = pokePOINT (ptr `plusPtr` (off*sizeofPOINT))++type LPRECT = Ptr RECT+type MbLPRECT = Maybe LPRECT++withRECT :: RECT -> (Ptr RECT -> IO a) -> IO a+withRECT r f =+ allocaRECT $ \ ptr -> do+ pokeRECT ptr r+ f ptr++getRECT :: LPRECT -> IO RECT+getRECT = peekRECT++----------------------------------------------------------------+-- (GDI related) Handles+----------------------------------------------------------------++type HBITMAP = HANDLE+type MbHBITMAP = Maybe HBITMAP++type HFONT = HANDLE+type MbHFONT = Maybe HFONT++type HCURSOR = HICON+type MbHCURSOR = Maybe HCURSOR++type HICON = HANDLE+type MbHICON = Maybe HICON+++-- This is not the only handle / resource that should be+-- finalised for you, but it's a start.+-- ToDo.++type HRGN = ForeignHANDLE+type PRGN = HANDLE++type MbHRGN = Maybe HRGN++type HPALETTE = HANDLE+type MbHPALETTE = Maybe HPALETTE++type HBRUSH = HANDLE+type MbHBRUSH = Maybe HBRUSH++type HPEN = HANDLE+type MbHPEN = Maybe HPEN++type HACCEL = HANDLE++type HDC = HANDLE+type MbHDC = Maybe HDC++type HDWP = HANDLE+type MbHDWP = Maybe HDWP++type HWND = HANDLE+type MbHWND = Maybe HWND++#{enum HWND, castUINTToPtr+ , hWND_BOTTOM = HWND_BOTTOM+ , hWND_NOTOPMOST = HWND_NOTOPMOST+ , hWND_TOP = HWND_TOP+ , hWND_TOPMOST = HWND_TOPMOST+ }++type HMENU = HANDLE+type MbHMENU = Maybe HMENU++----------------------------------------------------------------+-- COLORREF+----------------------------------------------------------------++type COLORREF = #{type COLORREF}++foreign import ccall unsafe "HsGDI.h"+ rgb :: BYTE -> BYTE -> BYTE -> COLORREF++foreign import ccall unsafe "HsGDI.h"+ getRValue :: COLORREF -> BYTE++foreign import ccall unsafe "HsGDI.h"+ getGValue :: COLORREF -> BYTE++foreign import ccall unsafe "HsGDI.h"+ getBValue :: COLORREF -> BYTE++foreign import ccall unsafe "HsGDI.h"+ pALETTERGB :: BYTE -> BYTE -> BYTE -> COLORREF++foreign import ccall unsafe "HsGDI.h"+ pALETTEINDEX :: WORD -> COLORREF++----------------------------------------------------------------+-- RasterOp macro+----------------------------------------------------------------++type RasterOp3 = Word32+type RasterOp4 = Word32++foreign import ccall unsafe "HsGDI.h"+ mAKEROP4 :: RasterOp3 -> RasterOp3 -> RasterOp4++----------------------------------------------------------------+-- Miscellaneous enumerations+----------------------------------------------------------------++type PolyFillMode = INT+#{enum PolyFillMode,+ , aLTERNATE = ALTERNATE+ , wINDING = WINDING+ }++----------------------------------------------------------------++type ArcDirection = INT+type MbArcDirection = Maybe ArcDirection+#{enum ArcDirection,+ , aD_COUNTERCLOCKWISE = AD_COUNTERCLOCKWISE+ , aD_CLOCKWISE = AD_CLOCKWISE+ }++----------------------------------------------------------------++type GraphicsMode = DWORD+type MbGraphicsMode = Maybe GraphicsMode+#{enum GraphicsMode,+ , gM_COMPATIBLE = GM_COMPATIBLE+ , gM_ADVANCED = GM_ADVANCED+ }++----------------------------------------------------------------++type BackgroundMode = INT+#{enum BackgroundMode,+ , tRANSPARENT = TRANSPARENT+ , oPAQUE = OPAQUE+ }++----------------------------------------------------------------++type HatchStyle = INT+#{enum HatchStyle,+ , hS_HORIZONTAL = HS_HORIZONTAL+ , hS_VERTICAL = HS_VERTICAL+ , hS_FDIAGONAL = HS_FDIAGONAL+ , hS_BDIAGONAL = HS_BDIAGONAL+ , hS_CROSS = HS_CROSS+ , hS_DIAGCROSS = HS_DIAGCROSS+ }++----------------------------------------------------------------++type StretchBltMode = INT+#{enum StretchBltMode,+ , bLACKONWHITE = BLACKONWHITE+ , wHITEONBLACK = WHITEONBLACK+ , cOLORONCOLOR = COLORONCOLOR+ , hALFTONE = HALFTONE+ , sTRETCH_ANDSCANS = STRETCH_ANDSCANS+ , sTRETCH_ORSCANS = STRETCH_ORSCANS+ , sTRETCH_DELETESCANS = STRETCH_DELETESCANS+ }++----------------------------------------------------------------++type TextAlignment = UINT+#{enum TextAlignment,+ , tA_NOUPDATECP = TA_NOUPDATECP+ , tA_UPDATECP = TA_UPDATECP+ , tA_LEFT = TA_LEFT+ , tA_RIGHT = TA_RIGHT+ , tA_CENTER = TA_CENTER+ , tA_TOP = TA_TOP+ , tA_BOTTOM = TA_BOTTOM+ , tA_BASELINE = TA_BASELINE+ }++----------------------------------------------------------------++type ClippingMode = INT+#{enum ClippingMode,+ , rGN_AND = RGN_AND+ , rGN_OR = RGN_OR+ , rGN_XOR = RGN_XOR+ , rGN_DIFF = RGN_DIFF+ , rGN_COPY = RGN_COPY+ }++----------------------------------------------------------------++type RegionType = INT+#{enum RegionType,+ , eRROR = ERROR+ , nULLREGION = NULLREGION+ , sIMPLEREGION = SIMPLEREGION+ , cOMPLEXREGION = COMPLEXREGION+ }++gDI_ERROR :: Num a => a+gDI_ERROR = #{const GDI_ERROR}++cLR_INVALID :: COLORREF+cLR_INVALID = #{const CLR_INVALID}++----------------------------------------------------------------++#{enum UINT,+ , oBJ_PEN = OBJ_PEN+ , oBJ_BRUSH = OBJ_BRUSH+ , oBJ_DC = OBJ_DC+ , oBJ_METADC = OBJ_METADC+ , oBJ_PAL = OBJ_PAL+ , oBJ_FONT = OBJ_FONT+ , oBJ_BITMAP = OBJ_BITMAP+ , oBJ_REGION = OBJ_REGION+ , oBJ_METAFILE = OBJ_METAFILE+ , oBJ_MEMDC = OBJ_MEMDC+ , oBJ_EXTPEN = OBJ_EXTPEN+ , oBJ_ENHMETADC = OBJ_ENHMETADC+ , oBJ_ENHMETAFILE = OBJ_ENHMETAFILE+ }++----------------------------------------------------------------+-- Miscellaneous primitives+----------------------------------------------------------------++-- Can't pass structs with current FFI, so use C wrappers++foreign import ccall unsafe "HsGDI.h"+ prim_ChildWindowFromPoint :: HWND -> Ptr POINT -> IO HWND+foreign import ccall unsafe "HsGDI.h"+ prim_ChildWindowFromPointEx :: HWND -> Ptr POINT -> DWORD -> IO HWND+foreign import ccall unsafe "HsGDI.h"+ prim_MenuItemFromPoint :: HWND -> HMENU -> Ptr POINT -> IO UINT++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/Icon.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.Icon+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.Icon where++import Graphics.Win32.GDI.Types+import System.Win32.Types++----------------------------------------------------------------+-- Icons+----------------------------------------------------------------++copyIcon :: HICON -> IO HICON+copyIcon icon =+ failIfNull "CopyIcon" $ c_CopyIcon icon+foreign import stdcall unsafe "windows.h CopyIcon"+ c_CopyIcon :: HICON -> IO HICON++drawIcon :: HDC -> Int -> Int -> HICON -> IO ()+drawIcon dc x y icon =+ failIfFalse_ "DrawIcon" $ c_DrawIcon dc x y icon+foreign import stdcall unsafe "windows.h DrawIcon"+ c_DrawIcon :: HDC -> Int -> Int -> HICON -> IO Bool++destroyIcon :: HICON -> IO ()+destroyIcon icon =+ failIfFalse_ "DestroyIcon" $ c_DestroyIcon icon+foreign import stdcall unsafe "windows.h DestroyIcon"+ c_DestroyIcon :: HICON -> IO Bool++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/Key.hsc view
@@ -0,0 +1,120 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.Key+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.Key where++import Graphics.Win32.GDI.Types+import System.Win32.Types++import Control.Monad (liftM)++#include <windows.h>++type VKey = DWORD++#{enum VKey,+ , vK_LBUTTON = VK_LBUTTON+ , vK_RBUTTON = VK_RBUTTON+ , vK_CANCEL = VK_CANCEL+ , vK_MBUTTON = VK_MBUTTON+ , vK_BACK = VK_BACK+ , vK_TAB = VK_TAB+ , vK_CLEAR = VK_CLEAR+ , vK_RETURN = VK_RETURN+ , vK_SHIFT = VK_SHIFT+ , vK_CONTROL = VK_CONTROL+ , vK_MENU = VK_MENU+ , vK_PAUSE = VK_PAUSE+ , vK_CAPITAL = VK_CAPITAL+ , vK_ESCAPE = VK_ESCAPE+ , vK_SPACE = VK_SPACE+ , vK_PRIOR = VK_PRIOR+ , vK_NEXT = VK_NEXT+ , vK_END = VK_END+ , vK_HOME = VK_HOME+ , vK_LEFT = VK_LEFT+ , vK_UP = VK_UP+ , vK_RIGHT = VK_RIGHT+ , vK_DOWN = VK_DOWN+ , vK_SELECT = VK_SELECT+ , vK_EXECUTE = VK_EXECUTE+ , vK_SNAPSHOT = VK_SNAPSHOT+ , vK_INSERT = VK_INSERT+ , vK_DELETE = VK_DELETE+ , vK_HELP = VK_HELP+ , vK_NUMPAD0 = VK_NUMPAD0+ , vK_NUMPAD1 = VK_NUMPAD1+ , vK_NUMPAD2 = VK_NUMPAD2+ , vK_NUMPAD3 = VK_NUMPAD3+ , vK_NUMPAD4 = VK_NUMPAD4+ , vK_NUMPAD5 = VK_NUMPAD5+ , vK_NUMPAD6 = VK_NUMPAD6+ , vK_NUMPAD7 = VK_NUMPAD7+ , vK_NUMPAD8 = VK_NUMPAD8+ , vK_NUMPAD9 = VK_NUMPAD9+ , vK_MULTIPLY = VK_MULTIPLY+ , vK_ADD = VK_ADD+ , vK_SEPARATOR = VK_SEPARATOR+ , vK_SUBTRACT = VK_SUBTRACT+ , vK_DECIMAL = VK_DECIMAL+ , vK_DIVIDE = VK_DIVIDE+ , vK_F1 = VK_F1+ , vK_F2 = VK_F2+ , vK_F3 = VK_F3+ , vK_F4 = VK_F4+ , vK_F5 = VK_F5+ , vK_F6 = VK_F6+ , vK_F7 = VK_F7+ , vK_F8 = VK_F8+ , vK_F9 = VK_F9+ , vK_F10 = VK_F10+ , vK_F11 = VK_F11+ , vK_F12 = VK_F12+ , vK_F13 = VK_F13+ , vK_F14 = VK_F14+ , vK_F15 = VK_F15+ , vK_F16 = VK_F16+ , vK_F17 = VK_F17+ , vK_F18 = VK_F18+ , vK_F19 = VK_F19+ , vK_F20 = VK_F20+ , vK_F21 = VK_F21+ , vK_F22 = VK_F22+ , vK_F23 = VK_F23+ , vK_F24 = VK_F24+ , vK_NUMLOCK = VK_NUMLOCK+ , vK_SCROLL = VK_SCROLL+ }++foreign import stdcall unsafe "windows.h EnableWindow"+ enableWindow :: HWND -> Bool -> IO Bool++getActiveWindow :: IO (Maybe HWND)+getActiveWindow = liftM ptrToMaybe c_GetActiveWindow+foreign import stdcall unsafe "windows.h GetActiveWindow"+ c_GetActiveWindow :: IO HWND++foreign import stdcall unsafe "windows.h GetAsyncKeyState"+ getAsyncKeyState :: Int -> IO WORD++getFocus :: IO (Maybe HWND)+getFocus = liftM ptrToMaybe c_GetFocus+foreign import stdcall unsafe "windows.h GetFocus"+ c_GetFocus :: IO HWND++foreign import stdcall unsafe "windows.h GetKBCodePage"+ getKBCodePage :: IO UINT++foreign import stdcall unsafe "windows.h IsWindowEnabled"+ isWindowEnabled :: HWND -> IO Bool
+ Graphics/Win32/Menu.hsc view
@@ -0,0 +1,471 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.Menu+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.Menu+{-+ (+ MenuName+ , checkMenuItem+ , checkMenuRadioItem+ , createMenu+ , createPopupMenu+ , deleteMenu+ , destroyMenu+ , drawMenuBar+ , enableMenuItem+ , getMenu+ , getMenuDefaultItem+ , getMenuItemCount+ , getMenuItemID+ , getMenuItemInfo+ , getMenuItemRect+ , getMenuState+ , getSubMenu+ , getSystemMenu+ , hiliteMenuItem+ , insertMenuItem+ , isMenu+ , loadMenu+ , menuItemFromPoint+ , setMenu+ , setMenuDefaultItem+ , setMenuItemBitmaps+ , setMenuItemInfo+ , trackPopupMenu+ , trackPopupMenuEx++ , GMDIFlag+ , MenuItem+ , MenuFlag+ , MenuState+ , TrackMenuFlag+ , SystemMenuCommand++ -- Obsolete:+ , appendMenu+ , insertMenu+ , modifyMenu+ , removeMenu++ ) -} where++import Graphics.Win32.GDI.Types+import System.Win32.Types++import Foreign+import Control.Monad (liftM)++#include <windows.h>++type MenuName = LPCTSTR++checkMenuItem :: HMENU -> MenuItem -> MenuFlag -> IO Bool+checkMenuItem menu item check = do+ rv <- failIf (== -1) "CheckMenuItem" $ c_CheckMenuItem menu item check+ return (rv == mF_CHECKED)+foreign import stdcall unsafe "windows.h CheckMenuItem"+ c_CheckMenuItem :: HMENU -> UINT -> UINT -> IO DWORD++checkMenuRadioItem :: HMENU -> MenuItem -> MenuItem -> MenuItem -> MenuFlag -> IO ()+checkMenuRadioItem menu first_id last_id check flags =+ failIfFalse_ "CheckMenuRadioItem" $+ c_CheckMenuRadioItem menu first_id last_id check flags+foreign import stdcall unsafe "windows.h CheckMenuRadioItem"+ c_CheckMenuRadioItem :: HMENU -> UINT -> UINT -> UINT -> UINT -> IO Bool++createMenu :: IO HMENU+createMenu =+ failIfNull "CreateMenu" $ c_CreateMenu+foreign import stdcall unsafe "windows.h CreateMenu"+ c_CreateMenu :: IO HMENU++createPopupMenu :: IO HMENU+createPopupMenu =+ failIfNull "CreatePopupMenu" $ c_CreatePopupMenu+foreign import stdcall unsafe "windows.h CreatePopupMenu"+ c_CreatePopupMenu :: IO HMENU++drawMenuBar :: HWND -> IO ()+drawMenuBar wnd =+ failIfFalse_ "DrawMenuBar" $ c_DrawMenuBar wnd+foreign import stdcall unsafe "windows.h DrawMenuBar"+ c_DrawMenuBar :: HWND -> IO Bool++type MenuState = MenuFlag++enableMenuItem :: HMENU -> MenuItem -> MenuFlag -> IO MenuState+enableMenuItem menu item flag =+ failIf (== 0xffffffff) "EnableMenuItem" $ c_EnableMenuItem menu item flag+foreign import stdcall unsafe "windows.h EnableMenuItem"+ c_EnableMenuItem :: HMENU -> UINT -> UINT -> IO MenuState++type GMDIFlag = UINT++type MenuFlag = UINT++#{enum GMDIFlag,+ , gMDI_USEDISABLED = GMDI_USEDISABLED+ , gMDI_GOINTOPOPUPS = GMDI_GOINTOPOPUPS+ }++#{enum MenuFlag,+ , mF_BYCOMMAND = MF_BYCOMMAND+ , mF_BYPOSITION = MF_BYPOSITION+ , mF_CHECKED = MF_CHECKED+ }++type MenuItem = UINT++#{enum MenuItem,+ , mF_INSERT = MF_INSERT+ , mF_CHANGE = MF_CHANGE+ , mF_APPEND = MF_APPEND+ , mF_DELETE = MF_DELETE+ , mF_REMOVE = MF_REMOVE+ , mF_USECHECKBITMAPS = MF_USECHECKBITMAPS+ , mF_POPUP = MF_POPUP+ , mF_SYSMENU = MF_SYSMENU+ , mF_HELP = MF_HELP+ , mF_MOUSESELECT = MF_MOUSESELECT+ , mF_END = MF_END // Obsolete -- only used by old RES files+ }++#{enum MenuFlag,+ , mFT_STRING = MFT_STRING+ , mFT_BITMAP = MFT_BITMAP+ , mFT_MENUBARBREAK = MFT_MENUBARBREAK+ , mFT_MENUBREAK = MFT_MENUBREAK+ , mFT_OWNERDRAW = MFT_OWNERDRAW+ , mFT_RADIOCHECK = MFT_RADIOCHECK+ , mFT_SEPARATOR = MFT_SEPARATOR+ , mFT_RIGHTORDER = MFT_RIGHTORDER+ , mFT_RIGHTJUSTIFY = MFT_RIGHTJUSTIFY+ }+++#{enum MenuState,+ , mFS_GRAYED = MFS_GRAYED+ , mFS_DISABLED = MFS_DISABLED // == MFS_GRAYED+ , mFS_CHECKED = MFS_CHECKED+ , mFS_HILITE = MFS_HILITE+ , mFS_ENABLED = MFS_ENABLED+ , mFS_UNCHECKED = MFS_UNCHECKED+ , mFS_UNHILITE = MFS_UNHILITE+ , mFS_DEFAULT = MFS_DEFAULT+ }++type TrackMenuFlag = UINT++#{enum TrackMenuFlag,+ , tPM_LEFTBUTTON = TPM_LEFTBUTTON+ , tPM_RIGHTBUTTON = TPM_RIGHTBUTTON+ , tPM_LEFTALIGN = TPM_LEFTALIGN+ , tPM_CENTERALIGN = TPM_CENTERALIGN+ , tPM_RIGHTALIGN = TPM_RIGHTALIGN+ , tPM_TOPALIGN = TPM_TOPALIGN+ , tPM_VCENTERALIGN = TPM_VCENTERALIGN+ , tPM_BOTTOMALIGN = TPM_BOTTOMALIGN+ , tPM_HORIZONTAL = TPM_HORIZONTAL // Horz alignment matters more+ , tPM_VERTICAL = TPM_VERTICAL // Vert alignment matters more+ , tPM_NONOTIFY = TPM_NONOTIFY // Don't send any notification msgs+ , tPM_RETURNCMD = TPM_RETURNCMD+ }++type SystemMenuCommand = UINT++#{enum SystemMenuCommand,+ , sC_SIZE = SC_SIZE+ , sC_MOVE = SC_MOVE+ , sC_MINIMIZE = SC_MINIMIZE+ , sC_MAXIMIZE = SC_MAXIMIZE+ , sC_NEXTWINDOW = SC_NEXTWINDOW+ , sC_PREVWINDOW = SC_PREVWINDOW+ , sC_CLOSE = SC_CLOSE+ , sC_VSCROLL = SC_VSCROLL+ , sC_HSCROLL = SC_HSCROLL+ , sC_MOUSEMENU = SC_MOUSEMENU+ , sC_KEYMENU = SC_KEYMENU+ , sC_ARRANGE = SC_ARRANGE+ , sC_RESTORE = SC_RESTORE+ , sC_TASKLIST = SC_TASKLIST+ , sC_SCREENSAVE = SC_SCREENSAVE+ , sC_HOTKEY = SC_HOTKEY+ , sC_DEFAULT = SC_DEFAULT+ , sC_MONITORPOWER = SC_MONITORPOWER+ , sC_CONTEXTHELP = SC_CONTEXTHELP+ , sC_SEPARATOR = SC_SEPARATOR+ }++foreign import stdcall unsafe "windows.h IsMenu" isMenu :: HMENU -> IO Bool++getSystemMenu :: HWND -> Bool -> IO (Maybe HMENU)+getSystemMenu wnd revert =+ liftM ptrToMaybe $ c_GetSystemMenu wnd revert+foreign import stdcall unsafe "windows.h GetSystemMenu"+ c_GetSystemMenu :: HWND -> Bool -> IO HMENU++getMenu :: HWND -> IO (Maybe HMENU)+getMenu wnd =+ liftM ptrToMaybe $ c_GetMenu wnd+foreign import stdcall unsafe "windows.h GetMenu"+ c_GetMenu :: HWND -> IO HMENU++getMenuDefaultItem :: HMENU -> Bool -> GMDIFlag -> IO MenuItem+getMenuDefaultItem menu bypos flags =+ failIf (== -1) "GetMenuDefaultItem" $ c_GetMenuDefaultItem menu bypos flags+foreign import stdcall unsafe "windows.h GetMenuDefaultItem"+ c_GetMenuDefaultItem :: HMENU -> Bool -> UINT -> IO UINT++getMenuState :: HMENU -> MenuItem -> MenuFlag -> IO MenuState+getMenuState menu item flags =+ failIf (== -1) "GetMenuState" $ c_GetMenuState menu item flags+foreign import stdcall unsafe "windows.h GetMenuState"+ c_GetMenuState :: HMENU -> UINT -> UINT -> IO MenuState++getSubMenu :: HMENU -> MenuItem -> IO (Maybe HMENU)+getSubMenu menu pos =+ liftM ptrToMaybe $ c_GetSubMenu menu pos+foreign import stdcall unsafe "windows.h GetSubMenu"+ c_GetSubMenu :: HMENU -> UINT -> IO HMENU++setMenu :: HWND -> HMENU -> IO ()+setMenu wnd menu =+ failIfFalse_ "SetMenu" $ c_SetMenu wnd menu+foreign import stdcall unsafe "windows.h SetMenu"+ c_SetMenu :: HWND -> HMENU -> IO Bool++getMenuItemCount :: HMENU -> IO Int+getMenuItemCount menu =+ failIf (== -1) "GetMenuItemCount" $ c_GetMenuItemCount menu+foreign import stdcall unsafe "windows.h GetMenuItemCount"+ c_GetMenuItemCount :: HMENU -> IO Int++type MenuID = UINT++getMenuItemID :: HMENU -> MenuItem -> IO MenuID+getMenuItemID menu item =+ failIf (== -1) "GetMenuItemID" $ c_GetMenuItemID menu item+foreign import stdcall unsafe "windows.h GetMenuItemID"+ c_GetMenuItemID :: HMENU -> UINT -> IO MenuID++data MenuItemInfo+ = MenuItemInfo {+ menuItemType :: MenuFlag,+ menuItemState :: MenuState,+ menuItemID :: UINT,+ menuItemSubMenu :: HMENU,+ menuItemBitmapChecked :: HBITMAP,+ menuItemBitmapUnchecked :: HBITMAP,+ menuItemData :: DWORD,+ menuItemTypeData :: String+ }++-- Don't make this an instance of Storable, because poke isn't what we want.++peekMenuItemInfo :: Ptr MenuItemInfo -> IO MenuItemInfo+peekMenuItemInfo p = do+ itemType <- #{peek MENUITEMINFO,fType} p+ itemState <- #{peek MENUITEMINFO,fState} p+ itemID <- #{peek MENUITEMINFO,wID} p+ itemSubMenu <- #{peek MENUITEMINFO,hSubMenu} p+ itemBitmapChecked <- #{peek MENUITEMINFO,hbmpChecked} p+ itemBitmapUnchecked <- #{peek MENUITEMINFO,hbmpUnchecked} p+ itemData <- #{peek MENUITEMINFO,dwItemData} p+ nchars <- #{peek MENUITEMINFO,cch} p+ c_str <- #{peek MENUITEMINFO,dwTypeData} p+ itemTypeData <- peekTStringLen (c_str, fromIntegral (nchars::UINT))+ return MenuItemInfo+ { menuItemType = itemType+ , menuItemState = itemState+ , menuItemID = itemID+ , menuItemSubMenu = itemSubMenu+ , menuItemBitmapChecked = itemBitmapChecked+ , menuItemBitmapUnchecked = itemBitmapUnchecked+ , menuItemData = itemData+ , menuItemTypeData = itemTypeData+ }++allocaMenuItemInfo :: (Ptr MenuItemInfo -> IO a) -> IO a+allocaMenuItemInfo f =+ let size = #{size MENUITEMINFO} in+ allocaBytes size $ \ p -> do+ #{poke MENUITEMINFO,cbSize} p (fromIntegral size::DWORD)+ f p++withMenuItemInfo :: MenuItemInfo -> (Ptr MenuItemInfo -> IO a) -> IO a+withMenuItemInfo info f =+ allocaMenuItemInfo $ \ p ->+ withTStringLen (menuItemTypeData info) $ \ (c_str, nchars) -> do+ #{poke MENUITEMINFO,fType} p (menuItemType info)+ #{poke MENUITEMINFO,fState} p (menuItemState info)+ #{poke MENUITEMINFO,wID} p (menuItemID info)+ #{poke MENUITEMINFO,hSubMenu} p (menuItemSubMenu info)+ #{poke MENUITEMINFO,hbmpChecked} p (menuItemBitmapChecked info)+ #{poke MENUITEMINFO,hbmpUnchecked} p (menuItemBitmapUnchecked info)+ #{poke MENUITEMINFO,dwItemData} p c_str+ #{poke MENUITEMINFO,cch} p (fromIntegral nchars::UINT)+ f p++type MenuItemMask = UINT++#{enum MenuItemMask,+ , mIIM_CHECKMARKS = MIIM_CHECKMARKS+ , mIIM_DATA = MIIM_DATA+ , mIIM_ID = MIIM_ID+ , mIIM_STATE = MIIM_STATE+ , mIIM_SUBMENU = MIIM_SUBMENU+ , mIIM_TYPE = MIIM_TYPE+ }++pokeFMask :: Ptr MenuItemInfo -> MenuItemMask -> IO ()+pokeFMask p_info mask =+ #{poke MENUITEMINFO,fMask} p_info mask++getMenuItemInfo :: HMENU -> MenuItem -> Bool -> MenuItemMask -> IO MenuItemInfo+getMenuItemInfo menu item bypos mask =+ allocaMenuItemInfo $ \ p_info -> do+ pokeFMask p_info mask+ failIfFalse_ "GetMenuItemInfo" $ c_GetMenuItemInfo menu item bypos p_info+ peekMenuItemInfo p_info+foreign import stdcall unsafe "windows.h GetMenuItemInfoW"+ c_GetMenuItemInfo :: HMENU -> UINT -> Bool -> Ptr MenuItemInfo -> IO Bool++getMenuItemRect :: HWND -> HMENU -> MenuItem -> IO RECT+getMenuItemRect wnd menu item =+ allocaRECT $ \ p_rect -> do+ failIfFalse_ "GetMenuItemRect" $ c_GetMenuItemRect wnd menu item p_rect+ peekRECT p_rect+foreign import stdcall unsafe "windows.h GetMenuItemRect"+ c_GetMenuItemRect :: HWND -> HMENU -> UINT -> LPRECT -> IO Bool++foreign import stdcall unsafe "windows.h HiliteMenuItem"+ hiliteMenuItem :: HWND -> HMENU -> MenuItem -> MenuFlag -> IO Bool++insertMenuItem :: HMENU -> MenuItem -> Bool -> MenuItemInfo -> IO ()+insertMenuItem menu item bypos info =+ withMenuItemInfo info $ \ p_info ->+ failIfFalse_ "InsertMenuItem" $ c_InsertMenuItem menu item bypos p_info+foreign import stdcall unsafe "windows.h InsertMenuItemW"+ c_InsertMenuItem :: HMENU -> UINT -> Bool -> Ptr MenuItemInfo -> IO Bool++type Menu = LPCTSTR+-- intToMenu :: Int -> Menu+-- intToMenu i = makeIntResource (toWord i)++loadMenu :: Maybe HINSTANCE -> Menu -> IO HMENU+loadMenu mb_inst menu =+ failIfNull "LoadMenu" $ c_LoadMenu (maybePtr mb_inst) menu+foreign import stdcall unsafe "windows.h LoadMenuW"+ c_LoadMenu :: HINSTANCE -> Menu -> IO HMENU++-- Dealing with mappings to/from structs is a pain in GC,+-- so we'll leave this one out for now.+-- %fun LoadMenuIndirect :: MenuTemplate -> IO HMENU++-- Can't pass structs with current FFI, so use a C wrapper (from Types)+menuItemFromPoint :: HWND -> HMENU -> POINT -> IO UINT+menuItemFromPoint wnd menu pt =+ withPOINT pt $ \ p_pt ->+ prim_MenuItemFromPoint wnd menu p_pt++setMenuDefaultItem :: HMENU -> MenuItem -> Bool -> IO ()+setMenuDefaultItem menu item bypos =+ failIfFalse_ "SetMenuDefaultItem" $ c_SetMenuDefaultItem menu item bypos+foreign import stdcall unsafe "windows.h SetMenuDefaultItem"+ c_SetMenuDefaultItem :: HMENU -> MenuItem -> Bool -> IO Bool++setMenuItemBitmaps :: HMENU -> MenuItem -> MenuFlag -> HBITMAP -> HBITMAP -> IO ()+setMenuItemBitmaps menu pos flags bm_unchecked bm_checked =+ failIfFalse_ "SetMenuItemBitmaps" $+ c_SetMenuItemBitmaps menu pos flags bm_unchecked bm_checked+foreign import stdcall unsafe "windows.h SetMenuItemBitmaps"+ c_SetMenuItemBitmaps :: HMENU -> UINT -> UINT -> HBITMAP -> HBITMAP -> IO Bool++destroyMenu :: HMENU -> IO ()+destroyMenu menu =+ failIfFalse_ "DestroyMenu" $ c_DestroyMenu menu+foreign import stdcall unsafe "windows.h DestroyMenu"+ c_DestroyMenu :: HMENU -> IO Bool++deleteMenu :: HMENU -> MenuItem -> MenuFlag -> IO ()+deleteMenu menu item flag =+ failIfFalse_ "DeleteMenu" $ c_DeleteMenu menu item flag+foreign import stdcall unsafe "windows.h DeleteMenu"+ c_DeleteMenu :: HMENU -> UINT -> UINT -> IO Bool++setMenuItemInfo :: HMENU -> MenuItem -> Bool -> MenuItemMask -> MenuItemInfo -> IO ()+setMenuItemInfo menu item bypos mask info =+ withMenuItemInfo info $ \ p_info -> do+ pokeFMask p_info mask+ failIfFalse_ "SetMenuItemInfo" $ c_SetMenuItemInfo menu item bypos p_info+foreign import stdcall unsafe "windows.h SetMenuItemInfoW"+ c_SetMenuItemInfo :: HMENU -> UINT -> Bool -> Ptr MenuItemInfo -> IO Bool++trackPopupMenu :: HMENU -> TrackMenuFlag -> Int -> Int -> HWND -> RECT -> IO ()+trackPopupMenu menu flags x y wnd rect =+ withRECT rect $ \ p_rect ->+ failIfFalse_ "TrackPopupMenu" $ c_TrackPopupMenu menu flags x y 0 wnd p_rect+foreign import stdcall unsafe "windows.h TrackPopupMenu"+ c_TrackPopupMenu :: HMENU -> TrackMenuFlag -> Int -> Int -> Int -> HWND -> LPRECT -> IO Bool++type TPMPARAMS = ()++withTPMPARAMS :: Ptr RECT -> (Ptr TPMPARAMS -> IO a) -> IO a+withTPMPARAMS p_rect f =+ let size = #{size TPMPARAMS} in+ allocaBytes size $ \ p -> do+ #{poke TPMPARAMS,cbSize} p (fromIntegral size::UINT)+ copyBytes (#{ptr TPMPARAMS,rcExclude} p) p_rect size+ f p++trackPopupMenuEx :: HMENU -> TrackMenuFlag -> Int -> Int -> HWND -> Maybe (Ptr RECT) -> IO ()+trackPopupMenuEx menu flags x y wnd mb_p_rect =+ maybeWith withTPMPARAMS mb_p_rect $ \ p_ptmp ->+ failIfFalse_ "TrackPopupMenuEx" $ c_TrackPopupMenuEx menu flags x y wnd p_ptmp+foreign import stdcall unsafe "windows.h TrackPopupMenuEx"+ c_TrackPopupMenuEx :: HMENU -> TrackMenuFlag -> Int -> Int -> HWND -> Ptr TPMPARAMS -> IO Bool++-- Note: these 3 assume the flags don't include MF_BITMAP or MF_OWNERDRAW+-- (which are hidden by this interface)++appendMenu :: HMENU -> MenuFlag -> MenuID -> String -> IO ()+appendMenu menu flags id_item name =+ withTString name $ \ c_name ->+ failIfFalse_ "AppendMenu" $ c_AppendMenu menu flags id_item c_name+foreign import stdcall unsafe "windows.h AppendMenuW"+ c_AppendMenu :: HMENU -> UINT -> MenuID -> LPCTSTR -> IO Bool++insertMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> String -> IO ()+insertMenu menu item flags id_item name =+ withTString name $ \ c_name ->+ failIfFalse_ "InsertMenu" $ c_InsertMenu menu item flags id_item c_name+foreign import stdcall unsafe "windows.h InsertMenuW"+ c_InsertMenu :: HMENU -> UINT -> UINT -> MenuID -> LPCTSTR -> IO Bool++modifyMenu :: HMENU -> MenuItem -> MenuFlag -> MenuID -> String -> IO ()+modifyMenu menu item flags id_item name =+ withTString name $ \ c_name ->+ failIfFalse_ "ModifyMenu" $ c_ModifyMenu menu item flags id_item c_name+foreign import stdcall unsafe "windows.h ModifyMenuW"+ c_ModifyMenu :: HMENU -> UINT -> UINT -> MenuID -> LPCTSTR -> IO Bool++removeMenu :: HMENU -> MenuItem -> MenuFlag -> IO ()+removeMenu menu pos flags =+ failIfFalse_ "RemoveMenu" $ c_RemoveMenu menu pos flags+foreign import stdcall unsafe "windows.h RemoveMenu"+ c_RemoveMenu :: HMENU -> UINT -> UINT -> IO Bool++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/Message.hsc view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.Message+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.Message where++import System.Win32.Types++#include <windows.h>++type WindowMessage = DWORD++#{enum WindowMessage,+ , wM_COMPACTING = WM_COMPACTING+ , wM_WININICHANGE = WM_WININICHANGE+ , wM_SYSCOLORCHANGE = WM_SYSCOLORCHANGE+ , wM_QUERYNEWPALETTE = WM_QUERYNEWPALETTE+ , wM_PALETTEISCHANGING = WM_PALETTEISCHANGING+ , wM_PALETTECHANGED = WM_PALETTECHANGED+ , wM_FONTCHANGE = WM_FONTCHANGE+ , wM_SPOOLERSTATUS = WM_SPOOLERSTATUS+ , wM_DEVMODECHANGE = WM_DEVMODECHANGE+ , wM_TIMECHANGE = WM_TIMECHANGE+ , wM_POWER = WM_POWER+ , wM_QUERYENDSESSION = WM_QUERYENDSESSION+ , wM_ENDSESSION = WM_ENDSESSION+ , wM_QUIT = WM_QUIT+ , wM_CREATE = WM_CREATE+ , wM_NCCREATE = WM_NCCREATE+ , wM_DESTROY = WM_DESTROY+ , wM_NCDESTROY = WM_NCDESTROY+ , wM_SHOWWINDOW = WM_SHOWWINDOW+ , wM_SETREDRAW = WM_SETREDRAW+ , wM_ENABLE = WM_ENABLE+ , wM_SETTEXT = WM_SETTEXT+ , wM_GETTEXT = WM_GETTEXT+ , wM_GETTEXTLENGTH = WM_GETTEXTLENGTH+ , wM_WINDOWPOSCHANGING = WM_WINDOWPOSCHANGING+ , wM_WINDOWPOSCHANGED = WM_WINDOWPOSCHANGED+ , wM_MOVE = WM_MOVE+ , wM_SIZE = WM_SIZE+ , wM_QUERYOPEN = WM_QUERYOPEN+ , wM_CLOSE = WM_CLOSE+ , wM_GETMINMAXINFO = WM_GETMINMAXINFO+ , wM_PAINT = WM_PAINT+ , wM_ERASEBKGND = WM_ERASEBKGND+ , wM_ICONERASEBKGND = WM_ICONERASEBKGND+ , wM_NCPAINT = WM_NCPAINT+ , wM_NCCALCSIZE = WM_NCCALCSIZE+ , wM_QUERYDRAGICON = WM_QUERYDRAGICON+ , wM_DROPFILES = WM_DROPFILES+ , wM_ACTIVATE = WM_ACTIVATE+ , wM_ACTIVATEAPP = WM_ACTIVATEAPP+ , wM_NCACTIVATE = WM_NCACTIVATE+ , wM_SETFOCUS = WM_SETFOCUS+ , wM_KILLFOCUS = WM_KILLFOCUS+ , wM_KEYDOWN = WM_KEYDOWN+ , wM_KEYUP = WM_KEYUP+ , wM_CHAR = WM_CHAR+ , wM_DEADCHAR = WM_DEADCHAR+ , wM_SYSKEYDOWN = WM_SYSKEYDOWN+ , wM_SYSKEYUP = WM_SYSKEYUP+ , wM_SYSCHAR = WM_SYSCHAR+ , wM_SYSDEADCHAR = WM_SYSDEADCHAR+ , wM_KEYFIRST = WM_KEYFIRST+ , wM_KEYLAST = WM_KEYLAST+ , wM_MOUSEMOVE = WM_MOUSEMOVE+ , wM_LBUTTONDOWN = WM_LBUTTONDOWN+ , wM_LBUTTONUP = WM_LBUTTONUP+ , wM_LBUTTONDBLCLK = WM_LBUTTONDBLCLK+ , wM_RBUTTONDOWN = WM_RBUTTONDOWN+ , wM_RBUTTONUP = WM_RBUTTONUP+ , wM_RBUTTONDBLCLK = WM_RBUTTONDBLCLK+ , wM_MBUTTONDOWN = WM_MBUTTONDOWN+ , wM_MBUTTONUP = WM_MBUTTONUP+ , wM_MBUTTONDBLCLK = WM_MBUTTONDBLCLK+ , wM_MOUSEFIRST = WM_MOUSEFIRST+ , wM_MOUSELAST = WM_MOUSELAST+ , wM_NCMOUSEMOVE = WM_NCMOUSEMOVE+ , wM_NCLBUTTONDOWN = WM_NCLBUTTONDOWN+ , wM_NCLBUTTONUP = WM_NCLBUTTONUP+ , wM_NCLBUTTONDBLCLK = WM_NCLBUTTONDBLCLK+ , wM_NCRBUTTONDOWN = WM_NCRBUTTONDOWN+ , wM_NCRBUTTONUP = WM_NCRBUTTONUP+ , wM_NCRBUTTONDBLCLK = WM_NCRBUTTONDBLCLK+ , wM_NCMBUTTONDOWN = WM_NCMBUTTONDOWN+ , wM_NCMBUTTONUP = WM_NCMBUTTONUP+ , wM_NCMBUTTONDBLCLK = WM_NCMBUTTONDBLCLK+ , wM_MOUSEACTIVATE = WM_MOUSEACTIVATE+ , wM_CANCELMODE = WM_CANCELMODE+ , wM_TIMER = WM_TIMER+ , wM_INITMENU = WM_INITMENU+ , wM_INITMENUPOPUP = WM_INITMENUPOPUP+ , wM_MENUSELECT = WM_MENUSELECT+ , wM_MENUCHAR = WM_MENUCHAR+ , wM_COMMAND = WM_COMMAND+ , wM_HSCROLL = WM_HSCROLL+ , wM_VSCROLL = WM_VSCROLL+ , wM_CUT = WM_CUT+ , wM_COPY = WM_COPY+ , wM_PASTE = WM_PASTE+ , wM_CLEAR = WM_CLEAR+ , wM_UNDO = WM_UNDO+ , wM_RENDERFORMAT = WM_RENDERFORMAT+ , wM_RENDERALLFORMATS = WM_RENDERALLFORMATS+ , wM_DESTROYCLIPBOARD = WM_DESTROYCLIPBOARD+ , wM_DRAWCLIPBOARD = WM_DRAWCLIPBOARD+ , wM_PAINTCLIPBOARD = WM_PAINTCLIPBOARD+ , wM_SIZECLIPBOARD = WM_SIZECLIPBOARD+ , wM_VSCROLLCLIPBOARD = WM_VSCROLLCLIPBOARD+ , wM_HSCROLLCLIPBOARD = WM_HSCROLLCLIPBOARD+ , wM_ASKCBFORMATNAME = WM_ASKCBFORMATNAME+ , wM_CHANGECBCHAIN = WM_CHANGECBCHAIN+ , wM_SETCURSOR = WM_SETCURSOR+ , wM_SYSCOMMAND = WM_SYSCOMMAND+ , wM_MDICREATE = WM_MDICREATE+ , wM_MDIDESTROY = WM_MDIDESTROY+ , wM_MDIACTIVATE = WM_MDIACTIVATE+ , wM_MDIRESTORE = WM_MDIRESTORE+ , wM_MDINEXT = WM_MDINEXT+ , wM_MDIMAXIMIZE = WM_MDIMAXIMIZE+ , wM_MDITILE = WM_MDITILE+ , wM_MDICASCADE = WM_MDICASCADE+ , wM_MDIICONARRANGE = WM_MDIICONARRANGE+ , wM_MDIGETACTIVE = WM_MDIGETACTIVE+ , wM_MDISETMENU = WM_MDISETMENU+ , wM_CHILDACTIVATE = WM_CHILDACTIVATE+ , wM_INITDIALOG = WM_INITDIALOG+ , wM_NEXTDLGCTL = WM_NEXTDLGCTL+ , wM_PARENTNOTIFY = WM_PARENTNOTIFY+ , wM_ENTERIDLE = WM_ENTERIDLE+ , wM_GETDLGCODE = WM_GETDLGCODE+ , wM_SETFONT = WM_SETFONT+ , wM_GETFONT = WM_GETFONT+ , wM_DRAWITEM = WM_DRAWITEM+ , wM_MEASUREITEM = WM_MEASUREITEM+ , wM_DELETEITEM = WM_DELETEITEM+ , wM_COMPAREITEM = WM_COMPAREITEM+ , wM_VKEYTOITEM = WM_VKEYTOITEM+ , wM_CHARTOITEM = WM_CHARTOITEM+ , wM_QUEUESYNC = WM_QUEUESYNC+ , wM_USER = WM_USER+ , wM_APP = WM_APP+ }++registerWindowMessage :: String -> IO WindowMessage+registerWindowMessage msg =+ withTString msg c_RegisterWindowMessage+foreign import stdcall unsafe "windows.h RegisterWindowMessageW"+ c_RegisterWindowMessage :: LPCTSTR -> IO WindowMessage++-- These are WM_SIZE specific+#{enum WPARAM,+ , sIZE_RESTORED = SIZE_RESTORED+ , sIZE_MINIMIZED = SIZE_MINIMIZED+ , sIZE_MAXIMIZED = SIZE_MAXIMIZED+ , sIZE_MAXSHOW = SIZE_MAXSHOW+ , sIZE_MAXHIDE = SIZE_MAXHIDE+ }++----------------------------------------------------------------+-- Phew!+----------------------------------------------------------------
+ Graphics/Win32/Misc.hsc view
@@ -0,0 +1,294 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.Misc+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.Misc where++import Graphics.Win32.GDI.Types+import System.Win32.Types++import Data.Maybe+import Foreign++#include <windows.h>+#include "gettime.h"++----------------------------------------------------------------+-- Resources+-- (should probably be distributed between+-- Graphics.Win32.{Icon,Cursor,Accelerator,Menu,...})+----------------------------------------------------------------++type Accelerator = LPCTSTR+-- intToAccelerator :: Int -> Accelerator+-- intToAccelerator i = makeIntResource (toWord i)++-- cursor and icon should not be const pointer; GSL ???+type Cursor = LPTSTR+-- intToCursor :: Int -> Cursor+-- intToCursor i = makeIntResource (toWord i)++type Icon = LPTSTR+-- intToIcon :: Int -> Icon+-- intToIcon i = makeIntResource (toWord i)++loadAccelerators :: Maybe HINSTANCE -> Accelerator -> IO HACCEL+loadAccelerators mb_inst accel =+ failIfNull "LoadAccelerators" $ c_LoadAccelerators (maybePtr mb_inst) accel+foreign import stdcall unsafe "windows.h LoadAcceleratorsW"+ c_LoadAccelerators :: HINSTANCE -> Accelerator -> IO HACCEL++loadCursor :: Maybe HINSTANCE -> Cursor -> IO HCURSOR+loadCursor mb_inst cursor =+ failIfNull "LoadCursor" $ c_LoadCursor (maybePtr mb_inst) cursor+foreign import stdcall unsafe "windows.h LoadCursorW"+ c_LoadCursor :: HINSTANCE -> Cursor -> IO HCURSOR++loadIcon :: Maybe HINSTANCE -> Icon -> IO HICON+loadIcon mb_inst icon =+ failIfNull "LoadIcon" $ c_LoadIcon (maybePtr mb_inst) icon+foreign import stdcall unsafe "windows.h LoadIconW"+ c_LoadIcon :: HINSTANCE -> Icon -> IO HICON++#{enum Cursor, castUINTToPtr+ , iDC_ARROW = (UINT)IDC_ARROW+ , iDC_IBEAM = (UINT)IDC_IBEAM+ , iDC_WAIT = (UINT)IDC_WAIT+ , iDC_CROSS = (UINT)IDC_CROSS+ , iDC_UPARROW = (UINT)IDC_UPARROW+ , iDC_SIZENWSE = (UINT)IDC_SIZENWSE+ , iDC_SIZENESW = (UINT)IDC_SIZENESW+ , iDC_SIZEWE = (UINT)IDC_SIZEWE+ , iDC_SIZENS = (UINT)IDC_SIZENS+ }++#{enum Icon, castUINTToPtr+ , iDI_APPLICATION = (UINT)IDI_APPLICATION+ , iDI_HAND = (UINT)IDI_HAND+ , iDI_QUESTION = (UINT)IDI_QUESTION+ , iDI_EXCLAMATION = (UINT)IDI_EXCLAMATION+ , iDI_ASTERISK = (UINT)IDI_ASTERISK+ }++----------------------------------------------------------------+-- Message Boxes+----------------------------------------------------------------++type MBStyle = UINT++#{enum MBStyle,+ , mB_OK = MB_OK+ , mB_OKCANCEL = MB_OKCANCEL+ , mB_ABORTRETRYIGNORE = MB_ABORTRETRYIGNORE+ , mB_YESNOCANCEL = MB_YESNOCANCEL+ , mB_YESNO = MB_YESNO+ , mB_RETRYCANCEL = MB_RETRYCANCEL+ , mB_ICONHAND = MB_ICONHAND+ , mB_ICONQUESTION = MB_ICONQUESTION+ , mB_ICONEXCLAMATION = MB_ICONEXCLAMATION+ , mB_ICONASTERISK = MB_ICONASTERISK+ , mB_ICONINFORMATION = MB_ICONINFORMATION+ , mB_ICONSTOP = MB_ICONSTOP+ , mB_DEFBUTTON1 = MB_DEFBUTTON1+ , mB_DEFBUTTON2 = MB_DEFBUTTON2+ , mB_DEFBUTTON3 = MB_DEFBUTTON3+ , mB_APPLMODAL = MB_APPLMODAL+ , mB_SYSTEMMODAL = MB_SYSTEMMODAL+ , mB_TASKMODAL = MB_TASKMODAL+ , mB_SETFOREGROUND = MB_SETFOREGROUND+ }++type MBStatus = UINT++#{enum MBStatus,+ , iDABORT = IDABORT+ , iDCANCEL = IDCANCEL+ , iDIGNORE = IDIGNORE+ , iDNO = IDNO+ , iDOK = IDOK+ , iDRETRY = IDRETRY+ , iDYES = IDYES+ }++-- Note: if the error is ever raised, we're in a very sad way!++messageBox :: HWND -> String -> String -> MBStyle -> IO MBStatus+messageBox wnd text caption style =+ withTString text $ \ c_text ->+ withTString caption $ \ c_caption ->+ failIfZero "MessageBox" $ c_MessageBox wnd c_text c_caption style+foreign import stdcall unsafe "windows.h MessageBoxW"+ c_MessageBox :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus++----------------------------------------------------------------+--+----------------------------------------------------------------++type StdHandleId = DWORD++#{enum StdHandleId,+ , sTD_INPUT_HANDLE = STD_INPUT_HANDLE+ , sTD_OUTPUT_HANDLE = STD_OUTPUT_HANDLE+ , sTD_ERROR_HANDLE = STD_ERROR_HANDLE+ }++getStdHandle :: StdHandleId -> IO HANDLE+getStdHandle hid =+ failIf (== iNVALID_HANDLE_VALUE) "GetStdHandle" $ c_GetStdHandle hid+foreign import stdcall unsafe "windows.h GetStdHandle"+ c_GetStdHandle :: StdHandleId -> IO HANDLE++----------------------------------------------------------------+-- Rotatable Ellipse hack+--+-- Win95 (Win32?) doesn't support rotating ellipses - so we+-- implement them with polygons.+--+-- We use a fixed number of edges rather than varying the number+-- according to the radius of the ellipse.+-- If anyone feels like improving the code (to vary the number),+-- they should place a fixed upper bound on the number of edges+-- since it takes a relatively long time to draw 1000 edges.+----------------------------------------------------------------++transformedEllipse :: HDC -> POINT -> POINT -> POINT -> IO ()+transformedEllipse dc (x0,y0) (x1,y1) (x2,y2) =+ failIfFalse_ "transformedEllipse" $ c_transformedEllipse dc x0 y0 x1 y1 x2 y2+foreign import ccall unsafe "ellipse.h transformedEllipse"+ c_transformedEllipse :: HDC -> LONG -> LONG -> LONG -> LONG -> LONG -> LONG -> IO Bool++{-# CFILES cbits/ellipse.c #-}++----------------------------------------------------------------+-- Cursor+----------------------------------------------------------------++getCursorPos :: IO POINT+getCursorPos =+ allocaPOINT $ \ p_pt -> do+ failIfFalse_ "GetCursorPos" $ c_GetCursorPos p_pt+ peekPOINT p_pt+foreign import stdcall unsafe "windows.h GetCursorPos"+ c_GetCursorPos :: Ptr POINT -> IO Bool++setCursorPos :: POINT -> IO ()+setCursorPos (x,y) =+ failIfFalse_ "setCursorPos" $ c_SetCursorPos x y+foreign import stdcall unsafe "windows.h SetCursorPos"+ c_SetCursorPos :: LONG -> LONG -> IO Bool++clipCursor :: RECT -> IO ()+clipCursor rect =+ withRECT rect $ \ p_rect ->+ failIfFalse_ "ClipCursor" $ c_ClipCursor p_rect+foreign import stdcall unsafe "windows.h ClipCursor"+ c_ClipCursor :: Ptr RECT -> IO Bool++getClipCursor :: IO RECT+getClipCursor =+ allocaRECT $ \ p_rect -> do+ failIfFalse_ "GetClipCursor" $ c_GetClipCursor p_rect+ peekRECT p_rect+foreign import stdcall unsafe "windows.h GetClipCursor"+ c_GetClipCursor :: Ptr RECT -> IO Bool++----------------------------------------------------------------+-- Exit/shutdown+----------------------------------------------------------------++type ExitOption = UINT++#{enum ExitOption,+ , eWX_FORCE = EWX_FORCE+ , eWX_LOGOFF = EWX_LOGOFF+ , eWX_POWEROFF = EWX_POWEROFF+ , eWX_REBOOT = EWX_REBOOT+ , eWX_SHUTDOWN = EWX_SHUTDOWN+ }++exitWindowsEx :: ExitOption -> IO ()+exitWindowsEx opt =+ failIfFalse_ "ExitWindowsEx" $ c_ExitWindowsEx opt 0+foreign import stdcall unsafe "windows.h ExitWindowsEx"+ c_ExitWindowsEx :: ExitOption -> DWORD -> IO Bool++exitWindows :: IO ()+exitWindows = exitWindowsEx 0++----------------------------------------------------------------+-- Beeping+----------------------------------------------------------------++type Beep = UINT+type MbBeep = Maybe Beep++maybeBeep :: Maybe Beep -> Beep+maybeBeep = fromMaybe 0xffffffff++type Duration = Int++type MbDuration = Maybe Duration++maybeDuration :: Maybe Duration -> Duration+maybeDuration = fromMaybe (-1)++messageBeep :: Maybe Beep -> IO ()+messageBeep mb_beep =+ c_MessageBeep (maybeBeep mb_beep)+foreign import stdcall unsafe "windows.h MessageBeep"+ c_MessageBeep :: Beep -> IO ()++beep :: WORD -> MbDuration -> IO ()+beep freq mb_dur =+ failIfFalse_ "Beep" $ c_Beep freq (maybeDuration mb_dur)+foreign import stdcall unsafe "windows.h Beep"+ c_Beep :: WORD -> Duration -> IO Bool++----------------------------------------------------------------+-- Timers+----------------------------------------------------------------++type TimerId = UINT++type TIMERPROC = FunPtr (HWND -> UINT -> TimerId -> DWORD -> IO ())++-- ToDo: support the other two forms of timer initialisation++-- Cause WM_TIMER events to be sent to window callback++setWinTimer :: HWND -> TimerId -> UINT -> IO TimerId+setWinTimer wnd timer elapse =+ failIfZero "SetTimer" $ c_SetTimer wnd timer elapse nullFunPtr+foreign import stdcall unsafe "windows.h SetTimer"+ c_SetTimer :: HWND -> TimerId -> UINT -> TIMERPROC -> IO TimerId++killTimer :: Maybe HWND -> TimerId -> IO ()+killTimer mb_wnd timer =+ failIfFalse_ "KillTimer" $ c_KillTimer (maybePtr mb_wnd) timer+foreign import stdcall unsafe "windows.h KillTimer"+ c_KillTimer :: HWND -> TimerId -> IO Bool++-- For documentation purposes:+type MilliSeconds = DWORD++foreign import stdcall unsafe "windows.h timeGetTime"+ timeGetTime :: IO MilliSeconds++----------------------------------------------------------------++-- %fun ezCreateFont :: Unknown+-- %result BITMAP({ getBitmapInfo(x) })++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Graphics/Win32/Resource.hsc view
@@ -0,0 +1,143 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.Resource+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.Resource where++import System.Win32.Types++import Foreign++#include <windows.h>++beginUpdateResource :: String -> Bool -> IO HANDLE+beginUpdateResource name del =+ withTString name $ \ c_name ->+ failIfNull "BeginUpdateResource" $ c_BeginUpdateResource c_name del+foreign import stdcall unsafe "windows.h BeginUpdateResourceW"+ c_BeginUpdateResource :: LPCTSTR -> Bool -> IO HANDLE++type ResourceImageType = UINT++type HRSRC = Ptr ()++type HGLOBAL = Ptr ()++#{enum ResourceImageType,+ , iMAGE_BITMAP = IMAGE_BITMAP+ , iMAGE_ICON = IMAGE_ICON+ , iMAGE_CURSOR = IMAGE_CURSOR+ }++copyImage :: HANDLE -> ResourceImageType -> Int -> Int -> UINT -> IO HANDLE+copyImage h ty x y flags =+ failIfNull "CopyImage" $ c_CopyImage h ty x y flags+foreign import stdcall unsafe "windows.h CopyImage"+ c_CopyImage :: HANDLE -> ResourceImageType -> Int -> Int -> UINT -> IO HANDLE++endUpdateResource :: HANDLE -> BOOL -> IO ()+endUpdateResource h discard =+ failIfFalse_ "EndUpdateResource" $ c_EndUpdateResource h discard+foreign import stdcall unsafe "windows.h EndUpdateResourceW"+ c_EndUpdateResource :: HANDLE -> BOOL -> IO Bool++type ResourceType = LPCTSTR++#{enum ResourceType, castUINTToPtr+ , rT_ACCELERATOR = (UINT)RT_ACCELERATOR // Accelerator table+ , rT_ANICURSOR = (UINT)RT_ANICURSOR // Animated cursor+ , rT_ANIICON = (UINT)RT_ANIICON // Animated icon+ , rT_BITMAP = (UINT)RT_BITMAP // Bitmap resource+ , rT_CURSOR = (UINT)RT_CURSOR // Hardware-dependent cursor resource+ , rT_DIALOG = (UINT)RT_DIALOG // Dialog box+ , rT_FONT = (UINT)RT_FONT // Font resource+ , rT_FONTDIR = (UINT)RT_FONTDIR // Font directory resource+ , rT_GROUP_CURSOR = (UINT)RT_GROUP_CURSOR // Hardware-independent cursor resource+ , rT_GROUP_ICON = (UINT)RT_GROUP_ICON // Hardware-independent icon resource+ , rT_HTML = (UINT)RT_HTML // HTML document+ , rT_ICON = (UINT)RT_ICON // Hardware-dependent icon resource+ , rT_MENU = (UINT)RT_MENU // Menu resource+ , rT_MESSAGETABLE = (UINT)RT_MESSAGETABLE // Message-table entry+ , rT_RCDATA = (UINT)RT_RCDATA // Application-defined resource (raw data)+ , rT_STRING = (UINT)RT_STRING // String-table entry+ , rT_VERSION = (UINT)RT_VERSION // Version resource+ }++findResource :: HMODULE -> String -> ResourceType -> IO HRSRC+findResource hmod name ty =+ withTString name $ \ c_name ->+ failIfNull "FindResource" $ c_FindResource hmod c_name ty+foreign import stdcall unsafe "windows.h FindResourceW"+ c_FindResource :: HMODULE -> LPCTSTR -> LPCTSTR -> IO HRSRC++-- was: LPCTSTR_+findResourceEx :: HMODULE -> String -> ResourceType -> WORD -> IO HRSRC+findResourceEx hmod name ty lang =+ withTString name $ \ c_name ->+ failIfNull "FindResourceEx" $ c_FindResourceEx hmod c_name ty lang+foreign import stdcall unsafe "windows.h FindResourceExW"+ c_FindResourceEx :: HMODULE -> LPCTSTR -> LPCTSTR -> WORD -> IO HRSRC++type ResourceSize = Int++lR_DEFAULTSIZE :: ResourceSize+lR_DEFAULTSIZE = #{const LR_DEFAULTSIZE}++type LoadImageFlags = UINT++#{enum LoadImageFlags,+ , lR_DEFAULTCOLOR = LR_DEFAULTCOLOR+ , lR_CREATEDIBSECTION = LR_CREATEDIBSECTION+ , lR_LOADFROMFILE = LR_LOADFROMFILE+ , lR_LOADMAP3DCOLORS = LR_LOADMAP3DCOLORS+ , lR_LOADTRANSPARENT = LR_LOADTRANSPARENT+ , lR_MONOCHROME = LR_MONOCHROME+ , lR_SHARED = LR_SHARED+ }++-- , LR_VGACOLOR (Not in mingw-20001111 headers)++-- was: LPCTSTR_+loadImage :: HINSTANCE -> String -> ResourceImageType -> ResourceSize -> ResourceSize -> LoadImageFlags -> IO HANDLE+loadImage inst name ty x y load =+ withTString name $ \ c_name ->+ failIfNull "LoadImage" $ c_LoadImage inst c_name ty x y load+foreign import stdcall unsafe "windows.h LoadImageW"+ c_LoadImage :: HINSTANCE -> LPCTSTR -> ResourceImageType -> ResourceSize -> ResourceSize -> LoadImageFlags -> IO HANDLE++loadResource :: HMODULE -> HRSRC -> IO HGLOBAL+loadResource hmod res =+ failIfNull "LoadResource" $ c_LoadResource hmod res+foreign import stdcall unsafe "windows.h LoadResource"+ c_LoadResource :: HMODULE -> HRSRC -> IO HGLOBAL++lockResource :: HGLOBAL -> IO Addr+lockResource res =+ failIfNull "LockResource" $ c_LockResource res+foreign import stdcall unsafe "windows.h LockResource"+ c_LockResource :: HGLOBAL -> IO Addr++sizeofResource :: HMODULE -> HRSRC -> IO DWORD+sizeofResource hmod res =+ failIfZero "SizeofResource" $ c_SizeofResource hmod res+foreign import stdcall unsafe "windows.h SizeofResource"+ c_SizeofResource :: HMODULE -> HRSRC -> IO DWORD++-- was: LPCTSTR_+updateResource :: HANDLE -> ResourceType -> String -> WORD -> Addr -> DWORD -> IO ()+updateResource h ty name lang p_data data_len =+ withTString name $ \ c_name ->+ failIfFalse_ "UpdateResource" $+ c_UpdateResource h ty c_name lang p_data data_len+foreign import stdcall unsafe "windows.h UpdateResourceW"+ c_UpdateResource :: HANDLE -> LPCTSTR -> LPCTSTR -> WORD -> Addr -> DWORD -> IO Bool
+ Graphics/Win32/Window.hsc view
@@ -0,0 +1,689 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Win32.Window+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module Graphics.Win32.Window where++import System.Win32.Types+import Graphics.Win32.GDI.Types+import Graphics.Win32.Message++import Control.Monad+import Data.Maybe+import Foreign++#include <windows.h>++----------------------------------------------------------------+-- Window Class+----------------------------------------------------------------++-- The classname must not be deallocated until the corresponding class+-- is deallocated. For this reason, we represent classnames by pointers+-- and explicitly allocate the className.++type ClassName = LPCTSTR++-- Note: this is one of those rare functions which doesnt free all+-- its String arguments.++mkClassName :: String -> ClassName+mkClassName name = unsafePerformIO (newTString name)++type ClassStyle = UINT++#{enum ClassStyle,+ , cS_VREDRAW = CS_VREDRAW+ , cS_HREDRAW = CS_HREDRAW+ , cS_OWNDC = CS_OWNDC+ , cS_CLASSDC = CS_CLASSDC+ , cS_PARENTDC = CS_PARENTDC+ , cS_SAVEBITS = CS_SAVEBITS+ , cS_DBLCLKS = CS_DBLCLKS+ , cS_BYTEALIGNCLIENT = CS_BYTEALIGNCLIENT+ , cS_BYTEALIGNWINDOW = CS_BYTEALIGNWINDOW+ , cS_NOCLOSE = CS_NOCLOSE+ , cS_GLOBALCLASS = CS_GLOBALCLASS+ }++type WNDCLASS =+ (ClassStyle, -- style+ HINSTANCE, -- hInstance+ Maybe HICON, -- hIcon+ Maybe HCURSOR, -- hCursor+ Maybe HBRUSH, -- hbrBackground+ Maybe LPCTSTR, -- lpszMenuName+ ClassName) -- lpszClassName++--ToDo!+--To avoid confusion with NULL, WNDCLASS requires you to add 1 to a SystemColor+--(which can be NULL)+-- %fun mkMbHBRUSH :: SystemColor -> MbHBRUSH+-- %code+-- %result ((HBRUSH)($0+1));++withWNDCLASS :: WNDCLASS -> (Ptr WNDCLASS -> IO a) -> IO a+withWNDCLASS (style, inst, mb_icon, mb_cursor, mb_bg, mb_menu, cls) f =+ allocaBytes #{size WNDCLASS} $ \ p -> do+ #{poke WNDCLASS,style} p style+ #{poke WNDCLASS,lpfnWndProc} p genericWndProc_p+ #{poke WNDCLASS,cbClsExtra} p (0::INT)+ #{poke WNDCLASS,cbWndExtra} p (0::INT)+ #{poke WNDCLASS,hInstance} p inst+ #{poke WNDCLASS,hIcon} p (maybePtr mb_icon)+ #{poke WNDCLASS,hCursor} p (maybePtr mb_cursor)+ #{poke WNDCLASS,hbrBackground} p (maybePtr mb_bg)+ #{poke WNDCLASS,lpszMenuName} p (maybePtr mb_menu)+ #{poke WNDCLASS,lpszClassName} p cls+ f p++foreign import ccall unsafe "WndProc.h &genericWndProc"+ genericWndProc_p :: FunPtr WindowClosure++{-# CFILES cbits/WndProc.c #-}++registerClass :: WNDCLASS -> IO (Maybe ATOM)+registerClass cls =+ withWNDCLASS cls $ \ p ->+ liftM numToMaybe $ c_RegisterClass p+foreign import stdcall unsafe "windows.h RegisterClassW"+ c_RegisterClass :: Ptr WNDCLASS -> IO ATOM++foreign import stdcall unsafe "windows.h UnregisterClassW"+ unregisterClass :: ClassName -> HINSTANCE -> IO ()++----------------------------------------------------------------+-- Window Style+----------------------------------------------------------------++type WindowStyle = DWORD++#{enum WindowStyle,+ , wS_OVERLAPPED = WS_OVERLAPPED+ , wS_POPUP = WS_POPUP+ , wS_CHILD = WS_CHILD+ , wS_CLIPSIBLINGS = WS_CLIPSIBLINGS+ , wS_CLIPCHILDREN = WS_CLIPCHILDREN+ , wS_VISIBLE = WS_VISIBLE+ , wS_DISABLED = WS_DISABLED+ , wS_MINIMIZE = WS_MINIMIZE+ , wS_MAXIMIZE = WS_MAXIMIZE+ , wS_CAPTION = WS_CAPTION+ , wS_BORDER = WS_BORDER+ , wS_DLGFRAME = WS_DLGFRAME+ , wS_VSCROLL = WS_VSCROLL+ , wS_HSCROLL = WS_HSCROLL+ , wS_SYSMENU = WS_SYSMENU+ , wS_THICKFRAME = WS_THICKFRAME+ , wS_MINIMIZEBOX = WS_MINIMIZEBOX+ , wS_MAXIMIZEBOX = WS_MAXIMIZEBOX+ , wS_GROUP = WS_GROUP+ , wS_TABSTOP = WS_TABSTOP+ , wS_OVERLAPPEDWINDOW = WS_OVERLAPPEDWINDOW+ , wS_POPUPWINDOW = WS_POPUPWINDOW+ , wS_CHILDWINDOW = WS_CHILDWINDOW+ , wS_TILED = WS_TILED+ , wS_ICONIC = WS_ICONIC+ , wS_SIZEBOX = WS_SIZEBOX+ , wS_TILEDWINDOW = WS_TILEDWINDOW+ }++type WindowStyleEx = DWORD++#{enum WindowStyleEx,+ , wS_EX_DLGMODALFRAME = WS_EX_DLGMODALFRAME+ , wS_EX_NOPARENTNOTIFY = WS_EX_NOPARENTNOTIFY+ , wS_EX_TOPMOST = WS_EX_TOPMOST+ , wS_EX_ACCEPTFILES = WS_EX_ACCEPTFILES+ , wS_EX_TRANSPARENT = WS_EX_TRANSPARENT+ , wS_EX_MDICHILD = WS_EX_MDICHILD+ , wS_EX_TOOLWINDOW = WS_EX_TOOLWINDOW+ , wS_EX_WINDOWEDGE = WS_EX_WINDOWEDGE+ , wS_EX_CLIENTEDGE = WS_EX_CLIENTEDGE+ , wS_EX_CONTEXTHELP = WS_EX_CONTEXTHELP+ , wS_EX_RIGHT = WS_EX_RIGHT+ , wS_EX_LEFT = WS_EX_LEFT+ , wS_EX_RTLREADING = WS_EX_RTLREADING+ , wS_EX_LTRREADING = WS_EX_LTRREADING+ , wS_EX_LEFTSCROLLBAR = WS_EX_LEFTSCROLLBAR+ , wS_EX_RIGHTSCROLLBAR = WS_EX_RIGHTSCROLLBAR+ , wS_EX_CONTROLPARENT = WS_EX_CONTROLPARENT+ , wS_EX_STATICEDGE = WS_EX_STATICEDGE+ , wS_EX_APPWINDOW = WS_EX_APPWINDOW+ , wS_EX_OVERLAPPEDWINDOW = WS_EX_OVERLAPPEDWINDOW+ , wS_EX_PALETTEWINDOW = WS_EX_PALETTEWINDOW+ }++cW_USEDEFAULT :: Pos+cW_USEDEFAULT = #{const CW_USEDEFAULT}++type Pos = Int++type MbPos = Maybe Pos++maybePos :: Maybe Pos -> Pos+maybePos = fromMaybe cW_USEDEFAULT++type WindowClosure = HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT++foreign import ccall "wrapper"+ mkWindowClosure :: WindowClosure -> IO (FunPtr WindowClosure)++setWindowClosure :: HWND -> WindowClosure -> IO ()+setWindowClosure wnd closure = do+ fp <- mkWindowClosure closure+ c_SetWindowLong wnd (#{const GWL_USERDATA}) (castFunPtrToLONG fp)+ return ()+foreign import stdcall unsafe "windows.h SetWindowLongW"+ c_SetWindowLong :: HWND -> INT -> LONG -> IO LONG++createWindow+ :: ClassName -> String -> WindowStyle ->+ Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos ->+ Maybe HWND -> Maybe HMENU -> HINSTANCE -> WindowClosure ->+ IO HWND+createWindow = createWindowEx 0+-- apparently CreateWindowA/W are just macros for CreateWindowExA/W++createWindowEx+ :: WindowStyle -> ClassName -> String -> WindowStyle+ -> Maybe Pos -> Maybe Pos -> Maybe Pos -> Maybe Pos+ -> Maybe HWND -> Maybe HMENU -> HINSTANCE -> WindowClosure+ -> IO HWND+createWindowEx estyle cname wname wstyle mb_x mb_y mb_w mb_h mb_parent mb_menu inst closure = do+ -- Freeing the title/window name has been reported+ -- to cause a crash, so let's not do it.+ -- withTString wname $ \ c_wname -> do+ c_wname <- newTString wname+ wnd <- failIfNull "CreateWindowEx" $+ c_CreateWindowEx estyle cname c_wname wstyle+ (maybePos mb_x) (maybePos mb_y) (maybePos mb_w) (maybePos mb_h)+ (maybePtr mb_parent) (maybePtr mb_menu) inst nullPtr+ setWindowClosure wnd closure+ return wnd+foreign import stdcall "windows.h CreateWindowExW"+ c_CreateWindowEx+ :: WindowStyle -> ClassName -> LPCTSTR -> WindowStyle+ -> Pos -> Pos -> Pos -> Pos+ -> HWND -> HMENU -> HINSTANCE -> LPVOID+ -> IO HWND++----------------------------------------------------------------++defWindowProc :: Maybe HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT+defWindowProc mb_wnd msg w l =+ c_DefWindowProc (maybePtr mb_wnd) msg w l+foreign import stdcall "windows.h DefWindowProcW"+ c_DefWindowProc :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT++----------------------------------------------------------------++getClientRect :: HWND -> IO RECT+getClientRect wnd =+ allocaRECT $ \ p_rect -> do+ failIfFalse_ "GetClientRect" $ c_GetClientRect wnd p_rect+ peekRECT p_rect+foreign import stdcall unsafe "windows.h GetClientRect"+ c_GetClientRect :: HWND -> Ptr RECT -> IO Bool++getWindowRect :: HWND -> IO RECT+getWindowRect wnd =+ allocaRECT $ \ p_rect -> do+ failIfFalse_ "GetWindowRect" $ c_GetWindowRect wnd p_rect+ peekRECT p_rect+foreign import stdcall unsafe "windows.h GetWindowRect"+ c_GetWindowRect :: HWND -> Ptr RECT -> IO Bool++-- Should it be Maybe RECT instead?++invalidateRect :: Maybe HWND -> Maybe LPRECT -> Bool -> IO ()+invalidateRect wnd p_mb_rect erase =+ failIfFalse_ "InvalidateRect" $+ c_InvalidateRect (maybePtr wnd) (maybePtr p_mb_rect) erase+foreign import stdcall "windows.h InvalidateRect"+ c_InvalidateRect :: HWND -> LPRECT -> Bool -> IO Bool++screenToClient :: HWND -> POINT -> IO POINT+screenToClient wnd pt =+ withPOINT pt $ \ p_pt -> do+ failIfFalse_ "ScreenToClient" $ c_ScreenToClient wnd p_pt+ peekPOINT p_pt+foreign import stdcall unsafe "windows.h ScreenToClient"+ c_ScreenToClient :: HWND -> Ptr POINT -> IO Bool++clientToScreen :: HWND -> POINT -> IO POINT+clientToScreen wnd pt =+ withPOINT pt $ \ p_pt -> do+ failIfFalse_ "ClientToScreen" $ c_ClientToScreen wnd p_pt+ peekPOINT p_pt+foreign import stdcall unsafe "windows.h ClientToScreen"+ c_ClientToScreen :: HWND -> Ptr POINT -> IO Bool++----------------------------------------------------------------+-- Setting window text/label+----------------------------------------------------------------+-- For setting the title bar text. But inconvenient to make the LPCTSTR++setWindowText :: HWND -> String -> IO ()+setWindowText wnd text =+ withTString text $ \ c_text ->+ failIfFalse_ "SetWindowText" $ c_SetWindowText wnd c_text+foreign import stdcall "windows.h SetWindowTextW"+ c_SetWindowText :: HWND -> LPCTSTR -> IO Bool++----------------------------------------------------------------+-- Paint struct+----------------------------------------------------------------++type PAINTSTRUCT =+ ( HDC -- hdc+ , Bool -- fErase+ , RECT -- rcPaint+ )++type LPPAINTSTRUCT = Addr++sizeofPAINTSTRUCT :: DWORD+sizeofPAINTSTRUCT = #{size PAINTSTRUCT}++allocaPAINTSTRUCT :: (LPPAINTSTRUCT -> IO a) -> IO a+allocaPAINTSTRUCT = allocaBytes #{size PAINTSTRUCT}++beginPaint :: HWND -> LPPAINTSTRUCT -> IO HDC+beginPaint wnd paint =+ failIfNull "BeginPaint" $ c_BeginPaint wnd paint+foreign import stdcall "windows.h BeginPaint"+ c_BeginPaint :: HWND -> LPPAINTSTRUCT -> IO HDC++foreign import stdcall "windows.h EndPaint"+ endPaint :: HWND -> LPPAINTSTRUCT -> IO ()+-- Apparently always succeeds (return non-zero)++----------------------------------------------------------------+-- ShowWindow+----------------------------------------------------------------++type ShowWindowControl = DWORD++#{enum ShowWindowControl,+ , sW_HIDE = SW_HIDE+ , sW_SHOWNORMAL = SW_SHOWNORMAL+ , sW_SHOWMINIMIZED = SW_SHOWMINIMIZED+ , sW_SHOWMAXIMIZED = SW_SHOWMAXIMIZED+ , sW_MAXIMIZE = SW_MAXIMIZE+ , sW_SHOWNOACTIVATE = SW_SHOWNOACTIVATE+ , sW_SHOW = SW_SHOW+ , sW_MINIMIZE = SW_MINIMIZE+ , sW_SHOWMINNOACTIVE = SW_SHOWMINNOACTIVE+ , sW_SHOWNA = SW_SHOWNA+ , sW_RESTORE = SW_RESTORE+ }++foreign import stdcall "windows.h ShowWindow"+ showWindow :: HWND -> ShowWindowControl -> IO Bool++----------------------------------------------------------------+-- Misc+----------------------------------------------------------------++adjustWindowRect :: RECT -> WindowStyle -> Bool -> IO RECT+adjustWindowRect rect style menu =+ withRECT rect $ \ p_rect -> do+ failIfFalse_ "AdjustWindowRect" $ c_AdjustWindowRect p_rect style menu+ peekRECT p_rect+foreign import stdcall unsafe "windows.h AdjustWindowRect"+ c_AdjustWindowRect :: Ptr RECT -> WindowStyle -> Bool -> IO Bool++adjustWindowRectEx :: RECT -> WindowStyle -> Bool -> WindowStyleEx -> IO RECT+adjustWindowRectEx rect style menu exstyle =+ withRECT rect $ \ p_rect -> do+ failIfFalse_ "AdjustWindowRectEx" $+ c_AdjustWindowRectEx p_rect style menu exstyle+ peekRECT p_rect+foreign import stdcall unsafe "windows.h AdjustWindowRectEx"+ c_AdjustWindowRectEx :: Ptr RECT -> WindowStyle -> Bool -> WindowStyleEx -> IO Bool++-- Win2K and later:+-- %fun AllowSetForegroundWindow :: DWORD -> IO ()++-- %+-- %dis animateWindowType x = dWORD x+-- type AnimateWindowType = DWORD++-- %const AnimateWindowType+-- [ AW_SLIDE+-- , AW_ACTIVATE+-- , AW_BLEND+-- , AW_HIDE+-- , AW_CENTER+-- , AW_HOR_POSITIVE+-- , AW_HOR_NEGATIVE+-- , AW_VER_POSITIVE+-- , AW_VER_NEGATIVE+-- ]++-- Win98 or Win2K:+-- %fun AnimateWindow :: HWND -> DWORD -> AnimateWindowType -> IO ()+-- %code BOOL success = AnimateWindow(arg1,arg2,arg3)+-- %fail { !success } { ErrorWin("AnimateWindow") }++foreign import stdcall unsafe "windows.h AnyPopup"+ anyPopup :: IO Bool++arrangeIconicWindows :: HWND -> IO ()+arrangeIconicWindows wnd =+ failIfFalse_ "ArrangeIconicWindows" $ c_ArrangeIconicWindows wnd+foreign import stdcall unsafe "windows.h ArrangeIconicWindows"+ c_ArrangeIconicWindows :: HWND -> IO Bool++beginDeferWindowPos :: Int -> IO HDWP+beginDeferWindowPos n =+ failIfNull "BeginDeferWindowPos" $ c_BeginDeferWindowPos n+foreign import stdcall unsafe "windows.h BeginDeferWindowPos"+ c_BeginDeferWindowPos :: Int -> IO HDWP++bringWindowToTop :: HWND -> IO ()+bringWindowToTop wnd =+ failIfFalse_ "BringWindowToTop" $ c_BringWindowToTop wnd+foreign import stdcall "windows.h BringWindowToTop"+ c_BringWindowToTop :: HWND -> IO Bool++-- Can't pass structs with current FFI, so use a C wrapper (in Types)+childWindowFromPoint :: HWND -> POINT -> IO (Maybe HWND)+childWindowFromPoint wnd pt =+ withPOINT pt $ \ p_pt ->+ liftM ptrToMaybe $ prim_ChildWindowFromPoint wnd p_pt++-- Can't pass structs with current FFI, so use a C wrapper (in Types)+childWindowFromPointEx :: HWND -> POINT -> DWORD -> IO (Maybe HWND)+childWindowFromPointEx parent pt flags =+ withPOINT pt $ \ p_pt ->+ liftM ptrToMaybe $ prim_ChildWindowFromPointEx parent p_pt flags++closeWindow :: HWND -> IO ()+closeWindow wnd =+ failIfFalse_ "CloseWindow" $ c_DestroyWindow wnd++deferWindowPos :: HDWP -> HWND -> HWND -> Int -> Int -> Int -> Int -> SetWindowPosFlags -> IO HDWP+deferWindowPos wp wnd after x y cx cy flags =+ failIfNull "DeferWindowPos" $ c_DeferWindowPos wp wnd after x y cx cy flags+foreign import stdcall unsafe "windows.h DeferWindowPos"+ c_DeferWindowPos :: HDWP -> HWND -> HWND -> Int -> Int -> Int -> Int -> SetWindowPosFlags -> IO HDWP++destroyWindow :: HWND -> IO ()+destroyWindow wnd =+ failIfFalse_ "DestroyWindow" $ c_DestroyWindow wnd+foreign import stdcall "windows.h DestroyWindow"+ c_DestroyWindow :: HWND -> IO Bool++endDeferWindowPos :: HDWP -> IO ()+endDeferWindowPos pos =+ failIfFalse_ "EndDeferWindowPos" $ c_EndDeferWindowPos pos+foreign import stdcall unsafe "windows.h EndDeferWindowPos"+ c_EndDeferWindowPos :: HDWP -> IO Bool++findWindow :: String -> String -> IO (Maybe HWND)+findWindow cname wname =+ withTString cname $ \ c_cname ->+ withTString wname $ \ c_wname ->+ liftM ptrToMaybe $ c_FindWindow c_cname c_wname+foreign import stdcall unsafe "windows.h FindWindowW"+ c_FindWindow :: LPCTSTR -> LPCTSTR -> IO HWND++findWindowEx :: HWND -> HWND -> String -> String -> IO (Maybe HWND)+findWindowEx parent after cname wname =+ withTString cname $ \ c_cname ->+ withTString wname $ \ c_wname ->+ liftM ptrToMaybe $ c_FindWindowEx parent after c_cname c_wname+foreign import stdcall unsafe "windows.h FindWindowExW"+ c_FindWindowEx :: HWND -> HWND -> LPCTSTR -> LPCTSTR -> IO HWND++foreign import stdcall unsafe "windows.h FlashWindow"+ flashWindow :: HWND -> Bool -> IO Bool+-- No error code++moveWindow :: HWND -> Int -> Int -> Int -> Int -> Bool -> IO ()+moveWindow wnd x y w h repaint =+ failIfFalse_ "MoveWindow" $ c_MoveWindow wnd x y w h repaint+foreign import stdcall "windows.h MoveWindow"+ c_MoveWindow :: HWND -> Int -> Int -> Int -> Int -> Bool -> IO Bool++foreign import stdcall unsafe "windows.h GetDesktopWindow"+ getDesktopWindow :: IO HWND++foreign import stdcall unsafe "windows.h GetForegroundWindow"+ getForegroundWindow :: IO HWND++getParent :: HWND -> IO HWND+getParent wnd =+ failIfNull "GetParent" $ c_GetParent wnd+foreign import stdcall unsafe "windows.h GetParent"+ c_GetParent :: HWND -> IO HWND++getTopWindow :: HWND -> IO HWND+getTopWindow wnd =+ failIfNull "GetTopWindow" $ c_GetTopWindow wnd+foreign import stdcall unsafe "windows.h GetTopWindow"+ c_GetTopWindow :: HWND -> IO HWND+++type SetWindowPosFlags = UINT++#{enum SetWindowPosFlags,+ , sWP_NOSIZE = SWP_NOSIZE+ , sWP_NOMOVE = SWP_NOMOVE+ , sWP_NOZORDER = SWP_NOZORDER+ , sWP_NOREDRAW = SWP_NOREDRAW+ , sWP_NOACTIVATE = SWP_NOACTIVATE+ , sWP_FRAMECHANGED = SWP_FRAMECHANGED+ , sWP_SHOWWINDOW = SWP_SHOWWINDOW+ , sWP_HIDEWINDOW = SWP_HIDEWINDOW+ , sWP_NOCOPYBITS = SWP_NOCOPYBITS+ , sWP_NOOWNERZORDER = SWP_NOOWNERZORDER+ , sWP_NOSENDCHANGING = SWP_NOSENDCHANGING+ , sWP_DRAWFRAME = SWP_DRAWFRAME+ , sWP_NOREPOSITION = SWP_NOREPOSITION+ }++----------------------------------------------------------------+-- HDCs+----------------------------------------------------------------++type GetDCExFlags = DWORD++#{enum GetDCExFlags,+ , dCX_WINDOW = DCX_WINDOW+ , dCX_CACHE = DCX_CACHE+ , dCX_CLIPCHILDREN = DCX_CLIPCHILDREN+ , dCX_CLIPSIBLINGS = DCX_CLIPSIBLINGS+ , dCX_PARENTCLIP = DCX_PARENTCLIP+ , dCX_EXCLUDERGN = DCX_EXCLUDERGN+ , dCX_INTERSECTRGN = DCX_INTERSECTRGN+ , dCX_LOCKWINDOWUPDATE = DCX_LOCKWINDOWUPDATE+ }++-- apparently mostly fails if you use invalid hwnds++getDCEx :: HWND -> HRGN -> GetDCExFlags -> IO HDC+getDCEx wnd rgn flags =+ withForeignPtr rgn $ \ p_rgn ->+ failIfNull "GetDCEx" $ c_GetDCEx wnd p_rgn flags+foreign import stdcall unsafe "windows.h GetDCEx"+ c_GetDCEx :: HWND -> PRGN -> GetDCExFlags -> IO HDC++getDC :: Maybe HWND -> IO HDC+getDC mb_wnd =+ failIfNull "GetDC" $ c_GetDC (maybePtr mb_wnd)+foreign import stdcall unsafe "windows.h GetDC"+ c_GetDC :: HWND -> IO HDC++getWindowDC :: Maybe HWND -> IO HDC+getWindowDC mb_wnd =+ failIfNull "GetWindowDC" $ c_GetWindowDC (maybePtr mb_wnd)+foreign import stdcall unsafe "windows.h GetWindowDC"+ c_GetWindowDC :: HWND -> IO HDC++releaseDC :: Maybe HWND -> HDC -> IO ()+releaseDC mb_wnd dc =+ failIfFalse_ "ReleaseDC" $ c_ReleaseDC (maybePtr mb_wnd) dc+foreign import stdcall unsafe "windows.h ReleaseDC"+ c_ReleaseDC :: HWND -> HDC -> IO Bool++getDCOrgEx :: HDC -> IO POINT+getDCOrgEx dc =+ allocaPOINT $ \ p_pt -> do+ failIfFalse_ "GetDCOrgEx" $ c_GetDCOrgEx dc p_pt+ peekPOINT p_pt+foreign import stdcall unsafe "windows.h GetDCOrgEx"+ c_GetDCOrgEx :: HDC -> Ptr POINT -> IO Bool++----------------------------------------------------------------+-- Caret+----------------------------------------------------------------++hideCaret :: HWND -> IO ()+hideCaret wnd =+ failIfFalse_ "HideCaret" $ c_HideCaret wnd+foreign import stdcall unsafe "windows.h HideCaret"+ c_HideCaret :: HWND -> IO Bool++showCaret :: HWND -> IO ()+showCaret wnd =+ failIfFalse_ "ShowCaret" $ c_ShowCaret wnd+foreign import stdcall unsafe "windows.h ShowCaret"+ c_ShowCaret :: HWND -> IO Bool++-- ToDo: allow arg2 to be NULL or {(HBITMAP)1}++createCaret :: HWND -> HBITMAP -> Maybe INT -> Maybe INT -> IO ()+createCaret wnd bm mb_w mb_h =+ failIfFalse_ "CreateCaret" $+ c_CreateCaret wnd bm (maybeNum mb_w) (maybeNum mb_h)+foreign import stdcall unsafe "windows.h CreateCaret"+ c_CreateCaret :: HWND -> HBITMAP -> INT -> INT -> IO Bool++destroyCaret :: IO ()+destroyCaret =+ failIfFalse_ "DestroyCaret" $ c_DestroyCaret+foreign import stdcall unsafe "windows.h DestroyCaret"+ c_DestroyCaret :: IO Bool++getCaretPos :: IO POINT+getCaretPos =+ allocaPOINT $ \ p_pt -> do+ failIfFalse_ "GetCaretPos" $ c_GetCaretPos p_pt+ peekPOINT p_pt+foreign import stdcall unsafe "windows.h GetCaretPos"+ c_GetCaretPos :: Ptr POINT -> IO Bool++setCaretPos :: POINT -> IO ()+setCaretPos (x,y) =+ failIfFalse_ "SetCaretPos" $ c_SetCaretPos x y+foreign import stdcall unsafe "windows.h SetCaretPos"+ c_SetCaretPos :: LONG -> LONG -> IO Bool++-- The remarks on SetCaretBlinkTime are either highly risible or very sad -+-- depending on whether you plan to use this function.++----------------------------------------------------------------+-- MSGs and event loops+--+-- Note that the following functions have to be reentrant:+--+-- DispatchMessage+-- SendMessage+-- UpdateWindow (I think)+-- RedrawWindow (I think)+--+-- The following dont have to be reentrant (according to documentation)+--+-- GetMessage+-- PeekMessage+-- TranslateMessage+--+-- For Hugs (and possibly NHC too?) this is no big deal.+-- For GHC, you have to use casm_GC instead of casm.+-- (It might be simpler to just put all this code in another+-- file and build it with the appropriate command line option...)+----------------------------------------------------------------++-- type MSG =+-- ( HWND -- hwnd;+-- , UINT -- message;+-- , WPARAM -- wParam;+-- , LPARAM -- lParam;+-- , DWORD -- time;+-- , POINT -- pt;+-- )++type LPMSG = Addr++allocaMessage :: (LPMSG -> IO a) -> IO a+allocaMessage = allocaBytes #{size MSG}++-- A NULL window requests messages for any window belonging to this thread.+-- a "success" value of 0 indicates that WM_QUIT was received++getMessage :: LPMSG -> Maybe HWND -> IO Bool+getMessage msg mb_wnd = do+ res <- failIf (== -1) "GetMessage" $+ c_GetMessage msg (maybePtr mb_wnd) 0 0+ return (res /= 0)+foreign import stdcall "windows.h GetMessageW"+ c_GetMessage :: LPMSG -> HWND -> UINT -> UINT -> IO LONG++-- A NULL window requests messages for any window belonging to this thread.+-- Arguably the code block shouldn't be a 'safe' one, but it shouldn't really+-- hurt.++peekMessage :: LPMSG -> Maybe HWND -> UINT -> UINT -> UINT -> IO ()+peekMessage msg mb_wnd filterMin filterMax remove = do+ failIf (== -1) "PeekMessage" $+ c_PeekMessage msg (maybePtr mb_wnd) filterMin filterMax remove+ return ()+foreign import stdcall "windows.h PeekMessageW"+ c_PeekMessage :: LPMSG -> HWND -> UINT -> UINT -> UINT -> IO LONG++-- Note: you're not supposed to call this if you're using accelerators++foreign import stdcall "windows.h TranslateMessage"+ translateMessage :: LPMSG -> IO BOOL++updateWindow :: HWND -> IO ()+updateWindow wnd =+ failIfFalse_ "UpdateWindow" $ c_UpdateWindow wnd+foreign import stdcall "windows.h UpdateWindow"+ c_UpdateWindow :: HWND -> IO Bool++-- Return value of DispatchMessage is usually ignored++foreign import stdcall "windows.h DispatchMessageW"+ dispatchMessage :: LPMSG -> IO LONG++foreign import stdcall "windows.h SendMessageW"+ sendMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT++----------------------------------------------------------------++-- ToDo: figure out reentrancy stuff+-- ToDo: catch error codes+--+-- ToDo: how to send HWND_BROADCAST to PostMessage+-- %fun PostMessage :: MbHWND -> WindowMessage -> WPARAM -> LPARAM -> IO ()+-- %fun PostQuitMessage :: Int -> IO ()+-- %fun PostThreadMessage :: DWORD -> WindowMessage -> WPARAM -> LPARAM -> IO ()+-- %fun InSendMessage :: IO Bool++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 1997-2003, Alastair Reid+Copyright (c) 2006, Esa Ilari Vuokko+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither names of the copyright holders nor the names of the contributors+may be used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Win32.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32+-- Copyright : (c) Alastair Reid, 1999-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- An FFI binding to the system part of the Win32 API.+--+-----------------------------------------------------------------------------++module System.Win32+ ( module System.Win32.DLL+ , module System.Win32.File+ , module System.Win32.FileMapping+ , module System.Win32.Info+ , module System.Win32.Mem+ , module System.Win32.NLS+ , module System.Win32.Process+ , module System.Win32.Registry+ , module System.Win32.Time+ , module System.Win32.Console+ , module System.Win32.Types+ ) where++import System.Win32.DLL+import System.Win32.File+import System.Win32.FileMapping+import System.Win32.Info+import System.Win32.Mem+import System.Win32.NLS hiding ( LCID, LANGID, SortID, SubLANGID+ , PrimaryLANGID, mAKELCID, lANGIDFROMLCID+ , sORTIDFROMLCID, mAKELANGID, pRIMARYLANGID+ , sUBLANGID )+import System.Win32.Process+import System.Win32.Registry+import System.Win32.Time+import System.Win32.Console+import System.Win32.Types++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ System/Win32/Console.hsc view
@@ -0,0 +1,55 @@+----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Console +-- Copyright : (c) University of Glasgow 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info> +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32 Console API +-- +----------------------------------------------------------------------------- + +module System.Win32.Console ( + -- * Console code pages + getConsoleCP, + setConsoleCP, + getConsoleOutputCP, + setConsoleOutputCP, + -- * Ctrl events + CtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT, + generateConsoleCtrlEvent + ) where + +import System.Win32.Types + +foreign import stdcall unsafe "windows.h GetConsoleCP" + getConsoleCP :: IO UINT + +foreign import stdcall unsafe "windows.h SetConsoleCP" + setConsoleCP :: UINT -> IO () + +foreign import stdcall unsafe "windows.h GetConsoleOutputCP" + getConsoleOutputCP :: IO UINT + +foreign import stdcall unsafe "windows.h SetConsoleOutputCP" + setConsoleOutputCP :: UINT -> IO () + +type CtrlEvent = DWORD +#{enum CtrlEvent, + , cTRL_C_EVENT = 0 + , cTRL_BREAK_EVENT = 1 + } + +generateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO () +generateConsoleCtrlEvent e p + = failIfFalse_ + "generateConsoleCtrlEvent" + $ c_GenerateConsoleCtrlEvent e p + +foreign import stdcall safe "windows.h GenerateConsoleCtrlEvent" + c_GenerateConsoleCtrlEvent :: CtrlEvent -> DWORD -> IO BOOL + +-- ToDo: lots more
+ System/Win32/DLL.hsc view
@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.DLL+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.DLL where++import System.Win32.Types++import Foreign+import Foreign.C++#include <windows.h>++disableThreadLibraryCalls :: HMODULE -> IO ()+disableThreadLibraryCalls hmod =+ failIfFalse_ "DisableThreadLibraryCalls" $ c_DisableThreadLibraryCalls hmod+foreign import stdcall unsafe "windows.h DisableThreadLibraryCalls"+ c_DisableThreadLibraryCalls :: HMODULE -> IO Bool++freeLibrary :: HMODULE -> IO ()+freeLibrary hmod =+ failIfFalse_ "FreeLibrary" $ c_FreeLibrary hmod+foreign import stdcall unsafe "windows.h FreeLibrary"+ c_FreeLibrary :: HMODULE -> IO Bool++{-# CFILES cbits/HsWin32.c #-}+foreign import ccall "HsWin32.h &FreeLibraryFinaliser"+ c_FreeLibraryFinaliser :: FunPtr (HMODULE -> IO ())++getModuleFileName :: HMODULE -> IO String+getModuleFileName hmod =+ allocaArray 512 $ \ c_str -> do+ failIfFalse_ "GetModuleFileName" $ c_GetModuleFileName hmod c_str 512+ peekTString c_str+foreign import stdcall unsafe "windows.h GetModuleFileNameW"+ c_GetModuleFileName :: HMODULE -> LPTSTR -> Int -> IO Bool++getModuleHandle :: Maybe String -> IO HMODULE+getModuleHandle mb_name =+ maybeWith withTString mb_name $ \ c_name ->+ failIfNull "GetModuleHandle" $ c_GetModuleHandle c_name+foreign import stdcall unsafe "windows.h GetModuleHandleW"+ c_GetModuleHandle :: LPCTSTR -> IO HMODULE++getProcAddress :: HMODULE -> String -> IO Addr+getProcAddress hmod procname =+ withCString procname $ \ c_procname ->+ failIfNull "GetProcAddress" $ c_GetProcAddress hmod c_procname+foreign import stdcall unsafe "windows.h GetProcAddress"+ c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr++loadLibrary :: String -> IO HINSTANCE+loadLibrary name =+ withTString name $ \ c_name ->+ failIfNull "LoadLibrary" $ c_LoadLibrary c_name+foreign import stdcall unsafe "windows.h LoadLibraryW"+ c_LoadLibrary :: LPCTSTR -> IO HINSTANCE++type LoadLibraryFlags = DWORD++#{enum LoadLibraryFlags,+ , lOAD_LIBRARY_AS_DATAFILE = LOAD_LIBRARY_AS_DATAFILE+ , lOAD_WITH_ALTERED_SEARCH_PATH = LOAD_WITH_ALTERED_SEARCH_PATH+ }++loadLibraryEx :: String -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE+loadLibraryEx name h flags =+ withTString name $ \ c_name ->+ failIfNull "LoadLibraryEx" $ c_LoadLibraryEx c_name h flags+foreign import stdcall unsafe "windows.h LoadLibraryExW"+ c_LoadLibraryEx :: LPCTSTR -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE
+ System/Win32/DebugApi.hsc view
@@ -0,0 +1,387 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.DebugApi+-- Copyright : (c) Esa Ilari Vuokko, 2006+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for using Windows DebugApi.+--+-----------------------------------------------------------------------------+module System.Win32.DebugApi where++import Control.Exception( bracket_ )+import Data.Word ( Word8, Word32 )+import Foreign ( Ptr, nullPtr, ForeignPtr, mallocForeignPtrBytes+ , peekByteOff, plusPtr, allocaBytes, castPtr, poke+ , withForeignPtr, Storable, sizeOf, peek, pokeByteOff )+import System.IO ( fixIO )+import System.Win32.Types ( HANDLE, BOOL, WORD, DWORD, failIf_, failWith+ , getLastError, failIf, LPTSTR, withTString )++#include "windows.h"++type PID = DWORD+type TID = DWORD+type DebugEventId = (PID, TID)+type ForeignAddress = Word32++type PHANDLE = Ptr ()+type THANDLE = Ptr ()++type ThreadInfo = (THANDLE, ForeignAddress, ForeignAddress) -- handle to thread, thread local, thread start+type ImageInfo = (HANDLE, ForeignAddress, DWORD, DWORD, ForeignAddress)+type ExceptionInfo = (Bool, Bool, ForeignAddress) -- First chance, continuable, address+++data Exception+ = UnknownException+ | AccessViolation Bool ForeignAddress+ | ArrayBoundsExceeded+ | Breakpoint+ | DataTypeMisalignment+ | FltDenormalOperand+ | FltDivideByZero+ | FltInexactResult+ | FltInvalidOperation+ | FltOverflow+ | FltStackCheck+ | FltUnderflow+ | IllegalInstruction+ | InPageError+ | IntDivideByZero+ | IntOverflow+ | InvalidDisposition+ | NonContinuable+ | PrivilegedInstruction+ | SingleStep+ | StackOverflow+ deriving (Show)+ +data DebugEventInfo+ = UnknownDebugEvent+ | Exception ExceptionInfo Exception+ | CreateThread ThreadInfo+ | CreateProcess PHANDLE ImageInfo ThreadInfo+ | ExitThread TID+ | ExitProcess PID+ | LoadDll ImageInfo+ | UnloadDll TID+ | DebugString ForeignAddress Bool WORD+ deriving (Show)++type DebugEvent = (DebugEventId, DebugEventInfo)++--------------------------------------------------------------------------+-- Handling debugevents++peekDebugEvent :: Ptr a -> IO DebugEvent+peekDebugEvent p = do+ code <- (#peek DEBUG_EVENT, dwDebugEventCode) p+ pid <- (#peek DEBUG_EVENT, dwProcessId) p+ tid <- (#peek DEBUG_EVENT, dwThreadId) p+ r <- rest (code::DWORD) (plusPtr p (#offset DEBUG_EVENT, u))+ return ((pid,tid), r)+ where+ dwZero = 0 :: DWORD+ wZero = 0 :: WORD+ + rest (#const EXCEPTION_DEBUG_EVENT) p = do+ chance <- (#peek EXCEPTION_DEBUG_INFO, dwFirstChance) p+ flags <- (#peek EXCEPTION_RECORD, ExceptionFlags) p+ addr <- (#peek EXCEPTION_RECORD, ExceptionAddress) p+ code <- (#peek EXCEPTION_RECORD, ExceptionCode) p+ e <- case code::DWORD of+ (#const EXCEPTION_ACCESS_VIOLATION) -> return $ AccessViolation False 0+ (#const EXCEPTION_ARRAY_BOUNDS_EXCEEDED) -> return ArrayBoundsExceeded+ (#const EXCEPTION_BREAKPOINT) -> return Breakpoint+ (#const EXCEPTION_DATATYPE_MISALIGNMENT) -> return DataTypeMisalignment+ (#const EXCEPTION_FLT_DENORMAL_OPERAND) -> return FltDenormalOperand+ (#const EXCEPTION_FLT_DIVIDE_BY_ZERO) -> return FltDivideByZero+ (#const EXCEPTION_FLT_INEXACT_RESULT) -> return FltInexactResult+ (#const EXCEPTION_FLT_INVALID_OPERATION) -> return FltInvalidOperation+ (#const EXCEPTION_FLT_OVERFLOW) -> return FltOverflow+ (#const EXCEPTION_FLT_STACK_CHECK) -> return FltStackCheck+ (#const EXCEPTION_FLT_UNDERFLOW) -> return FltUnderflow+ (#const EXCEPTION_ILLEGAL_INSTRUCTION) -> return IllegalInstruction+ (#const EXCEPTION_IN_PAGE_ERROR) -> return InPageError+ (#const EXCEPTION_INT_DIVIDE_BY_ZERO) -> return IntDivideByZero+ (#const EXCEPTION_INT_OVERFLOW) -> return IntOverflow+ (#const EXCEPTION_INVALID_DISPOSITION) -> return InvalidDisposition+ (#const EXCEPTION_NONCONTINUABLE_EXCEPTION) -> return NonContinuable+ (#const EXCEPTION_PRIV_INSTRUCTION) -> return PrivilegedInstruction+ (#const EXCEPTION_SINGLE_STEP) -> return SingleStep+ (#const EXCEPTION_STACK_OVERFLOW) -> return StackOverflow+ _ -> return UnknownException + return $ Exception (chance/=dwZero, flags==dwZero, addr) e++ rest (#const CREATE_THREAD_DEBUG_EVENT) p = do+ handle <- (#peek CREATE_THREAD_DEBUG_INFO, hThread) p+ local <- (#peek CREATE_THREAD_DEBUG_INFO, lpThreadLocalBase) p+ start <- (#peek CREATE_THREAD_DEBUG_INFO, lpStartAddress) p+ return $ CreateThread (handle, local, start)++ rest (#const CREATE_PROCESS_DEBUG_EVENT) p = do+ file <- (#peek CREATE_PROCESS_DEBUG_INFO, hFile) p+ proc <- (#peek CREATE_PROCESS_DEBUG_INFO, hProcess) p+ thread <- (#peek CREATE_PROCESS_DEBUG_INFO, hThread) p+ imgbase <- (#peek CREATE_PROCESS_DEBUG_INFO, lpBaseOfImage) p+ dbgoff <- (#peek CREATE_PROCESS_DEBUG_INFO, dwDebugInfoFileOffset) p+ dbgsize <- (#peek CREATE_PROCESS_DEBUG_INFO, nDebugInfoSize) p+ local <- (#peek CREATE_PROCESS_DEBUG_INFO, lpThreadLocalBase) p+ start <- (#peek CREATE_PROCESS_DEBUG_INFO, lpStartAddress) p+ imgname <- (#peek CREATE_PROCESS_DEBUG_INFO, lpImageName) p+ --unicode <- (#peek CREATE_PROCESS_DEBUG_INFO, fUnicode) p+ return $ CreateProcess proc + (file, imgbase, dbgoff, dbgsize, imgname) --, unicode/=wZero)+ (thread, local, start)+ + rest (#const EXIT_THREAD_DEBUG_EVENT) p =+ (#peek EXIT_THREAD_DEBUG_INFO, dwExitCode) p >>= return.ExitThread+ + rest (#const EXIT_PROCESS_DEBUG_EVENT) p =+ (#peek EXIT_PROCESS_DEBUG_INFO, dwExitCode) p >>= return.ExitProcess+ + rest (#const LOAD_DLL_DEBUG_EVENT) p = do+ file <- (#peek LOAD_DLL_DEBUG_INFO, hFile) p+ imgbase <- (#peek LOAD_DLL_DEBUG_INFO, lpBaseOfDll) p+ dbgoff <- (#peek LOAD_DLL_DEBUG_INFO, dwDebugInfoFileOffset) p+ dbgsize <- (#peek LOAD_DLL_DEBUG_INFO, nDebugInfoSize) p+ imgname <- (#peek LOAD_DLL_DEBUG_INFO, lpImageName) p+ --unicode <- (#peek LOAD_DLL_DEBUG_INFO, fUnicode) p+ return $ + LoadDll (file, imgbase, dbgoff, dbgsize, imgname)--, unicode/=wZero)++ rest (#const OUTPUT_DEBUG_STRING_EVENT) p = do+ dat <- (#peek OUTPUT_DEBUG_STRING_INFO, lpDebugStringData) p+ unicode <- (#peek OUTPUT_DEBUG_STRING_INFO, fUnicode) p+ length <- (#peek OUTPUT_DEBUG_STRING_INFO, nDebugStringLength) p+ return $ DebugString dat (unicode/=wZero) length+ + rest (#const UNLOAD_DLL_DEBUG_EVENT) p =+ (#peek UNLOAD_DLL_DEBUG_INFO, lpBaseOfDll) p >>= return.UnloadDll++ rest _ _ = return UnknownDebugEvent++++waitForDebugEvent :: Maybe Int -> IO (Maybe DebugEvent)+waitForDebugEvent timeout = allocaBytes (#size DEBUG_EVENT) $ \buf -> do+ res <- c_WaitForDebugEvent buf $ maybe (#const INFINITE) fromIntegral timeout+ if res+ then peekDebugEvent buf >>= return.Just+ else getLastError >>= \e -> case e of+ (#const ERROR_INVALID_HANDLE) -> return Nothing+ (#const ERROR_SEM_TIMEOUT) -> return Nothing+ _ -> die e+ where+ die res = failWith "WaitForDebugEvent" res++getDebugEvents :: Int -> IO [DebugEvent]+getDebugEvents timeout = waitForDebugEvent (Just timeout) >>= getMore+ where+ getMore e = case e of+ Nothing -> return []+ Just e -> do+ rest <- waitForDebugEvent (Just 0) >>= getMore+ return $ e:rest++continueDebugEvent :: DebugEventId -> Bool -> IO ()+continueDebugEvent (pid,tid) cont =+ failIf_ not "ContinueDebugEvent" $ c_ContinueDebugEvent pid tid cont'+ where+ cont' = if cont+ then (#const DBG_CONTINUE)+ else (#const DBG_EXCEPTION_NOT_HANDLED)++--------------------------------------------------------------------------+-- Process control++debugActiveProcess :: PID -> IO ()+debugActiveProcess pid =+ failIf_ not "debugActiveProcess: DebugActiveProcess" $+ c_DebugActiveProcess pid++-- Windows XP+-- debugActiveProcessStop :: PID -> IO ()+-- debugActiveProcessStop pid =+-- failIf_ not "debugActiveProcessStop: DebugActiveProcessStop" $+-- c_DebugActiveProcessStop pid++--------------------------------------------------------------------------+-- Process memory++peekProcessMemory :: PHANDLE -> ForeignAddress -> Int -> Ptr a -> IO ()+peekProcessMemory proc addr size buf =+ failIf_ not "peekProcessMemory: ReadProcessMemory" $+ c_ReadProcessMemory proc (plusPtr nullPtr $ fromIntegral addr) (castPtr buf) (fromIntegral size) nullPtr++readProcessMemory :: PHANDLE -> ForeignAddress -> Int -> IO (ForeignPtr a)+readProcessMemory proc addr size = do+ res <- mallocForeignPtrBytes size+ withForeignPtr res $ peekProcessMemory proc addr size+ return res++pokeProcessMemory :: PHANDLE -> ForeignAddress -> Int -> Ptr a -> IO ()+pokeProcessMemory proc addr size buf =+ failIf_ not "pokeProcessMemory: WriteProcessMemory" $+ c_WriteProcessMemory proc (plusPtr nullPtr $ fromIntegral addr) (castPtr buf) (fromIntegral size) nullPtr++withProcessMemory :: PHANDLE -> ForeignAddress -> Int -> (Ptr a -> IO b) -> IO b+withProcessMemory proc addr size act = allocaBytes size $ \buf -> do+ peekProcessMemory proc addr size buf+ res <- act buf+ pokeProcessMemory proc addr size buf+ return res++peekP :: (Storable a) => PHANDLE -> ForeignAddress -> IO a+peekP proc addr = fixIO $ \res -> withProcessMemory proc addr (sizeOf res) peek++pokeP :: (Storable a) => PHANDLE -> ForeignAddress -> a -> IO ()+pokeP proc addr v = withProcessMemory proc addr (sizeOf v) $ \buf -> poke buf v++--------------------------------------------------------------------------+-- Thread Control++suspendThread :: THANDLE -> IO DWORD+suspendThread t =+ failIf (==0-1) "SuspendThread" $ c_SuspendThread t++resumeThread :: THANDLE -> IO DWORD+resumeThread t =+ failIf (==0-1) "ResumeThread" $ c_ResumeThread t++withSuspendedThread :: THANDLE -> IO a -> IO a+withSuspendedThread t = bracket_ (suspendThread t) (resumeThread t)++--getThreadId :: THANDLE -> IO TID+--getThreadId = failIf (==0) "GetThreadId" . c_GetThreadId++--------------------------------------------------------------------------+-- Thread register control+getThreadContext :: THANDLE -> Ptr a -> IO ()+getThreadContext t buf =+ failIf_ not "GetThreadContext" $ c_GetThreadContext t (castPtr buf)++setThreadContext :: THANDLE -> Ptr a -> IO ()+setThreadContext t buf =+ failIf_ not "SetThreadContext" $ c_SetThreadContext t (castPtr buf)++useAllRegs :: Ptr a -> IO ()+useAllRegs buf = (#poke CONTEXT, ContextFlags) buf v+ where+ v = (#const CONTEXT_FULL|CONTEXT_DEBUG_REGISTERS|CONTEXT_FLOATING_POINT) :: DWORD++withThreadContext :: THANDLE -> (Ptr a -> IO b) -> IO b+withThreadContext t act =+ allocaBytes (#size CONTEXT)+ $ \buf -> bracket_+ (useAllRegs buf >> getThreadContext t buf)+ (useAllRegs buf >> setThreadContext t buf)+ (act buf)+++eax, ebx, ecx, edx :: Int+esi, edi :: Int+ebp, eip, esp :: Int+segCs, segDs, segEs, segFs, segGs :: Int+eFlags :: Int++eax = (#offset CONTEXT, Eax)+ebx = (#offset CONTEXT, Ebx)+ecx = (#offset CONTEXT, Ecx)+edx = (#offset CONTEXT, Edx)+esi = (#offset CONTEXT, Esi)+edi = (#offset CONTEXT, Edi)+ebp = (#offset CONTEXT, Ebp)+eip = (#offset CONTEXT, Eip)+esp = (#offset CONTEXT, Esp)+segCs = (#offset CONTEXT, SegCs)+segDs = (#offset CONTEXT, SegDs)+segEs = (#offset CONTEXT, SegEs)+segFs = (#offset CONTEXT, SegFs)+segGs = (#offset CONTEXT, SegGs)+eFlags = (#offset CONTEXT, EFlags)++dr :: Int -> Int+dr n = case n of+ 0 -> (#offset CONTEXT, Dr0)+ 1 -> (#offset CONTEXT, Dr1)+ 2 -> (#offset CONTEXT, Dr2)+ 3 -> (#offset CONTEXT, Dr3)+ 6 -> (#offset CONTEXT, Dr6)+ 7 -> (#offset CONTEXT, Dr7)+ _ -> undefined+ +setReg :: Ptr a -> Int -> DWORD -> IO ()+setReg = pokeByteOff++getReg :: Ptr a -> Int -> IO DWORD+getReg = peekByteOff++modReg :: Ptr a -> Int -> (DWORD->DWORD) -> IO DWORD+modReg buf r f = do+ old <- getReg buf r+ setReg buf r (f old)+ return old++makeModThreadContext :: [(Int, DWORD->DWORD)] -> Ptr a -> IO [DWORD]+makeModThreadContext act buf = mapM (uncurry $ modReg buf) act++modifyThreadContext :: THANDLE -> [(Int, DWORD->DWORD)] -> IO [DWORD]+modifyThreadContext t a = withThreadContext t $ makeModThreadContext a++--------------------------------------------------------------------------+-- On process being debugged++outputDebugString :: String -> IO ()+outputDebugString s = withTString s $ \s -> c_OutputDebugString s++--------------------------------------------------------------------------+-- Raw imports++foreign import stdcall "windows.h SuspendThread"+ c_SuspendThread :: THANDLE -> IO DWORD++foreign import stdcall "windows.h ResumeThread"+ c_ResumeThread :: THANDLE -> IO DWORD++foreign import stdcall "windows.h WaitForDebugEvent"+ c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL++foreign import stdcall "windows.h ContinueDebugEvent"+ c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL++foreign import stdcall "windows.h DebugActiveProcess"+ c_DebugActiveProcess :: DWORD -> IO Bool+ +-- Windows XP+-- foreign import stdcall "windows.h DebugActiveProcessStop"+-- c_DebugActiveProcessStop :: DWORD -> IO Bool++foreign import stdcall "windows.h ReadProcessMemory" c_ReadProcessMemory :: + PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL++foreign import stdcall "windows.h WriteProcessMemory" c_WriteProcessMemory ::+ PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL++foreign import stdcall "windows.h GetThreadContext"+ c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL++foreign import stdcall "windows.h SetThreadContext"+ c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL++--foreign import stdcall "windows.h GetThreadId"+-- c_GetThreadId :: THANDLE -> IO TID++foreign import stdcall "windows.h OutputDebugStringW"+ c_OutputDebugString :: LPTSTR -> IO ()++foreign import stdcall "windows.h IsDebuggerPresent"+ isDebuggerPresent :: IO BOOL++foreign import stdcall "windows.h DebugBreak"+ debugBreak :: IO ()
+ System/Win32/File.hsc view
@@ -0,0 +1,514 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.File+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.File+{-+ ( AccessMode, ShareMode, CreateMode, FileAttributeOrFlag+ , CreateFile, CloseHandle, DeleteFile, CopyFile+ , MoveFileFlag, MoveFile, MoveFileEx,+ )+-}+where++import System.Win32.Types+import System.Win32.Time++import Foreign++#include <windows.h>++----------------------------------------------------------------+-- Enumeration types+----------------------------------------------------------------++type AccessMode = UINT++gENERIC_NONE :: AccessMode+gENERIC_NONE = 0++#{enum AccessMode,+ , gENERIC_READ = GENERIC_READ+ , gENERIC_WRITE = GENERIC_WRITE+ , gENERIC_EXECUTE = GENERIC_EXECUTE+ , gENERIC_ALL = GENERIC_ALL+ , dELETE = DELETE+ , rEAD_CONTROL = READ_CONTROL+ , wRITE_DAC = WRITE_DAC+ , wRITE_OWNER = WRITE_OWNER+ , sYNCHRONIZE = SYNCHRONIZE+ , sTANDARD_RIGHTS_REQUIRED = STANDARD_RIGHTS_REQUIRED+ , sTANDARD_RIGHTS_READ = STANDARD_RIGHTS_READ+ , sTANDARD_RIGHTS_WRITE = STANDARD_RIGHTS_WRITE+ , sTANDARD_RIGHTS_EXECUTE = STANDARD_RIGHTS_EXECUTE+ , sTANDARD_RIGHTS_ALL = STANDARD_RIGHTS_ALL+ , sPECIFIC_RIGHTS_ALL = SPECIFIC_RIGHTS_ALL+ , aCCESS_SYSTEM_SECURITY = ACCESS_SYSTEM_SECURITY+ , mAXIMUM_ALLOWED = MAXIMUM_ALLOWED+ }++----------------------------------------------------------------++type ShareMode = UINT++fILE_SHARE_NONE :: ShareMode+fILE_SHARE_NONE = 0++#{enum ShareMode,+ , fILE_SHARE_READ = FILE_SHARE_READ+ , fILE_SHARE_WRITE = FILE_SHARE_WRITE+ }++----------------------------------------------------------------++type CreateMode = UINT++#{enum CreateMode,+ , cREATE_NEW = CREATE_NEW+ , cREATE_ALWAYS = CREATE_ALWAYS+ , oPEN_EXISTING = OPEN_EXISTING+ , oPEN_ALWAYS = OPEN_ALWAYS+ , tRUNCATE_EXISTING = TRUNCATE_EXISTING+ }++----------------------------------------------------------------++type FileAttributeOrFlag = UINT++#{enum FileAttributeOrFlag,+ , fILE_ATTRIBUTE_READONLY = FILE_ATTRIBUTE_READONLY+ , fILE_ATTRIBUTE_HIDDEN = FILE_ATTRIBUTE_HIDDEN+ , fILE_ATTRIBUTE_SYSTEM = FILE_ATTRIBUTE_SYSTEM+ , fILE_ATTRIBUTE_DIRECTORY = FILE_ATTRIBUTE_DIRECTORY+ , fILE_ATTRIBUTE_ARCHIVE = FILE_ATTRIBUTE_ARCHIVE+ , fILE_ATTRIBUTE_NORMAL = FILE_ATTRIBUTE_NORMAL+ , fILE_ATTRIBUTE_TEMPORARY = FILE_ATTRIBUTE_TEMPORARY+ , fILE_ATTRIBUTE_COMPRESSED = FILE_ATTRIBUTE_COMPRESSED+ , fILE_FLAG_WRITE_THROUGH = FILE_FLAG_WRITE_THROUGH+ , fILE_FLAG_OVERLAPPED = FILE_FLAG_OVERLAPPED+ , fILE_FLAG_NO_BUFFERING = FILE_FLAG_NO_BUFFERING+ , fILE_FLAG_RANDOM_ACCESS = FILE_FLAG_RANDOM_ACCESS+ , fILE_FLAG_SEQUENTIAL_SCAN = FILE_FLAG_SEQUENTIAL_SCAN+ , fILE_FLAG_DELETE_ON_CLOSE = FILE_FLAG_DELETE_ON_CLOSE+ , fILE_FLAG_BACKUP_SEMANTICS = FILE_FLAG_BACKUP_SEMANTICS+ , fILE_FLAG_POSIX_SEMANTICS = FILE_FLAG_POSIX_SEMANTICS+ }+#ifndef __WINE_WINDOWS_H+#{enum FileAttributeOrFlag,+ , sECURITY_ANONYMOUS = SECURITY_ANONYMOUS+ , sECURITY_IDENTIFICATION = SECURITY_IDENTIFICATION+ , sECURITY_IMPERSONATION = SECURITY_IMPERSONATION+ , sECURITY_DELEGATION = SECURITY_DELEGATION+ , sECURITY_CONTEXT_TRACKING = SECURITY_CONTEXT_TRACKING+ , sECURITY_EFFECTIVE_ONLY = SECURITY_EFFECTIVE_ONLY+ , sECURITY_SQOS_PRESENT = SECURITY_SQOS_PRESENT+ , sECURITY_VALID_SQOS_FLAGS = SECURITY_VALID_SQOS_FLAGS+ }+#endif++----------------------------------------------------------------++type MoveFileFlag = DWORD++#{enum MoveFileFlag,+ , mOVEFILE_REPLACE_EXISTING = MOVEFILE_REPLACE_EXISTING+ , mOVEFILE_COPY_ALLOWED = MOVEFILE_COPY_ALLOWED+ , mOVEFILE_DELAY_UNTIL_REBOOT = MOVEFILE_DELAY_UNTIL_REBOOT+ }++----------------------------------------------------------------++type FilePtrDirection = DWORD++#{enum FilePtrDirection,+ , fILE_BEGIN = FILE_BEGIN+ , fILE_CURRENT = FILE_CURRENT+ , fILE_END = FILE_END+ }++----------------------------------------------------------------++type DriveType = UINT++#{enum DriveType,+ , dRIVE_UNKNOWN = DRIVE_UNKNOWN+ , dRIVE_NO_ROOT_DIR = DRIVE_NO_ROOT_DIR+ , dRIVE_REMOVABLE = DRIVE_REMOVABLE+ , dRIVE_FIXED = DRIVE_FIXED+ , dRIVE_REMOTE = DRIVE_REMOTE+ , dRIVE_CDROM = DRIVE_CDROM+ , dRIVE_RAMDISK = DRIVE_RAMDISK+ }++----------------------------------------------------------------++type DefineDosDeviceFlags = DWORD++#{enum DefineDosDeviceFlags,+ , dDD_RAW_TARGET_PATH = DDD_RAW_TARGET_PATH+ , dDD_REMOVE_DEFINITION = DDD_REMOVE_DEFINITION+ , dDD_EXACT_MATCH_ON_REMOVE = DDD_EXACT_MATCH_ON_REMOVE+ }++----------------------------------------------------------------++type BinaryType = DWORD++#{enum BinaryType,+ , sCS_32BIT_BINARY = SCS_32BIT_BINARY+ , sCS_DOS_BINARY = SCS_DOS_BINARY+ , sCS_WOW_BINARY = SCS_WOW_BINARY+ , sCS_PIF_BINARY = SCS_PIF_BINARY+ , sCS_POSIX_BINARY = SCS_POSIX_BINARY+ , sCS_OS216_BINARY = SCS_OS216_BINARY+ }++----------------------------------------------------------------++type FileNotificationFlag = DWORD++#{enum FileNotificationFlag,+ , fILE_NOTIFY_CHANGE_FILE_NAME = FILE_NOTIFY_CHANGE_FILE_NAME+ , fILE_NOTIFY_CHANGE_DIR_NAME = FILE_NOTIFY_CHANGE_DIR_NAME+ , fILE_NOTIFY_CHANGE_ATTRIBUTES = FILE_NOTIFY_CHANGE_ATTRIBUTES+ , fILE_NOTIFY_CHANGE_SIZE = FILE_NOTIFY_CHANGE_SIZE+ , fILE_NOTIFY_CHANGE_LAST_WRITE = FILE_NOTIFY_CHANGE_LAST_WRITE+ , fILE_NOTIFY_CHANGE_SECURITY = FILE_NOTIFY_CHANGE_SECURITY+ }++----------------------------------------------------------------++type FileType = DWORD++#{enum FileType,+ , fILE_TYPE_UNKNOWN = FILE_TYPE_UNKNOWN+ , fILE_TYPE_DISK = FILE_TYPE_DISK+ , fILE_TYPE_CHAR = FILE_TYPE_CHAR+ , fILE_TYPE_PIPE = FILE_TYPE_PIPE+ , fILE_TYPE_REMOTE = FILE_TYPE_REMOTE+ }++----------------------------------------------------------------++type LPSECURITY_ATTRIBUTES = Ptr ()+type MbLPSECURITY_ATTRIBUTES = Maybe LPSECURITY_ATTRIBUTES++----------------------------------------------------------------+-- Other types+----------------------------------------------------------------++data BY_HANDLE_FILE_INFORMATION = BY_HANDLE_FILE_INFORMATION+ { bhfiFileAttributes :: FileAttributeOrFlag+ , bhfiCreationTime, bhfiLastAccessTime, bhfiLastWriteTime :: FILETIME+ , bhfiVolumeSerialNumber :: DWORD+ , bhfiSize :: DDWORD+ , bhfiNumberOfLinks :: DWORD+ , bhfiFileIndex :: DDWORD+ } deriving (Show)++instance Storable BY_HANDLE_FILE_INFORMATION where+ sizeOf = const (#size BY_HANDLE_FILE_INFORMATION)+ alignment = sizeOf+ poke buf bhi = do+ (#poke BY_HANDLE_FILE_INFORMATION, dwFileAttributes) buf (bhfiFileAttributes bhi)+ (#poke BY_HANDLE_FILE_INFORMATION, ftCreationTime) buf (bhfiCreationTime bhi)+ (#poke BY_HANDLE_FILE_INFORMATION, ftLastAccessTime) buf (bhfiLastAccessTime bhi)+ (#poke BY_HANDLE_FILE_INFORMATION, ftLastWriteTime) buf (bhfiLastWriteTime bhi)+ (#poke BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf (bhfiVolumeSerialNumber bhi)+ (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeHigh) buf sizeHi+ (#poke BY_HANDLE_FILE_INFORMATION, nFileSizeLow) buf sizeLow+ (#poke BY_HANDLE_FILE_INFORMATION, nNumberOfLinks) buf (bhfiNumberOfLinks bhi)+ (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexHigh) buf idxHi+ (#poke BY_HANDLE_FILE_INFORMATION, nFileIndexLow) buf idxLow+ where+ (sizeHi,sizeLow) = ddwordToDwords $ bhfiSize bhi+ (idxHi,idxLow) = ddwordToDwords $ bhfiFileIndex bhi++ peek buf = do+ attr <- (#peek BY_HANDLE_FILE_INFORMATION, dwFileAttributes) buf+ ctim <- (#peek BY_HANDLE_FILE_INFORMATION, ftCreationTime) buf+ lati <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastAccessTime) buf+ lwti <- (#peek BY_HANDLE_FILE_INFORMATION, ftLastWriteTime) buf+ vser <- (#peek BY_HANDLE_FILE_INFORMATION, dwVolumeSerialNumber) buf+ fshi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeHigh) buf+ fslo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileSizeLow) buf+ link <- (#peek BY_HANDLE_FILE_INFORMATION, nNumberOfLinks) buf+ idhi <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexHigh) buf+ idlo <- (#peek BY_HANDLE_FILE_INFORMATION, nFileIndexLow) buf+ return $ BY_HANDLE_FILE_INFORMATION attr ctim lati lwti vser+ (dwordsToDdword (fshi,fslo)) link (dwordsToDdword (idhi,idlo))++----------------------------------------------------------------+-- File operations+----------------------------------------------------------------++deleteFile :: String -> IO ()+deleteFile name =+ withTString name $ \ c_name ->+ failIfFalse_ "DeleteFile" $ c_DeleteFile c_name+foreign import stdcall unsafe "windows.h DeleteFileW"+ c_DeleteFile :: LPCTSTR -> IO Bool++copyFile :: String -> String -> Bool -> IO ()+copyFile src dest over =+ withTString src $ \ c_src ->+ withTString dest $ \ c_dest ->+ failIfFalse_ "CopyFile" $ c_CopyFile c_src c_dest over+foreign import stdcall unsafe "windows.h CopyFileW"+ c_CopyFile :: LPCTSTR -> LPCTSTR -> Bool -> IO Bool++moveFile :: String -> String -> IO ()+moveFile src dest =+ withTString src $ \ c_src ->+ withTString dest $ \ c_dest ->+ failIfFalse_ "MoveFile" $ c_MoveFile c_src c_dest+foreign import stdcall unsafe "windows.h MoveFileW"+ c_MoveFile :: LPCTSTR -> LPCTSTR -> IO Bool++moveFileEx :: String -> String -> MoveFileFlag -> IO ()+moveFileEx src dest flags =+ withTString src $ \ c_src ->+ withTString dest $ \ c_dest ->+ failIfFalse_ "MoveFileEx" $ c_MoveFileEx c_src c_dest flags+foreign import stdcall unsafe "windows.h MoveFileExW"+ c_MoveFileEx :: LPCTSTR -> LPCTSTR -> MoveFileFlag -> IO Bool++setCurrentDirectory :: String -> IO ()+setCurrentDirectory name =+ withTString name $ \ c_name ->+ failIfFalse_ "SetCurrentDirectory" $ c_SetCurrentDirectory c_name+foreign import stdcall unsafe "windows.h SetCurrentDirectoryW"+ c_SetCurrentDirectory :: LPCTSTR -> IO Bool++createDirectory :: String -> Maybe LPSECURITY_ATTRIBUTES -> IO ()+createDirectory name mb_attr =+ withTString name $ \ c_name ->+ failIfFalse_ "CreateDirectory" $ c_CreateDirectory c_name (maybePtr mb_attr)+foreign import stdcall unsafe "windows.h CreateDirectoryW"+ c_CreateDirectory :: LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool++createDirectoryEx :: String -> String -> Maybe LPSECURITY_ATTRIBUTES -> IO ()+createDirectoryEx template name mb_attr =+ withTString template $ \ c_template ->+ withTString name $ \ c_name ->+ failIfFalse_ "CreateDirectoryEx" $+ c_CreateDirectoryEx c_template c_name (maybePtr mb_attr)+foreign import stdcall unsafe "windows.h CreateDirectoryExW"+ c_CreateDirectoryEx :: LPCTSTR -> LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool++removeDirectory :: String -> IO ()+removeDirectory name =+ withTString name $ \ c_name ->+ failIfFalse_ "RemoveDirectory" $ c_RemoveDirectory c_name+foreign import stdcall unsafe "windows.h RemoveDirectoryW"+ c_RemoveDirectory :: LPCTSTR -> IO Bool++getBinaryType :: String -> IO BinaryType+getBinaryType name =+ withTString name $ \ c_name ->+ alloca $ \ p_btype -> do+ failIfFalse_ "GetBinaryType" $ c_GetBinaryType c_name p_btype+ peek p_btype+foreign import stdcall unsafe "windows.h GetBinaryTypeW"+ c_GetBinaryType :: LPCTSTR -> Ptr DWORD -> IO Bool++----------------------------------------------------------------+-- HANDLE operations+----------------------------------------------------------------++createFile :: String -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE+createFile name access share mb_attr mode flag mb_h =+ withTString name $ \ c_name ->+ failIf (==iNVALID_HANDLE_VALUE) "CreateFile" $+ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h)+foreign import stdcall unsafe "windows.h CreateFileW"+ c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE++closeHandle :: HANDLE -> IO ()+closeHandle h =+ failIfFalse_ "CloseHandle" $ c_CloseHandle h+foreign import stdcall unsafe "windows.h CloseHandle"+ c_CloseHandle :: HANDLE -> IO Bool++{-# CFILES cbits/HsWin32.c #-}+foreign import ccall "HsWin32.h &CloseHandleFinaliser"+ c_CloseHandleFinaliser :: FunPtr (Ptr a -> IO ())++foreign import stdcall unsafe "windows.h GetFileType"+ getFileType :: HANDLE -> IO FileType+--Apparently no error code++flushFileBuffers :: HANDLE -> IO ()+flushFileBuffers h =+ failIfFalse_ "FlushFileBuffers" $ c_FlushFileBuffers h+foreign import stdcall unsafe "windows.h FlushFileBuffers"+ c_FlushFileBuffers :: HANDLE -> IO Bool++setEndOfFile :: HANDLE -> IO ()+setEndOfFile h =+ failIfFalse_ "SetEndOfFile" $ c_SetEndOfFile h+foreign import stdcall unsafe "windows.h SetEndOfFile"+ c_SetEndOfFile :: HANDLE -> IO Bool++setFileAttributes :: String -> FileAttributeOrFlag -> IO ()+setFileAttributes name attr =+ withTString name $ \ c_name ->+ failIfFalse_ "SetFileAttributes" $ c_SetFileAttributes c_name attr+foreign import stdcall unsafe "windows.h SetFileAttributesW"+ c_SetFileAttributes :: LPCTSTR -> FileAttributeOrFlag -> IO Bool++getFileAttributes :: String -> IO FileAttributeOrFlag+getFileAttributes name =+ withTString name $ \ c_name ->+ failIf (== 0xFFFFFFFF) "GetFileAttributes" $ c_GetFileAttributes c_name+foreign import stdcall unsafe "windows.h GetFileAttributesW"+ c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag++getFileInformationByHandle :: HANDLE -> IO BY_HANDLE_FILE_INFORMATION+getFileInformationByHandle h = alloca $ \res -> do+ failIfFalse_ "GetFileInformationByHandle" $ c_GetFileInformationByHandle h res+ peek res+foreign import stdcall unsafe "windows.h GetFileInformationByHandle"+ c_GetFileInformationByHandle :: HANDLE -> Ptr BY_HANDLE_FILE_INFORMATION -> IO BOOL++----------------------------------------------------------------+-- Read/write files+----------------------------------------------------------------++-- No support for this yet+--type OVERLAPPED =+-- (DWORD, -- Offset+-- DWORD, -- OffsetHigh+-- HANDLE) -- hEvent++type LPOVERLAPPED = Ptr ()++type MbLPOVERLAPPED = Maybe LPOVERLAPPED++--Sigh - I give up & prefix win32_ to the next two to avoid+-- senseless Prelude name clashes. --sof.++win32_ReadFile :: HANDLE -> Ptr a -> DWORD -> Maybe LPOVERLAPPED -> IO DWORD+win32_ReadFile h buf n mb_over =+ alloca $ \ p_n -> do+ failIfFalse_ "ReadFile" $ c_ReadFile h buf n p_n (maybePtr mb_over)+ peek p_n+foreign import stdcall unsafe "windows.h ReadFile"+ c_ReadFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool++win32_WriteFile :: HANDLE -> Ptr a -> DWORD -> Maybe LPOVERLAPPED -> IO DWORD+win32_WriteFile h buf n mb_over =+ alloca $ \ p_n -> do+ failIfFalse_ "WriteFile" $ c_WriteFile h buf n p_n (maybePtr mb_over)+ peek p_n+foreign import stdcall unsafe "windows.h WriteFile"+ c_WriteFile :: HANDLE -> Ptr a -> DWORD -> Ptr DWORD -> LPOVERLAPPED -> IO Bool++-- missing Seek functioinality; GSL ???+-- Dont have Word64; ADR+-- %fun SetFilePointer :: HANDLE -> Word64 -> FilePtrDirection -> IO Word64++----------------------------------------------------------------+-- File Notifications+--+-- Use these to initialise, "increment" and close a HANDLE you can wait+-- on.+----------------------------------------------------------------++findFirstChangeNotification :: String -> Bool -> FileNotificationFlag -> IO HANDLE+findFirstChangeNotification path watch flag =+ withTString path $ \ c_path ->+ failIfNull "FindFirstChangeNotification" $+ c_FindFirstChangeNotification c_path watch flag+foreign import stdcall unsafe "windows.h FindFirstChangeNotificationW"+ c_FindFirstChangeNotification :: LPCTSTR -> Bool -> FileNotificationFlag -> IO HANDLE++findNextChangeNotification :: HANDLE -> IO ()+findNextChangeNotification h =+ failIfFalse_ "FindNextChangeNotification" $ c_FindNextChangeNotification h+foreign import stdcall unsafe "windows.h FindNextChangeNotification"+ c_FindNextChangeNotification :: HANDLE -> IO Bool++findCloseChangeNotification :: HANDLE -> IO ()+findCloseChangeNotification h =+ failIfFalse_ "FindCloseChangeNotification" $ c_FindCloseChangeNotification h+foreign import stdcall unsafe "windows.h FindCloseChangeNotification"+ c_FindCloseChangeNotification :: HANDLE -> IO Bool++----------------------------------------------------------------+-- DOS Device flags+----------------------------------------------------------------++defineDosDevice :: DefineDosDeviceFlags -> String -> String -> IO ()+defineDosDevice flags name path =+ withTString path $ \ c_path ->+ withTString name $ \ c_name ->+ failIfFalse_ "DefineDosDevice" $ c_DefineDosDevice flags c_name c_path+foreign import stdcall unsafe "windows.h DefineDosDeviceW"+ c_DefineDosDevice :: DefineDosDeviceFlags -> LPCTSTR -> LPCTSTR -> IO Bool++----------------------------------------------------------------++-- These functions are very unusual in the Win32 API:+-- They dont return error codes++foreign import stdcall unsafe "windows.h AreFileApisANSI"+ areFileApisANSI :: IO Bool++foreign import stdcall unsafe "windows.h SetFileApisToOEM"+ setFileApisToOEM :: IO ()++foreign import stdcall unsafe "windows.h SetFileApisToANSI"+ setFileApisToANSI :: IO ()++foreign import stdcall unsafe "windows.h SetHandleCount"+ setHandleCount :: UINT -> IO UINT++----------------------------------------------------------------++getLogicalDrives :: IO DWORD+getLogicalDrives =+ failIfZero "GetLogicalDrives" $ c_GetLogicalDrives+foreign import stdcall unsafe "windows.h GetLogicalDrives"+ c_GetLogicalDrives :: IO DWORD++-- %fun GetDriveType :: Maybe String -> IO DriveType++getDiskFreeSpace :: Maybe String -> IO (DWORD,DWORD,DWORD,DWORD)+getDiskFreeSpace path =+ maybeWith withTString path $ \ c_path ->+ alloca $ \ p_sectors ->+ alloca $ \ p_bytes ->+ alloca $ \ p_nfree ->+ alloca $ \ p_nclusters -> do+ failIfFalse_ "GetDiskFreeSpace" $+ c_GetDiskFreeSpace c_path p_sectors p_bytes p_nfree p_nclusters+ sectors <- peek p_sectors+ bytes <- peek p_bytes+ nfree <- peek p_nfree+ nclusters <- peek p_nclusters+ return (sectors, bytes, nfree, nclusters)+foreign import stdcall unsafe "windows.h GetDiskFreeSpaceW"+ c_GetDiskFreeSpace :: LPCTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> IO Bool++setVolumeLabel :: String -> String -> IO ()+setVolumeLabel path name =+ withTString path $ \ c_path ->+ withTString name $ \ c_name ->+ failIfFalse_ "SetVolumeLabel" $ c_SetVolumeLabel c_path c_name+foreign import stdcall unsafe "windows.h SetVolumeLabelW"+ c_SetVolumeLabel :: LPCTSTR -> LPCTSTR -> IO Bool++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ System/Win32/FileMapping.hsc view
@@ -0,0 +1,168 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.FileMapping+-- Copyright : (c) Esa Ilari Vuokko, 2006+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32 mapped files.+--+-----------------------------------------------------------------------------+module System.Win32.FileMapping where++import System.Win32.Types ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR, withTString+ , failIf, failIfNull, DDWORD, ddwordToDwords+ , iNVALID_HANDLE_VALUE )+import System.Win32.Mem+import System.Win32.File+import System.Win32.Info++import Control.Exception ( block, bracket )+import Data.ByteString.Base ( ByteString(..) )+import Foreign ( Ptr, nullPtr, plusPtr, maybeWith, FunPtr+ , ForeignPtr, newForeignPtr )++#include "windows.h"++---------------------------------------------------------------------------+-- Derived functions+---------------------------------------------------------------------------++-- | Maps file fully and returns ForeignPtr and length of the mapped area.+-- The mapped file is opened read-only and shared reading.+mapFile :: FilePath -> IO (ForeignPtr a, Int)+mapFile path = do+ bracket+ (createFile path gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing)+ (closeHandle)+ $ \fh -> bracket+ (createFileMapping (Just fh) pAGE_READONLY 0 Nothing)+ (closeHandle)+ $ \fm -> do+ fi <- getFileInformationByHandle fh+ fp <- block $ do+ ptr <- mapViewOfFile fm fILE_MAP_READ 0 0+ newForeignPtr c_UnmapViewOfFileFinaliser ptr+ return (fp, fromIntegral $ bhfiSize fi)++-- | As mapFile, but returns ByteString+mapFileBs :: FilePath -> IO ByteString+mapFileBs p = do+ (fp,i) <- mapFile p+ return $ PS fp 0 i++data MappedObject = MappedObject HANDLE HANDLE FileMapAccess++-- | Opens an existing file and creates mapping object to it.+withMappedFile+ :: FilePath -- ^ Path+ -> Bool -- ^ Write? (False = read-only)+ -> Maybe Bool -- ^ Sharing mode, no sharing, share read, share read+write+ -> (Integer -> MappedObject -> IO a) -- ^ Action+ -> IO a+withMappedFile path write share act =+ bracket+ (createFile path access share' Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing)+ (closeHandle)+ $ \fh -> bracket+ (createFileMapping (Just fh) page 0 Nothing)+ (closeHandle)+ $ \fm -> do+ bhfi <- getFileInformationByHandle fh+ act (fromIntegral $ bhfiSize bhfi) (MappedObject fh fm mapaccess)+ where+ access = if write then gENERIC_READ+gENERIC_WRITE else gENERIC_READ+ page = if write then pAGE_READWRITE else pAGE_READONLY+ mapaccess = if write then fILE_MAP_ALL_ACCESS else fILE_MAP_READ+ share' = case share of+ Nothing -> fILE_SHARE_NONE+ Just False -> fILE_SHARE_READ+ Just True -> fILE_SHARE_READ + fILE_SHARE_WRITE++-- | Maps area into memory.+withMappedArea+ :: MappedObject -- ^ Mapped object, from withMappedFile+ -> Integer -- ^ Position in file+ -> Int -- ^ Size of mapped area+ -> (Ptr a -> IO b) -- ^ Action+ -> IO b+withMappedArea (MappedObject _ mh access) pos size act = do+ si <- getSystemInfo+ let gran = fromIntegral $ siAllocationGranularity si+ (blocks, offset) = divMod pos gran+ start = blocks*gran+ size' = fromIntegral $ size + fromIntegral (pos - start)+ bracket+ (mapViewOfFileEx mh access (fromIntegral start) size' nullPtr)+ (unmapViewOfFile)+ (act . flip plusPtr (fromIntegral offset))++---------------------------------------------------------------------------+-- Enums+---------------------------------------------------------------------------+type ProtectSectionFlags = DWORD+#{enum ProtectSectionFlags,+ , sEC_COMMIT = SEC_COMMIT+ , sEC_IMAGE = SEC_IMAGE+ , sEC_NOCACHE = SEC_NOCACHE+ , sEC_RESERVE = SEC_RESERVE+ }+type FileMapAccess = DWORD+#{enum FileMapAccess,+ , fILE_MAP_ALL_ACCESS = FILE_MAP_ALL_ACCESS+ , fILE_MAP_COPY = FILE_MAP_COPY+ , fILE_MAP_READ = FILE_MAP_READ+ , fILE_MAP_WRITE = FILE_MAP_WRITE+ }++---------------------------------------------------------------------------+-- API in Haskell+---------------------------------------------------------------------------+createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> IO HANDLE+createFileMapping mh flags mosize name =+ maybeWith withTString name $ \name ->+ failIf (==nullPtr) "createFileMapping: CreateFileMapping" $ c_CreateFileMapping handle nullPtr flags moshi moslow name+ where+ (moshi,moslow) = ddwordToDwords mosize+ handle = maybe iNVALID_HANDLE_VALUE id mh++openFileMapping :: FileMapAccess -> BOOL -> Maybe String -> IO HANDLE+openFileMapping access inherit name =+ maybeWith withTString name $ \name ->+ failIf (==nullPtr) "openFileMapping: OpenFileMapping" $+ c_OpenFileMapping access inherit name++mapViewOfFileEx :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> Ptr a -> IO (Ptr b)+mapViewOfFileEx h access offset size base = + failIfNull "mapViewOfFile(Ex): c_MapViewOfFileEx" $+ c_MapViewOfFileEx h access ohi olow size base+ where+ (ohi,olow) = ddwordToDwords offset++mapViewOfFile :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> IO (Ptr a)+mapViewOfFile h a o s = mapViewOfFileEx h a o s nullPtr++unmapViewOfFile :: Ptr a -> IO ()+unmapViewOfFile v = c_UnmapViewOfFile v >> return ()++---------------------------------------------------------------------------+-- Imports+---------------------------------------------------------------------------+foreign import stdcall "windows.h OpenFileMappingW"+ c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE++foreign import stdcall "windows.h CreateFileMappingW"+ c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE ++foreign import stdcall "windows.h MapViewOfFileEx"+ c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b)++foreign import stdcall "windows.h UnmapViewOfFile"+ c_UnmapViewOfFile :: Ptr a -> IO BOOL++{-# CFILES cbits/HsWin32.c #-}+foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser"+ c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ())
+ System/Win32/Info.hsc view
@@ -0,0 +1,342 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.Info+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.Info where++import System.Win32.Types++import Foreign ( Storable(sizeOf, alignment, peekByteOff, pokeByteOff,+ peek, poke)+ , Ptr, alloca, allocaArray )++#include <windows.h>++----------------------------------------------------------------+-- Environment Strings+----------------------------------------------------------------++-- %fun ExpandEnvironmentStrings :: String -> IO String++----------------------------------------------------------------+-- Computer Name+----------------------------------------------------------------++-- %fun GetComputerName :: IO String+-- %fun SetComputerName :: String -> IO ()+-- %end free(arg1)++----------------------------------------------------------------+-- Hardware Profiles+----------------------------------------------------------------++-- %fun GetCurrentHwProfile :: IO HW_PROFILE_INFO++----------------------------------------------------------------+-- Keyboard Type+----------------------------------------------------------------++-- %fun GetKeyboardType :: KeyboardTypeKind -> IO KeyboardType++----------------------------------------------------------------+-- System Color+----------------------------------------------------------------++type SystemColor = UINT++-- ToDo: This list is out of date.++#{enum SystemColor,+ , cOLOR_SCROLLBAR = COLOR_SCROLLBAR+ , cOLOR_BACKGROUND = COLOR_BACKGROUND+ , cOLOR_ACTIVECAPTION = COLOR_ACTIVECAPTION+ , cOLOR_INACTIVECAPTION = COLOR_INACTIVECAPTION+ , cOLOR_MENU = COLOR_MENU+ , cOLOR_WINDOW = COLOR_WINDOW+ , cOLOR_WINDOWFRAME = COLOR_WINDOWFRAME+ , cOLOR_MENUTEXT = COLOR_MENUTEXT+ , cOLOR_WINDOWTEXT = COLOR_WINDOWTEXT+ , cOLOR_CAPTIONTEXT = COLOR_CAPTIONTEXT+ , cOLOR_ACTIVEBORDER = COLOR_ACTIVEBORDER+ , cOLOR_INACTIVEBORDER = COLOR_INACTIVEBORDER+ , cOLOR_APPWORKSPACE = COLOR_APPWORKSPACE+ , cOLOR_HIGHLIGHT = COLOR_HIGHLIGHT+ , cOLOR_HIGHLIGHTTEXT = COLOR_HIGHLIGHTTEXT+ , cOLOR_BTNFACE = COLOR_BTNFACE+ , cOLOR_BTNSHADOW = COLOR_BTNSHADOW+ , cOLOR_GRAYTEXT = COLOR_GRAYTEXT+ , cOLOR_BTNTEXT = COLOR_BTNTEXT+ , cOLOR_INACTIVECAPTIONTEXT = COLOR_INACTIVECAPTIONTEXT+ , cOLOR_BTNHIGHLIGHT = COLOR_BTNHIGHLIGHT+ }++-- %fun GetSysColor :: SystemColor -> IO COLORREF+-- %fun SetSysColors :: [(SystemColor,COLORREF)] -> IO ()++----------------------------------------------------------------+-- Standard Directories+----------------------------------------------------------------++getSystemDirectory :: IO String+getSystemDirectory = try "GetSystemDirectory" c_getSystemDirectory 512++getWindowsDirectory :: IO String+getWindowsDirectory = try "GetWindowsDirectory" c_getWindowsDirectory 512++try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String+try loc f n = do+ e <- allocaArray (fromIntegral n) $ \lptstr -> do+ r <- failIfZero loc $ f lptstr n+ if (r > n) then return (Left r) else do+ str <- peekTStringLen (lptstr, fromIntegral r)+ return (Right str)+ case e of+ Left n -> try loc f n + Right str -> return str++foreign import ccall unsafe "GetWindowsDirectoryW"+ c_getWindowsDirectory :: LPTSTR -> UINT -> IO UINT++foreign import ccall unsafe "GetSystemDirectoryW"+ c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT++----------------------------------------------------------------+-- System Info (Info about processor and memory subsystem)+----------------------------------------------------------------++data ProcessorArchitecture = PaUnknown WORD | PaIntel | PaMips | PaAlpha | PaPpc | PaIa64 | PaIa32OnIa64 | PaAmd64+ deriving (Show,Eq)++instance Storable ProcessorArchitecture where+ sizeOf _ = sizeOf (undefined::WORD)+ alignment _ = alignment (undefined::WORD)+ poke buf pa = pokeByteOff buf 0 $ case pa of+ PaUnknown w -> w+ PaIntel -> #const PROCESSOR_ARCHITECTURE_INTEL+ PaMips -> #const PROCESSOR_ARCHITECTURE_MIPS+ PaAlpha -> #const PROCESSOR_ARCHITECTURE_ALPHA+ PaPpc -> #const PROCESSOR_ARCHITECTURE_PPC+ PaIa64 -> #const PROCESSOR_ARCHITECTURE_IA64+#ifndef __WINE_WINDOWS_H+ PaIa32OnIa64 -> #const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64+#endif+ PaAmd64 -> #const PROCESSOR_ARCHITECTURE_AMD64+ peek buf = do+ v <- (peekByteOff buf 0:: IO WORD)+ return $ case v of+ (#const PROCESSOR_ARCHITECTURE_INTEL) -> PaIntel+ (#const PROCESSOR_ARCHITECTURE_MIPS) -> PaMips+ (#const PROCESSOR_ARCHITECTURE_ALPHA) -> PaAlpha+ (#const PROCESSOR_ARCHITECTURE_PPC) -> PaPpc+ (#const PROCESSOR_ARCHITECTURE_IA64) -> PaIa64+#ifndef __WINE_WINDOWS_H+ (#const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64) -> PaIa32OnIa64+#endif+ (#const PROCESSOR_ARCHITECTURE_AMD64) -> PaAmd64+ w -> PaUnknown w++data SYSTEM_INFO = SYSTEM_INFO+ { siProcessorArchitecture :: ProcessorArchitecture+ , siPageSize :: DWORD+ , siMinimumApplicationAddress, siMaximumApplicationAddress :: LPVOID+ , siActiveProcessorMask :: DWORD+ , siNumberOfProcessors :: DWORD+ , siProcessorType :: DWORD+ , siAllocationGranularity :: DWORD+ , siProcessorLevel :: WORD+ , siProcessorRevision :: WORD+ } deriving (Show)++instance Storable SYSTEM_INFO where+ sizeOf = const #size SYSTEM_INFO+ alignment = sizeOf+ poke buf si = do+ (#poke SYSTEM_INFO, wProcessorArchitecture) buf (siProcessorArchitecture si)+ (#poke SYSTEM_INFO, dwPageSize) buf (siPageSize si)+ (#poke SYSTEM_INFO, lpMinimumApplicationAddress) buf (siMinimumApplicationAddress si)+ (#poke SYSTEM_INFO, lpMaximumApplicationAddress) buf (siMaximumApplicationAddress si)+ (#poke SYSTEM_INFO, dwActiveProcessorMask) buf (siActiveProcessorMask si)+ (#poke SYSTEM_INFO, dwNumberOfProcessors) buf (siNumberOfProcessors si)+ (#poke SYSTEM_INFO, dwProcessorType) buf (siProcessorType si)+ (#poke SYSTEM_INFO, dwAllocationGranularity) buf (siAllocationGranularity si)+ (#poke SYSTEM_INFO, wProcessorLevel) buf (siProcessorLevel si)+ (#poke SYSTEM_INFO, wProcessorRevision) buf (siProcessorRevision si)++ peek buf = do+ processorArchitecture <-+ (#peek SYSTEM_INFO, wProcessorArchitecture) buf+ pageSize <- (#peek SYSTEM_INFO, dwPageSize) buf+ minimumApplicationAddress <-+ (#peek SYSTEM_INFO, lpMinimumApplicationAddress) buf+ maximumApplicationAddress <-+ (#peek SYSTEM_INFO, lpMaximumApplicationAddress) buf+ activeProcessorMask <- (#peek SYSTEM_INFO, dwActiveProcessorMask) buf+ numberOfProcessors <- (#peek SYSTEM_INFO, dwNumberOfProcessors) buf+ processorType <- (#peek SYSTEM_INFO, dwProcessorType) buf+ allocationGranularity <-+ (#peek SYSTEM_INFO, dwAllocationGranularity) buf+ processorLevel <- (#peek SYSTEM_INFO, wProcessorLevel) buf+ processorRevision <- (#peek SYSTEM_INFO, wProcessorRevision) buf+ return $ SYSTEM_INFO {+ siProcessorArchitecture = processorArchitecture,+ siPageSize = pageSize,+ siMinimumApplicationAddress = minimumApplicationAddress,+ siMaximumApplicationAddress = maximumApplicationAddress,+ siActiveProcessorMask = activeProcessorMask,+ siNumberOfProcessors = numberOfProcessors,+ siProcessorType = processorType,+ siAllocationGranularity = allocationGranularity,+ siProcessorLevel = processorLevel,+ siProcessorRevision = processorRevision+ }++foreign import stdcall unsafe "windows.h GetSystemInfo"+ c_GetSystemInfo :: Ptr SYSTEM_INFO -> IO ()++getSystemInfo :: IO SYSTEM_INFO+getSystemInfo = alloca $ \ret -> do+ c_GetSystemInfo ret+ peek ret++----------------------------------------------------------------+-- System metrics+----------------------------------------------------------------++type SMSetting = UINT++#{enum SMSetting,+ , sM_ARRANGE = SM_ARRANGE+ , sM_CLEANBOOT = SM_CLEANBOOT+ , sM_CMETRICS = SM_CMETRICS+ , sM_CMOUSEBUTTONS = SM_CMOUSEBUTTONS+ , sM_CXBORDER = SM_CXBORDER+ , sM_CYBORDER = SM_CYBORDER+ , sM_CXCURSOR = SM_CXCURSOR+ , sM_CYCURSOR = SM_CYCURSOR+ , sM_CXDLGFRAME = SM_CXDLGFRAME+ , sM_CYDLGFRAME = SM_CYDLGFRAME+ , sM_CXDOUBLECLK = SM_CXDOUBLECLK+ , sM_CYDOUBLECLK = SM_CYDOUBLECLK+ , sM_CXDRAG = SM_CXDRAG+ , sM_CYDRAG = SM_CYDRAG+ , sM_CXEDGE = SM_CXEDGE+ , sM_CYEDGE = SM_CYEDGE+ , sM_CXFRAME = SM_CXFRAME+ , sM_CYFRAME = SM_CYFRAME+ , sM_CXFULLSCREEN = SM_CXFULLSCREEN+ , sM_CYFULLSCREEN = SM_CYFULLSCREEN+ , sM_CXHSCROLL = SM_CXHSCROLL+ , sM_CYVSCROLL = SM_CYVSCROLL+ , sM_CXICON = SM_CXICON+ , sM_CYICON = SM_CYICON+ , sM_CXICONSPACING = SM_CXICONSPACING+ , sM_CYICONSPACING = SM_CYICONSPACING+ , sM_CXMAXIMIZED = SM_CXMAXIMIZED+ , sM_CYMAXIMIZED = SM_CYMAXIMIZED+ , sM_CXMENUCHECK = SM_CXMENUCHECK+ , sM_CYMENUCHECK = SM_CYMENUCHECK+ , sM_CXMENUSIZE = SM_CXMENUSIZE+ , sM_CYMENUSIZE = SM_CYMENUSIZE+ , sM_CXMIN = SM_CXMIN+ , sM_CYMIN = SM_CYMIN+ , sM_CXMINIMIZED = SM_CXMINIMIZED+ , sM_CYMINIMIZED = SM_CYMINIMIZED+ , sM_CXMINTRACK = SM_CXMINTRACK+ , sM_CYMINTRACK = SM_CYMINTRACK+ , sM_CXSCREEN = SM_CXSCREEN+ , sM_CYSCREEN = SM_CYSCREEN+ , sM_CXSIZE = SM_CXSIZE+ , sM_CYSIZE = SM_CYSIZE+ , sM_CXSIZEFRAME = SM_CXSIZEFRAME+ , sM_CYSIZEFRAME = SM_CYSIZEFRAME+ , sM_CXSMICON = SM_CXSMICON+ , sM_CYSMICON = SM_CYSMICON+ , sM_CXSMSIZE = SM_CXSMSIZE+ , sM_CYSMSIZE = SM_CYSMSIZE+ , sM_CXVSCROLL = SM_CXVSCROLL+ , sM_CYHSCROLL = SM_CYHSCROLL+ , sM_CYVTHUMB = SM_CYVTHUMB+ , sM_CYCAPTION = SM_CYCAPTION+ , sM_CYKANJIWINDOW = SM_CYKANJIWINDOW+ , sM_CYMENU = SM_CYMENU+ , sM_CYSMCAPTION = SM_CYSMCAPTION+ , sM_DBCSENABLED = SM_DBCSENABLED+ , sM_DEBUG = SM_DEBUG+ , sM_MENUDROPALIGNMENT = SM_MENUDROPALIGNMENT+ , sM_MIDEASTENABLED = SM_MIDEASTENABLED+ , sM_MOUSEPRESENT = SM_MOUSEPRESENT+ , sM_NETWORK = SM_NETWORK+ , sM_PENWINDOWS = SM_PENWINDOWS+ , sM_SECURE = SM_SECURE+ , sM_SHOWSOUNDS = SM_SHOWSOUNDS+ , sM_SLOWMACHINE = SM_SLOWMACHINE+ , sM_SWAPBUTTON = SM_SWAPBUTTON+ }++-- %fun GetSystemMetrics :: SMSetting -> IO Int++----------------------------------------------------------------+-- Thread Desktops+----------------------------------------------------------------++-- %fun GetThreadDesktop :: ThreadId -> IO HDESK+-- %fun SetThreadDesktop :: ThreadId -> HDESK -> IO ()++----------------------------------------------------------------+-- User name+----------------------------------------------------------------++-- %fun GetUserName :: IO String++----------------------------------------------------------------+-- Version Info+----------------------------------------------------------------++-- %fun GetVersionEx :: IO VersionInfo+--+-- typedef struct _OSVERSIONINFO{+-- DWORD dwOSVersionInfoSize;+-- DWORD dwMajorVersion;+-- DWORD dwMinorVersion;+-- DWORD dwBuildNumber;+-- DWORD dwPlatformId;+-- TCHAR szCSDVersion[ 128 ];+-- } OSVERSIONINFO;++----------------------------------------------------------------+-- Processor features+----------------------------------------------------------------++--+-- Including these lines causes problems on Win95+-- %fun IsProcessorFeaturePresent :: ProcessorFeature -> Bool+--+-- type ProcessorFeature = DWORD+-- %dis processorFeature x = dWORD x+--+-- %const ProcessorFeature+-- % [ PF_FLOATING_POINT_PRECISION_ERRATA+-- % , PF_FLOATING_POINT_EMULATED+-- % , PF_COMPARE_EXCHANGE_DOUBLE+-- % , PF_MMX_INSTRUCTIONS_AVAILABLE+-- % ]++----------------------------------------------------------------+-- System Parameter Information+----------------------------------------------------------------++-- %fun SystemParametersInfo :: ?? -> Bool -> IO ??++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ System/Win32/Mem.hsc view
@@ -0,0 +1,267 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.Mem+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.Mem where++import System.Win32.Types++import Foreign+import Foreign.C.Types++#include <windows.h>++copyMemory :: Ptr a -> Ptr a -> DWORD -> IO ()+copyMemory dest src nbytes = copyBytes dest src (fromIntegral nbytes)++moveMemory :: Ptr a -> Ptr a -> DWORD -> IO ()+moveMemory dest src nbytes = moveBytes dest src (fromIntegral nbytes)++fillMemory :: Ptr a -> DWORD -> BYTE -> IO ()+fillMemory dest nbytes val =+ memset dest (fromIntegral val) (fromIntegral nbytes)++zeroMemory :: Ptr a -> DWORD -> IO ()+zeroMemory dest nbytes = memset dest 0 (fromIntegral nbytes)++foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO ()++foreign import stdcall unsafe "windows.h GetProcessHeap"+ getProcessHeap :: IO HANDLE++#ifndef __WINE_WINDOWS_H+foreign import stdcall unsafe "windows.h GetProcessHeaps"+ getProcessHeaps :: DWORD -> Addr -> IO DWORD+#endif++type HGLOBAL = Addr++type GlobalAllocFlags = UINT++gMEM_INVALID_HANDLE :: GlobalAllocFlags+gMEM_INVALID_HANDLE = #{const GMEM_INVALID_HANDLE}++#{enum GlobalAllocFlags,+ , gMEM_FIXED = GMEM_FIXED+ , gMEM_MOVEABLE = GMEM_MOVEABLE+ , gPTR = GPTR+ , gHND = GHND+ , gMEM_DDESHARE = GMEM_DDESHARE+ , gMEM_SHARE = GMEM_SHARE+ , gMEM_LOWER = GMEM_LOWER+ , gMEM_NOCOMPACT = GMEM_NOCOMPACT+ , gMEM_NODISCARD = GMEM_NODISCARD+ , gMEM_NOT_BANKED = GMEM_NOT_BANKED+ , gMEM_NOTIFY = GMEM_NOTIFY+ , gMEM_ZEROINIT = GMEM_ZEROINIT+ }++globalAlloc :: GlobalAllocFlags -> DWORD -> IO HGLOBAL+globalAlloc flags size =+ failIfNull "GlobalAlloc" $ c_GlobalAlloc flags size+foreign import stdcall unsafe "windows.h GlobalAlloc"+ c_GlobalAlloc :: GlobalAllocFlags -> DWORD -> IO HGLOBAL++-- %fun GlobalDiscard :: HGLOBAL -> IO HGLOBAL+-- %fail {res1==NULL}{ErrorWin("GlobalDiscard")}++globalFlags :: HGLOBAL -> IO GlobalAllocFlags+globalFlags mem =+ failIf (== gMEM_INVALID_HANDLE) "GlobalFlags" $ c_GlobalFlags mem+foreign import stdcall unsafe "windows.h GlobalFlags"+ c_GlobalFlags :: HGLOBAL -> IO GlobalAllocFlags++globalFree :: HGLOBAL -> IO HGLOBAL+globalFree mem =+ failIfNull "GlobalFree" $ c_GlobalFree mem+foreign import stdcall unsafe "windows.h GlobalFree"+ c_GlobalFree :: HGLOBAL -> IO HGLOBAL++globalHandle :: Addr -> IO HGLOBAL+globalHandle addr =+ failIfNull "GlobalHandle" $ c_GlobalHandle addr+foreign import stdcall unsafe "windows.h GlobalHandle"+ c_GlobalHandle :: Addr -> IO HGLOBAL++globalLock :: HGLOBAL -> IO Addr+globalLock mem =+ failIfNull "GlobalLock" $ c_GlobalLock mem+foreign import stdcall unsafe "windows.h GlobalLock"+ c_GlobalLock :: HGLOBAL -> IO Addr++-- %fun GlobalMemoryStatus :: IO MEMORYSTATUS++globalReAlloc :: HGLOBAL -> DWORD -> GlobalAllocFlags -> IO HGLOBAL+globalReAlloc mem size flags =+ failIfNull "GlobalReAlloc" $ c_GlobalReAlloc mem size flags+foreign import stdcall unsafe "windows.h GlobalReAlloc"+ c_GlobalReAlloc :: HGLOBAL -> DWORD -> GlobalAllocFlags -> IO HGLOBAL++globalSize :: HGLOBAL -> IO DWORD+globalSize mem =+ failIfZero "GlobalSize" $ c_GlobalSize mem+foreign import stdcall unsafe "windows.h GlobalSize"+ c_GlobalSize :: HGLOBAL -> IO DWORD++globalUnlock :: HGLOBAL -> IO ()+globalUnlock mem =+ failIfFalse_ "GlobalUnlock" $ c_GlobalUnlock mem+foreign import stdcall unsafe "windows.h GlobalUnlock"+ c_GlobalUnlock :: HGLOBAL -> IO Bool++type HeapAllocFlags = DWORD++#{enum HeapAllocFlags,+ , hEAP_GENERATE_EXCEPTIONS = HEAP_GENERATE_EXCEPTIONS+ , hEAP_NO_SERIALIZE = HEAP_NO_SERIALIZE+ , hEAP_ZERO_MEMORY = HEAP_ZERO_MEMORY+ }++heapAlloc :: HANDLE -> HeapAllocFlags -> DWORD -> IO Addr+heapAlloc heap flags size =+ failIfNull "HeapAlloc" $ c_HeapAlloc heap flags size+foreign import stdcall unsafe "windows.h HeapAlloc"+ c_HeapAlloc :: HANDLE -> HeapAllocFlags -> DWORD -> IO Addr++heapCompact :: HANDLE -> HeapAllocFlags -> IO UINT+heapCompact heap flags =+ failIfZero "HeapCompact" $ c_HeapCompact heap flags+foreign import stdcall unsafe "windows.h HeapCompact"+ c_HeapCompact :: HANDLE -> HeapAllocFlags -> IO UINT++heapCreate :: HeapAllocFlags -> DWORD -> DWORD -> IO HANDLE+heapCreate flags initSize maxSize =+ failIfNull "HeapCreate" $ c_HeapCreate flags initSize maxSize+foreign import stdcall unsafe "windows.h HeapCreate"+ c_HeapCreate :: HeapAllocFlags -> DWORD -> DWORD -> IO HANDLE++heapDestroy :: HANDLE -> IO ()+heapDestroy heap =+ failIfFalse_ "HeapDestroy" $ c_HeapDestroy heap+foreign import stdcall unsafe "windows.h HeapDestroy"+ c_HeapDestroy :: HANDLE -> IO Bool++heapFree :: HANDLE -> HeapAllocFlags -> Addr -> IO ()+heapFree heap flags addr =+ failIfFalse_ "HeapFree" $ c_HeapFree heap flags addr+foreign import stdcall unsafe "windows.h HeapFree"+ c_HeapFree :: HANDLE -> HeapAllocFlags -> Addr -> IO Bool++heapLock :: HANDLE -> IO ()+heapLock heap =+ failIfFalse_ "HeapLock" $ c_HeapLock heap+foreign import stdcall unsafe "windows.h HeapLock"+ c_HeapLock :: HANDLE -> IO Bool++heapReAlloc :: HANDLE -> HeapAllocFlags -> Addr -> DWORD -> IO Addr+heapReAlloc heap flags addr size =+ failIfNull "HeapReAlloc" $ c_HeapReAlloc heap flags addr size+foreign import stdcall unsafe "windows.h HeapReAlloc"+ c_HeapReAlloc :: HANDLE -> HeapAllocFlags -> Addr -> DWORD -> IO Addr++heapSize :: HANDLE -> HeapAllocFlags -> Addr -> IO DWORD+heapSize heap flags addr =+ failIfZero "HeapSize" $ c_HeapSize heap flags addr+foreign import stdcall unsafe "windows.h HeapSize"+ c_HeapSize :: HANDLE -> HeapAllocFlags -> Addr -> IO DWORD++heapUnlock :: HANDLE -> IO ()+heapUnlock heap =+ failIfFalse_ "HeapUnlock" $ c_HeapUnlock heap+foreign import stdcall unsafe "windows.h HeapUnlock"+ c_HeapUnlock :: HANDLE -> IO Bool++foreign import stdcall unsafe "windows.h HeapValidate"+ heapValidate :: HANDLE -> HeapAllocFlags -> Addr -> IO Bool++type VirtualAllocFlags = DWORD++#{enum VirtualAllocFlags,+ , mEM_COMMIT = MEM_COMMIT+ , mEM_RESERVE = MEM_RESERVE+ }++-- % , MEM_TOP_DOWN (not in mingw-20001111 winnt.h)++type ProtectFlags = DWORD++#{enum ProtectFlags,+ , pAGE_READONLY = PAGE_READONLY+ , pAGE_READWRITE = PAGE_READWRITE+ , pAGE_EXECUTE = PAGE_EXECUTE+ , pAGE_EXECUTE_READ = PAGE_EXECUTE_READ+ , pAGE_EXECUTE_READWRITE = PAGE_EXECUTE_READWRITE+ , pAGE_GUARD = PAGE_GUARD+ , pAGE_NOACCESS = PAGE_NOACCESS+ , pAGE_NOCACHE = PAGE_NOCACHE+ }++type FreeFlags = DWORD++#{enum FreeFlags,+ , mEM_DECOMMIT = MEM_DECOMMIT+ , mEM_RELEASE = MEM_RELEASE+ }++virtualAlloc :: Addr -> DWORD -> VirtualAllocFlags -> ProtectFlags -> IO Addr+virtualAlloc addt size ty flags =+ failIfNull "VirtualAlloc" $ c_VirtualAlloc addt size ty flags+foreign import stdcall unsafe "windows.h VirtualAlloc"+ c_VirtualAlloc :: Addr -> DWORD -> DWORD -> DWORD -> IO Addr++-- %fun VirtualAllocEx :: HANDLE -> Addr -> DWORD -> VirtualAllocFlags -> ProtectFlags ->IO Addr+-- %code extern LPVOID WINAPI VirtualAllocEx(HANDLE,LPVOID,DWORD,DWORD,DWORD);+-- % LPVOID res1=VirtualAllocEx(arg1,arg2,arg3,arg4,arg5);+-- %fail {res1==NULL}{ErrorWin("VirtualAllocEx")}++virtualFree :: Addr -> DWORD -> FreeFlags -> IO ()+virtualFree addr size flags =+ failIfFalse_ "VirtualFree" $ c_VirtualFree addr size flags+foreign import stdcall unsafe "windows.h VirtualFree"+ c_VirtualFree :: Addr -> DWORD -> FreeFlags -> IO Bool++-- %fun VirtualFreeEx :: HANDLE -> Addr -> DWORD -> FreeFlags -> IO ()+-- %code extern BOOL WINAPI VirtualFreeEx(HANDLE,LPVOID,DWORD,DWORD);+-- % BOOL res1=VirtualFreeEx(arg1,arg2,arg3,arg4);+-- %fail {res1=0}{ErrorWin("VirtualFreeEx")}++virtualLock :: Addr -> DWORD -> IO ()+virtualLock addr size =+ failIfFalse_ "VirtualLock" $ c_VirtualLock addr size+foreign import stdcall unsafe "windows.h VirtualLock"+ c_VirtualLock :: Addr -> DWORD -> IO Bool++virtualProtect :: Addr -> DWORD -> ProtectFlags -> IO ProtectFlags+virtualProtect addr size new_prot =+ alloca $ \ p_old -> do+ failIfFalse_ "VirtualProtect" $ c_VirtualProtect addr size new_prot p_old+ peek p_old+foreign import stdcall unsafe "windows.h VirtualProtect"+ c_VirtualProtect :: Addr -> DWORD -> DWORD -> Ptr DWORD -> IO Bool++virtualProtectEx :: HANDLE -> Addr -> DWORD -> ProtectFlags -> IO ProtectFlags+virtualProtectEx proc addr size new_prot =+ alloca $ \ p_old -> do+ failIfFalse_ "VirtualProtectEx" $+ c_VirtualProtectEx proc addr size new_prot p_old+ peek p_old+foreign import stdcall unsafe "windows.h VirtualProtectEx"+ c_VirtualProtectEx :: HANDLE -> Addr -> DWORD -> DWORD -> Ptr DWORD -> IO Bool++-- No VirtualQuery..()++virtualUnlock :: Addr -> DWORD -> IO ()+virtualUnlock addr size =+ failIfFalse_ "VirtualUnlock" $ c_VirtualUnlock addr size+foreign import stdcall unsafe "windows.h VirtualUnlock"+ c_VirtualUnlock :: Addr -> DWORD -> IO Bool
+ System/Win32/NLS.hsc view
@@ -0,0 +1,338 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.NLS+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.NLS (+ module System.Win32.NLS,++ -- defined in System.Win32.Types+ LCID, LANGID, SortID, SubLANGID, PrimaryLANGID,+ mAKELCID, lANGIDFROMLCID, sORTIDFROMLCID,+ mAKELANGID, pRIMARYLANGID, sUBLANGID+ ) where++import System.Win32.Types++import Foreign++#include <windows.h>+#include "errors.h"+#include "win32debug.h"++#{enum LCID,+ , lOCALE_SYSTEM_DEFAULT = LOCALE_SYSTEM_DEFAULT+ , lOCALE_USER_DEFAULT = LOCALE_USER_DEFAULT+ , lOCALE_NEUTRAL = LOCALE_NEUTRAL+ }++foreign import stdcall unsafe "windows.h ConvertDefaultLocale"+ convertDefaultLocale :: LCID -> IO LCID++-- ToDo: various enum functions.++type CodePage = UINT++#{enum CodePage,+ , cP_ACP = CP_ACP+ , cP_MACCP = CP_MACCP+ , cP_OEMCP = CP_OEMCP+ }++foreign import stdcall unsafe "windows.h GetACP"+ getACP :: IO CodePage++foreign import stdcall unsafe "windows.h SetThreadLocale"+ setThreadLocale :: LCID -> IO ()++type LCTYPE = UINT++#{enum LCTYPE,+ , lOCALE_ICALENDARTYPE = LOCALE_ICALENDARTYPE+ , lOCALE_SDATE = LOCALE_SDATE+ , lOCALE_ICURRDIGITS = LOCALE_ICURRDIGITS+ , lOCALE_SDECIMAL = LOCALE_SDECIMAL+ , lOCALE_ICURRENCY = LOCALE_ICURRENCY+ , lOCALE_SGROUPING = LOCALE_SGROUPING+ , lOCALE_IDIGITS = LOCALE_IDIGITS+ , lOCALE_SLIST = LOCALE_SLIST+ , lOCALE_IFIRSTDAYOFWEEK = LOCALE_IFIRSTDAYOFWEEK+ , lOCALE_SLONGDATE = LOCALE_SLONGDATE+ , lOCALE_IFIRSTWEEKOFYEAR = LOCALE_IFIRSTWEEKOFYEAR+ , lOCALE_SMONDECIMALSEP = LOCALE_SMONDECIMALSEP+ , lOCALE_ILZERO = LOCALE_ILZERO+ , lOCALE_SMONGROUPING = LOCALE_SMONGROUPING+ , lOCALE_IMEASURE = LOCALE_IMEASURE+ , lOCALE_SMONTHOUSANDSEP = LOCALE_SMONTHOUSANDSEP+ , lOCALE_INEGCURR = LOCALE_INEGCURR+ , lOCALE_SNEGATIVESIGN = LOCALE_SNEGATIVESIGN+ , lOCALE_INEGNUMBER = LOCALE_INEGNUMBER+ , lOCALE_SPOSITIVESIGN = LOCALE_SPOSITIVESIGN+ , lOCALE_SSHORTDATE = LOCALE_SSHORTDATE+ , lOCALE_ITIME = LOCALE_ITIME+ , lOCALE_STHOUSAND = LOCALE_STHOUSAND+ , lOCALE_S1159 = LOCALE_S1159+ , lOCALE_STIME = LOCALE_STIME+ , lOCALE_S2359 = LOCALE_S2359+ , lOCALE_STIMEFORMAT = LOCALE_STIMEFORMAT+ , lOCALE_SCURRENCY = LOCALE_SCURRENCY+ }++setLocaleInfo :: LCID -> LCTYPE -> String -> IO ()+setLocaleInfo locale ty info =+ withTString info $ \ c_info ->+ failIfFalse_ "SetLocaleInfo" $ c_SetLocaleInfo locale ty c_info+foreign import stdcall unsafe "windows.h SetLocaleInfoW"+ c_SetLocaleInfo :: LCID -> LCTYPE -> LPCTSTR -> IO Bool++type LCMapFlags = DWORD++#{enum LCMapFlags,+ , lCMAP_BYTEREV = LCMAP_BYTEREV+ , lCMAP_FULLWIDTH = LCMAP_FULLWIDTH+ , lCMAP_HALFWIDTH = LCMAP_HALFWIDTH+ , lCMAP_HIRAGANA = LCMAP_HIRAGANA+ , lCMAP_KATAKANA = LCMAP_KATAKANA+ , lCMAP_LOWERCASE = LCMAP_LOWERCASE+ , lCMAP_SORTKEY = LCMAP_SORTKEY+ , lCMAP_UPPERCASE = LCMAP_UPPERCASE+ , nORM_IGNORECASE = NORM_IGNORECASE+ , nORM_IGNORENONSPACE = NORM_IGNORENONSPACE+ , nORM_IGNOREKANATYPE = NORM_IGNOREKANATYPE+ , nORM_IGNORESYMBOLS = NORM_IGNORESYMBOLS+ , nORM_IGNOREWIDTH = NORM_IGNOREWIDTH+ , sORT_STRINGSORT = SORT_STRINGSORT+ , lCMAP_LINGUISTIC_CASING = LCMAP_LINGUISTIC_CASING+ , lCMAP_SIMPLIFIED_CHINESE = LCMAP_SIMPLIFIED_CHINESE+ , lCMAP_TRADITIONAL_CHINESE = LCMAP_TRADITIONAL_CHINESE+ }++lCMapString :: LCID -> LCMapFlags -> String -> Int -> IO String+lCMapString locale flags src dest_size =+ withTStringLen src $ \ (c_src, src_len) ->+ allocaArray dest_size $ \ c_dest -> do+ failIfZero "LCMapString" $+ c_LCMapString locale flags c_src src_len c_dest dest_size+ peekTString c_dest+foreign import stdcall unsafe "windows.h LCMapStringW"+ c_LCMapString :: LCID -> LCMapFlags -> LPCTSTR -> Int -> LPCTSTR -> Int -> IO Int++type LocaleTestFlags = DWORD++#{enum LocaleTestFlags,+ , lCID_INSTALLED = LCID_INSTALLED+ , lCID_SUPPORTED = LCID_SUPPORTED+ }++foreign import stdcall unsafe "windows.h IsValidLocale"+ isValidLocale :: LCID -> LocaleTestFlags -> IO Bool++foreign import stdcall unsafe "windows.h IsValidCodePage"+ isValidCodePage :: CodePage -> IO Bool++foreign import stdcall unsafe "windows.h GetUserDefaultLCID"+ getUserDefaultLCID :: LCID++foreign import stdcall unsafe "windows.h GetUserDefaultLangID"+ getUserDefaultLangID :: LANGID++foreign import stdcall unsafe "windows.h GetThreadLocale"+ getThreadLocale :: IO LCID++foreign import stdcall unsafe "windows.h GetSystemDefaultLCID"+ getSystemDefaultLCID :: LCID++foreign import stdcall unsafe "windows.h GetSystemDefaultLangID"+ getSystemDefaultLangID :: LANGID++foreign import stdcall unsafe "windows.h GetOEMCP"+ getOEMCP :: CodePage++#{enum PrimaryLANGID,+ , lANG_NEUTRAL = LANG_NEUTRAL+ , lANG_BULGARIAN = LANG_BULGARIAN+ , lANG_CHINESE = LANG_CHINESE+ , lANG_CZECH = LANG_CZECH+ , lANG_DANISH = LANG_DANISH+ , lANG_GERMAN = LANG_GERMAN+ , lANG_GREEK = LANG_GREEK+ , lANG_ENGLISH = LANG_ENGLISH+ , lANG_SPANISH = LANG_SPANISH+ , lANG_FINNISH = LANG_FINNISH+ , lANG_FRENCH = LANG_FRENCH+ , lANG_HUNGARIAN = LANG_HUNGARIAN+ , lANG_ICELANDIC = LANG_ICELANDIC+ , lANG_ITALIAN = LANG_ITALIAN+ , lANG_JAPANESE = LANG_JAPANESE+ , lANG_KOREAN = LANG_KOREAN+ , lANG_DUTCH = LANG_DUTCH+ , lANG_NORWEGIAN = LANG_NORWEGIAN+ , lANG_POLISH = LANG_POLISH+ , lANG_PORTUGUESE = LANG_PORTUGUESE+ , lANG_ROMANIAN = LANG_ROMANIAN+ , lANG_RUSSIAN = LANG_RUSSIAN+ , lANG_CROATIAN = LANG_CROATIAN+ , lANG_SLOVAK = LANG_SLOVAK+ , lANG_SWEDISH = LANG_SWEDISH+ , lANG_TURKISH = LANG_TURKISH+ , lANG_SLOVENIAN = LANG_SLOVENIAN+ , lANG_ARABIC = LANG_ARABIC+ , lANG_CATALAN = LANG_CATALAN+ , lANG_HEBREW = LANG_HEBREW+ , lANG_SERBIAN = LANG_SERBIAN+ , lANG_ALBANIAN = LANG_ALBANIAN+ , lANG_THAI = LANG_THAI+ , lANG_URDU = LANG_URDU+ , lANG_INDONESIAN = LANG_INDONESIAN+ , lANG_BELARUSIAN = LANG_BELARUSIAN+ , lANG_ESTONIAN = LANG_ESTONIAN+ , lANG_LATVIAN = LANG_LATVIAN+ , lANG_LITHUANIAN = LANG_LITHUANIAN+ , lANG_FARSI = LANG_FARSI+ , lANG_VIETNAMESE = LANG_VIETNAMESE+ , lANG_ARMENIAN = LANG_ARMENIAN+ , lANG_AZERI = LANG_AZERI+ , lANG_BASQUE = LANG_BASQUE+ , lANG_MACEDONIAN = LANG_MACEDONIAN+ , lANG_AFRIKAANS = LANG_AFRIKAANS+ , lANG_GEORGIAN = LANG_GEORGIAN+ , lANG_FAEROESE = LANG_FAEROESE+ , lANG_HINDI = LANG_HINDI+ , lANG_MALAY = LANG_MALAY+ , lANG_KAZAK = LANG_KAZAK+ , lANG_SWAHILI = LANG_SWAHILI+ , lANG_UZBEK = LANG_UZBEK+ , lANG_TATAR = LANG_TATAR+ , lANG_BENGALI = LANG_BENGALI+ , lANG_PUNJABI = LANG_PUNJABI+ , lANG_GUJARATI = LANG_GUJARATI+ , lANG_ORIYA = LANG_ORIYA+ , lANG_TAMIL = LANG_TAMIL+ , lANG_TELUGU = LANG_TELUGU+ , lANG_KANNADA = LANG_KANNADA+ , lANG_MALAYALAM = LANG_MALAYALAM+ , lANG_ASSAMESE = LANG_ASSAMESE+ , lANG_MARATHI = LANG_MARATHI+ , lANG_SANSKRIT = LANG_SANSKRIT+ , lANG_KONKANI = LANG_KONKANI+ , lANG_MANIPURI = LANG_MANIPURI+ , lANG_SINDHI = LANG_SINDHI+ , lANG_KASHMIRI = LANG_KASHMIRI+ , lANG_NEPALI = LANG_NEPALI+ }++#{enum SortID,+ , sORT_DEFAULT = SORT_DEFAULT+ , sORT_JAPANESE_XJIS = SORT_JAPANESE_XJIS+ , sORT_JAPANESE_UNICODE = SORT_JAPANESE_UNICODE+ , sORT_CHINESE_BIG5 = SORT_CHINESE_BIG5+ , sORT_CHINESE_UNICODE = SORT_CHINESE_UNICODE+ , sORT_KOREAN_KSC = SORT_KOREAN_KSC+ , sORT_KOREAN_UNICODE = SORT_KOREAN_UNICODE+ }++#{enum SubLANGID,+ , sUBLANG_NEUTRAL = SUBLANG_NEUTRAL+ , sUBLANG_DEFAULT = SUBLANG_DEFAULT+ , sUBLANG_SYS_DEFAULT = SUBLANG_SYS_DEFAULT+ , sUBLANG_CHINESE_TRADITIONAL = SUBLANG_CHINESE_TRADITIONAL+ , sUBLANG_CHINESE_SIMPLIFIED = SUBLANG_CHINESE_SIMPLIFIED+ , sUBLANG_CHINESE_HONGKONG = SUBLANG_CHINESE_HONGKONG+ , sUBLANG_CHINESE_SINGAPORE = SUBLANG_CHINESE_SINGAPORE+ , sUBLANG_DUTCH = SUBLANG_DUTCH+ , sUBLANG_DUTCH_BELGIAN = SUBLANG_DUTCH_BELGIAN+ , sUBLANG_ENGLISH_US = SUBLANG_ENGLISH_US+ , sUBLANG_ENGLISH_UK = SUBLANG_ENGLISH_UK+ , sUBLANG_ENGLISH_AUS = SUBLANG_ENGLISH_AUS+ , sUBLANG_ENGLISH_CAN = SUBLANG_ENGLISH_CAN+ , sUBLANG_ENGLISH_NZ = SUBLANG_ENGLISH_NZ+ , sUBLANG_ENGLISH_EIRE = SUBLANG_ENGLISH_EIRE+ , sUBLANG_FRENCH = SUBLANG_FRENCH+ , sUBLANG_FRENCH_BELGIAN = SUBLANG_FRENCH_BELGIAN+ , sUBLANG_FRENCH_CANADIAN = SUBLANG_FRENCH_CANADIAN+ , sUBLANG_FRENCH_SWISS = SUBLANG_FRENCH_SWISS+ , sUBLANG_GERMAN = SUBLANG_GERMAN+ , sUBLANG_GERMAN_SWISS = SUBLANG_GERMAN_SWISS+ , sUBLANG_GERMAN_AUSTRIAN = SUBLANG_GERMAN_AUSTRIAN+ , sUBLANG_ITALIAN = SUBLANG_ITALIAN+ , sUBLANG_ITALIAN_SWISS = SUBLANG_ITALIAN_SWISS+ , sUBLANG_NORWEGIAN_BOKMAL = SUBLANG_NORWEGIAN_BOKMAL+ , sUBLANG_NORWEGIAN_NYNORSK = SUBLANG_NORWEGIAN_NYNORSK+ , sUBLANG_PORTUGUESE = SUBLANG_PORTUGUESE+ , sUBLANG_PORTUGUESE_BRAZILIAN = SUBLANG_PORTUGUESE_BRAZILIAN+ , sUBLANG_SPANISH = SUBLANG_SPANISH+ , sUBLANG_SPANISH_MEXICAN = SUBLANG_SPANISH_MEXICAN+ , sUBLANG_SPANISH_MODERN = SUBLANG_SPANISH_MODERN+ , sUBLANG_ARABIC_SAUDI_ARABIA = SUBLANG_ARABIC_SAUDI_ARABIA+ , sUBLANG_ARABIC_IRAQ = SUBLANG_ARABIC_IRAQ+ , sUBLANG_ARABIC_EGYPT = SUBLANG_ARABIC_EGYPT+ , sUBLANG_ARABIC_LIBYA = SUBLANG_ARABIC_LIBYA+ , sUBLANG_ARABIC_ALGERIA = SUBLANG_ARABIC_ALGERIA+ , sUBLANG_ARABIC_MOROCCO = SUBLANG_ARABIC_MOROCCO+ , sUBLANG_ARABIC_TUNISIA = SUBLANG_ARABIC_TUNISIA+ , sUBLANG_ARABIC_OMAN = SUBLANG_ARABIC_OMAN+ , sUBLANG_ARABIC_YEMEN = SUBLANG_ARABIC_YEMEN+ , sUBLANG_ARABIC_SYRIA = SUBLANG_ARABIC_SYRIA+ , sUBLANG_ARABIC_JORDAN = SUBLANG_ARABIC_JORDAN+ , sUBLANG_ARABIC_LEBANON = SUBLANG_ARABIC_LEBANON+ , sUBLANG_ARABIC_KUWAIT = SUBLANG_ARABIC_KUWAIT+ , sUBLANG_ARABIC_UAE = SUBLANG_ARABIC_UAE+ , sUBLANG_ARABIC_BAHRAIN = SUBLANG_ARABIC_BAHRAIN+ , sUBLANG_ARABIC_QATAR = SUBLANG_ARABIC_QATAR+ , sUBLANG_AZERI_CYRILLIC = SUBLANG_AZERI_CYRILLIC+ , sUBLANG_AZERI_LATIN = SUBLANG_AZERI_LATIN+ , sUBLANG_CHINESE_MACAU = SUBLANG_CHINESE_MACAU+ , sUBLANG_ENGLISH_SOUTH_AFRICA = SUBLANG_ENGLISH_SOUTH_AFRICA+ , sUBLANG_ENGLISH_JAMAICA = SUBLANG_ENGLISH_JAMAICA+ , sUBLANG_ENGLISH_CARIBBEAN = SUBLANG_ENGLISH_CARIBBEAN+ , sUBLANG_ENGLISH_BELIZE = SUBLANG_ENGLISH_BELIZE+ , sUBLANG_ENGLISH_TRINIDAD = SUBLANG_ENGLISH_TRINIDAD+ , sUBLANG_ENGLISH_PHILIPPINES = SUBLANG_ENGLISH_PHILIPPINES+ , sUBLANG_ENGLISH_ZIMBABWE = SUBLANG_ENGLISH_ZIMBABWE+ , sUBLANG_FRENCH_LUXEMBOURG = SUBLANG_FRENCH_LUXEMBOURG+ , sUBLANG_FRENCH_MONACO = SUBLANG_FRENCH_MONACO+ , sUBLANG_GERMAN_LUXEMBOURG = SUBLANG_GERMAN_LUXEMBOURG+ , sUBLANG_GERMAN_LIECHTENSTEIN = SUBLANG_GERMAN_LIECHTENSTEIN+ , sUBLANG_KASHMIRI_INDIA = SUBLANG_KASHMIRI_INDIA+ , sUBLANG_KOREAN = SUBLANG_KOREAN+ , sUBLANG_LITHUANIAN = SUBLANG_LITHUANIAN+ , sUBLANG_MALAY_MALAYSIA = SUBLANG_MALAY_MALAYSIA+ , sUBLANG_MALAY_BRUNEI_DARUSSALAM = SUBLANG_MALAY_BRUNEI_DARUSSALAM+ , sUBLANG_NEPALI_INDIA = SUBLANG_NEPALI_INDIA+ , sUBLANG_SERBIAN_LATIN = SUBLANG_SERBIAN_LATIN+ , sUBLANG_SERBIAN_CYRILLIC = SUBLANG_SERBIAN_CYRILLIC+ , sUBLANG_SPANISH_GUATEMALA = SUBLANG_SPANISH_GUATEMALA+ , sUBLANG_SPANISH_COSTA_RICA = SUBLANG_SPANISH_COSTA_RICA+ , sUBLANG_SPANISH_PANAMA = SUBLANG_SPANISH_PANAMA+ , sUBLANG_SPANISH_DOMINICAN_REPUBLIC = SUBLANG_SPANISH_DOMINICAN_REPUBLIC+ , sUBLANG_SPANISH_VENEZUELA = SUBLANG_SPANISH_VENEZUELA+ , sUBLANG_SPANISH_COLOMBIA = SUBLANG_SPANISH_COLOMBIA+ , sUBLANG_SPANISH_PERU = SUBLANG_SPANISH_PERU+ , sUBLANG_SPANISH_ARGENTINA = SUBLANG_SPANISH_ARGENTINA+ , sUBLANG_SPANISH_ECUADOR = SUBLANG_SPANISH_ECUADOR+ , sUBLANG_SPANISH_CHILE = SUBLANG_SPANISH_CHILE+ , sUBLANG_SPANISH_URUGUAY = SUBLANG_SPANISH_URUGUAY+ , sUBLANG_SPANISH_PARAGUAY = SUBLANG_SPANISH_PARAGUAY+ , sUBLANG_SPANISH_BOLIVIA = SUBLANG_SPANISH_BOLIVIA+ , sUBLANG_SPANISH_EL_SALVADOR = SUBLANG_SPANISH_EL_SALVADOR+ , sUBLANG_SPANISH_HONDURAS = SUBLANG_SPANISH_HONDURAS+ , sUBLANG_SPANISH_NICARAGUA = SUBLANG_SPANISH_NICARAGUA+ , sUBLANG_SPANISH_PUERTO_RICO = SUBLANG_SPANISH_PUERTO_RICO+ , sUBLANG_SWEDISH = SUBLANG_SWEDISH+ , sUBLANG_SWEDISH_FINLAND = SUBLANG_SWEDISH_FINLAND+ , sUBLANG_URDU_PAKISTAN = SUBLANG_URDU_PAKISTAN+ , sUBLANG_URDU_INDIA = SUBLANG_URDU_INDIA+ , sUBLANG_UZBEK_LATIN = SUBLANG_UZBEK_LATIN+ , sUBLANG_UZBEK_CYRILLIC = SUBLANG_UZBEK_CYRILLIC+ }++-- , SUBLANG_LITHUANIAN_CLASSIC (not in mingw-20001111)
+ System/Win32/Process.hsc view
@@ -0,0 +1,124 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.Process+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.Process where+import Control.Exception ( bracket )+import Control.Monad ( liftM5 )+import Foreign ( Ptr, peekByteOff, allocaBytes, pokeByteOff+ , plusPtr )+import System.Win32.File ( closeHandle )+import System.Win32.Types++#include <windows.h>+#include <tlhelp32.h>++-- constant to wait for a very long time.+iNFINITE :: DWORD+iNFINITE = #{const INFINITE}++foreign import stdcall unsafe "windows.h Sleep"+ sleep :: DWORD -> IO ()+++type ProcessId = DWORD+type ProcessHandle = HANDLE+type ProcessAccessRights = DWORD+#{enum ProcessAccessRights,+ , pROCESS_ALL_ACCESS = PROCESS_ALL_ACCESS+ , pROCESS_CREATE_PROCESS = PROCESS_CREATE_PROCESS+ , pROCESS_CREATE_THREAD = PROCESS_CREATE_THREAD+ , pROCESS_DUP_HANDLE = PROCESS_DUP_HANDLE+ , pROCESS_QUERY_INFORMATION = PROCESS_QUERY_INFORMATION+ , pROCESS_SET_QUOTA = PROCESS_SET_QUOTA+ , pROCESS_SET_INFORMATION = PROCESS_SET_INFORMATION+ , pROCESS_TERMINATE = PROCESS_TERMINATE+ , pROCESS_VM_OPERATION = PROCESS_VM_OPERATION+ , pROCESS_VM_READ = PROCESS_VM_READ+ , pROCESS_VM_WRITE = PROCESS_VM_WRITE+ , sYNCHORNIZE = SYNCHRONIZE + }++foreign import stdcall unsafe "windows.h OpenProcess"+ c_OpenProcess :: ProcessAccessRights -> BOOL -> ProcessId -> IO ProcessHandle+++openProcess :: ProcessAccessRights -> BOOL -> ProcessId -> IO ProcessHandle+openProcess r inh i = failIfNull "OpenProcess" $ c_OpenProcess r inh i++type Th32SnapHandle = HANDLE+type Th32SnapFlags = DWORD+-- | ProcessId, number of threads, parent ProcessId, process base priority, path of executable file+type ProcessEntry32 = (ProcessId, Int, ProcessId, LONG, String)++#{enum Th32SnapFlags,+ , tH32CS_SNAPALL = TH32CS_SNAPALL+ , tH32CS_SNAPHEAPLIST = TH32CS_SNAPHEAPLIST+ , tH32CS_SNAPMODULE = TH32CS_SNAPMODULE+ , tH32CS_SNAPPROCESS = TH32CS_SNAPPROCESS+ , tH32CS_SNAPTHREAD = TH32CS_SNAPTHREAD+ }+{-+ , tH32CS_SNAPGETALLMODS = TH32CS_GETALLMODS+ , tH32CS_SNAPNOHEAPS = TH32CS_SNAPNOHEAPS +-}++foreign import stdcall unsafe "tlhelp32.h CreateToolhelp32Snapshot"+ c_CreateToolhelp32Snapshot :: Th32SnapFlags -> ProcessId -> IO Th32SnapHandle++foreign import stdcall unsafe "tlhelp32.h Process32FirstW"+ c_Process32First :: Th32SnapHandle -> Ptr ProcessEntry32 -> IO BOOL++foreign import stdcall unsafe "tlhelp32.h Process32NextW"+ c_Process32Next :: Th32SnapHandle -> Ptr ProcessEntry32 -> IO BOOL++-- | Create a snapshot of specified resources. Call closeHandle to close snapshot.+createToolhelp32Snapshot :: Th32SnapFlags -> Maybe ProcessId -> IO Th32SnapHandle+createToolhelp32Snapshot f p+ = failIfNull "CreateToolhelp32Snapshot" $ c_CreateToolhelp32Snapshot+ f (maybe 0 id p)++withTh32Snap :: Th32SnapFlags -> Maybe ProcessId -> (Th32SnapHandle -> IO a) -> IO a+withTh32Snap f p = bracket (createToolhelp32Snapshot f p) (closeHandle)+++peekProcessEntry32 :: Ptr ProcessEntry32 -> IO ProcessEntry32+peekProcessEntry32 buf = liftM5 (,,,,)+ ((#peek PROCESSENTRY32, th32ProcessID) buf)+ ((#peek PROCESSENTRY32, cntThreads) buf)+ ((#peek PROCESSENTRY32, th32ParentProcessID) buf)+ ((#peek PROCESSENTRY32, pcPriClassBase) buf)+ (peekTString $ (#ptr PROCESSENTRY32, szExeFile) buf)++-- | Enumerate processes using Process32First and Process32Next+th32SnapEnumProcesses :: Th32SnapHandle -> IO [ProcessEntry32]+th32SnapEnumProcesses h = allocaBytes (#size PROCESSENTRY32) $ \pe -> do+ putStrLn "1"+ (#poke PROCESSENTRY32, dwSize) pe ((#size PROCESSENTRY32)::DWORD)+ putStrLn "2"+ ok <- c_Process32First h pe+ putStrLn "3"+ readAndNext ok pe []+ where+ readAndNext ok pe res+ | not ok = do+ err <- getLastError+ print err+ if err==(#const ERROR_NO_MORE_FILES)+ then return $ reverse res+ else failWith "th32SnapEnumProcesses: Process32First/Process32Next" err+ | otherwise = do+ putStrLn "reading"+ entry <- peekProcessEntry32 pe+ ok' <- c_Process32Next h pe+ readAndNext ok' pe (entry:res)
+ System/Win32/Registry.hsc view
@@ -0,0 +1,506 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.Registry+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for accessing the Win32 registry.+--+-----------------------------------------------------------------------------++module System.Win32.Registry+ ( module System.Win32.Registry+ ) where+{- What's really on offer:+ (+ regCloseKey -- :: HKEY -> IO ()+ , regConnectRegistry -- :: Maybe String -> HKEY -> IO HKEY+ , regCreateKey -- :: HKEY -> String -> IO HKEY+ , regCreateKeyEx -- :: HKEY -> String -> String+ -- -> RegCreateOptions -> REGSAM+ -- -> Maybe LPSECURITY_ATTRIBUTES+ -- -> IO (HKEY, Bool)+ , regDeleteKey -- :: HKEY -> String -> IO ()+ , regDeleteValue -- :: HKEY -> String -> IO ()+ , regEnumKeys -- :: HKEY -> IO [String]+ , regEnumKey -- :: HKEY -> DWORD -> Addr -> DWORD -> IO String+ , regEnumKeyValue -- :: HKEY -> DWORD -> Addr -> DWORD -> Addr -> DWORD -> IO String+ , regFlushKey -- :: HKEY -> IO ()+ , regLoadKey -- :: HKEY -> String -> String -> IO ()+ , regNotifyChangeKeyValue -- :: HKEY -> Bool -> RegNotifyOptions+ -- -> HANDLE -> Bool -> IO ()+ , regOpenKey -- :: HKEY -> String -> IO HKEY+ , regOpenKeyEx -- :: HKEY -> String -> REGSAM -> IO HKEY+ , regQueryInfoKey -- :: HKEY -> IO RegInfoKey+ , regQueryValue -- :: HKEY -> Maybe String -> IO String+ , regQueryValueKey -- :: HKEY -> Maybe String -> IO String+ , regQueryValueEx -- :: HKEY -> String -> Addr -> Int -> IO RegValueType+ , regReplaceKey -- :: HKEY -> String -> String -> String -> IO ()+ , regRestoreKey -- :: HKEY -> String -> RegRestoreFlags -> IO ()+ , regSaveKey -- :: HKEY -> String -> Maybe LPSECURITY_ATTRIBUTES -> IO ()+ , regSetValue -- :: HKEY -> String -> String -> IO ()+ , regSetValueEx -- :: HKEY -> String -> RegValueType -> LPTSTR -> Int -> IO ()+ , regSetStringValue -- :: HKEY -> String -> String -> IO ()+ , regUnloadKey -- :: HKEY -> String -> IO ()+ ) where+-}++{-+ Registry API omissions:++ RegQueryMultipleValues()+ RegEnumKeyEx()++-}++import System.Win32.Time+import System.Win32.Types+import System.Win32.File++import Foreign++#include <windows.h>++#{enum HKEY, (unsafePerformIO . newForeignHANDLE . castUINTToPtr)+ , hKEY_CLASSES_ROOT = (UINT)HKEY_CLASSES_ROOT+ , hKEY_CURRENT_CONFIG = (UINT)HKEY_CURRENT_CONFIG+ , hKEY_CURRENT_USER = (UINT)HKEY_CURRENT_USER+ , hKEY_LOCAL_MACHINE = (UINT)HKEY_LOCAL_MACHINE+ , hKEY_USERS = (UINT)HKEY_USERS+ }+-- , PKEYERFORMANCE_DATA NT only+-- , HKEY_DYN_DATA 95/98 only++regCloseKey :: HKEY -> IO ()+regCloseKey key =+ withForeignPtr key $ \ p_key ->+ failUnlessSuccess "RegCloseKey" $ c_RegCloseKey p_key+foreign import stdcall unsafe "windows.h RegCloseKey"+ c_RegCloseKey :: PKEY -> IO ErrCode++-- Connects to a predefined registry handle on another computer.++regConnectRegistry :: Maybe String -> HKEY -> IO HKEY+regConnectRegistry mb_machine key =+ withForeignPtr key $ \ p_key ->+ maybeWith withTString mb_machine $ \ c_machine ->+ alloca $ \ p_out_key -> do+ failUnlessSuccess "RegConnectRegistry" $+ c_RegConnectRegistry c_machine p_key p_out_key+ p_new_key <- peek p_out_key+ newForeignHANDLE p_new_key+foreign import stdcall unsafe "windows.h RegConnectRegistryW"+ c_RegConnectRegistry :: LPCTSTR -> PKEY -> Ptr PKEY -> IO ErrCode++regCreateKey :: HKEY -> String -> IO HKEY+regCreateKey key subkey =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ alloca $ \ p_out_key -> do+ failUnlessSuccess "RegCreateKey" $+ c_RegCreateKey p_key c_subkey p_out_key+ p_new_key <- peek p_out_key+ newForeignHANDLE p_new_key+foreign import stdcall unsafe "windows.h RegCreateKeyW"+ c_RegCreateKey :: PKEY -> LPCTSTR -> Ptr PKEY -> IO ErrCode++type RegCreateOptions = DWORD++#{enum RegCreateOptions,+ , rEG_OPTION_NON_VOLATILE = REG_OPTION_NON_VOLATILE+ , rEG_OPTION_VOLATILE = REG_OPTION_VOLATILE+ }++type REGSAM = #{type REGSAM}++#{enum REGSAM,+ , kEY_ALL_ACCESS = KEY_ALL_ACCESS+ , kEY_CREATE_LINK = KEY_CREATE_LINK+ , kEY_CREATE_SUB_KEY = KEY_CREATE_SUB_KEY+ , kEY_ENUMERATE_SUB_KEYS = KEY_ENUMERATE_SUB_KEYS+ , kEY_EXECUTE = KEY_EXECUTE+ , kEY_NOTIFY = KEY_NOTIFY+ , kEY_QUERY_VALUE = KEY_QUERY_VALUE+ , kEY_READ = KEY_READ+ , kEY_SET_VALUE = KEY_SET_VALUE+ , kEY_WRITE = KEY_WRITE+ }++regCreateKeyEx :: HKEY -> String -> String -> RegCreateOptions -> REGSAM -> Maybe LPSECURITY_ATTRIBUTES -> IO (HKEY, Bool)+regCreateKeyEx key subkey cls opts sam mb_attr =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ withTString cls $ \ c_cls ->+ alloca $ \ p_res ->+ alloca $ \ p_disp -> do+ failUnlessSuccess "RegCreateKeyEx" $+ c_RegCreateKeyEx p_key c_subkey 0 c_cls opts sam (maybePtr mb_attr) p_res p_disp+ p_out_key <- peek p_res+ out_key <- newForeignHANDLE p_out_key+ disp <- peek p_disp+ return (out_key, disp == #{const REG_CREATED_NEW_KEY})+foreign import stdcall unsafe "windows.h RegCreateKeyExW"+ c_RegCreateKeyEx :: PKEY -> LPCTSTR -> DWORD -> LPCTSTR -> RegCreateOptions -> REGSAM -> LPSECURITY_ATTRIBUTES -> Ptr PKEY -> Ptr DWORD -> IO ErrCode++regDeleteKey :: HKEY -> String -> IO ()+regDeleteKey key subkey =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ failUnlessSuccess "RegDeleteKey" $ c_RegDeleteKey p_key c_subkey+foreign import stdcall unsafe "windows.h RegDeleteKeyW"+ c_RegDeleteKey :: PKEY -> LPCTSTR -> IO ErrCode++regDeleteValue :: HKEY -> String -> IO ()+regDeleteValue key name =+ withForeignPtr key $ \ p_key ->+ withTString name $ \ c_name ->+ failUnlessSuccess "RegDeleteValue" $ c_RegDeleteValue p_key c_name+foreign import stdcall unsafe "windows.h RegDeleteValueW"+ c_RegDeleteValue :: PKEY -> LPCTSTR -> IO ErrCode++regEnumKeys :: HKEY -> IO [String]+regEnumKeys hkey = do+ hinfo <- regQueryInfoKey hkey+ let buflen = 1+max_subkey_len hinfo+ buf <- mallocBytes (fromIntegral buflen)+ ls <- go 0 buf buflen+ free buf+ return ls+ where+ go n buf buflen = do+ (v,flg) <- regEnumKey hkey n buf buflen+ if flg /= 0+ then return []+ else do+ vs <- go (n+1) buf buflen+ return (v:vs)++regEnumKeyVals :: HKEY -> IO [(String,String,RegValueType)]+regEnumKeyVals hkey = do+ hinfo <- regQueryInfoKey hkey+ let nmlen = 1+max_value_name_len hinfo -- add spc for terminating NUL.+ let vallen = 1+max_value_len hinfo+ nmbuf <- mallocBytes (fromIntegral nmlen)+ valbuf <- mallocBytes (fromIntegral vallen)+ ls <- go 0 nmbuf nmlen valbuf vallen+ free nmbuf+ free valbuf+ return ls+ where+ go n nmbuf nmlen valbuf vallen = do+ (ty,nm,flg) <- regEnumValue hkey n nmbuf nmlen valbuf vallen+ if flg /= 0+ then return []+ else do++ val <-+ case ty of+ x | x == rEG_SZ -> peekTString (castPtr valbuf)+ | x == rEG_DWORD -> peekElemOff (castPtr valbuf) 0 >>= \ v -> return (show (v :: DWORD))+ | otherwise -> return "<<unknown>>"++ vs <- go (n+1) nmbuf nmlen valbuf vallen+ return ((nm,val,ty):vs)++-- It's up to the programmer to ensure that a large enough+-- buffer is passed in here.++regEnumKey :: HKEY -> DWORD -> LPTSTR -> DWORD -> IO (String, Int)+regEnumKey key index c_name len =+ withForeignPtr key $ \ p_key -> do+ no_more <- failUnlessSuccessOr eRROR_NO_MORE_ITEMS "RegEnumKey" $+ c_RegEnumKey p_key index c_name len+ str <- peekTString c_name+ return (str, fromEnum no_more)+foreign import stdcall unsafe "windows.h RegEnumKeyW"+ c_RegEnumKey :: PKEY -> DWORD -> LPTSTR -> DWORD -> IO ErrCode++regEnumValue :: HKEY -> DWORD -> LPTSTR -> DWORD -> LPBYTE -> DWORD -> IO (RegValueType, String, Int)+regEnumValue key index name name_len value value_len =+ withForeignPtr key $ \ p_key ->+ with name_len $ \ p_name_len ->+ with value_len $ \ p_value_len ->+ alloca $ \ p_reg_ty -> do+ no_more <- failUnlessSuccessOr eRROR_NO_MORE_ITEMS "RegEnumValue" $+ c_RegEnumValue p_key index name p_name_len nullPtr p_reg_ty value p_value_len+ reg_ty <- peek p_reg_ty+ str <- peekTString name+ return (reg_ty, str, fromEnum no_more)+foreign import stdcall unsafe "windows.h RegEnumValueW"+ c_RegEnumValue :: PKEY -> DWORD -> LPTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> LPBYTE -> Ptr DWORD -> IO ErrCode++eRROR_NO_MORE_ITEMS :: ErrCode+eRROR_NO_MORE_ITEMS = #{const ERROR_NO_MORE_ITEMS}++regFlushKey :: HKEY -> IO ()+regFlushKey key =+ withForeignPtr key $ \ p_key ->+ failUnlessSuccess "RegFlushKey" $ c_RegFlushKey p_key+foreign import stdcall unsafe "windows.h RegFlushKey"+ c_RegFlushKey :: PKEY -> IO ErrCode++-- ifdef FOR_WINDOWS_NT+-- RegGetKeySecurity :: HKEY -> SECURITY_INFORMATION -> IO SECURITY_DESCRIPTION++-- endif++regLoadKey :: HKEY -> String -> String -> IO ()+regLoadKey key subkey file =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ withTString file $ \ c_file ->+ failUnlessSuccess "RegLoadKey" $ c_RegLoadKey p_key c_subkey c_file+foreign import stdcall unsafe "windows.h RegLoadKeyW"+ c_RegLoadKey :: PKEY -> LPCTSTR -> LPCTSTR -> IO ErrCode++-- ifdef FOR_WINDOWS_NT++type RegNotifyOptions = DWORD++#{enum RegNotifyOptions,+ , rEG_NOTIFY_CHANGE_NAME = REG_NOTIFY_CHANGE_NAME+ , rEG_NOTIFY_CHANGE_ATTRIBUTES = REG_NOTIFY_CHANGE_ATTRIBUTES+ , rEG_NOTIFY_CHANGE_LAST_SET = REG_NOTIFY_CHANGE_LAST_SET+ , rEG_NOTIFY_CHANGE_SECURITY = REG_NOTIFY_CHANGE_SECURITY+ }++regNotifyChangeKeyValue :: HKEY -> Bool -> RegNotifyOptions -> HANDLE -> Bool -> IO ()+regNotifyChangeKeyValue key watch notifyFilter event async =+ withForeignPtr key $ \ p_key ->+ failUnlessSuccess "RegNotifyChangeKeyValue" $+ c_RegNotifyChangeKeyValue p_key watch notifyFilter event async+foreign import stdcall unsafe "windows.h RegNotifyChangeKeyValue"+ c_RegNotifyChangeKeyValue :: PKEY -> Bool -> RegNotifyOptions -> HANDLE -> Bool -> IO ErrCode++-- endif++-- for Win 3.x compatibility, use RegOpenKeyEx instead.++regOpenKey :: HKEY -> String -> IO HKEY+regOpenKey key subkey =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ alloca $ \ p_res -> do+ failUnlessSuccess "RegOpenKey" $ c_RegOpenKey p_key c_subkey p_res+ p_res_key <- peek p_res+ newForeignHANDLE p_res_key+foreign import stdcall unsafe "windows.h RegOpenKeyW"+ c_RegOpenKey :: PKEY -> LPCTSTR -> Ptr PKEY -> IO ErrCode++regOpenKeyEx :: HKEY -> String -> REGSAM -> IO HKEY+regOpenKeyEx key subkey sam =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ alloca $ \ p_res -> do+ failUnlessSuccess "RegOpenKeyEx" $ c_RegOpenKeyEx p_key c_subkey 0 sam p_res+ p_res_key <- peek p_res+ newForeignHANDLE p_res_key+foreign import stdcall unsafe "windows.h RegOpenKeyExW"+ c_RegOpenKeyEx :: PKEY -> LPCTSTR -> DWORD -> REGSAM -> Ptr PKEY -> IO ErrCode++data RegInfoKey =+ RegInfoKey {+ class_string :: String,+ class_id :: Int,+ subkeys :: Word32,+ max_subkey_len :: Word32,+ max_class_len :: Word32,+ values :: Word32,+ max_value_name_len :: Word32,+ max_value_len :: Word32,+ sec_len :: Int,+ lastWrite_lo :: Word32,+ lastWrite_hi :: Word32+ }++regQueryInfoKey :: HKEY -> IO RegInfoKey+regQueryInfoKey key =+ withForeignPtr key $ \ p_key ->+ allocaBytes 100 $ \ c_class_string ->+ alloca $ \ p_class_id ->+ alloca $ \ p_subkeys ->+ alloca $ \ p_max_subkey_len ->+ alloca $ \ p_max_class_len ->+ alloca $ \ p_values ->+ alloca $ \ p_max_value_name_len ->+ alloca $ \ p_max_value_len ->+ alloca $ \ p_sec_len ->+ allocaBytes (#{size FILETIME}) $ \ p_lastWrite -> do+ failUnlessSuccess "RegQueryInfoKey" $+ c_RegQueryInfoKey p_key c_class_string p_class_id nullPtr p_subkeys+ p_max_subkey_len p_max_class_len p_values p_max_value_name_len+ p_max_value_len p_sec_len p_lastWrite+ class_string <- peekTString c_class_string+ class_id <- peek p_class_id+ subkeys <- peek p_subkeys+ max_subkey_len <- peek p_max_subkey_len+ max_class_len <- peek p_max_class_len+ values <- peek p_values+ max_value_name_len <- peek p_max_value_name_len+ max_value_len <- peek p_max_value_len+ sec_len <- peek p_sec_len+ lastWrite_lo <- #{peek FILETIME,dwLowDateTime} p_lastWrite+ lastWrite_hi <- #{peek FILETIME,dwHighDateTime} p_lastWrite+ return $ RegInfoKey+ { class_string = class_string+ , class_id = fromIntegral class_id+ , subkeys = subkeys+ , max_subkey_len = max_subkey_len+ , max_class_len = max_class_len+ , values = values+ , max_value_name_len = max_value_name_len+ , max_value_len = max_value_len+ , sec_len = fromIntegral sec_len+ , lastWrite_lo = lastWrite_lo+ , lastWrite_hi = lastWrite_hi+ }+foreign import stdcall unsafe "windows.h RegQueryInfoKeyW"+ c_RegQueryInfoKey :: PKEY -> LPTSTR -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr DWORD -> Ptr FILETIME -> IO ErrCode++-- RegQueryMultipleValues :: HKEY -> IO ([VALENT],String)++-- RegQueryValue() isn't really that, it just allows you to+-- get at the default values of keys, so we provide our own+-- (and better!) version of it. If you want RegQueryValue()s+-- behaviour, use regQueryValueKey.++regQueryValueKey :: HKEY -> Maybe String -> IO String+regQueryValueKey key mb_subkey =+ withForeignPtr key $ \ p_key ->+ maybeWith withTString mb_subkey $ \ c_subkey ->+ alloca $ \ p_value_len -> do+ failUnlessSuccess "RegQueryValue" $+ c_RegQueryValue p_key c_subkey nullPtr p_value_len+ value_len <- peek p_value_len+ allocaArray0 (fromIntegral value_len) $ \ c_value -> do+ failUnlessSuccess "RegQueryValue" $+ c_RegQueryValue p_key c_subkey c_value p_value_len+ peekTString c_value+foreign import stdcall unsafe "windows.h RegQueryValueW"+ c_RegQueryValue :: PKEY -> LPCTSTR -> LPTSTR -> Ptr LONG -> IO ErrCode++regQueryValue :: HKEY -> Maybe String -> IO String+regQueryValue key mb_subkey =+ withForeignPtr key $ \ p_key ->+ maybeWith withTString mb_subkey $ \ c_subkey ->+ alloca $ \ p_ty ->+ alloca $ \ p_value_len -> do+ failUnlessSuccess "RegQueryValue" $+ c_RegQueryValueEx p_key c_subkey nullPtr p_ty nullPtr p_value_len+ ty <- peek p_ty+ failUnlessSuccess "RegQueryValue" $ return (if ty == rEG_SZ then 0 else 1)+ value_len <- peek p_value_len+ allocaArray0 (fromIntegral value_len) $ \ c_value -> do+ failUnlessSuccess "RegQueryValue" $+ c_RegQueryValueEx p_key c_subkey nullPtr p_ty c_value p_value_len+ peekTString (castPtr c_value)++regQueryValueEx :: HKEY -> String -> LPBYTE -> Int -> IO RegValueType+regQueryValueEx key name value value_len =+ withForeignPtr key $ \ p_key ->+ withTString name $ \ c_name ->+ alloca $ \ p_ty ->+ with (fromIntegral value_len) $ \ p_value_len -> do+ failUnlessSuccess "RegQueryValueEx" $+ c_RegQueryValueEx p_key c_name nullPtr p_ty value p_value_len+ peek p_ty+foreign import stdcall unsafe "windows.h RegQueryValueExW"+ c_RegQueryValueEx :: PKEY -> LPCTSTR -> Ptr DWORD -> Ptr DWORD -> LPBYTE -> Ptr DWORD -> IO ErrCode++regReplaceKey :: HKEY -> String -> String -> String -> IO ()+regReplaceKey key subkey newfile oldfile =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ withTString newfile $ \ c_newfile ->+ withTString oldfile $ \ c_oldfile ->+ failUnlessSuccess "RegReplaceKey" $+ c_RegReplaceKey p_key c_subkey c_newfile c_oldfile+foreign import stdcall unsafe "windows.h RegReplaceKeyW"+ c_RegReplaceKey :: PKEY -> LPCTSTR -> LPCTSTR -> LPCTSTR -> IO ErrCode++type RegRestoreFlags = DWORD++#{enum RegRestoreFlags,+ , rEG_WHOLE_HIVE_VOLATILE = REG_WHOLE_HIVE_VOLATILE+ , rEG_REFRESH_HIVE = REG_REFRESH_HIVE+ , rEG_NO_LAZY_FLUSH = REG_NO_LAZY_FLUSH+ }++regRestoreKey :: HKEY -> String -> RegRestoreFlags -> IO ()+regRestoreKey key file flags =+ withForeignPtr key $ \ p_key ->+ withTString file $ \ c_file ->+ failUnlessSuccess "RegRestoreKey" $ c_RegRestoreKey p_key c_file flags+foreign import stdcall unsafe "windows.h RegRestoreKeyW"+ c_RegRestoreKey :: PKEY -> LPCTSTR -> RegRestoreFlags -> IO ErrCode++regSaveKey :: HKEY -> String -> Maybe LPSECURITY_ATTRIBUTES -> IO ()+regSaveKey key file mb_attr =+ withForeignPtr key $ \ p_key ->+ withTString file $ \ c_file ->+ failUnlessSuccess "RegSaveKey" $ c_RegSaveKey p_key c_file (maybePtr mb_attr)+foreign import stdcall unsafe "windows.h RegSaveKeyW"+ c_RegSaveKey :: PKEY -> LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO ErrCode++-- ifdef FOR_WINDOWS_NT++-- RegSetKeySecurity :: HKEY -> SECURITY_INFORMATION -> SECURITY_DESCRIPTOR -> IO ()++-- endif++-- 3.1 compat. - only allows storage of REG_SZ values.++regSetValue :: HKEY -> String -> String -> IO ()+regSetValue key subkey value =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ withTStringLen value $ \ (c_value, value_len) ->+ failUnlessSuccess "RegSetValue" $+ c_RegSetValue p_key c_subkey rEG_SZ c_value value_len+foreign import stdcall unsafe "windows.h RegSetValueW"+ c_RegSetValue :: PKEY -> LPCTSTR -> DWORD -> LPCTSTR -> Int -> IO ErrCode+++type RegValueType = DWORD++#{enum RegValueType,+ , rEG_BINARY = REG_BINARY+ , rEG_DWORD = REG_DWORD+ , rEG_DWORD_LITTLE_ENDIAN = REG_DWORD_LITTLE_ENDIAN+ , rEG_DWORD_BIG_ENDIAN = REG_DWORD_BIG_ENDIAN+ , rEG_EXPAND_SZ = REG_EXPAND_SZ+ , rEG_LINK = REG_LINK+ , rEG_MULTI_SZ = REG_MULTI_SZ+ , rEG_NONE = REG_NONE+ , rEG_RESOURCE_LIST = REG_RESOURCE_LIST+ , rEG_SZ = REG_SZ+ }++-- regSetValueEx has a somewhat wieldly interface if all you want to do is+-- add a string value (a Common Thing to want to do), so we support this+-- specially:+regSetStringValue :: HKEY -> String -> String -> IO ()+regSetStringValue hk key val =+ withTString val $ \ v ->+ regSetValueEx hk key rEG_SZ v (length val)++regSetValueEx :: HKEY -> String -> RegValueType -> LPTSTR -> Int -> IO ()+regSetValueEx key subkey ty value value_len =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ failUnlessSuccess "RegSetValueEx" $+ c_RegSetValueEx p_key c_subkey 0 ty value value_len+foreign import stdcall unsafe "windows.h RegSetValueExW"+ c_RegSetValueEx :: PKEY -> LPCTSTR -> DWORD -> RegValueType -> LPTSTR -> Int -> IO ErrCode++regUnLoadKey :: HKEY -> String -> IO ()+regUnLoadKey key subkey =+ withForeignPtr key $ \ p_key ->+ withTString subkey $ \ c_subkey ->+ failUnlessSuccess "RegUnLoadKey" $ c_RegUnLoadKey p_key c_subkey+foreign import stdcall unsafe "windows.h RegUnLoadKeyW"+ c_RegUnLoadKey :: PKEY -> LPCTSTR -> IO ErrCode
+ System/Win32/SimpleMAPI.hsc view
@@ -0,0 +1,389 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.SimpleMAPI+-- Copyright : (c) Esa Ilari Vuokko, 2006+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- FFI-bindings to interact with SimpleMAPI+--+-----------------------------------------------------------------------------+module System.Win32.SimpleMAPI+where+import Control.Exception ( bracket, handle, throw, finally )+import Control.Monad ( liftM5 )+import Foreign ( FunPtr, newForeignPtr, pokeByteOff, maybeWith+ , Ptr, castPtr, castPtrToFunPtr, nullPtr+ , touchForeignPtr, alloca, peek, allocaBytes+ , minusPtr, plusPtr, copyBytes, ForeignPtr )+import Foreign.C ( withCString, withCStringLen )+import Graphics.Win32.GDI.Types ( HWND)+import System.Win32.DLL ( loadLibrary, c_GetProcAddress, freeLibrary+ , c_FreeLibraryFinaliser )+import System.Win32.Types ( DWORD, LPSTR, HMODULE, failIfNull )++#include "windows.h"+#include "mapi.h"+++type ULONG = DWORD+type LHANDLE = ULONG+newtype MapiRecipDesc = MapiRecipDesc ()+type MapiFlag = ULONG+#{enum MapiFlag,+ , mAPI_LOGON_UI = MAPI_LOGON_UI+ , mAPI_NEW_SESSION = MAPI_NEW_SESSION+ , mAPI_FORCE_DOWNLOAD = MAPI_FORCE_DOWNLOAD+ , mAPI_LOGOFF_SHARED = MAPI_LOGOFF_SHARED+ , mAPI_LOGOFF_UI = MAPI_LOGOFF_UI+ , mAPI_DIALOG = MAPI_DIALOG+ , mAPI_UNREAD_ONLY = MAPI_UNREAD_ONLY+ , mAPI_LONG_MSGID = MAPI_LONG_MSGID+ , mAPI_GUARANTEE_FIFO = MAPI_GUARANTEE_FIFO+ , mAPI_ENVELOPE_ONLY = MAPI_ENVELOPE_ONLY+ , mAPI_PEEK = MAPI_PEEK+ , mAPI_BODY_AS_FILE = MAPI_BODY_AS_FILE+ , mAPI_SUPPRESS_ATTACH = MAPI_SUPPRESS_ATTACH+ , mAPI_AB_NOMODIFY = MAPI_AB_NOMODIFY+ , mAPI_OLE = MAPI_OLE+ , mAPI_OLE_STATIC = MAPI_OLE_STATIC+ , mAPI_UNREAD = MAPI_UNREAD+ , mAPI_RECEIPT_REQUESTED = MAPI_RECEIPT_REQUESTED+ , mAPI_SENT = MAPI_SENT+ }++mapiErrors :: [(ULONG,String)]+mapiErrors =+ [ ((#const SUCCESS_SUCCESS) , "Success")+ , ((#const MAPI_E_FAILURE) , "Generic error or multiple errors")+ , ((#const MAPI_E_USER_ABORT) , "User aborted")+ , ((#const MAPI_E_LOGIN_FAILURE) , "Logoff failed")+ , ((#const MAPI_E_LOGON_FAILURE) , "Logon failed")+ , ((#const MAPI_E_DISK_FULL) , "Disk full")+ , ((#const MAPI_E_INSUFFICIENT_MEMORY) , "Not enough memory")+ , ((#const MAPI_E_ACCESS_DENIED) , "Access denied")+ , ((#const MAPI_E_BLK_TOO_SMALL) , "BLK_TOO_SMALL")+ , ((#const MAPI_E_TOO_MANY_SESSIONS), "Too many open sessions")+ , ((#const MAPI_E_TOO_MANY_FILES) , "Too many open files")+ , ((#const MAPI_E_TOO_MANY_RECIPIENTS) , "Too many recipients")+ , ((#const MAPI_E_ATTACHMENT_NOT_FOUND) , "Attachemnt not found")+ , ((#const MAPI_E_ATTACHMENT_OPEN_FAILURE) , "Couldn't open attachment")+ , ((#const MAPI_E_ATTACHMENT_WRITE_FAILURE) , "Couldn't write attachment")+ , ((#const MAPI_E_UNKNOWN_RECIPIENT) , "Unknown recipient")+ , ((#const MAPI_E_BAD_RECIPTYPE) , "Bad recipient type")+ , ((#const MAPI_E_NO_MESSAGES) , "No messages")+ , ((#const MAPI_E_INVALID_MESSAGE) , "Invalid message")+ , ((#const MAPI_E_TEXT_TOO_LARGE) , "Text too large")+ , ((#const MAPI_E_INVALID_SESSION) , "Invalid session")+ , ((#const MAPI_E_TYPE_NOT_SUPPORTED) , "Type not supported")+ , ((#const MAPI_E_AMBIGUOUS_RECIPIENT) , "Ambigious recipient")+ , ((#const MAPI_E_AMBIGUOUS_RECIP) , "Ambigious recipient")+ , ((#const MAPI_E_MESSAGE_IN_USE) , "Message in use")+ , ((#const MAPI_E_NETWORK_FAILURE) , "Network failure")+ , ((#const MAPI_E_INVALID_EDITFIELDS) , "Invalid editfields")+ , ((#const MAPI_E_INVALID_RECIPS) , "Invalid recipient(s)")+ , ((#const MAPI_E_NOT_SUPPORTED) , "Not supported")+ ]++mapiErrorString :: ULONG -> String+mapiErrorString c = case lookup c mapiErrors of+ Nothing -> "Unkown error (" ++ show c ++ ")"+ Just x -> x++mapiFail :: String -> IO ULONG -> IO ULONG+mapiFail name act = act >>= \err -> if err==(#const SUCCESS_SUCCESS)+ then return err+ else fail $ name ++ ": " ++ mapiErrorString err+++mapiFail_ :: String -> IO ULONG -> IO ()+mapiFail_ n a = mapiFail n a >> return ()++type MapiLogonType = ULONG -> LPSTR -> LPSTR -> MapiFlag -> ULONG -> Ptr LHANDLE -> IO ULONG+foreign import stdcall "dynamic" mkMapiLogon :: FunPtr MapiLogonType -> MapiLogonType++type MapiLogoffType = LHANDLE -> ULONG -> MapiFlag -> ULONG -> IO ULONG+foreign import stdcall "dynamic" mkMapiLogoff :: FunPtr MapiLogoffType -> MapiLogoffType++type MapiResolveNameType =+ LHANDLE -> ULONG -> LPSTR -> MapiFlag -> ULONG+ -> Ptr (Ptr MapiRecipDesc) -> IO ULONG+foreign import stdcall "dynamic" mkMapiResolveName :: FunPtr MapiResolveNameType -> MapiResolveNameType++type MapiFreeBufferType = Ptr () -> IO ULONG+foreign import stdcall "dynamic" mkMapiFreeBuffer :: FunPtr MapiFreeBufferType -> MapiFreeBufferType++type MapiSendMailType = LHANDLE -> ULONG -> Ptr Message -> MapiFlag -> ULONG -> IO ULONG+foreign import stdcall "dynamic" mkMapiSendMail :: FunPtr MapiSendMailType -> MapiSendMailType++data MapiFuncs = MapiFuncs+ { mapifLogon :: MapiLogonType+ , mapifLogoff :: MapiLogoffType+ , mapifResolveName :: MapiResolveNameType+ , mapifFreeBuffer :: MapiFreeBufferType+ , mapifSendMail :: MapiSendMailType+ }++type MapiLoaded = (MapiFuncs, ForeignPtr ())+++-- |+loadMapiFuncs :: String -> HMODULE -> IO MapiFuncs+loadMapiFuncs dllname dll = liftM5 MapiFuncs+ (loadProc "MAPILogon" dll mkMapiLogon)+ (loadProc "MAPILogoff" dll mkMapiLogoff)+ (loadProc "MAPIResolveName" dll mkMapiResolveName)+ (loadProc "MAPIFreeBuffer" dll mkMapiFreeBuffer)+ (loadProc "MAPISendMail" dll mkMapiSendMail)+ where+ loadProc name dll conv = withCString name $ \name' -> do+ proc <- failIfNull ("loadMapiDll: " ++ dllname ++ ": " ++ name)+ $ c_GetProcAddress dll name'+ return $ conv $ castPtrToFunPtr proc+-- |+loadMapiDll :: String -> IO (MapiFuncs, HMODULE)+loadMapiDll dllname = do+ dll <- loadLibrary dllname+ handle (\e -> freeLibrary dll >> throw e) $ do+ funcs <- loadMapiFuncs dllname dll+ return (funcs, dll)++-- |+withMapiFuncs :: [String] -> (MapiFuncs -> IO a) -> IO a+withMapiFuncs dlls act = bracket load free (act . fst)+ where+ loadOne l = case l of+ [] -> fail $ "withMapiFuncs: Failed to load DLLs: " ++ show dlls+ x:y -> handle (const $ loadOne y) (loadMapiDll x)+ load = loadOne dlls+ free = freeLibrary . snd++-- |+loadMapi :: [String] -> IO MapiLoaded+loadMapi dlls = do+ (f,m) <- loadOne dlls+ m' <- newForeignPtr c_FreeLibraryFinaliser m+ return (f,m')+ where+ loadOne l = case l of+ [] -> fail $ "loadMapi: Failed to load any of DLLs: " ++ show dlls+ x:y -> handle (const $ loadOne y) (loadMapiDll x)++-- |+withMapiLoaded :: MapiLoaded -> (MapiFuncs -> IO a) -> IO a+withMapiLoaded (f,m) act = finally (act f) (touchForeignPtr m)++maybeHWND :: Maybe HWND -> ULONG+maybeHWND = maybe 0 (fromIntegral . flip minusPtr nullPtr)++-- | Create Simple MAPI-session by logon+mapiLogon+ :: MapiFuncs -- ^ Functions loaded from MAPI DLL+ -> Maybe HWND -- ^ Parent window, used for modal logon dialog+ -> Maybe String -- ^ Session+ -> Maybe String -- ^ Password+ -> MapiFlag -- ^ None, one or many flags: FORCE_DOWNLOAD, NEW_SESSION, LOGON_UI, PASSWORD_UI+ -> IO LHANDLE+mapiLogon f hwnd ses pw flags =+ maybeWith withCString ses $ \ses ->+ maybeWith withCString pw $ \pw ->+ alloca $ \out -> do+ mapiFail "MAPILogon: " $ mapifLogon+ f (maybeHWND hwnd) + ses pw flags 0 out+ peek out++-- | End Simple MAPI-session+mapiLogoff+ :: MapiFuncs+ -> LHANDLE+ -> Maybe HWND+ -> IO ()+mapiLogoff f ses hwnd+ = mapiFail_ "MAPILogoff"+ $ mapifLogoff f ses (maybeHWND hwnd) 0 0+++data RecipientClass = RcOriginal | RcTo | RcCc | RcBcc+ deriving (Show, Eq, Ord, Enum)++rcToULONG :: RecipientClass -> ULONG+rcToULONG = fromIntegral . fromEnum++uLONGToRc :: ULONG -> RecipientClass+uLONGToRc = toEnum . fromIntegral+++data Recipient+ = RecipResolve (Maybe HWND) MapiFlag String (Maybe Recipient)+ | Recip String String+ deriving (Show)+type Recipients = [(RecipientClass, Recipient)]++simpleRecip :: String -> Recipient+simpleRecip s = RecipResolve Nothing 0 s $ Just $ Recip s s++withRecipient+ :: MapiFuncs+ -> LHANDLE+ -> RecipientClass+ -> Recipient+ -> (Ptr MapiRecipDesc -> IO a)+ -> IO a+withRecipient f ses rcls rec act = resolve "" rec+ where+ a buf = do+ (#poke MapiRecipDesc, ulRecipClass) buf (rcToULONG rcls)+ act buf+ resolve err rc = case rc of+ Recip name addr ->+ withCString name $ \name ->+ withCString addr $ \addr ->+ allocaBytes (#size MapiRecipDesc) $ \buf -> do+ (#poke MapiRecipDesc, ulReserved) buf (0::ULONG)+ (#poke MapiRecipDesc, lpszName) buf name+ (#poke MapiRecipDesc, lpszAddress) buf addr+ (#poke MapiRecipDesc, ulEIDSize) buf (0::ULONG)+ (#poke MapiRecipDesc, lpEntryID) buf nullPtr+ a buf+ RecipResolve hwnd flag name fallback -> do+ res <- alloca $ \res ->+ withCString name $ \name' -> do+ errn <- mapifResolveName+ f ses (maybeHWND hwnd) name' flag 0 res+ if errn==(#const SUCCESS_SUCCESS)+ then do+ buf <- peek res+ v <- a buf+ mapifFreeBuffer f $ castPtr buf+ return $ Right v+ else return $ Left+ $ err ++ ", "+ ++ name ++ ":" ++ mapiErrorString errn+ case res of+ Left e -> case fallback of+ Nothing -> fail $ "Failed to resolve any of the recipients: " ++ e+ Just x -> resolve e x+ Right x -> return x++withRecipients+ :: MapiFuncs+ -> LHANDLE+ -> Recipients+ -> (Int -> Ptr MapiRecipDesc -> IO a)+ -> IO a+withRecipients f ses rec act = w [] rec+ where+ w res [] = allocaBytes (length res*rs) $ \buf -> do+ mapM_ (write buf) $ zip [0..] $ reverse res+ act (length res) buf+ w res ((c,r):y) = withRecipient f ses c r $ \x -> w (x:res) y+ rs = (#size MapiRecipDesc)+ write buf (off,src) = do+ let buf' = plusPtr buf (off*rs)+ copyBytes buf' src rs++data FileTag = FileTag+ { ftTag :: Maybe String -- ^ mime+ , ftEncoding :: Maybe String+ } deriving (Show)++defFileTag :: FileTag+defFileTag = FileTag Nothing Nothing++withFileTag :: FileTag -> (Ptr FileTag -> IO a) -> IO a+withFileTag ft act =+ allocaBytes (#size MapiFileTagExt) $ \buf ->+ w (ftTag ft) $ \(tbuf,tsiz) ->+ w (ftEncoding ft) $ \(ebuf,esiz) -> do+ (#poke MapiFileTagExt, ulReserved) buf (0::ULONG)+ (#poke MapiFileTagExt, cbTag) buf tsiz+ (#poke MapiFileTagExt, lpTag) buf tbuf+ (#poke MapiFileTagExt, cbEncoding) buf esiz+ (#poke MapiFileTagExt, lpEncoding) buf ebuf+ act buf+ where+ w v a = case v of+ Nothing -> a (nullPtr, 0)+ Just x -> withCStringLen x a++data Attachment = Attachment+ { attFlag :: MapiFlag+ , attPosition :: Maybe ULONG+ , attPath :: String+ , attName :: Maybe String+ , attTag :: Maybe FileTag+ } deriving (Show)+defAttachment :: Attachment+defAttachment = Attachment 0 Nothing "" Nothing Nothing+type Attachments = [Attachment]++withAttachments :: Attachments -> (Int -> Ptr Attachment -> IO a) -> IO a+withAttachments att act = allocaBytes (len*as) $ \buf -> write (act len buf) buf att+ where+ as = (#size MapiFileDesc)+ len = length att+ write act _ [] = act+ write act buf (att:y) =+ withCString (attPath att) $ \path ->+ maybeWith withFileTag (attTag att) $ \tag ->+ withCString (maybe (attPath att) id (attName att)) $ \name -> do+ (#poke MapiFileDesc, ulReserved) buf (0::ULONG)+ (#poke MapiFileDesc, flFlags) buf (attFlag att)+ (#poke MapiFileDesc, nPosition) buf (maybe 0xffffffff id $ attPosition att)+ (#poke MapiFileDesc, lpszPathName) buf path+ (#poke MapiFileDesc, lpszFileName) buf name+ (#poke MapiFileDesc, lpFileType) buf tag+ write act (plusPtr buf as) y++data Message = Message+ { msgSubject :: String+ , msgBody :: String+ , msgType :: Maybe String+ , msgDate :: Maybe String+ , msgConversationId :: Maybe String+ , msgFlags :: MapiFlag+ , msgFrom :: Maybe Recipient+ , msgRecips :: Recipients+ , msgAttachments :: Attachments+ } deriving (Show)++defMessage :: Message+defMessage = Message "" "" Nothing Nothing Nothing 0 Nothing [] []++withMessage+ :: MapiFuncs+ -> LHANDLE+ -> Message+ -> (Ptr Message -> IO a)+ -> IO a+withMessage f ses m act =+ withCString (msgSubject m) $ \subject ->+ withCString (msgBody m) $ \body ->+ maybeWith withCString (msgType m) $ \message_type ->+ maybeWith withCString (msgDate m) $ \date ->+ maybeWith withCString (msgConversationId m) $ \conv_id ->+ withRecipients f ses (msgRecips m) $ \rlen rbuf ->+ withAttachments (msgAttachments m) $ \alen abuf ->+ maybeWith (withRecipient f ses RcOriginal) (msgFrom m) $ \from ->+ allocaBytes (#size MapiMessage) $ \buf -> do+ (#poke MapiMessage, ulReserved) buf (0::ULONG)+ (#poke MapiMessage, lpszSubject) buf subject+ (#poke MapiMessage, lpszNoteText) buf body+ (#poke MapiMessage, lpszMessageType) buf message_type+ (#poke MapiMessage, lpszDateReceived) buf date+ (#poke MapiMessage, lpszConversationID) buf conv_id+ (#poke MapiMessage, flFlags) buf (msgFlags m)+ (#poke MapiMessage, lpOriginator) buf from+ (#poke MapiMessage, nRecipCount) buf (fromIntegral rlen :: ULONG)+ (#poke MapiMessage, lpRecips) buf rbuf+ (#poke MapiMessage, nFileCount) buf alen+ (#poke MapiMessage, lpFiles) buf abuf+ act buf++mapiSendMail :: MapiFuncs -> LHANDLE -> Maybe HWND -> Message -> MapiFlag -> IO ()+mapiSendMail f ses hwnd msg flag = withMessage f ses msg $ \msg ->+ mapiFail_ "MAPISendMail" $ mapifSendMail f ses (maybeHWND hwnd) msg flag 0
+ System/Win32/Time.hsc view
@@ -0,0 +1,305 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.Time+-- Copyright : (c) Esa Ilari Vuokko, 2006+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32 Time API.+--+-----------------------------------------------------------------------------+module System.Win32.Time where++import System.Win32.Types ( DWORD, WORD, LONG, BOOL, failIf, failIf_, HANDLE+ , peekTStringLen, LCID, LPTSTR, LPCTSTR, DDWORD+ , LARGE_INTEGER, ddwordToDwords, dwordsToDdword )++import Control.Monad ( when, liftM3, liftM )+import Data.Word ( Word8 )+import Foreign ( Storable(sizeOf, alignment, peekByteOff, peek,+ pokeByteOff, poke)+ , Ptr, nullPtr, castPtr, plusPtr, advancePtr+ , with, alloca, allocaBytes, copyArray )+import Foreign.C ( CInt, CWchar+ , peekCWString, withCWStringLen, withCWString )++#include "windows.h"++----------------------------------------------------------------+-- data types+----------------------------------------------------------------++newtype FILETIME = FILETIME DDWORD deriving (Show, Eq, Ord)++data SYSTEMTIME = SYSTEMTIME {+ wYear, wMonth, wDayOfWeek, wDay, wHour, wMinute, wSecond, wMilliseconds :: WORD }+ deriving (Show, Eq, Ord)++data TIME_ZONE_INFORMATION = TIME_ZONE_INFORMATION+ { tziBias :: LONG+ , tziStandardName :: String+ , tziStandardDate :: SYSTEMTIME+ , tziStandardBias :: LONG+ , tziDaylightName :: String+ , tziDaylightDate :: SYSTEMTIME+ , tziDaylightBias :: LONG+ } deriving (Show,Eq,Ord)++data TimeZoneId = TzIdUnknown | TzIdStandard | TzIdDaylight+ deriving (Show, Eq, Ord)++----------------------------------------------------------------+-- Instances+----------------------------------------------------------------++instance Storable FILETIME where+ sizeOf = const (#size FILETIME)+ alignment = sizeOf+ poke buf (FILETIME n) = do+ (#poke FILETIME, dwLowDateTime) buf low+ (#poke FILETIME, dwHighDateTime) buf hi+ where (hi,low) = ddwordToDwords n+ peek buf = do+ low <- (#peek FILETIME, dwLowDateTime) buf+ hi <- (#peek FILETIME, dwHighDateTime) buf+ return $ FILETIME $ dwordsToDdword (hi,low)++instance Storable SYSTEMTIME where+ sizeOf _ = #size SYSTEMTIME+ alignment = sizeOf+ poke buf st = do+ (#poke SYSTEMTIME, wYear) buf (wYear st)+ (#poke SYSTEMTIME, wMonth) buf (wMonth st)+ (#poke SYSTEMTIME, wDayOfWeek) buf (wDayOfWeek st)+ (#poke SYSTEMTIME, wDay) buf (wDay st)+ (#poke SYSTEMTIME, wHour) buf (wHour st)+ (#poke SYSTEMTIME, wMinute) buf (wMinute st)+ (#poke SYSTEMTIME, wSecond) buf (wSecond st)+ (#poke SYSTEMTIME, wMilliseconds) buf (wMilliseconds st)+ peek buf = do+ year <- (#peek SYSTEMTIME, wYear) buf+ month <- (#peek SYSTEMTIME, wMonth) buf+ dow <- (#peek SYSTEMTIME, wDayOfWeek) buf+ day <- (#peek SYSTEMTIME, wDay) buf+ hour <- (#peek SYSTEMTIME, wHour) buf+ min <- (#peek SYSTEMTIME, wMinute) buf+ sec <- (#peek SYSTEMTIME, wSecond) buf+ ms <- (#peek SYSTEMTIME, wMilliseconds) buf+ return $ SYSTEMTIME year month dow day hour min sec ms++instance Storable TIME_ZONE_INFORMATION where+ sizeOf _ = (#size TIME_ZONE_INFORMATION)+ alignment = sizeOf+ poke buf tzi = do+ (#poke TIME_ZONE_INFORMATION, Bias) buf (tziBias tzi)+ (#poke TIME_ZONE_INFORMATION, StandardDate) buf (tziStandardDate tzi)+ (#poke TIME_ZONE_INFORMATION, StandardBias) buf (tziStandardBias tzi)+ (#poke TIME_ZONE_INFORMATION, DaylightDate) buf (tziDaylightDate tzi)+ (#poke TIME_ZONE_INFORMATION, DaylightBias) buf (tziDaylightBias tzi)+ write buf (#offset TIME_ZONE_INFORMATION, StandardName) (tziStandardName tzi)+ write buf (#offset TIME_ZONE_INFORMATION, DaylightName) (tziDaylightName tzi)+ where+ write buf offset str = withCWStringLen str $ \(str,len) -> do+ when (len>31) $ fail "Storable TIME_ZONE_INFORMATION.poke: Too long string."+ let start = (advancePtr (castPtr buf) offset)+ end = advancePtr start len+ copyArray (castPtr str :: Ptr Word8) start len+ poke end 0+ peek buf = do+ bias <- (#peek TIME_ZONE_INFORMATION, Bias) buf+ sdat <- (#peek TIME_ZONE_INFORMATION, StandardDate) buf+ sbia <- (#peek TIME_ZONE_INFORMATION, StandardBias) buf+ ddat <- (#peek TIME_ZONE_INFORMATION, DaylightDate) buf+ dbia <- (#peek TIME_ZONE_INFORMATION, DaylightBias) buf+ snam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, StandardName))+ dnam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, DaylightName))+ return $ TIME_ZONE_INFORMATION bias snam sdat sbia dnam ddat dbia++foreign import stdcall "windows.h GetSystemTime"+ c_GetSystemTime :: Ptr SYSTEMTIME -> IO ()+getSystemTime :: IO SYSTEMTIME+getSystemTime = alloca $ \res -> do+ c_GetSystemTime res+ peek res++foreign import stdcall "windows.h SetSystemTime"+ c_SetSystemTime :: Ptr SYSTEMTIME -> IO BOOL+setSystemTime :: SYSTEMTIME -> IO ()+setSystemTime st = with st $ \st -> failIf_ not "setSystemTime: SetSystemTime" $+ c_SetSystemTime st++foreign import stdcall "windows.h GetSystemTimeAsFileTime"+ c_GetSystemTimeAsFileTime :: Ptr FILETIME -> IO ()+getSystemTimeAsFileTime :: IO FILETIME+getSystemTimeAsFileTime = alloca $ \ret -> do+ c_GetSystemTimeAsFileTime ret+ peek ret++foreign import stdcall "windows.h GetLocalTime"+ c_GetLocalTime :: Ptr SYSTEMTIME -> IO ()+getLocalTime :: IO SYSTEMTIME+getLocalTime = alloca $ \res -> do+ c_GetLocalTime res+ peek res++foreign import stdcall "windows.h SetLocalTime"+ c_SetLocalTime :: Ptr SYSTEMTIME -> IO BOOL+setLocalTime :: SYSTEMTIME -> IO ()+setLocalTime st = with st $ \st -> failIf_ not "setLocalTime: SetLocalTime" $+ c_SetLocalTime st++foreign import stdcall "windows.h GetSystemTimeAdjustment"+ c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL+getSystemTimeAdjustment :: IO (Maybe (Int, Int))+getSystemTimeAdjustment = alloca $ \ta -> alloca $ \ti -> alloca $ \enabled -> do+ failIf not "getSystemTimeAdjustment: GetSystemTimeAdjustment" $+ c_GetSystemTimeAdjustment ta ti enabled+ enabled <- peek enabled+ if enabled+ then do+ ta <- peek ta+ ti <- peek ti+ return $ Just (fromIntegral ta, fromIntegral ti)+ else return Nothing++foreign import stdcall "windows.h GetTickCount" getTickCount :: IO DWORD++foreign import stdcall "windows.h SetSystemTimeAdjustment"+ c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL+setSystemTimeAdjustment :: Maybe Int -> IO ()+setSystemTimeAdjustment ta =+ failIf_ not "setSystemTimeAjustment: SetSystemTimeAdjustment" $+ c_SetSystemTimeAdjustment time disabled+ where+ (time,disabled) = case ta of+ Nothing -> (0,True)+ Just x -> (fromIntegral x,False)++foreign import stdcall "windows.h GetTimeZoneInformation"+ c_GetTimeZoneInformation :: Ptr TIME_ZONE_INFORMATION -> IO DWORD+getTimeZoneInformation :: IO (TimeZoneId, TIME_ZONE_INFORMATION)+getTimeZoneInformation = alloca $ \tzi -> do+ tz <- failIf (==(#const TIME_ZONE_ID_INVALID)) "getTimeZoneInformation: GetTimeZoneInformation" $+ c_GetTimeZoneInformation tzi+ tzi <- peek tzi+ return . flip (,) tzi $ case tz of+ (#const TIME_ZONE_ID_UNKNOWN) -> TzIdUnknown+ (#const TIME_ZONE_ID_STANDARD) -> TzIdStandard+ (#const TIME_ZONE_ID_DAYLIGHT) -> TzIdDaylight+ _ -> TzIdUnknown -- to remove warning++foreign import stdcall "windows.h SystemTimeToFileTime"+ c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL+systemTimeToFileTime :: SYSTEMTIME -> IO FILETIME+systemTimeToFileTime s = with s $ \s -> alloca $ \ret -> do+ failIf not "systemTimeToFileTime: SystemTimeToFileTime" $+ c_SystemTimeToFileTime s ret+ peek ret++foreign import stdcall "windows.h FileTimeToSystemTime"+ c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL+fileTimeToSystemTime :: FILETIME -> IO SYSTEMTIME+fileTimeToSystemTime s = with s $ \s -> alloca $ \ret -> do+ failIf not "fileTimeToSystemTime: FileTimeToSystemTime" $+ c_FileTimeToSystemTime s ret+ peek ret++foreign import stdcall "windows.h GetFileTime"+ c_GetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL+getFileTime :: HANDLE -> IO (FILETIME,FILETIME,FILETIME)+getFileTime h = alloca $ \crt -> alloca $ \acc -> alloca $ \wrt -> do+ failIf not "getFileTime: GetFileTime" $ c_GetFileTime h crt acc wrt+ liftM3 (,,) (peek crt) (peek acc) (peek wrt)++foreign import stdcall "windows.h SetFileTime"+ c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL+setFileTime :: HANDLE -> FILETIME -> FILETIME -> FILETIME -> IO ()+setFileTime h crt acc wrt = with crt $ \crt -> with acc $ \acc -> with wrt $ \wrt -> do+ failIf not "setFileTime: SetFileTime" $ c_SetFileTime h crt acc wrt+ return ()++foreign import stdcall "windows.h FileTimeToLocalFileTime"+ c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL+fileTimeToLocalFileTime :: FILETIME -> IO FILETIME+fileTimeToLocalFileTime ft = with ft $ \ft -> alloca $ \res -> do+ failIf not "fileTimeToLocalFileTime: FileTimeToLocalFileTime"+ $ c_FileTimeToLocalFileTime ft res+ peek res++foreign import stdcall "windows.h LocalFileTimeToFileTime"+ c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL+localFileTimeToFileTime :: FILETIME -> IO FILETIME+localFileTimeToFileTime ft = with ft $ \ft -> alloca $ \res -> do+ failIf not "localFileTimeToFileTime: LocalFileTimeToFileTime"+ $ c_LocalFileTimeToFileTime ft res+ peek res++{-+-- Windows XP SP1+foreign import stdcall "windows.h GetSystemTimes"+ c_GetSystemTimes :: Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL+getSystemTimes :: IO (FILETIME,FILETIME,FILETIME)+getSystemTimes = alloca $ \idle -> alloca $ \kernel -> alloca $ \user -> do+ failIf not "getSystemTimes: GetSystemTimes" $ c_GetSystemTimes idle kernel user+ liftM3 (,,) (peek idle) (peek kernel) (peek user)+-}++{-+-- Windows XP+foreign import stdcall "windows.h SystemTimeToTzSpecificLocalTime"+ c_SystemTimeToTzSpecificLocalTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL+systemTimeToTzSpecificLocalTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME+systemTimeToTzSpecificLocalTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do+ failIf not "systemTimeToTzSpecificLocalTime: SystemTimeToTzSpecificLocalTime" $+ c_SystemTimeToTzSpecificLocalTime tzi st res+ peek res++foreign import stdcall "windows.h TzSpecificLocalTimeToSystemTime"+ c_TzSpecificLocalTimeToSystemTime :: Ptr TIME_ZONE_INFORMATION -> Ptr SYSTEMTIME -> Ptr SYSTEMTIME -> IO BOOL+tzSpecificLocalTimeToSystemTime :: TIME_ZONE_INFORMATION -> SYSTEMTIME -> IO SYSTEMTIME+tzSpecificLocalTimeToSystemTime tzi st = with tzi $ \tzi -> with st $ \st -> alloca $ \res -> do+ failIf not "tzSpecificLocalTimeToSystemTime: TzSpecificLocalTimeToSystemTime" $+ c_TzSpecificLocalTimeToSystemTime tzi st res+ peek res+-}++foreign import stdcall "windows.h QueryPerformanceFrequency"+ c_QueryPerformanceFrequency :: Ptr LARGE_INTEGER -> IO BOOL+queryPerformanceFrequency :: IO Integer+queryPerformanceFrequency = alloca $ \res -> do+ failIf not "queryPerformanceFrequency: QueryPerformanceFrequency" $+ c_QueryPerformanceFrequency res+ liftM fromIntegral $ peek res++foreign import stdcall "windows.h QueryPerformanceCounter"+ c_QueryPerformanceCounter:: Ptr LARGE_INTEGER -> IO BOOL+queryPerformanceCounter:: IO Integer+queryPerformanceCounter= alloca $ \res -> do+ failIf not "queryPerformanceCounter: QueryPerformanceCounter" $+ c_QueryPerformanceCounter res+ liftM fromIntegral $ peek res++type GetTimeFormatFlags = DWORD+#{enum GetTimeFormatFlags,+ , lOCALE_NOUSEROVERRIDE = LOCALE_NOUSEROVERRIDE+ , lOCALE_USE_CP_ACP = LOCALE_USE_CP_ACP+ , tIME_NOMINUTESORSECONDS = TIME_NOMINUTESORSECONDS+ , tIME_NOSECONDS = TIME_NOSECONDS+ , tIME_NOTIMEMARKER = TIME_NOTIMEMARKER+ , tIME_FORCE24HOURFORMAT= TIME_FORCE24HOURFORMAT+ }++foreign import stdcall "windows.h GetTimeFormatW"+ c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt+getTimeFormat :: LCID -> GetTimeFormatFlags -> SYSTEMTIME -> String -> IO String+getTimeFormat locale flags st fmt =+ with st $ \st ->+ withCWString fmt $ \fmt -> do+ size <- c_GetTimeFormat locale flags st fmt nullPtr 0+ allocaBytes ((fromIntegral size) * (sizeOf (undefined::CWchar))) $ \out -> do+ size <- failIf (==0) "getTimeFormat: GetTimeFormat" $+ c_GetTimeFormat locale flags st fmt (castPtr out) (fromIntegral size)+ peekTStringLen (out,fromIntegral size)
+ System/Win32/Types.hs view
@@ -0,0 +1,278 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Win32.Types+-- Copyright : (c) Alastair Reid, 1997-2003+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info>+-- Stability : provisional+-- Portability : portable+--+-- A collection of FFI declarations for interfacing with Win32.+--+-----------------------------------------------------------------------------++module System.Win32.Types+ ( module System.Win32.Types+ , nullPtr+ ) where++import Data.Maybe+import Foreign+import Foreign.C+import Numeric (showHex)++----------------------------------------------------------------+-- Platform specific definitions+--+-- Most typedefs and prototypes in Win32 are expressed in terms+-- of these types. Try to follow suit - it'll make it easier to+-- get things working on Win64 (or whatever they call it on Alphas).+----------------------------------------------------------------++type BOOL = Bool+type BYTE = Word8+type USHORT = Word16+type UINT = Word32+type INT = Int32+type WORD = Word16+type DWORD = Word32+type LONG = Int32+type FLOAT = Float+type LARGE_INTEGER = Int64++-- Not really a basic type, but used in many places+type DDWORD = Word64++----------------------------------------------------------------++type MbString = Maybe String+type MbINT = Maybe INT++type ATOM = UINT+type WPARAM = UINT+type LPARAM = LONG+type LRESULT = LONG+type SIZE_T = DWORD++type MbATOM = Maybe ATOM++----------------------------------------------------------------+-- Pointers+----------------------------------------------------------------++type Addr = Ptr ()++type LPVOID = Ptr ()+type LPBYTE = Ptr BYTE+type LPSTR = Ptr CChar+type LPCSTR = LPSTR+type LPWSTR = Ptr CWchar+type LPCWSTR = LPWSTR+type LPTSTR = Ptr TCHAR+type LPCTSTR = LPTSTR+type LPCTSTR_ = LPCTSTR++-- Optional things with defaults++maybePtr :: Maybe (Ptr a) -> Ptr a+maybePtr = fromMaybe nullPtr++ptrToMaybe :: Ptr a -> Maybe (Ptr a)+ptrToMaybe p = if p == nullPtr then Nothing else Just p++maybeNum :: Num a => Maybe a -> a+maybeNum = fromMaybe 0++numToMaybe :: Num a => a -> Maybe a+numToMaybe n = if n == 0 then Nothing else Just n++type MbLPVOID = Maybe LPVOID+type MbLPCSTR = Maybe LPCSTR+type MbLPCTSTR = Maybe LPCTSTR++----------------------------------------------------------------+-- Chars and strings+----------------------------------------------------------------++withTString :: String -> (LPTSTR -> IO a) -> IO a+withTStringLen :: String -> ((LPTSTR, Int) -> IO a) -> IO a+peekTString :: LPCTSTR -> IO String+peekTStringLen :: (LPCTSTR, Int) -> IO String+newTString :: String -> IO LPCTSTR++-- UTF-16 version:+type TCHAR = CWchar+withTString = withCWString+withTStringLen = withCWStringLen+peekTString = peekCWString+peekTStringLen = peekCWStringLen+newTString = newCWString++{- ANSI version:+type TCHAR = CChar+withTString = withCString+withTStringLen = withCStringLen+peekTString = peekCString+peekTStringLen = peekCStringLen+newTString = newCString+-}++----------------------------------------------------------------+-- Handles+----------------------------------------------------------------++type HANDLE = Ptr ()+type ForeignHANDLE = ForeignPtr ()++newForeignHANDLE :: HANDLE -> IO ForeignHANDLE+newForeignHANDLE = newForeignPtr deleteObject_p++handleToWord :: HANDLE -> UINT+handleToWord = castPtrToUINT++type HKEY = ForeignHANDLE+type PKEY = HANDLE++nullHANDLE :: HANDLE+nullHANDLE = nullPtr++type MbHANDLE = Maybe HANDLE++type HINSTANCE = Ptr ()+type MbHINSTANCE = Maybe HINSTANCE++type HMODULE = Ptr ()+type MbHMODULE = Maybe HMODULE++nullFinalHANDLE :: ForeignPtr a+nullFinalHANDLE = unsafePerformIO (newForeignPtr_ nullPtr)++iNVALID_HANDLE_VALUE :: HANDLE+iNVALID_HANDLE_VALUE = castUINTToPtr 0xffffffff++----------------------------------------------------------------+-- Errors+----------------------------------------------------------------++type ErrCode = DWORD++failIf :: (a -> Bool) -> String -> IO a -> IO a+failIf p wh act = do+ v <- act+ if p v then errorWin wh else return v++failIf_ :: (a -> Bool) -> String -> IO a -> IO ()+failIf_ p wh act = do+ v <- act+ if p v then errorWin wh else return ()++failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)+failIfNull = failIf (== nullPtr)++failIfZero :: Num a => String -> IO a -> IO a+failIfZero = failIf (== 0)++failIfFalse_ :: String -> IO Bool -> IO ()+failIfFalse_ = failIf_ not++failUnlessSuccess :: String -> IO ErrCode -> IO ()+failUnlessSuccess fn_name act = do+ r <- act+ if r == 0 then return () else failWith fn_name r++failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool+failUnlessSuccessOr val fn_name act = do+ r <- act+ if r == 0 then return False+ else if r == val then return True+ else failWith fn_name r++errorWin :: String -> IO a+errorWin fn_name = do+ err_code <- getLastError+ failWith fn_name err_code++failWith :: String -> ErrCode -> IO a+failWith fn_name err_code = do+ c_msg <- getErrorMessage err_code+ msg <- peekTString c_msg+ localFree c_msg+ fail (fn_name ++ ": " ++ msg ++ " (error code: " ++ showHex err_code ")")++----------------------------------------------------------------+-- Misc helpers+----------------------------------------------------------------++ddwordToDwords :: DDWORD -> (DWORD,DWORD)+ddwordToDwords n =+ (fromIntegral (n `shiftR` bitSize (undefined::DWORD))+ ,fromIntegral (n .&. fromIntegral (maxBound :: DWORD)))++dwordsToDdword:: (DWORD,DWORD) -> DDWORD+dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL`bitSize hi)++----------------------------------------------------------------+-- Primitives+----------------------------------------------------------------++foreign import stdcall unsafe "windows.h &DeleteObject"+ deleteObject_p :: FunPtr (HANDLE -> IO ())++foreign import stdcall unsafe "windows.h LocalFree"+ localFree :: Ptr a -> IO (Ptr a)++foreign import stdcall unsafe "windows.h GetLastError"+ getLastError :: IO ErrCode++{-# CFILES cbits/errors.c #-}++foreign import ccall unsafe "errors.h"+ getErrorMessage :: DWORD -> IO LPWSTR++{-# CFILES cbits/HsWin32.c #-}++foreign import ccall unsafe "HsWin32.h"+ lOWORD :: DWORD -> WORD++foreign import ccall unsafe "HsWin32.h"+ hIWORD :: DWORD -> WORD++foreign import ccall unsafe "HsWin32.h"+ castUINTToPtr :: UINT -> Ptr a++foreign import ccall unsafe "HsWin32.h"+ castPtrToUINT :: Ptr s -> UINT++foreign import ccall unsafe "HsWin32.h"+ castFunPtrToLONG :: FunPtr a -> LONG++type LCID = DWORD++type LANGID = WORD+type SortID = WORD++foreign import ccall unsafe "HsWin32.h prim_MAKELCID"+ mAKELCID :: LANGID -> SortID -> LCID++foreign import ccall unsafe "HsWin32.h prim_LANGIDFROMLCID"+ lANGIDFROMLCID :: LCID -> LANGID++foreign import ccall unsafe "HsWin32.h prim_SORTIDFROMLCID"+ sORTIDFROMLCID :: LCID -> SortID++type SubLANGID = WORD+type PrimaryLANGID = WORD++foreign import ccall unsafe "HsWin32.h prim_MAKELANGID"+ mAKELANGID :: PrimaryLANGID -> SubLANGID -> LANGID++foreign import ccall unsafe "HsWin32.h prim_PRIMARYLANGID"+ pRIMARYLANGID :: LANGID -> PrimaryLANGID++foreign import ccall unsafe "HsWin32.h prim_SUBLANGID"+ sUBLANGID :: LANGID -> SubLANGID++----------------------------------------------------------------+-- End+----------------------------------------------------------------
+ Win32.cabal view
@@ -0,0 +1,62 @@+name: Win32+version: 2.1+license: BSD3+license-file: LICENSE+author: Alastair Reid+copyright: Alastair Reid, 1999-2003+maintainer: Esa Ilari Vuokko <ei@vuokko.info>+category: System, Graphics+synopsis: A binding to part of the Win32 library+build-depends: base+ghc-options: -O -fvia-C -Wall -fno-warn-name-shadowing+exposed-modules:+ Graphics.Win32.GDI,+ Graphics.Win32.GDI.Bitmap,+ Graphics.Win32.GDI.Brush,+ Graphics.Win32.GDI.Clip,+ Graphics.Win32.GDI.Font,+ Graphics.Win32.GDI.Graphics2D,+ Graphics.Win32.GDI.HDC,+ Graphics.Win32.GDI.Palette,+ Graphics.Win32.GDI.Path,+ Graphics.Win32.GDI.Pen,+ Graphics.Win32.GDI.Region,+ Graphics.Win32.GDI.Types,+ Graphics.Win32,+ Graphics.Win32.Control,+ Graphics.Win32.Dialogue,+ Graphics.Win32.Icon,+ Graphics.Win32.Key,+ Graphics.Win32.Menu,+ Graphics.Win32.Message,+ Graphics.Win32.Misc,+ Graphics.Win32.Resource,+ Graphics.Win32.Window,+ System.Win32,+ System.Win32.DebugApi,+ System.Win32.DLL,+ System.Win32.File,+ System.Win32.FileMapping,+ System.Win32.Info,+ System.Win32.Mem,+ System.Win32.NLS,+ System.Win32.Process,+ System.Win32.Registry,+ System.Win32.SimpleMAPI,+ System.Win32.Time,+ System.Win32.Console,+ System.Win32.Types+extensions: ForeignFunctionInterface+extra-libraries:+ "user32", "gdi32", "winmm", "kernel32", "advapi32"+include-dirs: include+includes: "HsWin32.h", "HsGDI.h", "WndProc.h"+c-sources:+ cbits/HsGDI.c,+ cbits/HsWin32.c,+ cbits/WndProc.c,+ cbits/diatemp.c,+ cbits/dumpBMP.c,+ cbits/ellipse.c,+ cbits/errors.c+cc-options: -DUNICODE
+ cbits/HsGDI.c view
@@ -0,0 +1,3 @@+// Out-of-line versions of all the inline functions from HsGDI.h+#define INLINE /* nothing */+#include "HsGDI.h"
+ cbits/HsWin32.c view
@@ -0,0 +1,15 @@+// Out-of-line versions of all the inline functions from HsWin32.h+#define INLINE /* nothing */+#include "HsWin32.h"++void UnmapViewOfFileFinaliser(void * p) {+ UnmapViewOfFile(p);+}++void CloseHandleFinaliser(HANDLE h) {+ CloseHandle(h);+}++void FreeLibraryFinaliser(HMODULE m) {+ FreeLibrary(m);+}
+ cbits/WndProc.c view
@@ -0,0 +1,90 @@+#include "WndProc.h"+#include <stdio.h>+++/* Debugging code - might come in handy. */+#if 0+HWND+mkWin(long l)+{+ static char appN[] = "TestWin";+ HWND hw;+ WNDCLASSEX wndclass;+ + wndclass.cbSize = sizeof(wndclass);+ wndclass.style = CS_HREDRAW | CS_VREDRAW;+ wndclass.lpfnWndProc = genericWndProc;+ wndclass.cbClsExtra = 0;+ wndclass.cbWndExtra = 0;+ wndclass.hInstance = GetModuleHandle(NULL);+ wndclass.hIcon = LoadIcon(NULL, IDI_APPLICATION);+ wndclass.hCursor = LoadCursor(NULL, IDC_ARROW);+ wndclass.hbrBackground = (HBRUSH)GetStockObject(WHITE_BRUSH);+ wndclass.lpszMenuName = NULL;+ wndclass.lpszClassName = appN;+ wndclass.hIconSm = LoadIcon(NULL, IDI_APPLICATION);++ RegisterClassEx(&wndclass);++ hw = CreateWindow(appN, "test", WS_OVERLAPPEDWINDOW,100,100,100,100, NULL, NULL, GetModuleHandle(NULL),NULL);+ //ShowWindow (hw, SW_SHOWNORMAL);+ //UpdateWindow (hw);+ /*WndPump();*/+ //SetWindowLong( hw, GWL_USERDATA,l);+ return hw;+}++void+WndPump()+{+ MSG msg;++ fprintf(stderr, "Getting..\n");+ while (GetMessage(&msg, NULL, 0,0) != 0) {+ fprintf(stderr, "..got,\n");+ TranslateMessage(&msg);+ fprintf(stderr, "delivering.\n");+ DispatchMessage(&msg);+ fprintf(stderr, "Getting..\n");+ }+}+#endif++#ifdef DEBUG+char* __current_fun__ = NULL;+#endif++void+WndPump ()+{+ MSG msg;+ while(1) {+ GetMessage(&msg,NULL, 0,0);+ TranslateMessage(&msg);+ DispatchMessage(&msg);+ }+ return;+}++LRESULT CALLBACK genericWndProc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)+{+ LRESULT lr;++ if (hwnd) {+ LONG wndprocptr = GetWindowLong(hwnd,GWL_USERDATA);+ if (wndprocptr) {+ lr = ((LRESULT (*)(HWND,UINT,WPARAM,LPARAM))(wndprocptr))(hwnd,msg,wParam,lParam);+#if 0+ if (lr == -1) {+ return DefWindowProc(hwnd, msg, wParam, lParam);+ } else {+ return lr;+ }+#else+ return lr;+#endif+ }+ }+ return DefWindowProc(hwnd, msg, wParam, lParam);+}+
+ cbits/diatemp.c view
@@ -0,0 +1,223 @@+/*+ * Helper functions for filling in DLG(ITEM)TEMPLATEs -+ * closely based on code provided Rector & Newcomer+ * in their book, Win32 programming.+ *+ * The only change here is to make it possible to+ * add any number of controls to the dialog without+ * having to worry about overrunning the chunk of+ * memory that we're writing all this info into.+ *+ */++#include <windows.h>+#include <wchar.h>+#include <stdlib.h>+#include "diatemp.h"++#define DLGTEMPLATE_WORKING_SIZE 4096++LPDLGTEMPLATE getFinalDialog(DIA_TEMPLATE* dt)+{ + LPDLGTEMPLATE ptr = dt->dtemplate;+ free(dt);+ return ptr;+}++LPWORD+appendString (LPWORD ptr, LPCWSTR text)+{+ LPWSTR str = (LPWSTR)ptr;+ wcscpy(str, text);+ ptr = (LPWORD)(str + wcslen(str) + 1);+ return ptr;+}++LPWORD+setClassAtom(LPDLGITEMTEMPLATE item, WORD classatom)+{+ LPWORD ptr = (LPWORD)&item[1];+ *ptr++ = 0xffff;+ *ptr++ = classatom;+ return ptr;+}++LPWORD+setClassName(LPDLGITEMTEMPLATE item, LPCWSTR classname)+{+ LPWORD ptr = (LPWORD)&item[1];+ ptr = appendString(ptr, classname);+ return ptr;+}++LPWORD+setResourceID(LPWORD ptr, WORD id)+{+ *ptr++ = 0xffff;+ *ptr++ = (WORD)id;+ return ptr;+}++DIA_TEMPLATE*+mkDiaTemplate+ ( UINT size, int x, int y, int cx, int cy+ , DWORD style, DWORD exstyle+ , LPCWSTR menu, LPCWSTR class+ , LPCWSTR caption, LPCWSTR font+ , int height+ )+{+ LPDLGTEMPLATE dlg;+ LPWORD ptr;+ DIA_TEMPLATE* dtemp;+ + if ( size == 0 ) {+ size = DLGTEMPLATE_WORKING_SIZE;+ }+ dlg = (LPDLGTEMPLATE)malloc(size);+ if (dlg == NULL) {+ return NULL;+ }++ dlg->x = x;+ dlg->y = y;+ dlg->cx = cx;+ dlg->cy = cy;+ + dlg->cdit = 0;+ + dlg->style = style;+ if (font == NULL) {+ dlg->style &= ~ DS_SETFONT;+ } else {+ dlg->style |= DS_SETFONT;+ }+ dlg->dwExtendedStyle = exstyle;++ ptr= (LPWORD)&dlg[1];+ if (menu == NULL) {+ *ptr++ = 0;+ } else if (HIWORD(menu) == 0) {+ ptr = setResourceID(ptr, LOWORD(menu));+ } else {+ ptr = appendString(ptr, menu);+ }+ + if ( class == NULL ) {+ *ptr++ = 0;+ } else if ( HIWORD(class) == 0 ) {+ ptr = setResourceID(ptr, LOWORD(class));+ } else {+ ptr = appendString(ptr, class);+ }++ ptr = appendString(ptr, (caption == NULL ? L"" : caption)); ++ if ( font != NULL ) {+ *ptr++ = height;+ ptr = appendString(ptr, font);+ }++ dtemp = (DIA_TEMPLATE*)malloc(sizeof(DIA_TEMPLATE));+ if ( dtemp == NULL )+ return NULL;+ + dtemp->dtemplate = dlg;+ dtemp->next_dia_item = (LPDLGITEMTEMPLATE)ptr;+ dtemp->bytes_left = (unsigned int)(((char*)dlg + size) - (char*)ptr);+ dtemp->bytes_alloced = size;++ return dtemp;+}++static+DIA_TEMPLATE*+check_if_enough_mem(DIA_TEMPLATE* dia, LPCWSTR text, LPCWSTR classname)+{+ unsigned int sz = 0;++ sz += sizeof(DLGITEMTEMPLATE);++ if ( HIWORD(classname) == 0 ) {+ sz += sizeof(WORD);+ } else {+ sz += wcslen(classname) + 1;+ }+ if ( HIWORD(text) == 0 ) {+ sz += sizeof(WORD);+ } else {+ sz += wcslen(text) + 1;+ }++ if ( sz >= dia->bytes_left ) {+ unsigned int diff;+ dia->bytes_left = dia->bytes_left + dia->bytes_alloced;+ dia->bytes_alloced *= 2;+ /* Being defensive here.. */+ diff = (unsigned int)((char*)dia->next_dia_item - (char*)dia->dtemplate);+ dia->dtemplate = (LPDLGTEMPLATE)realloc((void*)dia->dtemplate, dia->bytes_alloced);+ if ( dia->dtemplate == NULL )+ return NULL;+ dia->next_dia_item = (LPDLGITEMTEMPLATE)((char*)dia->dtemplate + diff);+ return dia;+ } else {+ return dia;+ }+}++static+LPWORD noParms (LPDLGITEMTEMPLATE item, LPWORD ptr)+{+ *ptr++ = 0;+ if ( (((LPWORD)item) - ptr) & 0x1)+ *ptr++ = 0;+ + return ptr;+}++DIA_TEMPLATE*+addDiaControl+ ( DIA_TEMPLATE* dia+ , LPCWSTR text, short id+ , LPCWSTR classname, DWORD style+ , int x, int y, int cx, int cy+ , DWORD exstyle+ )+{+ LPWORD ptr;+ LPDLGITEMTEMPLATE item;++ dia = check_if_enough_mem(dia, text, classname);++ ptr = (LPWORD)&(dia->next_dia_item[1]);++ item = dia->next_dia_item;++ item->style = WS_CHILD | style;+ item->dwExtendedStyle = exstyle;+ item->x = x;+ item->y = y;+ item->cx = cx;+ item->cy = cy;+ item->id = (WORD)id;+ + if ( HIWORD(classname) != 0 ) {+ ptr = setClassName(item, classname);+ } else {+ ptr = setResourceID(ptr, LOWORD(classname));+ }++ if ( HIWORD(text) != 0 ) {+ ptr = appendString(ptr, text);+ } else {+ ptr = setResourceID(ptr, (short)(LOWORD(text)));+ }+ + ptr = noParms(item, ptr);+ + dia->bytes_left -= ((char*)ptr - ((char*)dia->next_dia_item));+ dia->next_dia_item = (LPDLGITEMTEMPLATE)ptr;+ + return dia;+}+
+ cbits/dumpBMP.c view
@@ -0,0 +1,207 @@+/******************************Module*Header*******************************\+* Module Name: savebmp.c+*+*+* Created: 06-Jan-1992 10:59:36+*+* Copyright (C) 1993-1995 Microsoft Corporation+*+* Contains the main routine, SaveBitmapFile, for saving a DDB into file+* in DIB format.+*+* Dependencies:+*+* (#defines)+* (#includes)+* #include <windows.h>+*+\**************************************************************************/+#include <windows.h>+#include <stdio.h>+#include "dumpBMP.h"++/******************************Public*Routine******************************\+* SaveBitmapFile+*+*+* Effects: Save pInfo->hBmpSaved into disk specified by pszFileName+*+* Warnings: assumes hBmpSaved is not selected into window's DC other than+* pInfo->hwnd's DC+*+\**************************************************************************/++//typedef LPBITMAPINFO PBITMAPINFO; // hack to keep cygwin32b17 happy++void CreateBMPFile(LPCSTR pszFileName, HBITMAP hBmp, HDC hDC)+{+ int hFile;+ OFSTRUCT ofReOpenBuff;+ HBITMAP hTmpBmp, hBmpOld;+ BOOL bSuccess;+ BITMAPFILEHEADER bfh;+ LPBITMAPINFO pbmi;+ PBYTE pBits;+ BITMAPINFO bmi;+ PBYTE pjTmp, pjTmpBmi;+ ULONG sizBMI;+++ bSuccess = TRUE;+#if 0+ if (ghPal) {+ SelectPalette(hDC, ghPal, FALSE);+ RealizePalette(hDC);+ }+#endif+ if (!hBmp) {+ fprintf(stderr, "There's no Bitmap to save!");+ return;+ }++ //+ // Let the graphics engine to retrieve the dimension of the bitmap for us+ // GetDIBits uses the size to determine if its BITMAPCOREINFO or BITMAPINFO+ // if BitCount != 0, color table will be retrieved+ //+ bmi.bmiHeader.biSize = 0x28; // GDI need this to work+ bmi.bmiHeader.biBitCount = 0; // dont get the color table+ if ((GetDIBits(hDC, hBmp, 0, 0, (LPSTR)NULL, &bmi, DIB_RGB_COLORS)) == 0) {+ fprintf(stderr, "GetDIBits failed!");+ return;+ }++ //+ // Now that we know the size of the image, alloc enough memory to retrieve+ // the actual bits+ //+ if ((pBits = (PBYTE)GlobalAlloc(GMEM_FIXED | GMEM_ZEROINIT,+ bmi.bmiHeader.biSizeImage)) == NULL) {+ fprintf(stderr, "Failed in Memory Allocation for pBits!");+ return;+ }++ //+ // Note: 24 bits per pixel has no color table. So, we dont have to+ // allocate memory for retrieving that. Otherwise, we do.+ //+ pbmi = &bmi; // assume no color table++ switch (bmi.bmiHeader.biBitCount) {+ case 24: // has color table+ sizBMI = sizeof(BITMAPINFOHEADER);+ break;+ case 16:+ case 32:+ sizBMI = sizeof(BITMAPINFOHEADER)+sizeof(DWORD)*3;+ break;+ default:+ sizBMI = sizeof(BITMAPINFOHEADER)+sizeof(RGBQUAD)*(1<<bmi.bmiHeader.biBitCount);+ break;++ }++ //+ // Allocate memory for color table if it is not 24bpp...+ //+ if (sizBMI != sizeof(BITMAPINFOHEADER)) {+ ULONG sizTmp;+ //+ // I need more memory for the color table+ //+ if ((pbmi = (LPBITMAPINFO)GlobalAlloc(GMEM_FIXED | GMEM_ZEROINIT, sizBMI )) == NULL) {+ fprintf(stderr, "Failed in Memory Allocation for pbmi!");+ bSuccess = FALSE;+ goto ErrExit1;+ }+ //+ // Now that weve a bigger chunk of memory, lets copy the Bitmap+ // info header data over+ //+ pjTmp = (PBYTE)pbmi;+ pjTmpBmi = (PBYTE)&bmi;+ sizTmp = sizeof(BITMAPINFOHEADER);++ while(sizTmp--)+ {+ *(pjTmp++) = *(pjTmpBmi++);+ }+ }++ //+ // Lets open the file and get ready for writing+ //+ if ((hFile = OpenFile(pszFileName, (LPOFSTRUCT)&ofReOpenBuff,+ OF_CREATE | OF_WRITE)) == -1) {+ fprintf(stderr, "Failed in OpenFile!");+ goto ErrExit2;+ }++ //+ // But first, fill in the info for the BitmapFileHeader+ //+ bfh.bfType = 0x4D42; // BM+ bfh.bfSize = sizeof(BITMAPFILEHEADER)+sizeof(BITMAPINFOHEADER)+sizBMI++ pbmi->bmiHeader.biSizeImage;+ bfh.bfReserved1 =+ bfh.bfReserved2 = 0;+ bfh.bfOffBits = sizeof(BITMAPFILEHEADER)+sizBMI;++ //+ // Write out the file header now+ //+ if (_lwrite(hFile, (LPSTR)&bfh, sizeof(BITMAPFILEHEADER)) == -1) {+ fprintf(stderr, "Failed in WriteFile!");+ bSuccess = FALSE;+ goto ErrExit3;+ }++ //+ // Bitmap cant be selected into a DC when calling GetDIBits+ // Assume that the hDC is the DC where the bitmap would have been selected+ // if indeed it has been selected+ //+ if (hTmpBmp = CreateCompatibleBitmap(hDC, pbmi->bmiHeader.biWidth, pbmi->bmiHeader.biHeight)) {+ hBmpOld = SelectObject(hDC, hTmpBmp);+ if ((GetDIBits(hDC, hBmp, 0, pbmi->bmiHeader.biHeight, (LPSTR)pBits, pbmi, DIB_RGB_COLORS))==0){+ fprintf(stderr, "Failed in GetDIBits!");+ bSuccess = FALSE;+ goto ErrExit4;+ }+ } else {+ fprintf(stderr, "Failed in creating bitmap!");+ bSuccess = FALSE;+ goto ErrExit3;+ }++ //+ // Now write out the BitmapInfoHeader and color table, if any+ //+ if (_lwrite(hFile, (LPSTR)pbmi, sizBMI) == -1) {+ fprintf(stderr, "Failed in WriteFile!");+ bSuccess = FALSE;+ goto ErrExit4;+ }++ //+ // write the bits also+ //+ if (_lwrite(hFile, (LPSTR)pBits, pbmi->bmiHeader.biSizeImage) == -1) {+ fprintf(stderr, "Failed in WriteFile!");+ bSuccess = FALSE;+ goto ErrExit4;+ }+++ErrExit4:+ SelectObject(hDC, hBmpOld);+ DeleteObject(hTmpBmp);+ErrExit3:+ _lclose(hFile);+ErrExit2:+ GlobalFree(pbmi);+ErrExit1:+ GlobalFree(pBits);+ return;+}+
+ cbits/ellipse.c view
@@ -0,0 +1,50 @@+#include <windows.h>+#include <math.h>++/*+ * Rotatable Ellipse hack+ *+ * Win95 (Win32?) doesn't support rotating ellipses - so we+ * implement them with polygons.+ *+ * We use a fixed number of edges rather than varying the number+ * according to the radius of the ellipse.+ * If anyone feels like improving the code (to vary the number),+ * they should place a fixed upper bound on the number of edges+ * since it takes a relatively long time to draw 1000 edges.+ */++int transformedEllipse(+ HDC hdc, LONG x0, LONG y0, LONG x1, LONG y1, LONG x2, LONG y2) {+ static BOOL firstTime = 1;+ static double sins[20];+ static double coss[20];++ int i;+ POINT pts[20];++ double x = (x1 + x2) / 2; /* centre of parallelogram */+ double y = (y1 + y2) / 2;++ double dx1 = (x1 - x0) / 2; /* distance to corners from centre */+ double dy1 = (y1 - y0) / 2;+ double dx2 = (x2 - x0) / 2;+ double dy2 = (y2 - y0) / 2;++ if (firstTime) {+ double a = 0.0;+ double da = 2.0*3.14159 / 20;+ for (i=0; i < 20; ++i, a+=da) {+ sins[i] = sin(a);+ coss[i] = cos(a);+ }+ firstTime = 0;+ }+ for(i=0; i < 20; ++i) {+ double c = coss[i];+ double s = sins[i];+ pts[i].x = x + c*dx1 + s*dx2;+ pts[i].y = y + c*dy1 + s*dy2;+ }+ return Polygon(hdc,pts,20);+}
+ cbits/errors.c view
@@ -0,0 +1,32 @@+#include <stdio.h>+#include <stdlib.h>+#include <windows.h>+#include "errors.h"++/* There's two ways we can generate error messages - with different tradeoffs:+ * If we do a function call, we have to use a static buffer.+ * If we use a macro and ANSI C's string splicing, we have to use constant+ * strings - and accept a certain amount of overhead from inserting the+ * boilerplate text.+ *+ * Why the concern about performance? Error messages are only generated+ * in exceptional situations -- sof 9/98+ *+ * sof 9/98 : Removed use of non-standard (and wimpy :-) snprintf().+ */++LPTSTR getErrorMessage(DWORD err)+{+ LPTSTR what;++ FormatMessage( + (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER) ,+ NULL,+ err,+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */+ (LPTSTR) &what,+ 0,+ NULL + );+ return what;+}