From 78398e22054fd034536120ed61013f504d0f54bb Mon Sep 17 00:00:00 2001 From: Eric Conlon <37287+ejconlon@users.noreply.github.com> Date: Thu, 5 Sep 2024 14:37:38 -0700 Subject: [PATCH] etc --- minipat-midi/src/Minipat/Midi/Boot.hs | 3 +- minipat-midi/src/Minipat/Midi/Count.hs | 25 +-- minipat-midi/src/Minipat/Midi/Impl.hs | 5 +- minipat-midi/src/Minipat/Midi/Midi.hs | 300 ++++++++++++++++++------- stack.yaml | 2 +- stack.yaml.lock | 6 +- 6 files changed, 241 insertions(+), 100 deletions(-) diff --git a/minipat-midi/src/Minipat/Midi/Boot.hs b/minipat-midi/src/Minipat/Midi/Boot.hs index 0698e53..f536af4 100644 --- a/minipat-midi/src/Minipat/Midi/Boot.hs +++ b/minipat-midi/src/Minipat/Midi/Boot.hs @@ -15,7 +15,6 @@ module Minipat.Midi.Boot ) where -import Minipat.Midi.Midi (PortMsg) import Data.Sequence (Seq) import Data.Text (Text) import Minipat.Live.Boot @@ -23,7 +22,7 @@ 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 (..)) +import Minipat.Midi.Midi (PortMsg, PortName (..)) type MidiLiveSt = (LiveSt, LiveBackend ~ I.MidiBackend) diff --git a/minipat-midi/src/Minipat/Midi/Count.hs b/minipat-midi/src/Minipat/Midi/Count.hs index f8e29e4..da92ebc 100644 --- a/minipat-midi/src/Minipat/Midi/Count.hs +++ b/minipat-midi/src/Minipat/Midi/Count.hs @@ -1,24 +1,24 @@ module Minipat.Midi.Count where -import Control.Monad (when) import Control.Exception (Exception) +import Control.Monad (when) +import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader, ReaderT (..)) +import Control.Monad.Writer (MonadWriter (..), WriterT (..)) 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 } +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 +instance (Ord e) => Semigroup (ErrCounts e) where ErrCounts m1 <> ErrCounts m2 = ErrCounts (Map.unionWith (+) m1 m2) -instance Ord e => Monoid (ErrCounts e) where +instance (Ord e) => Monoid (ErrCounts e) where mempty = ErrCounts Map.empty countErr :: e -> ErrCounts e @@ -27,15 +27,14 @@ 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 :: (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 } +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 +throwErrM :: (Ord e) => e -> CountM e s () +throwErrM = tell . countErr runCountM :: CountM e r a -> r -> IO (a, ErrCounts e) -runCountM (CountM m) = runWriterT . runReaderT m - +runCountM (CountM m) r = runWriterT (runReaderT m r) diff --git a/minipat-midi/src/Minipat/Midi/Impl.hs b/minipat-midi/src/Minipat/Midi/Impl.hs index 1a6a642..cbf2466 100644 --- a/minipat-midi/src/Minipat/Midi/Impl.hs +++ b/minipat-midi/src/Minipat/Midi/Impl.hs @@ -32,9 +32,10 @@ import Minipat.Live.Core (St, logAsyncState, stBackend, useCallback) import Minipat.Live.Logger (logInfo) import Minipat.Live.Resources (acquireAwait, qhHeap) import Minipat.Midi.Convert (convertMidiAttrs) +import Minipat.Midi.Midi (MidiState, SortedMsg (..), TimedMsg (..)) import Minipat.Time (Arc (..)) import Nanotime (PosixTime, TimeDelta, threadDelayDelta) -import Minipat.Midi.Midi (SortedMsg (..), TimedMsg (..), PortState) + -- import Sound.RtMidi (OutputDevice) -- import Sound.RtMidi qualified as R @@ -65,7 +66,7 @@ mkTimedMsgs (WithPlayMeta pm cd) = Nothing -> s1 data MidiData = MidiData - { mdPortState :: !PortState + { mdMidiState :: !MidiState , mdObsTask :: !(Async ()) , mdSendTask :: !(Async ()) } diff --git a/minipat-midi/src/Minipat/Midi/Midi.hs b/minipat-midi/src/Minipat/Midi/Midi.hs index ab84e05..eb95d62 100644 --- a/minipat-midi/src/Minipat/Midi/Midi.hs +++ b/minipat-midi/src/Minipat/Midi/Midi.hs @@ -2,23 +2,58 @@ module Minipat.Midi.Midi where +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, readTVarIO, stateTVar, writeTVar) +import Control.Exception (Exception) +import Control.Monad (when) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask, asks) +import Dahdit.Iface (mutEncode) +import Dahdit.Midi.Midi (ChanData (..), ChanVoiceData (..), Channel, LiveMsg (..)) import Dahdit.Midi.Osc (Datum (..)) -import Minipat.Live.Attrs (IsAttrs (..), attrsSingleton) -import Prettyprinter (Pretty) +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.String (IsString) -import Control.Exception (Exception) -import Dahdit.Midi.Midi (ChanData (..), ChanVoiceData (..), Channel, LiveMsg (..)) +import Data.List (find) import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.String (IsString (..)) import Data.Text (Text) -import Nanotime (PosixTime, TimeDelta) -import Foreign.ForeignPtr (ForeignPtr) -import Libremidi.Api (OutPort, OutHandle) -import Libremidi.Common (ErrM, Err, runErrM) -import Minipat.Midi.Count (CountM, countErrM, runCountM) -import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, readTVarIO, writeTVar) +import Data.Text qualified as T +import Data.Vector.Storable.Mutable qualified as VSM +import Data.Word (Word8) +import Libremidi.Api + ( Api + , MidiConfig (..) + , MidiPort (..) + , OutHandle + , OutPort + , cloneOutPort + , freeOutHandle + , freeOutPort + , newOutHandle + , outSendMsg1 + ) +import Libremidi.Common + ( Err + , ErrM + , UniquePtr + , aliveUniquePtr + , consumeUniquePtr + , newUniquePtr + , runErrM + , unRunErrM + , withUniquePtr' + ) +import Libremidi.Foreign qualified as LMF +import Libremidi.Simple (findOutPort) +import Minipat.Live.Attrs (IsAttrs (..), attrsSingleton) +import Minipat.Midi.Count (CountM, throwErrM) +import Nanotime (PosixTime, TimeDelta, threadDelayDelta) +import Prettyprinter (Pretty (..)) isNoteOff :: LiveMsg -> Bool isNoteOff = \case @@ -62,110 +97,217 @@ data TimedMsg = TimedMsg } deriving stock (Eq, Ord, Show) -newtype PortName = PortName { unPortName :: Text } +data SetDefault = SetDefaultNo | SetDefaultYes + deriving stock (Eq, Ord, Show, Enum, Bounded) + +instance Default SetDefault where + def = SetDefaultNo + +newtype PortName = PortName {unPortName :: Text} deriving stock (Eq, Ord, Show) deriving newtype (IsString, Pretty) -instance IsAttrs PortName where - toAttrs (PortName x) = attrsSingleton "port" (DatumString x) +data PortSel + = PortSelDefault + | PortSelName !PortName + | PortSelPrefix !Text + deriving stock (Eq, Ord, Show) + +psToText :: PortSel -> Text +psToText = \case + PortSelDefault -> "!" + PortSelName (PortName t) -> t + PortSelPrefix t -> T.snoc t '*' + +psFromText :: Text -> PortSel +psFromText t = + if t == "!" + then PortSelDefault + else + let mzc = T.unsnoc t + in case mzc of + Just (z, c) -> + if c == '*' + then PortSelPrefix z + else PortSelName (PortName t) + Nothing -> PortSelName (PortName t) + +instance Pretty PortSel where + pretty = pretty . psToText + +instance IsAttrs PortSel where + toAttrs = attrsSingleton "port" . DatumString . psToText + +instance Default PortSel where + def = PortSelDefault + +instance IsString PortSel where + fromString = psFromText . T.pack data PortMsg = PortMsg - { pmPort :: !(Maybe PortName) + { pmPort :: !PortSel , pmMsg :: !LiveMsg - } deriving stock (Eq, Ord, Show) + } + deriving stock (Eq, Ord, Show) data OutState = OutState { osPort :: !OutPort - , osHandle :: !OutHandle + , osHandle :: !(UniquePtr LMF.OutHandle) , osHeap :: !(TVar (Heap TimedMsg)) - } deriving stock (Eq) + } + deriving stock (Eq) newOutState :: OutPort -> OutHandle -> IO OutState -newOutState op oh = OutState op oh <$> newTVarIO Heap.empty +newOutState op oh = OutState op <$> newUniquePtr oh <*> newTVarIO Heap.empty + +freeOutState :: OutState -> IO () +freeOutState (OutState port handUniq heapVar) = do + atomically (writeTVar heapVar Heap.empty) + 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))) + +data MidiErr + = MidiErrMissingOutPort !PortSel + | MidiErrLibErr !(Maybe PortSel) !Err + deriving stock (Eq, Ord, Show) + +instance Exception MidiErr data MidiState = MidiState { msOutMap :: !(TVar (Map PortName OutState)) , msOutDefault :: !(TVar (Maybe PortName)) - } deriving stock (Eq) - -data OpenErr = - OpenErrMissingOutPort !PortName - | OpenErrLibErr !(Maybe PortName) !Err - deriving stock (Eq, Ord, Show) + } + deriving stock (Eq) -instance Exception OpenErr +selectOutState :: PortSel -> MidiState -> STM (Maybe (PortName, OutState)) +selectOutState ps (MidiState omv odv) = do + om <- readTVar omv + xod <- readTVar odv + pure $ case ps of + PortSelDefault -> fmap (\od -> (od, om Map.! od)) xod + PortSelName pn -> fmap (pn,) (Map.lookup pn om) + PortSelPrefix t -> find (\(PortName s, _) -> T.isPrefixOf t (T.toLower s)) (Map.toList om) -data SendErr = - SendErrNoOutPort - | SendErrMissingOutPort !PortName - | SendErrLibErr !PortName !Err - deriving stock (Eq, Ord, Show) +insertOutState :: PortName -> OutState -> SetDefault -> MidiState -> IO () +insertOutState pn os de (MidiState omv odv) = do + mz <- atomically $ do + when (de == SetDefaultYes) (writeTVar odv (Just pn)) + stateTVar omv (\m -> (Map.lookup pn m, Map.insert pn os m)) + for_ mz freeOutState -instance Exception SendErr +deleteOutState :: PortSel -> MidiState -> IO (Maybe PortName) +deleteOutState ps ms@(MidiState omv odv) = do + mz <- atomically $ do + mz <- selectOutState ps ms + case mz of + Just (pn, _) -> do + om <- readTVar omv + xod <- readTVar odv + writeTVar omv (Map.delete pn om) + case xod of + Just od | od == pn -> writeTVar odv Nothing + _ -> pure () + Nothing -> pure () + pure mz + case mz of + Just (pn, os) -> do + freeOutState os + pure (Just pn) + Nothing -> pure Nothing -data MidiErr = - MidiErrOpen !OpenErr - | MidiErrSend !SendErr - deriving stock (Eq, Ord, Show) +getOutDefault :: MidiState -> IO (Maybe PortName) +getOutDefault ms = readTVarIO (msOutDefault ms) -instance Exception MidiErr +setOutDefault :: PortName -> MidiState -> IO () +setOutDefault pn ms = atomically (writeTVar (msOutDefault ms) (Just pn)) -type MidiM = CountM MidiErr MidiState +data MidiEnv = MidiEnv + { meApi :: !Api + , meState :: !MidiState + } + deriving stock (Eq) --- addOutPort :: PortName -> Bool -> PortState -> IO () --- addOutPort pn de ps = do --- --- closeOutPort :: PortName -> PortState -> IO () --- closeOutPort = undefined --- --- setOutDefault :: Maybe PortName -> PortState -> IO () --- setOutDefault mpn ps = atomically (writeTVar (psOutDefault ps) mpn) +type MidiM = CountM MidiErr MidiEnv errM :: (Err -> MidiErr) -> ErrM a -> MidiM (Maybe a) errM f m = do ea <- liftIO (runErrM m) - case ea of - Left e -> countErrM (f e) >> pure Nothing - Right a -> pure (Just a) + either (\e -> Nothing <$ throwErrM (f e)) (pure . Just) ea errM_ :: (Err -> MidiErr) -> ErrM () -> MidiM () errM_ f m = do ea <- liftIO (runErrM m) - case ea of - Left e -> countErrM (f e) - Right _ -> pure () + either (throwErrM . f) pure ea --- addOutState :: OutPort -> OutHandle -> Bool -> MidiM () --- addOutState op oh de ms = do --- os <- newOutState op oh --- n <- withForeignPtr op outPortName --- atomically $ do --- modifyTVar (msOutMap ms) $ \m -> Map.insert n --- +openOutPort' :: PortName -> OutPort -> SetDefault -> (MidiConfig -> IO MidiConfig) -> MidiM () +openOutPort' pn op de f = do + MidiEnv api ms <- ask + 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 -openOutPort :: OutPort -> Bool -> MidiM () -openOutPort fop de = do - name <- undefined - undefined +selectOutPort :: PortSel -> IO (Maybe (PortName, OutPort)) +selectOutPort ps = + let f = fmap (fmap (first PortName)) . findOutPort + in case ps of + PortSelDefault -> pure Nothing + PortSelName (PortName t) -> f (t ==) + PortSelPrefix t -> let t' = T.toLower t in f (T.isPrefixOf t' . T.toLower) -closeOutPort :: OutPort -> MidiM () -closeOutPort = error "TODO" +openOutPort :: PortSel -> SetDefault -> (MidiConfig -> IO MidiConfig) -> MidiM () +openOutPort ps de f = do + mx <- liftIO (selectOutPort ps) + case mx of + Nothing -> throwErrM (MidiErrMissingOutPort ps) + Just (pn, op) -> openOutPort' pn op de f -openNamedOutPort :: PortName -> Bool -> MidiM () -openNamedOutPort = error "TODO" +closeOutPort :: PortSel -> MidiM () +closeOutPort ps = do + ms <- asks meState + mx <- liftIO (deleteOutState ps ms) + case mx of + Nothing -> throwErrM (MidiErrMissingOutPort ps) + Just _ -> pure () -closeNamedOutPort :: PortName -> MidiM () -closeNamedOutPort = error "TODO" +withOutPort :: PortSel -> (OutState -> ErrM ()) -> MidiM () +withOutPort ps f = do + ms <- asks meState + mz <- liftIO (atomically (selectOutState ps ms)) + case mz of + Nothing -> throwErrM (MidiErrMissingOutPort ps) + Just (pn, os) -> errM_ (MidiErrLibErr (Just (PortSelName pn))) (f os) -sendPortMsgs :: (Foldable f) => Int -> Maybe TimeDelta -> f PortMsg -> MidiM () -sendPortMsgs = error "TODO" +sendLiveMsg :: VSM.IOVector Word8 -> OutHandle -> LiveMsg -> ErrM () +sendLiveMsg buf oh lm = unRunErrM $ do + len <- fmap fromIntegral (mutEncode lm buf) + -- coercion is safe: Word8 -> CUChar + VSM.unsafeWith buf (\ptr -> runErrM (outSendMsg1 oh (coerce ptr) len)) --- sendLiveMsgs maxLen mayDelay outSt 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 +sendPortMsg' :: VSM.IOVector Word8 -> PortMsg -> MidiM () +sendPortMsg' buf (PortMsg ps lm) = + withOutPort ps (\os -> withOutHandle os (\oh -> sendLiveMsg buf oh lm)) +sendPortMsgs :: (Foldable f) => Int -> Maybe TimeDelta -> f PortMsg -> MidiM () +sendPortMsgs maxLen mayDelay msgs = do + buf <- liftIO (VSM.new maxLen) + for_ msgs $ \pm -> do + sendPortMsg' buf pm + liftIO (for_ mayDelay threadDelayDelta) diff --git a/stack.yaml b/stack.yaml index ffe6af4..e26a820 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,6 +21,6 @@ extra-deps: - looksee-0.6.0 - nanotime-0.3.2 - git: git@github.com:ejconlon/libremidi-haskell.git - commit: 64fe2ad4720f014eb55f3a1d2a3e63313d2debce + commit: 2edd8317f1f2e3a2f43bfcd2e7dc46aaf2fb1022 subdirs: - libremidi diff --git a/stack.yaml.lock b/stack.yaml.lock index 421ff19..30a2f30 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -75,16 +75,16 @@ packages: original: hackage: nanotime-0.3.2 - completed: - commit: 64fe2ad4720f014eb55f3a1d2a3e63313d2debce + commit: 2edd8317f1f2e3a2f43bfcd2e7dc46aaf2fb1022 git: git@github.com:ejconlon/libremidi-haskell.git name: libremidi pantry-tree: - sha256: 2dd97c2cf27101f3f7dd41f6e30a979742ce6649ed0c665b736c54a763d52736 + sha256: 993949807ef804a05372a7c0fc5db5f2739a71fbd0c6ff17808fe4c819f4d3f3 size: 11229 subdir: libremidi version: 0.1.0 original: - commit: 64fe2ad4720f014eb55f3a1d2a3e63313d2debce + commit: 2edd8317f1f2e3a2f43bfcd2e7dc46aaf2fb1022 git: git@github.com:ejconlon/libremidi-haskell.git subdir: libremidi snapshots: