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

-- | Simulate a MIDI synth and turn low level MIDI msgs back into a medium
-- level form.  This is a bit like \"unperform\".
module Midi.Synth where
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.Reader as Reader
import qualified Control.Monad.State.Strict as State

import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Tuple as Tuple

import qualified Util.Num as Num
import qualified Util.Seq as Seq
import qualified Midi.Midi as Midi
import qualified Midi.State as MState
import Midi.State (Addr)

import qualified Perform.Pitch as Pitch
import Global
import Types


-- * analyze

initial_pitches :: [Note] -> [(Int, Pitch.NoteNumber)]
initial_pitches :: [Note] -> [(Int, NoteNumber)]
initial_pitches [Note]
notes = ((Int, NoteNumber) -> Int)
-> [(Int, NoteNumber)] -> [(Int, NoteNumber)]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on (Int, NoteNumber) -> Int
forall a b. (a, b) -> a
fst ([(Int, NoteNumber)] -> [(Int, NoteNumber)])
-> [(Int, NoteNumber)] -> [(Int, NoteNumber)]
forall a b. (a -> b) -> a -> b
$ ((NoteNumber, Int) -> (Int, NoteNumber))
-> [(NoteNumber, Int)] -> [(Int, NoteNumber)]
forall a b. (a -> b) -> [a] -> [b]
map (NoteNumber, Int) -> (Int, NoteNumber)
forall a b. (a, b) -> (b, a)
Tuple.swap ([(NoteNumber, Int)] -> [(Int, NoteNumber)])
-> [(NoteNumber, Int)] -> [(Int, NoteNumber)]
forall a b. (a -> b) -> a -> b
$ Map NoteNumber Int -> [(NoteNumber, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map NoteNumber Int -> [(NoteNumber, Int)])
-> Map NoteNumber Int -> [(NoteNumber, Int)]
forall a b. (a -> b) -> a -> b
$
    (Int -> Int -> Int) -> [(NoteNumber, Int)] -> Map NoteNumber Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [(Note -> NoteNumber
initial_pitch Note
note, Int
1) | Note
note <- [Note]
notes ]

nonconstant_pitches :: [Note] -> [Note]
nonconstant_pitches :: [Note] -> [Note]
nonconstant_pitches = (Note -> Bool) -> [Note] -> [Note]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Note -> Bool) -> [Note] -> [Note])
-> (Note -> Bool) -> [Note] -> [Note]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Note -> Bool) -> Note -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealTime, NoteNumber)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(RealTime, NoteNumber)] -> Bool)
-> (Note -> [(RealTime, NoteNumber)]) -> Note -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> [(RealTime, NoteNumber)]
forall dur. NoteT dur -> [(RealTime, NoteNumber)]
note_pitches
    -- filter out ones after note-off
    -- take a decay time

initial_pitch :: Note -> Pitch.NoteNumber
initial_pitch :: Note -> NoteNumber
initial_pitch = NoteNumber -> NoteNumber
round_cents (NoteNumber -> NoteNumber)
-> (Note -> NoteNumber) -> Note -> NoteNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> NoteNumber
forall dur. NoteT dur -> NoteNumber
note_pitch

round_cents :: Pitch.NoteNumber -> Pitch.NoteNumber
round_cents :: NoteNumber -> NoteNumber
round_cents = (NoteNumber -> NoteNumber -> NoteNumber
forall a. Fractional a => a -> a -> a
/NoteNumber
100) (NoteNumber -> NoteNumber)
-> (NoteNumber -> NoteNumber) -> NoteNumber -> NoteNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (Integer -> NoteNumber)
-> (NoteNumber -> Integer) -> NoteNumber -> NoteNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteNumber -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (NoteNumber -> Integer)
-> (NoteNumber -> NoteNumber) -> NoteNumber -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NoteNumber -> NoteNumber -> NoteNumber
forall a. Num a => a -> a -> a
*NoteNumber
100)

-- * compute

data State = State {
    State -> State
state_channel :: !MState.State
    -- | Notes still sounding.  This retains notes for 'deactivate_time' after
    -- their note-off to capture controls during the decay.
    , State -> Map Addr [SoundingNote]
state_active :: !(Map Addr [SoundingNote])
    , State -> [Note]
state_notes :: ![Note]
    , State -> [(WriteMessage, Text)]
state_warns :: ![(Midi.WriteMessage, Text)]
    , State -> Map Addr PbRange
state_pb_range :: !(Map Addr PbRange)
    } deriving (Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)

-- | (down, up)
type PbRange = (Pitch.NoteNumber, Pitch.NoteNumber)

get_pb_range :: Addr -> State -> PbRange
get_pb_range :: Addr -> State -> PbRange
get_pb_range Addr
addr = PbRange -> Addr -> Map Addr PbRange -> PbRange
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (-NoteNumber
1, NoteNumber
1) Addr
addr (Map Addr PbRange -> PbRange)
-> (State -> Map Addr PbRange) -> State -> PbRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Addr PbRange
state_pb_range

