-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | Interface to CoreMIDI.

    Receiving messages in CoreMIDI is simple, there's a callback that gets
    called when one arrives.  However, it identifies them with a 'DeviceId',
    not a name.  You get the ID when you open the device for reading.  If the
    device is not present, then I record that I want it in 'Client', and
    'notify_callback' will hopefully add the DeviceId if it does appear.

    Sending messages is the same situation.  It's more complicated at the C
    level, which is documented in core_midi.cc.

    Other than that, CoreMIDI is pretty straightforward.  Since I only support
    a single MIDI initialization, the various open client and port types are
    kept as global variables inside the C binding.

    I originally tried to use PortMidi, but found it both lacking essential
    features (it couldn't schedule MIDI both for the future and for now), but
    also harder to write for.
-}
module Midi.CoreMidi (initialize) where
import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as Exception

import qualified Data.ByteString as ByteString
import           Data.ByteString (ByteString)
import qualified Data.IORef as IORef
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Foreign
import           Foreign (FunPtr, Ptr, Word8)
import qualified Foreign.C as C
import           Foreign.C (CInt(..), CString, CULong(..))

import qualified Util.FFI as FFI
import qualified Util.Log as Log
import qualified Midi.Encode as Encode
import qualified Midi.Interface as Interface
import qualified Midi.Midi as Midi

import qualified Perform.RealTime as RealTime
import           Perform.RealTime (RealTime)

import           Global


type Error = Text

-- * initialize

initialize :: Interface.Initialize a
initialize :: forall a. Initialize a
initialize String
app_name WantMessage
want_message Either Error (RawInterface WriteMessage) -> IO a
app = do
    TChan ReadMessage
chan <- forall a. IO (TChan a)
STM.newTChanIO
    Client
client <- IO Client
make_client
    forall {c}.
TChan ReadMessage -> (FunPtr ReadCallback -> IO c) -> IO c
with_read_cb TChan ReadMessage
chan forall a b. (a -> b) -> a -> b
$ \FunPtr ReadCallback
read_cb -> forall {c}. Client -> (FunPtr NotifyCallback -> IO c) -> IO c
with_notify_cb Client
client forall a b. (a -> b) -> a -> b
$ \FunPtr NotifyCallback
notify_cb ->
        forall a. String -> (CString -> IO a) -> IO a
C.withCString String
app_name forall a b. (a -> b) -> a -> b
$ \CString
app_namep -> do
            MVar (Maybe Error)
err_mvar <- forall a. IO (MVar a)
MVar.newEmptyMVar
            -- This, along with 'c_prime_runloop' below, is a bit of song and
            -- dance to get MIDI notifications to work in CoreMIDI.  It wants
            -- to send them on the current runloop when the client is created.
            -- But I don't use the OS X runloop, so I have to have
            -- c_initialize enter one right after it creates the client.
            --
            -- However, runloops on other threads apparently don't work unless
            -- the main runloop has been called at least once, which is what
            -- the 'c_prime_runloop' nonsense below is about.
            IO () -> IO ThreadId
Concurrent.forkOS forall a b. (a -> b) -> a -> b
$ do
                CError
err <- CString
-> FunPtr ReadCallback -> FunPtr NotifyCallback -> IO CError
c_initialize CString
app_namep FunPtr ReadCallback
read_cb FunPtr NotifyCallback
notify_cb
                forall a. MVar a -> a -> IO ()
MVar.putMVar MVar (Maybe Error)
err_mvar (CError -> Maybe Error
error_str CError
err)
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CError -> Maybe Error
error_str CError
err forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing) IO ()
c_cf_runloop_run
            forall a. MVar a -> IO a
MVar.takeMVar MVar (Maybe Error)
err_mvar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just Error
err -> Either Error (RawInterface WriteMessage) -> IO a
app (forall a b. a -> Either a b
Left Error
err)
                Maybe Error
Nothing -> do
                    IO ()
c_prime_runloop
                    Either Error (RawInterface WriteMessage) -> IO a
app (forall a b. b -> Either a b
Right (Client -> TChan ReadMessage -> RawInterface WriteMessage
mkinterface Client
client TChan ReadMessage
chan))
                        forall a b. IO a -> IO b -> IO a
`Exception.finally` IO ()
terminate
    where
    with_read_cb :: TChan ReadMessage -> (FunPtr ReadCallback -> IO c) -> IO c
