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

-- | Internal Cmds, that keep bits of Cmd.State up to date that everyone else
-- relies on.
module Cmd.Internal (
    cmd_record_keys
    , record_focus
    , cmd_record_ui_updates
    , update_ui_state
    , set_style
    , sync_status
    , default_selection_hooks
    , sync_zoom_status
    , can_checkpoint
) where
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.GitT as GitT
import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Pretty as Pretty
import qualified Util.Rect as Rect
import qualified Util.Seq as Seq
import qualified Util.Texts as Texts

import qualified App.Config as Config
import qualified App.Path as Path
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Msg as Msg
import qualified Cmd.NoteTrackParse as NoteTrackParse
import qualified Cmd.Perf as Perf
import qualified Cmd.Selection as Selection
import qualified Cmd.TimeStep as TimeStep

import qualified Derive.Attrs as Attrs
import qualified Derive.Parse as Parse
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal

import qualified Midi.Midi as Midi
import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal
import qualified Ui.Block as Block
import qualified Ui.Color as Color
import qualified Ui.Diff as Diff
import qualified Ui.Event as Event
import qualified Ui.Id as Id
import qualified Ui.Key as Key
import qualified Ui.ScoreTime as ScoreTime
import qualified Ui.Sel as Sel
import qualified Ui.Track as Track
import qualified Ui.Types as Types
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig
import qualified Ui.UiMsg as UiMsg
import qualified Ui.Update as Update
import qualified Ui.Zoom as Zoom

import           Global
import           Types


-- * record keys

-- | Record keydowns into the 'State' modifier map.
cmd_record_keys :: Cmd.M m => Msg.Msg -> m Cmd.Status
cmd_record_keys :: forall (m :: * -> *). M m => Msg -> m Status
cmd_record_keys Msg
msg = m () -> m Status
forall {a}. m a -> m Status
cont (m () -> m Status) -> m () -> m Status
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Maybe Modifier)
-> ((Bool, Maybe Modifier) -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Msg -> Maybe (Bool, Maybe Modifier)
msg_to_mod Msg
msg) (((Bool, Maybe Modifier) -> m ()) -> m ())
-> ((Bool, Maybe Modifier) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Bool
down, Maybe Modifier
mb_mod) -> do
    Map Modifier Modifier
mods <- m (Map Modifier Modifier)
forall (m :: * -> *). M m => m (Map Modifier Modifier)
Cmd.keys_down
    -- The kbd model is that absolute sets of modifiers are sent over, but the
    -- other modifiers take downs and ups and incrementally modify the state.
    -- It's rather awkward, but keyups and keydowns may be missed if focus
    -- has left the app.
    let mods2 :: Map Modifier Modifier
mods2 = Map Modifier Modifier -> Map Modifier Modifier
set_key_mods Map Modifier Modifier
mods
    Map Modifier Modifier
mods3 <- case (Bool
down, Maybe Modifier
mb_mod) of
        (Bool
True, Just Modifier
mod) -> Modifier -> Map Modifier Modifier -> m (Map Modifier Modifier)
forall {m :: * -> *}.
LogMonad m =>
Modifier -> Map Modifier Modifier -> m (Map Modifier Modifier)
insert Modifier
mod Map Modifier Modifier
mods2
        (Bool
False, Just Modifier
mod) -> Modifier -> Map Modifier Modifier -> m (Map Modifier Modifier)
forall {m :: * -> *} {a}.
LogMonad m =>
Modifier -> Map Modifier a -> m (Map Modifier a)
delete Modifier
mod Map Modifier Modifier
mods2
        (Bool, Maybe Modifier)
_ -> Map Modifier Modifier -> m (Map Modifier Modifier)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Modifier Modifier
mods2
    -- whenJust mb_mod $ \m ->
    --     Log.warn $ (if down then "keydown " else "keyup ")
    --         ++ show (Cmd.strip_modifier m) ++ " in " ++ show (Map.keys mods)
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_keys_down :: Map Modifier Modifier
Cmd.state_keys_down = Map Modifier Modifier
mods3 }
    where
    cont :: m a -> m Status
cont = (m a -> m Status -> m Status
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue)
    insert :: Modifier -> Map Modifier Modifier -> m (Map Modifier Modifier)
insert Modifier
mod Map Modifier Modifier
mods = do
        let key :: Modifier
key = Modifier -> Modifier
Cmd.strip_modifier Modifier
mod
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Modifier
key Modifier -> Map Modifier Modifier -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Modifier Modifier
mods) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Text -> m ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"keydown for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Modifier -> Text
forall a. Show a => a -> Text
showt Modifier
mod Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" already in modifiers"
        Map Modifier Modifier -> m (Map Modifier Modifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Modifier Modifier -> m (Map Modifier Modifier))
-> Map Modifier Modifier -> m (Map Modifier Modifier)
forall a b. (a -> b) -> a -> b
$ Modifier
-> Modifier -> Map Modifier Modifier -> Map Modifier Modifier
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Modifier
key Modifier
mod Map Modifier Modifier
mods
    delete :: Modifier -> Map Modifier a -> m (Map Modifier a)
delete Modifier
mod Map Modifier a
mods = do
        let key :: Modifier
key = Modifier -> Modifier
Cmd.strip_modifier Modifier
mod
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Modifier
key Modifier -> Map Modifier a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Modifier a
mods) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Text -> m ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"keyup for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Modifier -> Text
forall a. Show a => a -> Text
showt Modifier
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not in modifiers "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Modifier] -> Text
forall a. Show a => a -> Text
showt (Map Modifier a -> [Modifier]
forall k a. Map k a -> [k]
Map.keys Map Modifier a
mods)
        Map Modifier a -> m (Map Modifier a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Modifier a -> m (Map Modifier a))
-> Map Modifier a -> m (Map Modifier a)
forall a b. (a -> b) -> a -> b
$ Modifier -> Map Modifier a -> Map Modifier a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Modifier
key Map Modifier a
mods
    set_key_mods :: Map Modifier Modifier -> Map Modifier Modifier
set_key_mods Map Modifier Modifier
mods = case Msg -> Maybe [Modifier]
msg_to_key_mods Msg
msg of
        Just [Modifier]
kmods -> [(Modifier, Modifier)]
-> Map Modifier Modifier -> Map Modifier Modifier
forall k v. Ord k => [(k, v)] -> Map k v -> Map k v
Maps.insertList
            [(Modifier -> Modifier
Cmd.KeyMod Modifier
c, Modifier -> Modifier
Cmd.KeyMod Modifier
c) | Modifier
c <- [Modifier]
kmods]
            ((Modifier -> Bool)
-> Map Modifier Modifier -> Map Modifier Modifier
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Modifier -> Bool
not_key_mod Map Modifier Modifier
mods)
        Maybe [Modifier]
Nothing -> Map Modifier Modifier
mods
    not_key_mod :: Modifier -> Bool
not_key_mod (Cmd.KeyMod Modifier
_) = Bool
False
    not_key_mod Modifier
_ = Bool
True

-- | Get the set of Key.Modifiers from the msg.
msg_to_key_mods :: Msg.Msg -> Maybe [Key.Modifier]
msg_to_key_mods :: Msg -> Maybe [Modifier]
msg_to_key_mods Msg
msg = case Msg
msg of
    Msg.Ui (UiMsg.UiMsg Context
_ (UiMsg.MsgEvent MsgEvent
evt)) -> case MsgEvent
evt of
        UiMsg.Kbd KbdState
_ [Modifier]
mods Key
_ Maybe Char
_ -> [Modifier] -> Maybe [Modifier]
forall a. a -> Maybe a
Just [Modifier]
mods
        UiMsg.Mouse (UiMsg.MouseEvent { mouse_modifiers :: MouseEvent -> [Modifier]
UiMsg.mouse_modifiers = [Modifier]
mods }) ->
            [Modifier] -> Maybe [Modifier]
forall a. a -> Maybe a
Just [Modifier]
mods
        MsgEvent
_ -> Maybe [Modifier]
forall a. Maybe a
Nothing
    Msg