empty_state :: State
empty_state :: State
empty_state = State
-> Map Addr [SoundingNote]
-> [Note]
-> [(WriteMessage, Text)]
-> Map Addr PbRange
-> State
State State
MState.empty Map Addr [SoundingNote]
forall a. Monoid a => a
mempty [] [] Map Addr PbRange
forall a. Monoid a => a
mempty

-- | SoundingNotes may still be open.
type SoundingNote = NoteT (Maybe RealTime)
type Note = NoteT RealTime

data NoteT dur = Note {
    forall dur. NoteT dur -> RealTime
note_start :: RealTime
    , forall dur. NoteT dur -> dur
note_duration :: dur
    , forall dur. NoteT dur -> Key
note_key :: Midi.Key
    , forall dur. NoteT dur -> Channel
note_vel :: Midi.Velocity
    , forall dur. NoteT dur -> NoteNumber
note_pitch :: Pitch.NoteNumber
    , forall dur. NoteT dur -> [(RealTime, NoteNumber)]
note_pitches :: [(RealTime, Pitch.NoteNumber)]
    , forall dur. NoteT dur -> ControlMap
note_controls :: ControlMap
    , forall dur. NoteT dur -> Addr
note_addr :: Addr
    } deriving (NoteT dur -> NoteT dur -> Bool
(NoteT dur -> NoteT dur -> Bool)
-> (NoteT dur -> NoteT dur -> Bool) -> Eq (NoteT dur)
forall dur. Eq dur => NoteT dur -> NoteT dur -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteT dur -> NoteT dur -> Bool
$c/= :: forall dur. Eq dur => NoteT dur -> NoteT dur -> Bool
== :: NoteT dur -> NoteT dur -> Bool
$c== :: forall dur. Eq dur => NoteT dur -> NoteT dur -> Bool
Eq, Int -> NoteT dur -> ShowS
[NoteT dur] -> ShowS
NoteT dur -> String
(Int -> NoteT dur -> ShowS)
-> (NoteT dur -> String)
-> ([NoteT dur] -> ShowS)
-> Show (NoteT dur)
forall dur. Show dur => Int -> NoteT dur -> ShowS
forall dur. Show dur => [NoteT dur] -> ShowS
forall dur. Show dur => NoteT dur -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteT dur] -> ShowS
$cshowList :: forall dur. Show dur => [NoteT dur] -> ShowS
show :: NoteT dur -> String
$cshow :: forall dur. Show dur => NoteT dur -> String
showsPrec :: Int -> NoteT dur -> ShowS
$cshowsPrec :: forall dur. Show dur => Int -> NoteT dur -> ShowS
Show)

type ControlMap = Map MState.Control [(RealTime, Midi.ControlValue)]

-- | Keep the current msg for 'warn'.
type SynthM a = Reader.ReaderT Midi.WriteMessage
    (State.StateT State Identity.Identity) a

modify :: (State -> State) -> SynthM ()
modify :: (State -> State) -> SynthM ()
modify State -> State
f = do
    State
st <- ReaderT WriteMessage (StateT State Identity) State
forall s (m :: * -> *). MonadState s m => m s
State.get
    State -> SynthM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> SynthM ()) -> State -> SynthM ()
forall a b. (a -> b) -> a -> b
$! State -> State
f State
st

run :: State -> [Midi.WriteMessage] -> State
run :: State -> [WriteMessage] -> State
run State
state [WriteMessage]
msgs = State -> State
postproc (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ StateT State Identity () -> State
forall {a}. StateT State Identity a -> State
run_state (((Maybe WriteMessage, WriteMessage) -> StateT State Identity ())
-> [(Maybe WriteMessage, WriteMessage)] -> StateT State Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe WriteMessage, WriteMessage) -> StateT State Identity ()
msg1 ([WriteMessage] -> [(Maybe WriteMessage, WriteMessage)]
forall a. [a] -> [(Maybe a, a)]
Seq.zip_prev [WriteMessage]
msgs))
    where
    run_state :: StateT State Identity a -> State
run_state = Identity State -> State
forall a. Identity a -> a
Identity.runIdentity (Identity State -> State)
-> (StateT State Identity a -> Identity State)
-> StateT State Identity a
-> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT State Identity a -> State -> Identity State)
-> State -> StateT State Identity a -> Identity State
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT State Identity a -> State -> Identity State
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
State.execStateT State
state
    msg1 :: (Maybe WriteMessage, WriteMessage) -> StateT State Identity ()
msg1 (Maybe WriteMessage
prev, WriteMessage
wmsg) = (SynthM () -> WriteMessage -> StateT State Identity ())
-> WriteMessage -> SynthM () -> StateT State Identity ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SynthM () -> WriteMessage -> StateT State Identity ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT WriteMessage
wmsg (SynthM () -> StateT State Identity ())
-> SynthM () -> StateT State Identity ()
forall a b. (a -> b) -> a -> b
$ do
        let prev_t :: RealTime
