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

-- | Functions for instrument cmds.  This is called CUtil because there is also
-- "Derive.Instrument.DUtil" and they are usually imported together.
--
-- I need a better name than \"Util\" for everything.
module Cmd.Instrument.CUtil where
import qualified Data.Either as Either
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe

import qualified Util.Seq as Seq
import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.EditUtil as EditUtil
import qualified Cmd.Instrument.Drums as Drums
import qualified Cmd.Instrument.ImInst as ImInst
import qualified Cmd.Instrument.MidiInst as MidiInst
import qualified Cmd.MidiThru as MidiThru
import qualified Cmd.Msg as Msg
import qualified Cmd.Perf as Perf
import qualified Cmd.PhysicalKey as PhysicalKey
import qualified Cmd.Selection as Selection

import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.LEvent as LEvent
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig

import qualified Instrument.Common as Common
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch
import qualified Perform.NN as NN
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Thru as Thru
import qualified Ui.KeycapsT as KeycapsT
import qualified Ui.UiMsg as UiMsg

import           Global
import           Types


-- * eval call

insert_call :: Cmd.M m => Thru -> [(Char, Expr.Symbol)] -> Cmd.Handler m
insert_call :: forall (m :: * -> *). M m => Thru -> [(Char, Symbol)] -> Handler m
insert_call Thru
thru [(Char, Symbol)]
char_syms = Thru -> NoteEntryMap Expr -> Handler m
forall (m :: * -> *). M m => Thru -> NoteEntryMap Expr -> Handler m
insert_expr Thru
thru (Map Char Expr -> NoteEntryMap Expr
forall a. Map Char a -> NoteEntryMap a
Cmd.WithoutOctave Map Char Expr
forall {val}. Map Char (Expr val)
char_to_expr)
    where
    to_expr :: Symbol -> Expr val
to_expr Symbol
call = Symbol -> Expr val
forall val. Symbol -> Expr val
Expr.generator0 Symbol
call
    char_to_expr :: Map Char (Expr val)
char_to_expr = [(Char, Expr val)] -> Map Char (Expr val)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Char, Expr val)] -> Map Char (Expr val))
-> [(Char, Expr val)] -> Map Char (Expr val)
forall a b. (a -> b) -> a -> b
$
        ((Char, Symbol) -> (Char, Expr val))
-> [(Char, Symbol)] -> [(Char, Expr val)]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char)
-> (Symbol -> Expr val) -> (Char, Symbol) -> (Char, Expr val)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Stack => Char -> Char
Char -> Char
PhysicalKey.physical_key Symbol -> Expr val
forall val. Symbol -> Expr val
to_expr) [(Char, Symbol)]
char_syms

