etc

minipat-midi/minipat-midi.cabal

@@ -26,7 +26,9 @@ library
   exposed-modules:
       Minipat.Midi.Boot
       Minipat.Midi.Convert
+      Minipat.Midi.Count
       Minipat.Midi.Impl
+      Minipat.Midi.Midi
       Minipat.Midi.Mpk
       Minipat.Midi.SC
       Minipat.Midi.Setup
@@ -66,19 +68,21 @@ library
       ViewPatterns
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds
   build-depends:
-      RtMidi >=0.8 && <1.0
-    , async ==2.2.*
+      async ==2.2.*
     , base >=4.12 && <5
     , bytestring ==0.11.*
     , containers ==0.6.*
     , dahdit >=0.5.1 && <0.6
     , dahdit-midi >=0.5.5 && <0.6
     , data-default ==0.7.*
+    , exceptions >=0.10.7 && <0.11
     , heaps ==0.4.*
     , libremidi >=0.1.0 && <0.2.0
     , minipat ==0.1.*
     , minipat-live ==0.1.*
+    , mtl >=2.3.1 && <2.4
     , nanotime >=0.3.2 && <0.4
+    , prettyprinter >=1.7.1 && <1.8
     , resourcet ==1.3.*
     , stm ==2.5.*
     , text ==2.0.*
@@ -124,20 +128,22 @@ test-suite minipat-midi-test
       ViewPatterns
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      RtMidi >=0.8 && <1.0
-    , async ==2.2.*
+      async ==2.2.*
     , base >=4.12 && <5
     , bytestring ==0.11.*
     , containers ==0.6.*
     , dahdit >=0.5.1 && <0.6
     , dahdit-midi >=0.5.5 && <0.6
     , data-default ==0.7.*
+    , exceptions >=0.10.7 && <0.11
     , heaps ==0.4.*
     , libremidi >=0.1.0 && <0.2.0
     , minipat ==0.1.*
     , minipat-live ==0.1.*
     , minipat-midi
+    , mtl >=2.3.1 && <2.4
     , nanotime >=0.3.2 && <0.4
+    , prettyprinter >=1.7.1 && <1.8
     , resourcet ==1.3.*
     , stm ==2.5.*
     , tasty ==1.4.*

minipat-midi/package.yaml

@@ -26,11 +26,13 @@ dependencies:
 - minipat-live >= 0.1 && < 0.2
 - nanotime >= 0.3.2 && < 0.4
 - resourcet >= 1.3 && < 1.4
-- RtMidi >= 0.8 && < 1.0
 - stm >= 2.5 && < 2.6
 - text >= 2.0 && < 2.1
 - vector >= 0.13 && < 0.14
 - libremidi >= 0.1.0 && < 0.2.0
+- mtl >= 2.3.1 && < 2.4
+- exceptions >= 0.10.7 && < 0.11
+- prettyprinter >= 1.7.1 && < 1.8
 
 library:
   source-dirs: src

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

@@ -8,19 +8,22 @@ module Minipat.Midi.Boot
   , Vel
   , vel
   , v
+  , PortName
+  , port
   , midi
   , module Minipat.Live.Boot
   )
 where
 
-import Dahdit.Midi.Midi (LiveMsg)
+import Minipat.Midi.Midi (PortMsg)
 import Data.Sequence (Seq)
 import Data.Text (Text)
 import Minipat.Live.Boot
 import Minipat.Live.Datum (DatumProxy (..))
 import Minipat.Live.Extra (Note, parseDatum, parseMidiNote, parseNote)
 import Minipat.Midi.Convert (Vel (..))
 import Minipat.Midi.Impl qualified as I
+import Minipat.Midi.Midi (PortName (..))
 
 type MidiLiveSt = (LiveSt, LiveBackend ~ I.MidiBackend)
 
@@ -35,5 +38,8 @@ vel, v :: Text -> S Vel
 vel = fmap Vel . parseDatum DatumProxyInt32
 v = vel
 
