it works interactively now

src/Main.hs

@@ -13,7 +13,6 @@ import qualified SDL.Raw.Enum as SDL
 import SDL (($=))
 
 import Control.Concurrent.STM
-import Control.Concurrent.STM.TMVar
 
 import Graphics.GPipe
 
@@ -21,11 +20,12 @@ import Linear
 
 import Control.Monad
 import Control.Monad.Trans
-import Control.Concurrent
 
 import Reactive.Banana.Frameworks as RBF
 import Reactive.Banana as RB
 
+import Data.Maybe (fromMaybe)
+
 -- internal imports
 
 import Types
@@ -72,7 +72,7 @@ main = do
     shader <- compileShader $ do
       primitiveStream :: PrimitiveStream Triangles (V4 VFloat, V3 VFloat) <- toPrimitiveStream id :: Shader os (PrimitiveArray Triangles AttrInput) (PrimitiveStream Triangles (VertexFormat AttrInput))
       uniform <- getUniform (const (uniformBuffer,0))
-      let primitiveStream2 = fmap (\(pos,clr) -> (pos - V4 1 1 0 0, clr / 10)) primitiveStream  
+      let primitiveStream2 = fmap (\(pos, clr) -> (pos - V4 1 1 0 0, clr / 10)) primitiveStream
           primitiveStream3 = primitiveStream `mappend` primitiveStream2 
           rotationMatrix a = V4 (V4 (cos a) (-sin a) 0 0)   
                                 (V4 (sin a) (cos a) 0 0)  
@@ -98,11 +98,12 @@ main = do
 
     -- SDL.showWindow window
     listen@(_, fire) <- liftIO $ newAddHandler
-    uniformBufferVar <- liftIO $ newTMVarIO uniformBuffer :: ContextT FRPBallCtx os IO (TMVar (Buffer os (Uniform (B Float))))
+    uniVar <- liftIO $ newTMVarIO 0 :: ContextT FRPBallCtx os IO (TMVar Float)
     let writeUniform = writeBuffer uniformBuffer 0 :: [Float] -> ContextT FRPBallCtx os IO ()
-    writeUniform [0]
-    network <- liftIO $ compile (networkDescription listen writeUniform)
+    network <- liftIO $ compile (networkDescription listen uniVar)
     forever $ do
+      mrot <- liftIO $ atomically $ tryReadTMVar uniVar
+      writeUniform [fromMaybe 0 mrot]
       liftIO $ actuate network
       render $ do
         clearWindowColor win (V3 0 0 0)
@@ -119,12 +120,15 @@ main = do
 --   => (AddHandler [SDL.Event], x)
 --   -> TMVar (Buffer os (Uniform (B Float)))
 --   -> MomentIO ()
-networkDescription (listenerah, listenerfire) uniformWrite = mdo
+networkDescription (listenerah, listenerfire) univar = mdo
   (mouseah, mousefire)      <- liftIO $ newAddHandler
   blistener <- fromChanges [] =<< registerListenerEvent listenerah mousefire
   eventChanged <- changes blistener
-  emouse <- fromAddHandler =<< registerMouseEvent uniformWrite mouseah
-  let reaction = fmap print emouse
+  emouse <- fromAddHandler =<< registerMouseEvent univar mouseah
+  let reaction = fmap (\x -> do
+        let input = (\(V2 x _) -> fromIntegral x :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head x
+        void $ atomically $ swapTMVar univar input
+        print x) emouse
   let -- eventChangedReaction :: RB.Event (Future (IO ()))
       eventChangedReaction = fmap
         (\(x :: Future [SDL.Event]) ->
@@ -142,12 +146,11 @@ registerListenerEvent
 registerListenerEvent listenerah mousefire = do
   _ <- liftIO $ do
     register listenerah $ \evs -> do
-      if null evs then return () else mousefire
-        (filter (\ev -> case SDL.eventPayload ev of
-          SDL.MouseMotionEvent _ -> True
-          _                  -> False
-          ) evs
-          )
+      let fevs = filter (\ev -> case SDL.eventPayload ev of
+            SDL.MouseMotionEvent _ -> True
+            _                  -> False
+            ) evs
+      if null fevs then return () else mousefire fevs
   return listenerah
 
 -- registerMouseEvent
@@ -155,11 +158,10 @@ registerListenerEvent listenerah mousefire = do
 --   => Buffer os (Uniform (B Float))
 --   -> AddHandler [SDL.Event]
 --   -> m (AddHandler [SDL.Event])
-registerMouseEvent uniformWrite mouseah = do
+registerMouseEvent univar mouseah = do
   _ <- liftIO $ register mouseah ((\evs -> do
-      let input = [(\(V2 x y) -> fromIntegral x :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head evs]
-      return $ (uniformWrite input)
-      return ()
+      let input = (\(V2 x y) -> fromIntegral x :: Float) $ SDL.mouseMotionEventRelMotion $ (\(SDL.MouseMotionEvent dat) -> dat) $ SDL.eventPayload $ head evs
+      void $ atomically $ swapTMVar univar input
       ) :: [SDL.Event] -> IO ()
       )
   return mouseah