ref: 4161ae98a0bd95edcd9a8f48c5daf019dd7164bb misc/reflex-gl-demo/src/VertexArray.hs -rw-r--r-- 2.1 KiB View raw
                                                                                
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
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module VertexArray
  ( VertexArrayConfig
  , VertexArrayUpdates
  , SomeBuffer(..)
  , vertexArray
  ) where

import           Control.Monad.IO.Class (MonadIO(..))
import           Data.Functor ((<&>), void)
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Map.Misc (diffMap)
import           Data.StateVar (($=))
import           Data.Typeable
import           Graphics.Glow (AttributeLocation)
import qualified Graphics.Glow as Glow
import           Reflex

data SomeBuffer where
  SomeBuffer :: (Eq a, Typeable a) => Glow.Buffer a -> SomeBuffer

instance Eq SomeBuffer where
  (SomeBuffer (a :: Glow.Buffer a)) == (SomeBuffer (b :: Glow.Buffer b))
    = maybe False (\Refl -> a == b) $ eqT @a @b

type VertexArrayConfig = Map AttributeLocation (Maybe SomeBuffer, Glow.Layout)
type VertexArrayUpdates = Map AttributeLocation
  (Maybe (Maybe SomeBuffer, Glow.Layout))

vertexArray
  :: (MonadIO m, MonadIO (Performable m), MonadSample t m, PerformEvent t m)
  => Dynamic t VertexArrayConfig
  -> m Glow.VertexArray
vertexArray dConfig = do
  let eDiffs = uncurry diffMap <$> attach (current dConfig) (updated dConfig)
  vao <- Glow.gen

  -- Set up the VAO
  initialState <- sample $ current dConfig
  liftIO . Glow.withVertexArray vao . applyUpdates $ Just <$> initialState

  -- Update the VAO
  performEvent_ $ eDiffs <&> \diff -> liftIO $
    Glow.withVertexArray vao $ applyUpdates diff

  pure vao

applyUpdates :: VertexArrayUpdates -> IO ()
applyUpdates updates = void . flip Map.traverseWithKey updates $ \loc mCfg ->
  case mCfg of
    Nothing -> Glow.setVertexAttribute loc $= Nothing
    Just (mBuf, layout) ->
      let
        -- If we're reading from the buffer, bind it first
        bindBufferFunc = case mBuf of
          Nothing -> id
          Just (SomeBuffer buf) ->
            Glow.withBoundBufferAt Glow.ArrayBufferTarget buf
      in
        bindBufferFunc $ Glow.setVertexAttribute loc $= Just layout