-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
{- | Take Updates, which are generated by 'Ui.Diff', and send them to the UI.

    The C++ level and BlockC have no notion of "blocks" which may be shared
    between block views.  The haskell State does have this notion, so it's this
    module's job to distribute an operation on a block to all of the C++ block
    views that are displaying that block.

    So if this module has a bug, two views of one block could get out of sync
    and display different data.  Hopefully that won't happen.

    Implementation of merged tracks:

    They need to be implemented in two places: 1. when a block is updated with
    changed merged tracks, and 2. when a track is updated they should be
    preserved.  It's tricky because unlike normal track events, they are block
    level, not track level, so the same track in different blocks may be merged
    with different events.  I don't actually see a lot of use-case for the same
    track in different blocks, but as long as I have it, it makes sense that it
    can have different merges in different blocks, since it's really
    a display-level effect.

    This is a hassle because case 1 has to go hunt down the event info and case
    2 has to go hunt down the per-block info, but such is life.
-}
module Ui.Sync (
    sync
    , set_track_signals
    , set_play_position, clear_play_position
    , set_highlights, clear_highlights
    , set_im_progress, clear_im_progress
    , set_waveforms, clear_waveforms, gc_waveforms
    , floating_input
    -- ** keycaps
    , create_keycaps, destroy_keycaps, update_keycaps
    -- ** debug
    , print_debug
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Trace as Trace

import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Derive.ParseTitle as ParseTitle
import qualified Ui.Block as Block
import qualified Ui.BlockC as BlockC
import qualified Ui.Color as Color
import qualified Ui.Events as Events
import qualified Ui.Fltk as Fltk
import qualified Ui.Id as Id
import qualified Ui.KeycapsC as KeycapsC
import qualified Ui.KeycapsT as KeycapsT
import qualified Ui.PtrMap as PtrMap
import qualified Ui.Sel as Sel
import qualified Ui.Track as Track
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig
import qualified Ui.Update as Update

import           Global
import           Types


-- | Sync with the ui by applying the given updates to it.
--
-- TrackSignals are passed separately instead of going through diff because
-- they're special: they exist in Cmd.State and not in Ui.State.  It's rather
-- unpleasant, but as long as it's only TrackSignals then I can deal with it.
sync :: Fltk.Channel -> Track.TrackSignals -> Track.SetStyleHigh
    -> Ui.State -> [Update.DisplayUpdate] -> IO (Maybe Ui.Error)
sync :: Channel
-> TrackSignals
-> SetStyleHigh
-> State
-> [DisplayUpdate]
-> IO (Maybe Error)
sync Channel
ui_chan TrackSignals
track_signals SetStyleHigh
set_style State
state [DisplayUpdate]
updates = do
    [DisplayUpdate]
updates <- State -> [DisplayUpdate] -> IO [DisplayUpdate]
check_updates State
state forall a b. (a -> b) -> a -> b
$ [DisplayUpdate] -> [DisplayUpdate]
Update.sort [DisplayUpdate]
updates
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync.sort"
    -- Debug.fullM (Debug.putp "sync updates") updates
    case forall a. State -> StateId a -> Either Error (a, State, UiDamage)
Ui.run_id State
state forall a b. (a -> b) -> a -> b
$ TrackSignals
-> SetStyleHigh -> [DisplayUpdate] -> StateId [Fltk ()]
sync_actions TrackSignals
track_signals SetStyleHigh
set_style [DisplayUpdate]
updates of
        Left Error
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Error
err
        -- I reuse Ui.StateT for convenience, but run_update should
        -- not modify the State and hence shouldn't produce any updates.
        -- TODO Try to split StateT into ReadStateT and ReadWriteStateT to
        -- express this in the type?
        Right ([Fltk ()]
actions, State
_, UiDamage
_) -> do
            forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync.sync_actions"
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Fltk ()]
actions) forall a b. (a -> b) -> a -> b
$
                Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
ui_chan (Text
"sync " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [Fltk ()]
actions))
                    (forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Fltk ()]
actions)
            forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync.send"
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Filter out updates that will cause the BlockC level to throw an exception,
-- and log an error instead.  BlockC could log itself, but if BlockC gets a bad
-- update then that indicates a bug in the program, while this is meant to
-- filter out updates that could occur \"normally\".  I'm not sure the
-- distinction is worth it.
check_updates :: Ui.State -> [Update.DisplayUpdate] -> IO [Update.DisplayUpdate]
check_updates :: State -> [DisplayUpdate] -> IO [DisplayUpdate]
check_updates State
state = forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall a b. (a -> b) -> a -> b
$ \DisplayUpdate
update -> case DisplayUpdate
update of
    Update.View ViewId
view_id View
u -> case View
u of
        -- Already destroyed, so I don't expect it to exist.
        View
Update.DestroyView -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        View
_ | ViewId
view_id forall k a. Ord k => k -> Map k a -> Bool
`Map.member` State -> Map ViewId View
Ui.state_views State
state -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        View
_ -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"Update for nonexistent " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt ViewId
view_id forall a. Semigroup a => a -> a -> a
<> Text
": "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty View
u
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    DisplayUpdate
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

sync_actions :: Track.TrackSignals -> Track.SetStyleHigh
    -> [Update.DisplayUpdate] -> Ui.StateId [Fltk.Fltk ()]
sync_actions :: TrackSignals
-> SetStyleHigh -> [DisplayUpdate] -> StateId [Fltk ()]
sync_actions TrackSignals
track_signals SetStyleHigh
set_style [DisplayUpdate]
updates = do
    BlockId -> [ViewId]
views_of <- forall a b. [Update a b] -> State -> BlockId -> [ViewId]
old_views_of [DisplayUpdate]
updates forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM ((BlockId -> [ViewId])
-> TrackSignals
-> SetStyleHigh
-> DisplayUpdate
-> StateId [Fltk ()]
run_update BlockId -> [ViewId]
views_of TrackSignals
track_signals SetStyleHigh
set_style) [DisplayUpdate]
updates

set_track_signals :: Fltk.Channel -> [(ViewId, TrackNum, Track.TrackSignal)]
    -> IO ()
set_track_signals :: Channel -> [(ViewId, TrackNum, TrackSignal)] -> IO ()
set_track_signals Channel
ui_chan [(ViewId, TrackNum, TrackSignal)]
tracks =
    -- Make sure tracks is fully forced, because a hang on the fltk event loop
    -- can be confusing.
    [(ViewId, TrackNum, TrackSignal)]
tracks forall a b. NFData a => a -> b -> b
`DeepSeq.deepseq` Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
ui_chan Text
"set_track_signals" forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(ViewId, TrackNum, TrackSignal)]
tracks forall a b. (a -> b) -> a -> b
$ \(ViewId
view_id, TrackNum
tracknum, TrackSignal
tsig) ->
            ViewId -> TrackNum -> TrackSignal -> Fltk ()
set_track_signal ViewId
view_id TrackNum
tracknum TrackSignal
tsig

set_track_signal :: ViewId -> TrackNum -> Track.TrackSignal -> Fltk.Fltk ()
set_track_signal :: ViewId -> TrackNum -> TrackSignal -> Fltk ()
set_track_signal = ViewId -> TrackNum -> TrackSignal -> Fltk ()
BlockC.set_track_signal

-- | The play position selection bypasses all the usual State -> Diff -> Sync
-- stuff for a direct write to the UI.
--
-- This is because it happens asynchronously and would be noisy and inefficient
-- to work into the responder loop, and isn't part of the usual state that
-- should be saved anyway.
set_play_position :: Fltk.Channel -> [(ViewId, [(TrackNum, ScoreTime)])]
    -> IO ()
set_play_position :: Channel -> [(ViewId, [(TrackNum, ScoreTime)])] -> IO ()
set_play_position Channel
chan [(ViewId, [(TrackNum, ScoreTime)])]
view_sels = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ViewId, [(TrackNum, ScoreTime)])]
view_sels) forall a b. (a -> b) -> a -> b
$
    Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
chan Text
"set_play_position" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ do
        (ViewId
view_id, NonNull [(TrackNum, ScoreTime)]
tracknum_pos) <- forall a b. Ord a => [(a, b)] -> [(a, NonNull b)]
Lists.groupFst [(ViewId, [(TrackNum, ScoreTime)])]
view_sels
        (NonNull TrackNum
tracknums, NonNull ScoreTime
pos) <- forall a b. Ord a => [(a, b)] -> [(a, NonNull b)]
Lists.groupFst forall a b. (a -> b) -> a -> b
$
            forall b a. Ord b => [(a, b)] -> [(NonNull a, b)]
Lists.groupSnd (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat NonNull [(TrackNum, ScoreTime)]
tracknum_pos)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ViewId
-> TrackNum -> Maybe (NonNull TrackNum) -> [Selection] -> Fltk ()
set_selection_carefully ViewId
view_id
            TrackNum
Config.play_position_selnum (forall a. a -> Maybe a
Just NonNull TrackNum
tracknums) (forall a b. (a -> b) -> [a] -> [b]
map ScoreTime -> Selection
sel NonNull ScoreTime
pos)
    where
    sel :: ScoreTime -> Selection
sel ScoreTime
p = BlockC.Selection
        { sel_color :: Color
sel_color = Color
Config.play_selection_color
        , sel_start :: ScoreTime
sel_start = ScoreTime
p
        , sel_cur :: ScoreTime
sel_cur = ScoreTime
p
        , sel_orientation :: SelectionOrientation
sel_orientation = SelectionOrientation
BlockC.Both
        }

clear_play_position :: Fltk.Channel -> [ViewId] -> IO ()
clear_play_position :: Channel -> [ViewId] -> IO ()
clear_play_position = TrackNum -> Channel -> [ViewId] -> IO ()
clear_selections TrackNum
Config.play_position_selnum

-- ** event highlights

type Range = (TrackTime, TrackTime)

set_highlights :: Fltk.Channel -> [((ViewId, TrackNum), (Range, Color.Color))]
    -> IO ()
set_highlights :: Channel -> [((ViewId, TrackNum), (Range, Color))] -> IO ()
set_highlights = TrackNum
-> Channel -> [((ViewId, TrackNum), (Range, Color))] -> IO ()
set_selections TrackNum
Config.highlight_selnum

clear_highlights :: Fltk.Channel -> [ViewId] -> IO ()
clear_highlights :: Channel -> [ViewId] -> IO ()
clear_highlights = TrackNum -> Channel -> [ViewId] -> IO ()
clear_selections TrackNum
Config.highlight_selnum

set_im_progress :: Fltk.Channel -> [((ViewId, TrackNum), (Range, Color.Color))]
    -> IO ()
set_im_progress :: Channel -> [((ViewId, TrackNum), (Range, Color))] -> IO ()
set_im_progress = TrackNum
-> Channel -> [((ViewId, TrackNum), (Range, Color))] -> IO ()
set_selections TrackNum
Config.im_progress_selnum

clear_im_progress :: Fltk.Channel -> [ViewId] -> IO ()
clear_im_progress :: Channel -> [ViewId] -> IO ()
clear_im_progress = TrackNum -> Channel -> [ViewId] -> IO ()
clear_selections TrackNum
Config.im_progress_selnum

-- ** waveform

set_waveforms :: Fltk.Channel
    -> [((ViewId, TrackNum), [Track.WaveformChunk])] -> IO ()
set_waveforms :: Channel -> [((ViewId, TrackNum), [WaveformChunk])] -> IO ()
set_waveforms Channel
chan [((ViewId, TrackNum), [WaveformChunk])]
by_view
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((ViewId, TrackNum), [WaveformChunk])]
by_view = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
chan Text
"set_waveforms" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        [ ViewId -> TrackNum -> WaveformChunk -> Fltk ()
BlockC.set_waveform ViewId
view_id TrackNum
tracknum WaveformChunk
waveform
        | ((ViewId
view_id, TrackNum
tracknum), [WaveformChunk]
waveforms) <- [((ViewId, TrackNum), [WaveformChunk])]
by_view
        , WaveformChunk
waveform <- [WaveformChunk]
waveforms
        ]

clear_waveforms :: Fltk.Channel -> [ViewId] -> IO ()
clear_waveforms :: Channel -> [ViewId] -> IO ()
clear_waveforms Channel
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
clear_waveforms Channel
chan [ViewId]
view_ids = Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
chan Text
"clear_waveforms" forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ViewId -> Fltk ()
BlockC.clear_waveforms [ViewId]
view_ids

gc_waveforms :: Fltk.Channel -> IO ()
gc_waveforms :: Channel -> IO ()
gc_waveforms Channel
chan = Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
chan Text
"gc_waveforms" forall a b. (a -> b) -> a -> b
$ Fltk ()
BlockC.gc_waveforms

-- ** selections

set_selections :: Sel.Num -> Fltk.Channel
    -> [((ViewId, TrackNum), (Range, Color.Color))] -> IO ()
set_selections :: TrackNum
-> Channel -> [((ViewId, TrackNum), (Range, Color))] -> IO ()
set_selections TrackNum
selnum Channel
chan [((ViewId, TrackNum), (Range, Color))]
view_sels = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((ViewId, TrackNum), (Range, Color))]
view_sels) forall a b. (a -> b) -> a -> b
$
    Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
chan Text
"set_highlights" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ do
        (ViewId
view_id, [(TrackNum, [(Range, Color)])]
tracknum_sels) <- [((ViewId, TrackNum), (Range, Color))]
-> [(ViewId, [(TrackNum, [(Range, Color)])])]
group_by_view [((ViewId, TrackNum), (Range, Color))]
view_sels
        (TrackNum
tracknum, [(Range, Color)]
range_colors) <- [(TrackNum, [(Range, Color)])]
tracknum_sels
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ViewId
-> TrackNum -> Maybe (NonNull TrackNum) -> [Selection] -> Fltk ()
set_selection_carefully ViewId
view_id TrackNum
selnum
            (forall a. a -> Maybe a
Just [TrackNum
tracknum]) (forall a b. (a -> b) -> [a] -> [b]
map (Range, Color) -> Selection
make_sel [(Range, Color)]
range_colors)
    where
    make_sel :: (Range, Color) -> Selection
make_sel ((ScoreTime
start, ScoreTime
end), Color
color) = BlockC.Selection
        { sel_color :: Color
sel_color = Color
color
        , sel_start :: ScoreTime
sel_start = ScoreTime
start
        , sel_cur :: ScoreTime
sel_cur = ScoreTime
end
        , sel_orientation :: SelectionOrientation
sel_orientation = SelectionOrientation
BlockC.None
        }