-midi :: (MidiLiveSt) => Seq LiveMsg -> IO ()
+port :: Text -> S PortName
+port = fmap PortName . parseDatum DatumProxyString
+
+midi :: (MidiLiveSt) => Seq PortMsg -> IO ()
 midi ms = readLiveSt >>= \st -> I.sendMsgs st ms

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

@@ -0,0 +1,41 @@
+module Minipat.Midi.Count where
+
+import Control.Monad (when)
+import Control.Exception (Exception)
+import Control.Monad.IO.Class (MonadIO)
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Control.Monad.Reader (ReaderT (..), MonadReader)
+import Control.Monad.Writer (WriterT (..), MonadWriter (..))
+import Data.Typeable (Typeable)
+import Control.Monad.Catch (MonadThrow (..))
+
+newtype ErrCounts e = ErrCounts { unErrCounts :: Map e Int }
+  deriving stock (Eq, Ord, Show)
+
+instance (Show e, Typeable e) => Exception (ErrCounts e)
+
+instance Ord e => Semigroup (ErrCounts e) where
+  ErrCounts m1 <> ErrCounts m2 = ErrCounts (Map.unionWith (+) m1 m2)
+
+instance Ord e => Monoid (ErrCounts e) where
+  mempty = ErrCounts Map.empty
+
+countErr :: e -> ErrCounts e
+countErr e = ErrCounts (Map.singleton e 1)
+
+hasErrs :: ErrCounts e -> Bool
+hasErrs = not . Map.null . unErrCounts
+
+rethrowCounts :: (Show e, Typeable e) => MonadThrow m => ErrCounts e -> m ()
+rethrowCounts c = when (hasErrs c) (throwM c)
+
+newtype CountM e r a = CountM { unCountM :: ReaderT r (WriterT (ErrCounts e) IO) a }
+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader r, MonadWriter (ErrCounts e))
+
+countErrM :: Ord e => e -> CountM e s ()
+countErrM = tell . countErr
+
+runCountM :: CountM e r a -> r -> IO (a, ErrCounts e)
+runCountM (CountM m) = runWriterT . runReaderT m
+

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

@@ -34,66 +34,26 @@ import Minipat.Live.Resources (acquireAwait, qhHeap)
 import Minipat.Midi.Convert (convertMidiAttrs)
 import Minipat.Time (Arc (..))
 import Nanotime (PosixTime, TimeDelta, threadDelayDelta)
-import Sound.RtMidi (OutputDevice)
-import Sound.RtMidi qualified as R
+import Minipat.Midi.Midi (SortedMsg (..), TimedMsg (..), PortState)
+-- import Sound.RtMidi (OutputDevice)
+-- import Sound.RtMidi qualified as R
 
 defaultMaxMsgLen :: Int
 defaultMaxMsgLen = 1024
 
 -- TODO add max msg length
 data MidiBackend = MidiBackend
