-- | Interface to RtMidi
module Sound.RtMidi
  ( InputDevice
  , OutputDevice
  , IsDevice (getDeviceType)
  , DeviceType (..)
  , Api (..)
  , Error (..)
  , ready
  , compiledApis
  , openPort
  , openVirtualPort
  , closePort
  , portCount
  , portName
  , listPorts
  , findPort
  , defaultInput
  , createInput
  , setCallback
  , cancelCallback
  , ignoreTypes
  , getMessage
  , getMessageSized
  , defaultOutput
  , createOutput
  , sendMessage
  , closeDevice
  , currentApi
  ) where

import Control.Exception (Exception, throwIO)
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Unlift (MonadUnliftIO (..))
import Data.Coerce (coerce)
import Data.Word (Word8)
import Foreign (FunPtr, Ptr, Storable (..), alloca, allocaArray, nullPtr, peekArray, with, withArrayLen)
import Foreign.C (CDouble (..), CInt (..), CSize, CString, CUChar (..), peekCString, withCString)
import Sound.RtMidi.Foreign

-- 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
-- However, sysex messages can be quite large, so you might have to use the 'getMessageSized' variant.
defaultMessageSize :: Int
defaultMessageSize :: Int
defaultMessageSize = 4

-- | Allows us to discriminate in/out functions in generic contexts
data DeviceType =
    InputDeviceType
  | OutputDeviceType
  deriving (DeviceType -> DeviceType -> Bool
(DeviceType -> DeviceType -> Bool)
-> (DeviceType -> DeviceType -> Bool) -> Eq DeviceType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeviceType -> DeviceType -> Bool
$c/= :: DeviceType -> DeviceType -> Bool
== :: DeviceType -> DeviceType -> Bool
$c== :: DeviceType -> DeviceType -> Bool
Eq, Int -> DeviceType -> ShowS
[DeviceType] -> ShowS
DeviceType -> String
(Int -> DeviceType -> ShowS)
-> (DeviceType -> String)
-> ([DeviceType] -> ShowS)
-> Show DeviceType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeviceType] -> ShowS
$cshowList :: [DeviceType] -> ShowS
show :: DeviceType -> String
$cshow :: DeviceType -> String
showsPrec :: Int -> DeviceType -> ShowS
$cshowsPrec :: Int -> DeviceType -> ShowS
Show)

newtype Device = Device { Device -> Ptr Wrapper
unDevice :: Ptr Wrapper }
  deriving (Device -> Device -> Bool
(Device -> Device -> Bool)
-> (Device -> Device -> Bool) -> Eq Device
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Device -> Device -> Bool
$c/= :: Device -> Device -> Bool
== :: Device -> Device -> Bool
$c== :: Device -> Device -> Bool
Eq, Int -> Device -> ShowS
[Device] -> ShowS
Device -> String
(Int -> Device -> ShowS)
-> (Device -> String) -> ([Device] -> ShowS) -> Show Device
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Device] -> ShowS
$cshowList :: [Device] -> ShowS
show :: Device -> String
$cshow :: Device -> String
showsPrec :: Int -> Device -> ShowS
$cshowsPrec :: Int -> Device -> ShowS
Show)

-- | Generalizes 'InputDevice' and 'OutputDevice' for use in common functions
class IsDevice d where
  toDevice :: d -> Device
  getDeviceType :: d -> DeviceType

toDevicePtr :: IsDevice d => d -> Ptr Wrapper
toDevicePtr :: d -> Ptr Wrapper
toDevicePtr = Device -> Ptr Wrapper
unDevice (Device -> Ptr Wrapper) -> (d -> Device) -> d -> Ptr Wrapper
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Device
forall d. IsDevice d => d -> Device
toDevice

