etc

minipat-live/src/Minipat/Live/Resources.hs

@@ -6,6 +6,7 @@ module Minipat.Live.Resources
   , relVarUse
   , relVarAcquire
   , withRelVar
+  , acquirePure
   , acquireAsync
   , acquireLoop
   , QueueHead
@@ -23,6 +24,7 @@ import Control.Concurrent.STM (STM, atomically, retry)
 import Control.Concurrent.STM.TQueue (TQueue, peekTQueue, readTQueue, tryPeekTQueue)
 import Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar)
 import Control.Exception (SomeException, bracket, mask, onException)
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Resource (InternalState, closeInternalState, createInternalState)
 import Control.Monad.Trans.Resource.Internal (registerType)
 import Data.Acquire.Internal (Acquire (..), Allocated (..), mkAcquire)
@@ -52,6 +54,9 @@ relVarAcquire rv (Acquire f) = mask $ \restore -> do
 withRelVar :: (RelVar -> IO a) -> IO a
 withRelVar = bracket relVarInit relVarDispose
 
+acquirePure :: a -> Acquire (Async a)
+acquirePure = liftIO . async . pure
+
 acquireAsync :: IO a -> Acquire (Async a)
 acquireAsync act = mkAcquire (async act) cancel
 

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

@@ -3,13 +3,13 @@
 -- | Converts attrs to MIDI events
 module Minipat.Midi.Convert where
 
-import Data.Default (def)
 import Dahdit.Midi.Midi (ChanData (..), ChanVoiceData (..))
 import Dahdit.Midi.Osc (Datum (..))
+import Data.Default (def)
 import Data.Functor ((<&>))
 import Data.Int (Int32)
 import Minipat.Live.Attrs (Attrs, IsAttrs (..), attrsSingleton)
-import Minipat.Live.Convert (Branch (..), ConvErr, ConvM, branchM, defaultM, runConvM, lookupM)
+import Minipat.Live.Convert (Branch (..), ConvErr, ConvM, branchM, defaultM, lookupM, runConvM)
 import Minipat.Live.Datum (DatumProxy (..))
 import Minipat.Midi.Midi (PortData (..), psFromText)
 

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

@@ -38,3 +38,8 @@ throwErrM = tell . countErr
 
 runCountM :: CountM e r a -> r -> IO (a, ErrCounts e)
 runCountM (CountM m) r = runWriterT (runReaderT m r)
+
+execCountM :: (Show e, Typeable e) => CountM e r () -> r -> IO ()
+execCountM cm r = do
+  (_, c) <- runCountM cm r
+  rethrowCounts c

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

@@ -5,108 +5,118 @@ module Minipat.Midi.Impl
   ( MidiBackend (..)
   , MidiSt
   , sendMsgs
-  , sendLiveMsgs
   , connectAndSendMsgs
   )
 where
 
 import Control.Concurrent.Async (Async)
 import Control.Concurrent.STM (atomically)
 import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVarIO, writeTVar)
-import Control.Exception (finally, throwIO)
+import Control.Exception (throwIO)
 import Control.Monad.IO.Class (liftIO)
-import Dahdit.Iface (mutEncode)
-import Dahdit.Midi.Midi (ChanData (..), ChanVoiceData (..), Channel, LiveMsg (..))
-import Data.Acquire (mkAcquire)
+import Dahdit.Midi.Midi (LiveMsg (..))
+import Data.Acquire (withAcquire)
 import Data.Default (Default (..))
