{-# 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 ( Ptr, castPtr )
import Foreign.C.String ( peekCString )
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import System.IO.Unsafe ( unsafePerformIO )
import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLenum, GLubyte )

--------------------------------------------------------------------------------
-- Alas, GL and GLU define error enumerants with the same names, so we have to
-- rename these to avoid name clashes. Ugly, ugly, ugly...

data GL_ErrorCode =
     GL_NoError
   | GL_InvalidEnum
   | GL_InvalidValue
   | GL_InvalidOperation
   | GL_InvalidFramebufferOperation
   | GL_OutOfMemory
   | GL_StackOverflow
   | GL_StackUnderflow
   | GL_TableTooLarge

gl_marshalErrorCode :: GL_ErrorCode -> GLenum
gl_marshalErrorCode x = case x of
   GL_NoError -> 0x0
   GL_InvalidEnum -> 0x500
   GL_InvalidValue -> 0x501
   GL_InvalidOperation -> 0x502
   GL_InvalidFramebufferOperation -> 0x0506
   GL_OutOfMemory -> 0x505
   GL_StackOverflow -> 0x503
   GL_StackUnderflow -> 0x504
   GL_TableTooLarge -> 0x8031

--------------------------------------------------------------------------------
-- See comment above

data GLU_ErrorCode =
     GLU_InvalidEnum
   | GLU_InvalidValue
   | GLU_OutOfMemory
   | GLU_InvalidOperation

glu_marshalErrorCode :: GLU_ErrorCode -> GLenum
glu_marshalErrorCode x = case x of
   GLU_InvalidEnum -> 0x18a24
   GLU_InvalidValue -> 0x18a25
   GLU_OutOfMemory -> 0x18a26
   GLU_InvalidOperation -> 0x18a28

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

-- only the errors with the smallest and the largsest enum value
data NurbsError =
     NurbsError1
   | NurbsError37

marshalNurbsError :: NurbsError -> GLenum
marshalNurbsError x = case x of
   NurbsError1 -> 0x1879b
   NurbsError37 -> 0x187bf

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

-- only the errors with the smallest and the largsest enum value
data TessError =
     TessError1
   | TessError8

marshalTessError :: TessError -> GLenum
marshalTessError x = case x of
   TessError1 -> 0x18737
   TessError8 -> 0x1873e

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

-- | 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_marshalErrorCode  GL_InvalidEnum ||
   c == glu_marshalErrorCode GLU_InvalidEnum

isInvalidValue :: GLenum -> Bool
isInvalidValue c =
   c == gl_marshalErrorCode  GL_InvalidValue ||
   c == glu_marshalErrorCode GLU_InvalidValue

isInvalidOperation :: GLenum -> Bool
isInvalidOperation c =
   c == gl_marshalErrorCode  GL_InvalidOperation ||
   c == glu_marshalErrorCode GLU_InvalidOperation

isInvalidFramebufferOperation :: GLenum -> Bool
isInvalidFramebufferOperation c =
   c == gl_marshalErrorCode GL_InvalidFramebufferOperation

isOutOfMemory :: GLenum -> Bool
isOutOfMemory c =
   c == gl_marshalErrorCode  GL_OutOfMemory ||
   c == glu_marshalErrorCode GLU_OutOfMemory

isStackOverflow :: GLenum -> Bool
isStackOverflow c =
   c == gl_marshalErrorCode GL_StackOverflow

isStackUnderflow :: GLenum -> Bool
isStackUnderflow c =
   c == gl_marshalErrorCode GL_StackUnderflow

isTableTooLarge :: GLenum -> Bool
isTableTooLarge c =
   c == gl_marshalErrorCode GL_TableTooLarge

isTesselatorError :: GLenum -> Bool
isTesselatorError c =
   marshalTessError TessError1 <= c &&
   c <= marshalTessError TessError8

isNURBSError :: GLenum -> Bool
isNURBSError c =
   marshalNurbsError NurbsError1 <= c &&
   c <= marshalNurbsError NurbsError37

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

-- 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

foreign import CALLCONV unsafe "gluErrorString" gluErrorString ::
   GLenum -> IO (Ptr GLubyte)

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

-- 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_marshalErrorCode GL_NoError)

foreign import CALLCONV unsafe "glGetError" glGetError :: IO GLenum

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

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

recordErrorCode :: GLenum -> IO ()
recordErrorCode e = do
   getErrorCodesAux (\es -> (if null es then [e] else [], False))
   return ()

recordInvalidEnum :: IO ()
recordInvalidEnum = recordErrorCode (gl_marshalErrorCode GL_InvalidEnum)

recordInvalidValue :: IO ()
recordInvalidValue = recordErrorCode (gl_marshalErrorCode GL_InvalidValue)

recordOutOfMemory :: IO ()
recordOutOfMemory = recordErrorCode (glu_marshalErrorCode GLU_OutOfMemory)

-- 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