RtMidi 0.3.0.0 → 0.4.0.0

raw patch · 11 files changed

+280/−118 lines, 11 filesdep +deepseqdep +pretty-simpledep +vectornew-component:exe:rtmidi-reportPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, pretty-simple, vector

API changes (from Hackage documentation)

Files

• README.md +12/−18
• RtMidi.cabal +15/−4
• Sound/RtMidi.hs +77/−61
• Sound/RtMidi/Foreign.hsc +44/−8
• Sound/RtMidi/Report.hs +62/−0
• examples/callback.hs +4/−3
• examples/playback.hs +3/−2
• examples/poll.hs +3/−2
• examples/query.hs +0/−11
• examples/report.hs +5/−0
• test/Main.hs +55/−9

@@ -4,32 +4,26 @@  Haskell wrapper for [RtMidi](http://www.music.mcgill.ca/~gary/rtmidi/), the lightweight, cross-platform MIDI I/O library. -## Development--This project is tested with Cabal (latest versions of last two compiler lines) and Stack (latest LTS).+## How to use -You can get started with development like so:+See [Hackage](https://hackage.haskell.org/package/RtMidi) for the latest released version and add `RtMidi` and `vector` to your library `build-depends`. -    # Build on OSX CoreMIDI support or Linux with ALSA support-    # You can also pass `--flag RtMidi:jack` for Jack support-    stack build+Follow the [callback](https://github.com/riottracker/RtMidi/blob/master/examples/callback.hs) example to receive messages. -    # Verify that it works:-    stack exec -- rtmidi-query+Follow the [playback](https://github.com/riottracker/RtMidi/blob/master/examples/playback.hs) example to send messages. -There is also a `Dockerfile` in the `docker` directory and some `make` targets that can help you verify Linux builds:+## Development -    # Build the image and tag it `haskell-rtmidi-dev`-    make docker-build+This project is tested with Cabal (latest versions of last two compiler lines) and Stack (latest LTS). -    # Enter the docker image-    make docker-repl+You can get started with development like so: -    # Inside the docker image:-    cabal update && cabal build+    # Build and test on OSX CoreMIDI support or Linux with ALSA support.+    # (You can also manually invoke stack and pass `--flag RtMidi:jack` for Jack support.)+    make test -(Note that you can't use any `RtMidi` functions in the containerized env unless you are running a Linux host, and-even then you'd probably have to start the process with something like `docker run --device /dev/snd`.)+    # Print information about all accessible MIDI devices and all compiled APIs.+    make example-report  ## TODO 

@@ -1,5 +1,5 @@ name:                RtMidi-version:             0.3.0.0+version:             0.4.0.0 synopsis:            Haskell wrapper for RtMidi, the lightweight, cross-platform MIDI I/O library. description:         Please see the README on GitHub at <https://github.com/riottracker/RtMidi#readme> category:            Sound@@ -14,7 +14,7 @@                      examples/callback.hs                      examples/playback.hs                      examples/poll.hs-                     examples/query.hs+                     examples/report.hs cabal-version:       >=1.10 license:             MIT @@ -30,10 +30,16 @@  library   exposed-modules:     Sound.RtMidi+                     , Sound.RtMidi.Report   other-modules:       Sound.RtMidi.Foreign   build-depends:       base >=4.9 && <4.15+                     , deepseq >= 1.4.4.0 && < 2                      , unliftio-core >= 0.1.2.0 && < 1+                     , vector >= 0.12.1.2 && < 1   default-language:    Haskell2010+  default-extensions:  DeriveGeneric+                     , DerivingStrategies+                     , GeneralizedNewtypeDeriving   include-dirs:        rtmidi   extra-libraries:     stdc++   c-sources:           rtmidi/RtMidi.cpp@@ -72,6 +78,7 @@   build-depends:       base     , RtMidi+    , vector   default-language:   Haskell2010   ghc-options: -threaded -rtsopts @@ -81,6 +88,7 @@   build-depends:       base     , RtMidi+    , vector   default-language:   Haskell2010   ghc-options: -threaded -rtsopts @@ -90,15 +98,17 @@   build-depends:       base     , RtMidi+    , vector   default-language:   Haskell2010   ghc-options: -threaded -rtsopts -executable rtmidi-query-  main-is:            query.hs+executable rtmidi-report+  main-is:            report.hs   hs-source-dirs:     examples   build-depends:       base     , RtMidi+    , pretty-simple >= 3.2.3.0 && < 4   default-language:   Haskell2010   ghc-options: -threaded -rtsopts @@ -109,6 +119,7 @@   build-depends:       base     , RtMidi+    , vector     , tasty >= 1.2.3 && < 2     , tasty-hunit >= 0.10.0.2 && < 1   default-language:   Haskell2010

@@ -1,3 +1,6 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+ -- | Interface to RtMidi module Sound.RtMidi   ( InputDevice@@ -6,6 +9,9 @@   , DeviceType (..)   , Api (..)   , Error (..)+  , apiName+  , apiDisplayName+  , compiledApiByName   , ready   , compiledApis   , openPort@@ -18,26 +24,32 @@   , defaultInput   , createInput   , setCallback+  , setUnsafeCallback   , setForeignCallback   , cancelCallback   , ignoreTypes   , getMessage   , getMessageSized+  , getMessageMutable   , defaultOutput   , createOutput   , sendMessage   , currentApi   ) where +import Control.DeepSeq (NFData) import Control.Exception (Exception, throwIO) import Control.Monad (unless, void) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Data.Coerce (coerce)+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Storable.Mutable as VSM import Data.Word (Word8)-import Foreign (FunPtr, Ptr, Storable (..), alloca, allocaArray, nullPtr, peekArray, with, withArrayLen)+import Foreign (FunPtr, Ptr, Storable (..), alloca, allocaArray, nullPtr, peekArray) import Foreign.C (CDouble (..), CInt (..), CSize, CString, CUChar (..), peekCString, withCString) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)+import GHC.Generics (Generic) import Sound.RtMidi.Foreign  -- The default message size (in bytes) expected from 'getMessage'@@ -50,10 +62,11 @@ data DeviceType =     InputDeviceType   | OutputDeviceType-  deriving (Eq, Show)+  deriving stock (Eq, Show, Ord, Enum, Bounded, Generic)+  deriving anyclass (NFData)  newtype Device = Device { unDevice :: ForeignPtr Wrapper }-  deriving (Eq, Show)+  deriving stock (Eq, Show)  -- | Generalizes 'InputDevice' and 'OutputDevice' for use in common functions class IsDevice d where@@ -62,7 +75,7 @@  -- | A handle to a device to be used for input newtype InputDevice = InputDevice { unInputDevice :: Device }-  deriving (Eq, Show)+  deriving stock (Eq, Show)  instance IsDevice InputDevice where   toDevice = unInputDevice@@ -73,7 +86,7 @@  -- | A handle to a device to be used for input newtype OutputDevice = OutputDevice { unOutputDevice :: Device }-  deriving (Eq, Show)+  deriving stock (Eq, Show)  instance IsDevice OutputDevice where   toDevice = unOutputDevice@@ -82,37 +95,11 @@ newOutputDevice :: Ptr Wrapper -> IO OutputDevice newOutputDevice = fmap (OutputDevice . Device) . newForeignPtr rtmidi_out_free --- | Enum of RtMidi-supported APIs-data Api-  = UnspecifiedApi-  | CoreMidiApi-  | AlsaApi-  | JackApi-  | MultimediaApi-  | KernelStreamingApi-  | DummyApi-  deriving (Eq, Show)--instance Bounded Api where-  minBound = UnspecifiedApi-  maxBound = DummyApi--instance Enum Api where-  fromEnum UnspecifiedApi = 0-  fromEnum CoreMidiApi = 1-  fromEnum AlsaApi = 2-  fromEnum JackApi = 3-  fromEnum MultimediaApi = 4-  fromEnum DummyApi = 5-  toEnum 0 = UnspecifiedApi-  toEnum 1 = CoreMidiApi-  toEnum 2 = AlsaApi-  toEnum 3 = JackApi-  toEnum 4 = MultimediaApi-  toEnum 5 = DummyApi- -- | An internal RtMidi error-newtype Error = Error String deriving (Eq, Show)+newtype Error = Error { unError :: String }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)+ instance Exception Error  -- Detects and throws internal errors@@ -131,6 +118,18 @@ withDevicePtr :: IsDevice d => d -> (Ptr Wrapper -> IO a) -> IO a withDevicePtr d f = withDevicePtrUnguarded d (\dptr -> f dptr <* guardError dptr) +-- | Get the display name for the given 'Api'.+apiDisplayName :: MonadIO m => Api -> m String+apiDisplayName api = liftIO (rtmidi_api_display_name (fromApi api) >>= peekCString)++-- | Get the internal name for the given 'Api'.+apiName :: MonadIO m => Api -> m String+apiName api = liftIO (rtmidi_api_name (fromApi api) >>= peekCString)++-- | Lookup a compiled 'Api' by name.+compiledApiByName :: MonadIO m => String -> m Api+compiledApiByName name = liftIO (fmap toApi (withCString name rtmidi_compiled_api_by_name))+ -- | Check if a device is ok ready :: (MonadIO m, IsDevice d) => d -> m Bool ready d = liftIO (withDevicePtr d (fmap ok . peek))@@ -142,7 +141,7 @@   as <- allocaArray n $ \ptr -> do     rtmidi_get_compiled_api ptr (fromIntegral n)     peekArray n ptr-  pure (map (toEnum . fromIntegral) as)+  pure (map toApi as)  -- | Open a MIDI connection openPort :: (MonadIO m, IsDevice d)@@ -234,16 +233,21 @@             -> Int        -- ^ size of the MIDI input queue             -> m InputDevice createInput api clientName queueSizeLimit = liftIO $ do-  dptr <- withCString clientName (\str -> rtmidi_in_create (fromIntegral (fromEnum api)) str (fromIntegral queueSizeLimit))+  dptr <- withCString clientName (\str -> rtmidi_in_create (fromApi api) str (fromIntegral queueSizeLimit))   guardError dptr   newInputDevice dptr  foreign import ccall "wrapper"   mkCallbackPointer :: (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ()) -> IO (FunPtr (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ())) -adaptCallbackCTypes :: (Double -> [Word8] -> IO ()) -> (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ())-adaptCallbackCTypes f (CDouble t) d s _ = peekArray (fromIntegral s) d >>= \a -> f t (coerce a)+adaptCallbackCTypes :: (Double -> VS.Vector Word8 -> IO ()) -> (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ())+adaptCallbackCTypes !f (CDouble !t) m s _ = do+  buf <- VS.generateM (fromIntegral s) (peekElemOff (coerce m))+  f t buf +adaptUnsafeCallbackCTypes :: (Double -> Ptr Word8 -> Int -> IO ()) -> (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ())+adaptUnsafeCallbackCTypes !f (CDouble !t) m s _ = f t (coerce m) (fromIntegral s)+ -- | Set a callback function to be invoked for incoming MIDI messages. -- -- The callback function will be called whenever an incoming MIDI message is received.@@ -251,12 +255,22 @@ -- some messages in the queue. setCallback :: MonadUnliftIO m             => InputDevice-            -> (Double -> [Word8] -> m ())  -- ^ Function that takes a timestamp and a MIDI message as arguments+            -> (Double -> VS.Vector Word8 -> m ())  -- ^ Function that takes a timestamp and a MIDI message as arguments             -> m () setCallback d c = withRunInIO $ \run -> withDevicePtr d $ \dptr -> do   f <- mkCallbackPointer (adaptCallbackCTypes (\ts bytes -> run (c ts bytes)))   rtmidi_in_set_callback dptr f nullPtr +-- | A variant of 'setCallback' that takes a raw pointer and length. It is unsafe to share or reference the pointer beyond the+-- scope of the callback, as the RtMidi-owned memory it references may have been changed or freed.+setUnsafeCallback :: MonadIO m+                  => InputDevice+                  -> (Double -> Ptr Word8 -> Int -> IO ())+                  -> m ()+setUnsafeCallback d c = liftIO $ withDevicePtr d $ \dptr -> do+  f <- mkCallbackPointer (adaptUnsafeCallbackCTypes c)+  rtmidi_in_set_callback dptr f nullPtr+ -- | Set a /foreign/ callback function to be invoked for incoming MIDI messages. -- -- This variant allows you to set the callback to a C function pointer so we're not forced@@ -279,7 +293,7 @@ -- -- By default, MIDI timing and active sensing messages are ignored during message input because of their -- relative high data rates. MIDI sysex messages are ignored by default as well.--- Variable values of `true` imply that the respective message type will be ignored.+-- Variable values of 'True' imply that the respective message type will be ignored. ignoreTypes :: MonadIO m             => InputDevice             -> Bool       -- ^ SysEx messages@@ -288,28 +302,30 @@             -> m () ignoreTypes d x y z = liftIO (withDevicePtrUnguarded d (\dptr -> rtmidi_in_ignore_types dptr x y z)) --- | Variant of 'getMessage' that allows you to set message buffer size (typically for large sysex messages).-getMessageSized :: MonadIO m => InputDevice -> Int -> m (Double, [Word8])-getMessageSized d n = liftIO $ alloca $ \s -> allocaArray n $ flip with $ \m -> withDevicePtrUnguarded d $ \dptr -> do-  poke s (fromIntegral n)-  CDouble timestamp <- rtmidi_in_get_message dptr m s+-- | Variant of 'getMessage' that allows you to fill a shared buffer, returning timestamp and size.+getMessageMutable :: MonadIO m => InputDevice -> VSM.IOVector Word8 -> m (Double, Int)+getMessageMutable d buf = liftIO $ alloca $ \s -> VSM.unsafeWith buf $ \m -> withDevicePtrUnguarded d $ \dptr -> do+  poke s (fromIntegral (VSM.length buf))+  CDouble !timestamp <- rtmidi_in_get_message dptr (coerce m) s   guardError dptr-  size <- peek s-  message <--    case size of-      0 -> pure []-      _ -> do-        x <- peek m-        y <- peekArray (fromIntegral size) x-        pure (coerce y)-  pure (timestamp, message)+  csize <- peek s+  let !size = fromIntegral csize+  pure (timestamp, size) +-- | Variant of 'getMessage' that allows you to set message buffer size (typically for large sysex messages).+getMessageSized :: MonadIO m => InputDevice -> Int -> m (Double, VS.Vector Word8)+getMessageSized d n = liftIO $ do+  buf <- VSM.new n+  (!timestamp, !size) <- getMessageMutable d buf+  vec <- VSM.unsafeWith buf (VS.generateM size . peekElemOff)+  pure (timestamp, vec)+ -- | Return data bytes for the next available MIDI message in the input queue and the event delta-time in seconds. -- -- This function returns immediately whether a new message is available or not. -- A valid message is indicated by whether the list contains any elements. -- Note that large sysex messages will be silently dropped! Use 'getMessageSized' or use a callback to get these safely.-getMessage :: MonadIO m => InputDevice -> m (Double, [Word8])+getMessage :: MonadIO m => InputDevice -> m (Double, VS.Vector Word8) getMessage d = liftIO (getMessageSized d defaultMessageSize)  -- | Default constructor for a 'Device' to use for output.@@ -325,14 +341,14 @@              -> String     -- ^ client name              -> m OutputDevice createOutput api clientName = liftIO $ do-  dptr <- withCString clientName (rtmidi_out_create (fromIntegral (fromEnum api)))+  dptr <- withCString clientName (rtmidi_out_create (fromApi api))   guardError dptr   newOutputDevice dptr  -- | Immediately send a single message out an open MIDI output port.-sendMessage :: MonadIO m => OutputDevice -> [Word8] -> m ()-sendMessage d m = liftIO $ withArrayLen m $ \n ptr -> withDevicePtr d $ \dptr ->-  void (rtmidi_out_send_message dptr (coerce ptr) (fromIntegral n))+sendMessage :: MonadIO m => OutputDevice -> VS.Vector Word8 -> m ()+sendMessage d buf = liftIO $ VS.unsafeWith buf $ \m -> withDevicePtr d $ \dptr ->+  void (rtmidi_out_send_message dptr (coerce m) (fromIntegral (VS.length buf)))  -- | Returns the specifier for the MIDI 'Api' in use currentApi :: MonadIO m => IsDevice d => d -> m Api@@ -341,4 +357,4 @@     case getDeviceType d of       InputDeviceType -> rtmidi_in_get_current_api dptr       OutputDeviceType -> rtmidi_out_get_current_api dptr-  pure (toEnum (fromIntegral res))+  pure (toApi res)