-- | A handle to a device to be used for input
newtype InputDevice = InputDevice { InputDevice -> Device
unInputDevice :: Device }
  deriving (InputDevice -> InputDevice -> Bool
(InputDevice -> InputDevice -> Bool)
-> (InputDevice -> InputDevice -> Bool) -> Eq InputDevice
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InputDevice -> InputDevice -> Bool
$c/= :: InputDevice -> InputDevice -> Bool
== :: InputDevice -> InputDevice -> Bool
$c== :: InputDevice -> InputDevice -> Bool
Eq, Int -> InputDevice -> ShowS
[InputDevice] -> ShowS
InputDevice -> String
(Int -> InputDevice -> ShowS)
-> (InputDevice -> String)
-> ([InputDevice] -> ShowS)
-> Show InputDevice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputDevice] -> ShowS
$cshowList :: [InputDevice] -> ShowS
show :: InputDevice -> String
$cshow :: InputDevice -> String
showsPrec :: Int -> InputDevice -> ShowS
$cshowsPrec :: Int -> InputDevice -> ShowS
Show)

instance IsDevice InputDevice where
  toDevice :: InputDevice -> Device
toDevice = InputDevice -> Device
unInputDevice
  getDeviceType :: InputDevice -> DeviceType
getDeviceType _ = DeviceType
InputDeviceType

-- | A handle to a device to be used for input
newtype OutputDevice = OutputDevice { OutputDevice -> Device
unOutputDevice :: Device }
  deriving (OutputDevice -> OutputDevice -> Bool
(OutputDevice -> OutputDevice -> Bool)
-> (OutputDevice -> OutputDevice -> Bool) -> Eq OutputDevice
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputDevice -> OutputDevice -> Bool
$c/= :: OutputDevice -> OutputDevice -> Bool
== :: OutputDevice -> OutputDevice -> Bool
$c== :: OutputDevice -> OutputDevice -> Bool
Eq, Int -> OutputDevice -> ShowS
[OutputDevice] -> ShowS
OutputDevice -> String
(Int -> OutputDevice -> ShowS)
-> (OutputDevice -> String)
-> ([OutputDevice] -> ShowS)
-> Show OutputDevice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutputDevice] -> ShowS
$cshowList :: [OutputDevice] -> ShowS
show :: OutputDevice -> String
$cshow :: OutputDevice -> String
showsPrec :: Int -> OutputDevice -> ShowS
$cshowsPrec :: Int -> OutputDevice -> ShowS
Show)

instance IsDevice OutputDevice where
  toDevice :: OutputDevice -> Device
toDevice = OutputDevice -> Device
unOutputDevice
  getDeviceType :: OutputDevice -> DeviceType
getDeviceType _ = DeviceType
OutputDeviceType

-- | Enum of RtMidi-supported APIs
data Api
  = UnspecifiedApi
  | CoreMidiApi
  | AlsaApi
  | JackApi
  | MultimediaApi
  | KernelStreamingApi
  | DummyApi
  deriving (Api -> Api -> Bool
(Api -> Api -> Bool) -> (Api -> Api -> Bool) -> Eq Api
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Api -> Api -> Bool
$c/= :: Api -> Api -> Bool
== :: Api -> Api -> Bool
$c== :: Api -> Api -> Bool
Eq, Int -> Api -> ShowS
[Api] -> ShowS
Api -> String
(Int -> Api -> ShowS)
-> (Api -> String) -> ([Api] -> ShowS) -> Show Api
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Api] -> ShowS
$cshowList :: [Api] -> ShowS
show :: Api -> String
$cshow :: Api -> String
showsPrec :: Int -> Api -> ShowS
$cshowsPrec :: Int -> Api -> ShowS
Show)

instance Enum Api where
  fromEnum :: Api -> Int
fromEnum UnspecifiedApi = 0
  fromEnum CoreMidiApi = 1
  fromEnum AlsaApi = 2
  fromEnum JackApi = 3
  fromEnum MultimediaApi = 4
  fromEnum DummyApi = 5
  toEnum :: Int -> Api
toEnum 0 = Api
UnspecifiedApi
  toEnum 1 = Api
CoreMidiApi
  toEnum 2 = Api
AlsaApi
  toEnum 3 = Api
JackApi
  toEnum 4 = Api
MultimediaApi
  toEnum 5 = Api
DummyApi