-- | Juggle the selections around into the format that 'BlockC.set_selection'
-- wants.
group_by_view :: [((ViewId, TrackNum), (Range, Color.Color))]
    -> [(ViewId, [(TrackNum, [(Range, Color.Color)])])]
group_by_view :: [((ViewId, TrackNum), (Range, Color))]
-> [(ViewId, [(TrackNum, [(Range, Color)])])]
group_by_view [((ViewId, TrackNum), (Range, Color))]
view_sels = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. Ord a => [(a, b)] -> [(a, NonNull b)]
Lists.groupFst) [(ViewId, [(TrackNum, (Range, Color))])]
by_view
    where
    ([(ViewId, TrackNum)]
view_tracknums, [(Range, Color)]
range_colors) = forall a b. [(a, b)] -> ([a], [b])
unzip [((ViewId, TrackNum), (Range, Color))]
view_sels
    ([ViewId]
view_ids, NonNull TrackNum
tracknums) = forall a b. [(a, b)] -> ([a], [b])
unzip [(ViewId, TrackNum)]
view_tracknums
    by_view :: [(ViewId, [(TrackNum, (Range, Color.Color))])]
    by_view :: [(ViewId, [(TrackNum, (Range, Color))])]
by_view = forall a b. Ord a => [(a, b)] -> [(a, NonNull b)]
Lists.groupFst forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [ViewId]
view_ids (forall a b. [a] -> [b] -> [(a, b)]
zip NonNull TrackNum
tracknums [(Range, Color)]
range_colors)

clear_selections :: Sel.Num -> Fltk.Channel -> [ViewId] -> IO ()
clear_selections :: TrackNum -> Channel -> [ViewId] -> IO ()
clear_selections TrackNum
selnum Channel
chan [ViewId]
view_ids = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ViewId]
view_ids) forall a b. (a -> b) -> a -> b
$
    Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
chan Text
"clear_selections" forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ViewId
view_id -> ViewId
-> TrackNum -> Maybe (NonNull TrackNum) -> [Selection] -> Fltk ()
set_selection_carefully ViewId
view_id TrackNum
selnum forall a. Maybe a
Nothing [])
            [ViewId]
view_ids

-- | Call 'BlockC.set_selection', but be careful to not pass it a bad ViewId or
-- TrackNum.
--
-- This can be called outside of the responder loop, and the caller may have
-- an out of date UI state.
set_selection_carefully :: ViewId -> Sel.Num -> Maybe [TrackNum]
    -> [BlockC.Selection] -> Fltk.Fltk ()
set_selection_carefully :: ViewId
-> TrackNum -> Maybe (NonNull TrackNum) -> [Selection] -> Fltk ()
set_selection_carefully ViewId
view_id TrackNum
selnum Maybe (NonNull TrackNum)
maybe_tracknums [Selection]
sels =
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ViewId -> IO Bool
PtrMap.view_exists ViewId
view_id) forall a b. (a -> b) -> a -> b
$ do
        TrackNum
tracks <- ViewId -> Fltk TrackNum
BlockC.tracks ViewId
view_id
        let tracknums :: NonNull TrackNum
tracknums = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TrackNum
0 .. TrackNum
tracksforall a. Num a => a -> a -> a
-TrackNum
1] (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
<TrackNum
tracks)) Maybe (NonNull TrackNum)
maybe_tracknums
        ViewId -> TrackNum -> NonNull TrackNum -> [Selection] -> Fltk ()
BlockC.set_selection ViewId
view_id TrackNum
selnum NonNull TrackNum
tracknums [Selection]
sels

-- ** block misc

floating_input :: Ui.State -> Cmd.FloatingInput -> Fltk.Fltk ()
floating_input :: State -> FloatingInput -> Fltk ()
floating_input State
_ (Cmd.FloatingOpen ViewId
view_id TrackNum
tracknum ScoreTime
at Text
text (TrackNum, TrackNum)
selection) =
    ViewId
-> TrackNum -> ScoreTime -> Text -> (TrackNum, TrackNum) -> Fltk ()
BlockC.floating_open ViewId
view_id TrackNum
tracknum ScoreTime
at Text
text (TrackNum, TrackNum)
selection
floating_input State
state (Cmd.FloatingInsert Text
text) =
    [ViewId] -> Text -> Fltk ()
BlockC.floating_insert (forall k a. Map k a -> [k]
Map.keys (State -> Map ViewId View
Ui.state_views State
state)) Text
text

-- ** keycaps

create_keycaps :: Fltk.Channel -> (Int, Int) -> KeycapsT.Layout -> IO ()
create_keycaps :: Channel -> (TrackNum, TrackNum) -> Layout -> IO ()
create_keycaps Channel
ui_chan (TrackNum, TrackNum)
pos Layout
layout =
    Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
ui_chan Text
"create_keycaps" forall a b. (a -> b) -> a -> b
$ (TrackNum, TrackNum) -> Layout -> Fltk ()
KeycapsC.create (TrackNum, TrackNum)
pos Layout
layout

destroy_keycaps :: Fltk.Channel -> IO ()
destroy_keycaps :: Channel -> IO ()
destroy_keycaps Channel
ui_chan =
    Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
ui_chan Text
"destroy_keycaps" Fltk ()
KeycapsC.destroy

update_keycaps :: Fltk.Channel -> KeycapsT.RawBindings -> IO ()
update_keycaps :: Channel -> RawBindings -> IO ()
update_keycaps Channel
ui_chan RawBindings
bindings =
    Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
ui_chan Text
"update_keycaps" forall a b. (a -> b) -> a -> b
$ RawBindings -> Fltk ()
KeycapsC.update RawBindings
bindings

-- ** debug

print_debug :: Fltk.Channel -> ViewId -> IO ()
print_debug :: Channel -> ViewId -> IO ()
print_debug Channel
ui_chan ViewId
view_id =
    Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
ui_chan Text
"print_debug" forall a b. (a -> b) -> a -> b
$ ViewId -> Fltk ()
BlockC.print_debug ViewId
view_id

-- * run_update

-- There's a fair amount of copy and paste in here, since CreateView subsumes
-- the functions of InsertTrack and many others.  For example, the merged
-- events of a given track are calculated in 4 separate places.  It's nasty
-- error-prone imperative code.  I'd like to factor it better but I don't know
-- how.
--
-- Also, set_style occurs in a lot of places and has to be transformed in the
-- same way every time.  The problem is that each case has a large and
-- overlapping set of required data, and it comes from different places.  Also
-- work is expressed in multiple places, e.g. CreateView contains all the stuff
-- from modifying views and creating tracks.
--
-- It's also a little confusing in that this function runs in StateT, but
-- returns an IO action to be run in the UI thread, so there are two monads
-- here.

-- | Generate an IO action that applies the update to the UI.
--
-- CreateView Updates will modify the State to add the ViewPtr.  The IO in
-- the StateT is needed only for some logging.
run_update :: (BlockId -> [ViewId]) -> Track.TrackSignals
    -> Track.SetStyleHigh -> Update.DisplayUpdate -> Ui.StateId [Fltk.Fltk ()]
    -- I'd like to put the various args in a StateT, but so far it's not worth
    -- the annoyance of having to lift the Ui.M operations.
run_update :: (BlockId -> [ViewId])
-> TrackSignals
-> SetStyleHigh
-> DisplayUpdate
-> StateId [Fltk ()]
run_update BlockId -> [ViewId]
views_of TrackSignals
track_signals SetStyleHigh
set_style DisplayUpdate
update = case DisplayUpdate
update of
    Update.View ViewId