_ -> Maybe [Modifier]
forall a. Maybe a
Nothing

-- | Convert a Msg to (is_key_down, Modifier).
msg_to_mod :: Msg.Msg -> Maybe (Bool, Maybe Cmd.Modifier)
msg_to_mod :: Msg -> Maybe (Bool, Maybe Modifier)
msg_to_mod Msg
msg = case Msg
msg of
    Msg.Ui (UiMsg.UiMsg Context
context (UiMsg.MsgEvent MsgEvent
evt)) -> case MsgEvent
evt of
        UiMsg.Kbd KbdState
state [Modifier]
_ Key
_ Maybe Char
_ -> case KbdState
state of
            KbdState
UiMsg.KeyDown -> (Bool, Maybe Modifier) -> Maybe (Bool, Maybe Modifier)
forall a. a -> Maybe a
Just (Bool
True, Maybe Modifier
forall a. Maybe a
Nothing)
            KbdState
UiMsg.KeyUp -> (Bool, Maybe Modifier) -> Maybe (Bool, Maybe Modifier)
forall a. a -> Maybe a
Just (Bool
False, Maybe Modifier
forall a. Maybe a
Nothing)
            KbdState
_ -> Maybe (Bool, Maybe Modifier)
forall a. Maybe a
Nothing
        UiMsg.Mouse (UiMsg.MouseEvent
                { mouse_state :: MouseEvent -> MouseState
UiMsg.mouse_state = UiMsg.MouseDown TrackNum
btn }) ->
            (Bool, Maybe Modifier) -> Maybe (Bool, Maybe Modifier)
forall a. a -> Maybe a
Just (Bool
True, Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Maybe Modifier) -> Modifier -> Maybe Modifier
forall a b. (a -> b) -> a -> b
$ TrackNum -> Maybe (TrackNum, Track) -> Modifier
Cmd.MouseMod TrackNum
btn (Context -> Maybe (TrackNum, Track)
UiMsg.ctx_track Context
context))
        UiMsg.Mouse (UiMsg.MouseEvent
                { mouse_state :: MouseEvent -> MouseState
UiMsg.mouse_state = UiMsg.MouseUp TrackNum
btn }) ->
            (Bool, Maybe Modifier) -> Maybe (Bool, Maybe Modifier)
forall a. a -> Maybe a
Just (Bool
False, Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Maybe Modifier) -> Modifier -> Maybe Modifier
forall a b. (a -> b) -> a -> b
$ TrackNum -> Maybe (TrackNum, Track) -> Modifier
Cmd.MouseMod TrackNum
btn (Context -> Maybe (TrackNum, Track)
UiMsg.ctx_track Context
context))
        MsgEvent
_ -> Maybe (Bool, Maybe Modifier)
forall a. Maybe a
Nothing
    Msg.Midi (Midi.ReadMessage { rmsg_msg :: ReadMessage -> Message
Midi.rmsg_msg = Message
msg }) -> case Message
msg of
        Midi.ChannelMessage Channel
chan (Midi.NoteOn Key
key Channel
_vel) ->
            (Bool, Maybe Modifier) -> Maybe (Bool, Maybe Modifier)
forall a. a -> Maybe a
Just (Bool
True, Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Maybe Modifier) -> Modifier -> Maybe Modifier
forall a b. (a -> b) -> a -> b
$ Channel -> Key -> Modifier
Cmd.MidiMod Channel
chan Key
key)
        Midi.ChannelMessage Channel
chan (Midi.NoteOff Key
key Channel
_vel) ->
            (Bool, Maybe Modifier) -> Maybe (Bool, Maybe Modifier)
forall a. a -> Maybe a
Just (Bool
False, Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Maybe Modifier) -> Modifier -> Maybe Modifier
forall a b. (a -> b) -> a -> b
$ Channel -> Key -> Modifier
Cmd.MidiMod Channel
chan Key
key)
        Message
_ -> Maybe (Bool, Maybe Modifier)
forall a. Maybe a
Nothing
    Msg
_ -> Maybe (Bool, Maybe Modifier)
forall a. Maybe a
Nothing

-- * focus

-- | Keep 'Cmd.state_focused_view' up to date.
record_focus :: Cmd.M m => Msg.Msg -> m Cmd.Status
record_focus :: forall (m :: * -> *). M m => Msg -> m Status
record_focus (Msg.Ui UiMsg
m) = case UiMsg
m of
    UiMsg.UiMsg Context
_ (UiMsg.UiUpdate ViewId
view_id UiUpdate
UiMsg.UpdateClose) -> do
        m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Maybe ViewId -> Maybe ViewId -> Bool
forall a. Eq a => a -> a -> Bool
== ViewId -> Maybe ViewId
forall a. a -> Maybe a
Just ViewId
view_id) (Maybe ViewId -> Bool) -> m (Maybe ViewId) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State -> Maybe ViewId) -> m (Maybe ViewId)
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe ViewId
Cmd.state_focused_view) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_focused_view :: Maybe ViewId
Cmd.state_focused_view = Maybe ViewId
forall a. Maybe a
Nothing }
        Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
    UiMsg.UiMsg (UiMsg.Context { ctx_focus :: Context -> Maybe ViewId
UiMsg.ctx_focus = Just ViewId
view_id }) Msg
msg -> do
        m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((Maybe ViewId -> Maybe ViewId -> Bool
forall a. Eq a => a -> a -> Bool
== ViewId -> Maybe ViewId
forall a. a -> Maybe a
Just ViewId
view_id) (Maybe ViewId -> Bool) -> m (Maybe ViewId) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State -> Maybe ViewId) -> m (Maybe ViewId)
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe ViewId
Cmd.state_focused_view) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_focused_view :: Maybe ViewId
Cmd.state_focused_view = ViewId -> Maybe ViewId
forall a. a -> Maybe a
Just ViewId
view_id }
        Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> m Status) -> Status -> m Status
forall a b. (a -> b) -> a -> b
$ case Msg
msg of
           UiMsg.MsgEvent (UiMsg.AuxMsg AuxMsg
UiMsg.Focus) -> Status
Cmd.Done
           Msg
_ -> Status
Cmd.Continue
    UiMsg
_ -> Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
record_focus Msg
_ = Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue

-- * record ui updates

-- | Catch 'UiMsg.UiUpdate's from the UI, and modify the state accordingly to
-- reflect the UI state.
--
-- Unlike all the other Cmds, the state changes this makes are not synced.
-- UiUpdates report changes that have already occurred directly on the UI, so
-- syncing them would be redundant.
cmd_record_ui_updates :: Cmd.M m => Msg.Msg -> m Cmd.Status
cmd_record_ui_updates :: forall (m :: * -> *). M m => Msg -> m Status
cmd_record_ui_updates (Msg.Ui (UiMsg.UiMsg Context
_
        (UiMsg.UpdateScreenSize TrackNum
screen TrackNum
screens Rect
rect))) = do
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_screens :: [Rect]
Cmd.state_screens =
            TrackNum -> TrackNum -> Rect -> [Rect] -> [Rect]
set_screen TrackNum
screen TrackNum
screens Rect
rect (State -> [Rect]
Cmd.state_screens State
st)
        }
    Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
    where
    set_screen :: TrackNum -> TrackNum -> Rect -> [Rect] -> [Rect]
set_screen TrackNum
screen TrackNum
screens Rect
rect = TrackNum -> [Rect] -> [Rect]
forall a. TrackNum -> [a] -> [a]
take TrackNum
screens
        ([Rect] -> [Rect]) -> ([Rect] -> [Rect]) -> [Rect] -> [Rect]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rect -> TrackNum -> (Maybe Rect -> Rect) -> [Rect] -> [Rect]
forall a. a -> TrackNum -> (Maybe a -> a) -> [a] -> [a]
Seq.update_at Rect
Rect.empty TrackNum
screen (Rect -> Maybe Rect -> Rect
forall a b. a -> b -> a
const Rect
rect)
cmd_record_ui_updates Msg
msg = do
    (Context
ctx, ViewId
view_id, UiUpdate
update) <- Maybe (Context, ViewId, UiUpdate) -> m (Context, ViewId, UiUpdate)
forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless (Msg -> Maybe (Context, ViewId, UiUpdate)
update_of Msg
msg)
    Maybe TrackNum -> ViewId -> UiUpdate -> m ()