-- | Check if a device is ok
ready :: (MonadIO m, IsDevice d) => d -> m Bool
ready :: d -> m Bool
ready = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> (d -> IO Bool) -> d -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Wrapper -> Bool) -> IO Wrapper -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Wrapper -> Bool
ok (IO Wrapper -> IO Bool) -> (d -> IO Wrapper) -> d -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Wrapper -> IO Wrapper
forall a. Storable a => Ptr a -> IO a
peek  (Ptr Wrapper -> IO Wrapper)
-> (d -> Ptr Wrapper) -> d -> IO Wrapper
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr

-- | An internal RtMidi error
newtype Error = Error String deriving (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)
instance Exception Error

-- Detects and throws internal errors
guardError :: Ptr Wrapper -> IO ()
guardError :: Ptr Wrapper -> IO ()
guardError dptr :: Ptr Wrapper
dptr = do
  Wrapper
w <- Ptr Wrapper -> IO Wrapper
forall a. Storable a => Ptr a -> IO a
peek Ptr Wrapper
dptr
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Wrapper -> Bool
ok Wrapper
w) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String
e <- CString -> IO String
peekCString (Wrapper -> CString
msg Wrapper
w)
    Error -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> Error
Error String
e)

-- | A static function to determine MIDI 'Api's built in.
compiledApis :: MonadIO m => m [Api]
compiledApis :: m [Api]
compiledApis = IO [Api] -> m [Api]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Api] -> m [Api]) -> IO [Api] -> m [Api]
forall a b. (a -> b) -> a -> b
$ do
  Int
n <- (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Ptr (Ptr CInt) -> IO CInt
rtmidi_get_compiled_api Ptr (Ptr CInt)
forall a. Ptr a
nullPtr)
  [CInt]
as <- Int -> (Ptr CInt -> IO [CInt]) -> IO [CInt]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
n ((Ptr CInt -> IO [CInt]) -> IO [CInt])
-> (Ptr CInt -> IO [CInt]) -> IO [CInt]
forall a b. (a -> b) -> a -> b
$ (Ptr CInt -> (Ptr (Ptr CInt) -> IO [CInt]) -> IO [CInt])
-> (Ptr (Ptr CInt) -> IO [CInt]) -> Ptr CInt -> IO [CInt]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr CInt -> (Ptr (Ptr CInt) -> IO [CInt]) -> IO [CInt]
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with ((Ptr (Ptr CInt) -> IO [CInt]) -> Ptr CInt -> IO [CInt])
-> (Ptr (Ptr CInt) -> IO [CInt]) -> Ptr CInt -> IO [CInt]
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr (Ptr CInt)
ptr -> do
    Ptr (Ptr CInt) -> IO CInt
rtmidi_get_compiled_api Ptr (Ptr CInt)
ptr
    Ptr CInt
x <- Ptr (Ptr CInt) -> IO (Ptr CInt)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CInt)
ptr
    Int -> Ptr CInt -> IO [CInt]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
n Ptr CInt
x
  [Api] -> IO [Api]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CInt -> Api) -> [CInt] -> [Api]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Api
forall a. Enum a => Int -> a
toEnum (Int -> Api) -> (CInt -> Int) -> CInt -> Api
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> Int
forall a. Enum a => a -> Int
fromEnum) [CInt]
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 -> Int -> String -> m ()
openPort d :: d
d n :: Int
n name :: String
name = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let dptr :: Ptr Wrapper
dptr = d -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr d
d
  String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
name (Ptr Wrapper -> CInt -> CString -> IO ()
rtmidi_open_port Ptr Wrapper
dptr (Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
n))
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr

-- | 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 -> String -> m ()
openVirtualPort d :: d
d name :: String
name = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let dptr :: Ptr Wrapper
dptr = d -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr d
d
  String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
name (Ptr Wrapper -> CString -> IO ()
rtmidi_open_virtual_port Ptr Wrapper
dptr)
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr

-- | Close an open MIDI connection (if one exists).
closePort :: (MonadIO m, IsDevice d) => d -> m ()
closePort :: d -> m ()
closePort d :: d
d = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let dptr :: Ptr Wrapper
dptr = d -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr d
d
  Ptr Wrapper -> IO ()