with_read_cb TChan ReadMessage
chan = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
        (ReadCallback -> IO (FunPtr ReadCallback)
make_read_callback (WantMessage -> TChan ReadMessage -> ReadCallback
read_callback WantMessage
want_message TChan ReadMessage
chan))
        forall a. FunPtr a -> IO ()
Foreign.freeHaskellFunPtr
    with_notify_cb :: Client -> (FunPtr NotifyCallback -> IO c) -> IO c
with_notify_cb Client
client = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
        (NotifyCallback -> IO (FunPtr NotifyCallback)
make_notify_callback (Client -> NotifyCallback
notify_callback Client
client))
        forall a. FunPtr a -> IO ()
Foreign.freeHaskellFunPtr
    mkinterface :: Client -> TChan ReadMessage -> RawInterface WriteMessage
mkinterface Client
client TChan ReadMessage
chan = Interface.Interface
        { name :: String
name = String
"CoreMIDI"
        , read_channel :: TChan ReadMessage
read_channel = TChan ReadMessage
chan
        , read_devices :: IO [(ReadDevice, [ReadDevice])]
read_devices = forall a b. (a -> b) -> [a] -> [b]
map ((, []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> ReadDevice
Midi.read_device) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO [Error]
get_devices Bool
True
        , write_devices :: IO [(WriteDevice, [WriteDevice])]
write_devices = forall a b. (a -> b) -> [a] -> [b]
map ((, []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> WriteDevice
Midi.write_device) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO [Error]
get_devices Bool
False
        , connect_read_device :: ReadDevice -> IO Bool
connect_read_device = Client -> ReadDevice -> IO Bool
connect_read_device Client
client
        , disconnect_read_device :: ReadDevice -> IO Bool
disconnect_read_device = Client -> ReadDevice -> IO Bool
disconnect_read_device Client
client
        , connect_write_device :: WriteDevice -> IO Bool
connect_write_device = Client -> WriteDevice -> IO Bool
connect_write_device Client
client
        , write_message :: WriteMessage -> IO (Maybe Error)
write_message = Client -> WriteMessage -> IO (Maybe Error)
write_message Client
client
        , abort :: IO ()
abort = IO ()
abort
        , now :: IO RealTime
now = IO RealTime
now
        }

type ReadCallback = SourcePtr -> CTimestamp -> CInt -> Ptr Word8 -> IO ()
type SourcePtr = Foreign.StablePtr Midi.ReadDevice
-- typedef void (*ReadCallback)(void *p, Timestamp timestamp, int len,
--     const unsigned char *bytes);

type NotifyCallback = CString -> DeviceId -> CInt -> CInt -> IO ()
-- typedef void (*NotifyCallback)(const char *name, DeviceId dev_id,
--     int is_added, int is_read);

foreign import ccall "core_midi_terminate" terminate :: IO ()
foreign import ccall "core_midi_initialize"
    c_initialize :: CString -> FunPtr ReadCallback -> FunPtr NotifyCallback
        -> IO CError
foreign import ccall "wrapper"
    make_read_callback :: ReadCallback -> IO (FunPtr ReadCallback)
foreign import ccall "wrapper"
    make_notify_callback :: NotifyCallback -> IO (FunPtr NotifyCallback)
foreign import ccall "CFRunLoopRun" c_cf_runloop_run :: IO ()
foreign import ccall "core_midi_prime_runloop" c_prime_runloop :: IO ()

-- TODO this is run from the CoreMIDI callback.  The callback is supposed to
-- be low latency which means no allocation, but haskell has plenty of
-- allocation.  On the other hand, it hasn't been a problem in practice and
-- a separate thread monitoring a ringbuffer would just add more latency.
read_callback :: (ByteString -> Bool) -> Interface.ReadChan -> ReadCallback
read_callback :: WantMessage -> TChan ReadMessage -> ReadCallback
read_callback WantMessage
want_message TChan ReadMessage
chan SourcePtr
sourcep CError
ctimestamp CInt
len Ptr Word8
bytesp = do
    -- Oddly enough, even though ByteString is Word8, the ptr packing function
    -- wants CChar.
    ByteString
bytes <- CStringLen -> IO ByteString
ByteString.packCStringLen
        (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr Word8
bytesp, forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
len)
    ReadDevice
rdev <- forall a. StablePtr a -> IO a
Foreign.deRefStablePtr SourcePtr
sourcep
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WantMessage
want_message ByteString
bytes) forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan TChan ReadMessage
chan forall a b. (a -> b) -> a -> b
$
        ReadDevice -> RealTime -> Message -> ReadMessage
Midi.ReadMessage ReadDevice
rdev (CError -> RealTime
decode_time CError
ctimestamp) (ByteString -> Message
Encode.decode ByteString
bytes)

notify_callback :: Client -> NotifyCallback
notify_callback :: Client -> NotifyCallback
notify_callback Client
client CString
namep CInt
_dev_id CInt
c_is_added CInt
c_is_read = do
    -- I could make connect_read_device and connect_write_device that take
    -- the dev_id directly, but that's too much work.
    Error
name <- CString -> IO Error
FFI.peekCString CString
namep
    case (forall a. (Eq a, Num a) => a -> Bool
Foreign.toBool CInt
c_is_added, forall a. (Eq a, Num a) => a -> Bool
Foreign.toBool CInt
c_is_read) of
        (Bool
True, Bool
True) -> do
            let dev :: ReadDevice
dev = Error -> ReadDevice
Midi.read_device Error
name
            Set ReadDevice
reads <- forall a. IORef a -> IO a
IORef.readIORef (Client -> IORef (Set ReadDevice)
client_reads Client
client)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReadDevice
dev forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ReadDevice
reads) forall a b. (a -> b) -> a -> b
$
                forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Client -> ReadDevice -> IO Bool
