diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/RtMidi.cabal b/RtMidi.cabal --- a/RtMidi.cabal +++ b/RtMidi.cabal @@ -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 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 diff --git a/Sound/RtMidi.hs b/Sound/RtMidi.hs --- a/Sound/RtMidi.hs +++ b/Sound/RtMidi.hs @@ -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) diff --git a/Sound/RtMidi/Foreign.hsc b/Sound/RtMidi/Foreign.hsc --- a/Sound/RtMidi/Foreign.hsc +++ b/Sound/RtMidi/Foreign.hsc @@ -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 diff --git a/Sound/RtMidi/Report.hs b/Sound/RtMidi/Report.hs new file mode 100644 --- /dev/null +++ b/Sound/RtMidi/Report.hs @@ -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 diff --git a/examples/callback.hs b/examples/callback.hs --- a/examples/callback.hs +++ b/examples/callback.hs @@ -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 diff --git a/examples/playback.hs b/examples/playback.hs --- a/examples/playback.hs +++ b/examples/playback.hs @@ -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 diff --git a/examples/poll.hs b/examples/poll.hs --- a/examples/poll.hs +++ b/examples/poll.hs @@ -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 () diff --git a/examples/query.hs b/examples/query.hs deleted file mode 100644 --- a/examples/query.hs +++ /dev/null @@ -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) diff --git a/examples/report.hs b/examples/report.hs new file mode 100644 --- /dev/null +++ b/examples/report.hs @@ -0,0 +1,5 @@ +import Sound.RtMidi.Report (buildReport) +import Text.Pretty.Simple (pPrint) + +main :: IO () +main = buildReport >>= pPrint diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 + ]