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

-- | Get track-specific Cmds.  Essentially, this detects the type of track
-- under the selection, and then returns cmds from one of "Cmd.NoteTrack",
-- "Cmd.PitchTrack", or "Cmd.ControlTrack".  This also handles per-instrument
-- and per-scale cmds.
module Cmd.Track (
    track_cmd
    , event_and_note_step
) where
import qualified Control.Monad.Except as Except

import qualified Util.Log as Log
import qualified Cmd.Cmd as Cmd
import qualified Cmd.ControlTrack as ControlTrack
import qualified Cmd.Edit as Edit
import qualified Cmd.Info as Info
import qualified Cmd.MidiThru as MidiThru
import qualified Cmd.Msg as Msg
import qualified Cmd.NoteEntry as NoteEntry
import qualified Cmd.NoteTrack as NoteTrack
import qualified Cmd.NoteTrackKeymap as NoteTrackKeymap
import qualified Cmd.Perf as Perf
import qualified Cmd.PitchTrack as PitchTrack
import qualified Cmd.Selection as Selection
import qualified Cmd.TimeStep as TimeStep

import qualified Derive.ParseTitle as ParseTitle
import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Ui.Ui as Ui

import           Global
import           Types


track_cmd :: Msg.Msg -> Cmd.CmdId Cmd.Status
track_cmd :: Msg -> CmdId Status
track_cmd Msg
msg = do
    [Msg -> CmdId Status]
cmds <- CmdT Identity [Msg -> CmdId Status]
get_track_cmds forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`Except.catchError` \Error
exc -> do
        case Error
exc of
            Error
Ui.Abort -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Ui.Error CallStack
stack Text
msg ->
                forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write forall a b. (a -> b) -> a -> b
$ CallStack -> Priority -> Maybe Stack -> Text -> Msg
Log.msg_call_stack CallStack
stack Priority
Log.Warn forall a. Maybe a
Nothing
                    (Text
"getting track cmds: " forall a. Semigroup a => a -> a -> a
<> Text
msg)
        forall (m :: * -> *) a. Monad m => a -> m a
return []
    forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status
Cmd.sequence_cmds [Msg -> CmdId Status]
cmds Msg
msg

-- | Get cmds according to the currently focused block and track.
get_track_cmds :: Cmd.CmdId [Msg.Msg -> Cmd.CmdId Cmd.Status]
get_track_cmds :: CmdT Identity [Msg -> CmdId Status]
get_track_cmds = do
    -- If this fails, it means the the track type can't be determined and there
    -- will be no track cmds.
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    TrackNum
tracknum <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe TrackNum)
Cmd.get_insert_tracknum
    TrackId
track_id <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id TrackNum
tracknum
    Maybe ResolvedInstrument
mb_resolved <- forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe ResolvedInstrument)
lookup_inst BlockId
block_id TrackId
track_id
    Type
track_type <- Text -> Type
ParseTitle.track_type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m Text
Ui.get_track_title TrackId
track_id
    Bool
has_note_children <- forall (m :: * -> *). M m => BlockId -> TrackNum -> m Bool
Info.has_note_children BlockId
block_id TrackNum
tracknum

    EditState
edit_state <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> EditState
Cmd.state_edit
    let edit_mode :: EditMode
edit_mode = EditState -> EditMode
Cmd.state_edit_mode EditState
edit_state
    let with_input :: [Msg -> CmdId Status] -> Msg -> CmdId Status
with_input = forall (m :: * -> *).
M m =>
Bool -> Maybe Config -> [Msg -> m Status] -> Msg -> m Status
NoteEntry.cmds_with_input
            (EditState -> Bool
Cmd.state_kbd_entry EditState
edit_state)
            (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 :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ResolvedInstrument
mb_resolved)
    -- The order is important:
    -- - Per-instrument cmds can override all others.
    --
    -- - The note cmds make sure that kbd entry can take over the kbd, and midi
    -- thru gets first whack at incoming midi.
    --
    -- - Track cmds are also wanting to take over the whole keyboard.
    --
    -- - Keymap cmds are "background" and only apply if no more special mode is
    -- active, so they go last.
    --
    -- Instrument cmds aren't under 'NoteEntry.cmds_with_input' so they don't
    -- get 'Pitch.Input's.  This is because if they are creating their own
    -- kbd entry then they will want the underlying keystrokes, as drum
    -- mappings do.  If they want 'Pitch.Input's, they can call
    -- 'NoteEntry.cmds_with_input'.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ case (Type
track_type, Maybe ResolvedInstrument
mb_resolved) of
            (Type
ParseTitle.NoteTrack, Just ResolvedInstrument
resolved) ->
                forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). M m => Handler m -> Msg -> m Status
Cmd.call forall a b. (a -> b) -> a -> b
$ InstrumentCode -> [HandlerId]
Cmd.inst_cmds forall a b. (a -> b) -> a -> b
$ forall code. Common code -> code
Common.common_code forall a b. (a -> b) -> a -> b
$
                    forall code. Inst code -> Common code
Inst.inst_common forall a b. (a -> b) -> a -> b
$ ResolvedInstrument -> Inst
Cmd.inst_instrument ResolvedInstrument
resolved
            (Type, Maybe ResolvedInstrument)
_ -> []
        , (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => Bool -> Msg -> m Status
Edit.handle_floating_input forall a b. (a -> b) -> a -> b
$ case Type
track_type of
            Type
ParseTitle.NoteTrack -> Bool
False
            Type
_ -> Bool
True
        , (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ [Msg -> CmdId Status] -> Msg -> CmdId Status
with_input (EditMode -> Type -> Bool -> [Msg -> CmdId Status]
input_cmds EditMode
edit_mode Type
track_type Bool
has_note_children)
        , EditMode -> Type -> [Msg -> CmdId Status]
track_type_cmds EditMode
edit_mode Type
track_type
        , Type -> [Msg -> CmdId Status]
keymap_cmds Type
track_type
        ]

lookup_inst :: Cmd.M m => BlockId -> TrackId -> m (Maybe Cmd.ResolvedInstrument)
lookup_inst :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe ResolvedInstrument)
lookup_inst BlockId
block_id TrackId
track_id =
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *). M m => Track -> m (Maybe Instrument)
Perf.lookup_instrument (BlockId
block_id, forall a. a -> Maybe a
Just TrackId
track_id)) forall a b. (a -> b) -> a -> b
$ \Instrument
inst ->
    forall (m :: * -> *).
M m =>
Instrument -> m (Maybe ResolvedInstrument)
Cmd.lookup_instrument Instrument
inst

-- | Cmds that use InputNotes, and hence must be called with
-- 'NoteEntry.cmds_with_input'.
input_cmds :: Cmd.EditMode -> ParseTitle.Type -> Bool
    -> [Msg.Msg -> Cmd.CmdId Cmd.Status]
input_cmds :: EditMode -> Type -> Bool -> [Msg -> CmdId Status]
input_cmds EditMode
edit_mode Type
track_type Bool
has_note_children =
    [Msg -> CmdId Status]
universal forall a. [a] -> [a] -> [a]
++ case Type
track_type of
        Type
ParseTitle.NoteTrack
            | Bool
has_note_children -> []
            | Bool
otherwise -> case EditMode
edit_mode of
                EditMode
Cmd.ValEdit -> [forall (m :: * -> *). M m => Msg -> m Status
NoteTrack.cmd_val_edit]
                EditMode
_ -> []
        Type
ParseTitle.PitchTrack -> case EditMode
edit_mode of
            EditMode
Cmd.ValEdit -> [forall (m :: * -> *). M m => Msg -> m Status
PitchTrack.cmd_val_edit]
            EditMode
_ -> []
        Type
ParseTitle.ControlTrack -> case EditMode
edit_mode of
            EditMode
Cmd.ValEdit -> [forall (m :: * -> *). M m => Msg -> m Status
ControlTrack.cmd_val_edit]
            EditMode
_ -> []
        Type
ParseTitle.TempoTrack -> case EditMode
edit_mode of
            EditMode
Cmd.ValEdit -> [forall (m :: * -> *). M m => Msg -> m Status
ControlTrack.cmd_tempo_val_edit]
            EditMode
_ -> []
    where
    universal :: [Msg -> CmdId Status]
universal =
        [ forall (m :: * -> *). M m => Msg -> m Status
PitchTrack.cmd_record_note_status
        , Msg -> CmdId Status
MidiThru.cmd_midi_thru
        , forall (m :: * -> *). M m => Msg -> m Status
NoteEntry.floating_input_insert
        ]