view_id View
update ->
        TrackSignals -> SetStyleHigh -> ViewId -> View -> StateId [Fltk ()]
update_view TrackSignals
track_signals SetStyleHigh
set_style ViewId
view_id View
update
    Update.Block BlockId
block_id Block DisplayTrack
update ->
        (BlockId -> [ViewId])
-> TrackSignals
-> SetStyleHigh
-> BlockId
-> Block DisplayTrack
-> StateId [Fltk ()]
update_block BlockId -> [ViewId]
views_of TrackSignals
track_signals SetStyleHigh
set_style BlockId
block_id Block DisplayTrack
update
    Update.Track TrackId
track_id Track
update ->
        (BlockId -> [ViewId])
-> SetStyleHigh -> TrackId -> Track -> StateId [Fltk ()]
update_track BlockId -> [ViewId]
views_of SetStyleHigh
set_style TrackId
track_id Track
update
    Update.Ruler RulerId
ruler_id ->
        (BlockId -> [ViewId])
-> SetStyleHigh -> RulerId -> StateId [Fltk ()]
update_ruler BlockId -> [ViewId]
views_of SetStyleHigh
set_style RulerId
ruler_id
    Update.State () -> forall (m :: * -> *) a. Monad m => a -> m a
return []

update_view :: Track.TrackSignals -> Track.SetStyleHigh -> ViewId
    -> Update.View -> Ui.StateId [Fltk.Fltk ()]
update_view :: TrackSignals -> SetStyleHigh -> ViewId -> View -> StateId [Fltk ()]
update_view TrackSignals
track_signals SetStyleHigh
set_style ViewId
view_id View
Update.CreateView = do
    View
view <- forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block (View -> BlockId
Block.view_block View
view)

    let dtracks :: [DisplayTrack]
dtracks = Block -> [DisplayTrack]
Block.block_display_tracks Block
block
        btracks :: [Track]
btracks = Block -> [Track]
Block.block_tracks Block
block
        tlike_ids :: [TracklikeId]
tlike_ids = forall a b. (a -> b) -> [a] -> [b]
map Track -> TracklikeId
Block.tracklike_id [Track]
btracks
    -- It's important to get the tracklikes from the dtracks, not the
    -- tlike_ids.  That's because the dtracks will have already turned
    -- Collapsed tracks into Dividers.
    [Tracklike]
tracklikes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). M m => TracklikeId -> m Tracklike
Ui.get_tracklike forall b c a. (b -> c) -> (a -> b) -> a -> c
. DisplayTrack -> TracklikeId
Block.dtracklike_id) [DisplayTrack]
dtracks

    let sels :: Map TrackNum Selection
sels = View -> Map TrackNum Selection
Block.view_selections View
view
        selnum_sels :: [(Sel.Num, [([TrackNum], [BlockC.Selection])])]
        selnum_sels :: [(TrackNum, [(NonNull TrackNum, [Selection])])]
selnum_sels =
            [ (TrackNum
selnum, TrackNum
-> TrackNum -> Maybe Selection -> [(NonNull TrackNum, [Selection])]
track_selections TrackNum
selnum (forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [Track]
btracks) (forall a. a -> Maybe a
Just Selection
sel))
            | (TrackNum
selnum, Selection
sel) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map TrackNum Selection
sels
            ]
    State
state <- forall (m :: * -> *). M m => m State
Ui.get
    -- I manually sync the new empty view with its state.  It might reduce
    -- repetition to let Diff.diff do that by diffing against a state with an
    -- empty view, but this way seems less complicated if more error-prone.
    -- Sync: title, tracks, selection, skeleton
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ do
        let title :: Text
title = Namespace -> ViewId -> BlockId -> Text
block_window_title
                (Config -> Namespace
UiConfig.config_namespace (State -> Config
Ui.state_config State
state))
                ViewId
view_id (View -> BlockId
Block.view_block View
view)
        ViewId -> Text -> Rect -> Config -> Fltk ()
BlockC.create_view ViewId
view_id Text
title (View -> Rect
Block.view_rect View
view)
            (Block -> Config
Block.block_config Block
block)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b c d e.
[a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]
List.zip5 [TrackNum
0..] [DisplayTrack]
dtracks [Track]
btracks [TracklikeId]
tlike_ids [Tracklike]
tracklikes) forall a b. (a -> b) -> a -> b
$
            \(TrackNum
tracknum, DisplayTrack
dtrack, Track
btrack, TracklikeId
tlike_id, Tracklike
tlike) ->
                State
-> SetStyleHigh
-> BlockId
-> ViewId
-> TrackNum
-> DisplayTrack
-> TracklikeId
-> Tracklike
-> TrackSignals
-> Set TrackFlag
-> Fltk ()
insert_track State
state SetStyleHigh
set_style (View -> BlockId
Block.view_block View
view) ViewId
view_id
                    TrackNum
tracknum DisplayTrack
dtrack TracklikeId
tlike_id Tracklike
tlike TrackSignals
track_signals
                    (Track -> Set TrackFlag
Block.track_flags Track
btrack)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null (Block -> Text
Block.block_title Block
block)) forall a b. (a -> b) -> a -> b
$
            ViewId -> Text -> Fltk ()
BlockC.set_title ViewId
view_id (Block -> Text
Block.block_title Block
block)
        ViewId -> Skeleton -> [(Color, [(TrackNum, TrackNum)])] -> Fltk ()
BlockC.set_skeleton ViewId
view_id (Block -> Skeleton
Block.block_skeleton Block
block)
            (Block -> [(Color, [(TrackNum, TrackNum)])]
Block.integrate_skeleton Block
block)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TrackNum, [(NonNull TrackNum, [Selection])])]
selnum_sels forall a b. (a -> b) -> a -> b
$ \(TrackNum
selnum, [(NonNull TrackNum, [Selection])]
tracknums_sels) ->
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(NonNull TrackNum, [Selection])]
tracknums_sels forall a b. (a -> b) -> a -> b
$ \(NonNull TrackNum
tracknums, [Selection]
sels) ->
                ViewId -> TrackNum -> NonNull TrackNum -> [Selection] -> Fltk ()
BlockC.set_selection ViewId
view_id TrackNum
selnum NonNull TrackNum
tracknums [Selection]
sels
        ViewId -> Text -> Color -> Fltk ()
BlockC.set_status ViewId
view_id (Map (TrackNum, Text) Text -> Text
Block.show_status (View -> Map (TrackNum, Text) Text
Block.view_status View
view))
            (BlockId -> Block -> Maybe BlockId -> Color
Block.status_color (View -> BlockId
Block.view_block View
view) Block
block
                (Config -> Maybe BlockId
UiConfig.config_root (State -> Config
Ui.state_config State
state)))
        ViewId -> Zoom -> Fltk ()
BlockC.set_zoom ViewId
view_id (View -> Zoom
Block.view_zoom View
view)
        ViewId -> TrackNum -> Fltk ()
BlockC.set_track_scroll ViewId
view_id (View -> TrackNum
Block.view_track_scroll View
view)

update_view TrackSignals
_ SetStyleHigh
_ ViewId
view_id View
update = case View
update of
    View
