    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.Rendering.OpenGL.GL.Feedback
    -- Copyright   :  (c) Sven Panne 2002-2006
    -- License     :  BSD-style (see the file libraries/OpenGL/LICENSE)
    --
    -- Maintainer  :  sven.panne@aedion.de
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- This module corresponds to section 5.3 (Feedback) of the OpenGL 2.1 specs.
    --
    --------------------------------------------------------------------------------

    module Graphics.Rendering.OpenGL.GL.Feedback (
       FeedbackToken(..), VertexInfo(..), ColorInfo, FeedbackType(..),
       getFeedbackTokens, PassThroughValue(..), passThrough
    ) where

    import Control.Monad ( liftM2, liftM3, liftM4 )
    import Foreign.Marshal.Array ( allocaArray )
    import Foreign.Ptr ( Ptr, plusPtr )
    import Foreign.Storable ( Storable(sizeOf) )
    import Graphics.Rendering.OpenGL.GL.BasicTypes (
       GLenum, GLint, GLsizei, GLfloat )
    import Graphics.Rendering.OpenGL.GL.IOState (
       IOState, getIOState, peekIOState, evalIOState, nTimes )
    import Graphics.Rendering.OpenGL.GL.RenderMode ( withRenderMode )
    import Graphics.Rendering.OpenGL.GL.Selection ( RenderMode(Feedback) )
    import Graphics.Rendering.OpenGL.GL.StateVar ( HasGetter(get) )
    import Graphics.Rendering.OpenGL.GL.VertexSpec (
       Vertex2(..), Vertex3(..), Vertex4(..), Index1(..), Color4(..),
       TexCoord4(..), rgbaMode )

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

    data FeedbackToken =
         PointToken VertexInfo
       | LineToken VertexInfo VertexInfo
       | LineResetToken VertexInfo VertexInfo
       | PolygonToken [VertexInfo]
       | BitmapToken VertexInfo
       | DrawPixelToken VertexInfo
       | CopyPixelToken VertexInfo
       | PassThroughToken PassThroughValue
       deriving ( Eq, Ord, Show )

    data VertexInfo =
         Vertex2D             (Vertex2 GLfloat)
       | Vertex3D             (Vertex3 GLfloat)
       | Vertex3DColor        (Vertex3 GLfloat) ColorInfo
       | Vertex3DColorTexture (Vertex3 GLfloat) ColorInfo (TexCoord4 GLfloat)
       | Vertex4DColorTexture (Vertex4 GLfloat) ColorInfo (TexCoord4 GLfloat)
       deriving ( Eq, Ord, Show )

    type ColorInfo = Either (Index1 GLint) (Color4 GLfloat)

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

    data FeedbackTag =
         PointTag
       | LineTag
       | LineResetTag
       | PolygonTag
       | BitmapTag
       | DrawPixelTag
       | CopyPixelTag
       | PassThroughTag

    unmarshalFeedbackTag :: GLenum -> FeedbackTag
    unmarshalFeedbackTag x
       | x == 0x701 = PointTag
       | x == 0x702 = LineTag
       | x == 0x707 = LineResetTag
       | x == 0x703 = PolygonTag
       | x == 0x704 = BitmapTag
       | x == 0x705 = DrawPixelTag
       | x == 0x706 = CopyPixelTag
       | x == 0x700 = PassThroughTag
       | otherwise = error ("unmarshalFeedbackTag: illegal value " ++ show x)

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

    data FeedbackType =
         TwoD
       | ThreeD
       | ThreeDColor
       | ThreeDColorTexture
       | FourDColorTexture
       deriving ( Eq, Ord, Show )

    marshalFeedbackType :: FeedbackType -> GLenum
    marshalFeedbackType x = case x of
       TwoD -> 0x600
       ThreeD -> 0x601
       ThreeDColor -> 0x602
       ThreeDColorTexture -> 0x603
       FourDColorTexture -> 0x604

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

    getFeedbackTokens ::
       GLsizei -> FeedbackType -> IO a -> IO (a, Maybe [FeedbackToken])
    getFeedbackTokens bufSize feedbackType action =
       allocaArray (fromIntegral bufSize) $ \buf -> do
          glFeedbackBuffer bufSize (marshalFeedbackType feedbackType) buf
          (value, numValues) <- withRenderMode Feedback action
          tokens <- parseFeedbackBuffer numValues buf feedbackType
          return (value, tokens)

    foreign import CALLCONV unsafe "glFeedbackBuffer" glFeedbackBuffer ::
       GLsizei -> GLenum -> Ptr GLfloat -> IO ()

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

    parseFeedbackBuffer ::
       GLint -> Ptr GLfloat -> FeedbackType -> IO (Maybe [FeedbackToken])
    parseFeedbackBuffer numValues buf feedbackType
       | numValues < 0 = return Nothing
       | otherwise     = do
          rgba <- get rgbaMode
          let end = buf `plusPtr`
                      (sizeOf (undefined :: GLfloat) * fromIntegral numValues)
              infoParser = calcInfoParser feedbackType (calcColorParser rgba)
              loop tokens = do
                 ptr <- getIOState
                 if ptr == end
                    then return (reverse tokens)
                    else do token <- tokenParser infoParser
                            loop (token : tokens)
          fmap Just $ evalIOState (loop []) buf

    type Parser a = IOState GLfloat a

    tokenParser :: Parser VertexInfo -> Parser FeedbackToken
    tokenParser infoParser = do
       tag <- parseGLenum
       case unmarshalFeedbackTag tag of
          PointTag -> fmap PointToken infoParser
          LineTag -> liftM2 LineToken infoParser infoParser
          LineResetTag -> liftM2 LineResetToken infoParser infoParser
          PolygonTag -> do n <- parseGLint; fmap PolygonToken (nTimes n infoParser)
          BitmapTag -> fmap BitmapToken infoParser
          DrawPixelTag -> fmap DrawPixelToken infoParser
          CopyPixelTag -> fmap CopyPixelToken infoParser
          PassThroughTag -> fmap PassThroughToken parsePassThroughValue

    calcInfoParser :: FeedbackType -> Parser ColorInfo -> Parser VertexInfo
    calcInfoParser feedbackType colorParser = case feedbackType of
       TwoD ->
          fmap Vertex2D parseVertex2
       ThreeD ->
          fmap Vertex3D parseVertex3
       ThreeDColor ->
          liftM2 Vertex3DColor parseVertex3 colorParser
       ThreeDColorTexture ->
          liftM3 Vertex3DColorTexture parseVertex3 colorParser parseTexCoord4
       FourDColorTexture ->
          liftM3 Vertex4DColorTexture parseVertex4 colorParser parseTexCoord4

    parseVertex2 :: Parser (Vertex2 GLfloat)
    parseVertex2 = liftM2 Vertex2 parseGLfloat parseGLfloat

    parseVertex3 :: Parser (Vertex3 GLfloat)
    parseVertex3 = liftM3 Vertex3 parseGLfloat parseGLfloat parseGLfloat

    parseVertex4 :: Parser (Vertex4 GLfloat)
    parseVertex4 =
       liftM4 Vertex4 parseGLfloat parseGLfloat parseGLfloat parseGLfloat

    calcColorParser :: Bool -> Parser ColorInfo
    calcColorParser False = fmap Left parseIndex1
    calcColorParser True  = fmap Right parseColor4

    parseIndex1 :: Parser (Index1 GLint)
    parseIndex1 = fmap Index1 parseGLint

    parseColor4 :: Parser (Color4 GLfloat)
    parseColor4 = liftM4 Color4 parseGLfloat parseGLfloat parseGLfloat parseGLfloat

    parseTexCoord4 :: Parser (TexCoord4 GLfloat)
    parseTexCoord4 =
       liftM4 TexCoord4 parseGLfloat parseGLfloat parseGLfloat parseGLfloat

    parsePassThroughValue :: Parser PassThroughValue
    parsePassThroughValue = fmap PassThroughValue parseGLfloat

    parseGLenum :: Parser GLenum
    parseGLenum = fmap round parseGLfloat

    parseGLint :: Parser GLint
    parseGLint = fmap round parseGLfloat

    parseGLfloat :: Parser GLfloat
    parseGLfloat = peekIOState

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

    newtype PassThroughValue = PassThroughValue GLfloat
       deriving ( Eq, Ord, Show )

    foreign import CALLCONV unsafe "glPassThrough" passThrough ::
       PassThroughValue -> IO ()