Added positionCallback.

Author: svenpanne

Graphics/UI/GLUT/Callbacks/Registration.hs

@@ -40,8 +40,8 @@ data CallbackType
    | SpaceballButtonCB | ButtonBoxCB       | DialsCB
    | TabletMotionCB    | TabletButtonCB    | JoystickCB
    | MenuStatusCB      | IdleCB
-   | CloseCB   -- freeglut only
-   | MouseWheelCB   -- freeglut only
+   -- freeglut-only callback types
+   | CloseCB           | MouseWheelCB      | PositionCB
    deriving ( Eq, Ord )
 
 isGlobal :: CallbackType -> Bool

Graphics/UI/GLUT/Callbacks/Window.hs

@@ -17,6 +17,9 @@ module Graphics.UI.GLUT.Callbacks.Window (
    -- * Reshape callback
    ReshapeCallback, reshapeCallback,
 
+   -- * Position callback
+   PositionCallback, positionCallback,
+
    -- * Callbacks for visibility changes
    Visibility(..), VisibilityCallback, visibilityCallback,
    WindowState(..), WindowStateCallback, windowStateCallback,
@@ -64,8 +67,7 @@ import Data.Bits hiding ( shift )
 import Data.Char
 import Data.Maybe
 import Foreign.C.Types
-import Graphics.Rendering.OpenGL ( Position(..), Size(..)
-                                 , SettableStateVar, makeSettableStateVar )
+import Graphics.Rendering.OpenGL
 import Graphics.UI.GLUT.Callbacks.Registration
 import Graphics.UI.GLUT.Raw
 import Graphics.UI.GLUT.State
@@ -190,6 +192,21 @@ reshapeCallback = makeSettableStateVar $
 
 --------------------------------------------------------------------------------
 
+-- | 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

Graphics/UI/GLUT/Raw/Callbacks.hs

@@ -33,6 +33,7 @@ module Graphics.UI.GLUT.Raw.Callbacks (
    MouseWheelFunc, makeMouseWheelFunc,
    OverlayDisplayFunc, makeOverlayDisplayFunc,
    PassiveMotionFunc, makePassiveMotionFunc,
+   PositionFunc, makePositionFunc,
    ReshapeFunc, makeReshapeFunc,
    SpaceballButtonFunc, makeSpaceballButtonFunc,
    SpaceballMotionFunc, makeSpaceballMotionFunc,
@@ -140,6 +141,11 @@ type PassiveMotionFunc = CInt -> CInt -> IO ()
 foreign import ccall "wrapper"
    makePassiveMotionFunc :: PassiveMotionFunc -> IO (FunPtr PassiveMotionFunc)
 
+type PositionFunc = CInt -> CInt -> IO ()
+
+foreign import ccall "wrapper"
+   makePositionFunc :: PositionFunc -> IO (FunPtr PositionFunc)
+
 type ReshapeFunc = CInt -> CInt -> IO ()
 
 foreign import ccall "wrapper"

Graphics/UI/GLUT/Raw/Functions.hs

@@ -87,6 +87,7 @@ module Graphics.UI.GLUT.Raw.Functions (
    glutOverlayDisplayFunc,
    glutPassiveMotionFunc,
    glutPopWindow,
+   glutPositionFunc,
    glutPositionWindow,
    glutPostOverlayRedisplay,
    glutPostRedisplay,
@@ -248,6 +249,7 @@ API_ENTRY(glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ())
 API_ENTRY(glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ())
 API_ENTRY(glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ())
 API_ENTRY(glutPopWindow,IO ())
+API_ENTRY(glutPositionFunc,FunPtr PositionFunc -> IO ())
 API_ENTRY(glutPositionWindow,CInt -> CInt -> IO ())
 API_ENTRY_SAFE(glutPostOverlayRedisplay,IO ())
 API_ENTRY(glutPostRedisplay,IO ())