@@ -1,10 +1,17 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ForeignFunctionInterface #-}  -- | FFI defs for RtMidi module Sound.RtMidi.Foreign   ( Wrapper (..)+  , Api (..)+  , ApiInternal+  , toApi+  , fromApi+  , rtmidi_api_display_name+  , rtmidi_api_name   , rtmidi_close_port+  , rtmidi_compiled_api_by_name   , rtmidi_get_compiled_api   , rtmidi_get_port_count   , rtmidi_get_port_name@@ -27,15 +34,18 @@  #include "rtmidi_c.h" +import Control.DeepSeq (NFData) import Foreign (FunPtr, Ptr, Storable (..)) import Foreign.C (CDouble (..), CInt (..), CString, CSize, CUChar, CUInt (..))+import GHC.Generics (Generic)  data Wrapper = Wrapper   { ptr :: !(Ptr ())   , dat :: !(Ptr ())   , ok  :: !Bool   , msg :: !CString-  } deriving (Eq, Show)+  } deriving stock (Eq, Show, Generic)+    deriving anyclass (NFData)  instance Storable Wrapper where   sizeOf _ = #{size struct RtMidiWrapper}@@ -52,14 +62,40 @@     d <- #{peek struct RtMidiWrapper, msg} ptr     pure (Wrapper a b c d) +-- | Enum of RtMidi-supported APIs+data Api+  = UnspecifiedApi+  | CoreMidiApi+  | AlsaApi+  | JackApi+  | MultimediaApi+  | DummyApi+  deriving stock (Eq, Show, Ord, Enum, Bounded, Generic)+  deriving anyclass (NFData)+ -- A parameter we'll be de/serializing from the 'Api' enum.-type ApiEnum = CInt+newtype ApiInternal = ApiInternal { unApiInternal :: CInt } deriving newtype (Storable) +toApi :: ApiInternal -> Api+toApi = toEnum . fromIntegral . unApiInternal++fromApi :: Api -> ApiInternal+fromApi = ApiInternal . fromIntegral . fromEnum++foreign import ccall "rtmidi_c.h rtmidi_api_display_name"+  rtmidi_api_display_name :: ApiInternal -> IO CString++foreign import ccall "rtmidi_c.h rtmidi_api_name"+  rtmidi_api_name :: ApiInternal -> IO CString+ foreign import ccall "rtmidi_c.h rtmidi_close_port"   rtmidi_close_port :: Ptr Wrapper -> IO () +foreign import ccall "rtmidi_c.h rtmidi_compiled_api_by_name"+  rtmidi_compiled_api_by_name :: CString -> IO ApiInternal+ foreign import ccall "rtmidi_c.h rtmidi_get_compiled_api"-  rtmidi_get_compiled_api :: Ptr ApiEnum -> CUInt -> IO CInt+  rtmidi_get_compiled_api :: Ptr ApiInternal -> CUInt -> IO CInt  foreign import ccall "rtmidi_c.h rtmidi_get_port_count"   rtmidi_get_port_count :: Ptr Wrapper -> IO CUInt@@ -71,7 +107,7 @@   rtmidi_in_cancel_callback :: Ptr Wrapper -> IO ()  foreign import ccall "rtmidi_c.h rtmidi_in_create"-  rtmidi_in_create :: ApiEnum -> CString -> CUInt -> IO (Ptr Wrapper)+  rtmidi_in_create :: ApiInternal -> CString -> CUInt -> IO (Ptr Wrapper)  foreign import ccall "rtmidi_c.h rtmidi_in_create_default"   rtmidi_in_create_default :: IO (Ptr Wrapper)@@ -80,7 +116,7 @@   rtmidi_in_free :: FunPtr (Ptr Wrapper -> IO ())  foreign import ccall "rtmidi_c.h rtmidi_in_get_current_api"-  rtmidi_in_get_current_api :: Ptr Wrapper -> IO ApiEnum+  rtmidi_in_get_current_api :: Ptr Wrapper -> IO ApiInternal  foreign import ccall "rtmidi_c.h rtmidi_in_get_message"   rtmidi_in_get_message :: Ptr Wrapper -> Ptr (Ptr CUChar) -> Ptr CSize -> IO CDouble@@ -98,7 +134,7 @@   rtmidi_open_virtual_port :: Ptr Wrapper -> CString -> IO ()  foreign import ccall "rtmidi_c.h rtmidi_out_create"-  rtmidi_out_create :: ApiEnum-> CString -> IO (Ptr Wrapper)+  rtmidi_out_create :: ApiInternal -> CString -> IO (Ptr Wrapper)  foreign import ccall "rtmidi_c.h rtmidi_out_create_default"   rtmidi_out_create_default :: IO (Ptr Wrapper)@@ -107,7 +143,7 @@   rtmidi_out_free :: FunPtr (Ptr Wrapper -> IO ())  foreign import ccall "rtmidi_c.h rtmidi_out_get_current_api"-  rtmidi_out_get_current_api :: Ptr Wrapper -> IO ApiEnum+  rtmidi_out_get_current_api :: Ptr Wrapper -> IO ApiInternal  foreign import ccall "rtmidi_c.h rtmidi_out_send_message"   rtmidi_out_send_message :: Ptr Wrapper -> Ptr CUChar -> CInt -> IO CInt

