GPURing.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

module GPURing where

import Control.Monad.Writer
import Data.Data
import Data.Dependent.Sum
import Data.Function
import Data.Typeable

import AttributeData
import RingBuffer
import MaskableStream

import LambdaCube.GL      as LC hiding (updateBuffer)
import LambdaCube.GL.Data hiding (updateBuffer) -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
import LambdaCube.GL.Mesh as LC
import LambdaCube.GL.Type
import LambdaCube.IR      as LC
import LambdaCube.GL.Util
import LambdaCube.GL.Input.Type
import LambdaCube.GL.Input hiding (createObjectCommands)


type Update keys = (keys -> Writer [DSum AttributeKey GLUniformValue] ())

new :: Data keys => Primitive -> String -> GLStorage -> (String -> String) -> Int -> IO (TargetBuffer (Update keys))
new prim streamName storage toAttr sz = fix $ \retProxy -> do
    let paramProxy = paramProxy' retProxy
            where paramProxy' :: io (targetbuffer (keys -> writer)) -> Proxy keys
                  paramProxy' _ = Proxy
    let ps = fieldParameters paramProxy toAttr
    putStrLn $ "Ring params: " ++ show ps
    gd0 <- uploadDynamicBuffer sz ps
    let gd = gd0 { dPrimitive = prim }
    Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr)
    obj <- addToObjectArray storage streamName [] gd
    -- readIORef (objCommands obj) >>= mapM_ print
    return TargetBuffer
        { syncBuffer   = \mask -> do updateCommands storage obj mask
                                     return ()
        , updateBuffer = \i u -> do updateAttributes i $ u keys
                                    return ()
        }