strokes_to_calls :: [Drums.Stroke] -> [(Char, Expr.Symbol)]
strokes_to_calls :: [Stroke] -> [(Char, Symbol)]
strokes_to_calls [Stroke]
strokes =
    [(Stroke -> Char
Drums._char Stroke
s, Stroke -> Symbol
Drums._name Stroke
s) | Stroke
s <- [Stroke]
strokes, Stroke -> Char
Drums._char Stroke
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ']
    -- As advertised in 'Drums.Stroke', don't bind to ' '.

-- | Select the flavor of thru to use when inserting an expression.  This
-- selects either 'expr_midi_thru' or 'expr_im_thru'.
--
-- Choosing manually is silly because the valid kind of thru depends on the
-- patch type.  It's just that due to history and wanting to avoid duplicated
-- code, the Cmd and Derive code in here doesn't care about MIDI vs. im...
-- except for thru.
data Thru = MidiThru | ImThru !Thru.ThruFunction | NoThru
    -- WRT ImThru, I can't just delegate to MidiThru.cmd_midi_thru because it
    -- doesn't know about the attrs, since it uses
    -- Cmd.get_instrument_attributes.

-- | Create a custom kbd entry cmd that inserts tracklang expressions at
-- the insertion point.  Since this shadows the default note entry cmd, it
-- has to handle thru on its own.
insert_expr :: Cmd.M m => Thru -- ^ Evaluate the expression and emit MIDI thru.
    -> Cmd.NoteEntryMap DeriveT.Expr
    -> Cmd.Handler m
insert_expr :: forall (m :: * -> *). M m => Thru -> NoteEntryMap Expr -> Handler m
insert_expr Thru
thru NoteEntryMap Expr
note_entry_map = (Msg -> m Status) -> Handler m
forall {m :: * -> *}. (Msg -> m Status) -> Handler m
handler ((Msg -> m Status) -> Handler m) -> (Msg -> m Status) -> Handler m
forall a b. (a -> b) -> a -> b
$ \Msg
msg -> do
    m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM m Bool
forall (m :: * -> *). M m => m Bool
Cmd.is_kbd_entry m ()
forall (m :: * -> *) a. M m => m a
Cmd.abort
    Fallthrough -> Msg -> m ()
forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.NoBackspace Msg
msg
    (KbdState
kstate, Char
char) <- Maybe (KbdState, Char) -> m (KbdState, Char)
forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless (Maybe (KbdState, Char) -> m (KbdState, Char))
-> Maybe (KbdState, Char) -> m (KbdState, Char)
forall a b. (a -> b) -> a -> b
$ Msg -> Maybe (KbdState, Char)
Msg.char Msg
msg
    Octave
octave <- (State -> Octave) -> m Octave
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets ((State -> Octave) -> m Octave) -> (State -> Octave) -> m Octave
forall a b. (a -> b) -> a -> b
$ EditState -> Octave
Cmd.state_kbd_entry_octave (EditState -> Octave) -> (State -> EditState) -> State -> Octave
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit
    case Octave -> Char -> NoteEntryMap Expr -> Maybe Expr
forall a. Octave -> Char -> NoteEntryMap a -> Maybe a
Cmd.note_entry_lookup Octave
octave Char
char NoteEntryMap Expr
note_entry_map of
        Maybe Expr
Nothing
            -- Eat keys that normally would be eaten by kbd entry.  Otherwise
            -- it'll fall through to normal kbd entry and try to enter a
            -- pitched note.
            --
            -- TODO another possibly cleaner way to accomplish this would be to
            -- put the NoteEntry stuff in as a default instrument cmd, so I
            -- could just replace it entirely.  But I still want to mask out
            -- those PhysicalKey.pitch_map keys because it seems to confusing
            -- to fall through to an editing key.
            | Char -> Map Char Pitch -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Char
char Map Char Pitch
PhysicalKey.pitch_map -> Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
            | Bool
otherwise -> Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
        Just Expr
expr -> do
            case Thru
thru of
                Thru
NoThru -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Thru
MidiThru -> KbdState -> Expr -> m ()
forall (m :: * -> *). M m => KbdState -> Expr -> m ()
expr_midi_thru KbdState
kstate Expr
expr
                ImThru ThruFunction
thru_f -> case KbdState
kstate of
                    KbdState
UiMsg.KeyDown ->
                        (Thru -> m ()) -> [Thru] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Thru -> m ()
forall (m :: * -> *). M m => Thru -> m ()
Cmd.write_thru ([Thru] -> m ()) -> m [Thru] -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ThruFunction -> Expr -> m [Thru]
forall (m :: * -> *). M m => ThruFunction -> Expr -> m [Thru]
expr_im_thru ThruFunction
thru_f Expr
expr
                    KbdState
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            case KbdState
kstate of
                KbdState
UiMsg.KeyDown -> Expr -> m ()
forall {m :: * -> *} {a}. (M m, ShowVal a) => a -> m ()
keydown Expr
expr
                KbdState
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
    where
    handler :: (Msg -> m Status) -> Handler m
handler = Maybe (NoteEntryMap KeyDoc) -> NamedCmd m -> Handler m
forall (m :: * -> *).
Maybe (NoteEntryMap KeyDoc) -> NamedCmd m -> Handler m
Cmd.Handler
        (NoteEntryMap KeyDoc -> Maybe (NoteEntryMap KeyDoc)
forall a. a -> Maybe a
Just (NoteEntryMap KeyDoc -> Maybe (NoteEntryMap KeyDoc))
-> NoteEntryMap KeyDoc -> Maybe (NoteEntryMap KeyDoc)
forall a b. (a -> b) -> a -> b
$ KeyDoc -> NoteEntryMap KeyDoc -> NoteEntryMap KeyDoc
forall a. a -> NoteEntryMap a -> NoteEntryMap a
merge_kbd_entry KeyDoc
"" (NoteEntryMap KeyDoc -> NoteEntryMap KeyDoc)
-> NoteEntryMap KeyDoc -> NoteEntryMap KeyDoc
forall a b. (a -> b) -> a -> b
$ Expr -> KeyDoc
to_keycap (Expr -> KeyDoc) -> NoteEntryMap Expr -> NoteEntryMap KeyDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NoteEntryMap Expr
note_entry_map)
        (NamedCmd m -> Handler m)
-> ((Msg -> m Status) -> NamedCmd m)
-> (Msg -> m Status)
-> Handler m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyDoc -> (Msg -> m Status) -> NamedCmd m
forall (m :: * -> *). KeyDoc -> (Msg -> m Status) -> NamedCmd m
Cmd.NamedCmd KeyDoc
"insert_expr"
    keydown :: a -> m ()
keydown a
expr = do
        (Octave, KeyDoc) -> Maybe KeyDoc -> m ()
forall (m :: * -> *).
M m =>
(Octave, KeyDoc) -> Maybe KeyDoc -> m ()
Cmd.set_status (Octave, KeyDoc)
Config.status_note (Maybe KeyDoc -> m ()) -> Maybe KeyDoc -> m ()
forall a b. (a -> b) -> a -> b
$ KeyDoc -> Maybe KeyDoc
forall a. a -> Maybe a
Just (KeyDoc -> Maybe KeyDoc) -> KeyDoc -> Maybe KeyDoc
forall a b. (a -> b) -> a -> b
$ a -> KeyDoc
forall a. ShowVal a => a -> KeyDoc
ShowVal.show_val a
expr
        m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
forall (m :: * -> *). M m => m Bool
Cmd.is_val_edit (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall {a}. m a -> m a
suppressed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Pos
pos <- m Pos
forall (m :: * -> *). M m => m Pos
EditUtil.get_pos
            Pos -> Bool -> Bool -> Modify -> m ()
forall (m :: * -> *). M m => Pos -> Bool -> Bool -> Modify -> m ()
EditUtil.modify_event_at_trigger Pos
pos Bool
False Bool
True (Modify -> m ()) -> Modify -> m ()
forall a b. (a -> b) -> a -> b
$
                (Maybe KeyDoc, Bool) -> Modify
forall a b. a -> b -> a
const (KeyDoc -> Maybe KeyDoc
forall a. a -> Maybe a
Just (a -> KeyDoc
forall a. ShowVal a => a -> KeyDoc
ShowVal.show_val a
expr), Bool
True)
        where
        suppressed :: m a -> m a
suppressed = EditMode -> KeyDoc -> m a -> m a
forall (m :: * -> *) a. M m => EditMode -> KeyDoc -> m a -> m a
Cmd.suppress_history EditMode
Cmd.ValEdit
            (KeyDoc
"keymap: " KeyDoc -> KeyDoc -> KeyDoc
forall a. Semigroup a => a -> a -> a
<> a -> KeyDoc
forall a. ShowVal a => a -> KeyDoc
ShowVal.show_val a
expr)

to_keycap :: DeriveT.Expr -> KeycapsT.KeyDoc
to_keycap :: Expr -> KeyDoc
to_keycap = Expr -> KeyDoc
forall val. ShowVal (Call val) => Expr val -> KeyDoc
Expr.show_val_expr

merge_kbd_entry :: a -> Cmd.NoteEntryMap a -> Cmd.NoteEntryMap a
merge_kbd_entry :: forall a. a -> NoteEntryMap a -> NoteEntryMap a
merge_kbd_entry a
val = \case
    Cmd.WithOctave Map Octave (Map Char a)
m -> Map Octave (Map Char a) -> NoteEntryMap a
forall a. Map Octave (Map Char a) -> NoteEntryMap a
Cmd.WithOctave (Map Octave (Map Char a) -> NoteEntryMap a)
-> Map Octave (Map Char a) -> NoteEntryMap a
forall a b. (a -> b) -> a -> b
$ (Map Char a -> Map Char a -> Map Char a
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Char a
empty) (Map Char a -> Map Char a)
-> Map Octave (Map Char a) -> Map Octave (Map Char a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Octave (Map Char a)
m
    Cmd.WithoutOctave Map Char a
m -> Map Char a -> NoteEntryMap a
forall a. Map Char a -> NoteEntryMap a
Cmd.WithoutOctave (Map Char a -> NoteEntryMap a) -> Map Char a -> NoteEntryMap a
forall a b. (a -> b) -> a -> b
$ Map Char a -> Map Char a -> Map Char a
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Char a
m Map Char a
empty
    where empty :: Map Char a
empty = a -> Pitch -> a
forall a b. a -> b -> a
const a
val (Pitch -> a) -> Map Char Pitch -> Map Char a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Char Pitch
PhysicalKey.pitch_map

expr_im_thru :: Cmd.M m => Thru.ThruFunction -> DeriveT.Expr -> m [Cmd.Thru]
expr_im_thru :: forall (m :: * -> *). M m => ThruFunction -> Expr -> m [Thru]
expr_im_thru ThruFunction
thru_f Expr
expr = do
    [Note]
notes <- Expr -> m [Note]
forall (m :: * -> *). M m => Expr -> m [Note]
eval_thru_notes Expr
expr
    Message
msg <- (KeyDoc -> KeyDoc) -> Either KeyDoc Message -> m Message
forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> KeyDoc) -> Either err a -> m a
Cmd.require_right (KeyDoc
"thru_f: "<>) (Either KeyDoc Message -> m Message)
-> Either KeyDoc Message -> m Message
forall a b. (a -> b) -> a -> b
$ ThruFunction
thru_f [Note]
notes
    [Thru] -> m [Thru]
forall (m :: * -> *) a. Monad m => a -> m a
return [Message -> Thru
Cmd.ImThru Message
msg]

eval_thru_notes :: Cmd.M m => DeriveT.Expr -> m [Thru.Note]
eval_thru_notes :: forall (m :: * -> *). M m => Expr -> m [Note]
eval_thru_notes Expr
expr = do
    (BlockId
block_id, Octave
_, TrackId
track_id, TrackTime
pos) <- m (BlockId, Octave, TrackId, TrackTime)
forall (m :: * -> *).
M m =>
m (BlockId, Octave, TrackId, TrackTime)
Selection.get_insert
    Either KeyDoc [Note]
result <- KeyDoc -> (Either KeyDoc [Note], [Msg]) -> m (Either KeyDoc [Note])
forall (m :: * -> *) a. LogMonad m => KeyDoc -> (a, [Msg]) -> m a
LEvent.write_snd_prefix KeyDoc
"CUtil.expr_attributes"
        ((Either KeyDoc [Note], [Msg]) -> m (Either KeyDoc [Note]))
-> m (Either KeyDoc [Note], [Msg]) -> m (Either KeyDoc [Note])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId
-> TrackId -> TrackTime -> Expr -> m (Either KeyDoc [Note], [Msg])
forall (m :: * -> *) d.
(M m, CallableExpr d) =>
BlockId
-> TrackId -> TrackTime -> Expr -> m (Either KeyDoc [d], [Msg])
Perf.derive_expr BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr
    [Note]
events <- (KeyDoc -> KeyDoc) -> Either KeyDoc [Note] -> m [Note]
forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> KeyDoc) -> Either err a -> m a
Cmd.require_right (KeyDoc
"CUtil.expr_attributes: "<>) Either KeyDoc [Note]
result
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Note] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
events) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ KeyDoc -> m ()
forall (m :: * -> *) a. (Stack, M m) => KeyDoc -> m a
Cmd.throw (KeyDoc -> m ()) -> KeyDoc -> m ()
forall a b. (a -> b) -> a -> b
$ KeyDoc
"expected events when evaluating: "
        KeyDoc -> KeyDoc -> KeyDoc
forall a. Semigroup a => a -> a -> a
<> Expr -> KeyDoc
forall a. ShowVal a => a -> KeyDoc
ShowVal.show_val Expr
expr
    [Note] -> m [Note]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Note] -> m [Note]) -> [Note] -> m [Note]
forall a b. (a -> b) -> a -> b
$ (Note -> Note) -> [Note] -> [Note]
forall a b. (a -> b) -> [a] -> [b]
map Note -> Note
make [Note]
events
    where
    make :: Note -> Note
