-- 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.Text as Text

import qualified Util.GitT as GitT
import qualified Util.Lists as Lists
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.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 = forall {a}. m a -> m Status
cont forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Msg -> Maybe (Bool, Maybe Modifier)
msg_to_mod Msg
msg) forall a b. (a -> b) -> a -> b
$ \(Bool
down, Maybe Modifier
mb_mod) -> do
    Map Modifier Modifier
mods <- 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) -> forall {m :: * -> *}.
LogMonad m =>
Modifier -> Map Modifier Modifier -> m (Map Modifier Modifier)
insert Modifier
mod Map Modifier Modifier
mods2
        (Bool
False, Just Modifier
mod) -> forall {m :: * -> *} {a}.
LogMonad m =>
Modifier -> Map Modifier a -> m (Map Modifier a)
delete Modifier
mod Map Modifier Modifier
mods2
        (Bool, Maybe 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)
    forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify 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 = (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Modifier
key forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Modifier Modifier
mods) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"keydown for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Modifier
mod forall a. Semigroup a => a -> a -> a
<> Text
" already in modifiers"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Modifier
key forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Modifier a
mods) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"keyup for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Modifier
key forall a. Semigroup a => a -> a -> a
<> Text
" not in modifiers "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall k a. Map k a -> [k]
Map.keys Map Modifier a
mods)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 -> 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]
            (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
_ -> forall a. a -> Maybe a
Just [Modifier]
mods
        UiMsg.Mouse (UiMsg.MouseEvent { mouse_modifiers :: MouseEvent -> [Modifier]
UiMsg.mouse_modifiers = [Modifier]
mods }) ->
            forall a. a -> Maybe a
Just [Modifier]
mods
        MsgEvent
_ -> forall a. Maybe a
Nothing
    Msg
_ -> 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 -> forall a. a -> Maybe a
Just (Bool
True, forall a. Maybe a
Nothing)
            KbdState
UiMsg.KeyUp -> forall a. a -> Maybe a
Just (Bool
False, forall a. Maybe a
Nothing)
            KbdState
_ -> forall a. Maybe a
Nothing
        UiMsg.Mouse (UiMsg.MouseEvent
                { mouse_state :: MouseEvent -> MouseState
UiMsg.mouse_state = UiMsg.MouseDown TrackNum
btn }) ->
            forall a. a -> Maybe a
Just (Bool
True, forall a. a -> Maybe a
Just 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 }) ->
            forall a. a -> Maybe a
Just (Bool
False, forall a. a -> Maybe a
Just 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
_ -> 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) ->
            forall a. a -> Maybe a
Just (Bool
True, forall a. a -> Maybe a
Just 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) ->
            forall a. a -> Maybe a
Just (Bool
False, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Channel -> Key -> Modifier
Cmd.MidiMod Channel
chan Key
key)
        Message
_ -> forall a. Maybe a
Nothing
    Msg
_ -> 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
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ViewId
view_id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe ViewId
Cmd.state_focused_view) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_focused_view :: Maybe ViewId
Cmd.state_focused_view = forall a. Maybe a
Nothing }
        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
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ViewId
view_id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe ViewId
Cmd.state_focused_view) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_focused_view :: Maybe ViewId
Cmd.state_focused_view = forall a. a -> Maybe a
Just ViewId
view_id }
        forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
record_focus Msg
_ = 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
    forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify 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)
        }
    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 = forall a. TrackNum -> [a] -> [a]
take TrackNum
screens
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> TrackNum -> (Maybe a -> a) -> [a] -> [a]
Lists.updateAt Rect
Rect.empty TrackNum
screen (forall a b. a -> b -> a
const Rect
rect)
cmd_record_ui_updates Msg
msg = do
    (Context
ctx, ViewId
view_id, UiUpdate
update) <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless (Msg -> Maybe (Context, ViewId, UiUpdate)
update_of Msg
msg)
    forall (m :: * -> *).
M m =>
Maybe TrackNum -> ViewId -> UiUpdate -> m ()
ui_update (forall a b. (a, b) -> a
fst 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
    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 -> forall (m :: * -> *). M m => ViewId -> TrackNum -> m ()
Ui.set_track_scroll ViewId
view_id TrackNum
hpos
    UiMsg.UpdateTimeScroll ScoreTime
offset -> forall (m :: * -> *). M m => ViewId -> (Zoom -> Zoom) -> m ()
Ui.modify_zoom ViewId
view_id 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 <- forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rect
rect forall a. Eq a => a -> a -> Bool
/= View -> Rect
Block.view_rect View
view) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => ViewId -> Rect -> m ()
Ui.set_view_rect ViewId
view_id Rect
rect
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (View -> Padding
Block.view_padding View
view forall a. Eq a => a -> a -> Bool
/= Padding
padding) forall a b. (a -> b) -> a -> b
$
            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 <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
            Bool
