-- 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

-- | Common interface for the MIDI drivers.
module Midi.Interface (
    Initialize
    , WantMessage
    , ReadChan
    , RawInterface(..), Interface
    , Message(..)
    , track_interface
    , reset_pitch
    , reset_controls

    , note_tracker
) where
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Concurrent.STM.TChan as TChan
import qualified Control.DeepSeq as DeepSeq
import qualified Control.Monad.State.Strict as State

import qualified Data.ByteString as ByteString
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Tuple as Tuple
import qualified Data.Vector as Vector
import           Data.Vector ((!))
import qualified Data.Vector.Unboxed as Unboxed
import qualified Data.Vector.Unboxed.Mutable as Mutable

import qualified Util.Num as Num
import qualified Midi.Midi as Midi
import           Perform.RealTime (RealTime)

import           Global


-- | Not all synths observe AllNotesOff, but swam does.  Swam also
-- tends to get stuck notes.  TODO who doesn't support it?  And does this fix
-- swam?  If no one and yes, then I can remove the old tracking mechanism.
use_all_notes_off :: Bool
use_all_notes_off :: Bool
use_all_notes_off = Bool
True

type Error = Text

type ReadChan = TChan.TChan Midi.ReadMessage

type Initialize a = String -- ^ register this name with CoreMIDI
    -> WantMessage
    -> (Either Error (RawInterface Midi.WriteMessage) -> IO a)
    -> IO a

-- | Read msgs that return false are filtered.  This uses a raw ByteString to
-- avoid the decode overhead for messages that will be rejected, probably in
-- a high-priority callback.  TODO I could probably make this a bitmask or
-- something and put it down in the driver.
type WantMessage = ByteString.ByteString -> Bool

-- | Produced by an @initialize@ function.
data RawInterface write_message = Interface {
    -- | Name of the MIDI driver.  Just for debugging.
    forall write_message. RawInterface write_message -> String
name :: String
    -- | ReadMessages from the opened ReadDevices become available on this
    -- channel.
    , forall write_message. RawInterface write_message -> ReadChan
read_channel :: ReadChan
    -- | Get currently connected read and write devices, along with a list
    -- of aliases for each one.
    , forall write_message.
RawInterface write_message -> IO [(ReadDevice, [ReadDevice])]
read_devices :: IO [(Midi.ReadDevice, [Midi.ReadDevice])]
    , forall write_message.
RawInterface write_message -> IO [(WriteDevice, [WriteDevice])]
write_devices :: IO [(Midi.WriteDevice, [Midi.WriteDevice])]

    -- | Start receiving messages on 'read_channel' from the given device.
    -- If it doesn't exist, return False.  But it's ok to connect to
    -- non-existent ReadDevices because if it does get plugged in, it will
    -- be connected automatically.
    , forall write_message.
RawInterface write_message -> ReadDevice -> IO Bool
connect_read_device :: Midi.ReadDevice -> IO Bool
    -- | Stop receiving messages for this device.  False if it wasn't
    -- connected.
    , forall write_message.
RawInterface write_message -> ReadDevice -> IO Bool
disconnect_read_device :: Midi.ReadDevice -> IO Bool

    -- | The same as 'connect_read_device'.
    , forall write_message.
RawInterface write_message -> WriteDevice -> IO Bool
connect_write_device :: Midi.WriteDevice -> IO Bool

    -- | Write a message to the output.  To avoid overflow, try to not have
    -- more than a thousand or so pending.  False if the WriteDevice isn't
    -- connected.
    --
    -- Messages should be written in increasing time order, with a special
    -- case that timestamp 0 messages will be written immediately.
    , forall write_message.
RawInterface write_message -> write_message -> IO (Maybe Error)
write_message :: write_message -> IO (Maybe Error)
    -- | Deschedule all pending write messages.
    , forall write_message. RawInterface write_message -> IO ()
abort :: IO ()
    -- | Current time according to the MIDI driver.
    , forall write_message. RawInterface write_message -> IO RealTime
now :: IO RealTime
    }

instance Show (RawInterface a) where
    show :: RawInterface a -> String