make Note
event = Thru.Note
        { _pitch :: NoteNumber
_pitch = NoteNumber -> Maybe NoteNumber -> NoteNumber
forall a. a -> Maybe a -> a
fromMaybe NoteNumber
0 (Note -> Maybe NoteNumber
Score.initial_nn Note
event)
        , _velocity :: Y
_velocity = Note -> Y
Score.initial_dynamic Note
event
        , _attributes :: Attributes
_attributes = Note -> Attributes
Score.event_attributes Note
event
        , _startOffset :: Octave
_startOffset = Octave -> (Typed Y -> Octave) -> Maybe (Typed Y) -> Octave
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Octave
0 (Y -> Octave
forall a b. (RealFrac a, Integral b) => a -> b
floor (Y -> Octave) -> (Typed Y -> Y) -> Typed Y -> Octave
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val) (Maybe (Typed Y) -> Octave) -> Maybe (Typed Y) -> Octave
forall a b. (a -> b) -> a -> b
$
            RealTime -> Control -> Note -> Maybe (Typed Y)
Score.control_at (Note -> RealTime
Score.event_start Note
event)
                (Control -> Control
Controls.from_shared Control
Control.sampleStartOffset) Note
event
        }

{- | Emit MIDI thru for an arbitrary expresison.

    This is more accurate and principled than what the usual kbd entry cmds do,
    since it reuses the deriver and performer directly, while they recreate the
    performer in an ad-hoc way, e.g. in "Cmd.MidiThru".  However, this allows
    them to play chords and is thus more suitable for pitched instruments.
    Actually, what MidiThru recreates is the channel allocation part of the
    performer, ultimately becasue the performer's allocator doesn't work in
    real time.  Still, perhaps it would be possible to integrate them better
    than I have.
-}
expr_midi_thru :: Cmd.M m => UiMsg.KbdState -> DeriveT.Expr -> m ()
expr_midi_thru :: forall (m :: * -> *). M m => KbdState -> Expr -> m ()
expr_midi_thru KbdState
kstate Expr
expr = case KbdState
kstate of
    KbdState
UiMsg.KeyRepeat -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    KbdState
UiMsg.KeyDown -> do
        (BlockId
block_id, Octave
_, TrackId
track_id, TrackTime
pos) <- m (BlockId, Octave, TrackId, TrackTime)
forall (m :: * -> *).
M m =>
m (BlockId, Octave, TrackId, TrackTime)
Selection.get_insert
        [WriteMessage]
msgs <- BlockId -> TrackId -> TrackTime -> Expr -> m [WriteMessage]
forall (m :: * -> *).
M m =>
BlockId -> TrackId -> TrackTime -> Expr -> m [WriteMessage]
expr_to_midi BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr
        let note_ons :: [(WriteDevice, Message)]
note_ons =
                [ (WriteMessage -> WriteDevice
Midi.wmsg_dev WriteMessage
wmsg, WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg)
                | WriteMessage
wmsg <- [WriteMessage]
msgs
                , Message -> Bool
Midi.is_note_on (WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg)
                ]
        ((WriteDevice, Message) -> m ())
-> [(WriteDevice, Message)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((WriteDevice -> Message -> m ()) -> (WriteDevice, Message) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry WriteDevice -> Message -> m ()
forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi) [(WriteDevice, Message)]
note_ons
    KbdState
UiMsg.KeyUp -> do
        -- This runs relies on 'expr_to_midi' producing exactly the same thing
        -- as the call above, so the NoteOffs will cancel out the NoteOns.  If
        -- this seems too unreliable, I could keep a Map from exprs to the note
        -- offs.  Keeping state around is also a bit unreliable, but maybe less
        -- so.
        (BlockId
block_id, Octave
_, TrackId
track_id, TrackTime
pos) <- m (BlockId, Octave, TrackId, TrackTime)
forall (m :: * -> *).
M m =>
m (BlockId, Octave, TrackId, TrackTime)
Selection.get_insert
        [WriteMessage]
msgs <- BlockId -> TrackId -> TrackTime -> Expr -> m [WriteMessage]
forall (m :: * -> *).
M m =>
BlockId -> TrackId -> TrackTime -> Expr -> m [WriteMessage]
expr_to_midi BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr
        let note_offs :: [(WriteDevice, Message)]
note_offs =
                [ (WriteDevice
dev, Message
msg)
                | Midi.WriteMessage WriteDevice
dev RealTime
_
                    msg :: Message
msg@(Midi.ChannelMessage Channel
_ (Midi.NoteOff Key
_ Channel
_)) <- [WriteMessage]
msgs
                ]
        ((WriteDevice, Message) -> m ())
-> [(WriteDevice, Message)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((WriteDevice -> Message -> m ()) -> (WriteDevice, Message) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry WriteDevice -> Message -> m ()
forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi) [(WriteDevice, Message)]
note_offs

-- | Call a note call and return the MIDI msgs it produces.
expr_to_midi :: Cmd.M m => BlockId -> TrackId -> TrackTime -> DeriveT.Expr
    -> m [Midi.WriteMessage]
expr_to_midi :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> TrackTime -> Expr -> m [WriteMessage]
expr_to_midi BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr = do
    Either KeyDoc [Note]
result <- KeyDoc -> (Either KeyDoc [Note], [Msg]) -> m (Either KeyDoc [Note])
forall (m :: * -> *) a. LogMonad m => KeyDoc -> (a, [Msg]) -> m a
LEvent.write_snd_prefix KeyDoc
"CUtil.expr_to_midi"
        ((Either KeyDoc [Note], [Msg]) -> m (Either KeyDoc [Note]))
-> m (Either KeyDoc [Note], [Msg]) -> m (Either KeyDoc [Note])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId
-> TrackId -> TrackTime -> Expr -> m (Either KeyDoc [Note], [Msg])
forall (m :: * -> *) d.
(M m, CallableExpr d) =>
BlockId
-> TrackId -> TrackTime -> Expr -> m (Either KeyDoc [d], [Msg])
Perf.derive_expr BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr
    [Note]
events <- (KeyDoc -> KeyDoc) -> Either KeyDoc [Note] -> m [Note]
forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> KeyDoc) -> Either err a -> m a
Cmd.require_right (KeyDoc
"CUtil.expr_to_midi: "<>) Either KeyDoc [Note]
result
    ([WriteMessage], [Msg]) -> m [WriteMessage]
forall (m :: * -> *) a. LogMonad m => (a, [Msg]) -> m a
LEvent.write_snd (([WriteMessage], [Msg]) -> m [WriteMessage])
-> m ([WriteMessage], [Msg]) -> m [WriteMessage]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Note] -> m ([WriteMessage], [Msg])
forall (m :: * -> *). M m => [Note] -> m ([WriteMessage], [Msg])
Perf.perform [Note]
events

-- * keyswitch

{- | Create a Cmd to set keyswitches.

    This simply sets the note text for subsequent notes, and also configures
    the instrument to play in the given keyswitch.

    TODO this just emits keyswitches for every addr and emits them redundantly.
    This is simpler but it would be more correct to use WriteDeviceState to
    emit them only when needed.  However, it's more complicated because then
    I need a current attrs (Map Instrument Attrs) along with current note text,
    so MidiThru can use the attrs to find the keyswitch.

    TODO if I can pull the current or previous note out of the derive then
    I could use that to play an example note.  Wait until I have a "play
    current line" framework up for that.
-}
keyswitches :: Cmd.M m => [(Char, Expr.Symbol, Midi.Key)] -> Cmd.Handler m
keyswitches :: forall (m :: * -> *). M m => [(Char, Symbol, Key)] -> Handler m
keyswitches [(Char, Symbol, Key)]
inputs = (Msg -> m Status) -> Handler m
forall {m :: * -> *}. (Msg -> m Status) -> Handler m
handler ((Msg -> m Status) -> Handler m) -> (Msg -> m Status) -> Handler m
forall a b. (a -> b) -> a -> b
$ \Msg
msg -> do
    Fallthrough -> Msg -> m ()
forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.NoBackspace Msg
msg
    Char
char <- Maybe Char -> m Char
forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless (Maybe Char -> m Char) -> Maybe Char -> m Char
forall a b. (a -> b) -> a -> b
$ Msg -> Maybe Char
Msg.char_down Msg
msg
    (Symbol
call, Key
key) <- Maybe (Symbol, Key) -> m (Symbol, Key)
forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless (Maybe (Symbol, Key) -> m (Symbol, Key))
-> Maybe (Symbol, Key) -> m (Symbol, Key)
forall a b. (a -> b) -> a -> b
$ Char -> Map Char (Symbol, Key) -> Maybe (Symbol, Key)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
char Map Char (Symbol, Key)
to_call
    Maybe Instrument -> Bool -> [ChannelMessage] -> m ()
