diff --git a/minipat-midi/src/Minipat/Midi/Impl.hs b/minipat-midi/src/Minipat/Midi/Impl.hs index 234fc43..1775ba9 100644 --- a/minipat-midi/src/Minipat/Midi/Impl.hs +++ b/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) diff --git a/minipat-midi/src/Minipat/Midi/Midi.hs b/minipat-midi/src/Minipat/Midi/Midi.hs index c6486fd..3c57ce6 100644 --- a/minipat-midi/src/Minipat/Midi/Midi.hs +++ b/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 diff --git a/minipat-midi/src/Minipat/Midi/Setup.hs b/minipat-midi/src/Minipat/Midi/Setup.hs index 8920a79..121ab04 100644 --- a/minipat-midi/src/Minipat/Midi/Setup.hs +++ b/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]])