{-# LANGUAGE DeriveDataTypeable #-}
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)
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)
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
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
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
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)
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))