show RawInterface a
interface = String
"((MidiInterface " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RawInterface a -> String
forall write_message. RawInterface write_message -> String
name RawInterface a
interface String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"))"

type Interface = RawInterface Message

-- | Annotate a WriteMessage with additional control messages.
data Message =
    Midi !Midi.WriteMessage
    -- | Turn off sounding notes on all devices and channels.
    | AllNotesOff !RealTime
    -- | Emit the messages for all devices that have been used.  This doesn't
    -- care if they have sounding notes because control state persists after
    -- NoteOff.
    | AllDevices !RealTime ![Midi.Message]
    deriving (Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> String
$cshow :: Message -> String
showsPrec :: Int -> Message -> ShowS
$cshowsPrec :: Int -> Message -> ShowS
Show, Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq)

instance Pretty Message where
    pretty :: Message -> Error
pretty Message
msg = case Message
msg of
        Midi WriteMessage
msg -> WriteMessage -> Error
forall a. Pretty a => a -> Error
pretty WriteMessage
msg
        AllNotesOff RealTime
time -> [Error] -> Error
Text.unwords [Error
"AllNotesOff", RealTime -> Error
forall a. Pretty a => a -> Error
pretty RealTime
time]
        AllDevices RealTime
time [Message]
msgs ->
            [Error] -> Error
Text.unwords [Error
"AllDevices", RealTime -> Error
forall a. Pretty a => a -> Error
pretty RealTime
time, [Message] -> Error
forall a. Pretty a => a -> Error
pretty [Message]
msgs]

instance DeepSeq.NFData Message where
    rnf :: Message -> ()
rnf (Midi WriteMessage
msg) = WriteMessage -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf WriteMessage
msg
    rnf (AllNotesOff RealTime
_) = ()
    rnf (AllDevices RealTime
_ [Message]
msgs) = [Message] -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf [Message]
msgs

track_interface :: RawInterface Midi.WriteMessage -> IO Interface
track_interface :: RawInterface WriteMessage -> IO Interface
track_interface RawInterface WriteMessage
interface = do
    Message -> IO (Maybe Error)
tracker <- Bool
-> (WriteMessage -> IO (Maybe Error))
-> IO (Message -> IO (Maybe Error))
forall err.
Bool
-> (WriteMessage -> IO (Maybe err))
-> IO (Message -> IO (Maybe err))
note_tracker Bool
use_all_notes_off (RawInterface WriteMessage -> WriteMessage -> IO (Maybe Error)
forall write_message.
RawInterface write_message -> write_message -> IO (Maybe Error)
write_message RawInterface WriteMessage
interface)
    Interface -> IO Interface
forall (m :: * -> *) a. Monad m => a -> m a
return (Interface -> IO Interface) -> Interface -> IO Interface
forall a b. (a -> b) -> a -> b
$ RawInterface WriteMessage
interface { write_message :: Message -> IO (Maybe Error)
write_message = Message -> IO (Maybe Error)
tracker }

reset_pitch :: RealTime -> Message
reset_pitch :: RealTime -> Message
reset_pitch RealTime
time = RealTime -> [Message] -> Message
AllDevices RealTime
time ([Message] -> Message) -> [Message] -> Message
forall a b. (a -> b) -> a -> b
$ ChannelMessage -> [Message]
all_channels (PitchBendValue -> ChannelMessage
Midi.PitchBend PitchBendValue
0)

reset_controls :: RealTime -> Message
reset_controls :: RealTime -> Message
reset_controls RealTime
time = RealTime -> [Message] -> Message
AllDevices RealTime
time ([Message] -> Message) -> [Message] -> Message
forall a b. (a -> b) -> a -> b
$
    (ChannelMessage -> [Message]) -> [ChannelMessage] -> [Message]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ChannelMessage -> [Message]
all_channels [ChannelMessage
Midi.ResetAllControls, PitchBendValue -> ChannelMessage
Midi.PitchBend PitchBendValue
0]

all_channels :: Midi.ChannelMessage -> [Midi.Message]
all_channels :: ChannelMessage -> [Message]
all_channels ChannelMessage
msg = [Channel -> ChannelMessage -> Message
Midi.ChannelMessage Channel
chan ChannelMessage
msg | Channel
chan <- [Channel
0..Channel
15]]