forall (m :: * -> *).
M m =>
Maybe Instrument -> Bool -> [ChannelMessage] -> m ()
MidiThru.channel_messages Maybe Instrument
forall a. Maybe a
Nothing Bool
False
        [Key -> Channel -> ChannelMessage
Midi.NoteOn Key
key Channel
64, Key -> Channel -> ChannelMessage
Midi.NoteOff Key
key Channel
64]
    KeyDoc -> m ()
forall (m :: * -> *). M m => KeyDoc -> m ()
Cmd.set_note_text (Symbol -> KeyDoc
Expr.unsym Symbol
call)
    Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
    where
    handler :: (Msg -> m Status) -> Handler m
handler = Maybe (NoteEntryMap KeyDoc) -> NamedCmd m -> Handler m
forall (m :: * -> *).
Maybe (NoteEntryMap KeyDoc) -> NamedCmd m -> Handler m
Cmd.Handler (NoteEntryMap KeyDoc -> Maybe (NoteEntryMap KeyDoc)
forall a. a -> Maybe a
Just NoteEntryMap KeyDoc
note_entry_map) (NamedCmd m -> Handler m)
-> ((Msg -> m Status) -> NamedCmd m)
-> (Msg -> m Status)
-> Handler m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyDoc -> (Msg -> m Status) -> NamedCmd m
forall (m :: * -> *). KeyDoc -> (Msg -> m Status) -> NamedCmd m
Cmd.NamedCmd KeyDoc
"keyswitches"
    note_entry_map :: NoteEntryMap KeyDoc
note_entry_map = Map Char KeyDoc -> NoteEntryMap KeyDoc
forall a. Map Char a -> NoteEntryMap a
Cmd.WithoutOctave (Map Char KeyDoc -> NoteEntryMap KeyDoc)
-> Map Char KeyDoc -> NoteEntryMap KeyDoc
forall a b. (a -> b) -> a -> b
$ Symbol -> KeyDoc
Expr.unsym (Symbol -> KeyDoc)
-> ((Symbol, Key) -> Symbol) -> (Symbol, Key) -> KeyDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol, Key) -> Symbol
forall a b. (a, b) -> a
fst ((Symbol, Key) -> KeyDoc)
-> Map Char (Symbol, Key) -> Map Char KeyDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Char (Symbol, Key)
to_call
    to_call :: Map Char (Symbol, Key)
to_call = [(Char, (Symbol, Key))] -> Map Char (Symbol, Key)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char
char, (Symbol
call, Key
key)) | (Char
char, Symbol
call, Key
key) <- [(Char, Symbol, Key)]
inputs]


-- * drums

-- | Create an unpitched drum instrument.  This is an instrument with an
-- enumeration of symbols and no pitch or duration.  Each key maps to its
-- own symbol.
simple_drum :: Thru -> Maybe ScoreT.Control -> [(Drums.Stroke, Midi.Key)]
    -> MidiInst.Patch -> MidiInst.Patch
simple_drum :: Thru -> Maybe Control -> [(Stroke, Key)] -> Patch -> Patch
simple_drum Thru
thru Maybe Control
tuning_control [(Stroke, Key)]
stroke_keys Patch
patch =
    Lens Patch Code
MidiInst.code Lens Patch Code -> Code -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= Code
code (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ [(Stroke, Key)] -> Patch -> Patch
drum_patch [(Stroke, Key)]
stroke_keys Patch
patch
    where
    code :: Code
code = Thru -> [(Stroke, CallConfig)] -> Code
drum_code Thru
thru (((Stroke, Key) -> (Stroke, CallConfig))
-> [(Stroke, Key)] -> [(Stroke, CallConfig)]
forall a b. (a -> b) -> [a] -> [b]
map ((,CallConfig
config) (Stroke -> (Stroke, CallConfig))
-> ((Stroke, Key) -> Stroke)
-> (Stroke, Key)
-> (Stroke, CallConfig)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stroke, Key) -> Stroke
forall a b. (a, b) -> a
fst) [(Stroke, Key)]
stroke_keys)
    config :: CallConfig
config = CallConfig
call_config { _tuning_control :: Maybe Control
_tuning_control = Maybe Control
tuning_control }

-- ** code

-- | Construct code from drum strokes.  This is both the deriver calls to
-- interpret the stroke names, and the cmds to enter them.
drum_code :: Thru -> [(Drums.Stroke, CallConfig)] -> MidiInst.Code
drum_code :: Thru -> [(Stroke, CallConfig)] -> Code
drum_code = [(Char, Symbol)] -> Thru -> [(Stroke, CallConfig)] -> Code
drum_code_cmd []

-- | 'drum_code', but with the opportunity to insert extra keys for
-- 'insert_call'.  This is because 'insert_expr' can't be stacked, since it
-- consumes kbd entry keys it doesn't map, since it's confusing if it doesn't.
drum_code_cmd :: [(Char, Expr.Symbol)] -> Thru -> [(Drums.Stroke, CallConfig)]
    -> MidiInst.Code
drum_code_cmd :: [(Char, Symbol)] -> Thru -> [(Stroke, CallConfig)] -> Code
drum_code_cmd [(Char, Symbol)]
extra_cmds Thru
thru [(Stroke, CallConfig)]
stroke_configs =
    [(Symbol, Generator Note)] -> Code
MidiInst.note_generators ([(Stroke, CallConfig)] -> [(Symbol, Generator Note)]
drum_calls [(Stroke, CallConfig)]
stroke_configs)
    Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<> HandlerId -> Code
MidiInst.cmd ([(Char, Symbol)] -> Thru -> [Stroke] -> HandlerId
forall (m :: * -> *).
M m =>
[(Char, Symbol)] -> Thru -> [Stroke] -> Handler m
drum_cmd [(Char, Symbol)]
extra_cmds Thru
thru (((Stroke, CallConfig) -> Stroke)
-> [(Stroke, CallConfig)] -> [Stroke]
forall a b. (a -> b) -> [a] -> [b]
map (Stroke, CallConfig) -> Stroke
forall a b. (a, b) -> a
fst [(Stroke, CallConfig)]
stroke_configs))

drum_code_ :: Thru -> [Drums.Stroke] -> MidiInst.Code
drum_code_ :: Thru -> [Stroke] -> Code
drum_code_ Thru
thru = Thru -> [(Stroke, CallConfig)] -> Code
drum_code Thru
thru ([(Stroke, CallConfig)] -> Code)
-> ([Stroke] -> [(Stroke, CallConfig)]) -> [Stroke] -> Code
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stroke -> (Stroke, CallConfig))
-> [Stroke] -> [(Stroke, CallConfig)]
forall a b. (a -> b) -> [a] -> [b]
map (,CallConfig
call_config)

drum_cmd :: Cmd.M m => [(Char, Expr.Symbol)] -> Thru -> [Drums.Stroke]
    -> Cmd.Handler m
drum_cmd :: forall (m :: * -> *).
M m =>
[(Char, Symbol)] -> Thru -> [Stroke] -> Handler m
drum_cmd [(Char, Symbol)]
extras Thru
thru = Thru -> [(Char, Symbol)] -> Handler m
forall (m :: * -> *). M m => Thru -> [(Char, Symbol)] -> Handler m
insert_call Thru
thru ([(Char, Symbol)] -> Handler m)
-> ([Stroke] -> [(Char, Symbol)]) -> [Stroke] -> Handler m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Char, Symbol)]
extras++) ([(Char, Symbol)] -> [(Char, Symbol)])
-> ([Stroke] -> [(Char, Symbol)]) -> [Stroke] -> [(Char, Symbol)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stroke] -> [(Char, Symbol)]
strokes_to_calls

-- ** patch

-- | Create a MIDI patch for the traditional kind of drum instrument where
-- each different stroke is mapped to a single MIDI keys.  'pitched_drum_patch'
-- is the variant where each stroke has a range of keys.
drum_patch :: [(Drums.Stroke, Midi.Key)] -> MidiInst.Patch -> MidiInst.Patch
drum_patch :: [(Stroke, Key)] -> Patch -> Patch
drum_patch [(Stroke, Key)]
stroke_keys =
    Patch -> Patch
