it draws!

frpball.cabal

@@ -22,8 +22,8 @@ executable frpball
   -- other-extensions:
   build-depends:       base ^>=4.12.0.0
                      , reactive-banana
-                     , sdl2
+                     , sdl2 ^>=2.5.0.0
-                     , GPipe
+                     , GPipe ^>=2.2.4
                      , linear
                      , gl
                      , text

src/Main.hs

@@ -39,16 +39,23 @@ main = do
   -- context <- SDL.glCreateContext window
   listen@(_, fire) <- newAddHandler
   network <- compile (networkDescription listen)
-  runContextT FRPBallCtxConfig $ do
+  runContextT (FRPBallCtxConfig "frpball"
+    SDL.defaultWindow
+      { SDL.windowInitialSize = V2 800 600
+      , SDL.windowResizable  = True
+      , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+          { SDL.glProfile = SDL.Core SDL.Normal 3 3
+        }
+      }) $ do
     win <- newWindow (WindowFormatColor RGB8) ("frpball", SDL.defaultWindow
       { SDL.windowInitialSize = V2 800 600
       , SDL.windowResizable  = True
-      , SDL.windowOpenGL      = Just SDL.defaultOpenGL
+      , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
           { SDL.glProfile = SDL.Core SDL.Normal 3 3
         }
       }
       )
-    vertexBuffer :: Buffer os (B4 Float, B3 Float) <- newBuffer 3
+    vertexBuffer :: Buffer os AttrInput <- newBuffer 3
     writeBuffer
       vertexBuffer
       0
@@ -57,7 +64,7 @@ main = do
       , (V4 1 1 0 1,  V3 0 0 1)
       ]
     shader <- compileShader $ do
-      primitiveStream <- toPrimitiveStream id
+      primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput))
       fragmentStream <- rasterize
         (const
           ( FrontAndBack
@@ -73,13 +80,19 @@ main = do
           )
           )
         fragmentStream
+
     -- SDL.showWindow window
-    liftIO $ do
+    liftIO $ actuate network
-      actuate network
     forever $ do
+      render $ do
+        clearWindowColor win (V3 0 0 0)
+        vertexArray <- newVertexArray vertexBuffer
+        let primitiveArray = toPrimitiveArray TriangleList vertexArray
+        shader primitiveArray
+      swapWindowBuffers win
+      liftIO $ do
         evs <- SDL.pollEvents
         fire evs
-      threadDelay $ 23 * 10 ^ 6
 
 networkDescription
   :: (AddHandler [SDL.Event], b)

src/Types.hs

@@ -29,7 +29,7 @@ data MouseEvent = MouseEvent
 
 data FRPBallCtx = FRPBallCtx
   { frpContexts :: TVar [SDL.GLContext]
-  , frpWindow   :: Maybe SDL.Window
+  , frpWindow   :: TVar [SDL.Window]
   , frpThread   :: SDL.ThreadID
   }
 
@@ -40,13 +40,13 @@ type Window = SDL.Window
 type WindowConfig = SDL.WindowConfig
 
 instance ContextHandler FRPBallCtx where
-  data ContextHandlerParameters FRPBallCtx = FRPBallCtxConfig
+  data ContextHandlerParameters FRPBallCtx = FRPBallCtxConfig T.Text SDL.WindowConfig
   type ContextWindow FRPBallCtx            = SDL.Window
   type WindowParameters FRPBallCtx         = (T.Text, SDL.WindowConfig)
 
-  contextHandlerCreate bla = do
+  contextHandlerCreate (FRPBallCtxConfig ititle iwinconfig) = do
     tid <- SDL.threadID
-    win <- return Nothing
+    win <- newTVarIO [] -- SDL.createWindow ititle iwinconfig
     ctx <- newTVarIO []
     return $ FRPBallCtx ctx win tid
 
@@ -55,15 +55,16 @@ instance ContextHandler FRPBallCtx where
 
   createContext frpctx (Just (bits, config)) = do
     win <- SDL.createWindow (fst config) (snd config)
-    ctx <- SDL.glCreateContext (fromJust $ frpWindow frpctx)
+    atomically $ modifyTVar (frpWindow frpctx) (win :)
+    ctx <- SDL.glCreateContext win
     atomically $ modifyTVar (frpContexts frpctx) (ctx :)
     SDL.showWindow win
     return win
 
   createContext frpctx Nothing = do
-    ctx <- SDL.glCreateContext (fromJust $ frpWindow frpctx)
+    ctx <- SDL.glCreateContext =<< (head <$> readTVarIO (frpWindow frpctx))
     atomically $ modifyTVar (frpContexts frpctx) (ctx :)
-    return $ fromJust $ frpWindow frpctx
+    head <$> readTVarIO (frpWindow frpctx)
 
   contextDoAsync ctx mwin act =
     liftIO act
@@ -81,5 +82,9 @@ instance ContextHandler FRPBallCtx where
     glFinish
     ctxs <- readTVarIO $ frpContexts frpctx
     forM_ ctxs $ \mmContext -> do
-      GPipe.contextDelete frpctx (fromJust $ frpWindow frpctx)
+      GPipe.contextDelete frpctx =<< (head <$> readTVarIO (frpWindow frpctx))
       SDL.glDeleteContext mmContext
+
+type AttrInput = (B4 Float, B3 Float)
+
+type RIStream = (Float, AttrInput)