-- * implementation

type TrackerM a = State.StateT State IO a
type State = Map Midi.WriteDevice (Vector.Vector (Mutable.IOVector Int))

run :: State -> TrackerM a -> IO (State, a)
run :: forall a. State -> TrackerM a -> IO (State, a)
run State
state = ((a, State) -> (State, a)) -> IO (a, State) -> IO (State, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, State) -> (State, a)
forall a b. (a, b) -> (b, a)
Tuple.swap (IO (a, State) -> IO (State, a))
-> (TrackerM a -> IO (a, State)) -> TrackerM a -> IO (State, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackerM a -> State -> IO (a, State))
-> State -> TrackerM a -> IO (a, State)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TrackerM a -> State -> IO (a, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT State
state

-- | Wrap a 'write_message' and keep track of which notes are on.  It can
-- then handle reset messages which need to know current state to reset it.
--
-- This is necessary because some synthesizers do not support AllNotesOff,
-- but also relieves callers of having to track which devices and channels
-- have active notes.
note_tracker :: Bool -> (Midi.WriteMessage -> IO (Maybe err))
    -> IO (Message -> IO (Maybe err))
note_tracker :: forall err.
Bool
-> (WriteMessage -> IO (Maybe err))
-> IO (Message -> IO (Maybe err))
note_tracker Bool
use_all_notes_off WriteMessage -> IO (Maybe err)
write = do
    MVar State
mstate <- State -> IO (MVar State)
forall a. a -> IO (MVar a)
MVar.newMVar State
forall k a. Map k a
Map.empty
    (Message -> IO (Maybe err)) -> IO (Message -> IO (Maybe err))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Message -> IO (Maybe err)) -> IO (Message -> IO (Maybe err)))
-> (Message -> IO (Maybe err)) -> IO (Message -> IO (Maybe err))
forall a b. (a -> b) -> a -> b
$ \Message
msg -> MVar State -> (State -> IO (State, Maybe err)) -> IO (Maybe err)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MVar.modifyMVar MVar State
mstate ((State -> IO (State, Maybe err)) -> IO (Maybe err))
-> (State -> IO (State, Maybe err)) -> IO (Maybe err)
forall a b. (a -> b) -> a -> b
$ \State
state -> State -> TrackerM (Maybe err) -> IO (State, Maybe err)
forall a. State -> TrackerM a -> IO (State, a)
run State
state (TrackerM (Maybe err) -> IO (State, Maybe err))
-> TrackerM (Maybe err) -> IO (State, Maybe err)
forall a b. (a -> b) -> a -> b
$ do
        [WriteMessage]
new_msgs <- Message -> StateT State IO [WriteMessage]
handle_msg Message
msg
        IO (Maybe err) -> TrackerM (Maybe err)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe err) -> TrackerM (Maybe err))
-> IO (Maybe err) -> TrackerM (Maybe err)
forall a b. (a -> b) -> a -> b
$ do
            (WriteMessage -> IO (Maybe err)) -> [WriteMessage] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WriteMessage -> IO (Maybe err)
write [WriteMessage]
new_msgs
            case Message
msg of
                Midi WriteMessage
wmsg -> WriteMessage -> IO (Maybe err)
write WriteMessage
wmsg
                Message
_ -> Maybe err -> IO (Maybe err)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe err
forall a. Maybe a
Nothing
    where
    handle_msg :: Message -> StateT State IO [WriteMessage]
handle_msg (Midi WriteMessage
wmsg) = do
        case WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg of
            Midi.ChannelMessage Channel
chan ChannelMessage
_
                | Bool -> Bool
not (Channel -> Channel -> Channel -> Bool
forall a. Ord a => a -> a -> a -> Bool
Num.inRange Channel
0 Channel
15 Channel
chan) -> () -> StateT State IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Midi.ChannelMessage Channel
chan (Midi.NoteOn Key
key Channel
vel)
                | Channel