@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveAnyClass #-}++-- | Utility code to gather MIDI system information.+module Sound.RtMidi.Report+  ( ApiReport (..)+  , Report (..)+  , buildApiReport+  , buildCustomReport+  , buildReport+  ) where++import Control.DeepSeq (NFData)+import Control.Monad.IO.Class (MonadIO)+import Data.List (nub)+import GHC.Generics (Generic)+import Sound.RtMidi++-- | MIDI system information specific to a particular API.+data ApiReport = ApiReport+  { apiRepApi :: !Api+  , apiRepName :: !String+  , apiRepDisplayName :: !String+  , apiInPorts :: ![(Int, String)]+  , apiOutPorts :: ![(Int, String)]+  } deriving stock (Eq, Show, Generic)+    deriving anyclass (NFData)++-- | MIDI system information for any number of APIs.+data Report = Report+  { defaultInApi :: !Api+  , defaultOutApi :: !Api+  , apiReports :: ![ApiReport]+  } deriving stock (Eq, Show, Generic)+    deriving anyclass (NFData)++-- | Gather information about the given 'Api', including port information.+buildApiReport :: MonadIO m => Api -> m ApiReport+buildApiReport api = do+  name <- apiName api+  displayName <- apiDisplayName api+  inDev <- createInput api ("rtmidi-report-input-" ++ name) 0+  inPorts <- listPorts inDev+  outDev <- createOutput api ("rtmidi-report-output-" ++ name)+  outPorts <- listPorts outDev+  pure (ApiReport api name displayName inPorts outPorts)++-- | Variant of 'buildReport' that allows you to restrict it to the default APIs.+buildCustomReport :: MonadIO m+                  => Bool  -- ^ True to report on default APIs, False to report on all compiled APIs.+                  -> m Report+buildCustomReport defaultOnly = do+  inDev <- defaultInput+  defInApi <- currentApi inDev+  outDev <- defaultOutput+  defOutApi <- currentApi outDev+  apis <- if defaultOnly then pure (nub [defInApi, defOutApi]) else compiledApis+  apiReps <- traverse buildApiReport apis+  pure (Report defInApi defOutApi apiReps)++-- | Gather information about all compiled APIs.+buildReport :: MonadIO m => m Report+buildReport = buildCustomReport False