prev_t = RealTime
-> (WriteMessage -> RealTime) -> Maybe WriteMessage -> RealTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
0 WriteMessage -> RealTime
Midi.wmsg_ts Maybe WriteMessage
prev
        Bool -> SynthM () -> SynthM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
wmsg RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
< RealTime
prev_t) (SynthM () -> SynthM ()) -> SynthM () -> SynthM ()
forall a b. (a -> b) -> a -> b
$
            Text -> SynthM ()
warn (Text -> SynthM ()) -> Text -> SynthM ()
forall a b. (a -> b) -> a -> b
$ Text
"timestamp less than previous: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
prev_t
        WriteMessage -> SynthM ()
run_msg WriteMessage
wmsg

postproc :: State -> State
postproc :: State -> State
postproc State
state_ = State
state
    { state_active :: Map Addr [SoundingNote]
state_active = (Addr -> [SoundingNote] -> Bool)
-> Map Addr [SoundingNote] -> Map Addr [SoundingNote]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Addr
_ [SoundingNote]
ns -> Bool -> Bool
not ([SoundingNote] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SoundingNote]
ns)) (Map Addr [SoundingNote] -> Map Addr [SoundingNote])
-> Map Addr [SoundingNote] -> Map Addr [SoundingNote]
forall a b. (a -> b) -> a -> b
$
        ([SoundingNote] -> [SoundingNote])
-> Map Addr [SoundingNote] -> Map Addr [SoundingNote]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((SoundingNote -> SoundingNote) -> [SoundingNote] -> [SoundingNote]
forall a b. (a -> b) -> [a] -> [b]
map SoundingNote -> SoundingNote
forall {dur}. NoteT dur -> NoteT dur
postproc_note) (State -> Map Addr [SoundingNote]
state_active State
state)
    , state_notes :: [Note]
state_notes = [Note] -> [Note]
forall a. [a] -> [a]
reverse ([Note] -> [Note]) -> [Note] -> [Note]
forall a b. (a -> b) -> a -> b
$ (Note -> Note) -> [Note] -> [Note]
forall a b. (a -> b) -> [a] -> [b]
map Note -> Note
forall {dur}. NoteT dur -> NoteT dur
postproc_note (State -> [Note]
state_notes State
state)
    , state_warns :: [(WriteMessage, Text)]
state_warns = [(WriteMessage, Text)] -> [(WriteMessage, Text)]
forall a. [a] -> [a]
reverse ([(WriteMessage, Text)] -> [(WriteMessage, Text)])
-> [(WriteMessage, Text)] -> [(WriteMessage, Text)]
forall a b. (a -> b) -> a -> b
$ State -> [(WriteMessage, Text)]
state_warns State
state
    }
    where
    state :: State
state = RealTime -> State -> State
deactivate RealTime
9999999 State
state_
    postproc_note :: NoteT dur -> NoteT dur
postproc_note NoteT dur
note = NoteT dur
note
        { note_controls :: ControlMap
note_controls = ([(RealTime, Channel)] -> [(RealTime, Channel)])
-> ControlMap -> ControlMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [(RealTime, Channel)] -> [(RealTime, Channel)]
forall a. [a] -> [a]
reverse (NoteT dur -> ControlMap
forall dur. NoteT dur -> ControlMap
note_controls NoteT dur
note)
        , note_pitches :: [(RealTime, NoteNumber)]
note_pitches = [(RealTime, NoteNumber)] -> [(RealTime, NoteNumber)]
forall a. [a] -> [a]
reverse (NoteT dur -> [(RealTime, NoteNumber)]
forall dur. NoteT dur -> [(RealTime, NoteNumber)]
note_pitches NoteT dur
note)
        }

run_msg :: Midi.WriteMessage -> SynthM ()
run_msg :: WriteMessage -> SynthM ()
run_msg wmsg :: WriteMessage
wmsg@(Midi.WriteMessage WriteDevice
dev RealTime
ts (Midi.ChannelMessage Channel
chan ChannelMessage
msg)) = do
    let addr :: Addr
addr = (WriteDevice
dev, Channel
chan)
    (State -> State) -> SynthM ()
