module Graphics.HaGL.Backend (
    RunObj(..),
    genRunObj,
    makeOff
) where

import Prelude hiding (id)
import Control.Monad (unless)
import Foreign.Marshal.Array (withArray)
import Foreign.Ptr (Ptr, wordPtrToPtr)
import Graphics.Rendering.OpenGL hiding (PrimitiveMode)

import qualified Data.Set as Set

import Graphics.HaGL.GLType
import Graphics.HaGL.GLExpr
import Graphics.HaGL.ExprID
import Graphics.HaGL.GLObj
import Graphics.HaGL.Eval
import Graphics.HaGL.CodeGen (GLProgram(GLProgram), InpVar(..), UniformVar(..), genProgram)


-- RunObj = GLProgram transformed to low-level OpenGL data

data RunObj = RunObj {
    RunObj -> PrimitiveMode
primitiveMode :: PrimitiveMode,
    RunObj -> Maybe [ConstExpr UInt]
indices :: Maybe [ConstExpr UInt],
    RunObj -> Set UniformVar
uniformVars :: Set.Set UniformVar,
    RunObj -> Int
numVerts :: Int,
    RunObj -> VertexArrayObject
vao :: VertexArrayObject,
    RunObj -> Program
prog :: Program
}

genRunObj :: GLObj -> IO RunObj
genRunObj :: GLObj -> IO RunObj
genRunObj = GLProgram -> IO RunObj
progToRunObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLObj -> GLProgram
genProgram

progToRunObj :: GLProgram -> IO RunObj
progToRunObj :: GLProgram -> IO RunObj
progToRunObj (GLProgram PrimitiveMode
primitiveMode Maybe [ConstExpr UInt]
indices 
  Set UniformVar
uniformVars Set InpVar
inputVars Int
numElts Shader
vertexShader Shader
fragmentShader) = do

    Shader
vs <- ShaderType -> String -> IO Shader
loadShader ShaderType
VertexShader forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Shader
vertexShader
    Shader
fs <- ShaderType -> String -> IO Shader
loadShader ShaderType
FragmentShader forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Shader
fragmentShader
    Program
prog <- IO Program
createProgram
    Program -> Shader -> IO ()
attachShader Program
prog Shader
vs
    Program -> Shader -> IO ()
attachShader Program
prog Shader
fs
    Program -> IO ()
linkProgram Program
prog

    VertexArrayObject
vao <- forall a (m :: * -> *). (GeneratableObjectName a, MonadIO m) => m a
genObjectName
    StateVar (Maybe VertexArrayObject)
bindVertexArrayObject forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just VertexArrayObject
vao

    -- TODO: it is more efficient to form a
    -- single buffer from all the input data
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Program -> InpVar -> IO ()
bindAttrDat Program
prog) Set InpVar
inputVars

    Maybe [ConstExpr UInt] -> IO ()
bindIndices Maybe [ConstExpr UInt]
indices

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimitiveMode
-> Maybe [ConstExpr UInt]
-> Set UniformVar
-> Int
-> VertexArrayObject
-> Program
-> RunObj
RunObj PrimitiveMode
primitiveMode Maybe [ConstExpr UInt]
indices
        Set UniformVar
uniformVars Int
numElts VertexArrayObject
vao Program
prog

loadShader :: ShaderType -> String -> IO Shader
loadShader :: ShaderType -> String -> IO Shader
loadShader ShaderType
stype String
src = do
    Shader
shader <- ShaderType -> IO Shader
createShader ShaderType
stype
    Shader -> StateVar ByteString
shaderSourceBS Shader
shader forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= String -> ByteString
packUtf8 String
src
    Shader -> IO ()
compileShader Shader
shader
    Bool
ok <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Shader -> GettableStateVar Bool
compileStatus Shader
shader)
    String
infoLog <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Shader -> GettableStateVar String
shaderInfoLog Shader
shader)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
infoLog Bool -> Bool -> Bool
|| String
infoLog forall a. Eq a => a -> a -> Bool
== String
"\NUL")
        (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String
"Shader info log:", String
infoLog, String
""])
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok forall a b. (a -> b) -> a -> b
$ do
        forall a (m :: * -> *). (ObjectName a, MonadIO m) => a -> m ()