@@ -1,9 +1,10 @@+import qualified Data.Vector.Storable as VS import Data.Word (Word8)-import Sound.RtMidi (closePort, defaultInput, openPort, setCallback) import Numeric (showHex)+import Sound.RtMidi (closePort, defaultInput, openPort, setCallback) -callback :: Double -> [Word8] -> IO ()-callback delta msg = putStrLn $ (foldr (showHex . fromEnum) "" msg) ++ " - " ++ (show delta)+callback :: Double -> VS.Vector Word8 -> IO ()+callback delta msg = putStrLn $ (VS.foldr (showHex . fromEnum) "" msg) ++ " - " ++ (show delta)  main :: IO () main = do

@@ -1,5 +1,6 @@-import Sound.RtMidi (closePort, defaultOutput, openPort, sendMessage, portCount, portName) import Control.Concurrent (threadDelay)+import qualified Data.Vector.Storable as VS+import Sound.RtMidi (closePort, defaultOutput, openPort, sendMessage, portCount, portName)  main :: IO () main = do@@ -15,6 +16,6 @@   let arp2 = take 12 $ cycle [0x50, 0x53, 0x58]   let song = cycle (arp0 ++ arp1 ++ arp2 ++ arp0)   putStrLn "playing..."-  mapM_ (\x -> sendMessage device [0x90, x, 0x7f] >> threadDelay 120000) $ take 240 song+  mapM_ (\x -> sendMessage device (VS.fromList [0x90, x, 0x7f]) >> threadDelay 120000) $ take 240 song   putStrLn "exiting..."   closePort device