rtmidi_close_port Ptr Wrapper
dptr
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr

-- | Return the number of MIDI ports available to the 'Device'.
portCount :: (MonadIO m, IsDevice d) => d -> m Int
portCount :: d -> m Int
portCount d :: d
d = IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ do
  let dptr :: Ptr Wrapper
dptr = d -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr d
d
  CInt
x <- Ptr Wrapper -> IO CInt
rtmidi_get_port_count Ptr Wrapper
dptr
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr
  Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
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 -> Int -> m (Maybe String)
portName d :: d
d n :: Int
n = IO (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
  let dptr :: Ptr Wrapper
dptr = d -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr d
d
  CString
x <- Ptr Wrapper -> CInt -> IO CString
rtmidi_get_port_name Ptr Wrapper
dptr (Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
n)
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr
  String
s <- CString -> IO String
peekCString CString
x
  case String
s of
    [] -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    _ -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
s)

-- | Convenience function to list ports.
--
-- 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 -> m [(Int, String)]
listPorts d :: d
d = IO [(Int, String)] -> m [(Int, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Int, String)] -> m [(Int, String)])
-> IO [(Int, String)] -> m [(Int, String)]
forall a b. (a -> b) -> a -> b
$ d -> IO Int
forall (m :: * -> *) d. (MonadIO m, IsDevice d) => d -> m Int
portCount d
d IO Int -> (Int -> IO [(Int, String)]) -> IO [(Int, String)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Int, String)] -> Int -> Int -> IO [(Int, String)]
forall (f :: * -> *).
MonadIO f =>
[(Int, String)] -> Int -> Int -> f [(Int, String)]
go [] 0 where
  go :: [(Int, String)] -> Int -> Int -> f [(Int, String)]
go acc :: [(Int, String)]
acc i :: Int
i c :: Int
c =
    if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
c
      then [(Int, String)] -> f [(Int, String)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Int, String)] -> [(Int, String)]
forall a. [a] -> [a]
reverse [(Int, String)]
acc)
      else do
        Maybe String
mn <- d -> Int -> f (Maybe String)
forall (m :: * -> *) d.
(MonadIO m, IsDevice d) =>
d -> Int -> m (Maybe String)
portName d
d Int
i
        let acc' :: [(Int, String)]
acc' = [(Int, String)]
-> (String -> [(Int, String)]) -> Maybe String -> [(Int, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(Int, String)]
acc (\n :: String
n -> (Int
i, String
n)(Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:[(Int, String)]
acc) Maybe String
mn
        [(Int, String)] -> Int -> Int -> f [(Int, String)]
go [(Int, String)]
acc' (Int -> Int
forall a. Enum a => a -> a
succ Int
i) Int
c

-- | Convenience function to lookup the first port satisfying the predicate.
--
-- You may want to find an exact name:
--
-- > findPort d (== name)
--
-- Or you may want to match part of a name:
--
-- > findPort d (isInfixOf name)
--
-- 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 -> (String -> Bool) -> m (Maybe Int)
findPort d :: d
d f :: String -> Bool
f = IO (Maybe Int) -> m (Maybe Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Int) -> m (Maybe Int))
-> IO (Maybe Int) -> m (Maybe Int)
forall a b. (a -> b) -> a -> b
$ d -> IO Int
forall (m :: * -> *) d. (MonadIO m, IsDevice d) => d -> m Int
portCount d
d IO Int -> (Int -> IO (Maybe Int)) -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> IO (Maybe Int)
forall (f :: * -> *). MonadIO f => Int -> Int -> f (Maybe Int)
go 0 where
  go :: Int -> Int -> f (Maybe Int)
go i :: Int
i c :: Int
c =
    if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
