diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,5 @@ # RtMidi -[![CircleCI](https://circleci.com/gh/riottracker/RtMidi/tree/master.svg?style=svg)](https://circleci.com/gh/riottracker/RtMidi/tree/master) - Haskell wrapper for [RtMidi](http://www.music.mcgill.ca/~gary/rtmidi/), the lightweight, cross-platform MIDI I/O library. ## How to use diff --git a/RtMidi.cabal b/RtMidi.cabal --- a/RtMidi.cabal +++ b/RtMidi.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: RtMidi -version: 0.5.0.3 +version: 0.6.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 @@ -34,7 +34,6 @@ other-modules: Sound.RtMidi.Foreign build-depends: base >=4.14 && <5 , 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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Sound/RtMidi.hs b/Sound/RtMidi.hs --- a/Sound/RtMidi.hs +++ b/Sound/RtMidi.hs @@ -35,13 +35,12 @@ , createOutput , sendMessage , currentApi - ) where + ) +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 @@ -51,6 +50,33 @@ import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) import GHC.Generics (Generic) import Sound.RtMidi.Foreign + ( Api (..) + , Wrapper (..) + , 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 + , rtmidi_in_cancel_callback + , rtmidi_in_create + , rtmidi_in_create_default + , rtmidi_in_free + , rtmidi_in_get_current_api + , rtmidi_in_get_message + , rtmidi_in_ignore_types + , rtmidi_in_set_callback + , rtmidi_open_port + , rtmidi_open_virtual_port + , rtmidi_out_create + , rtmidi_out_create_default + , rtmidi_out_free + , rtmidi_out_get_current_api + , rtmidi_out_send_message + , toApi + ) -- The default message size (in bytes) expected from 'getMessage' -- Mostly just needs to be bigger than the max MIDI message size, which is 3 bytes @@ -59,13 +85,13 @@ defaultMessageSize = 4 -- | Allows us to discriminate in/out functions in generic contexts -data DeviceType = - InputDeviceType +data DeviceType + = InputDeviceType | OutputDeviceType deriving stock (Eq, Show, Ord, Enum, Bounded, Generic) deriving anyclass (NFData) -newtype Device = Device { unDevice :: ForeignPtr Wrapper } +newtype Device = Device {unDevice :: ForeignPtr Wrapper} deriving stock (Eq, Show) -- | Generalizes 'InputDevice' and 'OutputDevice' for use in common functions @@ -74,7 +100,7 @@ getDeviceType :: d -> DeviceType -- | A handle to a device to be used for input -newtype InputDevice = InputDevice { unInputDevice :: Device } +newtype InputDevice = InputDevice {unInputDevice :: Device} deriving stock (Eq, Show) instance IsDevice InputDevice where @@ -85,7 +111,7 @@ newInputDevice = fmap (InputDevice . Device) . newForeignPtr rtmidi_in_free -- | A handle to a device to be used for input -newtype OutputDevice = OutputDevice { unOutputDevice :: Device } +newtype OutputDevice = OutputDevice {unOutputDevice :: Device} deriving stock (Eq, Show) instance IsDevice OutputDevice where @@ -96,7 +122,7 @@ newOutputDevice = fmap (OutputDevice . Device) . newForeignPtr rtmidi_out_free -- | An internal RtMidi error -newtype Error = Error { unError :: String } +newtype Error = Error {unError :: String} deriving stock (Eq, Show, Generic) deriving anyclass (NFData) @@ -119,24 +145,24 @@ 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) +apiDisplayName :: Api -> IO String +apiDisplayName api = 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) +apiName :: Api -> IO String +apiName api = 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)) +compiledApiByName :: String -> IO Api +compiledApiByName name = 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)) +ready :: IsDevice d => d -> IO Bool +ready d = withDevicePtr d (fmap ok . peek) -- | A static function to determine MIDI 'Api's built in. -compiledApis :: MonadIO m => m [Api] -compiledApis = liftIO $ do +compiledApis :: IO [Api] +compiledApis = do n <- fmap fromIntegral (rtmidi_get_compiled_api nullPtr 0) as <- allocaArray n $ \ptr -> do rtmidi_get_compiled_api ptr (fromIntegral n) @@ -144,37 +170,40 @@ pure (map toApi as) -- | Open a MIDI connection -openPort :: (MonadIO m, IsDevice d) - => d - -> Int -- ^ port number - -> String -- ^ name for the application port that is used - -> m () -openPort d n name = liftIO $ withDevicePtr d $ \dptr -> +openPort + :: IsDevice d + => d + -> Int + -- ^ port number + -> String + -- ^ name for the application port that is used + -> IO () +openPort d n name = withDevicePtr d $ \dptr -> withCString name (rtmidi_open_port dptr (toEnum n)) -- | This function creates a virtual MIDI output port to which other software applications can connect. -- -- This type of functionality is currently only supported by the Macintosh OS X, Linux ALSA and JACK APIs -- (the function does nothing with the other APIs). -openVirtualPort :: (MonadIO m, IsDevice d) => d -> String -> m () -openVirtualPort d name = liftIO $ withDevicePtr d $ \dptr -> do +openVirtualPort :: IsDevice d => d -> String -> IO () +openVirtualPort d name = withDevicePtr d $ \dptr -> do withCString name (rtmidi_open_virtual_port dptr) -- | Close an open MIDI connection (if one exists). -closePort :: (MonadIO m, IsDevice d) => d -> m () -closePort d = liftIO (withDevicePtr d rtmidi_close_port) +closePort :: IsDevice d => d -> IO () +closePort d = withDevicePtr d rtmidi_close_port -- | Return the number of MIDI ports available to the 'Device'. -portCount :: (MonadIO m, IsDevice d) => d -> m Int -portCount d = liftIO $ withDevicePtr d $ \dptr -> do +portCount :: IsDevice d => d -> IO Int +portCount d = withDevicePtr d $ \dptr -> do x <- rtmidi_get_port_count dptr pure (fromIntegral x) -- | Return a string identifier for the specified MIDI port number. -- -- 'Nothing' is returned if an invalid port specifier is provided. -portName :: (MonadIO m, IsDevice d) => d -> Int -> m (Maybe String) -portName d n = liftIO $ withDevicePtrUnguarded d $ \dptr -> do +portName :: IsDevice d => d -> Int -> IO (Maybe String) +portName d n = withDevicePtrUnguarded d $ \dptr -> do x <- rtmidi_get_port_name dptr (toEnum n) guardError dptr s <- peekCString x @@ -186,14 +215,15 @@ -- -- Note that the underlying library does not offer an "atomic" interface for this -- so results may be inconsistent if you connect/disconnect ports during this call. -listPorts :: (MonadIO m, IsDevice d) => d -> m [(Int, String)] -listPorts d = liftIO $ portCount d >>= go [] 0 where +listPorts :: IsDevice d => d -> IO [(Int, String)] +listPorts d = portCount d >>= go [] 0 + where go acc i c = if i >= c then pure (reverse acc) else do mn <- portName d i - let acc' = maybe acc (\n -> (i, n):acc) mn + let acc' = maybe acc (\n -> (i, n) : acc) mn go acc' (succ i) c -- | Convenience function to lookup the first port satisfying the predicate. @@ -208,8 +238,9 @@ -- -- Note that if you are performing many lookups, it's better to use 'listPorts' and -- do the lookups yourself (see the caveats there too). -findPort :: (MonadIO m, IsDevice d) => d -> (String -> Bool) -> m (Maybe Int) -findPort d f = liftIO $ portCount d >>= go 0 where +findPort :: IsDevice d => d -> (String -> Bool) -> IO (Maybe Int) +findPort d f = portCount d >>= go 0 + where go i c = if i >= c then pure Nothing @@ -220,19 +251,22 @@ _ -> go (succ i) c -- | Default constructor for a 'Device' to use for input. -defaultInput :: MonadIO m => m InputDevice -defaultInput = liftIO $ do +defaultInput :: IO InputDevice +defaultInput = do dptr <- rtmidi_in_create_default guardError dptr newInputDevice dptr -- | Create a new 'Device' to use for input. -createInput :: MonadIO m - => Api -- ^ API to use - -> String -- ^ client name - -> Int -- ^ size of the MIDI input queue - -> m InputDevice -createInput api clientName queueSizeLimit = liftIO $ do +createInput + :: Api + -- ^ API to use + -> String + -- ^ client name + -> Int + -- ^ size of the MIDI input queue + -> IO InputDevice +createInput api clientName queueSizeLimit = do dptr <- withCString clientName (\str -> rtmidi_in_create (fromApi api) str (fromIntegral queueSizeLimit)) guardError dptr newInputDevice dptr @@ -253,21 +287,22 @@ -- The callback function will be called whenever an incoming MIDI message is received. -- While not absolutely necessary, it is best to set the callback function before opening a MIDI port to avoid leaving -- some messages in the queue. -setCallback :: MonadUnliftIO m - => InputDevice - -> (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))) +setCallback + :: InputDevice + -> (Double -> VS.Vector Word8 -> IO ()) + -- ^ Function that takes a timestamp and a MIDI message as arguments + -> IO () +setCallback d c = withDevicePtr d $ \dptr -> do + f <- mkCallbackPointer (adaptCallbackCTypes c) 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 +setUnsafeCallback + :: InputDevice + -> (Double -> Ptr Word8 -> Int -> IO ()) + -> IO () +setUnsafeCallback d c = withDevicePtr d $ \dptr -> do f <- mkCallbackPointer (adaptUnsafeCallbackCTypes c) rtmidi_in_set_callback dptr f nullPtr @@ -275,36 +310,40 @@ -- -- This variant allows you to set the callback to a C function pointer so we're not forced -- to enter a Haskell wrapper every invocation. -setForeignCallback :: MonadIO m - => InputDevice - -> FunPtr (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ()) - -> Ptr () -- ^ Pointer to context that will be passed into the callback - -> m () -setForeignCallback d f ctx = liftIO $ withDevicePtr d $ \dptr -> +setForeignCallback + :: InputDevice + -> FunPtr (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ()) + -> Ptr () + -- ^ Pointer to context that will be passed into the callback + -> IO () +setForeignCallback d f ctx = withDevicePtr d $ \dptr -> rtmidi_in_set_callback dptr f ctx -- | Cancel use of the current callback function (if one exists). -- -- Subsequent incoming MIDI messages will be written to the queue and can be retrieved with the `getMessage` function. -cancelCallback :: MonadIO m => InputDevice -> m () -cancelCallback d = liftIO (withDevicePtr d rtmidi_in_cancel_callback) +cancelCallback :: InputDevice -> IO () +cancelCallback d = withDevicePtr d rtmidi_in_cancel_callback -- | Specify whether certain MIDI message types should be queued or ignored during input. -- -- 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. -ignoreTypes :: MonadIO m - => InputDevice - -> Bool -- ^ SysEx messages - -> Bool -- ^ Time messages - -> Bool -- ^ Sense messages - -> m () -ignoreTypes d x y z = liftIO (withDevicePtrUnguarded d (\dptr -> rtmidi_in_ignore_types dptr x y z)) +ignoreTypes + :: InputDevice + -> Bool + -- ^ SysEx messages + -> Bool + -- ^ Time messages + -> Bool + -- ^ Sense messages + -> IO () +ignoreTypes d x y z = withDevicePtrUnguarded d (\dptr -> rtmidi_in_ignore_types dptr x y z) -- | 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 +getMessageMutable :: InputDevice -> VSM.IOVector Word8 -> IO (Double, Int) +getMessageMutable d buf = 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 @@ -313,8 +352,8 @@ 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 +getMessageSized :: InputDevice -> Int -> IO (Double, VS.Vector Word8) +getMessageSized d n = do buf <- VSM.new n (!timestamp, !size) <- getMessageMutable d buf vec <- VSM.unsafeWith buf (VS.generateM size . peekElemOff) @@ -325,34 +364,36 @@ -- 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, VS.Vector Word8) -getMessage d = liftIO (getMessageSized d defaultMessageSize) +getMessage :: InputDevice -> IO (Double, VS.Vector Word8) +getMessage d = getMessageSized d defaultMessageSize -- | Default constructor for a 'Device' to use for output. -defaultOutput :: MonadIO m => m OutputDevice -defaultOutput = liftIO $ do +defaultOutput :: IO OutputDevice +defaultOutput = do dptr <- rtmidi_out_create_default guardError dptr newOutputDevice dptr -- | Create a new 'Device' to use for output. -createOutput :: MonadIO m - => Api -- ^ API to use - -> String -- ^ client name - -> m OutputDevice -createOutput api clientName = liftIO $ do +createOutput + :: Api + -- ^ API to use + -> String + -- ^ client name + -> IO OutputDevice +createOutput api clientName = do 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 -> VS.Vector Word8 -> m () -sendMessage d buf = liftIO $ VS.unsafeWith buf $ \m -> withDevicePtr d $ \dptr -> +sendMessage :: OutputDevice -> VS.Vector Word8 -> IO () +sendMessage d buf = 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 -currentApi d = liftIO $ withDevicePtr d $ \dptr -> do +currentApi :: IsDevice d => d -> IO Api +currentApi d = withDevicePtr d $ \dptr -> do res <- case getDeviceType d of InputDeviceType -> rtmidi_in_get_current_api dptr diff --git a/Sound/RtMidi/Report.hs b/Sound/RtMidi/Report.hs --- a/Sound/RtMidi/Report.hs +++ b/Sound/RtMidi/Report.hs @@ -7,13 +7,24 @@ , buildApiReport , buildCustomReport , buildReport - ) where + ) +where import Control.DeepSeq (NFData) -import Control.Monad.IO.Class (MonadIO) import Data.List (nub) import GHC.Generics (Generic) import Sound.RtMidi + ( Api + , apiDisplayName + , apiName + , compiledApis + , createInput + , createOutput + , currentApi + , defaultInput + , defaultOutput + , listPorts + ) -- | MIDI system information specific to a particular API. data ApiReport = ApiReport @@ -22,19 +33,21 @@ , apiRepDisplayName :: !String , apiInPorts :: ![(Int, String)] , apiOutPorts :: ![(Int, String)] - } deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) + } + 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) + } + 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 -> IO ApiReport buildApiReport api = do name <- apiName api displayName <- apiDisplayName api @@ -45,9 +58,10 @@ 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 + :: Bool + -- ^ True to report on default APIs, False to report on all compiled APIs. + -> IO Report buildCustomReport defaultOnly = do inDev <- defaultInput defInApi <- currentApi inDev @@ -58,5 +72,5 @@ pure (Report defInApi defOutApi apiReps) -- | Gather information about all compiled APIs. -buildReport :: MonadIO m => m Report +buildReport :: IO Report buildReport = buildCustomReport False diff --git a/examples/callback.hs b/examples/callback.hs --- a/examples/callback.hs +++ b/examples/callback.hs @@ -4,7 +4,7 @@ import Sound.RtMidi (closePort, defaultInput, openPort, setCallback) callback :: Double -> VS.Vector Word8 -> IO () -callback delta msg = putStrLn $ (VS.foldr (showHex . fromEnum) "" msg) ++ " - " ++ (show delta) +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,13 +1,13 @@ import Control.Concurrent (threadDelay) import qualified Data.Vector.Storable as VS -import Sound.RtMidi (closePort, defaultOutput, openPort, sendMessage, portCount, portName) +import Sound.RtMidi (closePort, defaultOutput, openPort, portCount, portName, sendMessage) main :: IO () main = do device <- defaultOutput numPorts <- portCount device - ports <- mapM (portName device) [0..numPorts-1] - mapM_ (\t -> putStrLn $ show t) $ zip [0..] ports + ports <- mapM (portName device) [0 .. numPorts - 1] + mapM_ print $ zip [0 ..] ports putStrLn "select port: " selection <- getLine openPort device (read selection) "RtMidi" diff --git a/examples/poll.hs b/examples/poll.hs --- a/examples/poll.hs +++ b/examples/poll.hs @@ -1,14 +1,12 @@ import Control.Concurrent (forkIO, killThread) -import Control.Monad (forever) +import Control.Monad (forever, when) 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 VS.length (snd m) > 0 then - putStrLn $ show m - else return () + when (VS.length (snd m) > 0) $ print m main :: IO () main = do diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,11 +3,12 @@ import Control.Concurrent (threadDelay) import Control.Monad (replicateM_, unless, when) import Data.Foldable (for_) -import Data.IORef (IORef, newIORef, readIORef, modifyIORef) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef) import Data.List (isInfixOf) +import Data.Maybe (fromMaybe) import qualified Data.Vector.Storable as VS import Data.Word (Word8) -import Sound.RtMidi (Api (..), apiName, apiDisplayName, closePort, compiledApiByName, compiledApis, createInput, createOutput, currentApi, findPort, sendMessage, setCallback, openPort, openVirtualPort) +import Sound.RtMidi (Api (..), apiDisplayName, apiName, closePort, compiledApiByName, compiledApis, createInput, createOutput, currentApi, findPort, openPort, openVirtualPort, sendMessage, setCallback) import Sound.RtMidi.Report (Report, buildReport) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) @@ -75,7 +76,7 @@ outApi <- currentApi outDev outApi @?= api maybePortNum <- findPort outDev (isInfixOf portName) - let portNum = maybe (error "Could not find port") id maybePortNum + let portNum = fromMaybe (error "Could not find port") maybePortNum openPort outDev portNum portName -- Send messages replicateM_ expectedCount (sendMessage outDev exampleMessage) @@ -94,10 +95,12 @@ apis <- compiledApis let rwTests = fmap testVirtualReadWrite (filter (/= DummyApi) apis) rwGroup = testGroup "R/W" rwTests - defaultMain $ testGroup "RtMidi" $ - [ testApiName - , testApiDisplayName - , testCompiledApiByName - , testBuildReport - , rwGroup - ] + defaultMain $ + testGroup + "RtMidi" + [ testApiName + , testApiDisplayName + , testCompiledApiByName + , testBuildReport + , rwGroup + ]