{-# OPTIONS_GHC -fno-cse #-}

-- #hide
--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GLU.ErrorsInternal
-- Copyright   :  (c) Sven Panne 2002-2009
-- License     :  BSD-style (see the file libraries/OpenGL/LICENSE)
--
-- Maintainer  :  sven.panne@aedion.de
-- Stability   :  stable
-- Portability :  portable
--
-- This is a purely internal module corresponding to some parts of section 2.5
-- (GL Errors) of the OpenGL 2.1 specs and chapter 8 (Errors) of the GLU specs.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GLU.ErrorsInternal (
   Error(..), ErrorCategory(..), getErrors,
   recordErrorCode, recordInvalidEnum, recordInvalidValue, recordOutOfMemory
) where

import Foreign.Ptr ( castPtr )
import Foreign.C.String ( peekCString )
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import System.IO.Unsafe ( unsafePerformIO )
import Graphics.Rendering.GLU.Raw
import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
import Graphics.Rendering.OpenGL.Raw.Core31

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

-- | GL\/GLU errors consist of a general error category and a description of
-- what went wrong.

data Error = Error ErrorCategory String
   deriving ( Eq, Ord, Show )

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

-- | General GL\/GLU error categories

data ErrorCategory
   = InvalidEnum
   | InvalidValue
   | InvalidOperation
   | InvalidFramebufferOperation
   | OutOfMemory
   | StackOverflow
   | StackUnderflow
   | TableTooLarge
   | TesselatorError
   | NURBSError
   deriving ( Eq, Ord, Show )

unmarshalErrorCategory :: GLenum -> ErrorCategory
unmarshalErrorCategory c
   | isInvalidEnum c      = InvalidEnum
   | isInvalidValue c     = InvalidValue
   | isInvalidOperation c = InvalidOperation
   | isInvalidFramebufferOperation c = InvalidFramebufferOperation
   | isOutOfMemory c      = OutOfMemory
   | isStackOverflow c    = StackOverflow
   | isStackUnderflow c   = StackUnderflow
   | isTableTooLarge c    = TableTooLarge
   | isTesselatorError c  = TesselatorError
   | isNURBSError c       = NURBSError
   | otherwise = error "unmarshalErrorCategory"

isInvalidEnum :: GLenum -> Bool
isInvalidEnum c = c == gl_INVALID_ENUM || c == glu_INVALID_ENUM

isInvalidValue :: GLenum -> Bool
isInvalidValue c = c == gl_INVALID_VALUE || c == glu_INVALID_VALUE

isInvalidOperation :: GLenum -> Bool
isInvalidOperation c = c == gl_INVALID_OPERATION || c == glu_INVALID_OPERATION

isInvalidFramebufferOperation :: GLenum -> Bool
isInvalidFramebufferOperation c = c == gl_INVALID_FRAMEBUFFER_OPERATION

isOutOfMemory :: GLenum -> Bool
isOutOfMemory c = c == gl_OUT_OF_MEMORY || c == glu_OUT_OF_MEMORY

isStackOverflow :: GLenum -> Bool
isStackOverflow c = c == gl_STACK_OVERFLOW

isStackUnderflow :: GLenum -> Bool
isStackUnderflow c = c == gl_STACK_UNDERFLOW

isTableTooLarge :: GLenum -> Bool
isTableTooLarge c = c == gl_TABLE_TOO_LARGE

isTesselatorError :: GLenum -> Bool
isTesselatorError c = glu_TESS_ERROR1 <= c && c <= glu_TESS_ERROR8

isNURBSError :: GLenum -> Bool
isNURBSError c = glu_NURBS_ERROR1 <= c && c <= glu_NURBS_ERROR37

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

-- The returned error string is statically allocated, so peekCString
-- does the right thing here. No malloc/free necessary here.

makeError :: GLenum -> IO Error
makeError e = do
   let category = unmarshalErrorCategory e
   ptr <- gluErrorString e
   description <- peekCString (castPtr ptr)
   return $ Error category description

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

-- This seems to be a common Haskell hack nowadays: A plain old global variable
-- with an associated getter and mutator. Perhaps some language/library support
-- is needed?

{-# NOINLINE theRecordedErrors #-}
theRecordedErrors :: IORef ([GLenum],Bool)
theRecordedErrors = unsafePerformIO (newIORef ([], True))

getRecordedErrors :: IO ([GLenum],Bool)
getRecordedErrors =  readIORef theRecordedErrors

setRecordedErrors :: ([GLenum],Bool) -> IO ()
setRecordedErrors = writeIORef theRecordedErrors

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

getGLErrors :: IO [GLenum]
getGLErrors = getGLErrorsAux []
   where getGLErrorsAux acc = do
            errorCode <- glGetError
            if isError errorCode
               then getGLErrorsAux (errorCode : acc)
               else return $ reverse acc

isError :: GLenum -> Bool
isError = (/= gl_NO_ERROR)

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

getErrors :: IO [Error]
getErrors = do
   es <- getErrorCodesAux (const ([], True))
   mapM makeError es

recordErrorCode :: GLenum -> IO ()
recordErrorCode e = do
   -- We don't need the return value because this calls setRecordedErrors
   _ <- getErrorCodesAux (\es -> (if null es then [e] else [], False))
   return ()

recordInvalidEnum :: IO ()
recordInvalidEnum = recordErrorCode gl_INVALID_ENUM

recordInvalidValue :: IO ()
recordInvalidValue = recordErrorCode gl_INVALID_VALUE

recordOutOfMemory :: IO ()
recordOutOfMemory = recordErrorCode gl_OUT_OF_MEMORY

-- ToDo: Make this thread-safe
getErrorCodesAux :: ([GLenum] -> ([GLenum],Bool)) -> IO [GLenum]
getErrorCodesAux f = do
   (recordedErrors, useGLErrors) <- getRecordedErrors
   glErrors <- getGLErrors
   let es = if useGLErrors then recordedErrors ++ glErrors else recordedErrors
   setRecordedErrors (f es)
   return es