modify ((State -> State) -> SynthM ()) -> (State -> State) -> SynthM ()
forall a b. (a -> b) -> a -> b
$ WriteMessage -> State -> State
update_channel_state WriteMessage
wmsg (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> State -> State
deactivate RealTime
ts
    case ChannelMessage -> ChannelMessage
normalize_msg ChannelMessage
msg of
        Midi.NoteOff Key
key Channel
_ -> Addr -> RealTime -> Key -> SynthM ()
note_off Addr
addr RealTime
ts Key
key
        Midi.NoteOn Key
key Channel
vel -> Addr -> RealTime -> Key -> Channel -> SynthM ()
note_on Addr
addr RealTime
ts Key
key Channel
vel
        Midi.Aftertouch Key
_ Channel
_ -> Text -> SynthM ()
warn Text
"aftertouch not supported"
        Midi.ControlChange Channel
c Channel
val -> Addr -> RealTime -> Control -> Channel -> SynthM ()
control Addr
addr RealTime
ts (Channel -> Control
MState.CC Channel
c) Channel
val
        Midi.ProgramChange Channel
_ -> Text -> SynthM ()
warn Text
"program change not supported"
        Midi.ChannelPressure Channel
val -> Addr -> RealTime -> Control -> Channel -> SynthM ()
control Addr
addr RealTime
ts Control
MState.Pressure Channel
val
        Midi.PitchBend PitchBendValue
val -> Addr -> RealTime -> PitchBendValue -> SynthM ()
pitch_bend Addr
addr RealTime
ts PitchBendValue
val
        ChannelMessage
_ -> Text -> SynthM ()
warn Text
"unhandled msg"
run_msg WriteMessage
_ = () -> SynthM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

update_channel_state :: Midi.WriteMessage -> State -> State
update_channel_state :: WriteMessage -> State -> State
update_channel_state WriteMessage
wmsg State
state =
    State
state { state_channel :: State
state_channel = State -> Message -> State
MState.process (State -> State
state_channel State
state) Message
msg }
    where msg :: Message
msg = (WriteMessage -> WriteDevice
Midi.wmsg_dev WriteMessage
wmsg, WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg)

normalize_msg :: Midi.ChannelMessage -> Midi.ChannelMessage
normalize_msg :: ChannelMessage -> ChannelMessage
normalize_msg (Midi.NoteOn Key
key Channel
0) = Key -> Channel -> ChannelMessage
Midi.NoteOff Key
key Channel
1
normalize_msg ChannelMessage
msg = ChannelMessage
msg

-- | After notes have had a note-off time for a certain amount of time, move
-- them from 'state_active' to 'state_notes'.  The certain amount of time
-- should be the note's decay time, but since I don't really know that, just
-- pick an arbitrary constant.
deactivate :: RealTime -> State -> State
deactivate :: RealTime -> State -> State
deactivate RealTime
now State
state = State
state
    { state_active :: Map Addr [SoundingNote]
state_active = Map Addr [SoundingNote]
still_active
    , state_notes :: [Note]
state_notes = (SoundingNote -> Maybe Note) -> [SoundingNote] -> [Note]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SoundingNote -> Maybe Note
forall {dur}. NoteT (Maybe dur) -> Maybe (NoteT dur)
close ([[SoundingNote]] -> [SoundingNote]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SoundingNote]]
done) [Note] -> [Note] -> [Note]
forall a. [a] -> [a] -> [a]
++ State -> [Note]
state_notes State
state
    }
    where
    ([Addr]
addrs, ([[SoundingNote]]
done, [[SoundingNote]]
active)) = ([([SoundingNote], [SoundingNote])]
 -> ([[SoundingNote]], [[SoundingNote]]))
-> ([Addr], [([SoundingNote], [SoundingNote])])
-> ([Addr], ([[SoundingNote]], [[SoundingNote]]))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [([SoundingNote], [SoundingNote])]
-> ([[SoundingNote]], [[SoundingNote]])
forall a b. [(a, b)] -> ([a], [b])
unzip (([Addr], [([SoundingNote], [SoundingNote])])
 -> ([Addr], ([[SoundingNote]], [[SoundingNote]])))
-> ([Addr], [([SoundingNote], [SoundingNote])])
-> ([Addr], ([[SoundingNote]], [[SoundingNote]]))
forall a b. (a -> b) -> a -> b
$ [(Addr, ([SoundingNote], [SoundingNote]))]
-> ([Addr], [([SoundingNote], [SoundingNote])])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Addr, ([SoundingNote], [SoundingNote]))]
 -> ([Addr], [([SoundingNote], [SoundingNote])]))
-> [(Addr, ([SoundingNote], [SoundingNote]))]
-> ([Addr], [([SoundingNote], [SoundingNote])])
forall a b. (a -> b) -> a -> b
$
        ((Addr, [SoundingNote])
 -> (Addr, ([SoundingNote], [SoundingNote])))
-> [(Addr, [SoundingNote])]
-> [(Addr, ([SoundingNote], [SoundingNote]))]
forall a b. (a -> b) -> [a] -> [b]
map (([SoundingNote] -> ([SoundingNote], [SoundingNote]))
-> (Addr, [SoundingNote])
-> (Addr, ([SoundingNote], [SoundingNote]))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((SoundingNote -> Bool)
-> [SoundingNote] -> ([SoundingNote], [SoundingNote])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition SoundingNote -> Bool
note_done)) ([(Addr, [SoundingNote])]
 -> [(Addr, ([SoundingNote], [SoundingNote]))])
-> [(Addr, [SoundingNote])]
-> [(Addr, ([SoundingNote], [SoundingNote]))]
forall a b. (a -> b) -> a -> b
$
        Map Addr [SoundingNote] -> [(Addr, [SoundingNote])]
forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map Addr [SoundingNote]
state_active State
state)
    still_active :: Map Addr [SoundingNote]