Update.DestroyView -> forall (m :: * -> *) a. Monad m => a -> m a
return [ViewId -> Fltk ()
BlockC.destroy_view ViewId
view_id]
    Update.ViewSize Rect
rect -> forall (m :: * -> *) a. Monad m => a -> m a
return [ViewId -> Rect -> Fltk ()
BlockC.set_size ViewId
view_id Rect
rect]
    Update.Status Map (TrackNum, Text) Text
status Color
color ->
        forall (m :: * -> *) a. Monad m => a -> m a
return [ViewId -> Text -> Color -> Fltk ()
BlockC.set_status ViewId
view_id (Map (TrackNum, Text) Text -> Text
Block.show_status Map (TrackNum, Text) Text
status) Color
color]
    Update.TrackScroll TrackNum
offset ->
        forall (m :: * -> *) a. Monad m => a -> m a
return [ViewId -> TrackNum -> Fltk ()
BlockC.set_track_scroll ViewId
view_id TrackNum
offset]
    Update.Zoom Zoom
zoom -> forall (m :: * -> *) a. Monad m => a -> m a
return [ViewId -> Zoom -> Fltk ()
BlockC.set_zoom ViewId
view_id Zoom
zoom]
    Update.Selection TrackNum
selnum Maybe Selection
maybe_sel -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ do
        TrackNum
tracks <- ViewId -> Fltk TrackNum
BlockC.tracks ViewId
view_id
        let tracknums_sels :: [(NonNull TrackNum, [Selection])]
tracknums_sels = TrackNum
-> TrackNum -> Maybe Selection -> [(NonNull TrackNum, [Selection])]
track_selections TrackNum
selnum TrackNum
tracks Maybe Selection
maybe_sel
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(NonNull TrackNum, [Selection])]
tracknums_sels forall a b. (a -> b) -> a -> b
$ \(NonNull TrackNum
tracknums, [Selection]
sels) ->
            ViewId -> TrackNum -> NonNull TrackNum -> [Selection] -> Fltk ()
BlockC.set_selection ViewId
view_id TrackNum
selnum NonNull TrackNum
tracknums [Selection]
sels
    View
Update.BringToFront -> forall (m :: * -> *) a. Monad m => a -> m a
return [ViewId -> Fltk ()
BlockC.bring_to_front ViewId
view_id]
    Update.TitleFocus Maybe TrackNum
tracknum ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ViewId -> Fltk ()
BlockC.set_block_title_focus ViewId
view_id)
            (ViewId -> TrackNum -> Fltk ()
BlockC.set_track_title_focus ViewId
view_id) Maybe TrackNum
tracknum

-- | Block ops apply to every view with that block.
update_block :: (BlockId -> [ViewId]) -> Track.TrackSignals
    -> Track.SetStyleHigh -> BlockId -> Update.Block Block.DisplayTrack
    -> Ui.StateId [Fltk.Fltk ()]
update_block :: (BlockId -> [ViewId])
-> TrackSignals
-> SetStyleHigh
-> BlockId
-> Block DisplayTrack
-> StateId [Fltk ()]
update_block BlockId -> [ViewId]
views_of TrackSignals
track_signals SetStyleHigh
set_style BlockId
block_id Block DisplayTrack
update = case Block DisplayTrack
update of
    Update.BlockTitle Text
title -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip ViewId -> Text -> Fltk ()
BlockC.set_title Text
title) [ViewId]
view_ids
    Update.BlockConfig Config
config -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip ViewId -> Config -> Fltk ()
BlockC.set_config Config
config) [ViewId]
view_ids
    Update.BlockSkeleton Skeleton
skel [(Color, [(TrackNum, TrackNum)])]
integrate_edges -> forall (m :: * -> *) a. Monad m => a -> m a
return
        [ ViewId -> Skeleton -> [(Color, [(TrackNum, TrackNum)])] -> Fltk ()
BlockC.set_skeleton ViewId
view_id Skeleton
skel [(Color, [(TrackNum, TrackNum)])]
integrate_edges
        | ViewId
view_id <- [ViewId]
view_ids
        ]
    Update.RemoveTrack TrackNum
tracknum -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip ViewId -> TrackNum -> Fltk ()
BlockC.remove_track TrackNum
tracknum) [ViewId]
view_ids
    Update.InsertTrack TrackNum
tracknum DisplayTrack
dtrack -> forall {m :: * -> *}.
M m =>
TrackNum -> DisplayTrack -> m [Fltk ()]
create_track TrackNum
tracknum DisplayTrack
dtrack
    Update.BlockTrack TrackNum
tracknum DisplayTrack
dtrack -> do
        Tracklike
tracklike <- forall (m :: * -> *). M m => TracklikeId -> m Tracklike
Ui.get_tracklike (DisplayTrack -> TracklikeId
Block.dtracklike_id DisplayTrack
dtrack)
        State
state <- forall (m :: * -> *). M m => m State
Ui.get
        let set_style_low :: SetStyle
set_style_low = State -> BlockId -> TracklikeId -> SetStyleHigh -> SetStyle
update_set_style State
state BlockId
block_id
                (DisplayTrack -> TracklikeId
Block.dtracklike_id DisplayTrack
dtrack) SetStyleHigh
set_style
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> (a -> b) -> [b]
for [ViewId]
view_ids forall a b. (a -> b) -> a -> b
$ \ViewId
view_id -> do
            ViewId -> TrackNum -> DisplayTrack -> Fltk ()
BlockC.set_display_track ViewId
view_id TrackNum
tracknum DisplayTrack
dtrack
            let merged :: [Events]
merged = State -> Set TrackId -> [Events]
events_of_track_ids State
state
                    (DisplayTrack -> Set TrackId
Block.dtrack_merged DisplayTrack
dtrack)
            -- This is unnecessary if I just collapsed the track, but
            -- no big deal.
            Bool
-> ViewId
-> TrackNum
-> Tracklike
-> [Events]
-> SetStyle
-> Fltk ()
BlockC.update_entire_track Bool
False ViewId
view_id TrackNum
tracknum Tracklike
tracklike
                [Events]
merged SetStyle
set_style_low
    where
    view_ids :: [ViewId]
view_ids = BlockId -> [ViewId]
views_of BlockId
block_id
    create_track :: TrackNum -> DisplayTrack -> m [Fltk ()]
create_track TrackNum
tracknum DisplayTrack
dtrack = do
        let tlike_id :: TracklikeId
tlike_id = DisplayTrack -> TracklikeId
Block.dtracklike_id DisplayTrack
dtrack
        Tracklike
tlike <- forall (m :: * -> *). M m => TracklikeId -> m Tracklike
Ui.get_tracklike TracklikeId
tlike_id
        State
state <- forall (m :: * -> *). M m => m State
Ui.get
        -- Not sure if this should be fatal?
        Track
