{-# OPTIONS -fglasgow-exts #-} ----------------------------------------------------------------------------------------- {-| Module : Events Copyright : (c) Daan Leijen 2003 License : wxWindows Maintainer : wxhaskell-devel@lists.sourceforge.net Stability : provisional Portability : portable Dynamically set (and get) Haskell event handlers for basic wxWindows events. Note that one should always call 'skipCurrentEvent' when an event is not processed in the event handler so that other eventhandlers can process the event. -} ----------------------------------------------------------------------------------------- module Graphics.UI.WXCore.Events ( -- * Set event handlers -- ** Controls buttonOnCommand , checkBoxOnCommand , choiceOnCommand , comboBoxOnCommand , comboBoxOnTextEnter , controlOnText , listBoxOnCommand , spinCtrlOnCommand -- , listBoxOnDClick , radioBoxOnCommand , sliderOnCommand , textCtrlOnTextEnter , listCtrlOnListEvent , treeCtrlOnTreeEvent , gridOnGridEvent -- ** Windows , windowOnMouse , windowOnKeyChar , windowOnKeyDown , windowOnKeyUp , windowAddOnClose , windowOnClose , windowOnDestroy , windowAddOnDelete , windowOnDelete , windowOnCreate , windowOnIdle , windowOnTimer , windowOnSize , windowOnFocus , windowOnActivate , windowOnPaint , windowOnPaintRaw , windowOnContextMenu , windowOnScroll , htmlWindowOnHtmlEvent -- ** Event handlers , evtHandlerOnMenuCommand , evtHandlerOnEndProcess , evtHandlerOnInput , evtHandlerOnInputSink , evtHandlerOnTaskBarIconEvent -- ** Raw STC export , EventSTC(..) , stcOnSTCEvent , stcGetOnSTCEvent -- ** Print events , EventPrint(..) , printOutOnPrint -- * Get event handlers -- ** Controls , buttonGetOnCommand , checkBoxGetOnCommand , choiceGetOnCommand , comboBoxGetOnCommand , comboBoxGetOnTextEnter , controlGetOnText , listBoxGetOnCommand , spinCtrlGetOnCommand -- , listBoxGetOnDClick , radioBoxGetOnCommand , sliderGetOnCommand , textCtrlGetOnTextEnter , listCtrlGetOnListEvent , treeCtrlGetOnTreeEvent , gridGetOnGridEvent -- ** Windows , windowGetOnMouse , windowGetOnKeyChar , windowGetOnKeyDown , windowGetOnKeyUp , windowGetOnClose , windowGetOnDestroy , windowGetOnDelete , windowGetOnCreate , windowGetOnIdle , windowGetOnTimer , windowGetOnSize , windowGetOnFocus , windowGetOnActivate , windowGetOnPaint , windowGetOnPaintRaw , windowGetOnContextMenu , windowGetOnScroll , htmlWindowGetOnHtmlEvent -- ** Event handlers , evtHandlerGetOnMenuCommand , evtHandlerGetOnEndProcess , evtHandlerGetOnInputSink , evtHandlerGetOnTaskBarIconEvent -- ** Printing , printOutGetOnPrint -- * Timers , windowTimerAttach , windowTimerCreate , timerOnCommand , timerGetOnCommand -- Idle events , appRegisterIdle -- * Calenders , EventCalendar(..) , calendarCtrlOnCalEvent , calendarCtrlGetOnCalEvent -- * Types -- ** Streams , StreamStatus(..), streamStatusFromInt -- ** Modifiers , Modifiers(..) , showModifiers , noneDown, justShift, justAlt, justControl, justMeta, isNoneDown , isNoShiftAltControlDown -- ** Mouse events , EventMouse (..) , showMouse , mousePos, mouseModifiers -- ** Keyboard events , EventKey (..), Key(..) , keyKey, keyModifiers, keyPos , showKey, showKeyModifiers -- * Set event handlers -- ** Drop Target events , DragResult (..) , dropTargetOnData , dropTargetOnDrop , dropTargetOnEnter , dropTargetOnDragOver , dropTargetOnLeave -- ** On DragAndDropEvent , DragMode (..) , dragAndDrop -- *** Special handler for Drop File event , fileDropTarget -- *** Special handler for Drop Text event , textDropTarget -- ** Scroll events , EventScroll(..), Orientation(..) , scrollOrientation, scrollPos -- ** Tree control events , EventTree(..) -- ** List control events , EventList(..), ListIndex -- ** Grid control events , EventGrid(..), Row, Column -- ** Html window events , EventHtml(..) -- * TaskBar icon events , EventTaskBarIcon(..) -- * Current event , propagateEvent , skipCurrentEvent , withCurrentEvent -- * Primitive , appOnInit -- ** Client data , treeCtrlSetItemClientData , evtHandlerWithClientData , evtHandlerSetClientData , objectWithClientData , objectSetClientData -- ** Input sink , inputSinkEventLastString -- ** Keys , KeyCode , modifiersToAccelFlags , keyCodeToKey, keyToKeyCode -- ** Events , windowOnEvent, windowOnEventEx -- ** Generic , OnEvent , evtHandlerOnEvent , evtHandlerOnEventConnect -- ** Unsafe , unsafeTreeCtrlGetItemClientData , unsafeEvtHandlerGetClientData , unsafeObjectGetClientData , unsafeGetHandlerState , unsafeWindowGetHandlerState ) where import Data.List( intersperse, findIndex ) import System.Environment( getProgName, getArgs ) import Foreign.StablePtr import Foreign.Ptr import Foreign.C.String import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Marshal.Utils import Data.Char ( chr ) -- used in stc import Data.Maybe ( fromMaybe ) import Control.Concurrent.MVar import System.IO.Unsafe( unsafePerformIO ) import qualified Data.IntMap as IntMap import Graphics.UI.WXCore.WxcTypes import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClasses import Graphics.UI.WXCore.WxcClassInfo import Graphics.UI.WXCore.Types import Graphics.UI.WXCore.Draw import Graphics.UI.WXCore.Defines ------------------------------------------------------------------------------------------ -- Controls (COMMAND events) ------------------------------------------------------------------------------------------ -- | Set an event handler for a push button. buttonOnCommand :: Button a -> IO () -> IO () buttonOnCommand button eventHandler = windowOnEvent button [wxEVT_COMMAND_BUTTON_CLICKED] eventHandler (\evt -> eventHandler) -- | Get the current button event handler on a window. buttonGetOnCommand :: Window a -> IO (IO ()) buttonGetOnCommand button = unsafeWindowGetHandlerState button wxEVT_COMMAND_BUTTON_CLICKED skipCurrentEvent -- | Set an event handler for "updated text", works for example on a 'TextCtrl' and 'ComboBox'. controlOnText :: Control a -> IO () -> IO () controlOnText control eventHandler = windowOnEvent control [wxEVT_COMMAND_TEXT_UPDATED] eventHandler (\evt -> eventHandler) -- | Get the current event handler for updated text. controlGetOnText :: Control a -> IO (IO ()) controlGetOnText control = unsafeWindowGetHandlerState control wxEVT_COMMAND_TEXT_UPDATED skipCurrentEvent -- | Set an event handler for an enter command in a text control. textCtrlOnTextEnter :: TextCtrl a -> IO () -> IO () textCtrlOnTextEnter textCtrl eventHandler = windowOnEvent textCtrl [wxEVT_COMMAND_TEXT_ENTER] eventHandler (\evt -> eventHandler) -- | Get the current text enter event handler. textCtrlGetOnTextEnter :: TextCtrl a -> IO (IO ()) textCtrlGetOnTextEnter textCtrl = unsafeWindowGetHandlerState textCtrl wxEVT_COMMAND_TEXT_ENTER skipCurrentEvent {- -- | Set an event handler for when a user tries to type more than than the maximally -- allowed text in a text control. textCtrlOnTextMaxLen :: IO () -> TextCtrl a -> IO () textCtrlOnTextMaxLen eventHandler textCtrl = windowOnEvent textCtrl [wxEVT_COMMAND_TEXT_MAXLEN] eventHandler (\evt -> eventHandler) -- | Get the current maximal text event handler. textCtrlGetOnTextMaxLen :: TextCtrl a -> IO (IO ()) textCtrlGetOnTextMaxLen textCtrl = unsafeWindowGetHandlerState textCtrl wxEVT_COMMAND_TEXT_MAXLEN skipCurrentEvent -} -- | Set an event handler for an enter command in a combo box. comboBoxOnTextEnter :: ComboBox a -> IO () -> IO () comboBoxOnTextEnter comboBox eventHandler = windowOnEvent comboBox [wxEVT_COMMAND_TEXT_ENTER] eventHandler (\evt -> eventHandler) -- | Get the current text enter event handler. comboBoxGetOnTextEnter :: ComboBox a -> IO (IO ()) comboBoxGetOnTextEnter comboBox = unsafeWindowGetHandlerState comboBox wxEVT_COMMAND_TEXT_ENTER skipCurrentEvent -- | Set an event handler for when a combo box item is selected. comboBoxOnCommand :: ComboBox a -> IO () -> IO () comboBoxOnCommand comboBox eventHandler = windowOnEvent comboBox [wxEVT_COMMAND_COMBOBOX_SELECTED] eventHandler (\evt -> eventHandler) -- | Get the current combo box event handler for selections comboBoxGetOnCommand :: ComboBox a -> IO (IO ()) comboBoxGetOnCommand comboBox = unsafeWindowGetHandlerState comboBox wxEVT_COMMAND_COMBOBOX_SELECTED skipCurrentEvent -- | Set an event handler for when a listbox item is (de)selected. listBoxOnCommand :: ListBox a -> IO () -> IO () listBoxOnCommand listBox eventHandler = windowOnEvent listBox [wxEVT_COMMAND_LISTBOX_SELECTED] eventHandler (\evt -> eventHandler) -- | Get the current listbox event handler for selections. listBoxGetOnCommand :: ListBox a -> IO (IO ()) listBoxGetOnCommand listBox = unsafeWindowGetHandlerState listBox wxEVT_COMMAND_LISTBOX_SELECTED skipCurrentEvent {- -- | Set an event handler for when a listbox item is double clicked. Takes the selected -- item index as an argument. listBoxOnDClick :: (Int -> IO ()) -> ListBox a -> IO () listBoxOnDClick eventHandler listBox = windowOnEvent listBox [wxEVT_COMMAND_LISTBOX_DCLICK] eventHandler dclickHandler where dclickHandler event = do index <- commandEventGetInt (objectCast event) eventHandler index -- | Get the current double click listbox event handler. listBoxGetOnDClick :: ListBox a -> IO (IO ()) listBoxGetOnDClick listBox = unsafeWindowGetHandlerState listBox wxEVT_COMMAND_LISTBOX_DCLICK (\index -> skipCurrentEvent) -} -- | Set an event handler for when a choice item is (de)selected. choiceOnCommand :: Choice a -> IO () -> IO () choiceOnCommand choice eventHandler = windowOnEvent choice [wxEVT_COMMAND_CHOICE_SELECTED] eventHandler (\evt -> eventHandler) -- | Get the current choice command event handler. choiceGetOnCommand :: Choice a -> IO (IO ()) choiceGetOnCommand choice = unsafeWindowGetHandlerState choice wxEVT_COMMAND_CHOICE_SELECTED skipCurrentEvent -- | Set an event handler for when a radiobox item is selected. radioBoxOnCommand :: RadioBox a -> IO () -> IO () radioBoxOnCommand radioBox eventHandler = windowOnEvent radioBox [wxEVT_COMMAND_RADIOBOX_SELECTED] eventHandler (\evt -> eventHandler) -- | Get the current radio box command handler. radioBoxGetOnCommand :: RadioBox a -> IO (IO ()) radioBoxGetOnCommand radioBox = unsafeWindowGetHandlerState radioBox wxEVT_COMMAND_RADIOBOX_SELECTED skipCurrentEvent -- | Set an event handler for when a slider item changes. sliderOnCommand :: Slider a -> IO () -> IO () sliderOnCommand slider eventHandler = windowOnEvent slider [wxEVT_COMMAND_SLIDER_UPDATED] eventHandler (\evt -> eventHandler) -- | Get the current slider command event handler. sliderGetOnCommand :: Slider a -> IO (IO ()) sliderGetOnCommand slider = unsafeWindowGetHandlerState slider wxEVT_COMMAND_SLIDER_UPDATED skipCurrentEvent -- | Set an event handler for when a checkbox clicked. checkBoxOnCommand :: CheckBox a -> (IO ()) -> IO () checkBoxOnCommand checkBox eventHandler = windowOnEvent checkBox [wxEVT_COMMAND_CHECKBOX_CLICKED] eventHandler (\evt -> eventHandler) -- | Get the current check box event handler. checkBoxGetOnCommand :: CheckBox a -> IO (IO ()) checkBoxGetOnCommand checkBox = unsafeWindowGetHandlerState checkBox wxEVT_COMMAND_CHECKBOX_CLICKED (skipCurrentEvent) -- | Set an event handler for when a spinCtrl clicked. spinCtrlOnCommand :: SpinCtrl a -> (IO ()) -> IO () spinCtrlOnCommand spinCtrl eventHandler = windowOnEvent spinCtrl [wxEVT_COMMAND_SPINCTRL_UPDATED] eventHandler (\evt -> eventHandler) -- | Get the current check box event handler. spinCtrlGetOnCommand :: SpinCtrl a -> IO (IO ()) spinCtrlGetOnCommand spinCtrl = unsafeWindowGetHandlerState spinCtrl wxEVT_COMMAND_SPINCTRL_UPDATED (skipCurrentEvent) {----------------------------------------------------------------------------------------- wxStyledTextCtrl's event -----------------------------------------------------------------------------------------} -- | Scintilla events. * Means extra information is available (excluding position, -- key and modifiers) but not yet implemented. ! means it's done data EventSTC = STCChange -- ^ ! wxEVT_STC_CHANGE. | STCStyleNeeded -- ^ ! wxEVT_STC_STYLENEEDED. | STCCharAdded Char Int -- ^ ? wxEVT_STC_CHARADDED. The position seems to be broken | STCSavePointReached -- ^ ! wxEVT_STC_SAVEPOINTREACHED. | STCSavePointLeft -- ^ ! wxEVT_STC_SAVEPOINTLEFT. | STCROModifyAttempt -- ^ ! wxEVT_STC_ROMODIFYATTEMPT. | STCKey -- ^ * wxEVT_STC_KEY. -- kolmodin 20050304: -- is this event ever raised? not under linux. -- according to davve, not under windows either | STCDoubleClick -- ^ ! wxEVT_STC_DOUBLECLICK. | STCUpdateUI -- ^ ! wxEVT_STC_UPDATEUI. | STCModified Int Int (Maybe String) Int Int Int Int Int -- ^ ? wxEVT_STC_MODIFIED. | STCMacroRecord Int Int Int -- ^ ! wxEVT_STC_MACRORECORD iMessage wParam lParam | STCMarginClick Bool Bool Bool Int Int -- ^ ? wxEVT_STC_MARGINCLICK. -- kolmodin 20050304: -- Add something nicer for alt, shift and ctrl? -- Perhaps a new datatype or a tuple. | STCNeedShown Int Int -- ^ ! wxEVT_STC_NEEDSHOWN length position. | STCPainted -- ^ ! wxEVT_STC_PAINTED. | STCUserListSelection Int String -- ^ ! wxEVT_STC_USERLISTSELECTION listType text | STCUriDropped String -- ^ ! wxEVT_STC_URIDROPPED | STCDwellStart Point -- ^ ! wxEVT_STC_DWELLSTART | STCDwellEnd Point -- ^ ! wxEVT_STC_DWELLEND | STCStartDrag Int Int String -- ^ ! wxEVT_STC_START_DRAG. | STCDragOver Point DragResult -- ^ ! wxEVT_STC_DRAG_OVER | STCDoDrop String DragResult -- ^ ! wxEVT_STC_DO_DROP | STCZoom -- ^ ! wxEVT_STC_ZOOM | STCHotspotClick -- ^ ! wxEVT_STC_HOTSPOT_CLICK | STCHotspotDClick -- ^ ! wxEVT_STC_HOTSPOT_DCLICK | STCCalltipClick -- ^ ! wxEVT_STC_CALLTIP_CLICK | STCAutocompSelection -- ^ ! wxEVT_STC_AUTOCOMP_SELECTION | STCUnknown -- ^ Unknown event. Should never occur. instance Show EventSTC where show STCChange = "(stc event: change)" show STCStyleNeeded = "(stc event: style needed)" show (STCCharAdded c p) = "(stc event: char added: " ++ show c ++ " at position " ++ show p ++ ")" show STCSavePointReached = "(stc event: save point reached)" show STCSavePointLeft = "(stc event: save point left)" show STCROModifyAttempt = "(stc event: read only modify attempt)" show STCKey = "(stc event: key)" show STCDoubleClick = "(stc event: double click)" show STCUpdateUI = "(stc event: update ui)" show (STCModified p mt t len ladd line fln flp) = "(stc event: modified: position " ++ show p ++ ", modtype " ++ show mt ++ ", text " ++ show t ++ ", length " ++ show len ++ ", lines added " ++ show ladd ++ ", line " ++ show line ++ ", fln " ++ show fln ++ ", flp " ++ show flp ++ ")" show (STCMacroRecord m wp lp) = "(stc event: macro record, message " ++ show m ++ ", wParam " ++ show wp ++ ", lParam " ++ show lp ++ ")" show (STCMarginClick alt shift ctrl p m) = "(stc event: margin " ++ show m ++ " clicked, pos " ++ show p ++ ", modifiers = [" ++ (if alt then "alt, " else "") ++ (if shift then "shift, " else "") ++ (if ctrl then "control" else "") ++ "])" show (STCNeedShown p len) = "(stc event: need to show lines from " ++ show p ++ ", length " ++ show len ++ ")" show STCPainted = "(stc event: painted)" show (STCUserListSelection lt t) = "(stc event: user list selection, type " ++ show lt ++ ", text " ++ show t ++ ")" show (STCUriDropped t) = "(stc event: uri dropped: " ++ t ++ ")" show (STCDwellStart p) = "(stc event: dwell start, (x,y) " ++ show p ++ ")" show (STCDwellEnd p) = "(stc event: dwell end, (x,y) " ++ show p ++ ")" show (STCStartDrag lin car str) = "(stc event: start drag, line " ++ show lin ++ ", caret " ++ show car ++ ", text " ++ show str ++ ")" show (STCDragOver p res) = "(stc event: drag over, (x,y) " ++ show p ++ ", dragResult " ++ show res ++ ")" show (STCDoDrop str res) = "(stc event: do drop, text " ++ show str ++ ", dragResult " ++ show res ++ ")" show STCZoom = "(stc event: zoom)" show STCHotspotClick = "(stc event: hotspot click)" show STCHotspotDClick = "(stc event: hotspot double click)" show STCCalltipClick = "(stc event: calltip clicked)" show STCAutocompSelection = "(stc event: autocomp selectioned)" show STCUnknown = "(stc event: unknown)" fromSTCEvent :: StyledTextEvent a -> IO EventSTC fromSTCEvent event = do et <- eventGetEventType event case lookup et stcEvents of Just action -> action event Nothing -> return STCUnknown stcEvents :: [(EventId, StyledTextEvent a -> IO EventSTC)] stcEvents = [ (wxEVT_STC_CHANGE, \_ -> return STCChange) , (wxEVT_STC_STYLENEEDED, \_ -> return STCStyleNeeded) , (wxEVT_STC_CHARADDED, charAdded) , (wxEVT_STC_SAVEPOINTREACHED, \_ -> return STCSavePointReached) , (wxEVT_STC_SAVEPOINTLEFT, \_ -> return STCSavePointLeft) , (wxEVT_STC_ROMODIFYATTEMPT, \_ -> return STCROModifyAttempt) , (wxEVT_STC_KEY, \_ -> return STCKey) , (wxEVT_STC_DOUBLECLICK, \_ -> return STCDoubleClick) , (wxEVT_STC_UPDATEUI, \_ -> return STCUpdateUI) , (wxEVT_STC_MODIFIED, modified) , (wxEVT_STC_MACRORECORD, macroRecord) , (wxEVT_STC_MARGINCLICK, marginClick) , (wxEVT_STC_NEEDSHOWN, needShown) , (wxEVT_STC_PAINTED, \_ -> return STCPainted) , (wxEVT_STC_USERLISTSELECTION, userListSelection) , (wxEVT_STC_URIDROPPED, uriDropped) , (wxEVT_STC_DWELLSTART, dwellStart) , (wxEVT_STC_DWELLEND, dwellEnd) , (wxEVT_STC_START_DRAG, startDrag) , (wxEVT_STC_DRAG_OVER, dragOver) , (wxEVT_STC_DO_DROP, doDrop) , (wxEVT_STC_ZOOM, \_ -> return STCZoom) , (wxEVT_STC_HOTSPOT_CLICK, \_ -> return STCHotspotClick) , (wxEVT_STC_CALLTIP_CLICK, \_ -> return STCCalltipClick) -- TODO: STCAutocompSelection event is not tested yet. , (wxEVT_STC_AUTOCOMP_SELECTION, \_ -> return STCAutocompSelection) ] where charAdded evt = do c <- styledTextEventGetKey evt let c' | c < 0 = chr $ c + 256 | otherwise = chr c p <- styledTextEventGetPosition evt return $ STCCharAdded c' p modified evt = do p <- styledTextEventGetPosition evt mt <- styledTextEventGetModificationType evt t <- styledTextEventGetText evt len <- styledTextEventGetLength evt ladd <- styledTextEventGetLinesAdded evt line <- styledTextEventGetLine evt fln <- styledTextEventGetFoldLevelNow evt flp <- styledTextEventGetFoldLevelPrev evt -- TODO: t should only be returned under some modificationtype conditions -- or should we always return it? return $ STCModified p mt (Just t) len ladd line fln flp macroRecord evt = do m <- styledTextEventGetMessage evt wp <- styledTextEventGetWParam evt lp <- styledTextEventGetLParam evt return $ STCMacroRecord m wp lp marginClick evt = do alt <- styledTextEventGetAlt evt shift <- styledTextEventGetShift evt ctrl <- styledTextEventGetControl evt p <- styledTextEventGetPosition evt m <- styledTextEventGetMargin evt return $ STCMarginClick alt shift ctrl p m needShown evt = do p <- styledTextEventGetPosition evt len <- styledTextEventGetLength evt return $ STCNeedShown p len {- -- expEVT_STC_POSCHANGED is removed in wxWidgets-2.6.x. posChanged evt = do p <- styledTextEventGetPosition evt return $ STCPosChanged p -} userListSelection evt = do lt <- styledTextEventGetListType evt text <- styledTextEventGetText evt return $ STCUserListSelection lt text uriDropped evt = do t <- styledTextEventGetText evt return $ STCUriDropped t dwellStart evt = do x <- styledTextEventGetX evt y <- styledTextEventGetY evt return $ STCDwellStart (point x y) dwellEnd evt = do x <- styledTextEventGetX evt y <- styledTextEventGetY evt return $ STCDwellEnd (point x y) startDrag evt = do lin <- styledTextEventGetLine evt car <- styledTextEventGetPosition evt str <- styledTextEventGetDragText evt return $ STCStartDrag lin car str dragOver evt = do x <- styledTextEventGetX evt y <- styledTextEventGetY evt res <- styledTextEventGetDragResult evt return $ STCDragOver (point x y) $ toDragResult res doDrop evt = do str <- styledTextEventGetDragText evt res <- styledTextEventGetDragResult evt return $ STCDoDrop str $ toDragResult res stcOnSTCEvent :: StyledTextCtrl a -> (EventSTC -> IO ()) -> IO () stcOnSTCEvent stc handler = do windowOnEvent stc stcEventsAll handler eventHandler where eventHandler event = do eventSTC <- fromSTCEvent (objectCast event) if isSTCUnknown eventSTC then return () -- what else? else handler eventSTC isSTCUnknown :: EventSTC -> Bool isSTCUnknown STCUnknown = True isSTCUnknown _ = False -- most of the events can probably be ignored stcEventsAll = map fst stcEvents stcGetOnSTCEvent :: StyledTextCtrl a -> IO (EventSTC -> IO ()) stcGetOnSTCEvent window = unsafeWindowGetHandlerState window (head $ map fst stcEvents) (\ev -> skipCurrentEvent) {----------------------------------------------------------------------------------------- Printing -----------------------------------------------------------------------------------------} -- | Printer events. data EventPrint = PrintBeginDoc (IO ()) Int Int -- ^ Print a copy: cancel, start page, end page | PrintEndDoc | PrintBegin -- ^ Begin a print job. | PrintEnd | PrintPrepare -- ^ Prepare: chance to call 'printOutSetPageLimits' for example. | PrintPage (IO ()) (DC ()) Int -- ^ Print a page: cancel, printer device context, page number. | PrintUnknown Int -- ^ Unknown print event with event code -- | Convert a 'PrintEvent' object to an 'EventPrint' value. fromPrintEvent :: WXCPrintEvent a -> IO EventPrint fromPrintEvent event = do tp <- eventGetEventType event case lookup tp printEvents of Just f -> f event Nothing -> return (PrintUnknown tp) -- | Print event list. printEvents :: [(Int,WXCPrintEvent a -> IO EventPrint)] printEvents = [(wxEVT_PRINT_PAGE, \ev -> do page <- wxcPrintEventGetPage ev pout <- wxcPrintEventGetPrintout ev dc <- printoutGetDC pout let cancel = wxcPrintEventSetContinue ev False return (PrintPage cancel dc page)) ,(wxEVT_PRINT_BEGIN_DOC,\ev -> do page <- wxcPrintEventGetPage ev epage<- wxcPrintEventGetEndPage ev let cancel = wxcPrintEventSetContinue ev False return (PrintBeginDoc cancel page epage)) ,(wxEVT_PRINT_PREPARE, \ev -> return PrintPrepare) ,(wxEVT_PRINT_END_DOC, \ev -> return PrintEndDoc) ,(wxEVT_PRINT_BEGIN, \ev -> return PrintBegin) ,(wxEVT_PRINT_END, \ev -> return PrintEnd) ] -- | Set an event handler for printing. printOutOnPrint :: WXCPrintout a -> (EventPrint -> IO ()) -> IO () printOutOnPrint printOut eventHandler = do evtHandler <- wxcPrintoutGetEvtHandler printOut evtHandlerOnEvent evtHandler idAny idAny (map fst printEvents) eventHandler (\_ -> return ()) printHandler where printHandler event = do eventPrint <- fromPrintEvent (objectCast event) eventHandler eventPrint -- | Get the current print handler printOutGetOnPrint :: WXCPrintout a -> IO (EventPrint -> IO ()) printOutGetOnPrint printOut = do evtHandler <- wxcPrintoutGetEvtHandler printOut unsafeGetHandlerState evtHandler idAny wxEVT_PRINT_PAGE (\ev -> skipCurrentEvent) {----------------------------------------------------------------------------------------- Scrolling -----------------------------------------------------------------------------------------} -- | Scroll events. data EventScroll = ScrollTop !Orientation !Int -- ^ scroll to top | ScrollBottom !Orientation !Int -- ^ scroll to bottom | ScrollLineUp !Orientation !Int -- ^ scroll line up | ScrollLineDown !Orientation !Int -- ^ scroll line down | ScrollPageUp !Orientation !Int -- ^ scroll page up | ScrollPageDown !Orientation !Int -- ^ scroll page down | ScrollTrack !Orientation !Int -- ^ frequent event when user drags the thumbtrack | ScrollRelease !Orientation !Int -- ^ thumbtrack is released deriving Show -- | The orientation of a widget. data Orientation = Horizontal | Vertical deriving (Eq, Show) -- | Get the orientation of a scroll event. scrollOrientation :: EventScroll -> Orientation scrollOrientation scroll = case scroll of ScrollTop orient pos -> orient ScrollBottom orient pos -> orient ScrollLineUp orient pos -> orient ScrollLineDown orient pos -> orient ScrollPageUp orient pos -> orient ScrollPageDown orient pos -> orient ScrollTrack orient pos -> orient ScrollRelease orient pos -> orient -- | Get the position of the scroll bar. scrollPos :: EventScroll -> Int scrollPos scroll = case scroll of ScrollTop orient pos -> pos ScrollBottom orient pos -> pos ScrollLineUp orient pos -> pos ScrollLineDown orient pos -> pos ScrollPageUp orient pos -> pos ScrollPageDown orient pos -> pos ScrollTrack orient pos -> pos ScrollRelease orient pos -> pos fromScrollEvent :: ScrollWinEvent a -> IO EventScroll fromScrollEvent event = do orient <- scrollWinEventGetOrientation event pos <- scrollWinEventGetPosition event tp <- eventGetEventType event let orientation | orient == wxHORIZONTAL = Horizontal | otherwise = Vertical case lookup tp scrollEvents of Just evt -> return (evt orientation pos) Nothing -> return (ScrollRelease orientation pos) scrollEvents :: [(Int,Orientation -> Int -> EventScroll)] scrollEvents = [(wxEVT_SCROLLWIN_TOP, ScrollTop) ,(wxEVT_SCROLLWIN_BOTTOM, ScrollBottom) ,(wxEVT_SCROLLWIN_LINEUP, ScrollLineUp) ,(wxEVT_SCROLLWIN_LINEDOWN, ScrollLineDown) ,(wxEVT_SCROLLWIN_PAGEUP, ScrollPageUp) ,(wxEVT_SCROLLWIN_PAGEDOWN, ScrollPageDown) ,(wxEVT_SCROLLWIN_THUMBTRACK, ScrollTrack) ,(wxEVT_SCROLLWIN_THUMBRELEASE, ScrollRelease) ] -- | Set a scroll event handler. windowOnScroll :: Window a -> (EventScroll -> IO ()) -> IO () windowOnScroll window eventHandler = windowOnEvent window (map fst scrollEvents) eventHandler scrollHandler where scrollHandler event = do eventScroll <- fromScrollEvent (objectCast event) eventHandler eventScroll -- | Get the current scroll event handler of a window. windowGetOnScroll :: Window a -> IO (EventScroll -> IO ()) windowGetOnScroll window = unsafeWindowGetHandlerState window wxEVT_SCROLLWIN_TOP (\scroll -> skipCurrentEvent) {-------------------------------------------------------------------------- Html event --------------------------------------------------------------------------} -- | Html window events data EventHtml = HtmlCellClicked String EventMouse Point -- ^ A /cell/ is clicked. Contains the cell /id/ attribute value, the mouse event and the logical coordinates. | HtmlCellHover String -- ^ The mouse hovers over a cell. Contains the cell /id/ attribute value. | HtmlLinkClicked String String String EventMouse Point -- ^ A link is clicked. Contains the hyperlink, the frame target, the cell /id/ attribute value, the mouse event, and the logical coordinates. | HtmlSetTitle String -- ^ Called when a @@ tag is parsed. | HtmlUnknown -- ^ Unrecognised html event instance Show EventHtml where show ev = case ev of HtmlCellClicked id mouse pnt -> "Html Cell " ++ show id ++ " clicked: " ++ show mouse HtmlLinkClicked href target id mouse p -> "Html Link " ++ show id ++ " clicked: " ++ href HtmlCellHover id -> "Html Cell " ++ show id ++ " hover" HtmlSetTitle title -> "Html event title: " ++ title HtmlUnknown -> "Html event unknown" fromHtmlEvent :: WXCHtmlEvent a -> IO EventHtml fromHtmlEvent event = do tp <- eventGetEventType event case lookup tp htmlEvents of Nothing -> return HtmlUnknown Just action -> action event where htmlEvents = [(wxEVT_HTML_CELL_MOUSE_HOVER, htmlHover) ,(wxEVT_HTML_CELL_CLICKED, htmlClicked) ,(wxEVT_HTML_LINK_CLICKED, htmlLink) ,(wxEVT_HTML_SET_TITLE, htmlTitle)] htmlTitle event = do title <- commandEventGetString event return (HtmlSetTitle title) htmlHover event = do id <- wxcHtmlEventGetHtmlCellId event return (HtmlCellHover id) htmlClicked event = do id <- wxcHtmlEventGetHtmlCellId event mouseEv <- wxcHtmlEventGetMouseEvent event mouse <- fromMouseEvent mouseEv pnt <- wxcHtmlEventGetLogicalPosition event return (HtmlCellClicked id mouse pnt) htmlLink event = do id <- wxcHtmlEventGetHtmlCellId event mouseEv <- wxcHtmlEventGetMouseEvent event mouse <- fromMouseEvent mouseEv href <- wxcHtmlEventGetHref event target <- wxcHtmlEventGetTarget event pnt <- wxcHtmlEventGetLogicalPosition event return (HtmlLinkClicked href target id mouse pnt) -- | Set a html event handler for a html window. The first argument determines whether -- hover events ('HtmlCellHover') are handled or not. htmlWindowOnHtmlEvent :: WXCHtmlWindow a -> Bool -> (EventHtml -> IO ()) -> IO () htmlWindowOnHtmlEvent window allowHover handler = windowOnEvent window htmlEvents handler eventHandler where htmlEvents = [wxEVT_HTML_CELL_CLICKED,wxEVT_HTML_LINK_CLICKED,wxEVT_HTML_SET_TITLE] ++ (if allowHover then [wxEVT_HTML_CELL_MOUSE_HOVER] else []) eventHandler event = do eventHtml <- fromHtmlEvent (objectCast event) handler eventHtml -- | Get the current html event handler of a html window. htmlWindowGetOnHtmlEvent :: WXCHtmlWindow a -> IO (EventHtml -> IO ()) htmlWindowGetOnHtmlEvent window = unsafeWindowGetHandlerState window wxEVT_HTML_CELL_CLICKED (\ev -> skipCurrentEvent) {----------------------------------------------------------------------------------------- Close, Destroy, Create -----------------------------------------------------------------------------------------} -- | Adds a close handler to the currently installed close handlers. windowAddOnClose :: Window a -> IO () -> IO () windowAddOnClose window new = do prev <- windowGetOnClose window windowOnClose window (do{ new; prev }) -- | Set an event handler that is called when the user tries to close a frame or dialog. -- Don't forget to call the previous handler or 'frameDestroy' explicitly or otherwise the -- frame won't be closed. windowOnClose :: Window a -> IO () -> IO () windowOnClose window eventHandler = windowOnEvent window [wxEVT_CLOSE_WINDOW] eventHandler (\ev -> eventHandler) -- | Get the current close event handler. windowGetOnClose :: Window a -> IO (IO ()) windowGetOnClose window = unsafeWindowGetHandlerState window wxEVT_CLOSE_WINDOW (do windowDestroy window; return ()) -- | Set an event handler that is called when the window is destroyed. -- /Note: does not seem to work on windows/. windowOnDestroy :: Window a -> IO () -> IO () windowOnDestroy window eventHandler = windowOnEvent window [wxEVT_DESTROY] eventHandler (\ev -> eventHandler) -- | Get the current destroy event handler. windowGetOnDestroy :: Window a -> IO (IO ()) windowGetOnDestroy window = unsafeWindowGetHandlerState window wxEVT_DESTROY (return ()) -- | Add a delete-event handler to the current installed delete-event handlers. -- -- > windowAddOnDelete window new -- > = do prev <- windowGetOnDelete window -- > windowOnDelete window (do{ new; prev }) windowAddOnDelete :: Window a -> IO () -> IO () windowAddOnDelete window new = do prev <- windowGetOnDelete window windowOnDelete window (do{ new; prev }) -- | Set an event handler that is called when the window is deleted. -- Use with care as the window itself is in a deletion state. windowOnDelete :: Window a -> IO () -> IO () windowOnDelete window eventHandler = windowOnEventEx window [wxEVT_DELETE] eventHandler onDelete (\ev -> return ()) where onDelete ownerDeleted | ownerDeleted = eventHandler | otherwise = return () -- don't run on disconnect! -- | Get the current delete event handler. windowGetOnDelete :: Window a -> IO (IO ()) windowGetOnDelete window = unsafeWindowGetHandlerState window wxEVT_DELETE (return ()) -- | Set an event handler that is called when the window is created. windowOnCreate :: Window a -> IO () -> IO () windowOnCreate window eventHandler = windowOnEvent window [wxEVT_CREATE] eventHandler (\ev -> eventHandler) -- | Get the current create event handler. windowGetOnCreate :: Window a -> IO (IO ()) windowGetOnCreate window = unsafeWindowGetHandlerState window wxEVT_CREATE (return ()) -- | Set an event handler that is called when the window is resized. windowOnSize :: Window a -> IO () -> IO () windowOnSize window eventHandler = windowOnEvent window [wxEVT_SIZE] eventHandler (\ev -> eventHandler) -- | Get the current resize event handler. windowGetOnSize :: Window a -> IO (IO ()) windowGetOnSize window = unsafeWindowGetHandlerState window wxEVT_SIZE (return ()) -- | Set an event handler that is called when the window is activated or deactivated. -- The event parameter is 'True' when the window is activated. windowOnActivate :: Window a -> (Bool -> IO ()) -> IO () windowOnActivate window eventHandler = windowOnEvent window [wxEVT_ACTIVATE] eventHandler activateHandler where activateHandler event = do active <- activateEventGetActive (objectCast event) eventHandler active -- | Get the current activate event handler. windowGetOnActivate :: Window a -> IO (Bool -> IO ()) windowGetOnActivate window = unsafeWindowGetHandlerState window wxEVT_ACTIVATE (\active -> return ()) -- | Set an event handler that is called when the window gets or loses the focus. -- The event parameter is 'True' when the window gets the focus. windowOnFocus :: Window a -> (Bool -> IO ()) -> IO () windowOnFocus window eventHandler = do windowOnEvent window [wxEVT_SET_FOCUS] eventHandler getFocusHandler windowOnEvent window [wxEVT_KILL_FOCUS] eventHandler killFocusHandler where getFocusHandler event = eventHandler True killFocusHandler event = eventHandler False -- | Get the current focus event handler. windowGetOnFocus :: Window a -> IO (Bool -> IO ()) windowGetOnFocus window = unsafeWindowGetHandlerState window wxEVT_SET_FOCUS (\getfocus -> return ()) -- | A context menu event is generated when the user righ-clicks in a window -- or presses shift-F10. windowOnContextMenu :: Window a -> IO () -> IO () windowOnContextMenu window eventHandler = windowOnEvent window [wxEVT_CONTEXT_MENU] eventHandler (\ev -> eventHandler) -- | Get the current context menu event handler. windowGetOnContextMenu :: Window a -> IO (IO ()) windowGetOnContextMenu window = unsafeWindowGetHandlerState window wxEVT_CONTEXT_MENU skipCurrentEvent -- | A menu event is generated when the user selects a menu item. -- You should install this handler on the window that owns the menubar or a popup menu. evtHandlerOnMenuCommand :: EvtHandler a -> Id -> IO () -> IO () evtHandlerOnMenuCommand window id eventHandler = evtHandlerOnEvent window id id [wxEVT_COMMAND_MENU_SELECTED] eventHandler (\_ -> return ()) (\ev -> eventHandler) -- | Get the current event handler for a certain menu. evtHandlerGetOnMenuCommand :: EvtHandler a -> Id -> IO (IO ()) evtHandlerGetOnMenuCommand window id = unsafeGetHandlerState window id wxEVT_COMMAND_MENU_SELECTED skipCurrentEvent -- | An idle event is generated in idle time. The handler should return whether more -- idle processing is needed ('True') or otherwise the event loop goes into a passive -- waiting state. windowOnIdle :: Window a -> IO Bool -> IO () windowOnIdle window eventHandler = windowOnEvent window [wxEVT_IDLE] eventHandler idleHandler where idleHandler event = do requestMore <- eventHandler idleEventRequestMore (objectCast event) requestMore return () -- | Get the current context menu event handler. windowGetOnIdle :: Window a -> IO (IO Bool) windowGetOnIdle window = unsafeWindowGetHandlerState window wxEVT_IDLE (return False) -- | A timer event is generated by an attached timer, see 'windowTimerAttach'. -- /Broken!/ (use 'timerOnCommand' instead). windowOnTimer :: Window a -> IO () -> IO () windowOnTimer window eventHandler = windowOnEvent window [wxEVT_TIMER] eventHandler (\ev -> eventHandler) -- | Get the current timer handler. windowGetOnTimer :: Window a -> IO (IO ()) windowGetOnTimer window = unsafeWindowGetHandlerState window wxEVT_TIMER (return ()) {----------------------------------------------------------------------------------------- Paint -----------------------------------------------------------------------------------------} -- | Set an event handler for /raw/ paint events. Draws directly to the -- paint device context ('PaintDC') and the 'DC' is not cleared when the handler -- is called. The handler takes two other arguments: the view rectangle and a -- list of /dirty/ rectangles. The rectangles contain logical coordinates and -- are already adjusted for scrolled windows. -- Note: you can not set both a 'windowOnPaintRaw' and 'windowOnPaint' handler! windowOnPaintRaw :: Window a -> (DC () -> Rect -> [Rect] -> IO ()) -> IO () windowOnPaintRaw window paintHandler = windowOnEvent window [wxEVT_PAINT] paintHandler onPaint where onPaint event = do obj <- eventGetEventObject event if (obj==objectNull) then return () else do let window = objectCast obj region <- windowGetUpdateRects window view <- windowGetViewRect window withPaintDC window (\paintDC -> do isScrolled <- objectIsScrolledWindow window when (isScrolled) (scrolledWindowPrepareDC (objectCast window) paintDC) paintHandler (downcastDC paintDC) view region) -- | Get the current /raw/ paint event handler. windowGetOnPaintRaw :: Window a -> IO (DC () -> Rect -> [Rect] -> IO ()) windowGetOnPaintRaw window = unsafeWindowGetHandlerState window wxEVT_PAINT (\dc rect region -> return ()) -- | Set an event handler for paint events. The implementation uses an -- intermediate buffer for non-flickering redraws. -- The device context ('DC') -- is always cleared before the paint handler is called. The paint handler -- also gets the currently visible view area as an argument (adjusted for scrolling). -- Note: you can not set both a 'windowOnPaintRaw' and 'windowOnPaint' handler! windowOnPaint :: Window a -> (DC () -> Rect -> IO ()) -> IO () windowOnPaint window paintHandler | wxToolkit == WxMac = windowOnPaintRaw window (\dc view _ -> paintHandler dc view) | otherwise = do v <- varCreate objectNull windowOnEventEx window [wxEVT_PAINT] paintHandler (destroy v) (onPaint v) where destroy v ownerDeleted = do bitmap <- varSwap v objectNull when (not (objectIsNull bitmap)) (bitmapDelete bitmap) onPaint v event = do obj <- eventGetEventObject event if (obj==objectNull) then return () else do let window = objectCast obj view <- windowGetViewRect window withPaintDC window (\paintDC -> do isScrolled <- objectIsScrolledWindow window when (isScrolled) (scrolledWindowPrepareDC (objectCast window) paintDC) -- Note: wxMSW 2.4 does not clear the properly scrolled view rectangle. let clear dc | wxToolkit == WxMSW = dcClearRect dc view | otherwise = dcClear dc -- and repaint with buffer dcBufferWithRefEx paintDC clear (Just v) view (\dc -> paintHandler dc view)) -- | Get the current paint event handler. windowGetOnPaint :: Window a -> IO (DC () -> Rect -> IO ()) windowGetOnPaint window = unsafeWindowGetHandlerState window wxEVT_PAINT (\dc view -> return ()) -- Get the logical /dirty/ rectangles as a list of 'Rect'. windowGetUpdateRects :: Window a -> IO [Rect] windowGetUpdateRects window = do region <- windowGetUpdateRegion window iter <- regionIteratorCreateFromRegion region rects <- getRects iter regionIteratorDelete iter p <- windowGetViewStart window return (map (\r -> rectMove r (vecFromPoint p)) rects) where getRects iter = do more <- regionIteratorHaveRects iter if more then do x <- regionIteratorGetX iter y <- regionIteratorGetY iter w <- regionIteratorGetWidth iter h <- regionIteratorGetHeight iter regionIteratorNext iter rs <- getRects iter return (rect (pt x y) (sz w h) : rs) else return [] {----------------------------------------------------------------------------------------- Modifiers -----------------------------------------------------------------------------------------} -- | Called when a process is ended with the process @pid@ and exitcode. evtHandlerOnEndProcess :: EvtHandler a -> (Int -> Int -> IO ()) -> IO () evtHandlerOnEndProcess evtHandler handler = evtHandlerOnEvent evtHandler (-1) (-1) [wxEVT_END_PROCESS] handler onDelete onEndProcess where onDelete ownerDeleted = return () onEndProcess event = let processEvent = objectCast event in do pid <- processEventGetPid processEvent code <- processEventGetExitCode processEvent handler pid code -- | Retrieve the current end process handler. evtHandlerGetOnEndProcess :: EvtHandler a -> IO (Int -> Int -> IO ()) evtHandlerGetOnEndProcess evtHandler = unsafeGetHandlerState evtHandler (-1) wxEVT_END_PROCESS (\pid code -> return ()) -- | The status of a stream (see 'StreamBase') data StreamStatus = StreamOk -- ^ No error. | StreamEof -- ^ No more input. | StreamReadError -- ^ Read error. | StreamWriteError -- ^ Write error. deriving (Eq,Show) -- | Convert a stream status code into 'StreamStatus'. streamStatusFromInt :: Int -> StreamStatus streamStatusFromInt code | code == wxSTREAM_NO_ERROR = StreamOk | code == wxSTREAM_EOF = StreamEof | code == wxSTREAM_READ_ERROR = StreamReadError | code == wxSTREAM_WRITE_ERROR = StreamWriteError | otherwise = StreamReadError -- | Install an event handler on an input stream. The handler is called -- whenever input is read (or when an error occurred). The third parameter -- gives the size of the input batches. The orignal input stream should no longer be referenced after this call! evtHandlerOnInput :: EvtHandler b -> (String -> StreamStatus -> IO ()) -> InputStream a -> Int -> IO () evtHandlerOnInput evtHandler handler stream bufferLen = do sink <- inputSinkCreate stream evtHandler bufferLen evtHandlerOnInputSink evtHandler handler sink inputSinkStart sink -- | Install an event handler on a specific input sink. It is advised to -- use the 'evtHandlerOnInput' whenever retrieval of the handler is not necessary. evtHandlerOnInputSink :: EvtHandler b -> (String -> StreamStatus -> IO ()) -> InputSink a -> IO () evtHandlerOnInputSink evtHandler handler sink = do id <- inputSinkGetId sink evtHandlerOnEvent evtHandler id id [wxEVT_INPUT_SINK] handler onDelete onInput where onDelete ownerDeleted = return () onInput event = let inputSinkEvent = objectCast event in do input <- inputSinkEventLastString inputSinkEvent code <- inputSinkEventLastError inputSinkEvent handler input (streamStatusFromInt code) -- | Retrieve the current input stream handler. evtHandlerGetOnInputSink :: EvtHandler b -> IO (String -> StreamStatus -> IO ()) evtHandlerGetOnInputSink evtHandler = unsafeGetHandlerState evtHandler (-1) wxEVT_INPUT_SINK (\input status -> return ()) -- | Read the input from an 'InputSinkEvent'. inputSinkEventLastString :: InputSinkEvent a -> IO String inputSinkEventLastString inputSinkEvent = do n <- inputSinkEventLastRead inputSinkEvent if (n <= 0) then return "" else do buffer <- inputSinkEventLastInput inputSinkEvent peekCWStringLen (buffer,n) {----------------------------------------------------------------------------------------- Modifiers -----------------------------------------------------------------------------------------} -- | The @Modifiers@ indicate the meta keys that have been pressed ('True') or not ('False'). data Modifiers = Modifiers { altDown :: !Bool -- ^ alt key down , shiftDown :: !Bool -- ^ shift key down , controlDown :: !Bool -- ^ control key down , metaDown :: !Bool -- ^ meta key down } deriving (Eq) instance Show Modifiers where show mods = showModifiers mods -- | Show modifiers, for example for use in menus. showModifiers :: Modifiers -> String showModifiers mods = concat $ intersperse "+" $ filter (not.null) [if controlDown mods then "Ctrl" else "" ,if altDown mods then "Alt" else "" ,if shiftDown mods then "Shift" else "" ,if metaDown mods then "Meta" else "" ] -- | Construct a 'Modifiers' structure with no meta keys pressed. noneDown :: Modifiers noneDown = Modifiers False False False False -- | Construct a 'Modifiers' structure with just Shift meta key pressed. justShift :: Modifiers justShift = noneDown{ shiftDown = True } -- | Construct a 'Modifiers' structure with just Alt meta key pressed. justAlt :: Modifiers justAlt = noneDown{ altDown = True } -- | Construct a 'Modifiers' structure with just Ctrl meta key pressed. justControl :: Modifiers justControl = noneDown{ controlDown = True } -- | Construct a 'Modifiers' structure with just Meta meta key pressed. justMeta :: Modifiers justMeta = noneDown{ metaDown = True } -- | Test if no meta key was pressed. isNoneDown :: Modifiers -> Bool isNoneDown (Modifiers shift control alt meta) = not (shift || control || alt || meta) -- | Test if no shift, alt, or control key was pressed. isNoShiftAltControlDown :: Modifiers -> Bool isNoShiftAltControlDown (Modifiers shift control alt meta) = not (shift || control || alt) -- | Tranform modifiers into an accelerator modifiers code. modifiersToAccelFlags :: Modifiers -> Int modifiersToAccelFlags mod = mask (altDown mod) 0x01 + mask (controlDown mod) 0x02 + mask (shiftDown mod) 0x04 where mask test flag = if test then flag else 0 {----------------------------------------------------------------------------------------- MouseEvent -----------------------------------------------------------------------------------------} -- | Mouse events. The 'Point' gives the logical (unscrolled) position. data EventMouse = MouseMotion !Point !Modifiers -- ^ Mouse was moved over the client area of the window | MouseEnter !Point !Modifiers -- ^ Mouse enters in the client area of the window | MouseLeave !Point !Modifiers -- ^ Mouse leaves the client area of the window | MouseLeftDown !Point !Modifiers -- ^ Mouse left button goes down | MouseLeftUp !Point !Modifiers -- ^ Mouse left button goes up | MouseLeftDClick !Point !Modifiers -- ^ Mouse left button double click | MouseLeftDrag !Point !Modifiers -- ^ Mouse left button drag | MouseRightDown !Point !Modifiers -- ^ Mouse right button goes down | MouseRightUp !Point !Modifiers -- ^ Mouse right button goes up | MouseRightDClick !Point !Modifiers -- ^ Mouse right button double click | MouseRightDrag !Point !Modifiers -- ^ Mouse right button drag (unsupported on most platforms) | MouseMiddleDown !Point !Modifiers -- ^ Mouse middle button goes down | MouseMiddleUp !Point !Modifiers -- ^ Mouse middle button goes up | MouseMiddleDClick !Point !Modifiers -- ^ Mouse middle button double click | MouseMiddleDrag !Point !Modifiers -- ^ Mouse middle button drag (unsupported on most platforms) | MouseWheel !Bool !Point !Modifiers -- ^ Mouse wheel rotation. (Bool is True for a downward rotation) deriving (Eq) -- ,Show) instance Show EventMouse where show mouse = showMouse mouse -- | Show an 'EventMouse' in a user friendly way. showMouse :: EventMouse -> String showMouse mouse = (if (null modsText) then "" else modsText ++ "+") ++ action ++ " at " ++ show (x,y) where modsText = show (mouseModifiers mouse) (Point x y) = mousePos mouse action = case mouse of MouseMotion p m -> "Motion" MouseEnter p m -> "Enter" MouseLeave p m -> "Leave" MouseLeftDown p m -> "Left down" MouseLeftUp p m -> "Left up" MouseLeftDClick p m -> "Left double click" MouseLeftDrag p m -> "Left drag" MouseRightDown p m -> "Right down" MouseRightUp p m -> "Right up" MouseRightDClick p m -> "Right double click" MouseRightDrag p m -> "Right drag" MouseMiddleDown p m -> "Middle down" MouseMiddleUp p m -> "Middle up" MouseMiddleDClick p m -> "Middle double click" MouseMiddleDrag p m -> "Middle drag" MouseWheel down p m -> "Wheel " ++ (if down then "down" else "up") -- | Extract the position from a 'MouseEvent'. mousePos :: EventMouse -> Point mousePos mouseEvent = case mouseEvent of MouseMotion p m -> p MouseEnter p m -> p MouseLeave p m -> p MouseLeftDown p m -> p MouseLeftUp p m -> p MouseLeftDClick p m -> p MouseLeftDrag p m -> p MouseRightDown p m -> p MouseRightUp p m -> p MouseRightDClick p m -> p MouseRightDrag p m -> p MouseMiddleDown p m -> p MouseMiddleUp p m -> p MouseMiddleDClick p m -> p MouseMiddleDrag p m -> p MouseWheel _ p m -> p -- | Extract the modifiers from a 'MouseEvent'. mouseModifiers :: EventMouse -> Modifiers mouseModifiers mouseEvent = case mouseEvent of MouseMotion p m -> m MouseEnter p m -> m MouseLeave p m -> m MouseLeftDown p m -> m MouseLeftUp p m -> m MouseLeftDClick p m -> m MouseLeftDrag p m -> m MouseRightDown p m -> m MouseRightUp p m -> m MouseRightDClick p m -> m MouseRightDrag p m -> m MouseMiddleDown p m -> m MouseMiddleUp p m -> m MouseMiddleDClick p m -> m MouseMiddleDrag p m -> m MouseWheel _ p m -> m fromMouseEvent :: MouseEvent a -> IO EventMouse fromMouseEvent event = do x <- mouseEventGetX event y <- mouseEventGetY event obj <- eventGetEventObject event point <- windowCalcUnscrolledPosition (objectCast obj) (Point x y) altDown <- mouseEventAltDown event controlDown <- mouseEventControlDown event shiftDown <- mouseEventShiftDown event metaDown <- mouseEventMetaDown event let modifiers = Modifiers altDown shiftDown controlDown metaDown dragging <- mouseEventDragging event if (dragging) then do leftDown <- mouseEventLeftIsDown event if (leftDown) then return (MouseLeftDrag point modifiers) else do middleDown <- mouseEventMiddleIsDown event if (middleDown) then return (MouseMiddleDrag point modifiers) else do rightDown <- mouseEventRightIsDown event if (rightDown) then return (MouseRightDrag point modifiers) else return (MouseMotion point modifiers) else do tp <- eventGetEventType event case lookup tp mouseEventTypes of Just mouse -> return (mouse point modifiers) Nothing -> if (tp==wxEVT_MOUSEWHEEL) then do rot <- mouseEventGetWheelRotation event delta <- mouseEventGetWheelDelta event if (abs rot >= delta) then return (MouseWheel (rot<0) point modifiers) else return (MouseMotion point modifiers) else return (MouseMotion point modifiers) mouseEventTypes :: [(Int,Point -> Modifiers -> EventMouse)] mouseEventTypes = [(wxEVT_MOTION , MouseMotion) -- must be the first element, see "windowOnMouse" ,(wxEVT_ENTER_WINDOW , MouseEnter) ,(wxEVT_LEAVE_WINDOW , MouseLeave) ,(wxEVT_LEFT_DOWN , MouseLeftDown) ,(wxEVT_LEFT_UP , MouseLeftUp) ,(wxEVT_LEFT_DCLICK , MouseLeftDClick) ,(wxEVT_MIDDLE_DOWN , MouseMiddleDown) ,(wxEVT_MIDDLE_UP , MouseMiddleUp) ,(wxEVT_MIDDLE_DCLICK, MouseMiddleDClick) ,(wxEVT_RIGHT_DOWN , MouseRightDown) ,(wxEVT_RIGHT_UP , MouseRightUp) ,(wxEVT_RIGHT_DCLICK , MouseRightDClick) ] -- | Set a mouse event handler for a window. The first argument determines whether -- mouse motion events ('MouseMotion') are handled or not. windowOnMouse :: Window a -> Bool -> (EventMouse -> IO ()) -> IO () windowOnMouse window allowMotion handler = windowOnEvent window mouseEvents handler eventHandler where mouseEvents = (map fst (if allowMotion then mouseEventTypes else tail (mouseEventTypes))) ++ [wxEVT_MOUSEWHEEL] eventHandler event = do eventMouse <- fromMouseEvent (objectCast event) handler eventMouse -- | Get the current mouse event handler of a window. windowGetOnMouse :: Window a -> IO (EventMouse -> IO ()) windowGetOnMouse window = unsafeWindowGetHandlerState window wxEVT_ENTER_WINDOW (\ev -> skipCurrentEvent) {----------------------------------------------------------------------------------------- KeyboardEvent -----------------------------------------------------------------------------------------} -- | Set an event handler for untranslated key presses. If 'skipCurrentEvent' is not -- called, the corresponding 'windowOnKeyChar' eventhandler won't be called. windowOnKeyDown :: Window a -> (EventKey -> IO ()) -> IO () windowOnKeyDown window handler = windowOnEvent window [wxEVT_KEY_DOWN] handler eventHandler where eventHandler event = do eventKey <- eventKeyFromEvent (objectCast event) handler eventKey -- | Get the current key down handler of a window. windowGetOnKeyDown :: Window a -> IO (EventKey -> IO ()) windowGetOnKeyDown window = unsafeWindowGetHandlerState window wxEVT_KEY_DOWN (\eventKey -> skipCurrentEvent) -- | Set an event handler for translated key presses. windowOnKeyChar :: Window a -> (EventKey -> IO ()) -> IO () windowOnKeyChar window handler = windowOnEvent window [wxEVT_CHAR] handler eventHandler where eventHandler event = do eventKey <- eventKeyFromEvent (objectCast event) handler eventKey -- | Get the current translated key handler of a window. windowGetOnKeyChar :: Window a -> IO (EventKey -> IO ()) windowGetOnKeyChar window = unsafeWindowGetHandlerState window wxEVT_CHAR (\eventKey -> skipCurrentEvent) -- | Set an event handler for (untranslated) key releases. windowOnKeyUp :: Window a -> (EventKey -> IO ()) -> IO () windowOnKeyUp window handler = windowOnEvent window [wxEVT_KEY_UP] handler eventHandler where eventHandler event = do eventKey <- eventKeyFromEvent (objectCast event) handler eventKey -- | Get the current key release handler of a window. windowGetOnKeyUp :: Window a -> IO (EventKey -> IO ()) windowGetOnKeyUp window = unsafeWindowGetHandlerState window wxEVT_KEY_UP (\keyInfo -> skipCurrentEvent) eventKeyFromEvent :: KeyEvent a -> IO EventKey eventKeyFromEvent event = do x <- keyEventGetX event y <- keyEventGetY event obj <- eventGetEventObject event point <- if objectIsNull obj then return (Point x y) else windowCalcUnscrolledPosition (objectCast obj) (Point x y) altDown <- keyEventAltDown event controlDown <- keyEventControlDown event shiftDown <- keyEventShiftDown event metaDown <- keyEventMetaDown event let modifiers = Modifiers altDown shiftDown controlDown metaDown keyCode <- keyEventGetKeyCode event let key = keyCodeToKey keyCode return (EventKey key modifiers point) -- | A keyboard event contains the key, the modifiers and the focus point. data EventKey = EventKey !Key !Modifiers !Point deriving (Eq,Show) -- | Extract the key from a keyboard event. keyKey :: EventKey -> Key keyKey (EventKey key mods pos) = key -- | Extract the modifiers from a keyboard event. keyModifiers :: EventKey -> Modifiers keyModifiers (EventKey key mods pos) = mods -- | Extract the position from a keyboard event. keyPos :: EventKey -> Point keyPos (EventKey key mods pos) = pos -- | A low-level virtual key code. type KeyCode = Int -- | A 'Key' represents a single key on a keyboard. data Key = KeyChar !Char -- ^ An ascii code. | KeyOther !KeyCode -- ^ An unknown virtual key. | KeyBack | KeyTab | KeyReturn | KeyEscape | KeySpace | KeyDelete | KeyInsert | KeyEnd | KeyHome | KeyLeft | KeyUp | KeyRight | KeyDown | KeyPageUp | KeyPageDown | KeyStart | KeyClear | KeyShift | KeyAlt | KeyControl | KeyMenu | KeyPause | KeyCapital | KeyHelp | KeySelect | KeyPrint | KeyExecute | KeySnapshot | KeyCancel | KeyLeftButton | KeyRightButton | KeyMiddleButton | KeyNum0 | KeyNum1 | KeyNum2 | KeyNum3 | KeyNum4 | KeyNum5 | KeyNum6 | KeyNum7 | KeyNum8 | KeyNum9 | KeyMultiply | KeyAdd | KeySeparator | KeySubtract | KeyDecimal | KeyDivide | KeyF1 | KeyF2 | KeyF3 | KeyF4 | KeyF5 | KeyF6 | KeyF7 | KeyF8 | KeyF9 | KeyF10 | KeyF11 | KeyF12 | KeyF13 | KeyF14 | KeyF15 | KeyF16 | KeyF17 | KeyF18 | KeyF19 | KeyF20 | KeyF21 | KeyF22 | KeyF23 | KeyF24 | KeyNumLock | KeyScroll {- Note: If we add "deriving (Show)" we get a strange link error in ghci: Loading package wxh ... linking ... Overflown relocs: 122 -} deriving (Eq) {- | KeyNumSpace | KeyNumTab | KeyNumEnter | KeyNumF1 | KeyNumF2 | KeyNumF3 | KeyNumF4 | KeyNumHome | KeyNumLeft | KeyNumUp | KeyNumRight | KeyNumDown | KeyNumPageUp | KeyNumPageDown | KeyNumEnd | KeyNumBegin | KeyNumInsert | KeyNumDelete | KeyNumEqual | KeyNumMultiply | KeyNumAdd | KeyNumSeparator | KeyNumSubstract | KeyNumDecimal | KeyNumSubstract -} -- | From a key to a virtual key code. keyToKeyCode :: Key -> KeyCode keyToKeyCode key = case key of KeyChar c -> fromEnum c KeyOther code -> code KeyBack -> wxK_BACK KeyTab -> wxK_TAB KeyReturn -> wxK_RETURN KeyEscape -> wxK_ESCAPE KeySpace -> wxK_SPACE KeyDelete -> wxK_DELETE KeyInsert -> wxK_INSERT KeyEnd -> wxK_END KeyHome -> wxK_HOME KeyLeft -> wxK_LEFT KeyUp -> wxK_UP KeyRight -> wxK_RIGHT KeyDown -> wxK_DOWN KeyPageUp -> wxK_PAGEUP KeyPageDown -> wxK_PAGEDOWN KeyStart -> wxK_START KeyClear -> wxK_CLEAR KeyShift -> wxK_SHIFT KeyAlt -> wxK_ALT KeyControl -> wxK_CONTROL KeyMenu -> wxK_MENU KeyPause -> wxK_PAUSE KeyCapital -> wxK_CAPITAL KeyHelp -> wxK_HELP KeySelect -> wxK_SELECT KeyPrint -> wxK_PRINT KeyExecute -> wxK_EXECUTE KeySnapshot -> wxK_SNAPSHOT KeyCancel -> wxK_CANCEL KeyLeftButton -> wxK_LBUTTON KeyRightButton -> wxK_RBUTTON KeyMiddleButton -> wxK_MBUTTON KeyNum0 -> wxK_NUMPAD0 KeyNum1 -> wxK_NUMPAD1 KeyNum2 -> wxK_NUMPAD2 KeyNum3 -> wxK_NUMPAD3 KeyNum4 -> wxK_NUMPAD4 KeyNum5 -> wxK_NUMPAD5 KeyNum6 -> wxK_NUMPAD6 KeyNum7 -> wxK_NUMPAD7 KeyNum8 -> wxK_NUMPAD8 KeyNum9 -> wxK_NUMPAD9 KeyMultiply -> wxK_MULTIPLY KeyAdd -> wxK_ADD KeySeparator -> wxK_SEPARATOR KeySubtract -> wxK_SUBTRACT KeyDecimal -> wxK_DECIMAL KeyDivide -> wxK_DIVIDE KeyF1 -> wxK_F1 KeyF2 -> wxK_F2 KeyF3 -> wxK_F3 KeyF4 -> wxK_F4 KeyF5 -> wxK_F5 KeyF6 -> wxK_F6 KeyF7 -> wxK_F7 KeyF8 -> wxK_F8 KeyF9 -> wxK_F9 KeyF10 -> wxK_F10 KeyF11 -> wxK_F11 KeyF12 -> wxK_F12 KeyF13 -> wxK_F13 KeyF14 -> wxK_F14 KeyF15 -> wxK_F15 KeyF16 -> wxK_F16 KeyF17 -> wxK_F17 KeyF18 -> wxK_F18 KeyF19 -> wxK_F19 KeyF20 -> wxK_F20 KeyF21 -> wxK_F21 KeyF22 -> wxK_F22 KeyF23 -> wxK_F23 KeyF24 -> wxK_F24 KeyNumLock -> wxK_NUMLOCK KeyScroll -> wxK_SCROLL -- | A virtual key code to a key. keyCodeToKey :: KeyCode -> Key keyCodeToKey keyCode = if (keyCode < wxK_DELETE && keyCode > wxK_SPACE) -- optimize for the common case then KeyChar (toEnum keyCode) else case IntMap.lookup keyCode keyCodeMap of Just key -> key Nothing | keyCode <= 255 -> KeyChar (toEnum keyCode) | otherwise -> KeyOther keyCode -- Use a big-endian patricia tree to efficiently map key codes to Haskell keys. -- Since it is a static map, we could maybe use one of Knuth's optimally balanced -- trees.... -- keyCodeMap :: IntMap.IntMap Key keyCodeMap = IntMap.fromList [(wxK_BACK , KeyBack) ,(wxK_TAB , KeyTab) ,(wxK_RETURN , KeyReturn) ,(wxK_ESCAPE , KeyEscape) ,(wxK_SPACE , KeySpace) ,(wxK_DELETE , KeyDelete) ,(wxK_INSERT , KeyInsert) ,(wxK_END , KeyEnd) ,(wxK_HOME , KeyHome) ,(wxK_LEFT , KeyLeft) ,(wxK_UP , KeyUp) ,(wxK_RIGHT , KeyRight) ,(wxK_DOWN , KeyDown) ,(wxK_PAGEUP , KeyPageUp) ,(wxK_PAGEDOWN , KeyPageDown) ,(wxK_START , KeyStart) ,(wxK_CLEAR , KeyClear) ,(wxK_SHIFT , KeyShift) ,(wxK_ALT , KeyAlt) ,(wxK_CONTROL , KeyControl) ,(wxK_MENU , KeyMenu) ,(wxK_PAUSE , KeyPause) ,(wxK_CAPITAL , KeyCapital) ,(wxK_HELP , KeyHelp) ,(wxK_SELECT , KeySelect) ,(wxK_PRINT , KeyPrint) ,(wxK_EXECUTE , KeyExecute) ,(wxK_SNAPSHOT , KeySnapshot) ,(wxK_CANCEL , KeyCancel) ,(wxK_LBUTTON , KeyLeftButton) ,(wxK_RBUTTON , KeyRightButton) ,(wxK_MBUTTON , KeyMiddleButton) ,(wxK_NUMPAD0 , KeyNum0) ,(wxK_NUMPAD1 , KeyNum1) ,(wxK_NUMPAD2 , KeyNum2) ,(wxK_NUMPAD3 , KeyNum3) ,(wxK_NUMPAD4 , KeyNum4) ,(wxK_NUMPAD5 , KeyNum5) ,(wxK_NUMPAD6 , KeyNum6) ,(wxK_NUMPAD7 , KeyNum7) ,(wxK_NUMPAD8 , KeyNum8) ,(wxK_NUMPAD9 , KeyNum9) ,(wxK_MULTIPLY , KeyMultiply) ,(wxK_ADD , KeyAdd) ,(wxK_SEPARATOR , KeySeparator) ,(wxK_SUBTRACT , KeySubtract) ,(wxK_DECIMAL , KeyDecimal) ,(wxK_DIVIDE , KeyDivide) ,(wxK_F1 , KeyF1) ,(wxK_F2 , KeyF2) ,(wxK_F3 , KeyF3) ,(wxK_F4 , KeyF4) ,(wxK_F5 , KeyF5) ,(wxK_F6 , KeyF6) ,(wxK_F7 , KeyF7) ,(wxK_F8 , KeyF8) ,(wxK_F9 , KeyF9) ,(wxK_F10 , KeyF10) ,(wxK_F11 , KeyF11) ,(wxK_F12 , KeyF12) ,(wxK_F13 , KeyF13) ,(wxK_F14 , KeyF14) ,(wxK_F15 , KeyF15) ,(wxK_F16 , KeyF16) ,(wxK_F17 , KeyF17) ,(wxK_F18 , KeyF18) ,(wxK_F19 , KeyF19) ,(wxK_F20 , KeyF20) ,(wxK_F21 , KeyF21) ,(wxK_F22 , KeyF22) ,(wxK_F23 , KeyF23) ,(wxK_F24 , KeyF24) ,(wxK_NUMLOCK , KeyNumLock) ,(wxK_SCROLL , KeyScroll) -- translate with loss of information ,(wxK_NUMPAD_SPACE , KeySpace) ,(wxK_NUMPAD_TAB , KeyTab) ,(wxK_NUMPAD_ENTER , KeyReturn) ,(wxK_NUMPAD_F1 , KeyF1) ,(wxK_NUMPAD_F2 , KeyF2) ,(wxK_NUMPAD_F3 , KeyF3) ,(wxK_NUMPAD_F4 , KeyF4) ,(wxK_NUMPAD_HOME , KeyHome) ,(wxK_NUMPAD_LEFT , KeyLeft) ,(wxK_NUMPAD_UP , KeyUp) ,(wxK_NUMPAD_RIGHT , KeyRight) ,(wxK_NUMPAD_DOWN , KeyDown) ,(wxK_NUMPAD_PAGEUP , KeyPageUp) ,(wxK_NUMPAD_PAGEDOWN , KeyPageDown) ,(wxK_NUMPAD_END , KeyEnd) -- ,(wxK_NUMPAD_BEGIN , KeyBegin) ,(wxK_NUMPAD_INSERT , KeyInsert) ,(wxK_NUMPAD_DELETE , KeyDelete) -- ,(wxK_NUMPAD_EQUAL , KeyEqual) ,(wxK_NUMPAD_MULTIPLY , KeyMultiply) ,(wxK_NUMPAD_ADD , KeyAdd) ,(wxK_NUMPAD_SEPARATOR , KeySeparator) ,(wxK_NUMPAD_SUBTRACT , KeySubtract) ,(wxK_NUMPAD_DECIMAL , KeyDecimal) ,(wxK_NUMPAD_DIVIDE , KeyDivide) ] instance Show Key where show k = showKey k -- | Show a key\/modifiers combination, for example for use in menus. showKeyModifiers :: Key -> Modifiers -> String showKeyModifiers key mods | null modsText = show key | otherwise = modsText ++ "+" ++ show key where modsText = show mods -- | Show a key for use in menus for example. showKey :: Key -> String showKey key = case key of KeyChar c -> [c] KeyOther code -> "[" ++ show code ++ "]" KeyBack -> "Backspace" KeyTab -> "Tab" KeyReturn -> "Enter" KeyEscape -> "Esc" KeySpace -> "Space" KeyDelete -> "Delete" KeyInsert -> "Insert" KeyEnd -> "End" KeyHome -> "Home" KeyLeft -> "Left" KeyUp -> "Up" KeyRight -> "Right" KeyDown -> "Down" KeyPageUp -> "PgUp" KeyPageDown -> "PgDn" KeyStart -> "Start" KeyClear -> "Clear" KeyShift -> "Shift" KeyAlt -> "Alt" KeyControl -> "Ctrl" KeyMenu -> "Menu" KeyPause -> "Pause" KeyCapital -> "Capital" KeyHelp -> "Help" KeySelect -> "Select" KeyPrint -> "Print" KeyExecute -> "Execute" KeySnapshot -> "Snapshot" KeyCancel -> "Cancel" KeyLeftButton -> "Left Button" KeyRightButton -> "Right Button" KeyMiddleButton -> "Middle Button" KeyNum0 -> "Num 0" KeyNum1 -> "Num 1" KeyNum2 -> "Num 2" KeyNum3 -> "Num 3" KeyNum4 -> "Num 4" KeyNum5 -> "Num 5" KeyNum6 -> "Num 6" KeyNum7 -> "Num 7" KeyNum8 -> "Num 8" KeyNum9 -> "Num 9" KeyMultiply -> "Num *" KeyAdd -> "Num +" KeySeparator -> "Num Separator" KeySubtract -> "Num -" KeyDecimal -> "Num ." KeyDivide -> "Num /" KeyF1 -> "F1" KeyF2 -> "F2" KeyF3 -> "F3" KeyF4 -> "F4" KeyF5 -> "F5" KeyF6 -> "F6" KeyF7 -> "F7" KeyF8 -> "F8" KeyF9 -> "F9" KeyF10 -> "F10" KeyF11 -> "F11" KeyF12 -> "F12" KeyF13 -> "F13" KeyF14 -> "F14" KeyF15 -> "F15" KeyF16 -> "F16" KeyF17 -> "F17" KeyF18 -> "F18" KeyF19 -> "F19" KeyF20 -> "F20" KeyF21 -> "F21" KeyF22 -> "F22" KeyF23 -> "F23" KeyF24 -> "F24" KeyNumLock -> "Numlock" KeyScroll -> "Scroll" {----------------------------------------------------------------------------------------- Drag and Drop events -----------------------------------------------------------------------------------------} -- | Drag results data DragResult = DragError | DragNone | DragCopy | DragMove | DragLink | DragCancel | DragUnknown deriving (Eq,Show) dragResults :: [(Int, DragResult)] dragResults = [(wxDRAG_ERROR ,DragError) ,(wxDRAG_NONE ,DragNone) ,(wxDRAG_COPY ,DragCopy) ,(wxDRAG_MOVE ,DragMove) ,(wxDRAG_LINK ,DragLink) ,(wxDRAG_CANCEL ,DragCancel)] fromDragResult :: DragResult -> Int fromDragResult drag = case drag of DragError -> wxDRAG_ERROR DragNone -> wxDRAG_NONE DragCopy -> wxDRAG_COPY DragMove -> wxDRAG_MOVE DragLink -> wxDRAG_LINK DragCancel -> wxDRAG_CANCEL DragUnknown -> wxDRAG_ERROR toDragResult :: Int -> DragResult toDragResult drag = case lookup drag dragResults of Just x -> x Nothing -> DragError -- | Set an event handler that is called when the drop target can be filled with data. -- This function require to use 'dropTargetGetData' in your event handler to fill data. dropTargetOnData :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO () dropTargetOnData drop event = do funPtr <- dragThreeFuncHandler event wxcDropTargetSetOnData (objectCast drop) (toCFunPtr funPtr) -- | Set an event handler for an drop command in a drop target. dropTargetOnDrop :: DropTarget a -> (Point -> IO Bool) -> IO () dropTargetOnDrop drop event = do funPtr <- dragTwoFuncHandler event wxcDropTargetSetOnDrop (objectCast drop) (toCFunPtr funPtr) -- | Set an event handler for an enter command in a drop target. dropTargetOnEnter :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO () dropTargetOnEnter drop event = do funPtr <- dragThreeFuncHandler event wxcDropTargetSetOnEnter (objectCast drop) (toCFunPtr funPtr) -- | Set an event handler for a drag over command in a drop target. dropTargetOnDragOver :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO () dropTargetOnDragOver drop event = do funPtr <- dragThreeFuncHandler event wxcDropTargetSetOnDragOver (objectCast drop) (toCFunPtr funPtr) -- | Set an event handler for a leave command in a drop target. dropTargetOnLeave :: DropTarget a -> (IO ()) -> IO () dropTargetOnLeave drop event = do funPtr <- dragZeroFuncHandler event wxcDropTargetSetOnLeave (objectCast drop) (toCFunPtr funPtr) dragZeroFuncHandler event = dragZeroFunc $ \obj -> do event dragTwoFuncHandler event = dragTwoFunc $ \obj x y -> do result <- event (point (fromIntegral x) (fromIntegral y)) return $ fromBool result dragThreeFuncHandler event = dragThreeFunc $ \obj x y pre -> do result <- event (point (fromIntegral x) (fromIntegral y)) (toDragResult $ fromIntegral pre) return $ fromIntegral $ fromDragResult result -- | Set an event handler for a drag & drop command between drag source window and drop -- target. You must set 'dropTarget' before use this action. -- And If you use 'fileDropTarget' or 'textDropTarget', you need not use this. dragAndDrop :: DropSource a -> DragMode -> (DragResult -> IO ()) -> IO () dragAndDrop drSrc flag event = do result <- dropSourceDoDragDrop drSrc (fromDragMode flag) case lookup result dragResults of Just x -> event x Nothing -> return () -- | Set an event handler that is called when text is dropped in target window. textDropTarget :: Window a -> TextDataObject b -> (Point -> String -> IO ()) -> IO () textDropTarget window textData event = do funPtr <- dropTextHandler event textDrop <- wxcTextDropTargetCreate nullPtr (toCFunPtr funPtr) dropTargetSetDataObject textDrop textData windowSetDropTarget window textDrop dropTextHandler event = wrapTextDropHandler $ \obj x y cstr -> do str <- peekCWString cstr event (point (fromIntegral x) (fromIntegral y)) str -- | Set an event handler that is called when files are dropped in target window. fileDropTarget :: Window a -> (Point -> [String] -> IO ()) -> IO () fileDropTarget window event = do funPtr <- dropFileHandler event fileDrop <- wxcFileDropTargetCreate nullPtr (toCFunPtr funPtr) windowSetDropTarget window fileDrop dropFileHandler event = wrapFileDropHandler $ \obj x y carr size -> do arr <- peekArray (fromIntegral size) carr files <- mapM peekCWString arr event (point (fromIntegral x) (fromIntegral y)) files data DragMode = CopyOnly | AllowMove | Default deriving (Eq,Show) -- deriving (Eq,Show,Read,Typeable) fromDragMode :: DragMode -> Int fromDragMode mode = case mode of CopyOnly -> wxDRAG_COPYONLY AllowMove -> wxDRAG_ALLOWMOVE Default -> wxDRAG_DEFALUTMOVE foreign import ccall "wrapper" dragZeroFunc :: (Ptr obj -> IO ()) -> IO (FunPtr (Ptr obj -> IO ())) foreign import ccall "wrapper" dragTwoFunc :: (Ptr obj -> CInt -> CInt -> IO CInt) -> IO (FunPtr (Ptr obj -> CInt -> CInt -> IO CInt)) foreign import ccall "wrapper" dragThreeFunc :: (Ptr obj -> CInt -> CInt -> CInt -> IO CInt) -> IO (FunPtr (Ptr obj -> CInt -> CInt -> CInt -> IO CInt)) foreign import ccall "wrapper" wrapTextDropHandler :: (Ptr obj -> CInt -> CInt -> Ptr CWchar -> IO ()) -> IO (FunPtr (Ptr obj -> CInt -> CInt -> Ptr CWchar -> IO ())) foreign import ccall "wrapper" wrapFileDropHandler :: (Ptr obj -> CInt -> CInt -> Ptr (Ptr CWchar) -> CInt -> IO ()) -> IO (FunPtr (Ptr obj -> CInt -> CInt -> Ptr (Ptr CWchar) -> CInt -> IO ())) {----------------------------------------------------------------------------------------- Grid events -----------------------------------------------------------------------------------------} type Column = Int type Row = Int -- | Grid events. data EventGrid = GridCellMouse !Row !Column !EventMouse | GridLabelMouse !Row !Column !EventMouse | GridCellChange !Row !Column !(IO ()) | GridCellSelect !Row !Column !(IO ()) | GridCellDeSelect !Row !Column !(IO ()) | GridEditorHidden !Row !Column !(IO ()) | GridEditorShown !Row !Column !(IO ()) | GridEditorCreated !Row !Column (IO (Control ())) | GridColSize !Column !Point !Modifiers (IO ()) | GridRowSize !Row !Point !Modifiers (IO ()) | GridRangeSelect !Row !Column !Row !Column !Rect !Modifiers !(IO ()) | GridRangeDeSelect !Row !Column !Row !Column !Rect !Modifiers !(IO ()) | GridUnknown !Row !Column !Int fromGridEvent :: GridEvent a -> IO EventGrid fromGridEvent gridEvent = do tp <- eventGetEventType gridEvent row <- gridEventGetRow gridEvent col <- gridEventGetCol gridEvent case lookup tp gridEvents of Just make -> make gridEvent row col Nothing -> return (GridUnknown row col tp) gridEvents :: [(Int, GridEvent a -> Int -> Int -> IO EventGrid)] gridEvents = [(wxEVT_GRID_CELL_LEFT_CLICK, gridMouse GridCellMouse MouseLeftDown) ,(wxEVT_GRID_CELL_LEFT_DCLICK, gridMouse GridCellMouse MouseLeftDClick) ,(wxEVT_GRID_CELL_RIGHT_CLICK, gridMouse GridCellMouse MouseRightDown) ,(wxEVT_GRID_CELL_RIGHT_DCLICK, gridMouse GridCellMouse MouseRightDClick) ,(wxEVT_GRID_LABEL_LEFT_CLICK, gridMouse GridLabelMouse MouseLeftDown) ,(wxEVT_GRID_LABEL_LEFT_DCLICK, gridMouse GridLabelMouse MouseLeftDClick) ,(wxEVT_GRID_LABEL_RIGHT_CLICK, gridMouse GridLabelMouse MouseRightDown) ,(wxEVT_GRID_LABEL_RIGHT_DCLICK, gridMouse GridLabelMouse MouseRightDClick) ,(wxEVT_GRID_CELL_CHANGE, gridVeto GridCellChange) ,(wxEVT_GRID_SELECT_CELL, gridSelect) ,(wxEVT_GRID_EDITOR_SHOWN, gridVeto GridEditorShown) ,(wxEVT_GRID_EDITOR_HIDDEN, gridVeto GridEditorHidden) ] where gridMouse make makeMouse gridEvent row col = do pt <- gridEventGetPosition gridEvent altDown <- gridEventAltDown gridEvent controlDown <- gridEventControlDown gridEvent shiftDown <- gridEventShiftDown gridEvent metaDown <- gridEventMetaDown gridEvent let modifiers = Modifiers altDown shiftDown controlDown metaDown return (make row col (makeMouse pt modifiers)) gridVeto make gridEvent row col = return (make row col (notifyEventVeto gridEvent)) gridSelect gridEvent row col = do selecting <- gridEventSelecting gridEvent if selecting then return (GridCellSelect row col (notifyEventVeto gridEvent)) else return (GridCellDeSelect row col (notifyEventVeto gridEvent)) -- | Set a grid event handler. gridOnGridEvent :: Grid a -> (EventGrid -> IO ()) -> IO () gridOnGridEvent grid eventHandler = windowOnEvent grid (map fst gridEvents) eventHandler gridHandler where gridHandler event = do eventGrid <- fromGridEvent (objectCast event) eventHandler eventGrid -- | Get the current grid event handler of a window. gridGetOnGridEvent :: Grid a -> IO (EventGrid -> IO ()) gridGetOnGridEvent grid = unsafeWindowGetHandlerState grid wxEVT_GRID_CELL_CHANGE (\event -> skipCurrentEvent) {----------------------------------------------------------------------------------------- TreeCtrl events -----------------------------------------------------------------------------------------} -- | Tree control events data EventTree = TreeBeginRDrag TreeItem !Point (IO ()) -- ^ Drag with right button. Call @IO@ action to continue dragging. | TreeBeginDrag TreeItem !Point (IO ()) | TreeEndDrag TreeItem !Point | TreeBeginLabelEdit TreeItem String (IO ()) -- ^ Edit a label. Call @IO@ argument to disallow the edit. | TreeEndLabelEdit TreeItem String Bool (IO ()) -- ^ End edit. @Bool@ is 'True' when the edit was cancelled. Call the @IO@ argument to veto the action. | TreeDeleteItem TreeItem | TreeItemActivated TreeItem | TreeItemCollapsed TreeItem | TreeItemCollapsing TreeItem (IO ()) -- ^ Call the @IO@ argument to veto. | TreeItemExpanding TreeItem (IO ()) -- ^ Call the @IO@ argument to veto. | TreeItemExpanded TreeItem | TreeItemRightClick TreeItem | TreeItemMiddleClick TreeItem | TreeSelChanged TreeItem TreeItem | TreeSelChanging TreeItem TreeItem (IO ()) -- ^ Call the @IO@ argument to veto. | TreeKeyDown TreeItem EventKey | TreeUnknown fromTreeEvent :: TreeEvent a -> IO EventTree fromTreeEvent treeEvent = do tp <- eventGetEventType treeEvent item <- treeEventGetItem treeEvent case lookup tp treeEvents of Just make -> make treeEvent item Nothing -> return TreeUnknown treeEvents :: [(Int,TreeEvent a -> TreeItem -> IO EventTree)] treeEvents = [(wxEVT_COMMAND_TREE_DELETE_ITEM, fromItemEvent TreeDeleteItem) ,(wxEVT_COMMAND_TREE_ITEM_ACTIVATED, fromItemEvent TreeItemActivated) ,(wxEVT_COMMAND_TREE_ITEM_COLLAPSED, fromItemEvent TreeItemCollapsed) ,(wxEVT_COMMAND_TREE_ITEM_EXPANDED, fromItemEvent TreeItemExpanded) ,(wxEVT_COMMAND_TREE_ITEM_RIGHT_CLICK, fromItemEvent TreeItemRightClick) ,(wxEVT_COMMAND_TREE_ITEM_MIDDLE_CLICK, fromItemEvent TreeItemMiddleClick) ,(wxEVT_COMMAND_TREE_ITEM_COLLAPSING, withVeto (fromItemEvent TreeItemCollapsing)) ,(wxEVT_COMMAND_TREE_ITEM_EXPANDING, withVeto (fromItemEvent TreeItemExpanding)) ,(wxEVT_COMMAND_TREE_KEY_DOWN, fromKeyDownEvent ) ,(wxEVT_COMMAND_TREE_BEGIN_LABEL_EDIT, fromBeginLabelEditEvent ) ,(wxEVT_COMMAND_TREE_END_LABEL_EDIT, fromEndLabelEditEvent ) ,(wxEVT_COMMAND_TREE_BEGIN_DRAG, withAllow (fromDragEvent TreeBeginDrag)) ,(wxEVT_COMMAND_TREE_BEGIN_RDRAG, withAllow (fromDragEvent TreeBeginRDrag)) ,(wxEVT_COMMAND_TREE_END_DRAG, fromDragEvent TreeEndDrag) ,(wxEVT_COMMAND_TREE_SEL_CHANGED, fromChangeEvent TreeSelChanged) ,(wxEVT_COMMAND_TREE_SEL_CHANGING, withVeto (fromChangeEvent TreeSelChanging)) ] where fromKeyDownEvent treeEvent item = do keyEvent <- treeEventGetKeyEvent treeEvent eventKey <- eventKeyFromEvent keyEvent return (TreeKeyDown item eventKey) fromBeginLabelEditEvent treeEvent item = do lab <- treeEventGetLabel treeEvent return (TreeBeginLabelEdit item lab (notifyEventVeto treeEvent)) fromEndLabelEditEvent treeEvent item = do lab <- treeEventGetLabel treeEvent can <- treeEventIsEditCancelled treeEvent return (TreeEndLabelEdit item lab can (notifyEventVeto treeEvent)) fromDragEvent make treeEvent item = do pt <- treeEventGetPoint treeEvent return (make item pt) fromChangeEvent make treeEvent item = do olditem <- treeEventGetOldItem treeEvent return (make item olditem) withAllow make treeEvent item = do f <- make treeEvent item return (f (treeEventAllow treeEvent)) withVeto make treeEvent item = do f <- make treeEvent item return (f (notifyEventVeto treeEvent)) fromItemEvent make treeEvent item = return (make item) -- | Set a tree event handler. treeCtrlOnTreeEvent :: TreeCtrl a -> (EventTree -> IO ()) -> IO () treeCtrlOnTreeEvent treeCtrl eventHandler = windowOnEvent treeCtrl (map fst treeEvents) eventHandler treeHandler where treeHandler event = do eventTree <- fromTreeEvent (objectCast event) eventHandler eventTree -- | Get the current tree event handler of a window. treeCtrlGetOnTreeEvent :: TreeCtrl a -> IO (EventTree -> IO ()) treeCtrlGetOnTreeEvent treeCtrl = unsafeWindowGetHandlerState treeCtrl wxEVT_COMMAND_TREE_ITEM_ACTIVATED (\event -> skipCurrentEvent) {----------------------------------------------------------------------------------------- ListCtrl events -----------------------------------------------------------------------------------------} -- | Type synonym for documentation purposes. type ListIndex = Int -- | List control events. data EventList = ListBeginDrag !ListIndex !Point (IO ()) -- ^ Drag with left mouse button. Call @IO@ argument to veto this action. | ListBeginRDrag !ListIndex !Point (IO ()) -- ^ Drag with right mouse button. @IO@ argument to veto this action. | ListBeginLabelEdit !ListIndex (IO ()) -- ^ Edit label. Call @IO@ argument to veto this action. | ListEndLabelEdit !ListIndex !Bool (IO ()) -- ^ End editing label. @Bool@ argument is 'True' when cancelled. Call @IO@ argument to veto this action. | ListDeleteItem !ListIndex | ListDeleteAllItems | ListItemSelected !ListIndex | ListItemDeselected !ListIndex | ListItemActivated !ListIndex -- ^ Activate (ENTER or double click) | ListItemFocused !ListIndex | ListItemMiddleClick !ListIndex | ListItemRightClick !ListIndex | ListInsertItem !ListIndex | ListColClick !Int -- ^ Column has been clicked. (-1 when clicked in control header outside any column) | ListColRightClick !Int | ListColBeginDrag !Int (IO ()) -- ^ Column is dragged. Index is of the column left of the divider that is being dragged. Call @IO@ argument to veto this action. | ListColDragging !Int | ListColEndDrag !Int (IO ()) -- ^ Column has been dragged. Call @IO@ argument to veto this action. | ListKeyDown !Key | ListCacheHint !Int !Int -- ^ (Inclusive) range of list items that are advised to be cached. | ListUnknown fromListEvent :: ListEvent a -> IO EventList fromListEvent listEvent = do tp <- eventGetEventType listEvent case lookup tp listEvents of Just f -> f listEvent Nothing -> return ListUnknown listEvents :: [(Int, ListEvent a -> IO EventList)] listEvents = [(wxEVT_COMMAND_LIST_BEGIN_LABEL_EDIT, withVeto $ withItem ListBeginLabelEdit) ,(wxEVT_COMMAND_LIST_DELETE_ITEM, withItem ListDeleteItem) ,(wxEVT_COMMAND_LIST_INSERT_ITEM, withItem ListInsertItem) ,(wxEVT_COMMAND_LIST_ITEM_ACTIVATED, withItem ListItemActivated) ,(wxEVT_COMMAND_LIST_ITEM_DESELECTED, withItem ListItemDeselected) ,(wxEVT_COMMAND_LIST_ITEM_FOCUSED, withItem ListItemFocused) ,(wxEVT_COMMAND_LIST_ITEM_MIDDLE_CLICK ,withItem ListItemMiddleClick) ,(wxEVT_COMMAND_LIST_ITEM_RIGHT_CLICK, withItem ListItemRightClick) ,(wxEVT_COMMAND_LIST_ITEM_SELECTED, withItem ListItemSelected) ,(wxEVT_COMMAND_LIST_END_LABEL_EDIT, withVeto $ withCancel $ withItem ListEndLabelEdit ) ,(wxEVT_COMMAND_LIST_BEGIN_RDRAG, withVeto $ withPoint $ withItem ListBeginRDrag) ,(wxEVT_COMMAND_LIST_BEGIN_DRAG, withVeto $ withPoint $ withItem ListBeginDrag) ,(wxEVT_COMMAND_LIST_COL_CLICK, withColumn ListColClick) ,(wxEVT_COMMAND_LIST_COL_BEGIN_DRAG, withVeto $ withColumn ListColBeginDrag) ,(wxEVT_COMMAND_LIST_COL_DRAGGING, withColumn ListColDragging) ,(wxEVT_COMMAND_LIST_COL_END_DRAG, withVeto $ withColumn ListColEndDrag) ,(wxEVT_COMMAND_LIST_COL_RIGHT_CLICK, withColumn ListColRightClick) ,(wxEVT_COMMAND_LIST_CACHE_HINT, withCache ListCacheHint ) ,(wxEVT_COMMAND_LIST_KEY_DOWN, withKeyCode ListKeyDown ) ,(wxEVT_COMMAND_LIST_DELETE_ALL_ITEMS, \event -> return ListDeleteAllItems ) ] where withPoint make listEvent = do f <- make listEvent pt <- listEventGetPoint listEvent return (f pt) withCancel make listEvent = do f <- make listEvent can <- listEventCancelled listEvent return (f can) withVeto :: (ListEvent a -> IO (IO () -> EventList)) -> ListEvent a -> IO EventList withVeto make listEvent = do f <- make listEvent return (f (notifyEventVeto listEvent)) withKeyCode make listEvent = do code <- listEventGetCode listEvent return (make (keyCodeToKey code)) withCache make listEvent = do lo <- listEventGetCacheFrom listEvent hi <- listEventGetCacheTo listEvent return (make lo hi) withColumn make listEvent = do col <- listEventGetColumn listEvent return (make col) withItem :: (ListIndex -> b) -> ListEvent a -> IO b withItem make listEvent = do item <- listEventGetIndex listEvent return (make item) -- | Set a list event handler. listCtrlOnListEvent :: ListCtrl a -> (EventList -> IO ()) -> IO () listCtrlOnListEvent listCtrl eventHandler = windowOnEvent listCtrl (map fst listEvents) eventHandler listHandler where listHandler event = do eventList <- fromListEvent (objectCast event) eventHandler eventList -- | Get the current list event handler of a window. listCtrlGetOnListEvent :: ListCtrl a -> IO (EventList -> IO ()) listCtrlGetOnListEvent listCtrl = unsafeWindowGetHandlerState listCtrl wxEVT_COMMAND_LIST_ITEM_ACTIVATED (\event -> skipCurrentEvent) ------------------------------------------------------------------------------------------ -- TaskBarIcon Events ------------------------------------------------------------------------------------------ data EventTaskBarIcon = TaskBarIconMove | TaskBarIconLeftDown | TaskBarIconLeftUp | TaskBarIconRightDown | TaskBarIconRightUp | TaskBarIconLeftDClick | TaskBarIconRightDClick | TaskBarIconUnknown deriving (Show, Eq) fromTaskBarIconEvent :: Event a -> IO EventTaskBarIcon fromTaskBarIconEvent event = do tp <- eventGetEventType event case lookup tp taskBarIconEvents of Just evt -> return evt Nothing -> return TaskBarIconUnknown taskBarIconEvents :: [(Int,EventTaskBarIcon)] taskBarIconEvents = [(wxEVT_TASKBAR_MOVE, TaskBarIconMove) ,(wxEVT_TASKBAR_LEFT_DOWN, TaskBarIconLeftDown) ,(wxEVT_TASKBAR_LEFT_UP, TaskBarIconLeftUp) ,(wxEVT_TASKBAR_RIGHT_DOWN, TaskBarIconRightDown) ,(wxEVT_TASKBAR_RIGHT_UP, TaskBarIconRightUp) ,(wxEVT_TASKBAR_LEFT_DCLICK, TaskBarIconLeftDClick) ,(wxEVT_TASKBAR_RIGHT_DCLICK, TaskBarIconRightDClick) ] -- | Set a taskbar icon event handler. evtHandlerOnTaskBarIconEvent :: TaskBarIcon a -> (EventTaskBarIcon -> IO ()) -> IO () evtHandlerOnTaskBarIconEvent taskbar eventHandler = evtHandlerOnEvent taskbar idAny idAny (map fst taskBarIconEvents) eventHandler -- finalize taskBarIcon's resource on Windows. (\_ -> if wxToolkit == WxMSW then (taskBarIconRemoveIcon taskbar -- But taskBarIconDelete doesn't work well in this part. I don't know why. -- >> taskBarIconDelete taskbar >> return ()) else (return ())) scrollHandler where scrollHandler event = do eventTaskBar <- fromTaskBarIconEvent event eventHandler eventTaskBar -- | Get the current event handler for a taskbar icon. evtHandlerGetOnTaskBarIconEvent :: EvtHandler a -> Id -> EventTaskBarIcon -> IO (IO ()) evtHandlerGetOnTaskBarIconEvent window id evt = unsafeGetHandlerState window id (fromMaybe wxEVT_TASKBAR_MOVE $ lookup evt $ uncurry (flip zip) . unzip $ taskBarIconEvents) skipCurrentEvent ------------------------------------------------------------------------------------------ -- TimerEx is handled specially. ------------------------------------------------------------------------------------------ -- | Create a new 'Timer' that is attached to a window. It is automatically deleted when -- its owner is deleted (using 'windowAddOnDelete'). The owning window will receive -- timer events ('windowOnTimer'). /Broken!/ (use 'windowTimerCreate'\/'timerOnCommand' instead.) windowTimerAttach :: Window a -> IO (Timer ()) windowTimerAttach w = do t <- timerCreate w idAny windowAddOnDelete w (timerDelete t) return t -- | Create a new 'TimerEx' timer. It is automatically deleted when its owner is deleted -- (using 'windowAddOnDelete'). React to timer events using 'timerOnCommand'. windowTimerCreate :: Window a -> IO (TimerEx ()) windowTimerCreate w = do t <- timerExCreate windowAddOnDelete w (timerDelete t) return t -- | Set an event handler that is called on a timer tick. This works for 'TimerEx' -- objects. timerOnCommand :: TimerEx a -> IO () -> IO () timerOnCommand timer io = do closure <- createClosure io (\ownerDeleted -> return ()) (\ev -> io) timerExConnect timer closure -- | Get the current timer event handler. timerGetOnCommand :: TimerEx a -> IO (IO ()) timerGetOnCommand timer = do closure <- timerExGetClosure timer unsafeClosureGetState closure (return ()) {-------------------------------------------------------------------------- The global idle timer Currently only used by the process code but can potentially be used to enable haskell threads to run in idle time --------------------------------------------------------------------------} {-# NOINLINE appIdleIntervals #-} appIdleIntervals :: Var [Int] appIdleIntervals = unsafePerformIO (varCreate []) -- | @appRegisterIdle interval handler@ registers a global idle event -- handler that is at least called every @interval@ milliseconds (and -- possible more). Returns a method that can be used to unregister this -- handler (so that it doesn't take any resources anymore). Multiple -- calls to this method chains the different idle event handlers. appRegisterIdle :: Int -> IO (IO ()) appRegisterIdle interval = do varUpdate appIdleIntervals (interval:) appUpdateIdleInterval return (appUnregisterIdle interval) -- Update the idle interval to the minimal one. appUpdateIdleInterval = do ivals <- varGet appIdleIntervals let ival = if null ivals then 0 else minimum ivals -- zero is off. appival <- wxcAppGetIdleInterval if (ival < appival) then wxcAppSetIdleInterval ival else return () -- Unregister an idle handler appUnregisterIdle :: Int -> IO () appUnregisterIdle ival = do varUpdate appIdleIntervals (remove ival) appUpdateIdleInterval where remove ival [] = [] -- very wrong! remove ival (i:is) | ival == i = is | otherwise = i : remove ival is {----------------------------------------------------------------------------------------- Calender events -----------------------------------------------------------------------------------------} data EventCalendar = CalendarDayChanged (DateTime ()) | CalendarDoubleClicked (DateTime ()) | CalendarMonthChanged (DateTime ()) | CalendarSelectionChanged (DateTime ()) | CalendarWeekdayClicked Int | CalendarYearChanged (DateTime ()) | CalendarUnknown fromCalendarEvent :: CalendarEvent a -> IO EventCalendar fromCalendarEvent calEvent = do tp <- eventGetEventType calEvent case lookup tp calEvents of Just f -> f calEvent Nothing -> return CalendarUnknown calEvents :: [(Int, CalendarEvent a -> IO EventCalendar)] calEvents = [(wxEVT_CALENDAR_DAY_CHANGED ,withDate CalendarDayChanged) ,(wxEVT_CALENDAR_DOUBLECLICKED ,withDate CalendarDoubleClicked) ,(wxEVT_CALENDAR_MONTH_CHANGED ,withDate CalendarMonthChanged) ,(wxEVT_CALENDAR_SEL_CHANGED ,withDate CalendarSelectionChanged) ,(wxEVT_CALENDAR_WEEKDAY_CLICKED,withWeekday CalendarWeekdayClicked) ,(wxEVT_CALENDAR_YEAR_CHANGED ,withDate CalendarYearChanged)] where withDate event calEvent = do date <- dateTimeCreate withObjectPtr date $ calendarEventGetDate calEvent return (event date) withWeekday event calEvent = fmap event $ calendarEventGetWeekDay calEvent -- | Set a calendar event handler. calendarCtrlOnCalEvent :: CalendarCtrl a -> (EventCalendar -> IO ()) -> IO () calendarCtrlOnCalEvent calCtrl eventHandler = windowOnEvent calCtrl (map fst calEvents) eventHandler calHandler where calHandler event = do eventCalendar <- fromCalendarEvent (objectCast event) eventHandler eventCalendar -- | Get the current calendar event handler of a window. calendarCtrlGetOnCalEvent :: CalendarCtrl a -> IO (EventCalendar -> IO ()) calendarCtrlGetOnCalEvent calCtrl = unsafeWindowGetHandlerState calCtrl wxEVT_CALENDAR_SEL_CHANGED (\event -> skipCurrentEvent) ------------------------------------------------------------------------------------------ -- Application startup ------------------------------------------------------------------------------------------ -- | Installs an init handler and starts the event loop. -- Note: the closure is deleted when initialization is complete, and than the Haskell init function -- is started. appOnInit :: IO () -> IO () appOnInit init = do closure <- createClosure (return () :: IO ()) onDelete (\ev -> return ()) -- run init on destroy ! progName <- getProgName args <- getArgs argv <- mapM newCWString (progName:args) let argc = length argv withArray (argv ++ [nullPtr]) $ \cargv -> wxcAppInitializeC closure argc cargv mapM_ free argv where onDelete ownerDeleted = init ------------------------------------------------------------------------------------------ -- Attaching haskell data to arbitrary objects. ------------------------------------------------------------------------------------------ -- | Use attached haskell data locally. This makes it type-safe. objectWithClientData :: WxObject a -> b -> ((b -> IO ()) -> IO b -> IO c) -> IO c objectWithClientData object initx fun = do let setter x = objectSetClientData object (return ()) x getter = do mb <- unsafeObjectGetClientData object case mb of Nothing -> return initx Just x -> return x setter initx fun setter getter -- | Attach haskell value to an arbitrary object. The 'IO' action is executed -- when the object is deleted. Note: 'evtHandlerSetClientData' is preferred when possible. objectSetClientData :: WxObject a -> IO () -> b -> IO () objectSetClientData object onDelete x = do closure <- createClosure x (const onDelete) (const (return ())) objectSetClientClosure object closure return () -- | Retrieve an attached haskell value. unsafeObjectGetClientData :: WxObject a -> IO (Maybe b) unsafeObjectGetClientData object = do closure <- objectGetClientClosure object unsafeClosureGetData closure -- | Use attached haskell data locally in a type-safe way. evtHandlerWithClientData :: EvtHandler a -> b -> ((b -> IO ()) -> IO b -> IO c) -> IO c evtHandlerWithClientData evtHandler initx fun = do let setter x = evtHandlerSetClientData evtHandler (return ()) x getter = do mb <- unsafeEvtHandlerGetClientData evtHandler case mb of Nothing -> return initx Just x -> return x setter initx fun setter getter -- | Attach a haskell value to an object derived from 'EvtHandler'. The 'IO' action -- executed when the object is deleted. evtHandlerSetClientData :: EvtHandler a -> IO () -> b -> IO () evtHandlerSetClientData evtHandler onDelete x = do closure <- createClosure x (const onDelete) (const (return ())) evtHandlerSetClientClosure evtHandler closure return () -- | Retrieve an attached haskell value, previously attached with 'evtHandlerSetClientData'. unsafeEvtHandlerGetClientData :: EvtHandler a -> IO (Maybe b) unsafeEvtHandlerGetClientData evtHandler = do closure <- evtHandlerGetClientClosure evtHandler unsafeClosureGetData closure -- | Attach a haskell value to tree item data. The 'IO' action -- executed when the object is deleted. treeCtrlSetItemClientData :: TreeCtrl a -> TreeItem -> IO () -> b -> IO () treeCtrlSetItemClientData treeCtrl item onDelete x = do closure <- createClosure x (const onDelete) (const (return ())) treeCtrlSetItemClientClosure treeCtrl item closure return () -- | Retrieve an attached haskell value to a tree item, previously attached with 'treeCtrlSetItemClientData'. unsafeTreeCtrlGetItemClientData :: TreeCtrl a -> TreeItem -> IO (Maybe b) unsafeTreeCtrlGetItemClientData treeCtrl item = do closure <- treeCtrlGetItemClientClosure treeCtrl item unsafeClosureGetData closure ------------------------------------------------------------------------------------------ -- Generic window connection ------------------------------------------------------------------------------------------ -- | Set a generic event handler on a certain window. windowOnEvent :: Window a -> [EventId] -> handler -> (Event () -> IO ()) -> IO () windowOnEvent window eventIds state eventHandler = windowOnEventEx window eventIds state (\ownerDelete -> return ()) eventHandler -- | Set a generic event handler on a certain window. Takes also a computation -- that is run when the event handler is destroyed -- the argument is 'True' if the -- owner is deleted, and 'False' if the event handler is disconnected for example. windowOnEventEx :: Window a -> [EventId] -> handler -> (Bool -> IO ()) -> (Event () -> IO ()) -> IO () windowOnEventEx window eventIds state destroy eventHandler = do let id = idAny -- id <- windowGetId window evtHandlerOnEvent window id id eventIds state destroy eventHandler -- | Retrieve the event handler state for a certain event on a window. unsafeWindowGetHandlerState :: Window a -> EventId -> b -> IO b unsafeWindowGetHandlerState window eventId def = do id <- windowGetId window unsafeGetHandlerState window id eventId def ------------------------------------------------------------------------------------------ -- The current event ------------------------------------------------------------------------------------------ {-# NOINLINE currentEvent #-} currentEvent :: MVar (Event ()) currentEvent = unsafePerformIO (newMVar objectNull) -- | Get the current event handler (can be 'objectNull'). getCurrentEvent :: IO (Event ()) getCurrentEvent = readMVar currentEvent -- | Do something with the current event /if/ we are calling from an event handler. withCurrentEvent :: (Event () -> IO ()) -> IO () withCurrentEvent f = do ev <- getCurrentEvent if (ev /= objectNull) then f ev else return () -- | Pass the event on the next /wxWindows/ event handler, either on this window or its parent. -- Always call this method when you do not process the event. /Note:/ The use of -- 'propagateEvent' is encouraged as it is a much better name than 'skipCurrentEvent'. This -- function name is just for better compatibility with wxWindows :-) skipCurrentEvent :: IO () skipCurrentEvent = withCurrentEvent (\event -> eventSkip event) -- | Pass the event on the next /wxWindows/ event handler, either on this window or its parent. -- Always call this method when you do not process the event. (This function just call 'skipCurrentEvent'). propagateEvent :: IO () propagateEvent = skipCurrentEvent ------------------------------------------------------------------------------------------ -- Generic event connection ------------------------------------------------------------------------------------------ -- | Retrievs the state associated with a certain event handler. If -- no event handler is defined for this kind of event or 'Id', the -- default value is returned. unsafeGetHandlerState :: EvtHandler a -> Id -> EventId -> b -> IO b unsafeGetHandlerState object id eventId def = do closure <- evtHandlerGetClosure object id eventId unsafeClosureGetState closure def -- | Type synonym to make the type signatures shorter for the documentation :-) type OnEvent = (Bool -> IO ()) -> (Event () -> IO ()) -> IO () -- | Sets a generic event handler, just as 'evtHandlerOnEventConnect' but first -- disconnects any event handlers for the same kind of events. evtHandlerOnEvent :: EvtHandler a -> Id -> Id -> [EventId] -> handler -> OnEvent evtHandlerOnEvent object firstId lastId eventIds state destroy eventHandler = do evtHandlerOnEventDisconnect object firstId lastId eventIds evtHandlerOnEventConnect object firstId lastId eventIds state destroy eventHandler -- Hack: using a global variable to determine whether we are disconnecting an event -- or not. This is used as a parameter to the 'destroy' procedure of an event. This -- enables us to re-install a 'windowOnDelete' handler for example without executing -- the deletion code. {-# NOINLINE disconnecting #-} disconnecting :: Var Bool disconnecting = unsafePerformIO (varCreate False) -- | Disconnect a certain event handler. evtHandlerOnEventDisconnect :: EvtHandler a -> Id -> Id -> [EventId] -> IO () evtHandlerOnEventDisconnect object firstId lastId eventIds = do prev <- varSwap disconnecting True mapM_ disconnectEventId eventIds varSet disconnecting prev where disconnectEventId eventId = evtHandlerDisconnect object firstId lastId eventId 0 {- actually: void* -} -- | Sets a generic event handler on an 'EvtHandler' object. The call -- (@evtHandlerOnEventConnect firstId lastId eventIds state destroy handler object@) sets an event -- handler @handler@ on @object@. The eventhandler gets called whenever an event -- happens that is in the list @eventIds@ on an object with an 'Id' between @firstId@ -- and @lastId@ (use -1 for any object). The @state@ is any kind of haskell data -- that is attached to this handler. It can be retrieved via 'unsafeGetHandlerState'. -- Normally, the @state@ is the event handler itself. This allows the current event -- handler to be retrieved via calls to 'buttonGetOnCommand' for example. The @destroy@ -- action is called when the event handler is destroyed. Its argument is 'True' when the -- owner is deleted, and 'False' if the event handler is just disconnected. evtHandlerOnEventConnect :: EvtHandler a -> Id -> Id -> [EventId] -> state -> OnEvent evtHandlerOnEventConnect object firstId lastId eventIds state destroy eventHandler = do closure <- createClosure state destroy eventHandler withObjectPtr closure $ \pclosure -> mapM_ (connectEventId pclosure) eventIds where connectEventId pclosure eventId = evtHandlerConnect object firstId lastId eventId pclosure -- Use a data wrapper for the closure state: seem to circumvent bugs when wrapping -- things like Int or overloaded stuff. data Wrap a = Wrap a unsafeClosureGetState :: Closure () -> a -> IO a unsafeClosureGetState closure def = do mb <- unsafeClosureGetData closure case mb of Nothing -> return def Just x -> return x unsafeClosureGetData :: Closure () -> IO (Maybe a) unsafeClosureGetData closure = if (objectIsNull closure) then return Nothing else do ptr <- closureGetData closure if (ptrIsNull ptr) then return Nothing else do (Wrap x) <- deRefStablePtr (castPtrToStablePtr ptr) return (Just x) -- | Create a closure with a certain haskell state, a function that is called -- when the closure is destroyed, and a function that is called when an event -- happens. The destroy function takes a boolean that is 'True' when the parent -- is deleted (and 'False' when the closure is just disconnected). The event -- handlers gets the 'Event' as its argument. createClosure :: state -> (Bool -> IO ()) -> (Event () -> IO ()) -> IO (Closure ()) createClosure st destroy handler = do funptr <- wrapEventHandler eventHandlerWrapper stptr <- newStablePtr (Wrap st) closureCreate funptr (castStablePtrToPtr stptr) where eventHandlerWrapper :: Ptr fun -> Ptr () -> Ptr (TEvent ()) -> IO () eventHandlerWrapper funptr stptr eventptr = do let event = objectFromPtr eventptr prev <- swapMVar currentEvent event if (objectIsNull event) then do isDisconnecting <- varGet disconnecting destroy (not isDisconnecting) when (stptr/=ptrNull) (freeStablePtr (castPtrToStablePtr stptr)) when (funptr/=ptrNull) (freeHaskellFunPtr (castPtrToFunPtr funptr)) else handler event swapMVar currentEvent prev return () foreign import ccall "wrapper" wrapEventHandler :: (Ptr fun -> Ptr st -> Ptr (TEvent ()) -> IO ()) -> IO (FunPtr (Ptr fun -> Ptr st -> Ptr (TEvent ()) -> IO ()))