still_active = [(Addr, [SoundingNote])] -> Map Addr [SoundingNote]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Addr, [SoundingNote])] -> Map Addr [SoundingNote])
-> [(Addr, [SoundingNote])] -> Map Addr [SoundingNote]
forall a b. (a -> b) -> a -> b
$ ((Addr, [SoundingNote]) -> Bool)
-> [(Addr, [SoundingNote])] -> [(Addr, [SoundingNote])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Addr, [SoundingNote]) -> Bool)
-> (Addr, [SoundingNote])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SoundingNote] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([SoundingNote] -> Bool)
-> ((Addr, [SoundingNote]) -> [SoundingNote])
-> (Addr, [SoundingNote])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Addr, [SoundingNote]) -> [SoundingNote]
forall a b. (a, b) -> b
snd) ([(Addr, [SoundingNote])] -> [(Addr, [SoundingNote])])
-> [(Addr, [SoundingNote])] -> [(Addr, [SoundingNote])]
forall a b. (a -> b) -> a -> b
$ [Addr] -> [[SoundingNote]] -> [(Addr, [SoundingNote])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Addr]
addrs [[SoundingNote]]
active
    note_done :: SoundingNote -> Bool
note_done SoundingNote
note = case SoundingNote -> Maybe RealTime
forall dur. NoteT dur -> dur
note_duration SoundingNote
note of
        Just RealTime
d -> RealTime
now RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= RealTime
d RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
deactivate_time
        Maybe RealTime
Nothing -> Bool
False
    close :: NoteT (Maybe dur) -> Maybe (NoteT dur)
close NoteT (Maybe dur)
note = case NoteT (Maybe dur) -> Maybe dur
forall dur. NoteT dur -> dur
note_duration NoteT (Maybe dur)
note of
        Maybe dur
Nothing -> Maybe (NoteT dur)
forall a. Maybe a
Nothing
        Just dur
d -> NoteT dur -> Maybe (NoteT dur)
forall a. a -> Maybe a
Just (NoteT dur -> Maybe (NoteT dur)) -> NoteT dur -> Maybe (NoteT dur)
forall a b. (a -> b) -> a -> b
$ NoteT (Maybe dur)
note { note_duration :: dur
note_duration = dur
d }

deactivate_time :: RealTime
deactivate_time :: RealTime
deactivate_time = RealTime
1

-- * msgs

note_on :: Addr -> RealTime -> Midi.Key -> Midi.Velocity -> SynthM ()
note_on :: Addr -> RealTime -> Key -> Channel -> SynthM ()
note_on Addr
addr RealTime
ts Key
key Channel
vel = do
    [SoundingNote]
active <- (State -> [SoundingNote])
-> ReaderT WriteMessage (StateT State Identity) [SoundingNote]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ((State -> [SoundingNote])
 -> ReaderT WriteMessage (StateT State Identity) [SoundingNote])
-> (State -> [SoundingNote])
-> ReaderT WriteMessage (StateT State Identity) [SoundingNote]
forall a b. (a -> b) -> a -> b
$ [SoundingNote] -> Addr -> Map Addr [SoundingNote] -> [SoundingNote]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Addr
addr (Map Addr [SoundingNote] -> [SoundingNote])
-> (State -> Map Addr [SoundingNote]) -> State -> [SoundingNote]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Addr [SoundingNote]
state_active
    let sounding :: [SoundingNote]
sounding = (SoundingNote -> Bool) -> [SoundingNote] -> [SoundingNote]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> SoundingNote -> Bool
key_sounding Key
key) [SoundingNote]
active
    Bool -> SynthM () -> SynthM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SoundingNote] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SoundingNote]
sounding) (SynthM () -> SynthM ()) -> SynthM () -> SynthM ()
forall a b. (a -> b) -> a -> b
$
        Text -> SynthM ()
warn (Text -> SynthM ()) -> Text -> SynthM ()
forall a b. (a -> b) -> a -> b
$ Text
"sounding notes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [SoundingNote] -> Text
forall a. Pretty a => a -> Text
pretty [SoundingNote]
sounding
    Channel
channel <- (State -> Channel)
-> ReaderT WriteMessage (StateT State Identity) Channel
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ((State -> Channel)
 -> ReaderT WriteMessage (StateT State Identity) Channel)
-> (State -> Channel)
-> ReaderT WriteMessage (StateT State Identity) Channel
forall a b. (a -> b) -> a -> b
$ Addr -> State -> Channel
MState.get_channel Addr
addr (State -> Channel) -> (State -> State) -> State -> Channel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
state_channel
    PbRange
pb_range <- (State -> PbRange)
-> ReaderT WriteMessage (StateT State Identity) PbRange
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ((State -> PbRange)
 -> ReaderT WriteMessage (StateT State Identity) PbRange)
-> (State -> PbRange)
-> ReaderT WriteMessage (StateT State Identity) PbRange
forall a b. (a -> b) -> a -> b
$ Addr -> State -> PbRange
get_pb_range Addr
addr
    Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr (PbRange
-> Channel -> Addr -> RealTime -> Key -> Channel -> SoundingNote
make_note PbRange
pb_range Channel
channel Addr
addr RealTime
ts Key
key Channel
vel :)