collapsed <- Set TrackFlag -> Bool
Block.is_collapsed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                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.
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
collapsed forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
Ui.set_track_width BlockId
block_id TrackNum
tracknum TrackNum
width
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TrackNum
suggested_width forall a. Ord a => a -> a -> Bool
> TrackNum
0) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
Ui.set_track_suggested_width BlockId
block_id TrackNum
tracknum TrackNum
suggested_width
        Maybe TrackNum
Nothing -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw forall a b. (a -> b) -> a -> b
$ Text
"update with no track: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt UiUpdate
update
    -- Handled by 'ui_update_state'.
    UiUpdate
UiMsg.UpdateClose -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    UiMsg.UpdateInput {} -> 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) <- 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
            forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
Cmd.modify_edit_state forall a b. (a -> b) -> a -> b
$ \EditState
st -> EditState
st
                { state_floating_input :: Bool
Cmd.state_floating_input = Bool
False }
            forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
        else do
            forall (m :: * -> *).
M m =>
Maybe TrackNum -> ViewId -> UiUpdate -> m ()
ui_update_state (forall a b. (a, b) -> a
fst 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
            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 <- forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
        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 -> forall (m :: * -> *). M m => ViewId -> m ()
Ui.destroy_view ViewId
view_id
    UiUpdate
_ -> 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 <- 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 -> forall (m :: * -> *). M m => TrackId -> Text -> m ()
Ui.set_track_title TrackId
track_id Text
text
                Maybe TrackId
Nothing -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showt (Maybe Text -> UiUpdate
UiMsg.UpdateInput (forall a. a -> Maybe a
Just Text
text))
                    forall a. Semigroup a => a -> a -> a
<> Text
" on non-event track " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
tracknum
        Maybe TrackNum
Nothing -> 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))) =
    forall a. a -> Maybe a
Just (Context
ctx, ViewId
view_id, UiUpdate
update)
update_of Msg
_ = 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 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
        | forall a. Maybe a -> Bool
Maybe.isNothing (Event -> Maybe Stack
Event.stack Event
event) = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a.
Map BlockId a
-> Namespace -> Maybe BlockId -> Text -> Maybe BlockId
NoteTrackParse.to_block_id Map BlockId a
blocks Namespace
namespace (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 <- forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify 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 <- forall (m :: * -> *). M m => m State
Cmd.get
    let updates :: [UiUpdate]
updates = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ DiffM () -> ([UiUpdate], [DisplayUpdate])
Diff.run 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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ViewId]
new_views) Bool -> Bool -> Bool
|| State -> EditState
Cmd.state_edit State
cmd_from forall a. Eq a => a -> a -> Bool
/= EditState
edit_state
            Bool -> Bool -> Bool
|| State -> Saved
Cmd.state_saved State
cmd_from forall a. Eq a => a -> a -> Bool
/= State -> Saved
Cmd.state_saved State
cmd_to) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => SaveStatus -> EditState -> m ()
sync_edit_state (State -> SaveStatus
get_save_status State
cmd_to) EditState
edit_state
    forall (m :: * -> *). M m => PlayState -> m ()
sync_play_state forall a b. (a -> b) -> a -> b
$ State -> PlayState
Cmd.state_play State
cmd_to
    forall (m :: * -> *). M m => FilePath -> Maybe Writable -> m ()
sync_save_file (State -> FilePath
Cmd.score_path State
cmd_to) (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State -> Maybe (Writable, SaveFile)
Cmd.state_save_file State
cmd_to)
    forall (m :: * -> *). M m => Default -> m ()
sync_defaults forall a b. (a -> b) -> a -> b
$ Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Default
UiConfig.default_ forall f a. Lens f a -> f -> a
#$ State
ui_to
    [(ViewId, Maybe Selection)] -> CmdT Identity ()
run_selection_hooks (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {t} {u}. Update t u -> Maybe (ViewId, Maybe Selection)
selection_update [UiUpdate]
updates)
    -- forM_ (new_views ++ mapMaybe zoom_update updates) sync_zoom_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) = forall a. a -> Maybe a
Just ViewId
view_id
    is_create_view Update t u
_ = 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 forall a. Eq a => a -> a -> Bool
== TrackNum
Config.insert_selnum = forall a. a -> Maybe a
Just (ViewId
view_id, Maybe Selection
sel)
    selection_update Update t u
_ = 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
        | 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) ->
        forall a. a -> Maybe a
Just (Canonical
repo, Commit
commit)
    (Maybe (Writable, SaveFile), Maybe Commit)
_ -> forall a. Maybe a
Nothing
    where
    prev :: Maybe Commit
prev = HistoryConfig -> Maybe Commit
Cmd.hist_last_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 =
    [ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *). M m => ViewId -> Maybe TrackSelection -> m ()
sync_selection_status)
    , forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
run_selection_hooks [(ViewId, Maybe Selection)]
sels = do
    [(ViewId, Maybe TrackSelection)]
sel_tracks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ViewId, Maybe Selection)]
sels forall a b. (a -> b) -> a -> b
$ \(ViewId
view_id, Maybe Selection
maybe_sel) -> case Maybe Selection
maybe_sel of
        Maybe Selection
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (ViewId
view_id, forall a. Maybe a
Nothing)
        Just Selection
sel -> do
            BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
            Maybe TrackId
maybe_track_id <- forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id
                (Selection -> TrackNum
Selection.sel_point_track Selection
sel)
            forall (m :: * -> *) a. Monad m => a -> m a
return (ViewId
view_id, forall a. a -> Maybe a
Just (Selection
sel, BlockId
block_id, Maybe TrackId
maybe_track_id))
    [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()]
hooks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets (Hooks -> [[(ViewId, Maybe TrackSelection)] -> CmdT Identity ()]
Cmd.hooks_selection forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Hooks
Cmd.state_hooks)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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
    forall (m :: * -> *). M m => SaveStatus -> EditState -> m ()
sync_edit_box SaveStatus
save_status EditState
st
    forall (m :: * -> *). M m => EditState -> m ()
sync_step_status EditState
st
    forall (m :: * -> *). M m => EditState -> m ()
sync_octave_status EditState
st
    forall (m :: * -> *). M m => RecordedActions -> m ()
sync_recorded_actions (EditState -> RecordedActions
Cmd.state_recorded_actions EditState
st)
    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)) forall a b. (a -> b) -> a -> b
$
            (if EditState -> Bool
Cmd.state_chord EditState
st then forall a b. (a, b) -> b
snd else forall a b. (a, b) -> a
fst) 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
' ')
    forall (m :: * -> *). M m => (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_status (TrackNum, Text)
Config.status_record forall a b. (a -> b) -> a -> b
$
        if EditState -> Bool
Cmd.state_record_velocity EditState
st then forall a. a -> Maybe a
Just Text
"vel" else forall a. Maybe a
Nothing
    forall (m :: * -> *). M m => Box -> Box -> m ()
Cmd.set_edit_box Box
skel Box
track

data SaveStatus = CantSave | Unsaved | Saved deriving (SaveStatus -> SaveStatus -> Bool
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
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 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 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
"-"
    forall (m :: * -> *). M m => (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_status (TrackNum, Text)
Config.status_step forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
step_status 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.
    forall (m :: * -> *). M m => (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_status (TrackNum, Text)
Config.status_octave (forall a. a -> Maybe a
Just (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 = forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"rec" forall a b. (a -> b) -> a -> b
$
    Text -> [Text] -> Text
Text.intercalate Text
", " [Char -> Text
Text.singleton Char
i forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Action
act |
        (Char
i, Action
act) <- 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 =
    forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"attrs" forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords
        [ forall a. ShowVal a => a -> Text
ShowVal.show_val Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
attrs
        | (Instrument
inst, Attributes
attrs) <- 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
    forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"play-step" forall a b. (a -> b) -> a -> b
$
        TimeStep -> Text
TimeStep.show_time_step (PlayState -> TimeStep
Cmd.state_play_step PlayState
st)
    forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"play-mult" forall a b. (a -> b) -> a -> b
$
        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 =
    forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"save" 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 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) =
    forall (m :: * -> *). M m => Text -> Text -> m ()
Cmd.set_global_status Text
"tempo" (if Double
tempo forall a. Eq a => a -> a -> Bool
== Double
1 then Text
"" else 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
_ = 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 forall a. Maybe a
Nothing
        (TrackNum, Text) -> Maybe Text -> m ()
set (TrackNum, Text)
Config.status_track_id forall a. Maybe a
Nothing
    Just (Selection
sel, BlockId
block_id, Maybe TrackId
maybe_track_id) -> do
        Namespace
ns <- forall (m :: * -> *). M m => m Namespace
Ui.get_namespace
        Maybe RealTime
start_secs <- forall {m :: * -> *}.
M m =>
BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
realtime BlockId
block_id Maybe TrackId
maybe_track_id forall a b. (a -> b) -> a -> b
$ Selection -> ScoreTime
Sel.min Selection
sel
        Maybe RealTime
end_secs <- forall {m :: * -> *}.
M m =>
BlockId -> Maybe TrackId -> ScoreTime -> m (Maybe RealTime)
realtime BlockId
block_id Maybe TrackId
maybe_track_id forall a b. (a -> b) -> a -> b
$ Selection -> ScoreTime
Sel.max Selection
sel
        (TrackNum, Text) -> Maybe Text -> m ()
set (TrackNum, Text)
Config.status_selection forall a b. (a -> b) -> a -> b
$
            forall a. a -> Maybe a
Just 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 forall a b. (a -> b) -> a -> b
$
            forall a. a -> Maybe a
Just 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 = 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 = forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm forall (m :: * -> *). M m => m (Maybe Performance)
Perf.lookup_root forall a b. (a -> b) -> a -> b
$ \Performance
perf ->
        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 =
    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) forall a. Semigroup a => a -> a -> a
<> Text
"t"
    forall a. Textlike a => a -> a -> a
`Texts.unwords2` case forall {b}. Maybe b -> Maybe b -> Maybe (b, b)
get Maybe RealTime
start_secs Maybe RealTime
end_secs of
        Just (RealTime
start, RealTime
end) -> forall a. (Eq a, Num a) => (a -> Text) -> a -> a -> Text
show_range RealTime -> Text
show_real RealTime
start RealTime
end 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) = forall a. a -> Maybe a
Just (b
a, b
b)
    get (Just b
a) Maybe b
Nothing = forall a. a -> Maybe a
Just (b
a, b
a)
    get Maybe b
Nothing (Just b
b) = forall a. a -> Maybe a
Just (b
b, b
b)
    get Maybe b
Nothing Maybe b
Nothing = 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 = forall a. (RealFrac a, Pretty a) => Bool -> a -> Text
Pretty.fraction Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Double
ScoreTime.to_double
    show_real :: RealTime -> Text
show_real = forall a. (RealFrac a, Pretty a) => Bool -> a -> Text
Pretty.fraction Bool
False 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
    forall a. Semigroup a => a -> a -> a
<> if a
start forall a. Eq a => a -> a -> Bool
== a
end then Text
"" else Text
"-" forall a. Semigroup a => a -> a -> a
<> a -> Text
fmt a
end
    forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> a -> Text
fmt (a
end forall a. Num a => a -> a -> a
- a
start) 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 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
        [ forall a. Show a => a -> Text
showt TrackNum
tstart
            forall a. Semigroup a => a -> a -> a
<> (if TrackNum
tstart forall a. Eq a => a -> a -> Bool
== TrackNum
tend then Text
"" else Char -> Text -> Text
Text.cons Char
'-' (forall a. Show a => a -> Text
showt TrackNum
tend))
        , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Namespace -> Id -> Text
Id.show_short Namespace
ns forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- 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)
    forall (m :: * -> *).
M m =>
ViewId -> (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_view_status ViewId
view_id (TrackNum, Text)
Config.status_control forall a b. (a -> b) -> a -> b
$ (Text
"c"<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
status
sync_selection_control ViewId
view_id Maybe TrackSelection
_ =
    forall (m :: * -> *).
M m =>
ViewId -> (TrackNum, Text) -> Maybe Text -> m ()
Cmd.set_view_status ViewId
view_id (TrackNum, Text)
Config.status_control 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 =
    forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (Text -> Maybe ControlType
parse_title 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) 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 {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        ControlType
_ -> forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
Cmd.lookup_performance BlockId
block_id) forall a b. (a -> b) -> a -> b
$ \Performance
perf -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
            TrackSignal
tsig <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (BlockId
block_id, TrackId
track_id)
                (Performance -> TrackSignals
Cmd.perf_track_signals Performance
perf)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {k} {kind :: k}.
ControlType -> Signal kind -> Double -> Text
show_val ControlType
ctype (TrackSignal -> Display
Track.ts_signal TrackSignal
tsig) 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just 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 {} -> forall a. ShowVal a => a -> Text
ShowVal.show_val
        ControlType
_
            | forall {k} (kind :: k). Signal kind -> Double
Signal.minimum Signal kind
sig forall a. Ord a => a -> a -> Bool
< -Double
1 Bool -> Bool -> Bool
|| forall {k} (kind :: k). Signal kind -> Double
Signal.maximum Signal kind
sig forall a. Ord a => a -> a -> Bool
> Double
1 ->
                forall a. ShowVal a => a -> Text
ShowVal.show_val
            | Bool
otherwise -> Double -> Text
ShowVal.show_hex_val