-- | Track-specific Cmds.
track_type_cmds :: Cmd.EditMode -> ParseTitle.Type
    -> [Msg.Msg -> Cmd.CmdId Cmd.Status]
track_type_cmds :: EditMode -> Type -> [Msg -> CmdId Status]
track_type_cmds EditMode
edit_mode = \case
    Type
ParseTitle.NoteTrack -> case EditMode
edit_mode of
        EditMode
Cmd.MethodEdit -> [forall (m :: * -> *). M m => Msg -> m Status
NoteTrack.cmd_method_edit]
        EditMode
_ -> []
    Type
ParseTitle.PitchTrack -> case EditMode
edit_mode of
        EditMode
Cmd.MethodEdit -> [forall (m :: * -> *). M m => Msg -> m Status
PitchTrack.cmd_method_edit]
        EditMode
_ -> []
    Type
ParseTitle.ControlTrack -> case EditMode
edit_mode of
        EditMode
Cmd.MethodEdit -> [forall (m :: * -> *). M m => Msg -> m Status
ControlTrack.cmd_method_edit]
        EditMode
_ -> []
    Type
ParseTitle.TempoTrack -> case EditMode
edit_mode of
        EditMode
Cmd.MethodEdit -> [forall (m :: * -> *). M m => Msg -> m Status
ControlTrack.cmd_method_edit]
        EditMode
_ -> []

-- | Track-specific keymaps.
keymap_cmds :: ParseTitle.Type -> [Msg.Msg -> Cmd.CmdId Cmd.Status]
keymap_cmds :: Type -> [Msg -> CmdId Status]
keymap_cmds = \case
    Type
ParseTitle.NoteTrack -> [forall (m :: * -> *). M m => Handler m -> Msg -> m Status
Cmd.call forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Keymap m -> Handler m
Cmd.Keymap forall a b. (a -> b) -> a -> b
$ Keymap (CmdT Identity)
NoteTrackKeymap.keymap]
    Type
_ -> []


-- * misc

-- | Like 'TimeStep.event_step', step to start and end of events.  But also
-- step to the start and end of the events of a parent note track, if any.
event_and_note_step :: Cmd.M m => m TimeStep.TimeStep
event_and_note_step :: forall (m :: * -> *). M m => m TimeStep
event_and_note_step = do
    (BlockId
block_id, TrackNum
tracknum, TrackId
_, TrackTime
_) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, TrackTime)
Selection.get_insert
    Maybe Track
maybe_track <- forall (m :: * -> *). M m => BlockId -> TrackNum -> m (Maybe Track)
Info.lookup_track_type BlockId
block_id TrackNum
tracknum
    Maybe TrackNum
note_tracknum <- case Track -> TrackType
Info.track_type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Track
maybe_track of
        Maybe TrackType
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just (Info.Note {}) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just (Info.Pitch Maybe TrackInfo
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just (Info.Pitch (Just TrackInfo
note)) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TrackInfo -> TrackNum
Ui.track_tracknum TrackInfo
note
        Just (Info.Control [TrackInfo]
tracks) -> forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
firstJusts (forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> m (Maybe TrackNum)
note_tracknum_of [TrackInfo]
tracks)
    let tracknums :: Tracks
tracknums = [TrackNum] -> Tracks
TimeStep.TrackNums forall a b. (a -> b) -> a -> b
$
            [TrackNum
tracknum] forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) Maybe TrackNum
note_tracknum
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Step] -> TimeStep
TimeStep.from_list
        [ Tracks -> Step
TimeStep.EventStart Tracks
tracknums, Tracks -> Step
TimeStep.EventEnd Tracks
tracknums
        , Step
TimeStep.BlockEdge
        ]
    where
    note_tracknum_of :: TrackInfo -> m (Maybe TrackNum)
note_tracknum_of TrackInfo
track = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TrackInfo -> m Bool
is_note TrackInfo
track)
        (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (TrackInfo -> TrackNum
Ui.track_tracknum TrackInfo
track))) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
    is_note :: TrackInfo -> m Bool
is_note = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Bool
ParseTitle.is_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Text
Ui.get_track_title
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> TrackId
Ui.track_id