make_note :: PbRange -> MState.Channel -> Addr -> RealTime -> Midi.Key
    -> Midi.Velocity -> SoundingNote
make_note :: PbRange
-> Channel -> Addr -> RealTime -> Key -> Channel -> SoundingNote
make_note PbRange
pb_range Channel
state Addr
addr RealTime
start Key
key Channel
vel = Note
    { note_start :: RealTime
note_start = RealTime
start
    , note_duration :: Maybe RealTime
note_duration = Maybe RealTime
forall a. Maybe a
Nothing
    , note_key :: Key
note_key = Key
key
    , note_vel :: Channel
note_vel = Channel
vel
    , note_pitch :: NoteNumber
note_pitch = PbRange -> Key -> PitchBendValue -> NoteNumber
convert_pitch PbRange
pb_range Key
key (Channel -> PitchBendValue
MState.chan_pb Channel
state)
    , note_pitches :: [(RealTime, NoteNumber)]
note_pitches = []
    , note_controls :: ControlMap
note_controls = Channel -> [(RealTime, Channel)]
forall {b}. b -> [(RealTime, b)]
here (Channel -> [(RealTime, Channel)])
-> Map Control Channel -> ControlMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Channel -> Map Control Channel
MState.chan_controls Channel
state
    , note_addr :: Addr
note_addr = Addr
addr
    }
    where here :: b -> [(RealTime, b)]
here b
val = [(RealTime
start, b
val)]

note_off :: Addr -> RealTime -> Midi.Key -> SynthM ()
note_off :: Addr -> RealTime -> Key -> SynthM ()
note_off Addr
addr RealTime
ts Key
key = do
    [SoundingNote]
active <- (State -> [SoundingNote])
-> ReaderT WriteMessage (StateT State Identity) [SoundingNote]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ((State -> [SoundingNote])
 -> ReaderT WriteMessage (StateT State Identity) [SoundingNote])
-> (State -> [SoundingNote])
-> ReaderT WriteMessage (StateT State Identity) [SoundingNote]
forall a b. (a -> b) -> a -> b
$ [SoundingNote] -> Addr -> Map Addr [SoundingNote] -> [SoundingNote]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Addr
addr (Map Addr [SoundingNote] -> [SoundingNote])
-> (State -> Map Addr [SoundingNote]) -> State -> [SoundingNote]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Addr [SoundingNote]
state_active
    let ([SoundingNote]
sounding, [SoundingNote]
rest) = (SoundingNote -> Bool)
-> [SoundingNote] -> ([SoundingNote], [SoundingNote])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (Key -> SoundingNote -> Bool
key_sounding Key
key) [SoundingNote]
active
    case [SoundingNote]
sounding of
        [] -> Text -> SynthM ()
warn Text
"no sounding notes"
        SoundingNote
n : [SoundingNote]
ns -> do
            Bool -> SynthM () -> SynthM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SoundingNote] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SoundingNote]
ns) (SynthM () -> SynthM ()) -> SynthM () -> SynthM ()
forall a b. (a -> b) -> a -> b
$
                Text -> SynthM ()
warn (Text -> SynthM ()) -> Text -> SynthM ()
forall a b. (a -> b) -> a -> b
$ Text
"multiple sounding notes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [SoundingNote] -> Text
forall a. Pretty a => a -> Text
pretty [SoundingNote]
sounding
            Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr (([SoundingNote] -> [SoundingNote]) -> SynthM ())
-> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
forall a b. (a -> b) -> a -> b
$ [SoundingNote] -> [SoundingNote] -> [SoundingNote]
forall a b. a -> b -> a
const ([SoundingNote] -> [SoundingNote] -> [SoundingNote])
-> [SoundingNote] -> [SoundingNote] -> [SoundingNote]
forall a b. (a -> b) -> a -> b
$
                SoundingNote
n { note_duration :: Maybe RealTime
note_duration = RealTime -> Maybe RealTime
forall a. a -> Maybe a
Just RealTime
ts } SoundingNote -> [SoundingNote] -> [SoundingNote]
forall a. a -> [a] -> [a]
: [SoundingNote]
rest

key_sounding :: Midi.Key -> SoundingNote -> Bool
key_sounding :: Key -> SoundingNote -> Bool
key_sounding Key
key SoundingNote
n = SoundingNote -> Maybe RealTime
forall dur. NoteT dur -> dur
note_duration SoundingNote
n Maybe RealTime -> Maybe RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe RealTime
forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& SoundingNote -> Key
forall dur. NoteT dur -> Key
note_key SoundingNote
n Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
key