vel Channel -> Channel -> Bool
forall a. Eq a => a -> a -> Bool
== Channel
0 -> WriteDevice -> Channel -> Key -> StateT State IO ()
note_off WriteDevice
dev Channel
chan Key
key
                | Bool
otherwise -> WriteDevice -> Channel -> Key -> StateT State IO ()
note_on WriteDevice
dev Channel
chan Key
key
            Midi.ChannelMessage Channel
chan (Midi.NoteOff Key
key Channel
_) ->
                WriteDevice -> Channel -> Key -> StateT State IO ()
note_off WriteDevice
dev Channel
chan Key
key
            Message
_ -> () -> StateT State IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [WriteMessage] -> StateT State IO [WriteMessage]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        where dev :: WriteDevice
dev = WriteMessage -> WriteDevice
Midi.wmsg_dev WriteMessage
wmsg
    handle_msg (AllNotesOff RealTime
time) = Bool -> RealTime -> StateT State IO [WriteMessage]
all_notes_off Bool
use_all_notes_off RealTime
time
    handle_msg (AllDevices RealTime
time [Message]
msgs) = RealTime -> [Message] -> StateT State IO [WriteMessage]
send_devices RealTime
time [Message]
msgs

-- if dev in state:
--      state[dev][chan][key] -= 1
note_off :: Midi.WriteDevice -> Midi.Channel -> Midi.Key -> TrackerM ()
note_off :: WriteDevice -> Channel -> Key -> StateT State IO ()
note_off WriteDevice
dev Channel
chan Key
key = Bool -> StateT State IO () -> StateT State IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Key -> Key -> Key -> Bool
forall a. Ord a => a -> a -> a -> Bool
Num.inRange Key
0 Key
128 Key
key) (StateT State IO () -> StateT State IO ())
-> StateT State IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ do
    State
state <- StateT State IO State
forall s (m :: * -> *). MonadState s m => m s
State.get
    Maybe (Vector (MVector RealWorld Int))
-> (Vector (MVector RealWorld Int) -> StateT State IO ())
-> StateT State IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (WriteDevice -> State -> Maybe (Vector (MVector RealWorld Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WriteDevice
dev State
state) ((Vector (MVector RealWorld Int) -> StateT State IO ())
 -> StateT State IO ())
-> (Vector (MVector RealWorld Int) -> StateT State IO ())
-> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ \Vector (MVector RealWorld Int)
chans -> IO () -> StateT State IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT State IO ()) -> IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$
        MVector (PrimState IO) Int -> (Int -> Int) -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
Mutable.modify (Vector (MVector RealWorld Int)
chans Vector (MVector RealWorld Int) -> Int -> MVector RealWorld Int
forall a. Vector a -> Int -> a
! Channel -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Channel
chan) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
            (Key -> Int
forall a. Num a => Key -> a
Midi.from_key Key
key)

-- if dev not in state:
--      state[dev] = [[0]*128] * 16
-- state[dev][chan][key] += 1
note_on :: Midi.WriteDevice -> Midi.Channel -> Midi.Key -> TrackerM ()
note_on :: WriteDevice -> Channel -> Key -> StateT State IO ()
note_on WriteDevice
dev Channel
chan Key
key = Bool -> StateT State IO () -> StateT State IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Key -> Key -> Key -> Bool
forall a. Ord a => a -> a -> a -> Bool
Num.inRange Key
0 Key
128 Key
key) (StateT State IO () -> StateT State IO ())
-> StateT State IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ do
    State
state <- StateT State IO State
forall s (m :: * -> *). MonadState s m => m s
State.get
    case WriteDevice -> State -> Maybe (Vector (MVector RealWorld Int))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WriteDevice
dev State
state of
        Maybe (Vector (MVector RealWorld Int))
Nothing -> do
            Vector (MVector RealWorld Int)
chans <- IO (Vector (MVector RealWorld Int))
-> StateT State IO (Vector (MVector RealWorld Int))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Vector (MVector RealWorld Int))
 -> StateT State IO (Vector (MVector RealWorld Int)))