forall (m :: * -> *).
M m =>
Maybe TrackNum -> ViewId -> UiUpdate -> m ()
ui_update ((TrackNum, Track) -> TrackNum
forall a b. (a, b) -> a
fst ((TrackNum, Track) -> TrackNum)
-> Maybe (TrackNum, Track) -> Maybe TrackNum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Maybe (TrackNum, Track)
UiMsg.ctx_track Context
ctx) ViewId
view_id UiUpdate
update
    -- return Continue to give 'update_ui_state' a crack at it
    Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue

ui_update :: Cmd.M m => Maybe TrackNum -> ViewId -> UiMsg.UiUpdate -> m ()
ui_update :: forall (m :: * -> *).
M m =>
Maybe TrackNum -> ViewId -> UiUpdate -> m ()
ui_update Maybe TrackNum
maybe_tracknum ViewId
view_id UiUpdate
update = case UiUpdate
update of
    UiMsg.UpdateTrackScroll TrackNum
hpos -> ViewId -> TrackNum -> m ()
forall (m :: * -> *). M m => ViewId -> TrackNum -> m ()
Ui.set_track_scroll ViewId
view_id TrackNum
hpos
    UiMsg.UpdateTimeScroll ScoreTime
offset -> ViewId -> (Zoom -> Zoom) -> m ()
forall (m :: * -> *). M m => ViewId -> (Zoom -> Zoom) -> m ()
Ui.modify_zoom ViewId
view_id ((Zoom -> Zoom) -> m ()) -> (Zoom -> Zoom) -> m ()
forall a b. (a -> b) -> a -> b
$ \Zoom
zoom ->
        Zoom
zoom { offset :: ScoreTime
Zoom.offset = ScoreTime
offset }
    UiMsg.UpdateViewResize Rect
rect Padding
padding -> do
        View
view <- ViewId -> m View
forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rect
rect Rect -> Rect -> Bool
forall a. Eq a => a -> a -> Bool
/= View -> Rect
Block.view_rect View
view) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ViewId -> Rect -> m ()
forall (m :: * -> *). M m => ViewId -> Rect -> m ()
Ui.set_view_rect ViewId
view_id Rect
rect
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (View -> Padding
Block.view_padding View
view Padding -> Padding -> Bool
forall a. Eq a => a -> a -> Bool
/= Padding
padding) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            ViewId -> Padding -> m ()
forall (m :: * -> *). M m => ViewId -> Padding -> m ()
Ui.set_view_padding ViewId
view_id Padding
padding
    UiMsg.UpdateTrackWidth TrackNum
width TrackNum
suggested_width -> case Maybe TrackNum
maybe_tracknum of
        Just TrackNum
tracknum -> do
            BlockId
block_id <- ViewId -> m BlockId
forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
            Bool
collapsed <- (TrackFlag
Block.Collapse `Set.member`) (Set TrackFlag -> Bool) -> m (Set TrackFlag) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                BlockId -> TrackNum -> m (Set TrackFlag)
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Set TrackFlag)
Ui.track_flags BlockId
block_id TrackNum
tracknum
            -- fltk shouldn't send widths for collapsed tracks, but it does
            -- anyway because otherwise it would have to cache the track sizes
            -- to know which one changed.  See BlockView::track_tile_cb.
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
collapsed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                BlockId -> TrackNum -> TrackNum -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
Ui.set_track_width BlockId
block_id TrackNum
tracknum TrackNum
width
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TrackNum
suggested_width TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
> TrackNum
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                BlockId -> TrackNum -> TrackNum -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
Ui.set_track_suggested_width BlockId
block_id TrackNum
tracknum TrackNum
suggested_width
        Maybe TrackNum
Nothing -> Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"update with no track: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UiUpdate -> Text
forall a. Show a => a -> Text
showt UiUpdate
update
    -- Handled by 'ui_update_state'.
    UiUpdate
UiMsg.UpdateClose -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    UiMsg.UpdateInput {} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | This is the other half of 'cmd_record_ui_updates', whose output is synced
-- like normal Cmds.  When its a block update I have to update the other
-- views.
update_ui_state :: Cmd.M m => Msg.Msg -> m Cmd.Status
update_ui_state :: forall (m :: * -> *). M m => Msg -> m Status
update_ui_state Msg
msg = do
    (Context
ctx, ViewId
view_id, UiUpdate
update) <- Maybe (Context, ViewId, UiUpdate) -> m (Context, ViewId, UiUpdate)
forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless (Msg -> Maybe (Context, ViewId, UiUpdate)
update_of Msg
msg)
    if Context -> Bool
UiMsg.ctx_floating_input Context
ctx
        then do
            (EditState -> EditState) -> m ()
forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
Cmd.modify_edit_state ((EditState -> EditState) -> m ())
-> (EditState -> EditState) -> m ()
forall a b. (a -> b) -> a -> b
$ \EditState
st -> EditState
st
                { state_floating_input :: Bool
Cmd.state_floating_input = Bool
False }
            Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
        else do
            Maybe TrackNum -> ViewId -> UiUpdate -> m ()
forall (m :: * -> *).
M m =>
Maybe TrackNum -> ViewId -> UiUpdate -> m ()
ui_update_state ((TrackNum, Track) -> TrackNum
forall a b. (a, b) -> a
fst ((TrackNum, Track) -> TrackNum)
-> Maybe (TrackNum, Track) -> Maybe TrackNum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Maybe (TrackNum, Track)
UiMsg.ctx_track Context
ctx) ViewId
view_id UiUpdate
update
            Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done

ui_update_state :: Cmd.M m => Maybe TrackNum -> ViewId -> UiMsg.UiUpdate -> m ()
ui_update_state :: forall (m :: * -> *).
M m =>
Maybe TrackNum -> ViewId -> UiUpdate -> m ()
ui_update_state Maybe TrackNum
maybe_tracknum ViewId
view_id UiUpdate
update = case UiUpdate
update of
    UiMsg.UpdateInput (Just Text
text) -> do
        View
view <- ViewId -> m View
forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
        BlockId -> Text -> m ()
forall {m :: * -> *}. M m => BlockId -> Text -> m ()
update_input (View -> BlockId
Block.view_block View
view) Text
text
    -- UiMsg.UpdateTimeScroll {} -> sync_zoom_status view_id
    UiUpdate
UiMsg.UpdateClose -> ViewId -> m ()
forall (m :: * -> *). M m => ViewId -> m ()
Ui.destroy_view ViewId
view_id
    UiUpdate
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where
    update_input :: BlockId -> Text -> m ()
update_input BlockId
block_id Text
text = case Maybe TrackNum
maybe_tracknum of
        Just TrackNum
tracknum -> do
            Maybe TrackId
track_id <- BlockId -> TrackNum -> m (Maybe TrackId)
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id TrackNum
tracknum
            case Maybe TrackId
track_id of
                Just TrackId
track_id -> TrackId -> Text -> m ()
forall (m :: * -> *). M m => TrackId -> Text -> m ()
Ui.set_track_title TrackId
track_id Text
text
                Maybe TrackId
Nothing -> Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ UiUpdate -> Text
forall a. Show a => a -> Text
showt (Maybe Text -> UiUpdate
UiMsg.UpdateInput (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
text))
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on non-event track " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
tracknum
        Maybe TrackNum
Nothing -> BlockId -> Text -> m ()
forall {m :: * -> *}. M m => BlockId -> Text -> m ()
Ui.set_block_title BlockId
block_id Text
text

update_of :: Msg.Msg -> Maybe (UiMsg.Context, ViewId, UiMsg.UiUpdate)
update_of :: Msg -> Maybe (Context, ViewId, UiUpdate)
update_of (Msg.Ui (UiMsg.UiMsg Context
ctx (UiMsg.UiUpdate ViewId
view_id UiUpdate
update))) =
    (Context, ViewId, UiUpdate) -> Maybe (Context, ViewId, UiUpdate)