connect_read_device Client
client ReadDevice
dev
        (Bool
True, Bool
False) -> do
            let dev :: WriteDevice
dev = Error -> WriteDevice
Midi.write_device Error
name
            Map WriteDevice (Maybe CInt)
writes <- forall a. IORef a -> IO a
IORef.readIORef (Client -> IORef (Map WriteDevice (Maybe CInt))
client_writes Client
client)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WriteDevice
dev forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map WriteDevice (Maybe CInt)
writes) forall a b. (a -> b) -> a -> b
$
                forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Client -> WriteDevice -> IO Bool
connect_write_device Client
client WriteDevice
dev
        -- I leave removes alone.  If a source disappears, I'll just stop
        -- getting msgs from it.  If a destination disappears, then writes
        -- to it will fail, exactly as if it weren't connected.  CoreMIDI
        -- doesn't let me look up the name and ID of disconnected devices
        -- anyway.
        (Bool, Bool)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

data Client = Client {
    -- | I don't need to deal with DeviceIds for reads.
    Client -> IORef (Set ReadDevice)
client_reads :: IORef.IORef (Set.Set Midi.ReadDevice)
    , Client -> IORef (Map WriteDevice (Maybe CInt))
client_writes :: IORef.IORef (Map.Map Midi.WriteDevice (Maybe DeviceId))
    }

make_client :: IO Client
make_client :: IO Client
make_client = IORef (Set ReadDevice)
-> IORef (Map WriteDevice (Maybe CInt)) -> Client
Client forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
IORef.newIORef forall a. Set a
Set.empty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
IORef.newIORef forall k a. Map k a
Map.empty

type DeviceId = CInt

-- * devices

connect_read_device :: Client -> Midi.ReadDevice -> IO Bool
connect_read_device :: Client -> ReadDevice -> IO Bool
connect_read_device Client
client ReadDevice
dev =
    Bool -> Error -> IO (Maybe CInt)
lookup_device_id Bool
True (ReadDevice -> Error
Midi.read_device_text ReadDevice
dev) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe CInt
Nothing -> do
            -- This means I want the device if it ever gets plugged in.
            forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef (Client -> IORef (Set ReadDevice)
client_reads Client
client) (forall a. Ord a => a -> Set a -> Set a
Set.insert ReadDevice
dev)
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just CInt
dev_id -> do
            -- CoreMIDI lets you attach an arbitrary pointer to each
            -- connection to identify msgs coming in on that connection.  So
            -- I can use a stable ptr to the ReadDevice and have the read
            -- callback directly get a ReadDevice without having to look
            -- anything up.
            SourcePtr
sourcep <- forall a. a -> IO (StablePtr a)
Foreign.newStablePtr ReadDevice
dev
            Bool