MidiInst.triggered
    (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Common Code
MidiInst.common(Patch :-> Common Code)
-> Lens (Common Code) CallMap -> Lens Patch CallMap
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens (Common Code) CallMap
forall {code}. Common code :-> CallMap
Common.call_map Lens Patch CallMap -> CallMap -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= [Stroke] -> CallMap
make_call_map (((Stroke, Key) -> Stroke) -> [(Stroke, Key)] -> [Stroke]
forall a b. (a -> b) -> [a] -> [b]
map (Stroke, Key) -> Stroke
forall a b. (a, b) -> a
fst [(Stroke, Key)]
stroke_keys))
    (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Patch
MidiInst.patch(Patch :-> Patch)
-> Lens Patch AttributeMap -> Lens Patch AttributeMap
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Patch AttributeMap
Patch.attribute_map Lens Patch AttributeMap -> AttributeMap -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= AttributeMap
keymap)
    where
    keymap :: AttributeMap
keymap = [(Attributes, Key)] -> AttributeMap
Patch.unpitched_keymap
        [(Stroke -> Attributes
Drums._attributes Stroke
stroke, Key
key) | (Stroke
stroke, Key
key) <- [(Stroke, Key)]
stroke_keys]

-- | im is much simpler than MIDI and doesn't need all the keymap garbage.
-- However, like 'drum_patch', this just sets patch config, the cmd and deriver
-- code has to be added separately, see 'drum_code' or 'drum_calls' for that.
im_drum_patch :: [Drums.Stroke] -> ImInst.Patch -> ImInst.Patch
im_drum_patch :: [Stroke] -> Patch -> Patch
im_drum_patch [Stroke]
strokes =
    Patch -> Patch
ImInst.triggered (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Common Code
ImInst.common(Patch :-> Common Code)
-> Lens (Common Code) CallMap -> Lens Patch CallMap
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens (Common Code) CallMap
forall {code}. Common code :-> CallMap
Common.call_map Lens Patch CallMap -> CallMap -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= [Stroke] -> CallMap
make_call_map [Stroke]
strokes)

-- | Used with 'pitched_attribute_map' for MIDI instruments that do the
-- strategy of assigning pitch ranges to each drum stroke.
type PitchedStrokes = [(Drums.Stroke, KeyswitchRange)]

-- | (keyswitch, low, high, root_pitch).  The root pitch is the pitch at the
-- bottom of the key range, and winds up in 'Patch.PitchedKeymap'.
type KeyswitchRange = ([Patch.Keyswitch], Midi.Key, Midi.Key, Midi.Key)

-- | Make a KeyswitchRange for each grouped Attributes set.  Attributes in the
-- same group get the same range and are differentiated by keyswitch.
make_keymap :: Maybe Midi.Key -- ^ Keyswitches start here.  If not given,
    -- this patch doesn't use keyswitches.
    -> Midi.Key -- ^ notes start here
    -> Midi.Key -- ^ each sound is mapped over this range
    -> Midi.Key -- ^ the pitch of the bottom note of each range
    -> [[Attrs.Attributes]] -> Map Attrs.Attributes KeyswitchRange
make_keymap :: Maybe Key
-> Key
-> Key
-> Key
-> [[Attributes]]
-> Map Attributes KeyswitchRange
make_keymap Maybe Key
base_keyswitch Key
base_key Key
range Key
root_pitch [[Attributes]]
groups = [(Attributes, KeyswitchRange)] -> Map Attributes KeyswitchRange
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Attributes, KeyswitchRange)] -> Map Attributes KeyswitchRange)
-> [(Attributes, KeyswitchRange)] -> Map Attributes KeyswitchRange
forall a b. (a -> b) -> a -> b
$ do
    ([Attributes]
group, Key
low) <- [[Attributes]] -> [Key] -> [([Attributes], Key)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Attributes]]
groups [Key
base_key, Key
base_keyKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
range ..]
    (Attributes
attrs, [Keyswitch]
ks) <- [Attributes] -> [[Keyswitch]] -> [(Attributes, [Keyswitch])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Attributes]
group ([[Keyswitch]] -> [(Attributes, [Keyswitch])])
-> [[Keyswitch]] -> [(Attributes, [Keyswitch])]
forall a b. (a -> b) -> a -> b
$ [[Keyswitch]]
-> (Key -> [[Keyswitch]]) -> Maybe Key -> [[Keyswitch]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Keyswitch] -> [[Keyswitch]]
forall a. a -> [a]
repeat [])
        (\Key
base -> (Key -> [Keyswitch]) -> [Key] -> [[Keyswitch]]
forall a b. (a -> b) -> [a] -> [b]
map ((Keyswitch -> [Keyswitch] -> [Keyswitch]
forall a. a -> [a] -> [a]
:[]) (Keyswitch -> [Keyswitch])
-> (Key -> Keyswitch) -> Key -> [Keyswitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Keyswitch
Patch.Keyswitch) [Key
base..]) Maybe Key
base_keyswitch
    (Attributes, KeyswitchRange) -> [(Attributes, KeyswitchRange)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Attributes
attrs, ([Keyswitch]
ks, Key
low, Key
low Key -> Key -> Key
forall a. Num a => a -> a -> a
+ (Key
rangeKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1), Key
root_pitch))

-- | This is like 'make_keymap', except with the arguments rearranged to more
-- closely match the sample utils I use.
make_keymap2 :: Maybe Midi.Key -> Midi.Key -> Midi.Key -> Midi.Key
    -> Midi.Key -> [[Attrs.Attributes]]
    -> Map Attrs.Attributes KeyswitchRange
make_keymap2 :: Maybe Key
-> Key
-> Key
-> Key
-> Key
-> [[Attributes]]
-> Map Attributes KeyswitchRange
make_keymap2 Maybe Key
base_keyswitch Key
base_key Key
natural_key Key
range Key
natural_nn =
    Maybe Key
-> Key
-> Key
-> Key
-> [[Attributes]]
-> Map Attributes KeyswitchRange
make_keymap Maybe Key
base_keyswitch Key
base_key Key
range
        (Key
natural_nn Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key -> Key
forall a. Num a => Key -> a
Midi.from_key Key
natural_key)

-- | This is like 'make_keymap', except that attributes are differentiated by
-- a 'Patch.ControlSwitch'.  CCs start at 102, and only groups of size >1
-- get a CC.  Since each group is controlled by its own CC number, you can then
-- select each variation independently.  This means any set of variations can
-- be played simultaneously, which is not true for keyswitches.
make_cc_keymap :: Midi.Key -- ^ notes start here
    -> Midi.Key -- ^ each sound is mapped over this range
    -> Midi.Key -- ^ the pitch of the bottom note of each range
    -> [[Attrs.Attributes]] -> Map Attrs.Attributes KeyswitchRange
make_cc_keymap :: Key
-> Key -> Key -> [[Attributes]] -> Map Attributes KeyswitchRange
make_cc_keymap Key
base_key Key
range Key
root_pitch =
    [(Attributes, KeyswitchRange)] -> Map Attributes KeyswitchRange
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Attributes, KeyswitchRange)] -> Map Attributes KeyswitchRange)
-> ([[Attributes]] -> [(Attributes, KeyswitchRange)])
-> [[Attributes]]
-> Map Attributes KeyswitchRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> [(Key, [Attributes])] -> [(Attributes, KeyswitchRange)]
forall {a}. Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go Channel
base_cc ([(Key, [Attributes])] -> [(Attributes, KeyswitchRange)])
-> ([[Attributes]] -> [(Key, [Attributes])])
-> [[Attributes]]
-> [(Attributes, KeyswitchRange)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> [[Attributes]] -> [(Key, [Attributes])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
base_key, Key
base_key Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
range ..]
    where
    go :: Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go Channel
_ [] = []
    go Channel
cc ((Key
low, [a]
group) : [(Key, [a])]
groups) = case [a]
group of
        [] -> Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go Channel
cc [(Key, [a])]
groups
        [a
attrs] -> (a
attrs, ([], Key
low, Key
low Key -> Key -> Key
forall a. Num a => a -> a -> a
+ (Key
rangeKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1), Key
root_pitch))
            (a, KeyswitchRange)
-> [(a, KeyswitchRange)] -> [(a, KeyswitchRange)]
forall a. a -> [a] -> [a]
: Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go Channel
cc [(Key, [a])]
groups
        [a]
_ ->
            [ (a
attrs, ([Channel -> Channel -> Keyswitch
Patch.ControlSwitch Channel
cc Channel
cc_val],
                Key
low, Key
low Key -> Key -> Key
forall a. Num a => a -> a -> a
+ (Key
rangeKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1), Key
root_pitch))
            | (a
attrs, Channel
cc_val) <- [a] -> [Channel] -> [(a, Channel)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
group [Channel
0 ..]
            ] [(a, KeyswitchRange)]
-> [(a, KeyswitchRange)] -> [(a, KeyswitchRange)]
forall a. [a] -> [a] -> [a]
++ Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go (Channel
ccChannel -> Channel -> Channel
forall a. Num a => a -> a -> a
+Channel
1) [(Key, [a])]
groups
    -- There is an unallocated block [102 .. 119], which should be enough.
    base_cc :: Channel
base_cc = Channel
102

-- | Annotate a Patch with an 'Patch.AttributeMap' from the given
-- PitchedStrokes.
pitched_drum_patch :: PitchedStrokes -> MidiInst.Patch -> MidiInst.Patch
pitched_drum_patch :: PitchedStrokes -> Patch -> Patch
pitched_drum_patch PitchedStrokes
strokes =
    Patch -> Patch
MidiInst.triggered
    (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Common Code
MidiInst.common(Patch :-> Common Code)
-> Lens (Common Code) CallMap -> Lens Patch CallMap
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens (Common Code) CallMap
forall {code}. Common code :-> CallMap
Common.call_map Lens Patch CallMap -> CallMap -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= [Stroke] -> CallMap
make_call_map (((Stroke, KeyswitchRange) -> Stroke) -> PitchedStrokes -> [Stroke]
forall a b. (a -> b) -> [a] -> [b]
map (Stroke, KeyswitchRange) -> Stroke
forall a b. (a, b) -> a
fst PitchedStrokes
strokes))
    (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Patch
MidiInst.patch(Patch :-> Patch)
-> Lens Patch AttributeMap -> Lens Patch AttributeMap
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Patch AttributeMap
Patch.attribute_map Lens Patch AttributeMap -> AttributeMap -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= PitchedStrokes -> AttributeMap
pitched_attribute_map PitchedStrokes
strokes)

make_call_map :: [Drums.Stroke] -> Common.CallMap
make_call_map :: [Stroke] -> CallMap
make_call_map = [(Attributes, Symbol)] -> CallMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Attributes, Symbol)] -> CallMap)
-> ([Stroke] -> [(Attributes, Symbol)]) -> [Stroke] -> CallMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stroke -> (Attributes, Symbol))
-> [Stroke] -> [(Attributes, Symbol)]
forall a b. (a -> b) -> [a] -> [b]
map (\Stroke
n -> (Stroke -> Attributes
Drums._attributes Stroke
n, Stroke -> Symbol
Drums._name Stroke
n))

pitched_attribute_map :: PitchedStrokes -> Patch.AttributeMap
pitched_attribute_map :: PitchedStrokes -> AttributeMap
pitched_attribute_map PitchedStrokes
strokes = [(Attributes, ([Keyswitch], Maybe Keymap))] -> AttributeMap
forall a. [(Attributes, a)] -> AttributeMap a
Common.attribute_map ([(Attributes, ([Keyswitch], Maybe Keymap))] -> AttributeMap)
-> [(Attributes, ([Keyswitch], Maybe Keymap))] -> AttributeMap
forall a b. (a -> b) -> a -> b
$ [(Attributes, ([Keyswitch], Maybe Keymap))]
-> [(Attributes, ([Keyswitch], Maybe Keymap))]
forall a. Ord a => [a] -> [a]
Seq.unique
    -- It's ok to have Notes with the same (attr, keyswitch), for instance if
    -- there are loud and soft versions, but pitched_attribute_map will see them
    -- as overlapping attrs, so filter out duplicates.
    [ (Stroke -> Attributes
Drums._attributes Stroke
stroke, ([Keyswitch]
ks, Keymap -> Maybe Keymap
forall a. a -> Maybe a
Just (Key -> Key -> Key -> Keymap
Patch.PitchedKeymap Key
low Key
high Key
root)))
    | (Stroke
stroke, ([Keyswitch]
ks, Key
low, Key
high, Key
root)) <- PitchedStrokes
strokes
    ]

-- | Make PitchedStrokes by pairing each 'Drums.Stroke' with its
-- 'KeyswitchRange'.
drum_pitched_strokes :: [Drums.Stroke] -> Map Attrs.Attributes KeyswitchRange
    -> (PitchedStrokes, ([Drums.Stroke], [Attrs.Attributes]))
    -- ^ Also return the strokes with no mapping (so they can't be played), and
    -- keymap ranges with no corresponding strokes (so there is no call to
    -- play them).
drum_pitched_strokes :: [Stroke]
-> Map Attributes KeyswitchRange
-> (PitchedStrokes, ([Stroke], [Attributes]))
drum_pitched_strokes [Stroke]
strokes Map Attributes KeyswitchRange
keymap = (PitchedStrokes
found, ([Stroke]
not_found, [Attributes]
unused))
    where
    unused :: [Attributes]
unused = (Attributes -> Bool) -> [Attributes] -> [Attributes]
forall a. (a -> Bool) -> [a] -> [a]
filter (Attributes -> [Attributes] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Attributes]
stroke_attrs) (Map Attributes KeyswitchRange -> [Attributes]
forall k a. Map k a -> [k]
Map.keys Map Attributes KeyswitchRange
keymap)
    stroke_attrs :: [Attributes]
stroke_attrs = (Stroke -> Attributes) -> [Stroke] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map Stroke -> Attributes
Drums._attributes [Stroke]
strokes
    ([Stroke]
not_found, PitchedStrokes
found) = [Either Stroke (Stroke, KeyswitchRange)]
-> ([Stroke], PitchedStrokes)
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers ([Either Stroke (Stroke, KeyswitchRange)]
 -> ([Stroke], PitchedStrokes))
-> [Either Stroke (Stroke, KeyswitchRange)]
-> ([Stroke], PitchedStrokes)
forall a b. (a -> b) -> a -> b
$ (Stroke -> Either Stroke (Stroke, KeyswitchRange))
-> [Stroke] -> [Either Stroke (Stroke, KeyswitchRange)]
forall a b. (a -> b) -> [a] -> [b]
map Stroke -> Either Stroke (Stroke, KeyswitchRange)
find [Stroke]
strokes
    find :: Stroke -> Either Stroke (Stroke, KeyswitchRange)
find Stroke
n = Either Stroke (Stroke, KeyswitchRange)
-> (KeyswitchRange -> Either Stroke (Stroke, KeyswitchRange))
-> Maybe KeyswitchRange
-> Either Stroke (Stroke, KeyswitchRange)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Stroke -> Either Stroke (Stroke, KeyswitchRange)
forall a b. a -> Either a b
Left Stroke
n) ((Stroke, KeyswitchRange) -> Either Stroke (Stroke, KeyswitchRange)
forall a b. b -> Either a b
Right ((Stroke, KeyswitchRange)
 -> Either Stroke (Stroke, KeyswitchRange))
-> (KeyswitchRange -> (Stroke, KeyswitchRange))
-> KeyswitchRange
-> Either Stroke (Stroke, KeyswitchRange)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Stroke
n)
        (Attributes -> Map Attributes KeyswitchRange -> Maybe KeyswitchRange
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Stroke -> Attributes
Drums._attributes Stroke
n) Map Attributes KeyswitchRange
keymap)

-- | Create a 'drum_call' for each Drums.Stroke.
--
-- This should probably go in DUtil, but that would make it depend on
-- "Cmd.Instrument.Drums".
drum_calls :: [(Drums.Stroke, CallConfig)]
    -> [(Expr.Symbol, Derive.Generator Derive.Note)]
drum_calls :: [(Stroke, CallConfig)] -> [(Symbol, Generator Note)]
drum_calls = ((Stroke, CallConfig) -> (Symbol, Generator Note))
-> [(Stroke, CallConfig)] -> [(Symbol, Generator Note)]
forall a b. (a -> b) -> [a] -> [b]
map (((Stroke, CallConfig) -> (Symbol, Generator Note))
 -> [(Stroke, CallConfig)] -> [(Symbol, Generator Note)])
-> ((Stroke, CallConfig) -> (Symbol, Generator Note))
-> [(Stroke, CallConfig)]
-> [(Symbol, Generator Note)]
forall a b. (a -> b) -> a -> b
$ \(Stroke
stroke, CallConfig
config) ->
    ( Stroke -> Symbol
Drums._name Stroke
stroke
    , CallConfig -> Symbol -> Attributes -> Generator Note
drum_call
        (CallConfig
config { _stroke_dyn :: Y
_stroke_dyn = Stroke -> Y
Drums._dynamic Stroke
stroke Y -> Y -> Y
forall a. Num a => a -> a -> a
* CallConfig -> Y
_stroke_dyn CallConfig
config })
        (Stroke -> Symbol
Drums._name Stroke
stroke) (Stroke -> Attributes
Drums._attributes Stroke
stroke)
    )