btrack <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Ui.require
            (Text
"InsertTrack with tracknum not in the block: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Block DisplayTrack
update)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Block
b -> forall a. [a] -> TrackNum -> Maybe a
Lists.at (Block -> [Track]
Block.block_tracks Block
b) TrackNum
tracknum)
                (forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> (a -> b) -> [b]
for [ViewId]
view_ids forall a b. (a -> b) -> a -> b
$ \ViewId
view_id ->
            State
-> SetStyleHigh
-> BlockId
-> ViewId
-> TrackNum
-> DisplayTrack
-> TracklikeId
-> Tracklike
-> TrackSignals
-> Set TrackFlag
-> Fltk ()
insert_track State
state SetStyleHigh
set_style BlockId
block_id ViewId
view_id TrackNum
tracknum DisplayTrack
dtrack
                TracklikeId
tlike_id Tracklike
tlike TrackSignals
track_signals (Track -> Set TrackFlag
Block.track_flags Track
btrack)

update_track :: (BlockId -> [ViewId]) -> Track.SetStyleHigh
    -> TrackId -> Update.Track -> Ui.StateId [Fltk.Fltk ()]
update_track :: (BlockId -> [ViewId])
-> SetStyleHigh -> TrackId -> Track -> StateId [Fltk ()]
update_track BlockId -> [ViewId]
views_of SetStyleHigh
set_style TrackId
track_id Track
update = do
    [BlockId]
block_ids <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
dtracks_with_track_id TrackId
track_id
    State
state <- forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        BlockId
block_id <- [BlockId]
block_ids
        Just Block
block <- [forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id (State -> Map BlockId Block
Ui.state_blocks State
state)]
        (TrackNum
tracknum, TracklikeId
tracklike_id) <- forall {a}.
(Num a, Enum a) =>
TrackId -> Block -> [(a, TracklikeId)]
tracklikes TrackId
track_id Block
block
        let merged :: [Events]
merged = State -> Block -> TrackNum -> [Events]
merged_events_of State
state Block
block TrackNum
tracknum
        Tracklike
tracklike <- State -> TracklikeId -> [Tracklike]
get_tracklike State
state TracklikeId
tracklike_id
        let set_style_low :: SetStyle
set_style_low = State -> BlockId -> TracklikeId -> SetStyleHigh -> SetStyle
update_set_style State
state BlockId
block_id TracklikeId
tracklike_id
                SetStyleHigh
set_style
        ViewId
view_id <- BlockId -> [ViewId]
views_of BlockId
block_id
        forall {m :: * -> *}.
Monad m =>
SetStyle
-> ViewId
-> Tracklike
-> TrackNum
-> [Events]
-> Track
-> m (Fltk ())
track_update SetStyle
set_style_low ViewId
view_id Tracklike
tracklike TrackNum
tracknum [Events]
merged Track
update
    where
    tracklikes :: TrackId -> Block -> [(a, TracklikeId)]
tracklikes TrackId
track_id Block
block =
        [ (a
n, TracklikeId
track) | (a
n, track :: TracklikeId
track@(Block.TId TrackId
tid RulerId
_)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [a
0..] [TracklikeId]
tracks
        , TrackId
tid forall a. Eq a => a -> a -> Bool
== TrackId
track_id
        ]
        where
        tracks :: [TracklikeId]
tracks = forall a b. (a -> b) -> [a] -> [b]
map DisplayTrack -> TracklikeId
Block.dtracklike_id (Block -> [DisplayTrack]
Block.block_display_tracks Block
block)
    track_update :: SetStyle
-> ViewId
-> Tracklike
-> TrackNum
-> [Events]
-> Track
-> m (Fltk ())
track_update SetStyle
set_style ViewId
view_id Tracklike
tracklike TrackNum
tracknum [Events]
merged Track
update =
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Track
update of
            Update.TrackEvents ScoreTime
low ScoreTime
high ->
                Bool
-> ViewId
-> TrackNum
-> Tracklike
-> [Events]
-> SetStyle
-> ScoreTime
-> ScoreTime
-> Fltk ()
BlockC.update_track Bool
False ViewId
view_id TrackNum
tracknum Tracklike
tracklike [Events]
merged
                    SetStyle
set_style ScoreTime
low ScoreTime
high
            Track
Update.TrackAllEvents ->
                Bool
-> ViewId
-> TrackNum
-> Tracklike
-> [Events]
-> SetStyle
-> Fltk ()
BlockC.update_entire_track Bool
False ViewId
view_id TrackNum
tracknum Tracklike
tracklike
                    [Events]
merged SetStyle
set_style
            Update.TrackTitle Text
title ->
                ViewId -> TrackNum -> Text -> Fltk ()
BlockC.set_track_title ViewId
view_id TrackNum
tracknum Text
title
            Update.TrackBg Color
_color ->
                -- update_track also updates the bg color
                Bool
-> ViewId
-> TrackNum
-> Tracklike
-> [Events]
-> SetStyle
-> ScoreTime
-> ScoreTime
-> Fltk ()
BlockC.update_track Bool
False ViewId
view_id TrackNum
tracknum Tracklike
tracklike
                    [Events]
merged SetStyle
set_style ScoreTime
0 ScoreTime
0
            Update.TrackRender RenderConfig
_render ->
                Bool
-> ViewId
-> TrackNum
-> Tracklike
-> [Events]
-> SetStyle
-> Fltk ()
BlockC.update_entire_track Bool
False ViewId
view_id TrackNum
tracknum Tracklike
tracklike
                    [Events]
merged SetStyle
set_style

update_ruler :: (BlockId -> [ViewId]) -> Track.SetStyleHigh -> RulerId
    -> Ui.StateId [Fltk.Fltk ()]
update_ruler :: (BlockId -> [ViewId])
-> SetStyleHigh -> RulerId -> StateId [Fltk ()]
update_ruler BlockId -> [ViewId]
views_of SetStyleHigh
set_style RulerId
ruler_id = do
    [(BlockId, [(TrackNum, TracklikeId)])]
block_tracks <- forall (m :: * -> *).
M m =>
RulerId -> m [(BlockId, [(TrackNum, TracklikeId)])]
dtracks_with_ruler_id RulerId
ruler_id
    State
state <- forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        (BlockId
block_id, [(TrackNum, TracklikeId)]
tracks) <- [(BlockId, [(TrackNum, TracklikeId)])]
block_tracks
        Just Block
block <- [forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id (State -> Map BlockId Block
Ui.state_blocks State
state)]
        ViewId
view_id <- BlockId -> [ViewId]
views_of BlockId
block_id
        (TrackNum
tracknum, TracklikeId
tracklike_id) <- [(TrackNum, TracklikeId)]
tracks
        Tracklike
tracklike <- State -> TracklikeId -> [Tracklike]
get_tracklike State
state TracklikeId
tracklike_id
        let merged :: [Events]
merged = State -> Block -> TrackNum -> [Events]
merged_events_of State
state Block
block TrackNum
tracknum
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
-> ViewId
-> TrackNum
-> Tracklike
-> [Events]
-> SetStyle
-> Fltk ()
BlockC.update_entire_track Bool
True ViewId
view_id TrackNum
tracknum Tracklike
tracklike
            [Events]
merged (State -> BlockId -> TracklikeId -> SetStyleHigh -> SetStyle
update_set_style State
state BlockId
block_id TracklikeId
tracklike_id SetStyleHigh
set_style)

for :: [a] -> (a -> b) -> [b]
for :: forall a b. [a] -> (a -> b) -> [b]
for = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map

-- | Get the views of a certain block, omitting ones that have been created.
-- This is because they are created from the new state, so any updates intended
-- to take them from the old state will be wrong.
--
-- TODO presumably this applies to InsertTrack, but I think it's harmless
-- because track updates are all idempotent, so redundantly setting the title
-- won't do any harm.  I'm not totally sure though.  This all seems like grody
-- hacks and if I really had a sensible theory for diffs and updates I wouldn't
-- have these kinds of problems.
old_views_of :: [Update.Update a b] -> Ui.State -> BlockId -> [ViewId]
old_views_of :: forall a b. [Update a b] -> State -> BlockId -> [ViewId]
old_views_of [Update a b]
updates State
state BlockId
block_id =
    [ ViewId
view_id
    | (ViewId
view_id, View
view) <- forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map ViewId View
Ui.state_views State
state)
    , View -> BlockId
Block.view_block View
view forall a. Eq a => a -> a -> Bool
== BlockId
block_id
    , ViewId
view_id forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set ViewId
created
    ]
    where
    created :: Set ViewId
created = forall a. Ord a => [a] -> Set a
Set.fromList
        [ViewId
view_id | Update.View ViewId
view_id View
Update.CreateView <- [Update a b]
updates]

-- | This is so 'update_track' and 'update_ruler' can use the list monad, which
-- looks nicer because it flattens the nested loops.  It means I lose error
-- reporting for bad IDs, but maybe this isn't the best place to catch those
-- anyway.
get_tracklike :: Ui.State -> Block.TracklikeId -> [Block.Tracklike]
get_tracklike :: State -> TracklikeId -> [Tracklike]
get_tracklike State
state = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. State -> StateId a -> Either Error a
Ui.eval State
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TracklikeId -> m Tracklike
Ui.get_tracklike

-- ** util

-- | Insert a track.  Tracks require a crazy amount of configuration.
insert_track :: Ui.State -> Track.SetStyleHigh -> BlockId -> ViewId
    -> TrackNum -> Block.DisplayTrack -> Block.TracklikeId -> Block.Tracklike
    -> Track.TrackSignals -> Set Block.TrackFlag -> Fltk.Fltk ()
insert_track :: State
-> SetStyleHigh
-> BlockId
-> ViewId
-> TrackNum
-> DisplayTrack
-> TracklikeId
-> Tracklike
-> TrackSignals
-> Set TrackFlag
-> Fltk ()
insert_track State
state SetStyleHigh
set_style BlockId
block_id ViewId
view_id TrackNum
tracknum DisplayTrack
dtrack TracklikeId
tlike_id Tracklike
tlike
        TrackSignals
track_signals Set TrackFlag
flags = do
    ViewId
-> TrackNum
-> Tracklike
-> [Events]
-> SetStyle
-> TrackNum
-> Fltk ()
BlockC.insert_track ViewId
view_id TrackNum
tracknum Tracklike
tlike [Events]
merged SetStyle
set_style_low
        (DisplayTrack -> TrackNum
Block.dtrack_width DisplayTrack
dtrack)
    ViewId -> TrackNum -> DisplayTrack -> Fltk ()
BlockC.set_display_track ViewId
view_id TrackNum
tracknum DisplayTrack
dtrack
    case (Tracklike
tlike, TracklikeId
tlike_id) of
        (Block.T Track
t Ruler
_, Block.TId TrackId
tid RulerId
_) -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null (Track -> Text
Track.track_title Track
t)) forall a b. (a -> b) -> a -> b
$
                ViewId -> TrackNum -> Text -> Fltk ()
