No weird CPP macro. Use MonadIO. Cleaned up imports.

Author: svenpanne

GLUT.cabal

@@ -137,7 +137,6 @@ extra-source-files:
    examples/RedBook8/common/Makefile
    examples/RedBook8/Makefile
    examples/examples.mk
-   include/HsGLUTExt.h
 
 flag UseNativeWindowsLibraries
   description:
@@ -166,7 +165,6 @@ library
     Graphics.UI.GLUT.Callbacks.Registration
     Graphics.UI.GLUT.QueryUtils
     Graphics.UI.GLUT.Raw
-    Graphics.UI.GLUT.Raw.APIEntry
     Graphics.UI.GLUT.Raw.Callbacks
     Graphics.UI.GLUT.Raw.Fonts
     Graphics.UI.GLUT.Raw.Functions
@@ -175,14 +173,14 @@ library
   c-sources:
      cbits/HsGLUT.c
   hs-source-dirs: src
-  include-dirs: include
   build-depends:
-    base       >= 3    && < 5,
-    array      >= 0.3  && < 0.6,
-    containers >= 0.3  && < 0.6,
-    StateVar   >= 1.1  && < 1.2,
-    OpenGLRaw  >= 2.3  && < 2.5,
-    OpenGL     >= 2.12 && < 2.13
+    base         >= 3    && < 5,
+    array        >= 0.3  && < 0.6,
+    containers   >= 0.3  && < 0.6,
+    transformers >= 0.2  && < 0.5,
+    StateVar     >= 1.1  && < 1.2,
+    OpenGLRaw    >= 2.3  && < 2.5,
+    OpenGL       >= 2.12 && < 2.13
   default-language: Haskell2010
   other-extensions: CPP
   ghc-options: -Wall

include/HsGLUTExt.h

@@ -22,8 +22,10 @@ module Graphics.UI.GLUT.Begin (
    ActionOnWindowClose(..), actionOnWindowClose
 ) where
 
-import Data.StateVar
-import Foreign.C.Types
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Data.StateVar ( StateVar, makeStateVar )
+import Foreign.C.Types ( CInt )
+
 import Graphics.UI.GLUT.QueryUtils
 import Graphics.UI.GLUT.Raw
 
@@ -33,7 +35,7 @@ import Graphics.UI.GLUT.Raw
 -- callbacks that have been registered. This routine should be called at most
 -- once in a GLUT program.
 
-mainLoop :: IO ()
+mainLoop :: MonadIO m => m ()
 mainLoop = glutMainLoop
 
 --------------------------------------------------------------------------------
@@ -42,7 +44,7 @@ mainLoop = glutMainLoop
 -- This allows the application to control its own event loop and still use the
 -- GLUT package.
 
-mainLoopEvent :: IO ()
+mainLoopEvent :: MonadIO m => m ()
 mainLoopEvent = glutMainLoopEvent
 
 --------------------------------------------------------------------------------
@@ -57,7 +59,7 @@ mainLoopEvent = glutMainLoopEvent
 -- for one behaviour over the other he should contact the freeglut Programming
 -- Consortium and ask for the code to be fixed.
 
-leaveMainLoop :: IO ()
+leaveMainLoop :: MonadIO m => m ()
 leaveMainLoop = glutLeaveMainLoop
 
 --------------------------------------------------------------------------------

src/Graphics/UI/GLUT/Begin.hs

@@ -21,11 +21,11 @@ module Graphics.UI.GLUT.Callbacks.Global (
    Timeout, TimerCallback, addTimerCallback
 ) where
 
-import Control.Monad.Fix
-import Foreign.C.Types
-import Graphics.Rendering.OpenGL ( Position(..)
-                                 , SettableStateVar
-                                 , makeSettableStateVar )
+import Control.Monad.Fix ( mfix )
+import Data.StateVar ( SettableStateVar, makeSettableStateVar )
+import Foreign.C.Types ( CInt )
+import Graphics.Rendering.OpenGL ( Position(..) )
+
 import Graphics.UI.GLUT.Callbacks.Registration
 import Graphics.UI.GLUT.Raw
 

src/Graphics/UI/GLUT/Callbacks/Global.hs

@@ -19,12 +19,13 @@ module Graphics.UI.GLUT.Callbacks.Registration (
 
 --------------------------------------------------------------------------------
 
-import Control.Monad
-import Data.IORef
-import qualified Data.Map as Map ( empty, lookup, insert, delete )
-import Data.Map ( Map )
-import Foreign.Ptr
-import Graphics.Rendering.OpenGL ( get )
+import Control.Monad ( when )
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
+import qualified Data.Map as M
+import Data.StateVar ( get )
+import Foreign.Ptr ( FunPtr, nullFunPtr, freeHaskellFunPtr )
+import System.IO.Unsafe ( unsafePerformIO )
+
 import Graphics.UI.GLUT.Raw
 import Graphics.UI.GLUT.Window
 
@@ -86,22 +87,22 @@ modifyCallbackTable = modifyIORef theCallbackTable
 
 --------------------------------------------------------------------------------
 
-type CallbackTable a = Map CallbackID (FunPtr a)
+type CallbackTable a = M.Map CallbackID (FunPtr a)
 
 emptyCallbackTable :: CallbackTable a
-emptyCallbackTable = Map.empty
+emptyCallbackTable = M.empty
 
 lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a))
 lookupInCallbackTable callbackID =
