etc

minipat-dirt/minipat-dirt.cabal

@@ -24,7 +24,6 @@ source-repository head
 
 library
   exposed-modules:
-      Minipat.Dirt.Loop
       Minipat.Dirt.Osc
       Minipat.Dirt.Prelude
       Minipat.Dirt.Ref

minipat-dirt/src/Minipat/Dirt/Prelude.hs

@@ -4,6 +4,7 @@ module Minipat.Dirt.Prelude where
 
 import Control.Concurrent (forkFinally)
 import Control.Concurrent.Async (async, cancel, waitCatch)
+import Control.Concurrent.STM.TVar (newTVarIO)
 import Control.Exception (SomeException, bracket, throwIO)
 import Control.Monad.IO.Class (liftIO)
 import Dahdit.Midi.Osc (Datum (..), Packet)
@@ -13,7 +14,6 @@ import Data.IORef (IORef, newIORef)
 import Data.Map.Strict qualified as Map
 import Data.Ratio ((%))
 import Minipat.Base qualified as B
-import Minipat.Dirt.Loop (loopAsync)
 import Minipat.Dirt.Osc qualified as O
 import Minipat.Dirt.Ref (Ref, ReleaseVar)
 import Minipat.Dirt.Ref qualified as R
@@ -146,9 +146,9 @@ testPlay = do
 
 testLoop :: IO ()
 testLoop = do
-  tdv <- newIORef (timeDeltaFromFracSecs 0.5)
+  tdv <- newTVarIO (timeDeltaFromFracSecs 0.5)
   withSt $ \st -> do
-    _ <- loopAsync (stRel st) tdv $ do
+    _ <- R.refLoop (stRel st) tdv $ do
       putStrLn "hello"
       pure Nothing
     threadDelayDelta (timeDeltaFromFracSecs 2)

minipat-dirt/src/Minipat/Dirt/Ref.hs

@@ -7,9 +7,11 @@ module Minipat.Dirt.Ref
   , refEmpty
   , refCreate
   , refCreate'
-  , refAsync
   , refReplace
   , refUse
+  , refAsync
+  , NonPosTimeDeltaErr (..)
+  , refLoop
   , RefM
   , refRead
   , refMayRead
@@ -19,13 +21,14 @@ where
 
 import Control.Concurrent.Async (Async, async, cancel)
 import Control.Concurrent.STM (STM, atomically, retry)
-import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar)
-import Control.Exception (bracket, bracket_, mask)
-import Control.Monad (ap, void)
+import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar, readTVarIO)
+import Control.Exception (Exception, bracket, bracket_, mask, throwIO)
+import Control.Monad (ap, unless, void)
 import Control.Monad.Trans.Resource (createInternalState)
 import Control.Monad.Trans.Resource.Internal (ReleaseMap, registerType, stateCleanup)
 import Data.Acquire.Internal (Acquire (..), Allocated (..), ReleaseType (..), mkAcquire)
 import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
+import Nanotime (MonoTime (..), TimeDelta (..), awaitDelta, currentTime)
 
 type ReleaseVar = IORef ReleaseMap
 
@@ -60,9 +63,6 @@ refCreate rv (Acquire f) = mask $ \restore -> do
 refCreate' :: ReleaseVar -> IO a -> (a -> IO ()) -> IO (Ref a)
 refCreate' rv acq rel = refCreate rv (mkAcquire acq rel)
 
-refAsync :: ReleaseVar -> IO a -> IO (Ref (Async a))
-refAsync rv act = refCreate' rv (async act) cancel
-
 -- | Release the ref, returning True if this was the releaser.
 -- False if early return due to other thread releasing.
 refCleanup :: Ref a -> IO Bool
@@ -133,6 +133,35 @@ refUse (Ref var) f = bracket bacq brel use
       Just (XOpen (Allocated a _)) -> Just a
       _ -> Nothing
 
+refAsync :: ReleaseVar -> IO a -> IO (Ref (Async a))
+refAsync rv act = refCreate' rv (async act) cancel
+
+data NonPosTimeDeltaErr = NonPosTimeDeltaErr
+  deriving stock (Eq, Ord, Show)
+
+instance Exception NonPosTimeDeltaErr
+
+awaitTime :: TimeDelta -> IORef MonoTime -> IO ()
+awaitTime td tv = do
+  lastTime <- readIORef tv
+  if lastTime == MonoTime 0
+    then do
+      curTime <- currentTime
+      writeIORef tv curTime
+    else do
+      nextTime <- awaitDelta lastTime td
+      writeIORef tv nextTime
+
+refLoop :: ReleaseVar -> TVar TimeDelta -> IO (Maybe a) -> IO (Ref (Async a))
+refLoop rv tdv act = do
+  tv <- newIORef (MonoTime 0)
+  let act' = do
+        td@(TimeDelta x) <- readTVarIO tdv
+        unless (x > 0) (throwIO NonPosTimeDeltaErr)
+        awaitTime td tv
+        act >>= maybe act' pure
+  refAsync rv act'
+
 newtype RefM a = RefM {unRefM :: forall b. (Maybe a -> STM () -> STM (b, STM ())) -> STM (b, STM ())}
   deriving stock (Functor)