BlockC.set_track_title ViewId
view_id TrackNum
tracknum (Track -> Text
Track.track_title Track
t)
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (BlockId
block_id, TrackId
tid) TrackSignals
track_signals of
                Just TrackSignal
tsig | Set TrackFlag -> Track -> Bool
Block.track_wants_signal Set TrackFlag
flags Track
t ->
                    ViewId -> TrackNum -> TrackSignal -> Fltk ()
BlockC.set_track_signal ViewId
view_id TrackNum
tracknum TrackSignal
tsig
                Maybe TrackSignal
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Tracklike, TracklikeId)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where
    set_style_low :: SetStyle
set_style_low = State -> BlockId -> TracklikeId -> SetStyleHigh -> SetStyle
update_set_style State
state BlockId
block_id TracklikeId
tlike_id SetStyleHigh
set_style
    merged :: [Events]
merged = State -> Set TrackId -> [Events]
events_of_track_ids State
state (DisplayTrack -> Set TrackId
Block.dtrack_merged DisplayTrack
dtrack)

-- | Convert SetStyleHigh to lower level SetStyle by giving it information not
-- available at lowel levels.  For the moment that's just an ad-hoc
-- 'has_note_children' flag.  This is a bit awkward and ad-hoc, but the
-- alternative is setting some flag in the 'Ui.Track.Track', and that's just
-- one more thing that can get out of sync.
update_set_style :: Ui.State -> BlockId -> Block.TracklikeId
    -> Track.SetStyleHigh -> Track.SetStyle
update_set_style :: State -> BlockId -> TracklikeId -> SetStyleHigh -> SetStyle
update_set_style State
state BlockId
block_id TracklikeId
tlike (Track.SetStyleHigh TrackBg
track_bg forall a.
Namespace -> Map BlockId a -> BlockId -> Bool -> EventStyle
set_style) =
    (TrackBg
track_bg,) forall a b. (a -> b) -> a -> b
$ case TracklikeId
tlike of
        Block.TId TrackId
track_id RulerId
_ ->
            forall a.
Namespace -> Map BlockId a -> BlockId -> Bool -> EventStyle
set_style Namespace
ns (State -> Map BlockId Block
Ui.state_blocks State
state) BlockId
block_id Bool
note_children
            where
            note_children :: Bool
note_children = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
False) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. State -> StateId a -> Either Error a
Ui.eval State
state forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *). M m => BlockId -> TrackId -> m Bool
has_note_children BlockId
block_id TrackId
track_id
        TracklikeId
_ -> forall a.
Namespace -> Map BlockId a -> BlockId -> Bool -> EventStyle
set_style Namespace
ns forall a. Monoid a => a
mempty BlockId
block_id Bool
False
    where
    ns :: Namespace
ns = Config -> Namespace
UiConfig.config_namespace (State -> Config
Ui.state_config State
state)

has_note_children :: Ui.M m => BlockId -> TrackId -> m Bool
has_note_children :: forall (m :: * -> *). M m => BlockId -> TrackId -> m Bool
has_note_children BlockId
block_id TrackId
track_id = do
    [TrackInfo]
children <- forall (m :: * -> *). M m => BlockId -> TrackId -> m [TrackInfo]
TrackTree.get_children_of BlockId
block_id TrackId
track_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Bool
ParseTitle.is_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> Text
Ui.track_title) [TrackInfo]
children

merged_events_of :: Ui.State -> Block.Block -> TrackNum -> [Events.Events]
merged_events_of :: State -> Block -> TrackNum -> [Events]
merged_events_of State
state Block
block TrackNum
tracknum =
    case forall a. [a] -> TrackNum -> Maybe a
Lists.at (Block -> [Track]
Block.block_tracks Block
block) TrackNum
tracknum of
        Just Track
track -> State -> Set TrackId -> [Events]
events_of_track_ids State
state (Track -> Set TrackId
Block.track_merged Track
track)
        Maybe Track
Nothing -> []

-- | Generate the title for block windows.
--
-- This is @block - view@, where @view@ will have @block@ stripped from the
-- beginning, e.g. @b1 - b1.v1@ becomes @b1 - .v1@.
block_window_title :: Id.Namespace -> ViewId -> BlockId -> Text
block_window_title :: Namespace -> ViewId -> BlockId -> Text
block_window_title Namespace
ns ViewId
view_id BlockId
block_id = Text
block forall a. Semigroup a => a -> a -> a
<> Text
" - " forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
strip Text
block Text
view
    where
    block :: Text
block = Namespace -> Id -> Text
Id.show_short Namespace
ns (forall a. Ident a => a -> Id
Id.unpack_id BlockId
block_id)
    view :: Text
view = Namespace -> Id -> Text
Id.show_short Namespace
ns (forall a. Ident a => a -> Id
Id.unpack_id ViewId
view_id)
    strip :: Text -> Text -> Text
strip Text
prefix Text
txt = forall a. a -> Maybe a -> a
fromMaybe Text
txt forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
Text.stripPrefix Text
prefix Text
txt

events_of_track_ids :: Ui.State -> Set TrackId -> [Events.Events]
events_of_track_ids :: State -> Set TrackId -> [Events]
events_of_track_ids State
state = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TrackId -> Maybe Events
events_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList
    where
    events_of :: TrackId -> Maybe Events
events_of TrackId
track_id = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Track -> Events
Track.track_events (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id Map TrackId Track
tracks)
    tracks :: Map TrackId Track
tracks = State -> Map TrackId Track
Ui.state_tracks State
state

-- | Convert Sel.Selection to BlockC.Selection, and clip to the valid track
-- range.  Return sets of tracknums and the selections they should have.
track_selections :: Sel.Num -> TrackNum -> Maybe Sel.Selection
    -> [([TrackNum], [BlockC.Selection])]
track_selections :: TrackNum
-> TrackNum -> Maybe Selection -> [(NonNull TrackNum, [Selection])]
track_selections TrackNum
selnum TrackNum
tracks Maybe Selection
maybe_sel = case Maybe Selection
maybe_sel of
    Maybe Selection
Nothing -> [([TrackNum
0 .. TrackNum
tracks forall a. Num a => a -> a -> a
- TrackNum
1], [])]
    Just Selection
sel -> (NonNull TrackNum
clear, []) forall a. a -> [a] -> [a]
: TrackNum
-> TrackNum -> Selection -> [(NonNull TrackNum, [Selection])]
convert_selection TrackNum
selnum TrackNum
tracks Selection
sel
        where
        (TrackNum
low, TrackNum
high) = Selection -> (TrackNum, TrackNum)
Sel.track_range Selection
sel
        clear :: NonNull TrackNum
clear = [TrackNum
0 .. TrackNum
low forall a. Num a => a -> a -> a
- TrackNum
1] forall a. [a] -> [a] -> [a]
++ [TrackNum
high forall a. Num a => a -> a -> a
+ TrackNum
1 .. TrackNum
tracks forall a. Num a => a -> a -> a
- TrackNum
1]

convert_selection :: Sel.Num -> TrackNum -> Sel.Selection
    -> [([TrackNum], [BlockC.Selection])]
convert_selection :: TrackNum
-> TrackNum -> Selection -> [(NonNull TrackNum, [Selection])]
convert_selection TrackNum
selnum TrackNum
tracks Selection
sel =
    forall a. (a -> Bool) -> [a] -> [a]
filter (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 b. (a, b) -> a
fst)
        [(NonNull TrackNum
cur_tracknums, [Bool -> Selection
make_sel Bool
True]), (NonNull TrackNum
tracknums, [Bool -> Selection
make_sel Bool
False])]
    where
    (NonNull TrackNum
cur_tracknums, NonNull TrackNum
tracknums) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (forall a. Eq a => a -> a -> Bool
== Selection -> TrackNum
Sel.cur_track Selection
sel)
        (TrackNum -> Selection -> NonNull TrackNum
Sel.tracknums TrackNum
tracks Selection
sel)
    make_sel :: Bool -> Selection
make_sel Bool
cur_track = BlockC.Selection
        { sel_color :: Color
sel_color = Color
color
        , sel_start :: ScoreTime
sel_start = Selection -> ScoreTime
Sel.start_pos Selection
sel
        , sel_cur :: ScoreTime
sel_cur = Selection -> ScoreTime
Sel.cur_pos Selection
sel
        , sel_orientation :: SelectionOrientation
sel_orientation = if Bool
cur_track
            then Orientation -> SelectionOrientation
convert (Selection -> Orientation
Sel.orientation Selection
sel)
            else SelectionOrientation
BlockC.None
        }
    color :: Color
color = TrackNum -> Color
Config.lookup_selection_color TrackNum
selnum
    convert :: Orientation -> SelectionOrientation
convert Orientation
o = case Orientation
o of
        Orientation
Sel.None -> SelectionOrientation
BlockC.None
        Orientation
Sel.Negative -> SelectionOrientation
BlockC.Negative
        Orientation
Sel.Positive -> SelectionOrientation
BlockC.Positive

dtracks_with_ruler_id :: Ui.M m =>
    RulerId -> m [(BlockId, [(TrackNum, Block.TracklikeId)])]
dtracks_with_ruler_id :: forall (m :: * -> *).
M m =>
RulerId -> m [(BlockId, [(TrackNum, TracklikeId)])]
dtracks_with_ruler_id RulerId
ruler_id =
    (TracklikeId -> Bool)
-> Map BlockId Block -> [(BlockId, [(TrackNum, TracklikeId)])]
find_dtracks ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just RulerId
ruler_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracklikeId -> Maybe RulerId
Block.ruler_id_of)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks

dtracks_with_track_id :: Ui.M m =>
    TrackId -> m [(BlockId, [(TrackNum, Block.TracklikeId)])]
dtracks_with_track_id :: forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
dtracks_with_track_id TrackId
track_id =
    (TracklikeId -> Bool)
-> Map BlockId Block -> [(BlockId, [(TrackNum, TracklikeId)])]
find_dtracks ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TrackId
track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracklikeId -> Maybe TrackId
Block.track_id_of)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks

find_dtracks :: (Block.TracklikeId -> Bool) -> Map BlockId Block.Block
    -> [(BlockId, [(TrackNum, Block.TracklikeId)])]
find_dtracks :: (TracklikeId -> Bool)
-> Map BlockId Block -> [(BlockId, [(TrackNum, TracklikeId)])]
find_dtracks TracklikeId -> Bool
f Map BlockId Block
blocks = do
    (BlockId
bid, Block
b) <- forall k a. Map k a -> [(k, a)]
Map.assocs Map BlockId Block
blocks
    let tracks :: [(TrackNum, TracklikeId)]
tracks = Block -> [(TrackNum, TracklikeId)]
get_tracks Block
b
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TrackNum, TracklikeId)]
tracks))
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
bid, [(TrackNum, TracklikeId)]
tracks)
    where
    all_tracks :: Block -> [(TrackNum, DisplayTrack)]
all_tracks Block
block = forall a. [a] -> [(TrackNum, a)]
Lists.enumerate (Block -> [DisplayTrack]
Block.block_display_tracks Block
block)
    get_tracks :: Block -> [(TrackNum, TracklikeId)]
get_tracks Block
block =
        [ (TrackNum
tracknum, DisplayTrack -> TracklikeId
Block.dtracklike_id DisplayTrack
track)
        | (TrackNum
tracknum, DisplayTrack
track) <- Block -> [(TrackNum, DisplayTrack)]
all_tracks Block
block, TracklikeId -> Bool
f (DisplayTrack -> TracklikeId
Block.dtracklike_id DisplayTrack
track)
        ]