-import Data.Foldable (foldl', for_)
+import Data.Foldable (foldl', for_, toList)
 import Data.Heap (Heap)
 import Data.Heap qualified as H
 import Data.Maybe (fromMaybe)
 import Data.Sequence (Seq (..))
 import Data.Sequence qualified as Seq
+import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Vector.Storable.Mutable qualified as VSM
+import Libremidi.Api (Api (..))
 import Minipat.Live.Backend (Backend (..), Callback (..), PlayMeta (..), WithPlayMeta (..))
 import Minipat.Live.Core (St, logAsyncState, stBackend, useCallback)
-import Minipat.Live.Logger (logInfo)
-import Minipat.Live.Resources (acquireAwait, qhHeap)
+import Minipat.Live.Logger (logInfo, newLogger)
+import Minipat.Live.Resources (acquireAsync, acquireAwait, acquirePure, qhHeap)
 import Minipat.Midi.Convert (convertMidiAttrs)
-import Minipat.Midi.Midi (MidiState (..), SortedMsg (..), TimedMsg (..), PortName, PortMsg, MidiEnv (..), PortData)
+import Minipat.Midi.Count (execCountM)
+import Minipat.Midi.Midi
+  ( AutoConn (..)
+  , MidiEnv (..)
+  , PortData (..)
+  , PortMsg (..)
+  , PortSel (..)
+  , SetDefault (..)
+  , SortedMsg (..)
+  , TimedMsg (..)
+  , mkNoteOff
+  , newMidiState
+  , openOutPort
+  , sendPortMsg'
+  , sendPortMsgs
+  )
 import Minipat.Time (Arc (..))
-import Nanotime (PosixTime, TimeDelta, threadDelayDelta)
-import Libremidi.Api (Api (..))
+import Nanotime (TimeDelta, threadDelayDelta)
 
 defaultMaxMsgLen :: Int
 defaultMaxMsgLen = 1024
 
 data MidiBackend = MidiBackend
   { mbApi :: !Api
+  , mbAutoConn :: !AutoConn
+  , mbDefOut :: !(Maybe Text)
   , mbMaxMsgLen :: !Int
   , mbDelay :: !(Maybe TimeDelta)
   }
 
 instance Default MidiBackend where
-  def = MidiBackend ApiUnspecified defaultMaxMsgLen Nothing
+  def = MidiBackend ApiUnspecified AutoConnYes Nothing defaultMaxMsgLen Nothing
 
 type MidiSt = St MidiBackend
 
 mkTimedMsgs :: WithPlayMeta PortData -> Seq TimedMsg
-mkTimedMsgs (WithPlayMeta pm pd) =
+mkTimedMsgs (WithPlayMeta pm pd@(PortData ps cd)) =
   let Arc t1 t2 = pmRealArc pm
       c = fromInteger (pmOrbit pm - 1)
-      m1 = LiveMsgChan c cd
+      m1 = PortMsg ps (LiveMsgChan c cd)
       s1 = Seq.singleton (TimedMsg t1 (SortedMsg m1))
   in  case mkNoteOff c pd of
         Just m2 -> s1 :|> TimedMsg t2 (SortedMsg m2)
         Nothing -> s1
 
 data MidiData = MidiData
-  { mdMidiEnv :: !MidiEnv
-  , mdObsTask :: !(Async ())
+  { mdEnv :: !MidiEnv
+  , mdHeap :: !(TVar (Heap TimedMsg))
+  , mdConnTask :: !(Async ())
   , mdSendTask :: !(Async ())
   }
 
--- sendMsgs :: (Foldable f) => St MidiBackend -> f PortMsg -> IO ()
--- sendMsgs st msgs = useCallback st $ \md ->
---   let MidiBackend _ _ maxLen mayDelay = stBackend st
---   in  sendLiveMsgs maxLen mayDelay msgs
---
--- connectAndSendMsgs :: (Foldable f) => MidiBackend -> f PortMsg -> IO ()
--- connectAndSendMsgs (MidiBackend openPred defPred maxLen mayDelay) msgs = do
---   device <- liftIO R.defaultOutput
---   mp <- R.findPort device portSel
---   case mp of
---     Nothing -> fail "Could not find acceptable port"
---     Just p -> do
---       flip finally (R.closePort device) $ do
---         R.openPort device p "minipat"
---         sendLiveMsgs maxLen mayDelay device msgs
+sendMsgs :: (Foldable f) => MidiSt -> f PortMsg -> IO ()
+sendMsgs st msgs = useCallback st $ \md -> do
+  let MidiBackend _ ac _ maxLen mayDelay = stBackend st
+  execCountM (sendPortMsgs maxLen mayDelay ac msgs) (mdEnv md)
+
+connectAndSendMsgs :: (Foldable f) => MidiBackend -> f LiveMsg -> IO ()
+connectAndSendMsgs mb@(MidiBackend _ _ defOut maxLen mayDelay) msgs = withAcquire acq use
+ where
+  ps = PortSelPrefix (fromMaybe "" defOut)
+  acq = do
+    logger <- liftIO newLogger
+    backendInit mb logger (pure False)
+  use md =
+    let msgs' = fmap (PortMsg ps) (toList msgs)
+    in  execCountM (sendPortMsgs maxLen mayDelay AutoConnNo msgs') (mdEnv md)
 
 instance Backend MidiBackend where
   type BackendData MidiBackend = MidiData
 
-  backendInit (MidiBackend api maxLen mayDelay) logger getPlayingSTM = do
-    -- device <- liftIO R.defaultOutput
-    -- let getPort = do
-    --       mp <- R.findPort device portSel
-    --       case mp of
-    --         Nothing -> fail "Could not find acceptable port"
-    --         Just p -> do
-    --           name <- fmap (fromMaybe "UNNAMED") (R.portName device p)
-    --           logInfo logger ("Opening port" <> T.pack (show p) <> " (" <> T.pack name <> ")")
-    --           R.openPort device p "minipat"
-    --           logInfo logger "Connected"
-    -- _ <- mkAcquire getPort (const (R.closePort device))
+  backendInit (MidiBackend api ac defOut maxLen mayDelay) logger getPlayingSTM = do
+    sendHeap <- liftIO (newTVarIO H.empty)
     buf <- liftIO (VSM.new maxLen)
-    ms <- newMidiState
-    let me = MidiEnv api ms
-    let send (TimedMsg _ (SortedMsg m)) = do
-          len <- fmap fromIntegral (mutEncode m buf)
-          VSM.unsafeWith buf (\ptr -> R.sendUnsafeMessage device ptr len)
+    ms <- liftIO newMidiState
+    let me = MidiEnv api logger ms
+        send (TimedMsg _ (SortedMsg pm)) = do
+          execCountM (sendPortMsg' buf ac pm) me
           for_ mayDelay threadDelayDelta
-    sendTask <- acquireAwait tmTime getPlayingSTM (qhHeap heap) send
-    fmap (MidiData device heap)
+        spawn = acquireAwait tmTime getPlayingSTM
+    connTask <- case defOut of
+      Nothing -> acquirePure ()
+      Just t -> acquireAsync (execCountM (openOutPort (PortSelPrefix t) SetDefaultYes) me)
+    sendTask <- spawn (qhHeap sendHeap) send
+    pure (MidiData me sendHeap connTask sendTask)
 
   backendSend _ _ cb evs = runCallback cb $ \md -> do
     msgs <- either throwIO pure (traverse (traverse convertMidiAttrs) evs)

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

@@ -27,13 +27,16 @@ import Data.Vector.Storable.Mutable qualified as VSM
 import Data.Word (Word8)
 import Libremidi.Api
   ( Api
+  , LogFun
+  , LogLvl (..)
   , MidiConfig (..)
   , MidiPort (..)
   , OutHandle
   , OutPort
   , cloneOutPort
   , freeOutHandle
   , freeOutPort
+  , newLogCb
   , newOutHandle
   , outSendMsg1
   )
@@ -51,6 +54,7 @@ import Libremidi.Common
 import Libremidi.Foreign qualified as LMF
 import Libremidi.Simple (findOutPort)
 import Minipat.Live.Attrs (IsAttrs (..), attrsSingleton)
+import Minipat.Live.Logger (LogAction, logError, logWarn)
 import Minipat.Midi.Count (CountM, throwErrM)
 import Nanotime (PosixTime, TimeDelta, threadDelayDelta)
 import Prettyprinter (Pretty (..))
@@ -114,7 +118,8 @@ isNoteOff (PortMsg _ lm) = case lm of
 data PortData = PortData
   { pdPort :: !PortSel
   , pdChan :: !ChanData
-  } deriving stock (Eq, Ord, Show)
+  }
+  deriving stock (Eq, Ord, Show)
 
 mkNoteOff :: Channel -> PortData -> Maybe PortMsg
 mkNoteOff c (PortData ps cd) = case cd of
@@ -155,6 +160,12 @@ data SetDefault = SetDefaultNo | SetDefaultYes
 instance Default SetDefault where
   def = SetDefaultNo
 
+data AutoConn = AutoConnNo | AutoConnYes
+  deriving stock (Eq, Ord, Show, Enum, Bounded)
+
+instance Default AutoConn where
+  def = AutoConnYes
+
 data OutState = OutState
   { osPort :: !OutPort
   , osHandle :: !(UniquePtr LMF.OutHandle)
@@ -239,9 +250,9 @@ setOutDefault pn ms = atomically (writeTVar (msOutDefault ms) (Just pn))
 
 data MidiEnv = MidiEnv
   { meApi :: !Api
+  , meLogger :: !LogAction
   , meState :: !MidiState
   }
-  deriving stock (Eq)
 
 type MidiM = CountM MidiErr MidiEnv
 
@@ -255,22 +266,37 @@ errM_ f m = do
   ea <- liftIO (runErrM m)
   either (throwErrM . f) pure ea
 
-openOutPort' :: PortName -> OutPort -> SetDefault -> (MidiConfig -> IO MidiConfig) -> MidiM ()
-openOutPort' pn op de f = do
-  MidiEnv api ms <- ask
+logFun :: LogAction -> LogFun
+logFun logger = \case
+  LogLvlWarn -> logWarn logger
+  LogLvlErr -> logError logger
+
+withMidiConfig :: PortName -> OutPort -> (MidiConfig -> MidiM ()) -> MidiM ()
+withMidiConfig pn op f = do
   mop' <- errM (MidiErrLibErr (Just (PortSelName pn))) (cloneOutPort op)
   case mop' of
     Nothing -> pure ()
     Just op' -> do
-      c <- liftIO $ do
-        x <- newUniquePtr op'
-        f (def {mcPort = Just (MidiPortOut x)})
-      moh <- errM (MidiErrLibErr (Just (PortSelName pn))) (newOutHandle api c)
-      case moh of
-        Nothing -> pure ()
-        Just oh -> liftIO $ do
-          os <- newOutState op oh
-          insertOutState pn os de ms
+      logger <- asks meLogger
+      port <- liftIO (fmap MidiPortOut (newUniquePtr op'))
+      warnCb <- liftIO (newLogCb (logFun logger) LogLvlWarn)
+      errCb <- liftIO (newLogCb (logFun logger) LogLvlErr)
+      f $
+        def
+          { mcPort = Just port
+          , mcOnWarn = Just warnCb
+          , mcOnErr = Just errCb
+          }
+
+openOutPort' :: PortName -> OutPort -> SetDefault -> MidiM ()
+openOutPort' pn op de = withMidiConfig pn op $ \mc -> do
+  MidiEnv api _ ms <- ask
+  moh <- errM (MidiErrLibErr (Just (PortSelName pn))) (newOutHandle api mc)
+  case moh of
+    Nothing -> pure ()
+    Just oh -> liftIO $ do
+      os <- newOutState op oh
+      insertOutState pn os de ms
 
 selectOutPort :: PortSel -> IO (Maybe (PortName, OutPort))
 selectOutPort ps =
@@ -280,12 +306,12 @@ selectOutPort ps =
         PortSelName (PortName t) -> f (t ==)
         PortSelPrefix t -> let t' = T.toLower t in f (T.isPrefixOf t' . T.toLower)
 
-openOutPort :: PortSel -> SetDefault -> (MidiConfig -> IO MidiConfig) -> MidiM ()
-openOutPort ps de f = do
+openOutPort :: PortSel -> SetDefault -> MidiM ()
+openOutPort ps de = do
   mx <- liftIO (selectOutPort ps)
   case mx of
     Nothing -> throwErrM (MidiErrMissingOutPort ps)
-    Just (pn, op) -> openOutPort' pn op de f
+    Just (pn, op) -> openOutPort' pn op de
 
 closeOutPort :: PortSel -> MidiM ()
 closeOutPort ps = do
@@ -295,8 +321,8 @@ closeOutPort ps = do
     Nothing -> throwErrM (MidiErrMissingOutPort ps)
     Just _ -> pure ()
 
-withOutPort :: PortSel -> (OutState -> ErrM ()) -> MidiM ()
-withOutPort ps f = do
+withOutPort :: PortSel -> AutoConn -> (OutState -> ErrM ()) -> MidiM ()
+withOutPort ps _ac f = do
   ms <- asks meState
   mz <- liftIO (atomically (selectOutState ps ms))
   case mz of
@@ -309,13 +335,13 @@ sendLiveMsg buf oh lm = unRunErrM $ do
   -- coercion is safe: Word8 -> CUChar
   VSM.unsafeWith buf (\ptr -> runErrM (outSendMsg1 oh (coerce ptr) len))
 
-sendPortMsg' :: VSM.IOVector Word8 -> PortMsg -> MidiM ()
-sendPortMsg' buf (PortMsg ps lm) =
-  withOutPort ps (\os -> withOutHandle os (\oh -> sendLiveMsg buf oh lm))
+sendPortMsg' :: VSM.IOVector Word8 -> AutoConn -> PortMsg -> MidiM ()
+sendPortMsg' buf ac (PortMsg ps lm) =
+  withOutPort ps ac (\os -> withOutHandle os (\oh -> sendLiveMsg buf oh lm))
 
-sendPortMsgs :: (Foldable f) => Int -> Maybe TimeDelta -> f PortMsg -> MidiM ()
-sendPortMsgs maxLen mayDelay msgs = do
+sendPortMsgs :: (Foldable f) => Int -> Maybe TimeDelta -> AutoConn -> f PortMsg -> MidiM ()
+sendPortMsgs maxLen mayDelay ac msgs = do
   buf <- liftIO (VSM.new maxLen)
   for_ msgs $ \pm -> do
-    sendPortMsg' buf pm
+    sendPortMsg' buf ac pm
     liftIO (for_ mayDelay threadDelayDelta)