{-# LANGUAGE GADTs, DataKinds, FlexibleContexts, TypeSynonymInstances,
             FlexibleInstances, MultiParamTypeClasses, KindSignatures,
             GeneralizedNewtypeDeriving, RankNTypes, TypeOperators, CPP,
             ScopedTypeVariables, UndecidableInstances, TypeFamilies #-}

module Graphics.Rendering.Ombra.Draw.Monad (
        Draw,
        DrawState,
        ResStatus(..),
        Buffer(..),
        drawState,
        drawInit,
        clearColor,
        clearDepth,
        clearStencil,
        preloadGeometry,
        preloadTexture,
        preloadProgram,
        removeGeometry,
        removeTexture,
        removeProgram,
        checkGeometry,
        checkTexture,
        checkProgram,
        textureSize,
        setProgram,
        resizeViewport,
        evalDraw,
        gl,
        drawGet
) where

import qualified Graphics.Rendering.Ombra.Blend.Draw as Blend
import qualified Graphics.Rendering.Ombra.Blend.Types as Blend
import Graphics.Rendering.Ombra.Color
import Graphics.Rendering.Ombra.Culling.Draw
import Graphics.Rendering.Ombra.Culling.Types
import Graphics.Rendering.Ombra.Draw.Class
import Graphics.Rendering.Ombra.Geometry
import Graphics.Rendering.Ombra.Geometry.Draw
import Graphics.Rendering.Ombra.OutBuffer.Types
import Graphics.Rendering.Ombra.Texture
import Graphics.Rendering.Ombra.Texture.Draw
import Graphics.Rendering.Ombra.Backend (GLES)
import qualified Graphics.Rendering.Ombra.Backend as GL
import Graphics.Rendering.Ombra.Internal.GL hiding (Texture, Program, Buffer,
                                                    UniformLocation, cullFace,
                                                    depthMask, colorMask,
                                                    drawBuffers, clearColor,
                                                    clearDepth, clearStencil)
import qualified Graphics.Rendering.Ombra.Internal.GL as GL
import Graphics.Rendering.Ombra.Internal.Resource
import Graphics.Rendering.Ombra.Screen
import Graphics.Rendering.Ombra.Shader.Language.Types
import Graphics.Rendering.Ombra.Shader.Program
import Graphics.Rendering.Ombra.Shader.Types
import qualified Graphics.Rendering.Ombra.Stencil.Draw as Stencil
import qualified Graphics.Rendering.Ombra.Stencil.Types as Stencil
import Graphics.Rendering.Ombra.Vector

import Data.Hashable
import Data.Proxy
import Data.Word
import Control.Monad
import Control.Monad.Base
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Control.Monad.Trans.Class
import Control.Monad.Trans.State

-- | The state of the 'Draw' monad.
data DrawState = DrawState
        { currentFrameBuffer :: FrameBuffer
        , currentProgram :: Maybe ProgramIndex
        , loadedProgram :: Maybe LoadedProgram
        , programs :: ResMap LoadedProgram
        , uniforms :: ResMap UniformLocation
        , elemBuffers :: ResMap LoadedBuffer
        , attributes :: ResMap LoadedAttribute
        , geometries :: ResMap LoadedGeometry
        , textureImages :: ResMap LoadedTexture
        , activeTextures :: Int
        -- , textureCache :: [LoadedTexture]
        , viewportSize :: ((Int, Int), (Int, Int))
        , blendMode :: Maybe Blend.Mode
        , stencilMode :: Maybe Stencil.Mode
        , cullFace :: Maybe CullFace
        , depthTest :: Bool
        , depthMask :: Bool
        , colorMask :: (Bool, Bool, Bool, Bool)
        }

data Buffer = ColorBuffer
            | DepthBuffer
            | StencilBuffer

-- | An implementation of 'MonadDraw' and 'MonadDrawBuffers'.
newtype Draw o a = Draw { unDraw :: StateT DrawState GL a }
        deriving ( Functor
                 , Applicative
                 , Monad
                 , MonadIO
                 , MonadBase IO
#if __GLASGOW_HASKELL__ >= 802
                 , MonadBaseControl IO
                 )
#else
                 )