-- | For 'drum_calls'.  If Just, only strokes which are a superset of one of
-- these move with the pitch, otherwise the stay at the given NoteNumber.  If
-- Nothing, all strokes move with the pitch.
pitched_strokes :: [Attrs.Attributes] -> Pitch.NoteNumber
    -> Attrs.Attributes -> CallConfig
pitched_strokes :: [Attributes] -> NoteNumber -> Attributes -> CallConfig
pitched_strokes [Attributes]
pitched NoteNumber
natural_nn Attributes
attrs
    | (Attributes -> Bool) -> [Attributes] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs) [Attributes]
pitched = CallConfig
call_config
    | Bool
otherwise = CallConfig
call_config
        { _transform :: NoteDeriver -> NoteDeriver
_transform = Pitch -> NoteDeriver -> NoteDeriver
forall a. Pitch -> Deriver a -> Deriver a
Derive.with_constant_pitch (NoteNumber -> Pitch
PSignal.nn_pitch NoteNumber
natural_nn)
        }

data CallConfig = CallConfig {
    -- | If set, look at this control for relative pitch adjustment.  For
    -- unpitched drums which nonetheless can use some tweaking.
    CallConfig -> Maybe Control
_tuning_control :: Maybe ScoreT.Control
    -- | If set, take pitch from a $name-pitch arg, otherwise use the given
    -- pitch.
    , CallConfig -> Maybe NoteNumber
_natural_nn :: Maybe Pitch.NoteNumber
    -- | Multiply dyn signal by this.
    , CallConfig -> Y
_stroke_dyn :: Signal.Y
    , CallConfig -> NoteDeriver -> NoteDeriver
_transform :: Derive.NoteDeriver -> Derive.NoteDeriver
    }

call_config :: CallConfig
call_config :: CallConfig
call_config = CallConfig
    { _tuning_control :: Maybe Control
_tuning_control = Maybe Control
forall a. Maybe a
Nothing
    , _natural_nn :: Maybe NoteNumber
_natural_nn = Maybe NoteNumber
forall a. Maybe a
Nothing
    , _stroke_dyn :: Y
_stroke_dyn = Y
1
    , _transform :: NoteDeriver -> NoteDeriver
_transform = NoteDeriver -> NoteDeriver
forall a. a -> a
id
    }

-- | This is the common deriver call that all drums and drum-like instruments
-- use at the bottom.
drum_call :: CallConfig -> Expr.Symbol -> Attrs.Attributes
    -> Derive.Generator Derive.Note
