module Graphics.UI.WXCore.Events
(
buttonOnCommand
, checkBoxOnCommand
, choiceOnCommand
, comboBoxOnCommand
, comboBoxOnTextEnter
, controlOnText
, listBoxOnCommand
, spinCtrlOnCommand
, radioBoxOnCommand
, sliderOnCommand
, textCtrlOnTextEnter
, listCtrlOnListEvent
, treeCtrlOnTreeEvent
, gridOnGridEvent
, windowOnMouse
, windowOnKeyChar
, windowOnKeyDown
, windowOnKeyUp
, windowAddOnClose
, windowOnClose
, windowOnDestroy
, windowAddOnDelete
, windowOnDelete
, windowOnCreate
, windowOnIdle
, windowOnTimer
, windowOnSize
, windowOnFocus
, windowOnActivate
, windowOnPaint
, windowOnPaintRaw
, windowOnContextMenu
, windowOnScroll
, htmlWindowOnHtmlEvent
, evtHandlerOnMenuCommand
, evtHandlerOnEndProcess
, evtHandlerOnInput
, evtHandlerOnInputSink
, evtHandlerOnTaskBarIconEvent
, EventSTC(..)
, stcOnSTCEvent
, stcGetOnSTCEvent
, EventPrint(..)
, printOutOnPrint
, buttonGetOnCommand
, checkBoxGetOnCommand
, choiceGetOnCommand
, comboBoxGetOnCommand
, comboBoxGetOnTextEnter
, controlGetOnText
, listBoxGetOnCommand
, spinCtrlGetOnCommand
, radioBoxGetOnCommand
, sliderGetOnCommand
, textCtrlGetOnTextEnter
, listCtrlGetOnListEvent
, treeCtrlGetOnTreeEvent
, gridGetOnGridEvent
, windowGetOnMouse
, windowGetOnKeyChar
, windowGetOnKeyDown
, windowGetOnKeyUp
, windowGetOnClose
, windowGetOnDestroy
, windowGetOnDelete
, windowGetOnCreate
, windowGetOnIdle
, windowGetOnTimer
, windowGetOnSize
, windowGetOnFocus
, windowGetOnActivate
, windowGetOnPaint
, windowGetOnPaintRaw
, windowGetOnContextMenu
, windowGetOnScroll
, htmlWindowGetOnHtmlEvent
, evtHandlerGetOnMenuCommand
, evtHandlerGetOnEndProcess
, evtHandlerGetOnInputSink
, evtHandlerGetOnTaskBarIconEvent
, printOutGetOnPrint
, windowTimerAttach
, windowTimerCreate
, timerOnCommand
, timerGetOnCommand
, appRegisterIdle
, EventCalendar(..)
, calendarCtrlOnCalEvent
, calendarCtrlGetOnCalEvent
, StreamStatus(..), streamStatusFromInt
, Modifiers(..)
, showModifiers
, noneDown, justShift, justAlt, justControl, justMeta, isNoneDown
, isNoShiftAltControlDown
, EventMouse (..)
, showMouse
, mousePos, mouseModifiers
, EventKey (..), Key(..)
, keyKey, keyModifiers, keyPos
, showKey, showKeyModifiers
, DragResult (..)
, dropTargetOnData
, dropTargetOnDrop
, dropTargetOnEnter
, dropTargetOnDragOver
, dropTargetOnLeave
, DragMode (..)
, dragAndDrop
, fileDropTarget
, textDropTarget
, EventScroll(..), Orientation(..)
, scrollOrientation, scrollPos
, EventTree(..)
, EventList(..), ListIndex
, EventGrid(..), Row, Column
, EventHtml(..)
, EventTaskBarIcon(..)
, propagateEvent
, skipCurrentEvent
, withCurrentEvent
, appOnInit
, treeCtrlSetItemClientData
, evtHandlerWithClientData
, evtHandlerSetClientData
, objectWithClientData
, objectSetClientData
, inputSinkEventLastString
, KeyCode
, modifiersToAccelFlags
, keyCodeToKey, keyToKeyCode
, windowOnEvent, windowOnEventEx
, OnEvent
, evtHandlerOnEvent
, evtHandlerOnEventConnect
, unsafeTreeCtrlGetItemClientData
, unsafeEvtHandlerGetClientData
, unsafeObjectGetClientData
, unsafeGetHandlerState
, unsafeWindowGetHandlerState
) where
import Data.List( intersperse, findIndex )
import System.Environment( getProgName, getArgs )
import Foreign.StablePtr
import Foreign.Ptr
import Foreign.C.String
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Data.Char ( chr )
import Data.Maybe ( fromMaybe )
import Control.Concurrent.MVar
import System.IO.Unsafe( unsafePerformIO )
import qualified Data.IntMap as IntMap
import Graphics.UI.WXCore.WxcTypes
import Graphics.UI.WXCore.WxcDefs
import Graphics.UI.WXCore.WxcClasses
import Graphics.UI.WXCore.WxcClassInfo
import Graphics.UI.WXCore.Types
import Graphics.UI.WXCore.Draw
import Graphics.UI.WXCore.Defines
buttonOnCommand :: Button a -> IO () -> IO ()
buttonOnCommand button eventHandler
= windowOnEvent button [wxEVT_COMMAND_BUTTON_CLICKED] eventHandler (\evt -> eventHandler)
buttonGetOnCommand :: Window a -> IO (IO ())
buttonGetOnCommand button
= unsafeWindowGetHandlerState button wxEVT_COMMAND_BUTTON_CLICKED skipCurrentEvent
controlOnText :: Control a -> IO () -> IO ()
controlOnText control eventHandler
= windowOnEvent control [wxEVT_COMMAND_TEXT_UPDATED] eventHandler (\evt -> eventHandler)
controlGetOnText :: Control a -> IO (IO ())
controlGetOnText control
= unsafeWindowGetHandlerState control wxEVT_COMMAND_TEXT_UPDATED skipCurrentEvent
textCtrlOnTextEnter :: TextCtrl a -> IO () -> IO ()
textCtrlOnTextEnter textCtrl eventHandler
= windowOnEvent textCtrl [wxEVT_COMMAND_TEXT_ENTER] eventHandler (\evt -> eventHandler)
textCtrlGetOnTextEnter :: TextCtrl a -> IO (IO ())
textCtrlGetOnTextEnter textCtrl
= unsafeWindowGetHandlerState textCtrl wxEVT_COMMAND_TEXT_ENTER skipCurrentEvent
comboBoxOnTextEnter :: ComboBox a -> IO () -> IO ()
comboBoxOnTextEnter comboBox eventHandler
= windowOnEvent comboBox [wxEVT_COMMAND_TEXT_ENTER] eventHandler (\evt -> eventHandler)
comboBoxGetOnTextEnter :: ComboBox a -> IO (IO ())
comboBoxGetOnTextEnter comboBox
= unsafeWindowGetHandlerState comboBox wxEVT_COMMAND_TEXT_ENTER skipCurrentEvent
comboBoxOnCommand :: ComboBox a -> IO () -> IO ()
comboBoxOnCommand comboBox eventHandler
= windowOnEvent comboBox [wxEVT_COMMAND_COMBOBOX_SELECTED] eventHandler (\evt -> eventHandler)
comboBoxGetOnCommand :: ComboBox a -> IO (IO ())
comboBoxGetOnCommand comboBox
= unsafeWindowGetHandlerState comboBox wxEVT_COMMAND_COMBOBOX_SELECTED skipCurrentEvent
listBoxOnCommand :: ListBox a -> IO () -> IO ()
listBoxOnCommand listBox eventHandler
= windowOnEvent listBox [wxEVT_COMMAND_LISTBOX_SELECTED] eventHandler (\evt -> eventHandler)
listBoxGetOnCommand :: ListBox a -> IO (IO ())
listBoxGetOnCommand listBox
= unsafeWindowGetHandlerState listBox wxEVT_COMMAND_LISTBOX_SELECTED skipCurrentEvent
choiceOnCommand :: Choice a -> IO () -> IO ()
choiceOnCommand choice eventHandler
= windowOnEvent choice [wxEVT_COMMAND_CHOICE_SELECTED] eventHandler (\evt -> eventHandler)
choiceGetOnCommand :: Choice a -> IO (IO ())
choiceGetOnCommand choice
= unsafeWindowGetHandlerState choice wxEVT_COMMAND_CHOICE_SELECTED skipCurrentEvent
radioBoxOnCommand :: RadioBox a -> IO () -> IO ()
radioBoxOnCommand radioBox eventHandler
= windowOnEvent radioBox [wxEVT_COMMAND_RADIOBOX_SELECTED] eventHandler (\evt -> eventHandler)
radioBoxGetOnCommand :: RadioBox a -> IO (IO ())
radioBoxGetOnCommand radioBox
= unsafeWindowGetHandlerState radioBox wxEVT_COMMAND_RADIOBOX_SELECTED skipCurrentEvent
sliderOnCommand :: Slider a -> IO () -> IO ()
sliderOnCommand slider eventHandler
= windowOnEvent slider [wxEVT_COMMAND_SLIDER_UPDATED] eventHandler (\evt -> eventHandler)
sliderGetOnCommand :: Slider a -> IO (IO ())
sliderGetOnCommand slider
= unsafeWindowGetHandlerState slider wxEVT_COMMAND_SLIDER_UPDATED skipCurrentEvent
checkBoxOnCommand :: CheckBox a -> (IO ()) -> IO ()
checkBoxOnCommand checkBox eventHandler
= windowOnEvent checkBox [wxEVT_COMMAND_CHECKBOX_CLICKED] eventHandler (\evt -> eventHandler)
checkBoxGetOnCommand :: CheckBox a -> IO (IO ())
checkBoxGetOnCommand checkBox
= unsafeWindowGetHandlerState checkBox wxEVT_COMMAND_CHECKBOX_CLICKED (skipCurrentEvent)
spinCtrlOnCommand :: SpinCtrl a -> (IO ()) -> IO ()
spinCtrlOnCommand spinCtrl eventHandler
= windowOnEvent spinCtrl [wxEVT_COMMAND_SPINCTRL_UPDATED] eventHandler (\evt -> eventHandler)
spinCtrlGetOnCommand :: SpinCtrl a -> IO (IO ())
spinCtrlGetOnCommand spinCtrl
= unsafeWindowGetHandlerState spinCtrl wxEVT_COMMAND_SPINCTRL_UPDATED (skipCurrentEvent)
data EventSTC
= STCChange
| STCStyleNeeded
| STCCharAdded Char Int
| STCSavePointReached
| STCSavePointLeft
| STCROModifyAttempt
| STCKey
| STCDoubleClick
| STCUpdateUI
| STCModified Int Int (Maybe String) Int Int Int Int Int
| STCMacroRecord Int Int Int
| STCMarginClick Bool Bool Bool Int Int
| STCNeedShown Int Int
| STCPainted
| STCUserListSelection Int String
| STCUriDropped String
| STCDwellStart Point
| STCDwellEnd Point
| STCStartDrag Int Int String
| STCDragOver Point DragResult
| STCDoDrop String DragResult
| STCZoom
| STCHotspotClick
| STCHotspotDClick
| STCCalltipClick
| STCAutocompSelection
| STCUnknown
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)
, (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
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
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 ()
else handler eventSTC
isSTCUnknown :: EventSTC -> Bool
isSTCUnknown STCUnknown = True
isSTCUnknown _ = False
stcEventsAll = map fst stcEvents
stcGetOnSTCEvent :: StyledTextCtrl a -> IO (EventSTC -> IO ())
stcGetOnSTCEvent window
= unsafeWindowGetHandlerState window (head $ map fst stcEvents) (\ev -> skipCurrentEvent)
data EventPrint = PrintBeginDoc (IO ()) Int Int
| PrintEndDoc
| PrintBegin
| PrintEnd
| PrintPrepare
| PrintPage (IO ()) (DC ()) Int
| PrintUnknown Int
fromPrintEvent :: WXCPrintEvent a -> IO EventPrint
fromPrintEvent event
= do tp <- eventGetEventType event
case lookup tp printEvents of
Just f -> f event
Nothing -> return (PrintUnknown tp)
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)
]
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
printOutGetOnPrint :: WXCPrintout a -> IO (EventPrint -> IO ())
printOutGetOnPrint printOut
= do evtHandler <- wxcPrintoutGetEvtHandler printOut
unsafeGetHandlerState evtHandler idAny wxEVT_PRINT_PAGE (\ev -> skipCurrentEvent)
data EventScroll = ScrollTop !Orientation !Int
| ScrollBottom !Orientation !Int
| ScrollLineUp !Orientation !Int
| ScrollLineDown !Orientation !Int
| ScrollPageUp !Orientation !Int
| ScrollPageDown !Orientation !Int
| ScrollTrack !Orientation !Int
| ScrollRelease !Orientation !Int
deriving Show
data Orientation = Horizontal | Vertical
deriving (Eq, Show)
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
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)
]
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
windowGetOnScroll :: Window a -> IO (EventScroll -> IO ())
windowGetOnScroll window
= unsafeWindowGetHandlerState window wxEVT_SCROLLWIN_TOP (\scroll -> skipCurrentEvent)
data EventHtml
= HtmlCellClicked String EventMouse Point
| HtmlCellHover String
| HtmlLinkClicked String String String EventMouse Point
| HtmlSetTitle String
| HtmlUnknown
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)
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
htmlWindowGetOnHtmlEvent :: WXCHtmlWindow a -> IO (EventHtml -> IO ())
htmlWindowGetOnHtmlEvent window
= unsafeWindowGetHandlerState window wxEVT_HTML_CELL_CLICKED (\ev -> skipCurrentEvent)
windowAddOnClose :: Window a -> IO () -> IO ()
windowAddOnClose window new
= do prev <- windowGetOnClose window
windowOnClose window (do{ new; prev })
windowOnClose :: Window a -> IO () -> IO ()
windowOnClose window eventHandler
= windowOnEvent window [wxEVT_CLOSE_WINDOW] eventHandler (\ev -> eventHandler)
windowGetOnClose :: Window a -> IO (IO ())
windowGetOnClose window
= unsafeWindowGetHandlerState window wxEVT_CLOSE_WINDOW (do windowDestroy window; return ())
windowOnDestroy :: Window a -> IO () -> IO ()
windowOnDestroy window eventHandler
= windowOnEvent window [wxEVT_DESTROY] eventHandler (\ev -> eventHandler)
windowGetOnDestroy :: Window a -> IO (IO ())
windowGetOnDestroy window
= unsafeWindowGetHandlerState window wxEVT_DESTROY (return ())
windowAddOnDelete :: Window a -> IO () -> IO ()
windowAddOnDelete window new
= do prev <- windowGetOnDelete window
windowOnDelete window (do{ new; prev })
windowOnDelete :: Window a -> IO () -> IO ()
windowOnDelete window eventHandler
= windowOnEventEx window [wxEVT_DELETE] eventHandler onDelete (\ev -> return ())
where
onDelete ownerDeleted
| ownerDeleted = eventHandler
| otherwise = return ()
windowGetOnDelete :: Window a -> IO (IO ())
windowGetOnDelete window
= unsafeWindowGetHandlerState window wxEVT_DELETE (return ())
windowOnCreate :: Window a -> IO () -> IO ()
windowOnCreate window eventHandler
= windowOnEvent window [wxEVT_CREATE] eventHandler (\ev -> eventHandler)
windowGetOnCreate :: Window a -> IO (IO ())
windowGetOnCreate window
= unsafeWindowGetHandlerState window wxEVT_CREATE (return ())
windowOnSize :: Window a -> IO () -> IO ()
windowOnSize window eventHandler
= windowOnEvent window [wxEVT_SIZE] eventHandler (\ev -> eventHandler)
windowGetOnSize :: Window a -> IO (IO ())
windowGetOnSize window
= unsafeWindowGetHandlerState window wxEVT_SIZE (return ())
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
windowGetOnActivate :: Window a -> IO (Bool -> IO ())
windowGetOnActivate window
= unsafeWindowGetHandlerState window wxEVT_ACTIVATE (\active -> return ())
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
windowGetOnFocus :: Window a -> IO (Bool -> IO ())
windowGetOnFocus window
= unsafeWindowGetHandlerState window wxEVT_SET_FOCUS (\getfocus -> return ())
windowOnContextMenu :: Window a -> IO () -> IO ()
windowOnContextMenu window eventHandler
= windowOnEvent window [wxEVT_CONTEXT_MENU] eventHandler (\ev -> eventHandler)
windowGetOnContextMenu :: Window a -> IO (IO ())
windowGetOnContextMenu window
= unsafeWindowGetHandlerState window wxEVT_CONTEXT_MENU skipCurrentEvent
evtHandlerOnMenuCommand :: EvtHandler a -> Id -> IO () -> IO ()
evtHandlerOnMenuCommand window id eventHandler
= evtHandlerOnEvent window id id [wxEVT_COMMAND_MENU_SELECTED] eventHandler (\_ -> return ()) (\ev -> eventHandler)
evtHandlerGetOnMenuCommand :: EvtHandler a -> Id -> IO (IO ())
evtHandlerGetOnMenuCommand window id
= unsafeGetHandlerState window id wxEVT_COMMAND_MENU_SELECTED skipCurrentEvent
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 ()
windowGetOnIdle :: Window a -> IO (IO Bool)
windowGetOnIdle window
= unsafeWindowGetHandlerState window wxEVT_IDLE (return False)
windowOnTimer :: Window a -> IO () -> IO ()
windowOnTimer window eventHandler
= windowOnEvent window [wxEVT_TIMER] eventHandler (\ev -> eventHandler)
windowGetOnTimer :: Window a -> IO (IO ())
windowGetOnTimer window
= unsafeWindowGetHandlerState window wxEVT_TIMER (return ())
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)
windowGetOnPaintRaw :: Window a -> IO (DC () -> Rect -> [Rect] -> IO ())
windowGetOnPaintRaw window
= unsafeWindowGetHandlerState window wxEVT_PAINT (\dc rect region -> return ())
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)
let clear dc | wxToolkit == WxMSW = dcClearRect dc view
| otherwise = dcClear dc
dcBufferWithRefEx paintDC clear (Just v) view (\dc -> paintHandler dc view))
windowGetOnPaint :: Window a -> IO (DC () -> Rect -> IO ())
windowGetOnPaint window
= unsafeWindowGetHandlerState window wxEVT_PAINT (\dc view -> return ())
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 []
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
evtHandlerGetOnEndProcess :: EvtHandler a -> IO (Int -> Int -> IO ())
evtHandlerGetOnEndProcess evtHandler
= unsafeGetHandlerState evtHandler (1) wxEVT_END_PROCESS (\pid code -> return ())
data StreamStatus = StreamOk
| StreamEof
| StreamReadError
| StreamWriteError
deriving (Eq,Show)
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
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
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)
evtHandlerGetOnInputSink :: EvtHandler b -> IO (String -> StreamStatus -> IO ())
evtHandlerGetOnInputSink evtHandler
= unsafeGetHandlerState evtHandler (1) wxEVT_INPUT_SINK (\input status -> return ())
inputSinkEventLastString :: InputSinkEvent a -> IO String
inputSinkEventLastString inputSinkEvent
= do n <- inputSinkEventLastRead inputSinkEvent
if (n <= 0)
then return ""
else do buffer <- inputSinkEventLastInput inputSinkEvent
peekCWStringLen (buffer,n)
data Modifiers = Modifiers
{ altDown :: !Bool
, shiftDown :: !Bool
, controlDown :: !Bool
, metaDown :: !Bool
}
deriving (Eq)
instance Show Modifiers where
show mods = showModifiers mods
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 ""
]
noneDown :: Modifiers
noneDown = Modifiers False False False False
justShift :: Modifiers
justShift = noneDown{ shiftDown = True }
justAlt :: Modifiers
justAlt = noneDown{ altDown = True }
justControl :: Modifiers
justControl = noneDown{ controlDown = True }
justMeta :: Modifiers
justMeta = noneDown{ metaDown = True }
isNoneDown :: Modifiers -> Bool
isNoneDown (Modifiers shift control alt meta) = not (shift || control || alt || meta)
isNoShiftAltControlDown :: Modifiers -> Bool
isNoShiftAltControlDown (Modifiers shift control alt meta) = not (shift || control || alt)
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
data EventMouse
= MouseMotion !Point !Modifiers
| MouseEnter !Point !Modifiers
| MouseLeave !Point !Modifiers
| MouseLeftDown !Point !Modifiers
| MouseLeftUp !Point !Modifiers
| MouseLeftDClick !Point !Modifiers
| MouseLeftDrag !Point !Modifiers
| MouseRightDown !Point !Modifiers
| MouseRightUp !Point !Modifiers
| MouseRightDClick !Point !Modifiers
| MouseRightDrag !Point !Modifiers
| MouseMiddleDown !Point !Modifiers
| MouseMiddleUp !Point !Modifiers
| MouseMiddleDClick !Point !Modifiers
| MouseMiddleDrag !Point !Modifiers
| MouseWheel !Bool !Point !Modifiers
deriving (Eq)
instance Show EventMouse where
show mouse = showMouse mouse
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")
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
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)
,(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)
]
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
windowGetOnMouse :: Window a -> IO (EventMouse -> IO ())
windowGetOnMouse window
= unsafeWindowGetHandlerState window wxEVT_ENTER_WINDOW (\ev -> skipCurrentEvent)
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
windowGetOnKeyDown :: Window a -> IO (EventKey -> IO ())
windowGetOnKeyDown window
= unsafeWindowGetHandlerState window wxEVT_KEY_DOWN (\eventKey -> skipCurrentEvent)
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
windowGetOnKeyChar :: Window a -> IO (EventKey -> IO ())
windowGetOnKeyChar window
= unsafeWindowGetHandlerState window wxEVT_CHAR (\eventKey -> skipCurrentEvent)
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
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)
data EventKey = EventKey !Key !Modifiers !Point
deriving (Eq,Show)
keyKey :: EventKey -> Key
keyKey (EventKey key mods pos) = key
keyModifiers :: EventKey -> Modifiers
keyModifiers (EventKey key mods pos) = mods
keyPos :: EventKey -> Point
keyPos (EventKey key mods pos) = pos
type KeyCode = Int
data Key
= KeyChar !Char
| KeyOther !KeyCode
| 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
deriving (Eq)
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
keyCodeToKey :: KeyCode -> Key
keyCodeToKey keyCode
= if (keyCode < wxK_DELETE && keyCode > wxK_SPACE)
then KeyChar (toEnum keyCode)
else case IntMap.lookup keyCode keyCodeMap of
Just key -> key
Nothing | keyCode <= 255 -> KeyChar (toEnum keyCode)
| otherwise -> KeyOther keyCode
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)
,(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_INSERT , KeyInsert)
,(wxK_NUMPAD_DELETE , KeyDelete)
,(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
showKeyModifiers :: Key -> Modifiers -> String
showKeyModifiers key mods
| null modsText = show key
| otherwise = modsText ++ "+" ++ show key
where
modsText = show mods
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"
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
dropTargetOnData :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO ()
dropTargetOnData drop event = do
funPtr <- dragThreeFuncHandler event
wxcDropTargetSetOnData (objectCast drop) (toCFunPtr funPtr)
dropTargetOnDrop :: DropTarget a -> (Point -> IO Bool) -> IO ()
dropTargetOnDrop drop event = do
funPtr <- dragTwoFuncHandler event
wxcDropTargetSetOnDrop (objectCast drop) (toCFunPtr funPtr)
dropTargetOnEnter :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO ()
dropTargetOnEnter drop event = do
funPtr <- dragThreeFuncHandler event
wxcDropTargetSetOnEnter (objectCast drop) (toCFunPtr funPtr)
dropTargetOnDragOver :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO ()
dropTargetOnDragOver drop event = do
funPtr <- dragThreeFuncHandler event
wxcDropTargetSetOnDragOver (objectCast drop) (toCFunPtr funPtr)
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
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 ()
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
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)
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 ()))
type Column = Int
type Row = Int
data EventGrid = GridCellMouse !Row !Column !EventMouse
| GridLabelMouse !Row !Column !EventMouse
| GridCellChange !Row !Column !(IO ())
| GridCellSelect !Row !Column !(IO ())
| GridCellDeSelect !Row !Column !(IO ())
| GridEditorHidden !Row !Column !(IO ())
| GridEditorShown !Row !Column !(IO ())
| GridEditorCreated !Row !Column (IO (Control ()))
| GridColSize !Column !Point !Modifiers (IO ())
| GridRowSize !Row !Point !Modifiers (IO ())
| GridRangeSelect !Row !Column !Row !Column !Rect !Modifiers !(IO ())
| GridRangeDeSelect !Row !Column !Row !Column !Rect !Modifiers !(IO ())
| GridUnknown !Row !Column !Int
fromGridEvent :: GridEvent a -> IO EventGrid
fromGridEvent gridEvent
= do tp <- eventGetEventType gridEvent
row <- gridEventGetRow gridEvent
col <- gridEventGetCol gridEvent
case lookup tp gridEvents of
Just make -> make gridEvent row col
Nothing -> return (GridUnknown row col tp)
gridEvents :: [(Int, GridEvent a -> Int -> Int -> IO EventGrid)]
gridEvents
= [(wxEVT_GRID_CELL_LEFT_CLICK, gridMouse GridCellMouse MouseLeftDown)
,(wxEVT_GRID_CELL_LEFT_DCLICK, gridMouse GridCellMouse MouseLeftDClick)
,(wxEVT_GRID_CELL_RIGHT_CLICK, gridMouse GridCellMouse MouseRightDown)
,(wxEVT_GRID_CELL_RIGHT_DCLICK, gridMouse GridCellMouse MouseRightDClick)
,(wxEVT_GRID_LABEL_LEFT_CLICK, gridMouse GridLabelMouse MouseLeftDown)
,(wxEVT_GRID_LABEL_LEFT_DCLICK, gridMouse GridLabelMouse MouseLeftDClick)
,(wxEVT_GRID_LABEL_RIGHT_CLICK, gridMouse GridLabelMouse MouseRightDown)
,(wxEVT_GRID_LABEL_RIGHT_DCLICK, gridMouse GridLabelMouse MouseRightDClick)
,(wxEVT_GRID_CELL_CHANGE, gridVeto GridCellChange)
,(wxEVT_GRID_SELECT_CELL, gridSelect)
,(wxEVT_GRID_EDITOR_SHOWN, gridVeto GridEditorShown)
,(wxEVT_GRID_EDITOR_HIDDEN, gridVeto GridEditorHidden)
]
where
gridMouse make makeMouse gridEvent row col
= do pt <- gridEventGetPosition gridEvent
altDown <- gridEventAltDown gridEvent
controlDown <- gridEventControlDown gridEvent
shiftDown <- gridEventShiftDown gridEvent
metaDown <- gridEventMetaDown gridEvent
let modifiers = Modifiers altDown shiftDown controlDown metaDown
return (make row col (makeMouse pt modifiers))
gridVeto make gridEvent row col
= return (make row col (notifyEventVeto gridEvent))
gridSelect gridEvent row col
= do selecting <- gridEventSelecting gridEvent
if selecting
then return (GridCellSelect row col (notifyEventVeto gridEvent))
else return (GridCellDeSelect row col (notifyEventVeto gridEvent))
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
gridGetOnGridEvent :: Grid a -> IO (EventGrid -> IO ())
gridGetOnGridEvent grid
= unsafeWindowGetHandlerState grid wxEVT_GRID_CELL_CHANGE (\event -> skipCurrentEvent)
data EventTree = TreeBeginRDrag TreeItem !Point (IO ())
| TreeBeginDrag TreeItem !Point (IO ())
| TreeEndDrag TreeItem !Point
| TreeBeginLabelEdit TreeItem String (IO ())
| TreeEndLabelEdit TreeItem String Bool (IO ())
| TreeDeleteItem TreeItem
| TreeItemActivated TreeItem
| TreeItemCollapsed TreeItem
| TreeItemCollapsing TreeItem (IO ())
| TreeItemExpanding TreeItem (IO ())
| TreeItemExpanded TreeItem
| TreeItemRightClick TreeItem
| TreeItemMiddleClick TreeItem
| TreeSelChanged TreeItem TreeItem
| TreeSelChanging TreeItem TreeItem (IO ())
| 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)
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
treeCtrlGetOnTreeEvent :: TreeCtrl a -> IO (EventTree -> IO ())
treeCtrlGetOnTreeEvent treeCtrl
= unsafeWindowGetHandlerState treeCtrl wxEVT_COMMAND_TREE_ITEM_ACTIVATED (\event -> skipCurrentEvent)
type ListIndex = Int
data EventList = ListBeginDrag !ListIndex !Point (IO ())
| ListBeginRDrag !ListIndex !Point (IO ())
| ListBeginLabelEdit !ListIndex (IO ())
| ListEndLabelEdit !ListIndex !Bool (IO ())
| ListDeleteItem !ListIndex
| ListDeleteAllItems
| ListItemSelected !ListIndex
| ListItemDeselected !ListIndex
| ListItemActivated !ListIndex
| ListItemFocused !ListIndex
| ListItemMiddleClick !ListIndex
| ListItemRightClick !ListIndex
| ListInsertItem !ListIndex
| ListColClick !Int
| ListColRightClick !Int
| ListColBeginDrag !Int (IO ())
| ListColDragging !Int
| ListColEndDrag !Int (IO ())
| ListKeyDown !Key
| ListCacheHint !Int !Int
| 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)
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
listCtrlGetOnListEvent :: ListCtrl a -> IO (EventList -> IO ())
listCtrlGetOnListEvent listCtrl
= unsafeWindowGetHandlerState listCtrl wxEVT_COMMAND_LIST_ITEM_ACTIVATED (\event -> skipCurrentEvent)
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)
]
evtHandlerOnTaskBarIconEvent :: TaskBarIcon a -> (EventTaskBarIcon -> IO ()) -> IO ()
evtHandlerOnTaskBarIconEvent taskbar eventHandler
= evtHandlerOnEvent taskbar idAny idAny (map fst taskBarIconEvents) eventHandler
(\_ -> if wxToolkit == WxMSW
then (taskBarIconRemoveIcon taskbar
>> return ())
else (return ()))
scrollHandler
where
scrollHandler event
= do eventTaskBar <- fromTaskBarIconEvent event
eventHandler eventTaskBar
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
windowTimerAttach :: Window a -> IO (Timer ())
windowTimerAttach w
= do t <- timerCreate w idAny
windowAddOnDelete w (timerDelete t)
return t
windowTimerCreate :: Window a -> IO (TimerEx ())
windowTimerCreate w
= do t <- timerExCreate
windowAddOnDelete w (timerDelete t)
return t
timerOnCommand :: TimerEx a -> IO () -> IO ()
timerOnCommand timer io
= do closure <- createClosure io (\ownerDeleted -> return ()) (\ev -> io)
timerExConnect timer closure
timerGetOnCommand :: TimerEx a -> IO (IO ())
timerGetOnCommand timer
= do closure <- timerExGetClosure timer
unsafeClosureGetState closure (return ())
appIdleIntervals :: Var [Int]
appIdleIntervals
= unsafePerformIO (varCreate [])
appRegisterIdle :: Int -> IO (IO ())
appRegisterIdle interval
= do varUpdate appIdleIntervals (interval:)
appUpdateIdleInterval
return (appUnregisterIdle interval)
appUpdateIdleInterval
= do ivals <- varGet appIdleIntervals
let ival = if null ivals then 0 else minimum ivals
appival <- wxcAppGetIdleInterval
if (ival < appival)
then wxcAppSetIdleInterval ival
else return ()
appUnregisterIdle :: Int -> IO ()
appUnregisterIdle ival
= do varUpdate appIdleIntervals (remove ival)
appUpdateIdleInterval
where
remove ival [] = []
remove ival (i:is) | ival == i = is
| otherwise = i : remove ival is
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
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
calendarCtrlGetOnCalEvent :: CalendarCtrl a -> IO (EventCalendar -> IO ())
calendarCtrlGetOnCalEvent calCtrl
= unsafeWindowGetHandlerState calCtrl wxEVT_CALENDAR_SEL_CHANGED (\event -> skipCurrentEvent)
appOnInit :: IO () -> IO ()
appOnInit init
= do closure <- createClosure (return () :: IO ()) onDelete (\ev -> return ())
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
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
objectSetClientData :: WxObject a -> IO () -> b -> IO ()
objectSetClientData object onDelete x
= do closure <- createClosure x (const onDelete) (const (return ()))
objectSetClientClosure object closure
return ()
unsafeObjectGetClientData :: WxObject a -> IO (Maybe b)
unsafeObjectGetClientData object
= do closure <- objectGetClientClosure object
unsafeClosureGetData closure
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
evtHandlerSetClientData :: EvtHandler a -> IO () -> b -> IO ()
evtHandlerSetClientData evtHandler onDelete x
= do closure <- createClosure x (const onDelete) (const (return ()))
evtHandlerSetClientClosure evtHandler closure
return ()
unsafeEvtHandlerGetClientData :: EvtHandler a -> IO (Maybe b)
unsafeEvtHandlerGetClientData evtHandler
= do closure <- evtHandlerGetClientClosure evtHandler
unsafeClosureGetData closure
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 ()
unsafeTreeCtrlGetItemClientData :: TreeCtrl a -> TreeItem -> IO (Maybe b)
unsafeTreeCtrlGetItemClientData treeCtrl item
= do closure <- treeCtrlGetItemClientClosure treeCtrl item
unsafeClosureGetData closure
windowOnEvent :: Window a -> [EventId] -> handler -> (Event () -> IO ()) -> IO ()
windowOnEvent window eventIds state eventHandler
= windowOnEventEx window eventIds state (\ownerDelete -> return ()) eventHandler
windowOnEventEx :: Window a -> [EventId] -> handler -> (Bool -> IO ()) -> (Event () -> IO ()) -> IO ()
windowOnEventEx window eventIds state destroy eventHandler
= do let id = idAny
evtHandlerOnEvent window id id eventIds state destroy eventHandler
unsafeWindowGetHandlerState :: Window a -> EventId -> b -> IO b
unsafeWindowGetHandlerState window eventId def
= do id <- windowGetId window
unsafeGetHandlerState window id eventId def
currentEvent :: MVar (Event ())
currentEvent
= unsafePerformIO (newMVar objectNull)
getCurrentEvent :: IO (Event ())
getCurrentEvent
= readMVar currentEvent
withCurrentEvent :: (Event () -> IO ()) -> IO ()
withCurrentEvent f
= do ev <- getCurrentEvent
if (ev /= objectNull)
then f ev
else return ()
skipCurrentEvent :: IO ()
skipCurrentEvent
= withCurrentEvent (\event -> eventSkip event)
propagateEvent :: IO ()
propagateEvent
= skipCurrentEvent
unsafeGetHandlerState :: EvtHandler a -> Id -> EventId -> b -> IO b
unsafeGetHandlerState object id eventId def
= do closure <- evtHandlerGetClosure object id eventId
unsafeClosureGetState closure def
type OnEvent = (Bool -> IO ()) -> (Event () -> IO ()) -> IO ()
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
disconnecting :: Var Bool
disconnecting
= unsafePerformIO (varCreate False)
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
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
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)
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 ()))