instance MonadBaseControl IO (Draw o) where
        type StM (Draw o) a = ComposeSt (StateT DrawState) GL a
        liftBaseWith f = Draw $ liftBaseWith $ \tf -> f (tf . unDraw)
        restoreM = Draw . restoreM
#endif

instance (FragmentShaderOutput o, GLES) => MonadDraw o Draw where
        withColorMask m a = stateReset colorMask setColorMask m a
        withDepthTest d a = stateReset depthTest setDepthTest d a
        withDepthMask m a = stateReset depthMask setDepthMask m a
        clearColor = clearBuffers [ColorBuffer]
        clearColorWith (Vec4 r g b a) = gl $ do GL.clearColor (realToFrac r)
                                                              (realToFrac g)
                                                              (realToFrac b)
                                                              (realToFrac a)
                                                clearBuffers [ColorBuffer]
                                                GL.clearColor 0.0 0.0 0.0 1.0
        clearDepth = clearBuffers [DepthBuffer]
        clearDepthWith value = gl $ do GL.clearDepth $ realToFrac value
                                       clearBuffers [DepthBuffer]
                                       GL.clearDepth 1
        clearStencil = clearBuffers [StencilBuffer]
        clearStencilWith value = gl $ do GL.clearStencil $ fromIntegral value
                                         clearBuffers [StencilBuffer]
                                         GL.clearStencil 0