c
      then Maybe Int -> f (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
      else do
        Maybe String
mn <- d -> Int -> f (Maybe String)
forall (m :: * -> *) d.
(MonadIO m, IsDevice d) =>
d -> Int -> m (Maybe String)
portName d
d Int
i
        case Maybe String
mn of
          Just n :: String
n | String -> Bool
f String
n -> Maybe Int -> f (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i)
          _ -> Int -> Int -> f (Maybe Int)
go (Int -> Int
forall a. Enum a => a -> a
succ Int
i) Int
c

-- | Default constructor for a 'Device' to use for input.
defaultInput :: MonadIO m => m InputDevice
defaultInput :: m InputDevice
defaultInput = IO InputDevice -> m InputDevice
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InputDevice -> m InputDevice)
-> IO InputDevice -> m InputDevice
forall a b. (a -> b) -> a -> b
$ do
  Ptr Wrapper
dptr <- IO (Ptr Wrapper)
rtmidi_in_create_default
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr
  InputDevice -> IO InputDevice
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Device -> InputDevice
InputDevice (Ptr Wrapper -> Device
Device Ptr Wrapper
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 -> String -> Int -> m InputDevice
createInput api :: Api
api clientName :: String
clientName queueSizeLimit :: Int
queueSizeLimit = IO InputDevice -> m InputDevice
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InputDevice -> m InputDevice)
-> IO InputDevice -> m InputDevice
forall a b. (a -> b) -> a -> b
$ do
  Ptr Wrapper
dptr <- String -> (CString -> IO (Ptr Wrapper)) -> IO (Ptr Wrapper)
forall a. String -> (CString -> IO a) -> IO a
withCString String
clientName (\str :: CString
str -> CInt -> CString -> CInt -> IO (Ptr Wrapper)
rtmidi_in_create (Int -> CInt
forall a. Enum a => Int -> a
toEnum (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Api -> Int
forall a. Enum a => a -> Int
fromEnum Api
api) CString
str (Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
queueSizeLimit))
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr
  InputDevice -> IO InputDevice
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Device -> InputDevice
InputDevice (Ptr Wrapper -> Device
Device Ptr Wrapper
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 :: (Double -> [Word8] -> IO ())
-> CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ()
adaptCallbackCTypes f :: Double -> [Word8] -> IO ()
f (CDouble t :: Double
t) d :: Ptr CUChar
d s :: CInt
s _ = Int -> Ptr CUChar -> IO [CUChar]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
s) Ptr CUChar
d IO [CUChar] -> ([CUChar] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a :: [CUChar]
a -> Double -> [Word8] -> IO ()
f Double
t ([CUChar] -> [Word8]
forall a b. Coercible a b => a -> b
coerce [CUChar]
a)

-- | Set a callback function to be invoked for incoming MIDI messages.
--
-- 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 -> [Word8] -> m ())  -- ^ Function that takes a timestamp and a MIDI message as arguments
            -> m ()
setCallback :: InputDevice -> (Double -> [Word8] -> m ()) -> m ()
setCallback d :: InputDevice
d c :: Double -> [Word8] -> m ()
c = ((forall a. m a -> IO a) -> IO ()) -> m ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \run :: forall a. m a -> IO a
run -> do
  let dptr :: Ptr Wrapper
dptr = InputDevice -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr InputDevice
d
  FunPtr (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ())
f <- (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ())
-> IO (FunPtr (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ()))
mkCallbackPointer ((Double -> [Word8] -> IO ())
-> CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ()
adaptCallbackCTypes (\ts :: Double
ts bytes :: [Word8]
bytes -> m () -> IO ()
forall a. m a -> IO a
run (Double -> [Word8] -> m ()
c Double
ts [Word8]
bytes)))
  Ptr Wrapper
-> FunPtr (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ())
-> Ptr ()
-> IO ()
rtmidi_in_set_callback Ptr Wrapper
dptr FunPtr (CDouble -> Ptr CUChar -> CInt -> Ptr () -> IO ())
f Ptr ()
forall a. Ptr a
nullPtr
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr

-- | 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 :: InputDevice -> m ()
cancelCallback d :: InputDevice
d = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let dptr :: Ptr Wrapper
dptr = InputDevice -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr InputDevice
d
  Ptr Wrapper -> IO ()
rtmidi_in_cancel_callback Ptr Wrapper
dptr
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr

-- | 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 :: InputDevice -> Bool -> Bool -> Bool -> m ()
ignoreTypes d :: InputDevice
d x :: Bool
x y :: Bool
y z :: Bool
z = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Wrapper -> Bool -> Bool -> Bool -> IO ()
rtmidi_in_ignore_types (InputDevice -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr InputDevice
d) Bool
x Bool
y Bool
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 :: InputDevice -> Int -> m (Double, [Word8])
getMessageSized d :: InputDevice
d n :: Int
n = IO (Double, [Word8]) -> m (Double, [Word8])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Double, [Word8]) -> m (Double, [Word8]))
-> IO (Double, [Word8]) -> m (Double, [Word8])
forall a b. (a -> b) -> a -> b
$ (Ptr CSize -> IO (Double, [Word8])) -> IO (Double, [Word8])
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO (Double, [Word8])) -> IO (Double, [Word8]))
-> (Ptr CSize -> IO (Double, [Word8])) -> IO (Double, [Word8])
forall a b. (a -> b) -> a -> b
$ \s :: Ptr CSize
s -> Int -> (Ptr CUChar -> IO (Double, [Word8])) -> IO (Double, [Word8])
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
n ((Ptr CUChar -> IO (Double, [Word8])) -> IO (Double, [Word8]))
-> (Ptr CUChar -> IO (Double, [Word8])) -> IO (Double, [Word8])
forall a b. (a -> b) -> a -> b
$ (Ptr CUChar
 -> (Ptr (Ptr CUChar) -> IO (Double, [Word8]))
 -> IO (Double, [Word8]))
