etc

minipat-midi/src/Minipat/Midi/Impl.hs

@@ -13,7 +13,7 @@ where
 
 import Control.Concurrent.Async (Async)
 import Control.Concurrent.STM (atomically)
-import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVarIO, writeTVar)
+import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVar, readTVarIO, writeTVar)
 import Control.Exception (throwIO)
 import Control.Monad.IO.Class (liftIO)
 import Dahdit.Midi.Midi (LiveMsg (..))
@@ -22,6 +22,7 @@ import Data.Default (Default (..))
 import Data.Foldable (foldl', for_, toList)
 import Data.Heap (Heap)
 import Data.Heap qualified as H
+import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe)
 import Data.Sequence (Seq (..))
 import Data.Sequence qualified as Seq
@@ -127,10 +128,31 @@ instance Backend MidiBackend where
     atomically (writeTVar (mdHeap md) H.empty)
 
   backendCheck _ logger cb = runCallback cb $ \md -> do
+    -- Show task info
+    connOk <- logAsyncState logger "conn" (mdConnTask md)
+    sendOk <- logAsyncState logger "send" (mdSendTask md)
+    -- Show ports
+    let ms = M.meState (mdEnv md)
+    (mayDefOut, outPorts) <- atomically $ do
+      mayDefOut <- fmap (fmap M.unPortName) (readTVar (M.msOutDefault ms))
+      outMap <- readTVar (M.msOutMap ms)
+      let outPorts = fmap M.unPortName (toList (Map.keys outMap))
+      pure (mayDefOut, outPorts)
+    let outOk = not (null outPorts)
+    if outOk
+      then do
+        logInfo logger "Out ports:"
+        for_ outPorts $ \op ->
+          logInfo logger $
+            if mayDefOut == Just op
+              then op <> " (default)"
+              else op
+      else logInfo logger "No out ports"
+    -- Show queue info
     h <- readTVarIO (mdHeap md)
     logInfo logger ("Queue length: " <> T.pack (show (H.size h)))
     case H.uncons h of
       Just (M.TimedMsg t (M.SortedMsg m), _) ->
         logInfo logger ("Queue head: " <> T.pack (show t) <> " " <> T.pack (show m))
       Nothing -> pure ()
-    logAsyncState logger "send" (mdSendTask md)
+    pure (connOk && sendOk && outOk)

minipat-midi/src/Minipat/Midi/Midi.hs

@@ -15,8 +15,6 @@ import Data.Bifunctor (first)
 import Data.Coerce (coerce)
 import Data.Default (Default (..))
 import Data.Foldable (for_)
-import Data.Heap (Heap)
-import Data.Heap qualified as Heap
 import Data.List (find)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
@@ -169,26 +167,21 @@ instance Default AutoConn where
 data OutState = OutState
   { osPort :: !OutPort
   , osHandle :: !(UniquePtr LMF.OutHandle)
-  , osHeap :: !(TVar (Heap TimedMsg))
   }
   deriving stock (Eq)
 
 newOutState :: OutPort -> OutHandle -> IO OutState
-newOutState op oh = OutState op <$> newUniquePtr oh <*> newTVarIO Heap.empty
+newOutState op oh = OutState op <$> newUniquePtr oh
 
 freeOutState :: OutState -> IO ()
-freeOutState (OutState port handUniq heapVar) = do
-  atomically (writeTVar heapVar Heap.empty)
+freeOutState (OutState port handUniq) = do
   consumeUniquePtr handUniq >>= freeOutHandle
   freeOutPort port
 
 withOutHandle :: OutState -> (OutHandle -> ErrM ()) -> ErrM ()
-withOutHandle (OutState _ handUniq heapVar) f = do
-  lock <- liftIO $ atomically $ do
-    waiting <- fmap (not . Heap.null) (readTVar heapVar)
-    alive <- aliveUniquePtr handUniq
-    pure (waiting && alive)
-  when lock (unRunErrM (withUniquePtr' handUniq (runErrM . f)))
+withOutHandle (OutState _ handUniq) f = do
+  alive <- liftIO (atomically (aliveUniquePtr handUniq))
+  when alive (unRunErrM (withUniquePtr' handUniq (runErrM . f)))
 
 data MidiErr
   = MidiErrMissingOutPort !PortSel
@@ -355,7 +348,9 @@ sendLiveMsg buf oh lm = unRunErrM $ do
 
 sendPortMsg' :: VSM.IOVector Word8 -> AutoConn -> PortMsg -> MidiM ()
 sendPortMsg' buf ac (PortMsg ps lm) =
-  withOutPort ps ac (\os -> withOutHandle os (\oh -> sendLiveMsg buf oh lm))
+  withOutPort ps ac $ \os ->
+    withOutHandle os $ \oh ->
+      sendLiveMsg buf oh lm
 
 sendPortMsgs :: (Foldable f) => Int -> Maybe TimeDelta -> AutoConn -> f PortMsg -> MidiM ()
 sendPortMsgs maxLen mayDelay ac msgs = do

minipat-midi/src/Minipat/Midi/Setup.hs

@@ -68,6 +68,16 @@ scBackend =
 withSc :: Seq LiveMsg -> IO ()
 withSc = connectAndSendMsgs scBackend
 
+busBackend :: MidiBackend
+busBackend =
+  def
+    { mbDefOut = Just "Bus"
+    , mbDelay = Just (timeDeltaFromFracSecs @Double 0.05)
+    }
+
+withBus :: Seq LiveMsg -> IO ()
+withBus = connectAndSendMsgs busBackend
+
 -- Send mpk config
 sendMpkCfgs :: IO ()
 sendMpkCfgs = withMpk (Seq.fromList [sendProgConfig (ProgBank i) (mkMpkCfg i) | i <- [0 .. 7]])