-- 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 " forall a. [a] -> [a] -> [a]
++ forall write_message. RawInterface write_message -> String
name RawInterface a
interface 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
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
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 -> forall a. Pretty a => a -> Error
pretty WriteMessage
msg
        AllNotesOff RealTime
time -> [Error] -> Error
Text.unwords [Error
"AllNotesOff", forall a. Pretty a => a -> Error
pretty RealTime
time]
        AllDevices RealTime
time [Message]
msgs ->
            [Error] -> Error
Text.unwords [Error
"AllDevices", forall a. Pretty a => a -> Error
pretty RealTime
time, forall a. Pretty a => a -> Error
pretty [Message]
msgs]

instance DeepSeq.NFData Message where
    rnf :: Message -> ()
rnf (Midi WriteMessage
msg) = forall a. NFData a => a -> ()
DeepSeq.rnf WriteMessage
msg
    rnf (AllNotesOff RealTime
_) = ()
    rnf (AllDevices RealTime
_ [Message]
msgs) = 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 <- forall err.
Bool
-> (WriteMessage -> IO (Maybe err))
-> IO (Message -> IO (Maybe err))
note_tracker Bool
use_all_notes_off (forall write_message.
RawInterface write_message -> write_message -> IO (Maybe Error)
write_message RawInterface WriteMessage
interface)
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 forall a b. (a -> b) -> a -> b
$
    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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> (b, a)
Tuple.swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 <- forall a. a -> IO (MVar a)
MVar.newMVar forall k a. Map k a
Map.empty
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Message
msg -> forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MVar.modifyMVar MVar State
mstate forall a b. (a -> b) -> a -> b
$ \State
state -> forall a. State -> TrackerM a -> IO (State, a)
run State
state forall a b. (a -> b) -> a -> b
$ do
        [WriteMessage]
new_msgs <- Message -> StateT State IO [WriteMessage]
handle_msg Message
msg
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 (forall a. Ord a => a -> a -> a -> Bool
Num.inRange Channel
0 Channel
15 Channel
chan) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Midi.ChannelMessage Channel
chan (Midi.NoteOn Key
key Channel
vel)
                | Channel
vel 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ord a => a -> a -> a -> Bool
Num.inRange Key
0 Key
128 Key
key) forall a b. (a -> b) -> a -> b
$ do
    State
state <- forall s (m :: * -> *). MonadState s m => m s
State.get
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WriteDevice
dev State
state) forall a b. (a -> b) -> a -> b
$ \Vector (MVector RealWorld Int)
chans -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
Mutable.modify (Vector (MVector RealWorld Int)
chans forall a. Vector a -> Int -> a
! forall a b. (Integral a, Num b) => a -> b
fromIntegral Channel
chan) (forall a. Num a => a -> a -> a
subtract Int
1)
            (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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ord a => a -> a -> a -> Bool
Num.inRange Key
0 Key
128 Key
key) forall a b. (a -> b) -> a -> b
$ do
    State
state <- forall s (m :: * -> *). MonadState s m => m s
State.get
    case 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
16 (forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> a -> m (MVector (PrimState m) a)
Mutable.replicate Int
128 Int
0)
            forall {m :: * -> *} {a}.
(MonadIO m, Unbox a, Num a) =>
Vector (MVector RealWorld a) -> m ()
set Vector (MVector RealWorld Int)
chans
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (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 -> 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
Mutable.modify (Vector (MVector RealWorld a)
chans forall a. Vector a -> Int -> a
! forall a b. (Integral a, Num b) => a -> b
fromIntegral Channel
chan) (forall a. Num a => a -> a -> a
+a
1) (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 <- forall s (m :: * -> *). MonadState s m => m s
State.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WriteDevice -> [WriteMessage]
mkmsgs (forall k a. Map k a -> [k]
Map.keys State
state)
    where
    mkmsgs :: WriteDevice -> [WriteMessage]
mkmsgs WriteDevice
dev = 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 <- forall s (m :: * -> *). MonadState s m => m s
State.get
    -- Debug.traceM "state" =<< traverse (traverse Unboxed.freeze) state
    [[[WriteMessage]]]
msgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList State
state) forall a b. (a -> b) -> a -> b
$ \(WriteDevice
dev, Vector (MVector RealWorld Int)
chans) ->
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [Channel
0..] (forall a. Vector a -> [a]
Vector.toList Vector (MVector RealWorld Int)
chans)) forall a b. (a -> b) -> a -> b
$ \(Channel
chan, MVector RealWorld Int
notes) ->
            if Bool
use_all_notes_off then forall (m :: * -> *) a. Monad m => a -> m a
return
                [ WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
dev RealTime
time forall a b. (a -> b) -> a -> b
$
                    Channel -> ChannelMessage -> Message
Midi.ChannelMessage Channel
chan ChannelMessage
Midi.AllNotesOff
                ]
            else do
                [Int]
keys <- forall a. Unbox a => Vector a -> [a]
Unboxed.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
Unboxed.freeze MVector RealWorld Int
notes
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> a -> m ()
Mutable.set MVector RealWorld Int
notes Int
0
                -- Emit a NoteOff for each current NoteOn I've seen.
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (WriteDevice -> Channel -> Key -> WriteMessage
note_off WriteDevice
dev Channel
chan)
                    [ Int -> Key
Midi.Key (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
                    | (Integer
i, Int
count) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [Int]
keys
                    , Int
_ <- [Int
0 .. Int
countforall a. Num a => a -> a -> a
-Int
1]
                    ]
    -- Debug.tracepM "msgs" $ concat $ concat msgs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (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 forall a b. (a -> b) -> a -> b
$
        Channel -> ChannelMessage -> Message
Midi.ChannelMessage Channel
chan forall a b. (a -> b) -> a -> b
$ Key -> Channel -> ChannelMessage
Midi.NoteOff Key
key Channel
0