-> (Ptr (Ptr CUChar) -> IO (Double, [Word8]))
-> Ptr CUChar
-> IO (Double, [Word8])
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr CUChar
-> (Ptr (Ptr CUChar) -> IO (Double, [Word8]))
-> IO (Double, [Word8])
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with ((Ptr (Ptr CUChar) -> IO (Double, [Word8]))
 -> Ptr CUChar -> IO (Double, [Word8]))
-> (Ptr (Ptr CUChar) -> IO (Double, [Word8]))
-> Ptr CUChar
-> IO (Double, [Word8])
forall a b. (a -> b) -> a -> b
$ \m :: Ptr (Ptr CUChar)
m -> do
  let dptr :: Ptr Wrapper
dptr = InputDevice -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr InputDevice
d
  Ptr CSize -> CSize -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CSize
s (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  CDouble timestamp :: Double
timestamp <- Ptr Wrapper -> Ptr (Ptr CUChar) -> Ptr CSize -> IO CDouble
rtmidi_in_get_message Ptr Wrapper
dptr Ptr (Ptr CUChar)
m Ptr CSize
s
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr
  CSize
size <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
s
  [Word8]
message <-
    case CSize
size of
      0 -> [Word8] -> IO [Word8]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      _ -> do
        Ptr CUChar
x <- Ptr (Ptr CUChar) -> IO (Ptr CUChar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CUChar)
m
        [CUChar]
y <- Int -> Ptr CUChar -> IO [CUChar]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
size) Ptr CUChar
x
        [Word8] -> IO [Word8]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CUChar] -> [Word8]
forall a b. Coercible a b => a -> b
coerce [CUChar]
y)
  (Double, [Word8]) -> IO (Double, [Word8])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
timestamp, [Word8]
message)

-- | 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 :: InputDevice -> m (Double, [Word8])
getMessage d :: InputDevice
d = IO (Double, [Word8]) -> m (Double, [Word8])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (InputDevice -> Int -> IO (Double, [Word8])
forall (m :: * -> *).
MonadIO m =>
InputDevice -> Int -> m (Double, [Word8])
getMessageSized InputDevice
d Int
defaultMessageSize)

-- | Default constructor for a 'Device' to use for output.
defaultOutput :: MonadIO m => m OutputDevice
defaultOutput :: m OutputDevice
defaultOutput = IO OutputDevice -> m OutputDevice
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OutputDevice -> m OutputDevice)
-> IO OutputDevice -> m OutputDevice
forall a b. (a -> b) -> a -> b
$ do
  Ptr Wrapper
