    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.UI.GLUT.Callbacks.Window
    -- Copyright   :  (c) Sven Panne 2002-2013
    -- License     :  BSD3
    --
    -- Maintainer  :  Sven Panne <svenpanne@gmail.com>
    -- Stability   :  stable
    -- Portability :  portable
    --
    --------------------------------------------------------------------------------

    module Graphics.UI.GLUT.Callbacks.Window (
       -- * Redisplay callbacks
       DisplayCallback, displayCallback, overlayDisplayCallback,

       -- * Reshape callback
       ReshapeCallback, reshapeCallback,

       -- * Position callback
       PositionCallback, positionCallback,

       -- * Callbacks for visibility changes
       Visibility(..), VisibilityCallback, visibilityCallback,
       WindowState(..), WindowStateCallback, windowStateCallback,

       -- * Window close callback
       CloseCallback, closeCallback,

       -- * Life cycle callbacks for mobile platforms
       InitContextCallback, initContextCallback,
       AppStatus(..), AppStatusCallback, appStatusCallback,

       -- * Keyboard callback
       KeyboardCallback, keyboardCallback, keyboardUpCallback,

       -- * Special callback
       SpecialCallback, specialCallback, specialUpCallback,

       -- * Mouse callback
       MouseCallback, mouseCallback,

       -- * Keyboard and mouse input callback
       Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..),
       KeyboardMouseCallback, keyboardMouseCallback,

       -- * Mouse wheel callback
       WheelNumber, WheelDirection, MouseWheelCallback, mouseWheelCallback,

       -- * Mouse movement callbacks
       MotionCallback, motionCallback, passiveMotionCallback,
       Crossing(..), CrossingCallback, crossingCallback,

       -- * Spaceball callback
       SpaceballMotion, SpaceballRotation, ButtonIndex, SpaceballInput(..),
       SpaceballCallback, spaceballCallback,

       -- * Dial & button box callback
       DialAndButtonBoxInput(..), DialIndex,
       DialAndButtonBoxCallback, dialAndButtonBoxCallback,

       -- * Tablet callback
       TabletPosition(..), TabletInput(..), TabletCallback, tabletCallback,

       -- * Joystick callback
       JoystickButtons(..), JoystickPosition(..),
       JoystickCallback, joystickCallback,

       -- * Multi-touch support
       TouchID,
       MultiMouseCallback, multiMouseCallback,
       MultiCrossingCallback, multiCrossingCallback,
       MultiMotionCallback, multiMotionCallback, multiPassiveMotionCallback

    ) where

    import Data.Bits ( (.&.) )
    import Data.Char ( chr )
    import Data.Maybe ( fromJust )
    import Data.StateVar ( SettableStateVar, makeSettableStateVar )
    import Foreign.C.Types ( CInt, CUInt )
    import Graphics.Rendering.OpenGL ( Position(..), Size(..) )

    import Graphics.UI.GLUT.Callbacks.Registration
    import Graphics.UI.GLUT.Raw
    import Graphics.UI.GLUT.State
    import Graphics.UI.GLUT.Types

    --------------------------------------------------------------------------------

    -- | A display callback

    type DisplayCallback = IO ()

    -- | Controls the display callback for the /current window./ When GLUT determines
    -- that the normal plane for the window needs to be redisplayed, the display
    -- callback for the window is called. Before the callback, the /current window/
    -- is set to the window needing to be redisplayed and (if no overlay display
    -- callback is registered) the /layer in use/ is set to the normal plane. The
    -- entire normal plane region should be redisplayed in response to the callback
    -- (this includes ancillary buffers if your program depends on their state).
    --
    -- GLUT determines when the display callback should be triggered based on the
    -- window\'s redisplay state. The redisplay state for a window can be either set
    -- explicitly by calling 'Graphics.UI.GLUT.Window.postRedisplay' or implicitly
    -- as the result of window damage reported by the window system. Multiple posted
    -- redisplays for a window are coalesced by GLUT to minimize the number of
    -- display callbacks called.
    --
    -- When an overlay is established for a window, but there is no overlay display
    -- callback registered, the display callback is used for redisplaying both the
    -- overlay and normal plane (that is, it will be called if either the redisplay
    -- state or overlay redisplay state is set). In this case, the /layer in use/ is
    -- not implicitly changed on entry to the display callback.
    --
    -- See 'overlayDisplayCallback' to understand how distinct callbacks for the
    -- overlay and normal plane of a window may be established.
    --
    -- When a window is created, no display callback exists for the window. It is
    -- the responsibility of the programmer to install a display callback for the
    -- window before the window is shown. A display callback must be registered for
    -- any window that is shown. If a window becomes displayed without a display
    -- callback being registered, a fatal error occurs. There is no way to
    -- \"deregister\" a display callback (though another callback routine can always
    -- be registered).
    --
    -- Upon return from the display callback, the normal damaged state of the window
    -- (see 'Graphics.UI.GLUT.State.damaged') is cleared. If there is no overlay
    -- display callback registered the overlay damaged state of the window (see
    -- 'Graphics.UI.GLUT.State.damaged') is also cleared.

    displayCallback :: SettableStateVar DisplayCallback
    displayCallback = makeSettableStateVar $
       setCallback DisplayCB glutDisplayFunc makeDisplayFunc . Just

    --------------------------------------------------------------------------------

    -- | Controls the overlay display callback for the /current window./ The overlay
    -- display callback is functionally the same as the window\'s display callback
    -- except that the overlay display callback is used to redisplay the window\'s
    -- overlay.
    --
    -- When GLUT determines that the overlay plane for the window needs to be
    -- redisplayed, the overlay display callback for the window is called. Before
    -- the callback, the /current window/ is set to the window needing to be
    -- redisplayed and the /layer in use/ is set to the overlay. The entire overlay
    -- region should be redisplayed in response to the callback (this includes
    -- ancillary buffers if your program depends on their state).
    --
    -- GLUT determines when the overlay display callback should be triggered based
    -- on the window\'s overlay redisplay state. The overlay redisplay state for a
    -- window can be either set explicitly by calling
    -- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' or implicitly as the result
    -- of window damage reported by the window system. Multiple posted overlay
    -- redisplays for a window are coalesced by GLUT to minimize the number of
    -- overlay display callbacks called.
    --
    -- Upon return from the overlay display callback, the overlay damaged state of
    -- the window (see 'Graphics.UI.GLUT.State.damaged') is cleared.
    --
    -- Initially there is no overlay display callback registered when an overlay is
    -- established. See 'displayCallback' to understand how the display callback
    -- alone is used if an overlay display callback is not registered.

    overlayDisplayCallback :: SettableStateVar (Maybe DisplayCallback)
    overlayDisplayCallback = makeSettableStateVar $
       setCallback OverlayDisplayCB glutOverlayDisplayFunc makeOverlayDisplayFunc

    --------------------------------------------------------------------------------

    -- | A reshape callback

    type ReshapeCallback = Size -> IO ()

    -- | Controls the reshape callback for the /current window./ The reshape callback
    -- is triggered when a window is reshaped. A reshape callback is also triggered
    -- immediately before a window\'s first display callback after a window is
    -- created or whenever an overlay for the window is established. The parameter
    -- of the callback specifies the new window size in pixels. Before the callback,
    -- the /current window/ is set to the window that has been reshaped.
    --
    -- If a reshape callback is not registered for a window or 'reshapeCallback' is
    -- set to 'Nothing' (to deregister a previously registered callback), the
    -- default reshape callback is used. This default callback will simply call
    --
    -- @
    -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.viewport' ('Graphics.Rendering.OpenGL.GL.CoordTrans.Position' 0 0) ('Graphics.Rendering.OpenGL.GL.CoordTrans.Size' /width/ /height/)
    -- @
    --
    -- on the normal plane (and on the overlay if one exists).
    --
    -- If an overlay is established for the window, a single reshape callback is
    -- generated. It is the callback\'s responsibility to update both the normal
    -- plane and overlay for the window (changing the layer in use as necessary).
    --
    -- When a top-level window is reshaped, subwindows are not reshaped. It is up to
    -- the GLUT program to manage the size and positions of subwindows within a
    -- top-level window. Still, reshape callbacks will be triggered for subwindows
    -- when their size is changed using 'Graphics.UI.GLUT.Window.windowSize'.

    reshapeCallback :: SettableStateVar (Maybe ReshapeCallback)
    reshapeCallback = makeSettableStateVar $
       setCallback ReshapeCB glutReshapeFunc (makeReshapeFunc . unmarshal)
       where unmarshal cb w h = cb (Size (fromIntegral w) (fromIntegral h))

    --------------------------------------------------------------------------------

    -- | A position callback

    type PositionCallback = Position -> IO ()

    -- | (/freeglut only/) Controls the position callback for the /current window./
    -- The position callback for a window is called when the position of a window
    -- changes.

    positionCallback :: SettableStateVar (Maybe PositionCallback)
    positionCallback = makeSettableStateVar $
       setCallback PositionCB glutPositionFunc (makePositionFunc . unmarshal)
       where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y))

    --------------------------------------------------------------------------------

    -- | The visibility state of the /current window/

    data Visibility
       = NotVisible -- ^ No part of the /current window/ is visible, i.e., until the
                    --   window\'s visibility changes, all further rendering to the
                    --   window is discarded.
       | Visible    -- ^ The /current window/ is totally or partially visible. GLUT
                    --   considers a window visible if any pixel of the window is
                    --   visible or any pixel of any descendant window is visible on
                    --   the screen.
       deriving ( Eq, Ord, Show )

    unmarshalVisibility :: CInt -> Visibility
    unmarshalVisibility x
       | x == glut_NOT_VISIBLE = NotVisible
       | x == glut_VISIBLE = Visible
       | otherwise = error ("unmarshalVisibility: illegal value " ++ show x)

    --------------------------------------------------------------------------------

    -- | A visibility callback

    type VisibilityCallback = Visibility -> IO ()

    -- | Controls the visibility callback for the /current window./ The visibility
    -- callback for a window is called when the visibility of a window changes.
    --
    -- If the visibility callback for a window is disabled and later re-enabled, the
    -- visibility status of the window is undefined; any change in window visibility
    -- will be reported, that is if you disable a visibility callback and re-enable
    -- the callback, you are guaranteed the next visibility change will be reported.
    --
    -- Note that you can either use 'visibilityCallback' or 'windowStateCallback',
    -- but not both, because the former is implemented via the latter.

    visibilityCallback :: SettableStateVar (Maybe VisibilityCallback)
    visibilityCallback = makeSettableStateVar $
       setCallback VisibilityCB glutVisibilityFunc
                   (makeVisibilityFunc . unmarshal)
       where unmarshal cb  = cb . unmarshalVisibility

    --------------------------------------------------------------------------------

    -- | The window state of the /current window/

    data WindowState
       = Unmapped          -- ^ The /current window/ is unmapped.
       | FullyRetained     -- ^ The /current window/ is unobscured.
       | PartiallyRetained -- ^ The /current window/ is partially obscured.
       | FullyCovered      -- ^ The /current window/ is fully obscured.
       deriving ( Eq, Ord, Show )

    unmarshalWindowState :: CInt -> WindowState
    unmarshalWindowState x
       | x == glut_HIDDEN = Unmapped
       | x == glut_FULLY_RETAINED = FullyRetained
       | x == glut_PARTIALLY_RETAINED = PartiallyRetained
       | x == glut_FULLY_COVERED = FullyCovered
       | otherwise = error ("unmarshalWindowState: illegal value " ++ show x)

    --------------------------------------------------------------------------------

    -- | A window state callback

    type WindowStateCallback = WindowState -> IO ()

    -- | Controls the window state callback for the
    -- /current window./ The window state callback for a window is called when the
    -- window state of a window changes.
    --
    -- If the window state callback for a window is disabled and later re-enabled,
    -- the window state state of the window is undefined; any change in the window
    -- state will be reported, that is if you disable a window state callback and
    -- re-enable the callback, you are guaranteed the next window state change will
    -- be reported.
    --
    -- Note that you can either use 'visibilityCallback' or 'windowStateCallback',
    -- but not both, because the former is implemented via the latter.

    windowStateCallback :: SettableStateVar (Maybe WindowStateCallback)
    windowStateCallback = makeSettableStateVar $
       setCallback WindowStatusCB glutWindowStatusFunc
                   (makeWindowStatusFunc . unmarshal)
       where unmarshal cb  = cb . unmarshalWindowState

    --------------------------------------------------------------------------------

    -- | A window close callback

    type CloseCallback = IO ()

    -- | Controls the window close callback for the /current window/.

    closeCallback :: SettableStateVar (Maybe CloseCallback)
    closeCallback = makeSettableStateVar $
       setCallback CloseCB glutCloseFunc makeCloseFunc

    --------------------------------------------------------------------------------

    -- | An initialize context callback

    type InitContextCallback = IO ()

    -- | (/freeglut only/) Controls the initialize context callback for the /current
    -- window/.

    initContextCallback :: SettableStateVar (Maybe InitContextCallback)
    initContextCallback = makeSettableStateVar $
       setCallback InitContextCB glutInitContextFunc makeInitContextFunc

    --------------------------------------------------------------------------------

    -- | The application status of the /current window/

    data AppStatus
       = AppStatusPause
       | AppStatusResume
       deriving ( Eq, Ord, Show )

    unmarshalAppStatus :: CInt -> AppStatus
    unmarshalAppStatus x
       | x == glut_APPSTATUS_PAUSE = AppStatusPause
       | x == glut_APPSTATUS_RESUME = AppStatusResume
       | otherwise = error ("unmarshalAppStatus: illegal value " ++ show x)

    --------------------------------------------------------------------------------

    -- | An application status callback

    type AppStatusCallback = AppStatus -> IO ()

    -- | Controls the application status callback for the /current window./

    appStatusCallback :: SettableStateVar (Maybe AppStatusCallback)
    appStatusCallback = makeSettableStateVar $
       setCallback AppStatusCB glutAppStatusFunc
                   (makeAppStatusFunc . unmarshal)
       where unmarshal cb  = cb . unmarshalAppStatus

    --------------------------------------------------------------------------------

    -- | A keyboard callback

    type KeyboardCallback = Char -> Position -> IO ()

    setKeyboardCallback :: Maybe KeyboardCallback -> IO ()
    setKeyboardCallback =
       setCallback KeyboardCB glutKeyboardFunc (makeKeyboardFunc . unmarshal)
       where unmarshal cb c x y = cb (chr (fromIntegral c))
                                     (Position (fromIntegral x) (fromIntegral y))

    -- | Controls the keyboard callback for the /current window/. This is
    -- activated only when a key is pressed.

    keyboardCallback :: SettableStateVar (Maybe KeyboardCallback)
    keyboardCallback = makeSettableStateVar setKeyboardCallback

    --------------------------------------------------------------------------------

    setKeyboardUpCallback :: Maybe KeyboardCallback -> IO ()
    setKeyboardUpCallback =
       setCallback KeyboardUpCB glutKeyboardUpFunc
                   (makeKeyboardUpFunc . unmarshal)
       where unmarshal cb c x y = cb (chr (fromIntegral c))
                                     (Position (fromIntegral x) (fromIntegral y))

    -- | Controls the keyboard callback for the /current window/. This is
    -- activated only when a key is released.

    keyboardUpCallback :: SettableStateVar (Maybe KeyboardCallback)
    keyboardUpCallback = makeSettableStateVar setKeyboardUpCallback

    --------------------------------------------------------------------------------

    -- | Special keys

    data SpecialKey
       = KeyF1
       | KeyF2
       | KeyF3
       | KeyF4
       | KeyF5
       | KeyF6
       | KeyF7
       | KeyF8
       | KeyF9
       | KeyF10
       | KeyF11
       | KeyF12
       | KeyLeft
       | KeyUp
       | KeyRight
       | KeyDown
       | KeyPageUp
       | KeyPageDown
       | KeyHome
       | KeyEnd
       | KeyInsert
       | KeyNumLock
       | KeyBegin
       | KeyDelete
       | KeyShiftL
       | KeyShiftR
       | KeyCtrlL
       | KeyCtrlR
       | KeyAltL
       | KeyAltR
       | KeyUnknown Int -- ^ You should actually never encounter this value, it is
                        -- just here as a safeguard against future changes in the
                        -- native GLUT library.
       deriving ( Eq, Ord, Show )

    unmarshalSpecialKey :: CInt -> SpecialKey
    unmarshalSpecialKey x
       | x == glut_KEY_F1 = KeyF1
       | x == glut_KEY_F2 = KeyF2
       | x == glut_KEY_F3 = KeyF3
       | x == glut_KEY_F4 = KeyF4
       | x == glut_KEY_F5 = KeyF5
       | x == glut_KEY_F6 = KeyF6
       | x == glut_KEY_F7 = KeyF7
       | x == glut_KEY_F8 = KeyF8
       | x == glut_KEY_F9 = KeyF9
       | x == glut_KEY_F10 = KeyF10
       | x == glut_KEY_F11 = KeyF11
       | x == glut_KEY_F12 = KeyF12
       | x == glut_KEY_LEFT = KeyLeft
       | x == glut_KEY_UP = KeyUp
       | x == glut_KEY_RIGHT = KeyRight
       | x == glut_KEY_DOWN = KeyDown
       | x == glut_KEY_PAGE_UP = KeyPageUp
       | x == glut_KEY_PAGE_DOWN = KeyPageDown
       | x == glut_KEY_HOME = KeyHome
       | x == glut_KEY_END = KeyEnd
       | x == glut_KEY_INSERT = KeyInsert
       | x == glut_KEY_NUM_LOCK = KeyNumLock
       | x == glut_KEY_BEGIN = KeyBegin
       | x == glut_KEY_DELETE = KeyDelete
       | x == glut_KEY_SHIFT_L = KeyShiftL
       | x == glut_KEY_SHIFT_R = KeyShiftR
       | x == glut_KEY_CTRL_L = KeyCtrlL
       | x == glut_KEY_CTRL_R = KeyCtrlR
       | x == glut_KEY_ALT_L = KeyAltL
       | x == glut_KEY_ALT_R = KeyAltR
       | otherwise = KeyUnknown (fromIntegral x)

    --------------------------------------------------------------------------------

    -- | A special key callback

    type SpecialCallback = SpecialKey -> Position -> IO ()

    setSpecialCallback :: Maybe SpecialCallback -> IO ()
    setSpecialCallback =
       setCallback SpecialCB glutSpecialFunc (makeSpecialFunc . unmarshal)
       where unmarshal cb k x y = cb (unmarshalSpecialKey k)
                                     (Position (fromIntegral x) (fromIntegral y))

    -- | Controls the special key callback for the /current window/. This is
    -- activated only when a special key is pressed.

    specialCallback :: SettableStateVar (Maybe SpecialCallback)
    specialCallback = makeSettableStateVar setSpecialCallback

    --------------------------------------------------------------------------------

    setSpecialUpCallback :: Maybe SpecialCallback -> IO ()
    setSpecialUpCallback =
       setCallback SpecialUpCB glutSpecialUpFunc (makeSpecialUpFunc . unmarshal)
       where unmarshal cb k x y = cb (unmarshalSpecialKey k)
                                     (Position (fromIntegral x) (fromIntegral y))

    -- | Controls the special key callback for the /current window/. This is
    -- activated only when a special key is released.

    specialUpCallback :: SettableStateVar (Maybe SpecialCallback)
    specialUpCallback = makeSettableStateVar setSpecialUpCallback

    --------------------------------------------------------------------------------

    -- | The current state of a key or button

    data KeyState
       = Down
       | Up
       deriving ( Eq, Ord, Show )

    unmarshalKeyState :: CInt -> KeyState
    unmarshalKeyState x
       | x == glut_DOWN = Down
       | x == glut_UP = Up
       | otherwise = error ("unmarshalKeyState: illegal value " ++ show x)

    --------------------------------------------------------------------------------

    -- | A mouse callback

    type MouseCallback = MouseButton -> KeyState -> Position -> IO ()

    setMouseCallback :: Maybe MouseCallback -> IO ()
    setMouseCallback =
       setCallback MouseCB glutMouseFunc (makeMouseFunc . unmarshal)
       where unmarshal cb b s x y = cb (unmarshalMouseButton b)
                                       (unmarshalKeyState s)
                                       (Position (fromIntegral x) (fromIntegral y))

    -- | Controls the mouse callback for the /current window/.

    mouseCallback :: SettableStateVar (Maybe MouseCallback)
    mouseCallback = makeSettableStateVar setMouseCallback

    --------------------------------------------------------------------------------

    -- | The state of the keyboard modifiers

    data Modifiers = Modifiers { shift, ctrl, alt :: KeyState }
       deriving ( Eq, Ord, Show )

    -- Could use fromBitfield + Enum/Bounded instances + marshalModifier instead...
    unmarshalModifiers :: CInt -> Modifiers
    unmarshalModifiers m = Modifiers {
       shift = if (m .&. glut_ACTIVE_SHIFT) /= 0 then Down else Up,
       ctrl  = if (m .&. glut_ACTIVE_CTRL ) /= 0 then Down else Up,
       alt   = if (m .&. glut_ACTIVE_ALT  ) /= 0 then Down else Up }

    getModifiers :: IO Modifiers
    getModifiers = fmap unmarshalModifiers glutGetModifiers

    --------------------------------------------------------------------------------

    -- | A generalized view of keys

    data Key
       = Char Char
       | SpecialKey SpecialKey
       | MouseButton MouseButton
       deriving ( Eq, Ord, Show )

    -- | A keyboard\/mouse callback

    type KeyboardMouseCallback =
       Key -> KeyState -> Modifiers -> Position -> IO ()

    -- | Controls the keyboard\/mouse callback for the /current window./ The
    -- keyboard\/mouse callback for a window is called when the state of a key or
    -- mouse button changes. The callback parameters indicate the new state of the
    -- key\/button, the state of the keyboard modifiers, and the mouse location in
    -- window relative coordinates.
    --
    -- Note that this is a convenience function that should not ordinarily be used
    -- in conjunction with `keyboardCallback`, `keyboardUpCallback`,
    -- `specialCallback`, `specialUpCallback`, or `mouseCallback`.

    keyboardMouseCallback :: SettableStateVar (Maybe KeyboardMouseCallback)
    keyboardMouseCallback = makeSettableStateVar setKeyboardMouseCallback

    setKeyboardMouseCallback :: Maybe KeyboardMouseCallback -> IO ()
    setKeyboardMouseCallback Nothing = do
       setKeyboardCallback   Nothing
       setKeyboardUpCallback Nothing
       setSpecialCallback    Nothing
       setSpecialUpCallback  Nothing
       setMouseCallback      Nothing
    setKeyboardMouseCallback (Just cb) = do
       setKeyboardCallback   (Just (\c   p -> do m <- getModifiers
                                                 cb (Char        c) Down m p))
       setKeyboardUpCallback (Just (\c   p -> do m <- getModifiers
                                                 cb (Char        c) Up   m p))
       setSpecialCallback    (Just (\s   p -> do m <- getModifiers
                                                 cb (SpecialKey  s) Down m p))
       setSpecialUpCallback  (Just (\s   p -> do m <- getModifiers
                                                 cb (SpecialKey  s) Up   m p))
       setMouseCallback      (Just (\b s p -> do m <- getModifiers
                                                 cb (MouseButton b) s    m p))

    --------------------------------------------------------------------------------

    type WheelNumber = Int

    type WheelDirection = Int

    type MouseWheelCallback = WheelNumber -> WheelDirection -> Position -> IO ()

    -- | (/freeglut only/) Controls the mouse wheel callback for the
    -- /current window./ The mouse wheel callback for a window is called when a
    -- mouse wheel is used and the wheel number is greater than or equal to
    -- 'Graphics.UI.GLUT.State.numMouseButtons'.

    mouseWheelCallback :: SettableStateVar (Maybe MouseWheelCallback)
    mouseWheelCallback = makeSettableStateVar $
       setCallback MouseWheelCB glutMouseWheelFunc (makeMouseWheelFunc . unmarshal)
       where unmarshal cb n d x y = cb (fromIntegral n) (fromIntegral d)
                                       (Position (fromIntegral x) (fromIntegral y))

    --------------------------------------------------------------------------------

    -- | A motion callback

    type MotionCallback = Position -> IO ()

    -- | Controls the motion callback for the /current window./ The motion callback
    -- for a window is called when the mouse moves within the window while one or
    -- more mouse buttons are pressed. The callback parameter indicates the mouse
    -- location in window relative coordinates.

    motionCallback :: SettableStateVar (Maybe MotionCallback)
    motionCallback = makeSettableStateVar $
       setCallback MotionCB glutMotionFunc (makeMotionFunc . unmarshal)
       where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y))

    --------------------------------------------------------------------------------

    -- | Controls the passive motion callback for the /current window./ The passive
    -- motion callback for a window is called when the mouse moves within the window
    -- while /no/ mouse buttons are pressed. The callback parameter indicates the
    -- mouse location in window relative coordinates.

    passiveMotionCallback :: SettableStateVar (Maybe MotionCallback)
    passiveMotionCallback = makeSettableStateVar $
       setCallback PassiveMotionCB glutPassiveMotionFunc
                   (makePassiveMotionFunc . unmarshal)
       where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y))

    --------------------------------------------------------------------------------

    -- | The relation between the mouse pointer and the /current window/ has
    -- changed.

    data Crossing
       = WindowLeft    -- ^ The mouse pointer has left the /current window./
       | WindowEntered -- ^ The mouse pointer has entered the /current window./
       deriving ( Eq, Ord, Show )

    unmarshalCrossing :: CInt -> Crossing
    unmarshalCrossing x
       | x == glut_LEFT = WindowLeft
       | x == glut_ENTERED = WindowEntered
       | otherwise = error ("unmarshalCrossing: illegal value " ++ show x)

    --------------------------------------------------------------------------------

    -- | An enter\/leave callback

    type CrossingCallback = Crossing -> IO ()

    -- | Controls the mouse enter\/leave callback for the /current window./ Note
    -- that some window systems may not generate accurate enter\/leave callbacks.
    --
    -- /X Implementation Notes:/ An X implementation of GLUT should generate
    -- accurate enter\/leave callbacks.

    crossingCallback :: SettableStateVar (Maybe CrossingCallback)
    crossingCallback = makeSettableStateVar $
       setCallback CrossingCB glutEntryFunc (makeEntryFunc . unmarshal)
       where unmarshal cb = cb . unmarshalCrossing

    --------------------------------------------------------------------------------

    -- | Translation of the Spaceball along one axis, normalized to be in the range
    -- of -1000 to +1000 inclusive

    type SpaceballMotion = Int

    -- | Rotation of the Spaceball along one axis, normalized to be in the range
    -- of -1800 .. +1800 inclusive

    type SpaceballRotation = Int

    -- | The index of a specific buttons of an input device.

    type ButtonIndex = Int

    -- | The state of the Spaceball has changed.

    data SpaceballInput
       = SpaceballMotion   SpaceballMotion SpaceballMotion SpaceballMotion
       | SpaceballRotation SpaceballRotation SpaceballRotation SpaceballRotation
       | SpaceballButton   ButtonIndex KeyState
       deriving ( Eq, Ord, Show )

    -- | A SpaceballButton callback

    type SpaceballCallback = SpaceballInput -> IO ()

    -- | Controls the Spaceball callback for the /current window./ The Spaceball
    -- callback for a window is called when the window has Spaceball input focus
    -- (normally, when the mouse is in the window) and the user generates Spaceball
    -- translations, rotations, or button presses. The number of available Spaceball
    -- buttons can be determined with 'Graphics.UI.GLUT.State.numSpaceballButtons'.
    --
    -- Registering a Spaceball callback when a Spaceball device is not available has
    -- no effect and is not an error. In this case, no Spaceball callbacks will be
    -- generated.

    spaceballCallback :: SettableStateVar (Maybe SpaceballCallback)
    spaceballCallback = makeSettableStateVar setSpaceballCallback

    setSpaceballCallback :: Maybe SpaceballCallback -> IO ()
    setSpaceballCallback Nothing = do
       setSpaceballMotionCallback   Nothing
       setSpaceballRotationCallback Nothing
       setSpaceballButtonCallback   Nothing
    setSpaceballCallback (Just cb) = do
       setSpaceballMotionCallback   (Just (\x y z -> cb (SpaceballMotion   x y z)))
       setSpaceballRotationCallback (Just (\x y z -> cb (SpaceballRotation x y z)))
       setSpaceballButtonCallback   (Just (\b s   -> cb (SpaceballButton   b s)))

    --------------------------------------------------------------------------------

    type SpaceballMotionCallback =
       SpaceballMotion -> SpaceballMotion -> SpaceballMotion -> IO ()

    setSpaceballMotionCallback :: Maybe SpaceballMotionCallback -> IO ()
    setSpaceballMotionCallback =
       setCallback SpaceballMotionCB glutSpaceballMotionFunc
                   (makeSpaceballMotionFunc . unmarshal)
       where unmarshal cb x y z =
                cb (fromIntegral x) (fromIntegral y) (fromIntegral z)

    --------------------------------------------------------------------------------

    type SpaceballRotationCallback =
       SpaceballRotation -> SpaceballRotation -> SpaceballRotation -> IO ()

    setSpaceballRotationCallback :: Maybe SpaceballRotationCallback -> IO ()
    setSpaceballRotationCallback =
       setCallback SpaceballRotateCB glutSpaceballRotateFunc
                   (makeSpaceballRotateFunc . unmarshal)
       where unmarshal cb x y z =
                cb (fromIntegral x) (fromIntegral y) (fromIntegral z)

    --------------------------------------------------------------------------------

    type SpaceballButtonCallback = ButtonIndex -> KeyState -> IO ()

    setSpaceballButtonCallback :: Maybe SpaceballButtonCallback -> IO ()
    setSpaceballButtonCallback =
       setCallback SpaceballButtonCB glutSpaceballButtonFunc
                   (makeSpaceballButtonFunc . unmarshal)
       where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s)

    --------------------------------------------------------------------------------

    -- | The index of a specific dial of a dial and button box.

    type DialIndex = Int

    -- | The dial & button box state has changed.

    data DialAndButtonBoxInput
       = DialAndButtonBoxButton ButtonIndex KeyState
       | DialAndButtonBoxDial   DialIndex Int
       deriving ( Eq, Ord, Show )

    -- | A dial & button box callback

    type DialAndButtonBoxCallback = DialAndButtonBoxInput -> IO ()

    -- | Controls the dial & button box callback for the /current window./ The dial
    -- & button box button callback for a window is called when the window has dial
    -- & button box input focus (normally, when the mouse is in the window) and the
    -- user generates dial & button box button presses or dial changes. The number
    -- of available dial & button box buttons and dials can be determined with
    -- 'Graphics.UI.GLUT.State.numDialsAndButtons'.
    --
    -- Registering a dial & button box callback when a dial & button box device is
    -- not available is ineffectual and not an error. In this case, no dial & button
    -- box button will be generated.

    dialAndButtonBoxCallback :: SettableStateVar (Maybe DialAndButtonBoxCallback)
    dialAndButtonBoxCallback = makeSettableStateVar setDialAndButtonBoxCallback

    setDialAndButtonBoxCallback :: Maybe DialAndButtonBoxCallback -> IO ()
    setDialAndButtonBoxCallback Nothing = do
       setButtonBoxCallback Nothing
       setDialsCallback     Nothing
    setDialAndButtonBoxCallback (Just cb) = do
       setButtonBoxCallback (Just (\b s -> cb (DialAndButtonBoxButton b s)))
       setDialsCallback     (Just (\d x -> cb (DialAndButtonBoxDial   d x)))

    --------------------------------------------------------------------------------

    type ButtonBoxCallback = ButtonIndex -> KeyState -> IO ()

    setButtonBoxCallback :: Maybe ButtonBoxCallback -> IO ()
    setButtonBoxCallback =
       setCallback ButtonBoxCB glutButtonBoxFunc (makeButtonBoxFunc . unmarshal)
       where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s)

    --------------------------------------------------------------------------------

    type DialsCallback = DialIndex -> Int -> IO ()

    setDialsCallback :: Maybe DialsCallback -> IO ()
    setDialsCallback =
        setCallback DialsCB glutDialsFunc (makeDialsFunc . unmarshal)
        where unmarshal cb d x = cb (fromIntegral d) (fromIntegral x)

    --------------------------------------------------------------------------------

    -- | Absolute tablet position, with coordinates normalized to be in the range of
    -- 0 to 2000 inclusive

    data TabletPosition = TabletPosition Int Int
       deriving ( Eq, Ord, Show )

    -- | The table state has changed.

    data TabletInput
       = TabletMotion
       | TabletButton ButtonIndex KeyState
       deriving ( Eq, Ord, Show )

    -- | A tablet callback

    type TabletCallback = TabletInput -> TabletPosition -> IO ()

    -- | Controls the tablet callback for the /current window./ The tablet callback
    -- for a window is called when the window has tablet input focus (normally, when
    -- the mouse is in the window) and the user generates tablet motion or button
    -- presses. The number of available tablet buttons can be determined with
    -- 'Graphics.UI.GLUT.State.numTabletButtons'.
    --
    -- Registering a tablet callback when a tablet device is not available is
    -- ineffectual and not an error. In this case, no tablet callbacks will be
    -- generated.

    tabletCallback :: SettableStateVar (Maybe TabletCallback)
    tabletCallback = makeSettableStateVar setTabletCallback

    setTabletCallback :: Maybe TabletCallback -> IO ()
    setTabletCallback Nothing = do
       setTabletMotionCallback Nothing
       setTabletButtonCallback Nothing
    setTabletCallback (Just cb) = do
       setTabletMotionCallback (Just (\p     -> cb TabletMotion       p))
       setTabletButtonCallback (Just (\b s p -> cb (TabletButton b s) p))

    --------------------------------------------------------------------------------

    type TabletMotionCallback = TabletPosition -> IO ()

    setTabletMotionCallback :: Maybe TabletMotionCallback -> IO ()
    setTabletMotionCallback =
        setCallback TabletMotionCB glutTabletMotionFunc
                    (makeTabletMotionFunc . unmarshal)
        where unmarshal cb x y =
                 cb (TabletPosition (fromIntegral x) (fromIntegral y))

    --------------------------------------------------------------------------------

    type TabletButtonCallback = ButtonIndex -> KeyState -> TabletPosition -> IO ()

    setTabletButtonCallback :: Maybe TabletButtonCallback -> IO ()
    setTabletButtonCallback =
        setCallback TabletButtonCB glutTabletButtonFunc
                    (makeTabletButtonFunc . unmarshal)
        where unmarshal cb b s x y =
                 cb (fromIntegral b) (unmarshalKeyState s)
                    (TabletPosition (fromIntegral x) (fromIntegral y))

    --------------------------------------------------------------------------------

    -- | The state of the joystick buttons

    data JoystickButtons = JoystickButtons {
       joystickButtonA, joystickButtonB,
       joystickButtonC, joystickButtonD :: KeyState }
       deriving ( Eq, Ord, Show )

    -- Could use fromBitfield + Enum/Bounded instances + unmarshalJoystickButton
    -- instead...
    unmarshalJoystickButtons :: CUInt -> JoystickButtons
    unmarshalJoystickButtons m = JoystickButtons {
       joystickButtonA = if (m .&. glut_JOYSTICK_BUTTON_A) /= 0 then Down else Up,
       joystickButtonB = if (m .&. glut_JOYSTICK_BUTTON_B) /= 0 then Down else Up,
       joystickButtonC = if (m .&. glut_JOYSTICK_BUTTON_C) /= 0 then Down else Up,
       joystickButtonD = if (m .&. glut_JOYSTICK_BUTTON_D) /= 0 then Down else Up }

    --------------------------------------------------------------------------------

    -- | Absolute joystick position, with coordinates normalized to be in the range
    -- of -1000 to 1000 inclusive. The signs of the three axes mean the following:
    --
    -- * negative = left, positive = right
    --
    -- * negative = towards player, positive = away
    --
    -- * if available (e.g. rudder): negative = down, positive = up

    data JoystickPosition = JoystickPosition Int Int Int
       deriving ( Eq, Ord, Show )

    --------------------------------------------------------------------------------

    -- | A joystick callback

    type JoystickCallback = JoystickButtons -> JoystickPosition -> IO ()

    -- | Controls the joystick callback for the /current window./ The joystick
    -- callback is called either due to polling of the joystick at the uniform timer
    -- interval specified (if > 0) or in response to an explicit call of
    -- 'Graphics.UI.GLUT.DeviceControl.forceJoystickCallback'.
    --
    -- /X Implementation Notes:/ Currently GLUT has no joystick support for X11.

    -- joystickCallback :: SettableStateVar (Maybe JoystickCallback, PollRate)
    joystickCallback :: SettableStateVar (Maybe (JoystickCallback, PollRate))
    joystickCallback =
       makeSettableStateVar $ \maybeCBAndRate ->
          setCallback JoystickCB
                      (\f -> glutJoystickFunc f (fromIntegral (snd (fromJust maybeCBAndRate))))
                      (makeJoystickFunc . unmarshal)
                      (fmap fst maybeCBAndRate)
        where unmarshal cb b x y z = cb (unmarshalJoystickButtons b)
                                        (JoystickPosition (fromIntegral x)
                                                          (fromIntegral y)
                                                          (fromIntegral z))

    --------------------------------------------------------------------------------

    -- | A description where the multi-touch event is coming from, the freeglut
    -- specs are very vague about the actual semantics. It contains the device ID
    -- and\/or the cursor\/finger ID.

    type TouchID = Int

    -- | A multi-touch variant of 'MouseCallback'.

    type MultiMouseCallback = TouchID -> MouseCallback

    -- | (/freeglut only/) A multi-touch variant of 'mouseCallback'.

    multiMouseCallback :: SettableStateVar (Maybe MultiMouseCallback)
    multiMouseCallback = makeSettableStateVar $
       setCallback MultiButtonCB glutMultiButtonFunc (makeMultiButtonFunc . unmarshal)
       where unmarshal cb d x y b s = cb (fromIntegral d)
                                         (unmarshalMouseButton b)
                                         (unmarshalKeyState s)
                                         (Position (fromIntegral x) (fromIntegral y))

    -- | A multi-touch variant of 'CrossingCallback'.

    type MultiCrossingCallback = TouchID -> CrossingCallback

    -- | (/freeglut only/) A multi-touch variant of 'crossingCallback'.

    multiCrossingCallback :: SettableStateVar (Maybe MultiCrossingCallback)
    multiCrossingCallback = makeSettableStateVar $
       setCallback MultiEntryCB glutMultiEntryFunc (makeMultiEntryFunc . unmarshal)
       where unmarshal cb d c = cb (fromIntegral d) (unmarshalCrossing c)

    -- | A multi-touch variant of 'MotionCallback'.

    type MultiMotionCallback = TouchID -> MotionCallback

    -- | (/freeglut only/) A multi-touch variant of 'motionCallback'.

    multiMotionCallback :: SettableStateVar (Maybe MultiMotionCallback)
    multiMotionCallback = makeSettableStateVar $
       setCallback MultiMotionCB glutMultiMotionFunc (makeMultiMotionFunc . unmarshal)
       where unmarshal cb d x y =
                cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y))

    -- | (/freeglut only/) A multi-touch variant of 'passiveMotionCallback'.

    multiPassiveMotionCallback :: SettableStateVar (Maybe MultiMotionCallback)
    multiPassiveMotionCallback = makeSettableStateVar $
       setCallback MultiPassiveCB glutMultiPassiveFunc (makeMultiPassiveFunc . unmarshal)
       where unmarshal cb d x y =
                cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y))