drum_call :: CallConfig -> Symbol -> Attributes -> Generator Note
drum_call (CallConfig Maybe Control
tuning_control Maybe NoteNumber
mb_natural_nn Y
stroke_dyn NoteDeriver -> NoteDeriver
transform)
        (Expr.Symbol KeyDoc
name) Attributes
attrs =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument (KeyDoc -> CallName
Derive.CallName KeyDoc
name) Tags
Tags.attr Doc
doc (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$
    Parser (Y, Maybe Pitch)
-> ((Y, Maybe Pitch) -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
        (Y -> Maybe Pitch -> (Y, Maybe Pitch))
-> Parser Y -> Parser (Maybe Pitch -> (Y, Maybe Pitch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"dyn" Y
1 Doc
"Dyn multiplier."
        Parser (Maybe Pitch -> (Y, Maybe Pitch))
-> Parser (Maybe Pitch) -> Parser (Y, Maybe Pitch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (if Maybe NoteNumber -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing Maybe NoteNumber
mb_natural_nn then Maybe Pitch -> Parser (Maybe Pitch)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Pitch
forall a. Maybe a
Nothing
            else ArgName
-> EnvironDefault -> Maybe Pitch -> Doc -> Parser (Maybe Pitch)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"pitch" EnvironDefault
Derive.Prefixed Maybe Pitch
forall a. Maybe a
Nothing Doc
"doc")
    ) (((Y, Maybe Pitch) -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> ((Y, Maybe Pitch) -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \(Y
dyn, Maybe Pitch
mb_pitch) -> GeneratorF Note -> GeneratorF Note
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting (GeneratorF Note -> GeneratorF Note)
-> GeneratorF Note -> GeneratorF Note
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args ->
        Y -> NoteDeriver -> NoteDeriver
forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic (Y
stroke_dyn Y -> Y -> Y
forall a. Num a => a -> a -> a
* Y
dyn) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Attributes -> NoteDeriver -> NoteDeriver
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
            PassedArgs Note -> NoteDeriver -> NoteDeriver
forall {a}. PassedArgs Note -> Deriver a -> Deriver a
with_tuning PassedArgs Note
args (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ NoteDeriver -> NoteDeriver
transform (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Maybe Pitch -> NoteDeriver -> NoteDeriver
forall {a}. Maybe Pitch -> Deriver a -> Deriver a
set_pitch Maybe Pitch
mb_pitch (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
            Config -> GeneratorF Note
Note.default_note Config
Note.no_duration_attributes PassedArgs Note
args
    where
    with_tuning :: PassedArgs Note -> Deriver a -> Deriver a
with_tuning PassedArgs Note
args = (Deriver a -> Deriver a)
-> (Control -> Deriver a -> Deriver a)
-> Maybe Control
-> Deriver a
-> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Deriver a -> Deriver a
forall a. a -> a
id (PassedArgs Note -> Control -> Deriver a -> Deriver a
forall a. PassedArgs Note -> Control -> Deriver a -> Deriver a
apply_tuning_control PassedArgs Note
args) Maybe Control
tuning_control
    set_pitch :: Maybe Pitch -> Deriver a -> Deriver a
set_pitch Maybe Pitch
mb_pitch = case Maybe NoteNumber
mb_natural_nn of
        Maybe NoteNumber
Nothing -> Deriver a -> Deriver a
forall a. a -> a
id
        Just NoteNumber
natural_nn -> Pitch -> Deriver a -> Deriver a
forall a. Pitch -> Deriver a -> Deriver a
Derive.with_constant_pitch
            (Pitch -> Maybe Pitch -> Pitch
forall a. a -> Maybe a -> a
fromMaybe (NoteNumber -> Pitch
PSignal.nn_pitch NoteNumber
natural_nn) Maybe Pitch
mb_pitch)
    doc :: Doc
doc = case Maybe Control
tuning_control of
        Maybe Control
Nothing -> Doc
""
        Just Control
control -> Doc
"This instrument is unpitched, but its tuning can be\
            \ adjusted with " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Control -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc Control
control Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
", in semitones\
            \ from the natural pitch."

apply_tuning_control :: Derive.NoteArgs -> ScoreT.Control -> Derive.Deriver a
    -> Derive.Deriver a
apply_tuning_control :: forall a. PassedArgs Note -> Control -> Deriver a -> Deriver a
apply_tuning_control PassedArgs Note
args Control
control Deriver a
deriver = do
    Y
tuning <- Y -> Maybe Y -> Y
forall a. a -> Maybe a -> a
fromMaybe Y
0 (Maybe Y -> Y)
-> Deriver State Error (Maybe Y) -> Deriver State Error Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Control -> RealTime -> Deriver State Error (Maybe Y)
Derive.untyped_control_at Control
control (RealTime -> Deriver State Error (Maybe Y))
-> Deriver State Error RealTime -> Deriver State Error (Maybe Y)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PassedArgs Note -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_start PassedArgs Note
args)
    let nn :: NoteNumber
nn = NoteNumber
NN.middle_c NoteNumber -> NoteNumber -> NoteNumber
forall a. Num a => a -> a -> a
+ Y -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn Y
tuning
    Pitch -> Deriver a -> Deriver a
forall a. Pitch -> Deriver a -> Deriver a
Derive.with_constant_pitch (NoteNumber -> Pitch
PSignal.nn_pitch NoteNumber
nn) Deriver a
deriver

-- * util

-- | Given a map describing how Attributes are mapped to the MIDI key range,
-- take a key binding to a 'PitchedStrokes'.  The reason these are separate is
-- that the map describes how a particular patch maps attributes, while the
-- key binding describes the capabilities of the instrument itself.
--
-- If a mapping has 'Attrs.soft', it's looked up without the soft, but gets
-- the given dynamic.
resolve_strokes :: Signal.Y -> Map Attrs.Attributes KeyswitchRange
    -> [(Char, Expr.Symbol, Attrs.Attributes, Drums.Group)]
    -- ^ (key_binding, emits_text, call_attributes, stop_group)
    -> (PitchedStrokes, [Text]) -- ^ also return errors
resolve_strokes :: Y
-> Map Attributes KeyswitchRange
-> [(Char, Symbol, Attributes, KeyDoc)]
-> (PitchedStrokes, [KeyDoc])
resolve_strokes Y
soft_dyn Map Attributes KeyswitchRange
keymap =
    ([KeyDoc], PitchedStrokes) -> (PitchedStrokes, [KeyDoc])
forall {b}. ([KeyDoc], [(Stroke, b)]) -> ([(Stroke, b)], [KeyDoc])
check_dups (([KeyDoc], PitchedStrokes) -> (PitchedStrokes, [KeyDoc]))
-> ([(Char, Symbol, Attributes, KeyDoc)]
    -> ([KeyDoc], PitchedStrokes))
-> [(Char, Symbol, Attributes, KeyDoc)]
-> (PitchedStrokes, [KeyDoc])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either KeyDoc (Stroke, KeyswitchRange)]
-> ([KeyDoc], PitchedStrokes)
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers ([Either KeyDoc (Stroke, KeyswitchRange)]
 -> ([KeyDoc], PitchedStrokes))
-> ([(Char, Symbol, Attributes, KeyDoc)]
    -> [Either KeyDoc (Stroke, KeyswitchRange)])
-> [(Char, Symbol, Attributes, KeyDoc)]
-> ([KeyDoc], PitchedStrokes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, Symbol, Attributes, KeyDoc)
 -> Either KeyDoc (Stroke, KeyswitchRange))
-> [(Char, Symbol, Attributes, KeyDoc)]
-> [Either KeyDoc (Stroke, KeyswitchRange)]
forall a b. (a -> b) -> [a] -> [b]
map (Char, Symbol, Attributes, KeyDoc)
-> Either KeyDoc (Stroke, KeyswitchRange)
resolve
    where
    resolve :: (Char, Symbol, Attributes, KeyDoc)
-> Either KeyDoc (Stroke, KeyswitchRange)
resolve (Char
char, Symbol
call, Attributes
attrs, KeyDoc
group) =
        Either KeyDoc (Stroke, KeyswitchRange)
-> (KeyswitchRange -> Either KeyDoc (Stroke, KeyswitchRange))
-> Maybe KeyswitchRange
-> Either KeyDoc (Stroke, KeyswitchRange)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (KeyDoc -> Either KeyDoc (Stroke, KeyswitchRange)
forall a b. a -> Either a b
Left (KeyDoc -> Either KeyDoc (Stroke, KeyswitchRange))
-> KeyDoc -> Either KeyDoc (Stroke, KeyswitchRange)
forall a b. (a -> b) -> a -> b
$ KeyDoc
"unmapped: " KeyDoc -> KeyDoc -> KeyDoc
forall a. Semigroup a => a -> a -> a
<> Attributes -> KeyDoc
forall a. Pretty a => a -> KeyDoc
pretty Attributes
attrs) ((Stroke, KeyswitchRange) -> Either KeyDoc (Stroke, KeyswitchRange)
forall a b. b -> Either a b
Right ((Stroke, KeyswitchRange)
 -> Either KeyDoc (Stroke, KeyswitchRange))
-> (KeyswitchRange -> (Stroke, KeyswitchRange))
-> KeyswitchRange
-> Either KeyDoc (Stroke, KeyswitchRange)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stroke
stroke,)) (Maybe KeyswitchRange -> Either KeyDoc (Stroke, KeyswitchRange))
-> Maybe KeyswitchRange -> Either KeyDoc (Stroke, KeyswitchRange)
forall a b. (a -> b) -> a -> b
$
            Attributes -> Map Attributes KeyswitchRange -> Maybe KeyswitchRange
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Attributes -> Attributes -> Attributes
Attrs.remove Attributes
Attrs.soft Attributes
attrs) Map Attributes KeyswitchRange
keymap
        where
        stroke :: Stroke
stroke = (Char -> Symbol -> Attributes -> Y -> Stroke
Drums.stroke_dyn Char
char Symbol
call Attributes
attrs Y
dyn) { _group :: KeyDoc
Drums._group = KeyDoc
group }
        dyn :: Y
dyn = if Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs Attributes
Attrs.soft then Y
soft_dyn else Y
1
    check_dups :: ([KeyDoc], [(Stroke, b)]) -> ([(Stroke, b)], [KeyDoc])
check_dups ([KeyDoc]
msgs, [(Stroke, b)]
strokes) = ([(Stroke, b)]
strokes3, [KeyDoc]
dup_msgs [KeyDoc] -> [KeyDoc] -> [KeyDoc]
forall a. [a] -> [a] -> [a]
++ [KeyDoc]
msgs)
        where
        dup_msgs :: [KeyDoc]
dup_msgs = (((Stroke, b), [(Stroke, b)]) -> KeyDoc)
-> [((Stroke, b), [(Stroke, b)])] -> [KeyDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((KeyDoc
">1 call with same name: "<>) (KeyDoc -> KeyDoc)
-> (((Stroke, b), [(Stroke, b)]) -> KeyDoc)
-> ((Stroke, b), [(Stroke, b)])
-> KeyDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Stroke, b), [(Stroke, b)]) -> KeyDoc
forall {b}. ((Stroke, b), [(Stroke, b)]) -> KeyDoc
extract) [((Stroke, b), [(Stroke, b)])]
by_name
            [KeyDoc] -> [KeyDoc] -> [KeyDoc]
forall a. [a] -> [a] -> [a]
++ (((Stroke, b), [(Stroke, b)]) -> KeyDoc)
-> [((Stroke, b), [(Stroke, b)])] -> [KeyDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((KeyDoc
">1 call mapped to same key: "<>) (KeyDoc -> KeyDoc)
-> (((Stroke, b), [(Stroke, b)]) -> KeyDoc)
-> ((Stroke, b), [(Stroke, b)])
-> KeyDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Stroke, b), [(Stroke, b)]) -> KeyDoc
forall {b}. ((Stroke, b), [(Stroke, b)]) -> KeyDoc
extract) [((Stroke, b), [(Stroke, b)])]
by_key
        extract :: ((Stroke, b), [(Stroke, b)]) -> KeyDoc
extract = [Stroke] -> KeyDoc
forall a. Pretty a => a -> KeyDoc
pretty ([Stroke] -> KeyDoc)
-> (((Stroke, b), [(Stroke, b)]) -> [Stroke])
-> ((Stroke, b), [(Stroke, b)])
-> KeyDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Stroke, b) -> Stroke) -> [(Stroke, b)] -> [Stroke]
forall a b. (a -> b) -> [a] -> [b]
map (Stroke, b) -> Stroke
forall a b. (a, b) -> a
fst ([(Stroke, b)] -> [Stroke])
-> (((Stroke, b), [(Stroke, b)]) -> [(Stroke, b)])
-> ((Stroke, b), [(Stroke, b)])
-> [Stroke]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\((Stroke, b)
x, [(Stroke, b)]
xs) -> (Stroke, b)
x (Stroke, b) -> [(Stroke, b)] -> [(Stroke, b)]
forall a. a -> [a] -> [a]
: [(Stroke, b)]
xs)
        ([(Stroke, b)]
strokes2, [((Stroke, b), [(Stroke, b)])]
by_name) = ((Stroke, b) -> Symbol)
-> [(Stroke, b)] -> ([(Stroke, b)], [((Stroke, b), [(Stroke, b)])])
forall k a. Ord k => (a -> k) -> [a] -> ([a], [(a, [a])])
Seq.partition_dups (Stroke -> Symbol
Drums._name (Stroke -> Symbol)
-> ((Stroke, b) -> Stroke) -> (Stroke, b) -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stroke, b) -> Stroke
forall a b. (a, b) -> a
fst) [(Stroke, b)]
strokes
        ([(Stroke, b)]
strokes3, [((Stroke, b), [(Stroke, b)])]
by_key) = ((Stroke, b) -> Char)
-> [(Stroke, b)] -> ([(Stroke, b)], [((Stroke, b), [(Stroke, b)])])
forall k a. Ord k => (a -> k) -> [a] -> ([a], [(a, [a])])
Seq.partition_dups (Stroke -> Char
Drums._char (Stroke -> Char) -> ((Stroke, b) -> Stroke) -> (Stroke, b) -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stroke, b) -> Stroke
forall a b. (a, b) -> a
fst) [(Stroke, b)]
strokes2