dptr <- IO (Ptr Wrapper)
rtmidi_out_create_default
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr
  OutputDevice -> IO OutputDevice
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Device -> OutputDevice
OutputDevice (Ptr Wrapper -> Device
Device Ptr Wrapper
dptr))

-- | Create a new 'Device' to use for output.
createOutput :: MonadIO m
             => Api        -- ^ API to use
             -> String     -- ^ client name
             -> m OutputDevice
createOutput :: Api -> String -> m OutputDevice
createOutput api :: Api
api clientName :: String
clientName = IO OutputDevice -> m OutputDevice
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OutputDevice -> m OutputDevice)
-> IO OutputDevice -> m OutputDevice
forall a b. (a -> b) -> a -> b
$ do
  Ptr Wrapper
dptr <- String -> (CString -> IO (Ptr Wrapper)) -> IO (Ptr Wrapper)
forall a. String -> (CString -> IO a) -> IO a
withCString String
clientName (CInt -> CString -> IO (Ptr Wrapper)
rtmidi_out_create (Int -> CInt
forall a. Enum a => Int -> a
toEnum (Api -> Int
forall a. Enum a => a -> Int
fromEnum Api
api)))
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr
  OutputDevice -> IO OutputDevice
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Device -> OutputDevice
OutputDevice (Ptr Wrapper -> Device
Device Ptr Wrapper
dptr))

-- | Immediately send a single message out an open MIDI output port.
sendMessage :: MonadIO m => OutputDevice -> [Word8] -> m ()
sendMessage :: OutputDevice -> [Word8] -> m ()
sendMessage d :: OutputDevice
d m :: [Word8]
m = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Word8] -> (Int -> Ptr Word8 -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [Word8]
m ((Int -> Ptr Word8 -> IO ()) -> IO ())
-> (Int -> Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \n :: Int
n ptr :: Ptr Word8
ptr -> do
  let dptr :: Ptr Wrapper
dptr = OutputDevice -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr OutputDevice
d
  Ptr Wrapper -> Ptr CUChar -> CInt -> IO CInt
rtmidi_out_send_message Ptr Wrapper
dptr (Ptr Word8 -> Ptr CUChar
forall a b. Coercible a b => a -> b
coerce Ptr Word8
ptr) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr

-- | If a MIDI connection is still open, it will be closed
closeDevice :: MonadIO m => IsDevice d => d -> m ()
closeDevice :: d -> m ()
closeDevice d :: d
d = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
  let dptr :: Ptr Wrapper
dptr = d -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr d
d
  in case d -> DeviceType
forall d. IsDevice d => d -> DeviceType
getDeviceType d
d of
    InputDeviceType -> Ptr Wrapper -> IO ()
rtmidi_in_free Ptr Wrapper
dptr
    OutputDeviceType -> Ptr Wrapper -> IO ()
rtmidi_out_free Ptr Wrapper
dptr

-- | Returns the specifier for the MIDI 'Api' in use
currentApi :: MonadIO m => IsDevice d => d -> m Api
currentApi :: d -> m Api
currentApi d :: d
d = IO Api -> m Api
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Api -> m Api) -> IO Api -> m Api
forall a b. (a -> b) -> a -> b
$ do
  let dptr :: Ptr Wrapper
dptr = d -> Ptr Wrapper
forall d. IsDevice d => d -> Ptr Wrapper
toDevicePtr d
d
  CInt
res <-
    case d -> DeviceType
forall d. IsDevice d => d -> DeviceType
getDeviceType d
d of
      InputDeviceType -> Ptr Wrapper -> IO CInt
rtmidi_in_get_current_api Ptr Wrapper
dptr
      OutputDeviceType -> Ptr Wrapper -> IO CInt
rtmidi_out_get_current_api Ptr Wrapper
dptr
  Ptr Wrapper -> IO ()
guardError Ptr Wrapper
dptr
  Api -> IO Api
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Api
forall a. Enum a => Int -> a
toEnum (CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
res))