instance GLES => MonadDrawBuffers Draw where
        {-
        drawBuffers w h gBuffer depthBuffer draw cont =
                do (ret, (newGBuffer, gBuffer'), (newDepthBuffer, depthBuffer'))
                        <- permanentDrawBuffers w h gBuffer depthBuffer draw
                   ret' <- cont gBuffer' depthBuffer' ret
                   when newGBuffer $ unusedTextures (textures gBuffer')
                   when newDepthBuffer $ unusedTextures (textures depthBuffer')
                   return ret'
        -}
        createBuffers w h gBufferInfo depthBufferInfo draw =
                do (ret, gBuffer, depthBuffer) <-
                        drawBuffers' w h
                                     True
                                     (Right gBufferInfo)
                                     (Right depthBufferInfo)
                                     draw
                   return (ret, BufferPair gBuffer depthBuffer)
        createGBuffer gBufferInfo depthBuffer draw =
                do let (w, h) = bufferSize depthBuffer
                   (ret, gBuffer, _) <-
                        drawBuffers' w h
                                     True
                                     (Right gBufferInfo)
                                     (Left depthBuffer)
                                     draw
                   return (ret, BufferPair gBuffer depthBuffer)
        createDepthBuffer gBuffer depthBufferInfo draw =
                do let (w, h) = bufferSize gBuffer
                   (ret, _, depthBuffer) <-
                        drawBuffers' w h
                                     True
                                     (Left gBuffer)
                                     (Right depthBufferInfo)
                                     draw
                   return (ret, BufferPair gBuffer depthBuffer)
        drawBuffers (BufferPair gBuffer depthBuffer) draw =
                do let (w, h) = bufferSize gBuffer
                   (ret, _, _) <- drawBuffers' w h
                                               True
                                               (Left gBuffer)
                                               (Left depthBuffer)
                                               draw
                   return ret

instance GLES => MonadRead GVec4 Draw where
        readColor = flip readPixels gl_RGBA
        readColorFloat = flip readPixels gl_RGBA
        readDepth = flip readPixels gl_DEPTH_COMPONENT
        readDepthFloat = flip readPixels gl_DEPTH_COMPONENT
        readStencil = flip readPixels gl_STENCIL_INDEX

instance GLES => MonadScreen (Draw o) where
        currentViewport = viewportSize <$> Draw get
        resizeViewport p w = do setViewport p w
                                Draw . modify $ \s ->
                                        s { viewportSize = (p, w) }
instance GLES => MonadProgram (Draw o) where
        setProgram p = withProgram p $ \(LoadedProgram glp _ _) ->
                                                gl $ useProgram glp
        getUniform id = do mprg <- loadedProgram <$> Draw get
                           case mprg of
                                Just prg -> do map <- uniforms <$> Draw get
                                               gl $ getResource' (Just prg)
                                                                 (prg, id)
                                                                 map
                                Nothing -> return $ Left "No loaded program."

instance GLES => MonadCulling (Draw o) where
        withCulling face a = stateReset cullFace setCullFace face a

instance GLES => Blend.MonadBlend (Draw o) where
        withBlendMode m a = stateReset blendMode setBlendMode m a

instance GLES => Stencil.MonadStencil (Draw o) where
        withStencilMode m a = stateReset stencilMode setStencilMode m a

instance GLES => MonadTexture (Draw o) where
        getTexture (TextureLoaded l) = return $ Right l
        getTexture (TextureImage t) = getTextureImage t
        withActiveTextures =
                defaultWithActiveTextures (activeTextures <$> Draw get)
                                          (\n -> Draw . modify  $ \s ->
                                                s { activeTextures = n })
        newTexture w h params i initialize =
                gl $ do t <- emptyTexture params
                        initialize t
                        return $ LoadedTexture w' h' i t
                {-
                do cache <- textureCache <$> Draw get
                   let (c1, c2) = flip break cache $
                                        \(LoadedTexture cw ch i' t) ->
                                                w' == cw && h' == ch && i == i'
                   case c2 of
                        [] -> gl $ do t <- emptyTexture params
                                      initialize t
                                      return $ LoadedTexture w' h' i t
                        (lt : c2') -> do Draw . modify $ \s ->
                                                s { textureCache = c1 ++ c2' }
                                         return lt
                -}
                where (w', h') = (fromIntegral w, fromIntegral h)
        {-
        unusedTextures ts =
                do cache <- textureCache <$> Draw get
                   let (cache', excess) = splitAt textureCacheMaxSize
                                                  (ts ++ cache)
                   Draw . modify $ \s -> s { textureCache = cache' }
                   mapM_ (removeTexture . TextureLoaded) excess
        -}

instance GLES => MonadGeometry (Draw o) where
        getAttribute = getDrawResource gl attributes
        getElementBuffer = getDrawResource gl elemBuffers
        getGeometry = getDrawResource id geometries

instance MonadGL (Draw o) where
        gl = Draw . lift

-- | Create a 'DrawState'.
drawState :: GLES
          => Int         -- ^ Viewport width
          -> Int         -- ^ Viewport height
          -> DrawState
drawState w h = DrawState { currentFrameBuffer = noFramebuffer
                          , currentProgram = Nothing
                          , loadedProgram = Nothing
                          -- , textureCache = []
                          , activeTextures = 0
                          , viewportSize = ((0, 0), (w, h))
                          , blendMode = Nothing
                          , depthTest = True
                          , depthMask = True
                          , stencilMode = Nothing
                          , cullFace = Nothing
                          , colorMask = (True, True, True, True)
                          , programs = err
                          , elemBuffers = err
                          , attributes = err
                          , geometries = err
                          , uniforms = err
                          , textureImages = err
                          }
        where err = error "Call drawInit first"

-- | Initialize the render engine.
drawInit :: GLES => Draw GVec4 ()
drawInit = do programs <- liftIO newResMap
              elemBuffers <- liftIO newResMap
              attributes <- liftIO newResMap
              geometries <- liftIO newResMap
              uniforms <- liftIO newResMap
              textureImages <- liftIO newResMap

              ((x, y), (w, h)) <- viewportSize <$> Draw get
              gl $ do GL.clearColor 0.0 0.0 0.0 1.0
                      GL.clearDepth 1
                      GL.clearStencil 0
                      enable gl_DEPTH_TEST
                      depthFunc gl_LESS
                      viewport (fromIntegral x) (fromIntegral y)
                               (fromIntegral w) (fromIntegral h)

              Draw . modify $ \s -> s { programs = programs
                                      , elemBuffers = elemBuffers
                                      , attributes = attributes
                                      , geometries = geometries
                                      , uniforms = uniforms
                                      , textureImages = textureImages
                                      }

{-
maxTexs :: (Integral a, GLES) => a
maxTexs = fromIntegral gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS
-}

{-
-- | Run a 'Draw' action.
runDraw :: Draw GVec4 a
        -> DrawState
        -> GL (a, DrawState)
runDraw (Draw a) = runStateT a

-- | Execute a 'Draw' action.
execDraw :: Draw GVec4 a
         -> DrawState
         -> GL DrawState
execDraw (Draw a) = execStateT a
-}

-- | Evaluate a 'Draw' action.
evalDraw :: Draw GVec4 a
         -> DrawState
         -> GL a
evalDraw (Draw a) = evalStateT a

left :: Either String a -> Maybe String
left (Left x) = Just x
left _ = Nothing

-- | Manually allocate a 'Geometry' in the GPU. Eventually returns an error
-- string.
preloadGeometry :: (GLES, GeometryVertex g, ElementType e)
                => Geometry e g
                -> Draw o (Maybe String)
preloadGeometry g = left <$> getGeometry g

-- | Manually allocate a 'Texture' in the GPU.
preloadTexture :: GLES => Texture -> Draw o (Maybe String)
preloadTexture t = left <$> getTexture t

-- | Manually allocate a 'Program' in the GPU.
preloadProgram :: GLES => Program gs is -> Draw o (Maybe String)
preloadProgram p = left <$> getProgram p

-- | Manually delete a 'Geometry' from the GPU.
removeGeometry :: (GLES, GeometryVertex g, ElementType e)
               => Geometry e g
               -> Draw o ()
removeGeometry g = removeDrawResource id geometries g

-- | Manually delete a 'Texture' from the GPU.
removeTexture :: GLES => Texture -> Draw o ()
removeTexture (TextureImage i) = removeDrawResource gl textureImages i
removeTexture (TextureLoaded l) = gl $ unloadResource
                                        (Nothing :: Maybe TextureImage) l

-- | Manually delete a 'Program' from the GPU.
removeProgram :: GLES => Program gs is -> Draw o ()
removeProgram = removeDrawResource gl programs

-- | Check if a 'Geometry' failed to load.
checkGeometry :: (GLES, GeometryVertex g, ElementType e)
              => Geometry e g
              -> Draw o (ResStatus ())
checkGeometry g = fmap (const ()) <$> checkDrawResource id geometries g

-- | Check if a 'Texture' failed to load. Eventually returns the texture width
-- and height.
checkTexture :: (GLES, Num a) => Texture -> Draw o (ResStatus (a, a))
checkTexture (TextureImage i) =
        fmap loadedTextureSize <$> checkDrawResource gl textureImages i
checkTexture (TextureLoaded l) = return $ Loaded (loadedTextureSize l)

loadedTextureSize :: (GLES, Num a) => LoadedTexture -> (a, a)
loadedTextureSize (LoadedTexture w h _ _) = (fromIntegral w, fromIntegral h)

-- | Check if a 'Program' failed to load.
checkProgram :: GLES => Program gs is -> Draw o (ResStatus ())
checkProgram p = fmap (const ()) <$> checkDrawResource gl programs p

stateReset :: (DrawState -> a)
           -> (a -> Draw o ())
           -> a
           -> Draw o b
           -> Draw o b
stateReset getOld set new act = do old <- getOld <$> Draw get
                                   set new
                                   b <- act
                                   set old
                                   return b

getTextureImage :: GLES => TextureImage
                -> Draw o (Either String LoadedTexture)
getTextureImage = getDrawResource gl textureImages

getProgram :: GLES => Program gs is -> Draw o (Either String LoadedProgram)
getProgram = getDrawResource' gl programs Nothing

withProgram :: GLES => Program i o -> (LoadedProgram -> Draw x ()) -> Draw x ()
withProgram p act =
        do current <- currentProgram <$> Draw get
           when (current /= Just (programIndex p)) $
                   getProgram p >>= \elp ->
                        case elp of
                             Right lp -> do Draw . modify $ \s ->
                                             s { currentProgram = Just $
                                                     programIndex p
                                               , loadedProgram = Just lp
                                               , activeTextures = 0
                                               }
                                            act lp
                             Left err -> error err

setBlendMode :: GLES => Maybe Blend.Mode -> Draw o ()
setBlendMode Nothing = do m <- blendMode <$> Draw get
                          case m of
                               Just _ -> gl $ disable gl_BLEND
                               Nothing -> return ()
                          Draw . modify $ \s -> s { blendMode = Nothing }
setBlendMode (Just newMode) =
        do mOldMode <- blendMode <$> Draw get
           case mOldMode of
                Nothing -> do gl $ enable gl_BLEND
                              changeColor >> changeEquation >> changeFunction
                Just oldMode ->
                     do when (Blend.constantColor oldMode /= constantColor)
                                changeColor
                        when (Blend.equation oldMode /= equation)
                                changeEquation
                        when (Blend.function oldMode /= function)
                                changeFunction
           Draw . modify $ \s -> s { blendMode = Just newMode }
        where constantColor = Blend.constantColor newMode
              equation@(rgbEq, alphaEq) = Blend.equation newMode
              function@(rgbs, rgbd, alphas, alphad) = Blend.function newMode
              changeColor = case constantColor of
                                 Just (Vec4 r g b a) -> gl $ blendColor r g b a
                                 Nothing -> return ()
              changeEquation = gl $ blendEquationSeparate rgbEq alphaEq
              changeFunction = gl $ blendFuncSeparate rgbs rgbd
                                                      alphas alphad

setStencilMode :: GLES => Maybe Stencil.Mode -> Draw o ()
setStencilMode Nothing = do m <- stencilMode <$> Draw get
                            case m of
                                 Just _ -> gl $ disable gl_STENCIL_TEST
                                 Nothing -> return ()
                            Draw . modify $ \s -> s { stencilMode = Nothing }
setStencilMode (Just newMode@(Stencil.Mode newFun newOp)) =
        do mOldMode <- stencilMode <$> Draw get
           case mOldMode of
                Nothing -> do gl $ enable gl_STENCIL_TEST
                              sides newFun changeFunction
                              sides newOp changeOperation
                Just (Stencil.Mode oldFun oldOp) ->
                        do when (oldFun /= newFun) $
                                sides newFun changeFunction
                           when (oldOp /= newOp) $
                                sides newOp changeOperation
           Draw . modify $ \s -> s { stencilMode = Just newMode }
        where changeFunction face f = let (t, v, m) = Stencil.function f
                                      in gl $ stencilFuncSeparate face t v m
              changeOperation face o = let (s, d, n) = Stencil.operation o
                                       in gl $ stencilOpSeparate face s d n
              sides (Stencil.FrontBack x) f = f gl_FRONT_AND_BACK x
              sides (Stencil.Separate x y) f = f gl_FRONT x >> f gl_BACK y

setCullFace :: GLES => Maybe CullFace -> Draw o ()
setCullFace Nothing = do old <- cullFace <$> Draw get
                         case old of
                              Just _ -> gl $ disable gl_CULL_FACE
                              Nothing -> return ()
                         Draw . modify $ \s -> s { cullFace = Nothing }
setCullFace (Just newFace) =
        do old <- cullFace <$> Draw get
           when (old == Nothing) . gl $ enable gl_CULL_FACE
           case old of
                Just oldFace | oldFace == newFace -> return ()
                _ -> gl . GL.cullFace $ case newFace of
                                             CullFront -> gl_FRONT
                                             CullBack -> gl_BACK
                                             CullFrontBack -> gl_FRONT_AND_BACK
           Draw . modify $ \s -> s { cullFace = Just newFace }
                   
setDepthTest :: GLES => Bool -> Draw o ()
setDepthTest = setFlag depthTest (\x s -> s { depthTest = x })
                       (gl $ enable gl_DEPTH_TEST) (gl $ disable gl_DEPTH_TEST)
                   
setDepthMask :: GLES => Bool -> Draw o ()
setDepthMask = setFlag depthMask (\x s -> s { depthMask = x })
                       (gl $ GL.depthMask true) (gl $ GL.depthMask false)

setFlag :: (DrawState -> Bool)
        -> (Bool -> DrawState -> DrawState)
        -> Draw o ()
        -> Draw o ()
        -> Bool
        -> Draw o ()
setFlag getF setF enable disable new =
        do old <- getF <$> Draw get
           case (old, new) of
                   (False, True) -> enable
                   (True, False) -> disable
                   _ -> return ()
           Draw . modify $ setF new

setColorMask :: GLES => (Bool, Bool, Bool, Bool) -> Draw o ()
setColorMask new@(r, g, b, a) = do old <- colorMask <$> Draw get
                                   when (old /= new) . gl $
                                           GL.colorMask r' g' b' a'
                                   Draw . modify $ \s -> s { colorMask = new }
        where (r', g', b', a') = (bool r, bool g, bool b, bool a)
              bool True = true
              bool False = false

getDrawResource :: Resource i r m
                => (m (Either String r) -> Draw o (Either String r))
                -> (DrawState -> ResMap r)
                -> i
                -> Draw o (Either String r)
getDrawResource lft mg i = do
        map <- mg <$> Draw get
        lft $ getResource i map

getDrawResource' :: Resource i r m
                => (m (Either String r) -> Draw o (Either String r))
                -> (DrawState -> ResMap r)
                -> Maybe k
                -> i
                -> Draw o (Either String r)
getDrawResource' lft mg k i = do
        map <- mg <$> Draw get
        lft $ getResource' k i map

checkDrawResource :: Resource i r m
                  => (m (ResStatus r) -> Draw o (ResStatus r))
                  -> (DrawState -> ResMap r)
                  -> i
                  -> Draw o (ResStatus r)
checkDrawResource lft mg i = do
        map <- mg <$> Draw get
        lft $ checkResource i map

removeDrawResource :: (Resource i r m, Hashable i)
                   => (m () -> Draw o ())
                   -> (DrawState -> ResMap r)
                   -> i
                   -> Draw o ()
removeDrawResource lft mg i = do
        s <- mg <$> Draw get
        lft $ removeResource i s

textureCacheMaxSize :: Num a => a
textureCacheMaxSize = 16

clearBuffers :: (GLES, MonadGL m) => [Buffer] -> m ()
clearBuffers = mapM_ $ gl . GL.clear . buffer
        where buffer ColorBuffer = gl_COLOR_BUFFER_BIT
              buffer DepthBuffer = gl_DEPTH_BUFFER_BIT
              buffer StencilBuffer = gl_STENCIL_BUFFER_BIT

createOutBuffer :: forall m o. (GLES, MonadTexture m)
                => Int
                -> Int
                -> OutBufferInfo o
                -> m (OutBuffer o)
createOutBuffer w h empty = 
        do let loader t = do bindTexture gl_TEXTURE_2D t
                             if pixelType == gl_FLOAT
                             then liftIO noFloat32Array >>=
                                          texImage2DFloat gl_TEXTURE_2D 0
                                                          internalFormat w' h'
                                                          0 format pixelType
                             else liftIO noUInt8Array >>=
                                          texImage2DUInt gl_TEXTURE_2D 0
                                                         internalFormat w' h'
                                                         0 format pixelType

           textures <- replicateM (fromIntegral texNum)
                                  (newTexture w h params cacheIdentifier loader)
           return $ case empty of
                         EmptyFloatGBuffer _ -> TextureFloatGBuffer w h textures
                         EmptyByteGBuffer _ -> TextureByteGBuffer w h textures
                         EmptyDepthBuffer _ ->
                                 TextureDepthBuffer w h $ head textures
                         EmptyDepthStencilBuffer _ ->
                                 TextureDepthStencilBuffer w h $ head textures
        where (w', h') = (fromIntegral w, fromIntegral h)
              cacheIdentifier = hash ( fromIntegral internalFormat :: Int
                                     , fromIntegral format :: Int
                                     , fromIntegral pixelType :: Int
                                     , params
                                     )
              (internalFormat, format, pixelType, params, texNum) =
                      case empty of
                           EmptyByteGBuffer params ->
                                   ( fromIntegral gl_RGBA
                                   , gl_RGBA
                                   , gl_UNSIGNED_BYTE
                                   , params
                                   , textureCount (Proxy :: Proxy o)
                                   )
                           EmptyFloatGBuffer params ->
                                   ( fromIntegral gl_RGBA32F
                                   , gl_RGBA
                                   , gl_FLOAT
                                   , params
                                   , textureCount (Proxy :: Proxy o)
                                   )
                           EmptyDepthBuffer params ->
                                   ( fromIntegral gl_DEPTH_COMPONENT
                                   , gl_DEPTH_COMPONENT
                                   , gl_UNSIGNED_SHORT
                                   , params
                                   , 1
                                   )
                           EmptyDepthStencilBuffer params ->
                                   ( fromIntegral gl_DEPTH_STENCIL
                                   , gl_DEPTH_STENCIL
                                   , gl_UNSIGNED_INT_24_8
                                   , params
                                   , 1
                                   )

drawBuffers' :: (GLES, FragmentShaderOutput o)
             => Int
             -> Int
             -> Bool
             -> Either (GBuffer o) (GBufferInfo o)
             -> Either DepthBuffer DepthBufferInfo
             -> Draw o a
             -> Draw o' (a, GBuffer o, DepthBuffer)
drawBuffers' w h addUnloader gBuffer depthBuffer draw =
        do (newColor, gBuffer') <-
                case gBuffer of
                     Right b -> (,) True <$> createOutBuffer w h b
                     Left b -> return (False, b)
           (newDepth, shouldClearStencil, depthBuffer') <-
                case depthBuffer of
                     Right b@(EmptyDepthBuffer _) ->
                             (,,) True False <$> createOutBuffer w h b
                     Right b@(EmptyDepthStencilBuffer _) ->
                             (,,) True True <$> createOutBuffer w h b
                     Left b -> return (False, False, b)
           ret <- drawUsedBuffers w h gBuffer' depthBuffer' $
                   do when newColor clearColor
                      when newDepth clearDepth
                      when shouldClearStencil clearStencil
                      draw
           gl $ do when (addUnloader && newColor) $ bufferUnloader gBuffer'
                   when (addUnloader && newDepth) $ bufferUnloader depthBuffer'
           return (ret, gBuffer', depthBuffer')
        where bufferUnloader buf = 
                        mapM_ (unloader buf (Nothing :: Maybe TextureImage))
                              (textures buf)

drawUsedBuffers :: GLES
                => Int
                -> Int
                -> GBuffer o
                -> DepthBuffer
                -> Draw o a
                -> Draw o' a
drawUsedBuffers w h gBuffer depthBuffer draw =
        do oldFb <- currentFrameBuffer <$> Draw get
           ret <- drawToTextures useDrawBuffers attachments w h oldFb $ \fb -> 
                do Draw . modify $ \s -> s { currentFrameBuffer = fb }
                   castDraw draw
           Draw . modify $ \s -> s { currentFrameBuffer = oldFb }
           return ret
        where colorAttachments = zipWith (\(LoadedTexture _ _ _ t) n ->
                                                (t, gl_COLOR_ATTACHMENT0 + n)
                                         )
                                         (textures gBuffer)
                                         [0 ..]
              depthAttachment =
                      case depthBuffer of
                           TextureDepthBuffer _ _ (LoadedTexture _ _ _ t) ->
                                (t, gl_DEPTH_ATTACHMENT)
                           TextureDepthStencilBuffer _ _ (LoadedTexture _ _ _ t) ->
                                (t, gl_DEPTH_STENCIL_ATTACHMENT)
              attachments = depthAttachment : colorAttachments
              useDrawBuffers | (_ : _ : _) <- colorAttachments = True
                             | otherwise = False

drawToTextures :: (GLES, MonadScreen m, MonadGL m)
               => Bool
               -> [(GL.Texture, GLEnum)]
               -> Int
               -> Int
               -> FrameBuffer
               -> (FrameBuffer -> m a)
               -> m a
drawToTextures useDrawBuffers atts w h oldFb draw =
        do fb <- gl createFramebuffer 
           gl $ bindFramebuffer gl_FRAMEBUFFER fb

           buffersToDraw <- fmap concat . flip mapM atts $
                   \(t, attach) ->
                           do let drawAttachment =
                                   [ fromIntegral attach
                                   | attach /= gl_DEPTH_ATTACHMENT
                                   , attach /= gl_DEPTH_STENCIL_ATTACHMENT
                                   ]
                                        
                              gl $ framebufferTexture2D gl_FRAMEBUFFER attach
                                                        gl_TEXTURE_2D t 0
                              return drawAttachment

           when useDrawBuffers $
                   liftIO (encodeInts buffersToDraw) >>= gl . GL.drawBuffers

           (sp, ss) <- currentViewport
           resizeViewport (0, 0) (fromIntegral w, fromIntegral h)

           ret <- draw fb

           resizeViewport sp ss
           gl $ do deleteFramebuffer fb
                   bindFramebuffer gl_FRAMEBUFFER oldFb

           return ret

class ReadPixels r where
        readPixels :: MonadGL m => (Int, Int, Int, Int) -> GLEnum -> m r

instance GLES => ReadPixels [Color] where
        readPixels (x, y, rw, rh) format =
                        do arr <- liftIO . newUInt8Array $
                                        fromIntegral rw * fromIntegral rh * 4
                           gl $ readPixelsUInt8 (fromIntegral x)
                                                (fromIntegral y)
                                                (fromIntegral rw)
                                                (fromIntegral rh)
                                                format gl_UNSIGNED_BYTE arr
                           liftIO $ fmap wordsToColors (decodeUInt8s arr)
                where wordsToColors (r : g : b : a : xs) =
                                Color r g b a : wordsToColors xs
                      wordsToColors _ = []

instance GLES => ReadPixels [Vec4] where
        readPixels (x, y, rw, rh) format =
                        do arr <- liftIO . newFloat32Array $
                                        fromIntegral rw * fromIntegral rh * 4
                           gl $ readPixelsFloat (fromIntegral x)
                                                (fromIntegral y)
                                                (fromIntegral rw)
                                                (fromIntegral rh)
                                                format gl_FLOAT arr
                           liftIO $ fmap floatsToVecs (decodeFloat32s arr)
                where floatsToVecs (r : g : b : a : xs) =
                                Vec4 r g b a : floatsToVecs xs
                      floatsToVecs _ = []

instance GLES => ReadPixels [Word8] where
        readPixels (x, y, rw, rh) format =
                        do arr <- liftIO . newUInt8Array $
                                        fromIntegral rw * fromIntegral rh
                           gl $ readPixelsUInt8 (fromIntegral x)
                                                (fromIntegral y)
                                                (fromIntegral rw)
                                                (fromIntegral rh)
                                                format gl_UNSIGNED_BYTE arr
                           liftIO $ decodeUInt8s arr

instance GLES => ReadPixels [Word16] where
        readPixels (x, y, rw, rh) format =
                        do arr <- liftIO . newUInt16Array $
                                        fromIntegral rw * fromIntegral rh
                           gl $ readPixelsUInt16 (fromIntegral x)
                                                 (fromIntegral y)
                                                 (fromIntegral rw)
                                                 (fromIntegral rh)
                                                 format gl_UNSIGNED_SHORT arr
                           liftIO $ decodeUInt16s arr

instance GLES => ReadPixels [Float] where
        readPixels (x, y, rw, rh) format =
                        do arr <- liftIO . newFloat32Array $
                                        fromIntegral rw * fromIntegral rh
                           gl $ readPixelsFloat (fromIntegral x)
                                                (fromIntegral y)
                                                (fromIntegral rw)
                                                (fromIntegral rh)
                                                format gl_FLOAT arr
                           liftIO $ decodeFloat32s arr

castDraw :: Draw o a -> Draw o' a
castDraw (Draw x) = Draw x


-- | Get the 'DrawState'.
drawGet :: Draw o DrawState
drawGet = Draw get