-   fmap (Map.lookup callbackID) getCallbackTable
+   fmap (M.lookup callbackID) getCallbackTable
 
 deleteFromCallbackTable :: CallbackID -> IO ()
 deleteFromCallbackTable callbackID =
-   modifyCallbackTable (Map.delete callbackID)
+   modifyCallbackTable (M.delete callbackID)
 
 addToCallbackTable :: CallbackID -> FunPtr a -> IO ()
 addToCallbackTable callbackID funPtr =
-   modifyCallbackTable (Map.insert callbackID funPtr)
+   modifyCallbackTable (M.insert callbackID funPtr)
 
 --------------------------------------------------------------------------------
 -- Another global mutable variable: The list of function pointers ready to be

src/Graphics/UI/GLUT/Callbacks/Registration.hs

@@ -74,11 +74,13 @@ module Graphics.UI.GLUT.Callbacks.Window (
 
 ) where
 
-import Data.Bits hiding ( shift )
-import Data.Char
-import Data.Maybe
-import Foreign.C.Types
-import Graphics.Rendering.OpenGL
+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

src/Graphics/UI/GLUT/Callbacks/Window.hs

@@ -41,10 +41,12 @@ module Graphics.UI.GLUT.Colormap (
    transparentIndex
 ) where
 
-import Foreign.C.Types
-import Graphics.Rendering.OpenGL ( GLfloat, GLint, Color3(..), Index1(..)
-                                 , StateVar, makeStateVar, GettableStateVar
-                                 , makeGettableStateVar )
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Data.StateVar ( GettableStateVar, makeGettableStateVar, StateVar, makeStateVar )
+import Foreign.C.Types ( CInt )
+import Graphics.Rendering.OpenGL.GL.VertexSpec ( Index1(..), Color3(..) )
+import Graphics.Rendering.OpenGL.Raw.Types ( GLint, GLfloat )
+
 import Graphics.UI.GLUT.QueryUtils
 import Graphics.UI.GLUT.Raw
 import Graphics.UI.GLUT.Types
@@ -87,7 +89,7 @@ getColorMapEntry cell = do
 -- 'copyColormap' should only be called when both the /current window/ and the
 -- specified window are color index windows.
 
-copyColormap :: Window -> IO ()
+copyColormap :: MonadIO m => Window -> m ()
 copyColormap (Window win) = glutCopyColormap win
 
 --------------------------------------------------------------------------------

src/Graphics/UI/GLUT/Colormap.hs

@@ -17,9 +17,11 @@ module Graphics.UI.GLUT.Debugging (
    reportErrors
 ) where
 
-import Graphics.Rendering.OpenGL ( Error(..), errors, get )
-import System.Environment
-import System.IO
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Data.StateVar ( get )
+import Graphics.Rendering.OpenGL ( Error(..), errors )
+import System.Environment ( getProgName )
+import System.IO ( hPutStrLn, stderr )
 
 --------------------------------------------------------------------------------
 
@@ -28,10 +30,10 @@ import System.IO
 -- error flags are reset after this action, i.e. there are no pending errors
 -- left afterwards.
 
-reportErrors :: IO ()
+reportErrors :: MonadIO m => m ()
 reportErrors = get errors >>= mapM_ reportError
 
-reportError :: Error -> IO ()
-reportError (Error _ msg) = do
+reportError :: MonadIO m => Error -> m ()
+reportError (Error _ msg) = liftIO $ do
    pn <- getProgName
    hPutStrLn stderr ("GLUT: Warning in " ++ pn ++ ": GL error: " ++ msg)

src/Graphics/UI/GLUT/Debugging.hs

@@ -19,8 +19,10 @@ module Graphics.UI.GLUT.DeviceControl (
    forceJoystickCallback
 ) where
 
-import Foreign.C.Types
-import Graphics.Rendering.OpenGL ( StateVar, makeStateVar )
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Data.StateVar ( StateVar, makeStateVar )
+import Foreign.C.Types ( CInt )
+
 import Graphics.UI.GLUT.QueryUtils
 import Graphics.UI.GLUT.Raw
 
@@ -118,5 +120,5 @@ perWindowKeyRepeat =
 -- This is done in a synchronous fashion within the current context, i.e. when
 -- 'forceJoystickCallback' returns, the callback will have already happened.
 