@@ -1,11 +1,12 @@-import Sound.RtMidi (InputDevice, closePort, defaultInput, getMessage, openPort) import Control.Concurrent (forkIO, killThread) import Control.Monad (forever)+import qualified Data.Vector.Storable as VS+import Sound.RtMidi (InputDevice, closePort, defaultInput, getMessage, openPort)  mainLoop :: InputDevice -> IO () mainLoop d = do   m <- getMessage d-  if length (snd m) > 0 then+  if VS.length (snd m) > 0 then     putStrLn $ show m   else return () 

@@ -1,11 +0,0 @@-import Sound.RtMidi (compiledApis, createOutput, currentApi, defaultOutput, listPorts)--main :: IO ()-main = do-  device <- defaultOutput-  api <- currentApi device-  builtin <- compiledApis-  portPairs <- listPorts device-  putStrLn $ "RtMidi output using " ++ (show api)-  putStrLn $ "built-in: " ++ (show builtin)-  putStrLn $ "available ports: " ++ (show portPairs)

@@ -0,0 +1,5 @@+import Sound.RtMidi.Report (buildReport)+import Text.Pretty.Simple (pPrint)++main :: IO ()+main = buildReport >>= pPrint

@@ -2,27 +2,67 @@  import Control.Concurrent (threadDelay) import Control.Monad (replicateM_, unless, when)+import Data.Foldable (for_) import Data.IORef (IORef, newIORef, readIORef, modifyIORef) import Data.List (isInfixOf)+import qualified Data.Vector.Storable as VS import Data.Word (Word8)-import Sound.RtMidi (Api (..), closePort, compiledApis, createInput, createOutput, currentApi, findPort, sendMessage, setCallback, openPort, openVirtualPort)+import Sound.RtMidi (Api (..), apiName, apiDisplayName, closePort, compiledApiByName, compiledApis, createInput, createOutput, currentApi, findPort, sendMessage, setCallback, openPort, openVirtualPort)+import Sound.RtMidi.Report (Report, buildReport) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=))  incIORef :: IORef Int -> IO () incIORef = flip modifyIORef succ -readerCallback :: IORef Int -> Double -> [Word8] -> IO ()-readerCallback countRef _ msg = incIORef countRef+-- A simple note-on message+exampleMessage :: VS.Vector Word8+exampleMessage = VS.fromList [0x90, 0x51, 0x7f] +readerCallback :: IORef Int -> Double -> VS.Vector Word8 -> IO ()+readerCallback countRef _ msg = do+  msg @?= exampleMessage+  incIORef countRef++testApiName :: TestTree+testApiName = testCase "apiName" $ do+  actualName1 <- apiName UnspecifiedApi+  actualName1 @?= "unspecified"+  actualName2 <- apiName DummyApi+  actualName2 @?= "dummy"++testApiDisplayName :: TestTree+testApiDisplayName = testCase "apiDisplayName" $ do+  actualName1 <- apiDisplayName UnspecifiedApi+  actualName1 @?= "Unknown"+  actualName2 <- apiDisplayName DummyApi+  actualName2 @?= "Dummy"++testCompiledApiByName :: TestTree+testCompiledApiByName = testCase "compiledApiByName" $ do+  actualApi1 <- compiledApiByName "unspecified"+  actualApi1 @?= UnspecifiedApi+  actualApi2 <- compiledApiByName "dummy"+  actualApi2 @?= UnspecifiedApi+  actualApi3 <- compiledApiByName "invalid"+  actualApi3 @?= UnspecifiedApi++testBuildReport :: TestTree+testBuildReport = testCase "buildReport" $ do+  -- We could test more but we mostly just want to make sure we can run 'buildReport'.+  _ <- buildReport+  pure ()+ testVirtualReadWrite :: Api -> TestTree testVirtualReadWrite api = testCase ("virtual read write with " <> show api) $ do   let expectedCount = 3-      -- a simple note-on message-      message = [0x90, 0x51, 0x7f]       portName = "rtmidi-test-port"       -- 100 ms delay in us       delayUs = 100000+  -- First a check of api name+  name <- apiName api+  actualApi <- compiledApiByName name+  actualApi @?= api   countRef <- newIORef 0   -- Create reader with callback   inDev <- createInput api "rtmidi-test-input" 100@@ -38,7 +78,7 @@   let portNum = maybe (error "Could not find port") id maybePortNum   openPort outDev portNum portName   -- Send messages-  replicateM_ expectedCount (sendMessage outDev message)+  replicateM_ expectedCount (sendMessage outDev exampleMessage)   -- Sleep a bit to ensure message delivery   threadDelay delayUs   -- Close writer@@ -52,6 +92,12 @@ main :: IO () main = do   apis <- compiledApis-  when (null apis) (assertFailure "No compiled APIs found")-  let tests = fmap testVirtualReadWrite apis-  defaultMain (testGroup "RtMidi" tests)+  let rwTests = fmap testVirtualReadWrite (filter (/= DummyApi) apis)+      rwGroup = testGroup "R/W" rwTests+  defaultMain $ testGroup "RtMidi" $+    [ testApiName+    , testApiDisplayName+    , testCompiledApiByName+    , testBuildReport+    , rwGroup+    ]