-- | Append a CC change to all sounding notes.
control :: Addr -> RealTime -> MState.Control -> Midi.ControlValue -> SynthM ()
control :: Addr -> RealTime -> Control -> Channel -> SynthM ()
control Addr
addr RealTime
ts Control
control Channel
val = Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr ((SoundingNote -> SoundingNote) -> [SoundingNote] -> [SoundingNote]
forall a b. (a -> b) -> [a] -> [b]
map SoundingNote -> SoundingNote
forall {dur}. NoteT dur -> NoteT dur
insert)
    where
    insert :: NoteT dur -> NoteT dur
insert NoteT dur
note = NoteT dur
note { note_controls :: ControlMap
note_controls =
        ([(RealTime, Channel)]
 -> [(RealTime, Channel)] -> [(RealTime, Channel)])
-> Control -> [(RealTime, Channel)] -> ControlMap -> ControlMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(RealTime, Channel)]
-> [(RealTime, Channel)] -> [(RealTime, Channel)]
forall a. [a] -> [a] -> [a]
(++) Control
control [(RealTime
ts, Channel
val)] (NoteT dur -> ControlMap
forall dur. NoteT dur -> ControlMap
note_controls NoteT dur
note) }

-- | Append pitch bend to all sounding notes.
pitch_bend :: Addr -> RealTime -> Midi.PitchBendValue -> SynthM ()
pitch_bend :: Addr -> RealTime -> PitchBendValue -> SynthM ()
pitch_bend Addr
addr RealTime
ts PitchBendValue
val = do
    PbRange
pb_range <- (State -> PbRange)
-> ReaderT WriteMessage (StateT State Identity) PbRange
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ((State -> PbRange)
 -> ReaderT WriteMessage (StateT State Identity) PbRange)
-> (State -> PbRange)
-> ReaderT WriteMessage (StateT State Identity) PbRange
forall a b. (a -> b) -> a -> b
$ Addr -> State -> PbRange
get_pb_range Addr
addr
    Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr ((SoundingNote -> SoundingNote) -> [SoundingNote] -> [SoundingNote]
forall a b. (a -> b) -> [a] -> [b]
map (PbRange -> SoundingNote -> SoundingNote
forall {dur}. PbRange -> NoteT dur -> NoteT dur
insert PbRange
pb_range))
    where
    insert :: PbRange -> NoteT dur -> NoteT dur
insert PbRange
pb_range NoteT dur
note = NoteT dur
note { note_pitches :: [(RealTime, NoteNumber)]
note_pitches =
        (RealTime
ts, PbRange -> Key -> PitchBendValue -> NoteNumber
convert_pitch PbRange
pb_range (NoteT dur -> Key
forall dur. NoteT dur -> Key
note_key NoteT dur
note) PitchBendValue
val) (RealTime, NoteNumber)
-> [(RealTime, NoteNumber)] -> [(RealTime, NoteNumber)]
forall a. a -> [a] -> [a]
: NoteT dur -> [(RealTime, NoteNumber)]
forall dur. NoteT dur -> [(RealTime, NoteNumber)]
note_pitches NoteT dur
note }

convert_pitch :: PbRange -> Midi.Key -> Midi.PitchBendValue -> Pitch.NoteNumber
convert_pitch :: PbRange -> Key -> PitchBendValue -> NoteNumber
convert_pitch (NoteNumber
down, NoteNumber
up) Key
key PitchBendValue
val = Key -> NoteNumber
forall a. Num a => Key -> a
Midi.from_key Key
key NoteNumber -> NoteNumber -> NoteNumber
forall a. Num a => a -> a -> a
+ PitchBendValue -> NoteNumber
convert PitchBendValue
val
    where
    convert :: PitchBendValue -> NoteNumber
convert PitchBendValue
v
        | PitchBendValue
v PitchBendValue -> PitchBendValue -> Bool
forall a. Ord a => a -> a -> Bool
>= PitchBendValue
0 = Double -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (PitchBendValue -> Double
Num.f2d PitchBendValue
v) NoteNumber -> NoteNumber -> NoteNumber
forall a. Num a => a -> a -> a
* NoteNumber
up
        | Bool
otherwise = Double -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (- (PitchBendValue -> Double
Num.f2d PitchBendValue
v)) NoteNumber -> NoteNumber -> NoteNumber
forall a. Num a => a -> a -> a
* NoteNumber
down

modify_notes :: Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes :: Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr [SoundingNote] -> [SoundingNote]
f = do
    Map Addr [SoundingNote]
active <- (State -> Map Addr [SoundingNote])
-> ReaderT
     WriteMessage (StateT State Identity) (Map Addr [SoundingNote])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Map Addr [SoundingNote]
state_active
    let notes :: [SoundingNote]
notes = [SoundingNote] -> Addr -> Map Addr [SoundingNote] -> [SoundingNote]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Addr
addr Map Addr [SoundingNote]
active
    (State -> State) -> SynthM ()
modify ((State -> State) -> SynthM ()) -> (State -> State) -> SynthM ()
forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
        { state_active :: Map Addr [SoundingNote]
state_active = Addr
-> [SoundingNote]
-> Map Addr [SoundingNote]
-> Map Addr [SoundingNote]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr ([SoundingNote] -> [SoundingNote]
f [SoundingNote]
notes) (State -> Map Addr [SoundingNote]
state_active State
state) }