-> IO (Vector (MVector RealWorld Int))
-> StateT State IO (Vector (MVector RealWorld Int))
forall a b. (a -> b) -> a -> b
$ [MVector RealWorld Int] -> Vector (MVector RealWorld Int)
forall a. [a] -> Vector a
Vector.fromList ([MVector RealWorld Int] -> Vector (MVector RealWorld Int))
-> IO [MVector RealWorld Int]
-> IO (Vector (MVector RealWorld Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                Int -> IO (MVector RealWorld Int) -> IO [MVector RealWorld Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
16 (Int -> Int -> IO (MVector (PrimState IO) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> a -> m (MVector (PrimState m) a)
Mutable.replicate Int
128 Int
0)
            Vector (MVector RealWorld Int) -> StateT State IO ()
forall {m :: * -> *} {a}.
(MonadIO m, Unbox a, Num a) =>
Vector (MVector RealWorld a) -> m ()
set Vector (MVector RealWorld Int)
chans
            (State -> State) -> StateT State IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (WriteDevice -> Vector (MVector RealWorld Int) -> State -> State
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert WriteDevice
dev Vector (MVector RealWorld Int)
chans)
        Just Vector (MVector RealWorld Int)
chans -> Vector (MVector RealWorld Int) -> StateT State IO ()
forall {m :: * -> *} {a}.
(MonadIO m, Unbox a, Num a) =>
Vector (MVector RealWorld a) -> m ()
set Vector (MVector RealWorld Int)
chans
    where
    set :: Vector (MVector RealWorld a) -> m ()
set Vector (MVector RealWorld a)
chans = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        MVector (PrimState IO) a -> (a -> a) -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
Mutable.modify (Vector (MVector RealWorld a)
chans Vector (MVector RealWorld a) -> Int -> MVector RealWorld a
forall a. Vector a -> Int -> a
! Channel -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Channel
chan) (a -> a -> a
forall a. Num a => a -> a -> a
+a
1) (Key -> Int
forall a. Num a => Key -> a
Midi.from_key Key
key)

-- | Send the given messages on all devices.
send_devices :: RealTime -> [Midi.Message] -> TrackerM [Midi.WriteMessage]
send_devices :: RealTime -> [Message] -> StateT State IO [WriteMessage]
send_devices RealTime
time [Message]
msgs = do
    State
state <- StateT State IO State
forall s (m :: * -> *). MonadState s m => m s
State.get
    [WriteMessage] -> StateT State IO [WriteMessage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([WriteMessage] -> StateT State IO [WriteMessage])
-> [WriteMessage] -> StateT State IO [WriteMessage]
forall a b. (a -> b) -> a -> b
$ (WriteDevice -> [WriteMessage]) -> [WriteDevice] -> [WriteMessage]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WriteDevice -> [WriteMessage]
mkmsgs (State -> [WriteDevice]
forall k a. Map k a -> [k]
Map.keys State
state)
    where
    mkmsgs :: WriteDevice -> [WriteMessage]
mkmsgs WriteDevice
dev = (Message -> WriteMessage) -> [Message] -> [WriteMessage]
forall a b. (a -> b) -> [a] -> [b]
map (WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
dev RealTime
time) [Message]
msgs

all_notes_off :: Bool -> RealTime -> TrackerM [Midi.WriteMessage]
all_notes_off :: Bool -> RealTime -> StateT State IO [WriteMessage]
all_notes_off Bool
use_all_notes_off RealTime
time = do
    State
state <- StateT State IO State
forall s (m :: * -> *). MonadState s m => m s
State.get
    -- Debug.traceM "state" =<< traverse (traverse Unboxed.freeze) state
    [[[WriteMessage]]]
msgs <- IO [[[WriteMessage]]] -> StateT State IO [[[WriteMessage]]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[[WriteMessage]]] -> StateT State IO [[[WriteMessage]]])
-> IO [[[WriteMessage]]] -> StateT State IO [[[WriteMessage]]]
forall a b. (a -> b) -> a -> b
$ [(WriteDevice, Vector (MVector RealWorld Int))]
-> ((WriteDevice, Vector (MVector RealWorld Int))
    -> IO [[WriteMessage]])
-> IO [[[WriteMessage]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (State -> [(WriteDevice, Vector (MVector RealWorld Int))]
forall k a. Map k a -> [(k, a)]
Map.toList State
state) (((WriteDevice, Vector (MVector RealWorld Int))
  -> IO [[WriteMessage]])
 -> IO [[[WriteMessage]]])
-> ((WriteDevice, Vector (MVector RealWorld Int))
    -> IO [[WriteMessage]])
-> IO [[[WriteMessage]]]
forall a b. (a -> b) -> a -> b
$ \(WriteDevice
dev, Vector (MVector RealWorld Int)
chans) ->
        [(Channel, MVector RealWorld Int)]
-> ((Channel, MVector RealWorld Int) -> IO [WriteMessage])
-> IO [[WriteMessage]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Channel]
-> [MVector RealWorld Int] -> [(Channel, MVector RealWorld Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Channel
0..] (Vector (MVector RealWorld Int) -> [MVector RealWorld Int]
forall a. Vector a -> [a]
Vector.toList Vector (MVector RealWorld Int)
chans)) (((Channel, MVector RealWorld Int) -> IO [WriteMessage])
 -> IO [[WriteMessage]])
-> ((Channel, MVector RealWorld Int) -> IO [WriteMessage])
-> IO [[WriteMessage]]
forall a b. (a -> b) -> a -> b
$ \(Channel
chan, MVector RealWorld Int
notes) ->
            if Bool
use_all_notes_off then [WriteMessage] -> IO [WriteMessage]
forall (m :: * -> *) a. Monad m => a -> m a
return
                [ WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
dev RealTime
time (Message -> WriteMessage) -> Message -> WriteMessage
forall a b. (a -> b) -> a -> b
$
                    Channel -> ChannelMessage -> Message
Midi.ChannelMessage Channel
chan ChannelMessage
Midi.AllNotesOff
                ]
            else do
                [Int]
keys <- Vector Int -> [Int]
forall a. Unbox a => Vector a -> [a]
Unboxed.toList (Vector Int -> [Int]) -> IO (Vector Int) -> IO [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) Int -> IO (Vector Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
Unboxed.freeze MVector RealWorld Int
MVector (PrimState IO) Int
notes
                IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> a -> m ()
Mutable.set MVector RealWorld Int
MVector (PrimState IO) Int
notes Int
0
                -- Emit a NoteOff for each current NoteOn I've seen.
                [WriteMessage] -> IO [WriteMessage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([WriteMessage] -> IO [WriteMessage])
-> [WriteMessage] -> IO [WriteMessage]
forall a b. (a -> b) -> a -> b
$ (Key -> WriteMessage) -> [Key] -> [WriteMessage]
forall a b. (a -> b) -> [a] -> [b]
map (WriteDevice -> Channel -> Key -> WriteMessage
note_off WriteDevice
dev Channel
chan)
                    [ Int -> Key
Midi.Key (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
                    | (Integer
i, Int
count) <- [Integer] -> [Int] -> [(Integer, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [Int]
keys
                    , Int
_ <- [Int
0 .. Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
                    ]
    -- Debug.tracepM "msgs" $ concat $ concat msgs
    [WriteMessage] -> StateT State IO [WriteMessage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([WriteMessage] -> StateT State IO [WriteMessage])
-> [WriteMessage] -> StateT State IO [WriteMessage]
forall a b. (a -> b) -> a -> b
$ [[WriteMessage]] -> [WriteMessage]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[WriteMessage]]] -> [[WriteMessage]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[WriteMessage]]]
msgs)
    where
    note_off :: WriteDevice -> Channel -> Key -> WriteMessage
note_off WriteDevice
dev Channel
chan Key
key = WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
dev RealTime
time (Message -> WriteMessage) -> Message -> WriteMessage
forall a b. (a -> b) -> a -> b
$
        Channel -> ChannelMessage -> Message
Midi.ChannelMessage Channel
chan (ChannelMessage -> Message) -> ChannelMessage -> Message
forall a b. (a -> b) -> a -> b
$ Key -> Channel -> ChannelMessage
Midi.NoteOff Key
key Channel
0