{-# LANGUAGE DeriveDataTypeable #-}
-- |Miscellaneous utilities for dealing with OpenGL errors.
module Graphics.GLUtil.GLError (printError, printErrorMsg, throwError, 
                                GLError, throwErrorMsg) where
import Control.Exception (Exception, throwIO)
import Control.Monad (when)
import Data.List (intercalate)
import Data.Typeable (Typeable)
import Graphics.Rendering.OpenGL
import System.IO (hPutStrLn, stderr)

-- |Check OpenGL error flags and print them on 'stderr'.
printError :: IO ()
printError :: IO ()
printError = GettableStateVar [Error] -> GettableStateVar [Error]
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar [Error]
errors GettableStateVar [Error] -> ([Error] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Error -> IO ()) -> [Error] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> (Error -> String) -> Error -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("GL: "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Error -> String) -> Error -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Show a => a -> String
show)

-- |Check OpenGL error flags and print them on 'stderr' with the given
-- message as a prefix. If there are no errors, nothing is printed.
printErrorMsg :: String -> IO ()
printErrorMsg :: String -> IO ()
printErrorMsg msg :: String
msg = do [Error]
errs <- GettableStateVar [Error] -> GettableStateVar [Error]
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar [Error]
errors
                       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Error] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Error]
errs))
                            (String -> IO ()
putStrLn String
msg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Error -> IO ()) -> [Error] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Error -> IO ()
printErr [Error]
errs)
  where printErr :: Error -> IO ()
printErr = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> (Error -> String) -> Error -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("  GL: "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Error -> String) -> Error -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Show a => a -> String
show

-- |An exception type for OpenGL errors.
data GLError = GLError String deriving (Typeable)
instance Exception GLError where
instance Show GLError where
  show :: GLError -> String
show (GLError msg :: String
msg) = "GLError " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

-- |Prefix each of a list of messages with "GL: ".
printGLErrors :: Show a => [a] -> String
printGLErrors :: [a] -> String
printGLErrors = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n  GL: " ([String] -> String) -> ([a] -> [String]) -> [a] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> ([a] -> [String]) -> [a] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show

-- |Throw an exception if there is an OpenGL error.
throwError :: IO ()
throwError :: IO ()
throwError = do [Error]
errs <- GettableStateVar [Error] -> GettableStateVar [Error]
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar [Error]
errors
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Error] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Error]
errs))
                     (GLError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (GLError -> IO ()) -> (String -> GLError) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GLError
GLError (String -> GLError) -> (String -> String) -> String -> GLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
tail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [Error] -> String
forall a. Show a => [a] -> String
printGLErrors [Error]
errs)

-- |Throw an exception if there is an OpenGL error. The exception's
-- error message is prefixed with the supplied 'String'.
throwErrorMsg :: String -> IO ()
throwErrorMsg :: String -> IO ()
throwErrorMsg msg :: String
msg = do [Error]
errs <- GettableStateVar [Error] -> GettableStateVar [Error]
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar [Error]
errors
                       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Error] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Error]
errs))
                            (GLError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (GLError -> IO ()) -> GLError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> GLError
GLError (String
msgString -> String -> String
forall a. [a] -> [a] -> [a]
++[Error] -> String
forall a. Show a => [a] -> String
printGLErrors [Error]
errs))