-  { mbPortSel :: !(String -> Bool)
+  { mbOpenPred :: !(PortName -> Bool)
+  , mbDefaultPred :: !(PortName -> Bool)
   , mbMaxMsgLen :: !Int
   , mbDelay :: !(Maybe TimeDelta)
   }
 
 instance Default MidiBackend where
-  def = MidiBackend (const True) defaultMaxMsgLen Nothing
+  def = MidiBackend (const False) (const False) defaultMaxMsgLen Nothing
 
 type MidiSt = St MidiBackend
 
--- | We order so that note offs come before other messages
-newtype SortedMsg = SortedMsg {unSortedMsg :: LiveMsg}
-  deriving stock (Show)
-  deriving newtype (Eq)
-
-isNoteOff :: LiveMsg -> Bool
-isNoteOff = \case
-  LiveMsgChan _ (ChanDataVoice cvd) ->
-    case cvd of
-      ChanVoiceDataNoteOn _ 0 -> True
-      ChanVoiceDataNoteOff _ _ -> True
-      _ -> False
-  _ -> False
-
-instance Ord SortedMsg where
-  compare (SortedMsg m1) (SortedMsg m2) =
-    let o1 = isNoteOff m1
-        o2 = isNoteOff m2
-        r = compare m1 m2
-    in  if o1
-          then
-            if o2
-              then r
-              else LT
-          else
-            if o2
-              then GT
-              else r
-
-data TimedMsg = TimedMsg
-  { tmTime :: !PosixTime
-  , tmMsg :: !SortedMsg
-  }
-  deriving stock (Eq, Ord, Show)
-
-mkNoteOff :: Channel -> ChanData -> Maybe LiveMsg
-mkNoteOff c = \case
-  ChanDataVoice (ChanVoiceDataNoteOn n v)
-    | v > 0 ->
-        Just (LiveMsgChan c (ChanDataVoice (ChanVoiceDataNoteOn n 0)))
-  _ -> Nothing
-
 mkTimedMsgs :: WithPlayMeta ChanData -> Seq TimedMsg
 mkTimedMsgs (WithPlayMeta pm cd) =
   let Arc t1 t2 = pmRealArc pm
@@ -105,28 +65,18 @@ mkTimedMsgs (WithPlayMeta pm cd) =
         Nothing -> s1
 
 data MidiData = MidiData
-  { mdDevice :: !OutputDevice
-  , mdHeap :: !(TVar (Heap TimedMsg))
+  { mdPortState :: !PortState
+  , mdObsTask :: !(Async ())
   , mdSendTask :: !(Async ())
   }
 
-sendLiveMsgs :: (Foldable f) => Int -> Maybe TimeDelta -> OutputDevice -> f LiveMsg -> IO ()
-sendLiveMsgs maxLen mayDelay device msgs = do
-  buf <- liftIO (VSM.new maxLen)
-  let send m = do
-        len <- fmap fromIntegral (mutEncode m buf)
-        VSM.unsafeWith buf (\ptr -> R.sendUnsafeMessage device ptr len)
-  for_ msgs $ \m -> do
-    send m
-    for_ mayDelay threadDelayDelta
-
 sendMsgs :: (Foldable f) => St MidiBackend -> f LiveMsg -> IO ()
 sendMsgs st msgs = useCallback st $ \md ->
   let MidiBackend _ maxLen mayDelay = stBackend st
   in  sendLiveMsgs maxLen mayDelay (mdDevice md) msgs
 
 connectAndSendMsgs :: (Foldable f) => MidiBackend -> f LiveMsg -> IO ()
-connectAndSendMsgs (MidiBackend portSel maxLen mayDelay) msgs = do
+connectAndSendMsgs (MidiBackend openPred defPred maxLen mayDelay) msgs = do
   device <- liftIO R.defaultOutput
   mp <- R.findPort device portSel
   case mp of
@@ -140,24 +90,25 @@ instance Backend MidiBackend where
   type BackendData MidiBackend = MidiData
 
   backendInit (MidiBackend portSel 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))
+    -- 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))
     heap <- liftIO (newTVarIO H.empty)
     buf <- liftIO (VSM.new maxLen)
     let send (TimedMsg _ (SortedMsg m)) = do
           len <- fmap fromIntegral (mutEncode m buf)
           VSM.unsafeWith buf (\ptr -> R.sendUnsafeMessage device ptr len)
           for_ mayDelay threadDelayDelta
-    fmap (MidiData device heap) (acquireAwait tmTime getPlayingSTM (qhHeap heap) send)
+    sendTask <- acquireAwait tmTime getPlayingSTM (qhHeap heap) send
+    fmap (MidiData device heap)
 
   backendSend _ _ cb evs = runCallback cb $ \md -> do
     msgs <- either throwIO pure (traverse (traverse convertMidiAttrs) evs)