-forceJoystickCallback :: IO ()
+forceJoystickCallback :: MonadIO m => m ()
 forceJoystickCallback = glutForceJoystickFunc

src/Graphics/UI/GLUT/DeviceControl.hs

@@ -22,11 +22,13 @@ module Graphics.UI.GLUT.Fonts (
    Font(..), BitmapFont(..), StrokeFont(..),
 ) where
 
-import Data.Char
-import Foreign.C.String
-import Foreign.C.Types
-import Foreign.Ptr
-import Graphics.Rendering.OpenGL
+import Control.Monad.IO.Class ( MonadIO(..) )
+import Data.Char ( ord )
+import Foreign.C.String ( withCString )
+import Foreign.C.Types ( CInt )
+import Foreign.Ptr ( castPtr )
+import Graphics.Rendering.OpenGL.Raw.Types ( GLint, GLfloat )
+
 import Graphics.UI.GLUT.Raw
 
 --------------------------------------------------------------------------------
@@ -44,20 +46,20 @@ class Font a where
    -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.translate' is used to translate
    -- the current model view matrix to advance the width of the string.
 
-   renderString :: a -> String -> IO ()
+   renderString :: MonadIO m => a -> String -> m ()
 
    -- | For a bitmap font, return the width in pixels of a string. For a stroke
    -- font, return the width in units. While the width of characters in a font
    -- may vary (though fixed width fonts do not vary), the maximum height
    -- characteristics of a particular font are fixed.
 
-   stringWidth :: a -> String -> IO GLint
+   stringWidth :: MonadIO m => a -> String -> m GLint
 
    -- | (/freeglut only/) For a bitmap font, return the maximum height of the
    -- characters in the given font measured in pixels. For a stroke font,
    -- return the width in units.
 
-   fontHeight :: a -> IO GLfloat
+   fontHeight :: MonadIO m => a -> m GLfloat
 
 instance Font BitmapFont where
    renderString = bitmapString
@@ -72,49 +74,55 @@ instance Font StrokeFont where
 
 --------------------------------------------------------------------------------
 
-bitmapString :: BitmapFont -> String -> IO ()
+bitmapString :: MonadIO m => BitmapFont -> String -> m ()
 bitmapString f s = do
    i <- marshalBitmapFont f
    mapM_ (\c -> withChar c (glutBitmapCharacter i)) s
 
-withChar :: Char -> (CInt -> IO a) -> IO a
+withChar :: MonadIO m => Char -> (CInt -> m a) -> m a
 withChar c f = f . fromIntegral . ord $ c
 
 --------------------------------------------------------------------------------
 
-strokeString :: StrokeFont -> String -> IO ()
+strokeString :: MonadIO m => StrokeFont -> String -> m ()
 strokeString f s = do
    i <- marshalStrokeFont f
    mapM_ (\c -> withChar c (glutStrokeCharacter i)) s
 
 --------------------------------------------------------------------------------
 
-bitmapLength :: BitmapFont -- ^ Bitmap font to use.
+bitmapLength :: MonadIO m
+             => BitmapFont -- ^ Bitmap font to use.
              -> String     -- ^ String to return width of (not confined to 8
                            --   bits).
-             -> IO GLint   -- ^ Width in pixels.
-bitmapLength f s = do
+             -> m GLint    -- ^ Width in pixels.
+bitmapLength f s = liftIO $ do
    i <- marshalBitmapFont f
    fmap fromIntegral $ withCString s (glutBitmapLength i . castPtr)
 
 --------------------------------------------------------------------------------
 
-strokeLength :: StrokeFont -- ^ Stroke font to use.
+strokeLength :: MonadIO m
+             => StrokeFont -- ^ Stroke font to use.
              -> String     -- ^ String to return width of (not confined to 8
                            --   bits).
-             -> IO GLint   -- ^ Width in units.
-strokeLength f s = do
+             -> m GLint    -- ^ Width in units.
+strokeLength f s = liftIO $ do
    i <- marshalStrokeFont f
    fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr)
 
 --------------------------------------------------------------------------------
 
-bitmapHeight :: BitmapFont -- ^ Bitmap font to use.
-             -> IO GLfloat -- ^ Height in pixels.
-bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marshalBitmapFont f
+bitmapHeight :: MonadIO m
+             => BitmapFont -- ^ Bitmap font to use.
+             -> m GLfloat  -- ^ Height in pixels.
+bitmapHeight f = liftIO $ do
+  i <- marshalBitmapFont f
+  fromIntegral `fmap` glutBitmapHeight  i
 
 --------------------------------------------------------------------------------
 
-strokeHeight :: StrokeFont -- ^ Stroke font to use.
-             -> IO GLfloat -- ^ Height in units.
+strokeHeight :: MonadIO m
+             => StrokeFont -- ^ Stroke font to use.
+             -> m GLfloat  -- ^ Height in units.
 strokeHeight f = glutStrokeHeight =<< marshalStrokeFont f