Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

2763 lines (2414 sloc) 111.925 kB
{-# LANGUAGE ForeignFunctionInterface #-}
-----------------------------------------------------------------------------------------
{-| 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.C.Types
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Data.Char ( chr ) -- used in stc
import Data.Maybe ( fromMaybe, fromJust )
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 @<title>@ 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_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_CHANGED (\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 ()))
Jump to Line
Something went wrong with that request. Please try again.