{-# 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 wxWidgets 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
        , toggleButtonOnCommand
        , treeCtrlOnTreeEvent
        , gridOnGridEvent
        , propertyGridOnPropertyGridEvent

        -- ** 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
        , toggleButtonGetOnCommand
        , treeCtrlGetOnTreeEvent
        , gridGetOnGridEvent
        , propertyGridGetOnPropertyGridEvent

        -- ** 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(..)

        -- ** PropertyGrid events
        , EventPropertyGrid(..)


        -- * 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.Types
import Foreign.C.String
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils

import Data.Char ( chr ) -- used in stc
import Data.Maybe ( fromMaybe, 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)

-- | Set an event handler for a push button.
toggleButtonOnCommand :: ToggleButton a -> IO () -> IO ()
toggleButtonOnCommand button eventHandler
  = windowOnEvent button [wxEVT_COMMAND_TOGGLEBUTTON_CLICKED] eventHandler (\evt -> eventHandler)

-- | Get the current button event handler on a window.
toggleButtonGetOnCommand :: Window a -> IO (IO ())
toggleButtonGetOnCommand button
  = unsafeWindowGetHandlerState button wxEVT_COMMAND_TOGGLEBUTTON_CLICKED 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


{-----------------------------------------------------------------------------------------
  PropertyGrid events
-----------------------------------------------------------------------------------------}
-- | PropertyGrid control events.
data EventPropertyGrid  
                = PropertyGridHighlighted (Maybe (PGProperty ()))
                | PropertyGridChanged (PGProperty ())
                | PropertyGridUnknown

fromPropertyGridEvent :: PropertyGridEvent a -> IO EventPropertyGrid
fromPropertyGridEvent propertyGridEvent
  = do tp <- eventGetEventType propertyGridEvent
       case lookup tp propertyGridEvents of
         Just f  -> f propertyGridEvent 
         Nothing -> return PropertyGridUnknown

propertyGridEvents :: [(Int, PropertyGridEvent a -> IO EventPropertyGrid)]
propertyGridEvents
  = [(wxEVT_PG_HIGHLIGHTED, withPGProperty PropertyGridHighlighted),
     (wxEVT_PG_CHANGED, withPGProperty (PropertyGridChanged . fromJust))
    ]
  where
    withPGProperty :: (Maybe((PGProperty ())) -> b) -> PropertyGridEvent a -> IO b
    withPGProperty make propertyGridEvent = do
        hasProp <- propertyGridEventHasProperty propertyGridEvent
        if not hasProp then return (make Nothing) else do
            prop <- propertyGridEventGetProperty propertyGridEvent
            return (make (Just prop))

-- | Set a PropertyGrid event handler.
propertyGridOnPropertyGridEvent :: PropertyGrid a -> (EventPropertyGrid -> IO ()) -> IO ()
propertyGridOnPropertyGridEvent propertyGrid eventHandler
  = windowOnEvent propertyGrid (map fst propertyGridEvents) eventHandler listHandler
  where
    listHandler event
      = do eventPropertyGrid <- fromPropertyGridEvent (objectCast event)
           eventHandler eventPropertyGrid

-- | Get the current PropertyGrid event handler of a window.
propertyGridGetOnPropertyGridEvent :: PropertyGrid a -> IO (EventPropertyGrid -> IO ())
propertyGridGetOnPropertyGridEvent propertyGrid
  -- I'm not sure what expEVT_PG_HIGHLIGHTED needs to be here for, just followed pattern with `listCtrlGetOnListEvent'
  = unsafeWindowGetHandlerState propertyGrid wxEVT_PG_HIGHLIGHTED (\event -> 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 /wxWidgets/ 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 wxWidgets :-)
skipCurrentEvent :: IO ()
skipCurrentEvent
  = withCurrentEvent (\event -> eventSkip event)

-- | Pass the event on the next /wxWidgets/ 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 ()))