deleteObjectName Shader
shader
        forall a. IOError -> IO a
ioError (String -> IOError
userError String
"shader compilation failed")
    forall (m :: * -> *) a. Monad m => a -> m a
return Shader
shader

bindAttrDat :: Program -> InpVar -> IO ()
bindAttrDat :: Program -> InpVar -> IO ()
bindAttrDat Program
prog (InpVar ExprID
id [GLExpr 'ConstDomain t]
xs) = do
    BufferObject
arrayBuffer <- forall a (m :: * -> *). (GeneratableObjectName a, MonadIO m) => m a
genObjectName
    BufferTarget -> StateVar (Maybe BufferObject)
bindBuffer BufferTarget
ArrayBuffer forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just BufferObject
arrayBuffer
    let val :: [t]
val = forall a b. (a -> b) -> [a] -> [b]
map forall t. GLExpr 'ConstDomain t -> t
constEval [GLExpr 'ConstDomain t]
xs
    let size :: GLsizeiptr
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall t. GLType t => [t] -> Int
eltSize [t]
val forall a. Num a => a -> a -> a
* forall t. GLType t => [t] -> Int
numComponents [t]
val forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
val
    forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray (forall t. GLInputType t => [t] -> [StoreElt t]
toStorableList [t]
val) forall a b. (a -> b) -> a -> b
$ \Ptr (StoreElt t)
ptr ->
        forall a. BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData BufferTarget
ArrayBuffer forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (GLsizeiptr
size, Ptr (StoreElt t)
ptr, BufferUsage
StaticDraw) 

    AttribLocation
attr <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> StateVar AttribLocation
attribLocation Program
prog forall a b. (a -> b) -> a -> b
$ ExprID -> String
idLabel ExprID
id)
    let numComps :: NumComponents
numComps = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall t. GLType t => [t] -> Int
numComponents [t]
val
    let intHandling :: IntegerHandling
intHandling = case forall t. GLType t => [t] -> DataType
getGlslType [t]
val of
            DataType
Int -> IntegerHandling
KeepIntegral 
            DataType
UnsignedInt -> IntegerHandling
KeepIntegral 
            DataType
Byte -> IntegerHandling
KeepIntegral 
            DataType
_ -> IntegerHandling
ToFloat
    forall a.
AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor a)
vertexAttribPointer AttribLocation
attr forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$=
        (IntegerHandling
intHandling, forall a.
NumComponents
-> DataType -> NumComponents -> Ptr a -> VertexArrayDescriptor a
VertexArrayDescriptor NumComponents
numComps (forall t. GLType t => [t] -> DataType
getGlslType [t]
val) NumComponents
0 (forall a. Int -> Ptr a
makeOff Int
0))
    AttribLocation -> StateVar Capability
vertexAttribArray AttribLocation
attr forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled

bindIndices :: Maybe [ConstExpr UInt] -> IO ()
bindIndices :: Maybe [ConstExpr UInt] -> IO ()
bindIndices (Just [ConstExpr UInt]
inds) = do
    BufferObject
elementArrayBuffer <- forall a (m :: * -> *). (GeneratableObjectName a, MonadIO m) => m a
genObjectName
    BufferTarget -> StateVar (Maybe BufferObject)
bindBuffer BufferTarget
ElementArrayBuffer forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just BufferObject
elementArrayBuffer
    let indSize :: GLsizeiptr
indSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
4 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstExpr UInt]
inds
    forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray (forall a b. (a -> b) -> [a] -> [b]
map forall t. GLExpr 'ConstDomain t -> t
constEval [ConstExpr UInt]
inds) forall a b. (a -> b) -> a -> b
$ \Ptr UInt
ptr ->
        forall a. BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData BufferTarget
ElementArrayBuffer forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (GLsizeiptr
indSize, Ptr UInt
ptr, BufferUsage
StaticDraw)
bindIndices Maybe [ConstExpr UInt]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

makeOff :: Int -> Ptr a
makeOff :: forall a. Int -> Ptr a
makeOff = forall a. WordPtr -> Ptr a
wordPtrToPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral