diff --git a/Graphics/Win32.hs b/Graphics/Win32.hs new file mode 100644 --- /dev/null +++ b/Graphics/Win32.hs @@ -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 +-- Stability : provisional +-- Portability : portable +-- +-- An interface to the Microsoft Windows user interface. +-- See 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 diff --git a/Graphics/Win32/Control.hsc b/Graphics/Win32/Control.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Control.hsc @@ -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 +-- 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 +#include + +-- == 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 diff --git a/Graphics/Win32/Dialogue.hsc b/Graphics/Win32/Dialogue.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Dialogue.hsc @@ -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 +-- 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 + +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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI.hs b/Graphics/Win32/GDI.hs new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI.hs @@ -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 +-- Stability : provisional +-- Portability : portable +-- +-- An interface to the Microsoft Windows graphics device interface (GDI). +-- See 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 diff --git a/Graphics/Win32/GDI/Bitmap.hsc b/Graphics/Win32/GDI/Bitmap.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Bitmap.hsc @@ -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 +-- 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 + +---------------------------------------------------------------- +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Brush.hsc b/Graphics/Win32/GDI/Brush.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Brush.hsc @@ -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 +-- 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 + +---------------------------------------------------------------- +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Clip.hsc b/Graphics/Win32/GDI/Clip.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Clip.hsc @@ -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 +-- 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 + +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 diff --git a/Graphics/Win32/GDI/Font.hsc b/Graphics/Win32/GDI/Font.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Font.hsc @@ -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 +-- 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 + +---------------------------------------------------------------- +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Graphics2D.hs b/Graphics/Win32/GDI/Graphics2D.hs new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Graphics2D.hs @@ -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 +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/HDC.hs b/Graphics/Win32/GDI/HDC.hs new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/HDC.hs @@ -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 +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Palette.hsc b/Graphics/Win32/GDI/Palette.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Palette.hsc @@ -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 +-- 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 + +---------------------------------------------------------------- +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Path.hs b/Graphics/Win32/GDI/Path.hs new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Path.hs @@ -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 +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Pen.hsc b/Graphics/Win32/GDI/Pen.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Pen.hsc @@ -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 +-- 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 + +---------------------------------------------------------------- +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Region.hs b/Graphics/Win32/GDI/Region.hs new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Region.hs @@ -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 +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/GDI/Types.hsc b/Graphics/Win32/GDI/Types.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/GDI/Types.hsc @@ -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 +-- 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 + +{-# 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/Icon.hs b/Graphics/Win32/Icon.hs new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Icon.hs @@ -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 +-- 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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/Key.hsc b/Graphics/Win32/Key.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Key.hsc @@ -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 +-- 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 + +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 diff --git a/Graphics/Win32/Menu.hsc b/Graphics/Win32/Menu.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Menu.hsc @@ -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 +-- 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 + +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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/Message.hsc b/Graphics/Win32/Message.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Message.hsc @@ -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 +-- Stability : provisional +-- Portability : portable +-- +-- A collection of FFI declarations for interfacing with Win32. +-- +----------------------------------------------------------------------------- + +module Graphics.Win32.Message where + +import System.Win32.Types + +#include + +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! +---------------------------------------------------------------- diff --git a/Graphics/Win32/Misc.hsc b/Graphics/Win32/Misc.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Misc.hsc @@ -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 +-- 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 +#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 +---------------------------------------------------------------- diff --git a/Graphics/Win32/Resource.hsc b/Graphics/Win32/Resource.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Resource.hsc @@ -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 +-- 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 + +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 diff --git a/Graphics/Win32/Window.hsc b/Graphics/Win32/Window.hsc new file mode 100644 --- /dev/null +++ b/Graphics/Win32/Window.hsc @@ -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 +-- 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 + +---------------------------------------------------------------- +-- 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 +---------------------------------------------------------------- diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Win32.hs b/System/Win32.hs new file mode 100644 --- /dev/null +++ b/System/Win32.hs @@ -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 +-- 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 +---------------------------------------------------------------- diff --git a/System/Win32/Console.hsc b/System/Win32/Console.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Console.hsc @@ -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 +-- 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 diff --git a/System/Win32/DLL.hsc b/System/Win32/DLL.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/DLL.hsc @@ -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 +-- 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 + +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 diff --git a/System/Win32/DebugApi.hsc b/System/Win32/DebugApi.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/DebugApi.hsc @@ -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 +-- 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 () diff --git a/System/Win32/File.hsc b/System/Win32/File.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/File.hsc @@ -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 +-- 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 + +---------------------------------------------------------------- +-- 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 +---------------------------------------------------------------- diff --git a/System/Win32/FileMapping.hsc b/System/Win32/FileMapping.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/FileMapping.hsc @@ -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 +-- 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 ()) diff --git a/System/Win32/Info.hsc b/System/Win32/Info.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Info.hsc @@ -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 +-- 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 + +---------------------------------------------------------------- +-- 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 +---------------------------------------------------------------- diff --git a/System/Win32/Mem.hsc b/System/Win32/Mem.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Mem.hsc @@ -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 +-- 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 + +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 diff --git a/System/Win32/NLS.hsc b/System/Win32/NLS.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/NLS.hsc @@ -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 +-- 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 +#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) diff --git a/System/Win32/Process.hsc b/System/Win32/Process.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Process.hsc @@ -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 +-- 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 +#include + +-- 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) diff --git a/System/Win32/Registry.hsc b/System/Win32/Registry.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Registry.hsc @@ -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 +-- 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 + +#{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 "<>" + + 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 diff --git a/System/Win32/SimpleMAPI.hsc b/System/Win32/SimpleMAPI.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/SimpleMAPI.hsc @@ -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 +-- 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 diff --git a/System/Win32/Time.hsc b/System/Win32/Time.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Time.hsc @@ -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 +-- 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) diff --git a/System/Win32/Types.hs b/System/Win32/Types.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Types.hs @@ -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 +-- 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 +---------------------------------------------------------------- diff --git a/Win32.cabal b/Win32.cabal new file mode 100644 --- /dev/null +++ b/Win32.cabal @@ -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 +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 diff --git a/cbits/HsGDI.c b/cbits/HsGDI.c new file mode 100644 --- /dev/null +++ b/cbits/HsGDI.c @@ -0,0 +1,3 @@ +// Out-of-line versions of all the inline functions from HsGDI.h +#define INLINE /* nothing */ +#include "HsGDI.h" diff --git a/cbits/HsWin32.c b/cbits/HsWin32.c new file mode 100644 --- /dev/null +++ b/cbits/HsWin32.c @@ -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); +} diff --git a/cbits/WndProc.c b/cbits/WndProc.c new file mode 100644 --- /dev/null +++ b/cbits/WndProc.c @@ -0,0 +1,90 @@ +#include "WndProc.h" +#include + + +/* 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); +} + diff --git a/cbits/diatemp.c b/cbits/diatemp.c new file mode 100644 --- /dev/null +++ b/cbits/diatemp.c @@ -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 +#include +#include +#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; +} + diff --git a/cbits/dumpBMP.c b/cbits/dumpBMP.c new file mode 100644 --- /dev/null +++ b/cbits/dumpBMP.c @@ -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 +* +\**************************************************************************/ +#include +#include +#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<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; +} + diff --git a/cbits/ellipse.c b/cbits/ellipse.c new file mode 100644 --- /dev/null +++ b/cbits/ellipse.c @@ -0,0 +1,50 @@ +#include +#include + +/* + * 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); +} diff --git a/cbits/errors.c b/cbits/errors.c new file mode 100644 --- /dev/null +++ b/cbits/errors.c @@ -0,0 +1,32 @@ +#include +#include +#include +#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; +}