ok <- CError -> IO Bool
check forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CInt -> Ptr () -> IO CError
c_connect_read_device CInt
dev_id
                (forall a. StablePtr a -> Ptr ()
Foreign.castStablePtrToPtr SourcePtr
sourcep)
            if Bool -> Bool
not Bool
ok then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else do
                forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef (Client -> IORef (Set ReadDevice)
client_reads Client
client) (forall a. Ord a => a -> Set a -> Set a
Set.insert ReadDevice
dev)
                forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

foreign import ccall "core_midi_connect_read_device"
    c_connect_read_device :: CInt -> Ptr () -> IO CError

disconnect_read_device :: Client -> Midi.ReadDevice -> IO Bool
disconnect_read_device :: Client -> ReadDevice -> IO Bool
disconnect_read_device Client
client ReadDevice
dev = do
    Maybe CInt
maybe_dev_id <- Bool -> Error -> IO (Maybe CInt)
lookup_device_id Bool
True (ReadDevice -> Error
Midi.read_device_text ReadDevice
dev)
    Bool
wanted <- forall a. Ord a => a -> Set a -> Bool
Set.member ReadDevice
dev forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
IORef.readIORef (Client -> IORef (Set ReadDevice)
client_reads Client
client)
    forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef (Client -> IORef (Set ReadDevice)
client_reads Client
client) (forall a. Ord a => a -> Set a -> Set a
Set.delete ReadDevice
dev)
    case (Maybe CInt
maybe_dev_id, Bool
wanted) of
        (Maybe CInt
Nothing, Bool
True) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        (Just CInt
dev_id, Bool
_) -> CError -> IO Bool
check forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CInt -> IO CError
c_disconnect_read_device CInt
dev_id
        (Maybe CInt, Bool)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

foreign import ccall "core_midi_disconnect_read_device"
    c_disconnect_read_device :: DeviceId -> IO CError

connect_write_device :: Client -> Midi.WriteDevice -> IO Bool
connect_write_device :: Client -> WriteDevice -> IO Bool
connect_write_device Client
client WriteDevice
dev = do
    -- CoreMIDI doesn't have a notion of connected write devices, they are
    -- all implicitly connected and you need only emit a msg with the
    -- appropriate device id.
    Maybe CInt
maybe_dev_id <- Bool -> Error -> IO (Maybe CInt)
lookup_device_id Bool
False (WriteDevice -> Error
Midi.write_device_text WriteDevice
dev)
    case Maybe CInt
maybe_dev_id of
        Maybe CInt
Nothing -> do
            forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef (Client -> IORef (Map WriteDevice (Maybe CInt))
client_writes Client
client) (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert WriteDevice
dev forall a. Maybe a
Nothing)
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just CInt
dev_id -> do
            forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef (Client -> IORef (Map WriteDevice (Maybe CInt))
client_writes Client
client)
                (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert WriteDevice
dev (forall a. a -> Maybe a
Just CInt
dev_id))
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

lookup_device_id :: Bool -> Text -> IO (Maybe DeviceId)
lookup_device_id :: Bool -> Error -> IO (Maybe CInt)
lookup_device_id Bool
is_read Error
dev = forall a b. Storable a => (Ptr a -> IO b) -> IO b
Foreign.alloca forall a b. (a -> b) -> a -> b
$ \Ptr CInt
dev_idp -> do
    CInt
found <- forall a. Error -> (CString -> IO a) -> IO a
FFI.withText Error
dev forall a b. (a -> b) -> a -> b
$ \CString
devp ->
        CInt -> CString -> Ptr CInt -> IO CInt
c_lookup_device_id (forall a. Num a => Bool -> a
Foreign.fromBool Bool
is_read) CString
devp Ptr CInt
dev_idp
    if CInt
found forall a. Eq a => a -> a -> Bool
== CInt
0 then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
Foreign.peek Ptr CInt
dev_idp

foreign import ccall "core_midi_lookup_device_id"
    c_lookup_device_id :: CInt -> CString -> Ptr DeviceId -> IO CInt

get_devices :: Bool -> IO [Text]
get_devices :: Bool -> IO [Error]
get_devices Bool
is_read = forall a b. Storable a => (Ptr a -> IO b) -> IO b
Foreign.alloca forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CString)
namesp -> do
    CInt
len <- CInt -> Ptr (Ptr CString) -> IO CInt
c_get_devices (forall a. Num a => Bool -> a
Foreign.fromBool Bool
is_read) Ptr (Ptr CString)
namesp
    Ptr CString