forall a. a -> Maybe a
Just (Context
ctx, ViewId
view_id, UiUpdate
update)
update_of Msg
_ = Maybe (Context, ViewId, UiUpdate)
forall a. Maybe a
Nothing


-- * set style

set_style :: Track.SetStyleHigh
set_style :: SetStyleHigh
set_style = TrackBg
-> (forall a.
    Namespace -> Map BlockId a -> BlockId -> Bool -> EventStyle)
-> SetStyleHigh
Track.SetStyleHigh TrackBg
track_bg forall a.
Namespace -> Map BlockId a -> BlockId -> Bool -> EventStyle
event_style

-- | Set the style of an event based on its contents.  This is hardcoded
-- for now but it's easy to put in StaticConfig if needed.
event_style :: Id.Namespace -> Map BlockId a -> BlockId -> Bool
    -> Event.EventStyle
event_style :: forall a.
Namespace -> Map BlockId a -> BlockId -> Bool -> EventStyle
event_style Namespace
namespace Map BlockId a
blocks BlockId
block_id Bool
has_note_children Text
title Event
event =
    StyleId -> StyleId
integrated (StyleId -> StyleId) -> StyleId -> StyleId
forall a b. (a -> b) -> a -> b
$
        Style -> StyleId -> StyleId
Config.event_style (Text -> Style
style_of (Event -> Text
Event.text Event
event)) (Event -> StyleId
Event.style Event
event)
    where
    integrated :: StyleId -> StyleId
integrated
        | Maybe Stack -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing (Event -> Maybe Stack
Event.stack Event
event) = StyleId -> StyleId
forall a. a -> a
id
        | Bool
otherwise = StyleId -> StyleId
Config.integrated_style
    style_of :: Text -> Style
style_of Text
text
        | Text
Config.event_comment Text -> Text -> Bool
`Text.isPrefixOf` Text
text = Style
Config.Commented
        | Bool
otherwise = case Text -> Either Text Expr
Parse.parse_expr Text
text of
            Left Text
_ -> Style
Config.Error
            Right Expr
_
                | Text -> Bool
ParseTitle.is_note_track Text
title ->
                    if Bool
has_note_children then Style
Config.NoteParent
                    else if Text -> Bool
is_block_call Text
text then Style
Config.NoteBlockCall
                    else Style
Config.Note
                | Text -> Bool
ParseTitle.is_pitch_track Text
title -> Style
Config.Pitch
                | Bool
otherwise -> Style
Config.Control
    is_block_call :: Text -> Bool
is_block_call = Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BlockId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([BlockId] -> Bool) -> (Text -> [BlockId]) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> (Text -> Maybe BlockId) -> Text -> [BlockId]
forall a. Bool -> (Text -> Maybe a) -> Text -> [a]
NoteTrackParse.block_calls_of Bool
False Text -> Maybe BlockId
to_block_id
    to_block_id :: Text -> Maybe BlockId
to_block_id = Map BlockId a
-> Namespace -> Maybe BlockId -> Text -> Maybe BlockId
forall a.
Map BlockId a
-> Namespace -> Maybe BlockId -> Text -> Maybe BlockId
NoteTrackParse.to_block_id Map BlockId a
blocks Namespace
namespace (BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
block_id)

-- | Set the track background color.
track_bg :: Track.Track -> Color.Color
track_bg :: TrackBg
track_bg Track
track
    | Text -> Bool
ParseTitle.is_pitch_track Text
title = Double -> Color -> Color
Color.brightness Double
1.7 Color
Config.pitch_color
    | Text -> Bool
ParseTitle.is_control_track Text
title =
        Double -> Color -> Color
Color.brightness Double
1.7 Color
Config.control_color
    | Bool
otherwise = TrackBg
Track.track_bg Track
track
    where title :: Text
title = Track -> Text
Track.track_title Track
track

-- * sync

-- | This is called after every non-failing cmd.
sync_status :: Ui.State -> Cmd.State -> Update.UiDamage -> Cmd.CmdId Cmd.Status
sync_status :: State -> State -> UiDamage -> CmdId Status
sync_status State
ui_from State
cmd_from UiDamage
damage = do
    State
ui_to <- CmdT Identity State
forall (m :: * -> *). M m => m State
Ui.get
    (State -> State) -> CmdT Identity ()
forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify ((State -> State) -> CmdT Identity ())
-> (State -> State) -> CmdT Identity ()
forall a b. (a -> b) -> a -> b
$ UiDamage -> State -> State -> State -> State
update_saved UiDamage
damage State
ui_from State
ui_to

    State
cmd_to <- CmdT Identity State
forall (m :: * -> *). M m => m State
Cmd.get
    let updates :: [UiUpdate]
updates = ([UiUpdate], [DisplayUpdate]) -> [UiUpdate]
forall a b. (a, b) -> a
fst (([UiUpdate], [DisplayUpdate]) -> [UiUpdate])
-> ([UiUpdate], [DisplayUpdate]) -> [UiUpdate]
forall a b. (a -> b) -> a -> b
$ DiffM () -> ([UiUpdate], [DisplayUpdate])
Diff.run (DiffM () -> ([UiUpdate], [DisplayUpdate]))
-> DiffM () -> ([UiUpdate], [DisplayUpdate])
forall a b. (a -> b) -> a -> b
$ State -> State -> UiDamage -> DiffM ()
Diff.diff_views State
ui_from State
ui_to UiDamage
damage
        new_views :: [ViewId]
new_views = (UiUpdate -> Maybe ViewId) -> [UiUpdate] -> [ViewId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UiUpdate -> Maybe ViewId
forall {t} {u}. Update t u -> Maybe ViewId
is_create_view [UiUpdate]
updates
        edit_state :: EditState
edit_state = State -> EditState
Cmd.state_edit State
cmd_to
    Bool -> CmdT Identity () -> CmdT Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([ViewId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ViewId]
new_views) Bool -> Bool -> Bool
|| State -> EditState
Cmd.state_edit State
cmd_from EditState -> EditState -> Bool
forall a. Eq a => a -> a -> Bool
/= EditState
edit_state
            Bool -> Bool -> Bool
|| State -> Saved
Cmd.state_saved State
cmd_from Saved -> Saved -> Bool
forall a. Eq a => a -> a -> Bool
/= State -> Saved
Cmd.state_saved State
cmd_to) (CmdT Identity () -> CmdT Identity ())
-> CmdT Identity () -> CmdT Identity ()
forall a b. (a -> b) -> a -> b
$
        SaveStatus -> EditState -> CmdT Identity ()
forall (m :: * -> *). M m => SaveStatus -> EditState -> m ()
sync_edit_state (State -> SaveStatus
get_save_status State
cmd_to) EditState
edit_state
    PlayState -> CmdT Identity ()
forall (m :: * -> *). M m => PlayState -> m ()
sync_play_state (PlayState -> CmdT Identity ()) -> PlayState -> CmdT Identity ()
forall a b. (a -> b) -> a -> b
$ State -> PlayState
Cmd.state_play State
cmd_to
    FilePath -> Maybe Writable -> CmdT Identity ()
forall (m :: * -> *). M m => FilePath -> Maybe Writable -> m ()
sync_save_file (State -> FilePath
Cmd.score_path State
cmd_to) ((Writable, SaveFile) -> Writable
forall a b. (a, b) -> a
fst ((Writable, SaveFile) -> Writable)
-> Maybe (Writable, SaveFile) -> Maybe Writable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State -> Maybe (Writable, SaveFile)
Cmd.state_save_file State
cmd_to)
    Default -> CmdT Identity ()
forall (m :: * -> *). M m => Default -> m ()
sync_defaults (Default -> CmdT Identity ()) -> Default -> CmdT Identity ()
forall a b. (a -> b) -> a -> b
$ Lens State Config
Ui.configLens State Config -> Lens Config Default -> Lens State Default
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Config Default
UiConfig.default_ Lens State Default -> State -> Default
forall f a. Lens f a -> f -> a
#$ State
ui_to
    [(ViewId, Maybe Selection)] -> CmdT Identity ()