-- * util

warn :: Text -> SynthM ()
warn :: Text -> SynthM ()
warn Text
msg = do
    WriteMessage
wmsg <- ReaderT WriteMessage (StateT State Identity) WriteMessage
forall r (m :: * -> *). MonadReader r m => m r
Reader.ask
    (State -> State) -> SynthM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((State -> State) -> SynthM ()) -> (State -> State) -> SynthM ()
forall a b. (a -> b) -> a -> b
$ \State
state ->
        State
state { state_warns :: [(WriteMessage, Text)]
state_warns = (WriteMessage
wmsg, Text
msg) (WriteMessage, Text)
-> [(WriteMessage, Text)] -> [(WriteMessage, Text)]
forall a. a -> [a] -> [a]
: State -> [(WriteMessage, Text)]
state_warns State
state }


-- * pretty

-- | Format synth state in an easier to read way.
pretty_state :: State -> Text
pretty_state :: State -> Text
pretty_state (State State
_chan Map Addr [SoundingNote]
active [Note]
notes [(WriteMessage, Text)]
warns Map Addr PbRange
_) = Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Text
"active:"], (SoundingNote -> Text) -> [SoundingNote] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SoundingNote -> Text
forall a. Pretty a => a -> Text
pretty ([[SoundingNote]] -> [SoundingNote]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Map Addr [SoundingNote] -> [[SoundingNote]]
forall k a. Map k a -> [a]
Map.elems Map Addr [SoundingNote]
active))
    , [Text
"", Text
"warns:"], ((WriteMessage, Text) -> Text) -> [(WriteMessage, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (WriteMessage, Text) -> Text
pretty_warn [(WriteMessage, Text)]
warns
    , [Text
"", Text
"notes:"], (Note -> Text) -> [Note] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Note -> Text
forall a. Pretty a => a -> Text
pretty [Note]
notes
    ]

instance Pretty dur => Pretty (NoteT dur) where
    pretty :: NoteT dur -> Text
pretty (Note RealTime
start dur
dur Key
_key Channel
vel NoteNumber
pitch [(RealTime, NoteNumber)]
pitches ControlMap
controls (WriteDevice
dev, Channel
chan)) =
        [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
            [ Text
addr_s, NoteNumber -> Text
forall a. Pretty a => a -> Text
pretty (NoteNumber -> NoteNumber
round_cents NoteNumber
pitch)
            , RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> dur -> Text
forall a. Pretty a => a -> Text
pretty dur
dur Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
            , Text
"vel:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Channel -> Text
forall a. (Integral a, Show a) => Int -> a -> Text
Num.hex Int
2 Channel
vel
            , if [(RealTime, NoteNumber)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RealTime, NoteNumber)]
pitches then Text
"" else Text
" p:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(RealTime, NoteNumber)] -> Text
forall a. Pretty a => a -> Text
pretty [(RealTime, NoteNumber)]
pitches
            , if ControlMap -> Bool
forall k a. Map k a -> Bool
Map.null ControlMap
controls then Text
""
                else Text
" c:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ControlMap -> Text
pretty_controls ControlMap
controls
            ]
        where addr_s :: Text
addr_s = WriteDevice -> Text
forall a. Pretty a => a -> Text
pretty WriteDevice
dev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Channel -> Text
forall a. Show a => a -> Text
showt Channel
chan

pretty_controls :: ControlMap -> Text
pretty_controls :: ControlMap -> Text
pretty_controls ControlMap
controls = Text -> [Text] -> Text
Text.intercalate Text
"\n\t"
    [Control -> Text
forall a. Show a => a -> Text
showt Control
cont Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(RealTime, Channel)] -> Text
forall a. Pretty a => a -> Text
pretty [(RealTime, Channel)]
vals | (Control
cont, [(RealTime, Channel)]
vals) <- ControlMap -> [(Control, [(RealTime, Channel)])]
forall k a. Map k a -> [(k, a)]
Map.assocs ControlMap
controls]

pretty_warn :: (Midi.WriteMessage, Text) -> Text
pretty_warn :: (WriteMessage, Text) -> Text
pretty_warn (Midi.WriteMessage WriteDevice
dev RealTime
ts (Midi.ChannelMessage Channel
chan ChannelMessage
msg), Text
warn) =
    RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
ts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> WriteDevice -> Text
forall a. Pretty a => a -> Text
pretty WriteDevice
dev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Channel -> Text
forall a. Show a => a -> Text
showt Channel
chan
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChannelMessage -> Text
forall a. Show a => a -> Text
showt ChannelMessage
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
warn
pretty_warn (Midi.WriteMessage WriteDevice
dev RealTime
ts Message
msg, Text
warn) =
    RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
ts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> WriteDevice -> Text
forall a. Pretty a => a -> Text
pretty WriteDevice
dev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Message -> Text
forall a. Show a => a -> Text
showt Message
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
warn