name_array <- forall a. Storable a => Ptr a -> IO a
Foreign.peek Ptr (Ptr CString)
namesp
    [CString]
cnames <- forall a. Storable a => Int -> Ptr a -> IO [a]
Foreign.peekArray (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
len) Ptr CString
name_array
    [Error]
names <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CString -> IO Error
FFI.peekCString [CString]
cnames
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Ptr a -> IO ()
Foreign.free [CString]
cnames
    forall a. Ptr a -> IO ()
Foreign.free Ptr CString
name_array
    forall (m :: * -> *) a. Monad m => a -> m a
return [Error]
names

foreign import ccall "core_midi_get_devices"
    c_get_devices :: CInt -> Ptr (Ptr CString) -> IO CInt

-- * write

-- | RealTime will be ignored for sysex msgs.
write_message :: Client -> Midi.WriteMessage -> IO (Maybe Error)
write_message :: Client -> WriteMessage -> IO (Maybe Error)
write_message Client
client (Midi.WriteMessage WriteDevice
dev RealTime
ts Message
msg)
    | Bool -> Bool
not (Message -> Bool
Midi.valid_msg Message
msg) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Error
"invalid msg: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Error
showt Message
msg
    | Bool
otherwise = do
        -- I could probably avoid this copy by using unsafe unpack and then a
        -- ForeignPtr or something to keep the gc off it, but MIDI is so slow
        -- that any sizable sysex will take forever to send anyway.
        Map WriteDevice (Maybe CInt)
writes <- forall a. IORef a -> IO a
IORef.readIORef (Client -> IORef (Map WriteDevice (Maybe CInt))
client_writes Client
client)
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WriteDevice
dev Map WriteDevice (Maybe CInt)
writes of
            Just (Just CInt
dev_id) ->
                forall a. ByteString -> (CStringLen -> IO a) -> IO a
ByteString.useAsCStringLen (Message -> ByteString
Encode.encode Message
msg) forall a b. (a -> b) -> a -> b
$
                \(CString
bytesp, Int
len) -> CError -> Maybe Error
error_str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CInt -> CError -> CInt -> Ptr Word8 -> IO CError
c_write_message CInt
dev_id
                    (RealTime -> CError
encode_time RealTime
ts) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) (forall a b. Ptr a -> Ptr b
Foreign.castPtr CString
bytesp)
            Maybe (Maybe CInt)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Error
"device not in open WriteDevices: "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Error
pretty (forall k a. Map k a -> [k]
Map.keys Map WriteDevice (Maybe CInt)
writes) forall a. Semigroup a => a -> a -> a
<> Error
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Error
pretty WriteDevice
dev

foreign import ccall "core_midi_write_message"
    c_write_message :: CInt -> CTimestamp -> CInt -> Ptr Word8 -> IO CError

-- * misc

-- | Clear all pending msgs.
abort :: IO ()
abort :: IO ()
abort = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ CError -> IO Bool
check forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO CError
c_abort
foreign import ccall "core_midi_abort" c_abort :: IO CError

-- | Get current timestamp.
now :: IO RealTime
now :: IO RealTime
now = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CError -> RealTime
decode_time IO CError
c_get_now
foreign import ccall "core_midi_get_now" c_get_now :: IO CTimestamp

type CTimestamp = CULong

decode_time :: CTimestamp -> RealTime
decode_time :: CError -> RealTime
decode_time = Integer -> RealTime
RealTime.milliseconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

encode_time :: RealTime -> CTimestamp
encode_time :: RealTime -> CError
encode_time = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max Integer
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Integer
RealTime.to_milliseconds

-- * errors

-- | Log any error and return False if there was one.
--
-- I previously threw an exception, but I feel like killing the whole app
-- is overkill.
check :: CError -> IO Bool
check :: CError -> IO Bool
check CError
err = case CError -> Maybe Error
error_str CError
err of
    Maybe Error
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Just Error
msg -> do
        forall (m :: * -> *). (Stack, LogMonad m) => Error -> m ()
Log.error Error
msg
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

type CError = CULong

-- TODO look up actual error msgs
error_str :: CError -> Maybe Error
error_str :: CError -> Maybe Error
error_str CError
err
    | CError
err forall a. Eq a => a -> a -> Bool
== CError
0 = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Error
"CoreMIDI error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Error
showt CError
err