run_selection_hooks ((UiUpdate -> Maybe (ViewId, Maybe Selection))
-> [UiUpdate] -> [(ViewId, Maybe Selection)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UiUpdate -> Maybe (ViewId, Maybe Selection)
forall {t} {u}. Update t u -> Maybe (ViewId, Maybe Selection)
selection_update [UiUpdate]
updates)
    -- forM_ (new_views ++ mapMaybe zoom_update updates) sync_zoom_status
    Status -> CmdId Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
    where
    is_create_view :: Update t u -> Maybe ViewId
is_create_view (Update.View ViewId
view_id View
Update.CreateView) = ViewId -> Maybe ViewId
forall a. a -> Maybe a
Just ViewId
view_id
    is_create_view Update t u
_ = Maybe ViewId
forall a. Maybe a
Nothing
    selection_update :: Update t u -> Maybe (ViewId, Maybe Selection)
selection_update (Update.View ViewId
view_id (Update.Selection TrackNum
selnum Maybe Selection
sel))
        | TrackNum
selnum TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
== TrackNum
Config.insert_selnum = (ViewId, Maybe Selection) -> Maybe (ViewId, Maybe Selection)
forall a. a -> Maybe a
Just (ViewId
view_id, Maybe Selection
sel)
    selection_update Update t u
_ = Maybe (ViewId, Maybe Selection)
forall a. Maybe a
Nothing
    -- zoom_update (Update.View view_id (Update.Zoom {})) = Just view_id
    -- zoom_update _ = Nothing

-- | Flip 'Cmd._saved_state' if the score has changed.  "Cmd.Save" will turn it
-- back on after a save.
update_saved :: Update.UiDamage -> Ui.State -> Ui.State -> Cmd.State
    -> Cmd.State
update_saved :: UiDamage -> State -> State -> State -> State
update_saved UiDamage
damage State
ui_from State
ui_to State
cmd_state = case SavedState
saved_state of
    SavedState
Cmd.JustLoaded -> State
cmd_state
        { state_saved :: Saved
Cmd.state_saved = SavedState -> Bool -> Saved
Cmd.Saved SavedState
Cmd.SavedChanges Bool
editor_open }
    SavedState
Cmd.SavedChanges
        | Maybe (Canonical, Commit) -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing (State -> Maybe (Canonical, Commit)
can_checkpoint State
cmd_state)
            Bool -> Bool -> Bool
&& State -> State -> UiDamage -> Bool
Diff.score_changed State
ui_from State
ui_to UiDamage
damage ->
        State
cmd_state { state_saved :: Saved
Cmd.state_saved = SavedState -> Bool -> Saved
Cmd.Saved SavedState
Cmd.UnsavedChanges Bool
editor_open }
    SavedState
_ -> State
cmd_state
    where Cmd.Saved SavedState
saved_state Bool
editor_open = State -> Saved
Cmd.state_saved State
cmd_state

-- | Return Just if there will be a git checkpoint.  'update_saved' has to
-- predict this because by the time 'Cmd.Undo.save_history' runs, it's too
-- late to make Ui.State changes.
--
-- This is not defined in Cmd.Undo to avoid a circular import.
can_checkpoint :: Cmd.State -> Maybe (Path.Canonical, GitT.Commit)
    -- ^ I need both a repo and a previous commit to checkpoint.
can_checkpoint :: State -> Maybe (Canonical, Commit)
can_checkpoint State
cmd_state = case (State -> Maybe (Writable, SaveFile)
Cmd.state_save_file State
cmd_state, Maybe Commit
prev) of
    (Just (Writable
Cmd.ReadWrite, Cmd.SaveRepo Canonical
repo), Just Commit
commit) ->
        (Canonical, Commit) -> Maybe (Canonical, Commit)
forall a. a -> Maybe a
Just (Canonical
repo, Commit
commit)
    (Maybe (Writable, SaveFile), Maybe Commit)
_ -> Maybe (Canonical, Commit)
forall a. Maybe a
Nothing
    where
    prev :: Maybe Commit
prev = HistoryConfig -> Maybe Commit
Cmd.hist_last_commit (HistoryConfig -> Maybe Commit) -> HistoryConfig -> Maybe Commit
forall a b. (a -> b) -> a -> b
$ State -> HistoryConfig
Cmd.state_history_config State
cmd_state

-- ** hooks

default_selection_hooks :: [[(ViewId, Maybe Cmd.TrackSelection)]
    -> Cmd.CmdId ()]
default_selection_hooks :: [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()]
default_selection_hooks =
    [ ((ViewId, Maybe TrackSelection) -> CmdT Identity ())
-> [(ViewId, Maybe TrackSelection)] -> CmdT Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ViewId -> Maybe TrackSelection -> CmdT Identity ())
-> (ViewId, Maybe TrackSelection) -> CmdT Identity ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ViewId -> Maybe TrackSelection -> CmdT Identity ()
forall (m :: * -> *). M m => ViewId -> Maybe TrackSelection -> m ()
sync_selection_status)
    , ((ViewId, Maybe TrackSelection) -> CmdT Identity ())
-> [(ViewId, Maybe TrackSelection)] -> CmdT Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ViewId -> Maybe TrackSelection -> CmdT Identity ())
-> (ViewId, Maybe TrackSelection) -> CmdT Identity ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ViewId -> Maybe TrackSelection -> CmdT Identity ()
forall (m :: * -> *). M m => ViewId -> Maybe TrackSelection -> m ()
sync_selection_control)
    ]

run_selection_hooks :: [(ViewId, Maybe Sel.Selection)] -> Cmd.CmdId ()
run_selection_hooks :: [(ViewId, Maybe Selection)] -> CmdT Identity ()
run_selection_hooks [] = () -> CmdT Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
run_selection_hooks [(ViewId, Maybe Selection)]
sels = do
    [(ViewId, Maybe TrackSelection)]
sel_tracks <- [(ViewId, Maybe Selection)]
-> ((ViewId, Maybe Selection)
    -> CmdT Identity (ViewId, Maybe TrackSelection))
-> CmdT Identity [(ViewId, Maybe TrackSelection)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ViewId, Maybe Selection)]
sels (((ViewId, Maybe Selection)
  -> CmdT Identity (ViewId, Maybe TrackSelection))
 -> CmdT Identity [(ViewId, Maybe TrackSelection)])
-> ((ViewId, Maybe Selection)
    -> CmdT Identity (ViewId, Maybe TrackSelection))
-> CmdT Identity [(ViewId, Maybe TrackSelection)]
forall a b. (a -> b) -> a -> b
$ \(ViewId
view_id, Maybe Selection
maybe_sel) -> case Maybe Selection
maybe_sel of
        Maybe Selection
Nothing -> (ViewId, Maybe TrackSelection)
-> CmdT Identity (ViewId, Maybe TrackSelection)
forall (m :: * -> *) a. Monad m => a -> m a
return (ViewId
view_id, Maybe TrackSelection
forall a. Maybe a
Nothing)
        Just Selection
sel -> do
            BlockId
block_id <- ViewId -> CmdT Identity BlockId
forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
            Maybe TrackId
maybe_track_id <- BlockId -> TrackNum -> CmdT Identity (Maybe TrackId)
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id
                (Selection -> TrackNum
Selection.sel_point_track Selection
sel)
            (ViewId, Maybe TrackSelection)
-> CmdT Identity (ViewId, Maybe TrackSelection)
forall (m :: * -> *) a. Monad m => a -> m a
return (ViewId
view_id, TrackSelection -> Maybe TrackSelection
forall a. a -> Maybe a
Just (Selection
sel, BlockId
block_id, Maybe TrackId
maybe_track_id))
    [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()]
hooks <- (State -> [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()])
-> CmdT
     Identity [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()]
forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (Hooks -> [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()]
Cmd.hooks_selection (Hooks -> [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()])
-> (State -> Hooks)
-> State
-> [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Hooks
Cmd.state_hooks)
    (([(ViewId, Maybe TrackSelection)] -> CmdT Identity ())
 -> CmdT Identity ())
-> [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()]
-> CmdT Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (([(ViewId, Maybe TrackSelection)] -> CmdT Identity ())
-> [(ViewId, Maybe TrackSelection)] -> CmdT Identity ()
forall a b. (a -> b) -> a -> b
$ [(ViewId, Maybe TrackSelection)]
sel_tracks) [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()]
hooks


-- ** sync

sync_edit_state :: Cmd.M m => SaveStatus -> Cmd.EditState -> m ()
sync_edit_state :: forall (m :: * -> *). M m => SaveStatus -> EditState -> m ()
sync_edit_state SaveStatus
save_status EditState
st = do
    SaveStatus -> EditState -> m ()
forall (m :: * -> *). M m => SaveStatus -> EditState -> m ()
sync_edit_box SaveStatus
save_status EditState
st
    EditState -> m ()
forall (m :: * -> *). M m => EditState -> m ()
sync_step_status EditState
st
    EditState -> m ()
forall (m :: * -> *). M m => EditState -> m ()
sync_octave_status EditState
st
    RecordedActions -> m ()
forall (m :: * -> *). M m => RecordedActions -> m ()
sync_recorded_actions (EditState -> RecordedActions
Cmd.state_recorded_actions EditState
st)
    Map Instrument Attributes -> m ()
forall (m :: * -> *). M m => Map Instrument Attributes -> m ()
sync_instrument_attributes (EditState -> Map Instrument Attributes
Cmd.state_instrument_attributes EditState
st)

-- | The two upper boxes reflect the edit state.  The lower box is red for
-- 'Cmd.ValEdit' or dark red for 'Cmd.MethodEdit'.  The upper box is green
-- for 'Cmd.state_advance' mode, and red otherwise.
--
-- The lower box has a @K@ if 'Cmd.state_kbd_entry' mode is enabled, and the
-- upper box has an @o@ if 'Cmd.state_chord' mode is enabled.  The upper box
-- also has a @\/@ if the score state hasn't been saved to disk, or @x@ if
-- it can't save to disk because there is no save file.
sync_edit_box :: Cmd.M m => SaveStatus -> Cmd.EditState -> m ()
sync_edit_box :: forall (m :: * -> *). M m => SaveStatus -> EditState -> m ()
sync_edit_box SaveStatus
save_status EditState
st = do
    let mode :: EditMode
mode = EditState -> EditMode
Cmd.state_edit_mode EditState
st
    let skel :: Box
skel = Color -> Char -> Box
Block.Box (EditMode -> Bool -> Color
skel_color EditMode
mode (EditState -> Bool
Cmd.state_advance EditState
st)) (Char -> Box) -> Char -> Box
forall a b. (a -> b) -> a -> b
$
            (if EditState -> Bool
Cmd.state_chord EditState
st then (Char, Char) -> Char
forall a b. (a, b) -> b
snd else (Char, Char) -> Char
forall a b. (a, b) -> a
fst) ((Char, Char) -> Char) -> (Char, Char) -> Char
forall a b. (a -> b) -> a -> b
$ case SaveStatus
save_status of
                -- Behold my cutesy attempt to fit in both bits of info.
                SaveStatus
CantSave -> (Char
'x', Char
'⊗')
                SaveStatus
Unsaved ->  (Char
'/', Char
'ø')
                SaveStatus
Saved ->    (Char
' ', Char
'o')
        track :: Box
track = Color -> Char -> Box
Block.Box (EditMode -> Color
edit_color EditMode
mode)
            (if EditState -> Bool
Cmd.state_kbd_entry EditState
st then Char
'K' else Char
' ')
    (TrackNum, Text) -> Maybe Text -> m ()
forall (m :: * -> *). M m => (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_status (TrackNum, Text)
Config.status_record (Maybe Text -> m ()) -> Maybe Text -> m ()
forall a b. (a -> b) -> a -> b
$
        if EditState -> Bool
Cmd.state_record_velocity EditState
st then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"vel" else Maybe Text
forall a. Maybe a
Nothing
    Box -> Box -> m ()
forall (m :: * -> *). M m => Box -> Box -> m ()
Cmd.set_edit_box Box
skel Box
track

data SaveStatus = CantSave | Unsaved | Saved deriving (SaveStatus -> SaveStatus -> Bool
(SaveStatus -> SaveStatus -> Bool)
-> (SaveStatus -> SaveStatus -> Bool) -> Eq SaveStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SaveStatus -> SaveStatus -> Bool
$c/= :: SaveStatus -> SaveStatus -> Bool
== :: SaveStatus -> SaveStatus -> Bool
$c== :: SaveStatus -> SaveStatus -> Bool
Eq, TrackNum -> SaveStatus -> ShowS
[SaveStatus] -> ShowS
SaveStatus -> FilePath
(TrackNum -> SaveStatus -> ShowS)
-> (SaveStatus -> FilePath)
-> ([SaveStatus] -> ShowS)
-> Show SaveStatus
forall a.
(TrackNum -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SaveStatus] -> ShowS
$cshowList :: [SaveStatus] -> ShowS
show :: SaveStatus -> FilePath
$cshow :: SaveStatus -> FilePath
showsPrec :: TrackNum -> SaveStatus -> ShowS
$cshowsPrec :: TrackNum -> SaveStatus -> ShowS
Show)

get_save_status :: Cmd.State -> SaveStatus
get_save_status :: State -> SaveStatus
get_save_status State
state = case State -> Maybe (Writable, SaveFile)
Cmd.state_save_file State
state of
    Maybe (Writable, SaveFile)
Nothing -> SaveStatus
CantSave
    Just (Writable
Cmd.ReadOnly, SaveFile
_) -> SaveStatus
CantSave
    Just (Writable
Cmd.ReadWrite, SaveFile
_)
        | Bool
editor_open Bool -> Bool -> Bool
|| SavedState
saved_state SavedState -> SavedState -> Bool
forall a. Eq a => a -> a -> Bool
/= SavedState
Cmd.SavedChanges -> SaveStatus
Unsaved
        | Bool
otherwise -> SaveStatus
Saved
        where Cmd.Saved SavedState
saved_state Bool
editor_open = State -> Saved
Cmd.state_saved State
state

skel_color :: Cmd.EditMode -> Bool -> Color.Color
skel_color :: EditMode -> Bool -> Color
skel_color EditMode
Cmd.NoEdit Bool
_ = EditMode -> Color
edit_color EditMode
Cmd.NoEdit
skel_color EditMode
_ Bool
advance
    -- Advance mode is only relevent for ValEdit.
    | Bool
advance = Color
Config.advance_color
    | Bool
otherwise = Color
Config.no_advance_color

edit_color :: Cmd.EditMode -> Color.Color
edit_color :: EditMode -> Color
edit_color EditMode
mode = case EditMode
mode of
    EditMode
Cmd.NoEdit -> Color
Config.box_color
    EditMode
Cmd.ValEdit -> Color
Config.val_edit_color
    EditMode
Cmd.MethodEdit -> Color
Config.method_edit_color

sync_step_status :: Cmd.M m => Cmd.EditState -> m ()
sync_step_status :: forall (m :: * -> *). M m => EditState -> m ()
sync_step_status EditState
st = do
    let step_status :: Text
step_status = TimeStep -> Text
TimeStep.show_time_step (EditState -> TimeStep
Cmd.state_time_step EditState
st)
        dur_status :: Text
dur_status =
            Text
orient Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TimeStep -> Text
TimeStep.show_time_step (EditState -> TimeStep
Cmd.state_note_duration EditState
st)
        orient :: Text
orient = case EditState -> Orientation
Cmd.state_note_orientation EditState
st of
            Orientation
Types.Positive -> Text
"+"
            Orientation
Types.Negative -> Text
"-"
    (TrackNum, Text) -> Maybe Text -> m ()
forall (m :: * -> *). M m => (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_status (TrackNum, Text)
Config.status_step (Maybe Text -> m ()) -> Maybe Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
step_status Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dur_status

sync_octave_status :: Cmd.M m => Cmd.EditState -> m ()
sync_octave_status :: forall (m :: * -> *). M m => EditState -> m ()
sync_octave_status EditState
st = do
    let octave :: TrackNum
octave = EditState -> TrackNum
Cmd.state_kbd_entry_octave EditState
st
    -- This is technically global state and doesn't belong in the block's
    -- status line, but I'm used to looking for it there, so put it in both
    -- places.
    (TrackNum, Text) -> Maybe Text -> m ()
forall (m :: * -> *). M m => (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_status (TrackNum, Text)
Config.status_octave (Text -> Maybe Text
forall a. a -> Maybe a
Just (TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
octave))

sync_recorded_actions :: Cmd.M m => Cmd.RecordedActions -> m ()
sync_recorded_actions :: forall (m :: * -> *). M m => RecordedActions -> m ()
sync_recorded_actions RecordedActions
actions = Text -> Text -> m ()
forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"rec" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text -> [Text] -> Text
Text.intercalate Text
", " [Char -> Text
Text.singleton Char
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Action -> Text
forall a. Pretty a => a -> Text
pretty Action
act |
        (Char
i, Action
act) <- RecordedActions -> [(Char, Action)]
forall k a. Map k a -> [(k, a)]
Map.toAscList RecordedActions
actions]

sync_instrument_attributes :: Cmd.M m =>
    Map ScoreT.Instrument Attrs.Attributes -> m ()
sync_instrument_attributes :: forall (m :: * -> *). M m => Map Instrument Attributes -> m ()
sync_instrument_attributes Map Instrument Attributes
inst_attrs =
    Text -> Text -> m ()
forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"attrs" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords
        [ Instrument -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Instrument
inst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Attributes -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
attrs
        | (Instrument
inst, Attributes
attrs) <- Map Instrument Attributes -> [(Instrument, Attributes)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Instrument Attributes
inst_attrs
        ]

sync_play_state :: Cmd.M m => Cmd.PlayState -> m ()
sync_play_state :: forall (m :: * -> *). M m => PlayState -> m ()
sync_play_state PlayState
st = do
    Text -> Text -> m ()
forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"play-step" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        TimeStep -> Text
TimeStep.show_time_step (PlayState -> TimeStep
Cmd.state_play_step PlayState
st)
    Text -> Text -> m ()
forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"play-mult" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        RealTime -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val (PlayState -> RealTime
Cmd.state_play_multiplier PlayState
st)

sync_save_file :: Cmd.M m => FilePath -> Maybe Cmd.Writable -> m ()
sync_save_file :: forall (m :: * -> *). M m => FilePath -> Maybe Writable -> m ()
sync_save_file FilePath
score_path Maybe Writable
writable =
    Text -> Text -> m ()
forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"save" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ case Maybe Writable
writable of
        Maybe Writable
Nothing -> Text
""
        Just Writable
Cmd.ReadWrite -> FilePath -> Text
txt FilePath
score_path
        Just Writable
Cmd.ReadOnly -> FilePath -> Text
txt FilePath
score_path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (ro)"

sync_defaults :: Cmd.M m => UiConfig.Default -> m ()
sync_defaults :: forall (m :: * -> *). M m => Default -> m ()
sync_defaults (UiConfig.Default Double
tempo) =
    Text -> Text -> m ()
forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"tempo" (if Double
tempo Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
1 then Text
"" else Double -> Text
forall a. Pretty a => a -> Text
pretty Double
tempo)

-- Zoom is actually not very useful, so this is disabled for now.  I'll leave
-- it here and the callers in place instead of deleting them so if I change my
-- mind then I still know where all the callers should be.
sync_zoom_status :: Cmd.M m => ViewId -> m ()
sync_zoom_status :: forall (m :: * -> *). M m => ViewId -> m ()
sync_zoom_status ViewId
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
-- sync_zoom_status view_id = do
--     view <- Ui.get_view view_id
--     Cmd.set_view_status view_id Config.status_zoom
--         (Just (pretty (Block.view_zoom view)))

-- * selection

sync_selection_status :: Cmd.M m => ViewId -> Maybe Cmd.TrackSelection -> m ()
sync_selection_status :: forall (m :: * -> *). M m => ViewId -> Maybe TrackSelection -> m ()
sync_selection_status ViewId
view_id = \case
    Maybe TrackSelection
Nothing -> do
        (TrackNum, Text) -> Maybe Text -> m ()
set (TrackNum, Text)
Config.status_selection Maybe Text
forall a. Maybe a
Nothing
        (TrackNum, Text) -> Maybe Text -> m ()
set (TrackNum, Text)
Config.status_track_id Maybe Text
forall a. Maybe a
Nothing
    Just (Selection
sel, BlockId
block_id, Maybe TrackId
maybe_track_id) -> do
        Namespace
ns <- m Namespace
forall (m :: * -> *). M m => m Namespace
Ui.get_namespace
        Maybe RealTime
start_secs <- BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
forall {m :: * -> *}.
M m =>
BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
realtime BlockId
block_id Maybe TrackId
maybe_track_id (ScoreTime -> m (Maybe RealTime))
-> ScoreTime -> m (Maybe RealTime)
forall a b. (a -> b) -> a -> b
$ Selection -> ScoreTime
Sel.min Selection
sel
        Maybe RealTime
end_secs <- BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
forall {m :: * -> *}.
M m =>
BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
realtime BlockId
block_id Maybe TrackId
maybe_track_id (ScoreTime -> m (Maybe RealTime))
-> ScoreTime -> m (Maybe RealTime)
forall a b. (a -> b) -> a -> b
$ Selection -> ScoreTime
Sel.max Selection
sel
        (TrackNum, Text) -> Maybe Text -> m ()
set (TrackNum, Text)
Config.status_selection (Maybe Text -> m ()) -> Maybe Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Selection -> Maybe RealTime -> Maybe RealTime -> Text
selection_status Selection
sel Maybe RealTime
start_secs Maybe RealTime
end_secs
        (TrackNum, Text) -> Maybe Text -> m ()
set (TrackNum, Text)
Config.status_track_id (Maybe Text -> m ()) -> Maybe Text -> m ()
forall a b. (a -> b) -> a -> b
$
            Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Namespace -> Selection -> Maybe TrackId -> Text
track_selection_status Namespace
ns Selection
sel Maybe TrackId
maybe_track_id
        -- This didn't seem too useful, but maybe I'll change my mind?
        -- Info.set_instrument_status block_id (Sel.cur_track sel)
    where
    set :: (TrackNum, Text) -> Maybe Text -> m ()
set = ViewId -> (TrackNum, Text) -> Maybe Text -> m ()
forall (m :: * -> *).
M m =>
ViewId -> (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_view_status ViewId
view_id
    realtime :: BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
realtime BlockId
block_id Maybe TrackId
maybe_track_id ScoreTime
t = m (Maybe Performance)
-> (Performance -> m (Maybe RealTime)) -> m (Maybe RealTime)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm m (Maybe Performance)
forall (m :: * -> *). M m => m (Maybe Performance)
Perf.lookup_root ((Performance -> m (Maybe RealTime)) -> m (Maybe RealTime))
-> (Performance -> m (Maybe RealTime)) -> m (Maybe RealTime)
forall a b. (a -> b) -> a -> b
$ \Performance
perf ->
        Performance
-> BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
forall (m :: * -> *).
M m =>
Performance
-> BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
Perf.lookup_realtime Performance
perf BlockId
block_id Maybe TrackId
maybe_track_id ScoreTime
t

selection_status :: Sel.Selection -> Maybe RealTime -> Maybe RealTime -> Text
selection_status :: Selection -> Maybe RealTime -> Maybe RealTime -> Text
selection_status Selection
sel Maybe RealTime
start_secs Maybe RealTime
end_secs =
    (ScoreTime -> Text) -> ScoreTime -> ScoreTime -> Text
forall a. (Eq a, Num a) => (a -> Text) -> a -> a -> Text
show_range ScoreTime -> Text
show_score (Selection -> ScoreTime
Sel.min Selection
sel) (Selection -> ScoreTime
Sel.max Selection
sel) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"t"
    Text -> Text -> Text
forall a. Textlike a => a -> a -> a
`Texts.unwords2` case Maybe RealTime -> Maybe RealTime -> Maybe (RealTime, RealTime)
forall {b}. Maybe b -> Maybe b -> Maybe (b, b)
get Maybe RealTime
start_secs Maybe RealTime
end_secs of
        Just (RealTime
start, RealTime
end) -> (RealTime -> Text) -> RealTime -> RealTime -> Text
forall a. (Eq a, Num a) => (a -> Text) -> a -> a -> Text
show_range RealTime -> Text
show_real RealTime
start RealTime
end Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"s"
        Maybe (RealTime, RealTime)
Nothing -> Text
""
    where
    get :: Maybe b -> Maybe b -> Maybe (b, b)
get (Just b
a) (Just b
b) = (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
a, b
b)
    get (Just b
a) Maybe b
Nothing = (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
a, b
a)
    get Maybe b
Nothing (Just b
b) = (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
b, b
b)
    get Maybe b
Nothing Maybe b
Nothing = Maybe (b, b)
forall a. Maybe a
Nothing
    -- ScoreTime tends to be low numbers and have fractions.  RealTime is
    -- just seconds though, so unless there's a unicode fraction, just use
    -- decimal notation.
    show_score :: ScoreTime -> Text
show_score = Bool -> Double -> Text
forall a. (RealFrac a, Pretty a) => Bool -> a -> Text
Pretty.fraction Bool
True (Double -> Text) -> (ScoreTime -> Double) -> ScoreTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Double
ScoreTime.to_double
    show_real :: RealTime -> Text
show_real = Bool -> Double -> Text
forall a. (RealFrac a, Pretty a) => Bool -> a -> Text
Pretty.fraction Bool
False (Double -> Text) -> (RealTime -> Double) -> RealTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Double
RealTime.to_seconds

show_range :: (Eq a, Num a) => (a -> Text) -> a -> a -> Text
show_range :: forall a. (Eq a, Num a) => (a -> Text) -> a -> a -> Text
show_range a -> Text
fmt a
start a
end = a -> Text
fmt a
start
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if a
start a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
end then Text
"" else Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
fmt a
end
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
fmt (a
end a -> a -> a
forall a. Num a => a -> a -> a
- a
start) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

track_selection_status :: Id.Namespace -> Sel.Selection -> Maybe TrackId -> Text
track_selection_status :: Namespace -> Selection -> Maybe TrackId -> Text
track_selection_status Namespace
ns Selection
sel Maybe TrackId
maybe_track_id =
    [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)
        [ TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
tstart
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if TrackNum
tstart TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
== TrackNum
tend then Text
"" else Char -> Text -> Text
Text.cons Char
'-' (TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
tend))
        , Text -> (TrackId -> Text) -> Maybe TrackId -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Namespace -> Id -> Text
Id.show_short Namespace
ns (Id -> Text) -> (TrackId -> Id) -> TrackId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackId -> Id
forall a. Ident a => a -> Id
Id.unpack_id) Maybe TrackId
maybe_track_id
        ]
    where (TrackNum
tstart, TrackNum
tend) = Selection -> (TrackNum, TrackNum)
Sel.track_range Selection
sel

-- ** selection control value

sync_selection_control :: Cmd.M m => ViewId -> Maybe Cmd.TrackSelection -> m ()
sync_selection_control :: forall (m :: * -> *). M m => ViewId -> Maybe TrackSelection -> m ()
sync_selection_control ViewId
view_id (Just (Selection
sel, BlockId
block_id, Just TrackId
track_id)) = do
    Maybe Text
status <- BlockId -> TrackId -> ScoreTime -> m (Maybe Text)
forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m (Maybe Text)
track_control BlockId
block_id TrackId
track_id (Selection -> ScoreTime
Selection.sel_point Selection
sel)
    ViewId -> (TrackNum, Text) -> Maybe Text -> m ()
forall (m :: * -> *).
M m =>
ViewId -> (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_view_status ViewId
view_id (TrackNum, Text)
Config.status_control (Maybe Text -> m ()) -> Maybe Text -> m ()
forall a b. (a -> b) -> a -> b
$ (Text
"c"<>) (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
status
sync_selection_control ViewId
view_id Maybe TrackSelection
_ =
    ViewId -> (TrackNum, Text) -> Maybe Text -> m ()
forall (m :: * -> *).
M m =>
ViewId -> (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_view_status ViewId
view_id (TrackNum, Text)
Config.status_control Maybe Text
forall a. Maybe a
Nothing

-- | This uses 'Cmd.perf_track_signals' rather than 'Cmd.perf_track_dynamic'
-- because track dynamics have the callers controls on a control track
track_control :: Cmd.M m => BlockId -> TrackId -> ScoreTime -> m (Maybe Text)
track_control :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreTime -> m (Maybe Text)
track_control BlockId
block_id TrackId
track_id ScoreTime
pos =
    m (Maybe ControlType)
-> (ControlType -> m (Maybe Text)) -> m (Maybe Text)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (Text -> Maybe ControlType
parse_title (Text -> Maybe ControlType) -> m Text -> m (Maybe ControlType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackId -> m Text
forall (m :: * -> *). M m => TrackId -> m Text
Ui.get_track_title TrackId
track_id) ((ControlType -> m (Maybe Text)) -> m (Maybe Text))
-> (ControlType -> m (Maybe Text)) -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ \ControlType
ctype ->
    case ControlType
ctype of
        -- Since I'm using TrackSignals, I just have numbers, not proper
        -- pitches.  So I could show pitches, but it would just be an NN,
        -- which doesn't seem that useful.
        ParseTitle.Pitch {} -> Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
        ControlType
_ -> m (Maybe Performance)
-> (Performance -> m (Maybe Text)) -> m (Maybe Text)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (BlockId -> m (Maybe Performance)
forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
Cmd.lookup_performance BlockId
block_id) ((Performance -> m (Maybe Text)) -> m (Maybe Text))
-> (Performance -> m (Maybe Text)) -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ \Performance
perf -> Maybe Text -> m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> m (Maybe Text)) -> Maybe Text -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
            TrackSignal
tsig <- (BlockId, TrackId)
-> Map (BlockId, TrackId) TrackSignal -> Maybe TrackSignal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (BlockId
block_id, TrackId
track_id)
                (Performance -> Map (BlockId, TrackId) TrackSignal
Cmd.perf_track_signals Performance
perf)
            Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ControlType -> Signal DisplaySig -> Double -> Text
forall {k} {kind :: k}.
ControlType -> Signal kind -> Double -> Text
show_val ControlType
ctype (TrackSignal -> Signal DisplaySig
Track.ts_signal TrackSignal
tsig) (Double -> Text) -> Double -> Text
forall a b. (a -> b) -> a -> b
$
                ScoreTime -> TrackSignal -> Double
Track.signal_at ScoreTime
pos TrackSignal
tsig
    where
    parse_title :: Text -> Maybe ControlType
parse_title = (Text -> Maybe ControlType)
-> (ControlType -> Maybe ControlType)
-> Either Text ControlType
-> Maybe ControlType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ControlType -> Text -> Maybe ControlType
forall a b. a -> b -> a
const Maybe ControlType
forall a. Maybe a
Nothing) ControlType -> Maybe ControlType
forall a. a -> Maybe a
Just (Either Text ControlType -> Maybe ControlType)
-> (Text -> Either Text ControlType) -> Text -> Maybe ControlType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text ControlType
ParseTitle.parse_control_type
    show_val :: ControlType -> Signal kind -> Double -> Text
show_val ControlType
ctype Signal kind
sig = case ControlType
ctype of
        ParseTitle.Tempo {} -> Double -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val
        ControlType
_
            | Signal kind -> Double
forall {k} (kind :: k). Signal kind -> Double
Signal.minimum Signal kind
sig Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< -Double
1 Bool -> Bool -> Bool
|| Signal kind -> Double
forall {k} (kind :: k). Signal kind -> Double
Signal.maximum Signal kind
sig Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1 ->
                Double -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val
            | Bool
otherwise -> Double -> Text
ShowVal.show_hex_val