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

{-# LANGUAGE ViewPatterns #-}
{- | This module implements kbd entry by intercepting kbd and MIDI events and
    re-emitting them as InputNotes.  These then go to the track-specific edit
    cmds to enter notes and to "Cmd.MidiThru" which re-emits them as MIDI.
-}
module Cmd.NoteEntry where
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set

import qualified Cmd.Cmd as Cmd
import qualified Cmd.EditUtil as EditUtil
import qualified Cmd.InputNote as InputNote
import qualified Cmd.Msg as Msg
import qualified Cmd.PhysicalKey as PhysicalKey

import qualified Derive.Controls as Controls
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Pitch as Pitch
import qualified Ui.Key as Key
import qualified Ui.UiMsg as UiMsg

import           Global


-- * with_note

{- | Take a Key (if @kbd_entry@ is True) or a ReadMessage to a Msg.InputNote
    and pass it to each of @cmds@.  As a minor optimization, @cmd@ is not
    called if no InputNote was produced.

    For the ASCII keyboard, the two rows of keys each map one octave of C to C.
    If the instrument responds to breath control, the key will also emit
    a breath control CC.

    It's a little less graceful than calling it many times applied to a single
    cmd, but only has to convert the input once and doesn't need tricks to make
    sure a converted key winds up with Done.

    Another way to do this would be place this as a transformer at the front of
    the responder, to transform keystrokes and MIDI keys into InputNotes.  That
    way, other Cmds don't have to worry about state_kbd_entry.  However, it
    would either require a privileged position for the transformer, or an
    additional Cmd feature to re-emit a new Msg.  In addition, it would
    preclude the ability to shadow it and catch MIDI msgs for other purposes.
-}
cmds_with_input :: Cmd.M m => Bool -> Maybe Patch.Config
    -> [Msg.Msg -> m Cmd.Status] -> (Msg.Msg -> m Cmd.Status)
cmds_with_input :: forall (m :: * -> *).
M m =>
Bool -> Maybe Config -> [Msg -> m Status] -> Msg -> m Status
cmds_with_input Bool
kbd_entry Maybe Config
maybe_config [Msg -> m Status]
cmds Msg
msg =
    forall (m :: * -> *).
M m =>
Bool -> Maybe Config -> Msg -> m (Maybe [Input])
msg_to_inputs Bool
kbd_entry Maybe Config
maybe_config Msg
msg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe [Input]
Nothing -> forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status
Cmd.sequence_cmds [Msg -> m Status]
cmds Msg
msg
        Just [Input]
inputs -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Status -> Status -> Status
Cmd.merge_status Status
Cmd.Done forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Input -> m Status
send [Input]
inputs
    where
    send :: Input -> m Status
send Input
input = do
        case Input
input of
            InputNote.NoteOn NoteId
note_id Input
_ Y
_ ->
                forall (m :: * -> *).
M m =>
(WriteDeviceState -> WriteDeviceState) -> m ()
Cmd.modify_wdev_state forall a b. (a -> b) -> a -> b
$ \WriteDeviceState
wdev -> WriteDeviceState
wdev
                    { wdev_last_note_id :: Maybe NoteId
Cmd.wdev_last_note_id = forall a. a -> Maybe a
Just NoteId
note_id }
            Input
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status
Cmd.sequence_cmds [Msg -> m Status]
cmds (Input -> Msg
Msg.InputNote Input
input)

-- | Like 'cmds_with_input', but figure out kbd_entry and patch on my own.
run_cmds_with_input :: Cmd.M m => [Msg.Msg -> m Cmd.Status]
    -> (Msg.Msg -> m Cmd.Status)
run_cmds_with_input :: forall (m :: * -> *). M m => [Msg -> m Status] -> Msg -> m Status
run_cmds_with_input [Msg -> m Status]
cmds Msg
msg = do
    Bool
kbd_entry <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ EditState -> Bool
Cmd.state_kbd_entry forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit
    Maybe Config
maybe_config <- forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm forall (m :: * -> *). M m => m (Maybe Instrument)
EditUtil.lookup_instrument forall a b. (a -> b) -> a -> b
$ \Instrument
inst ->
        forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *).
M m =>
Instrument -> m (Maybe ResolvedInstrument)
Cmd.lookup_instrument Instrument
inst) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Maybe (Patch, Config)
Cmd.midi_patch
    forall (m :: * -> *).
M m =>
Bool -> Maybe Config -> [Msg -> m Status] -> Msg -> m Status
cmds_with_input Bool
kbd_entry Maybe Config
maybe_config [Msg -> m Status]
cmds Msg
msg

-- | Convert a Msg to 'Msg.InputNote's, if applicable.  Returns Nothing if
-- the Msg is not convertible to InputNotes (and therefore other cmds should
-- get it), and Just [] if it is but didn't emit any InputNotes (and therefore
-- this other cmds shouldn't get it).
msg_to_inputs :: Cmd.M m => Bool -> Maybe Patch.Config -> Msg.Msg
    -> m (Maybe [InputNote.Input])
msg_to_inputs :: forall (m :: * -> *).
M m =>
Bool -> Maybe Config -> Msg -> m (Maybe [Input])
msg_to_inputs Bool
kbd_entry Maybe Config
maybe_config Msg
msg = do
    Bool
has_mods <- forall (m :: * -> *). M m => m Bool
are_modifiers_down
    Maybe [Input]
new_msgs <- if Bool
kbd_entry Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
has_mods
        then do
            Octave
octave <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (EditState -> Octave
Cmd.state_kbd_entry_octave forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit)
            let is_pressure :: Bool
is_pressure = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
                    (Config -> Flag -> Bool
`Patch.has_flag` Flag
Patch.Pressure) Maybe Config
maybe_config
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Octave -> Msg -> Maybe [Input]
kbd_input Bool
is_pressure Octave
octave Msg
msg
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). M m => Msg -> m (Maybe [Input])
midi_input Msg
msg) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) Maybe [Input]
new_msgs

are_modifiers_down :: Cmd.M m => m Bool
are_modifiers_down :: forall (m :: * -> *). M m => m Bool
are_modifiers_down = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null) forall (m :: * -> *). M m => m (Set Modifier)
Cmd.mods_down

-- ** kbd

-- | Convert a keyboard key-down to a 'Msg.InputNote'.
--
-- @Nothing@ means there's no input, @Just []@ means there was input, but
-- nothing to do.
kbd_input :: Bool -- ^ Whether this is a Pressure instrument or not.
    -- Pressure instruments respond to breath, and a kbd entry note on will
    -- emit an extra breath control.  This is convenient in practice because
    -- kbd entry is for quick and easy input and breath control gets in the way
    -- of that.
    -> Pitch.Octave -> Msg.Msg -> Maybe [InputNote.Input]
kbd_input :: Bool -> Octave -> Msg -> Maybe [Input]
kbd_input Bool
is_pressure Octave
octave (Msg -> Maybe (KbdState, Key)
Msg.key -> Just (KbdState
down, Key
key)) = case KbdState
down of
    KbdState
UiMsg.KeyRepeat
        -- Just [] makes the repeats get eaten here, but make sure to only
        -- suppress them if this key would have generated a note.
        | forall a. Maybe a -> Bool
Maybe.isJust Maybe [Input]
mb_inputs -> forall a. a -> Maybe a
Just []
        | Bool
otherwise -> forall a. Maybe a
Nothing
    KbdState
_ -> Maybe [Input]
mb_inputs
    where
    mb_inputs :: Maybe [Input]
mb_inputs = Bool -> Octave -> Bool -> Key -> Maybe [Input]
key_to_input Bool
is_pressure Octave
octave (KbdState
down forall a. Eq a => a -> a -> Bool
== KbdState
UiMsg.KeyDown) Key
key
kbd_input Bool
_ Octave
_ Msg
_ = forall a. Maybe a
Nothing

key_to_input :: Bool -> Pitch.Octave -> Bool -> Key.Key
    -> Maybe [InputNote.Input]
key_to_input :: Bool -> Octave -> Bool -> Key -> Maybe [Input]
key_to_input Bool
is_pressure Octave
octave Bool
is_down (Key.Char Char
c) = do
    Pitch
pitch <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c Map Char Pitch
PhysicalKey.pitch_map
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pitch -> [Input]
inputs_of (Octave -> Pitch -> Pitch
Pitch.add_octave Octave
octave Pitch
pitch)
    where
    inputs_of :: Pitch -> [Input]
inputs_of Pitch
pitch = case Bool -> Pitch -> Input
InputNote.from_ascii Bool
is_down Pitch
pitch of
        input :: Input
input@(InputNote.NoteOn NoteId
note_id Input
_ Y
_) | Bool
is_pressure ->
            -- Breath goes second, otherwise thru won't think it belongs to
            -- this note.
            [Input
input, forall {pitch}. NoteId -> Y -> GenericInput pitch
breath NoteId
note_id Y
InputNote.keyboard_velocity]
        Input
input -> [Input
input]
    breath :: NoteId -> Y -> GenericInput pitch
breath NoteId
note_id Y
val = forall pitch. NoteId -> Control -> Y -> GenericInput pitch
InputNote.Control NoteId
note_id Control
Controls.breath Y
val
key_to_input Bool
_ Octave
_ Bool
_ Key
_ = forall a. Maybe a
Nothing

-- ** midi

-- | Convert a 'Msg.Midi' msg.
midi_input :: Cmd.M m => Msg.Msg -> m (Maybe [InputNote.Input])
midi_input :: forall (m :: * -> *). M m => Msg -> m (Maybe [Input])
midi_input (Msg.Midi (Midi.ReadMessage ReadDevice
rdev RealTime
_ Message
midi_msg)) = do
    ReadDeviceState
rstate <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> ReadDeviceState
Cmd.state_rdev_state
    case ReadDeviceState
-> ReadDevice -> Message -> Maybe (Input, ReadDeviceState)
InputNote.from_midi ReadDeviceState
rstate ReadDevice
rdev Message
midi_msg of
        Just (Input
input, ReadDeviceState
rstate2) -> do
            forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_rdev_state :: ReadDeviceState
Cmd.state_rdev_state = ReadDeviceState
rstate2 }
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Input
input]
        Maybe (Input, ReadDeviceState)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [])
midi_input Msg
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- * floating_input_insert

floating_input_insert :: Cmd.M m => Msg.Msg -> m Cmd.Status
floating_input_insert :: forall (m :: * -> *). M m => Msg -> m Status
floating_input_insert Msg
msg = do
    Bool
floating_input <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ EditState -> Bool
Cmd.state_floating_input forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit
    case Msg
msg of
        Msg.InputNote (InputNote.NoteOn NoteId
_ Input
input Y
_) | Bool
floating_input -> do
            Note
note <- forall (m :: * -> *). M m => Input -> m Note
EditUtil.input_to_note Input
input
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FloatingInput -> Status
Cmd.FloatingInput forall a b. (a -> b) -> a -> b
$ Text -> FloatingInput
Cmd.FloatingInsert forall a b. (a -> b) -> a -> b
$
                Text
" (" forall a. Semigroup a => a -> a -> a
<> Note -> Text
Pitch.note_text Note
note forall a. Semigroup a => a -> a -> a
<> Text
")"
        Msg
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue