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

{- | Diff two states to produce a list of Updates, which must be sent to the
    UI to make it display the second state.

    This is unpleasantly complicated and subtle.  I wish I knew a better way!
-}
module Ui.Diff (
    run
    , diff, derive_diff, track_diff
    , score_changed
    , diff_views
) where
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.Writer as Writer
import qualified Data.Either as Either
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.Control as Control
import qualified Util.Logger as Logger
import qualified Util.Maps as Maps
import qualified Util.Ranges as Ranges
import qualified Util.Lists as Lists

import qualified App.Config as Config
import qualified Derive.Deriver.Monad as Derive
import qualified Ui.Block as Block
import qualified Ui.Color as Color
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Sel as Sel
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig
import qualified Ui.Update as Update

import           Global
import           Types


type DiffM a = Logger.LoggerT (Either Update.UiUpdate Update.DisplayUpdate)
    Identity.Identity a

change :: Update.UiUpdate -> DiffM ()
change :: UiUpdate -> DiffM ()
change = forall w (m :: * -> *). MonadLogger w m => [w] -> m ()
Logger.logs forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left

changes :: [Update.UiUpdate] -> DiffM ()
changes :: [UiUpdate] -> DiffM ()
changes = forall w (m :: * -> *). MonadLogger w m => [w] -> m ()
Logger.logs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left

change_display :: Update.DisplayUpdate -> DiffM ()
change_display :: DisplayUpdate -> DiffM ()
change_display = forall w (m :: * -> *). MonadLogger w m => [w] -> m ()
Logger.logs forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right

run :: DiffM () -> ([Update.UiUpdate], [Update.DisplayUpdate])
run :: DiffM () -> ([UiUpdate], [DisplayUpdate])
run = forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m [w]
Logger.exec

-- | Figure out updates needed to turn @st1@ into @st2@.
diff :: Update.UiDamage -> Ui.State -> Ui.State
    -> ([Update.UiUpdate], [Update.DisplayUpdate])
diff :: UiDamage -> State -> State -> ([UiUpdate], [DisplayUpdate])
diff UiDamage
damage State
st1 State
st2 = UiDamage
-> State
-> ([UiUpdate], [DisplayUpdate])
-> ([UiUpdate], [DisplayUpdate])
postproc UiDamage
damage State
st2 forall a b. (a -> b) -> a -> b
$ DiffM () -> ([UiUpdate], [DisplayUpdate])
run forall a b. (a -> b) -> a -> b
$ do
    let intersect :: (State -> Map k a) -> (UiDamage -> Set k) -> [(k, a, a)]
intersect State -> Map k a
get UiDamage -> Set k
keys =
            forall k a val state.
Ord k =>
(Map k a -> Map k a -> val)
-> state -> state -> (state -> Map k a) -> Set k -> val
damaged forall k v1 v2. Ord k => Map k v1 -> Map k v2 -> [(k, v1, v2)]
Maps.zipIntersection State
st1 State
st2 State -> Map k a
get (UiDamage -> Set k
keys UiDamage
damage)
    State -> State -> UiDamage -> DiffM ()
diff_views State
st1 State
st2 UiDamage
damage
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
Control.uncurry3 BlockId -> Block -> Block -> DiffM ()
diff_block) forall a b. (a -> b) -> a -> b
$
        forall {k} {a}.
Ord k =>
(State -> Map k a) -> (UiDamage -> Set k) -> [(k, a, a)]
intersect State -> Map BlockId Block
Ui.state_blocks UiDamage -> Set BlockId
Update._blocks
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
Control.uncurry3 (State -> TrackId -> Track -> Track -> DiffM ()
diff_track State
st2)) forall a b. (a -> b) -> a -> b
$
        forall {k} {a}.
Ord k =>
(State -> Map k a) -> (UiDamage -> Set k) -> [(k, a, a)]
intersect State -> Map TrackId Track
Ui.state_tracks (forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. UiDamage -> Map TrackId (Ranges TrackTime)
Update._tracks)
    -- I don't diff rulers, since they have lots of things in them and rarely
    -- change.  But that means I need the UiDamage hack, and modifications
    -- must be done through Ui.modify_ruler.
    UiDamage -> State -> State -> DiffM ()
diff_state UiDamage
damage State
st1 State
st2

-- | Here's where the three different kinds of updates come together.
-- CmdUpdates are converted into UiUpdates, and then all of them converted
-- to DisplayUpdates.
postproc :: Update.UiDamage -> Ui.State
    -> ([Update.UiUpdate], [Update.DisplayUpdate])
    -> ([Update.UiUpdate], [Update.DisplayUpdate])
postproc :: UiDamage
-> State
-> ([UiUpdate], [DisplayUpdate])
-> ([UiUpdate], [DisplayUpdate])
postproc UiDamage
damage State
to_state ([UiUpdate]
ui_updates, [DisplayUpdate]
display_updates) =
    ([UiUpdate] -> [UiUpdate]
cancel_updates [UiUpdate]
ui, [DisplayUpdate]
display forall a. [a] -> [a] -> [a]
++ State -> [DisplayUpdate] -> [DisplayUpdate]
refresh_selections State
to_state [DisplayUpdate]
display)
    where
    ui :: [UiUpdate]
ui = UiDamage -> [UiUpdate]
Update.to_ui UiDamage
damage forall a. [a] -> [a] -> [a]
++ [UiUpdate]
ui_updates
    display :: [DisplayUpdate]
display = [DisplayUpdate]
display_updates forall a. [a] -> [a] -> [a]
++ [UiUpdate] -> [DisplayUpdate]
to_display (State -> [UiUpdate] -> [UiUpdate]
merge_updates State
to_state [UiUpdate]
ui)
    to_display :: [UiUpdate] -> [DisplayUpdate]
to_display = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UiUpdate -> Maybe DisplayUpdate
Update.to_display

-- | If the updates have InsertTrack or RemoveTrack the selections may have
-- been moved or deleted.  Emit updates for all selections for all views of
-- blocks with added or removed tracks.
refresh_selections :: Ui.State -> [Update.DisplayUpdate]
    -> [Update.DisplayUpdate]
refresh_selections :: State -> [DisplayUpdate] -> [DisplayUpdate]
refresh_selections State
state [DisplayUpdate]
updates = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {t} {u}. ViewId -> [Update t u]
selections [ViewId]
view_ids
    where
    view_ids :: [ViewId]
view_ids =
        [ 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)
        , forall a. Ord a => a -> Set a -> Bool
Set.member (View -> BlockId
Block.view_block View
view) Set BlockId
block_ids
        ]
    block_ids :: Set BlockId
block_ids = forall a. Ord a => [a] -> Set a
Set.fromList [BlockId
block_id |
        Update.Block BlockId
block_id Block DisplayTrack
update <-[DisplayUpdate]
updates, forall {t}. Block t -> Bool
is_track Block DisplayTrack
update]
    is_track :: Block t -> Bool
is_track (Update.RemoveTrack {}) = Bool
True
    is_track (Update.InsertTrack {}) = Bool
True
    is_track Block t
_ = Bool
False

    selections :: ViewId -> [Update t u]
selections ViewId
view_id = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
        View
view <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ViewId
view_id (State -> Map ViewId View
Ui.state_views State
state)
        let update :: Int -> Update t u
update Int
selnum = forall t u. ViewId -> View -> Update t u
Update.View ViewId
view_id forall a b. (a -> b) -> a -> b
$
                Int -> Maybe Selection -> View
Update.Selection Int
selnum
                    (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
selnum (View -> Map Int Selection
Block.view_selections View
view))
        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 {t} {u}. Int -> Update t u
update [Int
0 .. Int
Config.max_selnums forall a. Num a => a -> a -> a
- Int
1]

-- | DestroyView, DestroyBlock, DestroyTrack, and DestroyRuler cancel out
-- previous updates.
--
-- This isn't technically necessary since callers should be robust against that,
-- but cancelling means less work for them and their warnings are more likely
-- to indicate a real problem.
cancel_updates :: [Update.UiUpdate] -> [Update.UiUpdate]
cancel_updates :: [UiUpdate] -> [UiUpdate]
cancel_updates [UiUpdate]
updates = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst 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
. forall {t :: * -> *} {t} {t}.
(Foldable t, Eq t) =>
(Update t State, t (Update t State)) -> Bool
destroyed) forall a b. (a -> b) -> a -> b
$
    forall a b. [a] -> [b] -> [(a, b)]
zip [UiUpdate]
updates (forall a. Int -> [a] -> [a]
drop Int
1 (forall a. [a] -> [[a]]
List.tails [UiUpdate]
updates))
    where
    destroyed :: (Update t State, t (Update t State)) -> Bool
destroyed (Update t State
update, t (Update t State)
future) = case Update t State
update of
        Update.View ViewId
vid View
view -> case View
view of
            View
Update.DestroyView -> Bool
False
            View
_ -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== forall t u. ViewId -> View -> Update t u
Update.View ViewId
vid View
Update.DestroyView) t (Update t State)
future
        Update.Block BlockId
bid Block t
_ -> State -> Bool
future_has (BlockId -> State
Update.DestroyBlock BlockId
bid)
        Update.Track TrackId
tid Track
_ -> State -> Bool
future_has (TrackId -> State
Update.DestroyTrack TrackId
tid)
        Update.Ruler RulerId
rid -> State -> Bool
future_has (RulerId -> State
Update.DestroyRuler RulerId
rid)
        Update.State State
update -> case State
update of
            Update.CreateBlock BlockId
bid Block
_ -> State -> Bool
future_has (BlockId -> State
Update.DestroyBlock BlockId
bid)
            Update.CreateTrack TrackId
tid Track
_ -> State -> Bool
future_has (TrackId -> State
Update.DestroyTrack TrackId
tid)
            Update.CreateRuler RulerId
rid Ruler
_ -> State -> Bool
future_has (RulerId -> State
Update.DestroyRuler RulerId
rid)
            State
_ -> Bool
False
        where future_has :: State -> Bool
future_has State
destroy = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== forall t u. u -> Update t u
Update.State State
destroy) t (Update t State)
future

-- | Given the track updates, figure out which other tracks have those tracks
-- merged and should also be updated.
--
-- The track diff doesn't generate event updates at all, they are expected to
-- be collected as a side-effect of the event insertion and deletion functions.
-- But that doesn't take into account merged tracks.
merge_updates :: Ui.State -> [Update.UiUpdate] -> [Update.UiUpdate]
merge_updates :: State -> [UiUpdate] -> [UiUpdate]
merge_updates State
state [UiUpdate]
updates = [UiUpdate]
updates forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {t} {u} {t} {u}. Update t u -> [Update t u]
propagate [UiUpdate]
updates
    where
    propagate :: Update t u -> [Update t u]
propagate (Update.Track TrackId
track_id Track
update)
        | Track -> Bool
is_event_update Track
update =
            forall a b. (a -> b) -> [a] -> [b]
map (\TrackId
tid -> forall t u. TrackId -> Track -> Update t u
Update.Track TrackId
tid Track
update) [TrackId]
merges_this
        | Bool
otherwise = []
        where merges_this :: [TrackId]
merges_this = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] TrackId
track_id Map TrackId [TrackId]
merged_to_track
    propagate Update t u
_ = []
    -- For each track update, find tracks that have it in merged
    track_to_merged :: [(TrackId, Set TrackId)]
track_to_merged = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Track -> Maybe (TrackId, Set TrackId)
merged_ids_of
        (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [Track]
Block.block_tracks (forall k a. Map k a -> [a]
Map.elems (State -> Map BlockId Block
Ui.state_blocks State
state)))
    merged_ids_of :: Track -> Maybe (TrackId, Set TrackId)
merged_ids_of Track
track = case Track -> TracklikeId
Block.tracklike_id Track
track of
        Block.TId TrackId
track_id RulerId
_ -> forall a. a -> Maybe a
Just (TrackId
track_id, Track -> Set TrackId
Block.track_merged Track
track)
        TracklikeId
_ -> forall a. Maybe a
Nothing
    -- Map from a track to all tracks that merge it.
    merged_to_track :: Map TrackId [TrackId]
merged_to_track = forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap
        [ (TrackId
merged_id, TrackId
track_id)
        | (TrackId
track_id, Set TrackId
merged_ids) <- [(TrackId, Set TrackId)]
track_to_merged
        , TrackId
merged_id <- forall a. Set a -> [a]
Set.toList Set TrackId
merged_ids
        ]
    is_event_update :: Track -> Bool
is_event_update (Update.TrackEvents {}) = Bool
True
    is_event_update Update.TrackAllEvents {} = Bool
True
    is_event_update Track
_ = Bool
False

-- ** view

diff_views :: Ui.State -> Ui.State -> Update.UiDamage -> DiffM ()
diff_views :: State -> State -> UiDamage -> DiffM ()
diff_views State
st1 State
st2 UiDamage
damage =
    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 (State -> State -> ViewId -> Paired View View -> DiffM ()
diff_view_pair State
st1 State
st2)) forall a b. (a -> b) -> a -> b
$
        forall k a val state.
Ord k =>
(Map k a -> Map k a -> val)
-> state -> state -> (state -> Map k a) -> Set k -> val
damaged forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs State
st1 State
st2 State -> Map ViewId View
Ui.state_views (UiDamage -> Set ViewId
Update._views UiDamage
damage)

diff_view_pair :: Ui.State -> Ui.State -> ViewId
    -> Lists.Paired Block.View Block.View -> DiffM ()
diff_view_pair :: State -> State -> ViewId -> Paired View View -> DiffM ()
diff_view_pair State
st1 State
st2 ViewId
view_id = \case
    Lists.Second View
_ -> UiUpdate -> DiffM ()
change forall a b. (a -> b) -> a -> b
$ forall t u. ViewId -> View -> Update t u
Update.View ViewId
view_id View
Update.CreateView
    Lists.First View
_ -> UiUpdate -> DiffM ()
change forall a b. (a -> b) -> a -> b
$ forall t u. ViewId -> View -> Update t u
Update.View ViewId
view_id View
Update.DestroyView
    Lists.Both View
view1 View
view2
        | View -> BlockId
Block.view_block View
view1 forall a. Eq a => a -> a -> Bool
/= View -> BlockId
Block.view_block View
view2 -> do
            UiUpdate -> DiffM ()
change forall a b. (a -> b) -> a -> b
$ forall t u. ViewId -> View -> Update t u
Update.View ViewId
view_id View
Update.DestroyView
            UiUpdate -> DiffM ()
change forall a b. (a -> b) -> a -> b
$ forall t u. ViewId -> View -> Update t u
Update.View ViewId
view_id View
Update.CreateView
        | Bool
otherwise -> State -> State -> ViewId -> View -> View -> DiffM ()
diff_view State
st1 State
st2 ViewId
view_id View
view1 View
view2

diff_view :: Ui.State -> Ui.State -> ViewId -> Block.View -> Block.View
    -> DiffM ()
diff_view :: State -> State -> ViewId -> View -> View -> DiffM ()
diff_view State
st1 State
st2 ViewId
view_id View
view1 View
view2 = do
    let emit :: View -> DiffM ()
emit = UiUpdate -> DiffM ()
change forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t u. ViewId -> View -> Update t u
Update.View ViewId
view_id
    let unequal :: (View -> k) -> Bool
unequal View -> k
f = forall k a. Eq k => (a -> k) -> a -> a -> Bool
unequal_on View -> k
f View
view1 View
view2
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (View -> k) -> Bool
unequal View -> Rect
Block.view_rect) forall a b. (a -> b) -> a -> b
$
        View -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Rect -> View
Update.ViewSize (View -> Rect
Block.view_rect View
view2)
    let color :: Color
color = State -> View -> Color
status_color State
st2 View
view2
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (View -> k) -> Bool
unequal View -> Map (Int, Text) Text
Block.view_status Bool -> Bool -> Bool
|| State -> View -> Color
status_color State
st1 View
view1 forall a. Eq a => a -> a -> Bool
/= Color
color) forall a b. (a -> b) -> a -> b
$
        View -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Map (Int, Text) Text -> Color -> View
Update.Status (View -> Map (Int, Text) Text
Block.view_status View
view2) Color
color
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (View -> k) -> Bool
unequal View -> Int
Block.view_track_scroll) forall a b. (a -> b) -> a -> b
$
        View -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Int -> View
Update.TrackScroll (View -> Int
Block.view_track_scroll View
view2)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (View -> k) -> Bool
unequal View -> Zoom
Block.view_zoom) forall a b. (a -> b) -> a -> b
$
        View -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Zoom -> View
Update.Zoom (View -> Zoom
Block.view_zoom View
view2)

    -- If the view doesn't have a block I should have failed long before here.
    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 ((View -> DiffM ()) -> Int -> Paired Selection Selection -> DiffM ()
diff_selection View -> DiffM ()
emit))
        (forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs (View -> Map Int Selection
Block.view_selections View
view1) (View -> Map Int Selection
Block.view_selections View
view2))

status_color :: Ui.State -> Block.View -> Color.Color
status_color :: State -> View -> Color
status_color State
state View
view =
    case 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) of
        Just Block
block -> BlockId -> Block -> Maybe BlockId -> Color
Block.status_color BlockId
block_id Block
block
            (Config -> Maybe BlockId
UiConfig.config_root (State -> Config
Ui.state_config State
state))
        Maybe Block
Nothing -> Color
Config.status_default
    where block_id :: BlockId
block_id = View -> BlockId
Block.view_block View
view

diff_selection :: (Update.View -> DiffM ())
    -> Sel.Num -> Lists.Paired Sel.Selection Sel.Selection -> DiffM ()
diff_selection :: (View -> DiffM ()) -> Int -> Paired Selection Selection -> DiffM ()
diff_selection View -> DiffM ()
_ Int
_ (Lists.Both Selection
sel1 Selection
sel2) | Selection
sel1 forall a. Eq a => a -> a -> Bool
== Selection
sel2 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
diff_selection View -> DiffM ()
emit Int
selnum Paired Selection Selection
paired = case Paired Selection Selection
paired of
    Lists.Both Selection
sel1 Selection
sel2
        | Selection
sel1 forall a. Eq a => a -> a -> Bool
/= Selection
sel2 -> View -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Int -> Maybe Selection -> View
Update.Selection Int
selnum (forall a. a -> Maybe a
Just Selection
sel2)
    Lists.Second Selection
sel2 -> View -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Int -> Maybe Selection -> View
Update.Selection Int
selnum (forall a. a -> Maybe a
Just Selection
sel2)
    Lists.First Selection
_ -> View -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Int -> Maybe Selection -> View
Update.Selection Int
selnum forall a. Maybe a
Nothing
    Paired Selection Selection
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- ** block / track / ruler

diff_block :: BlockId -> Block.Block -> Block.Block -> DiffM ()
diff_block :: BlockId -> Block -> Block -> DiffM ()
diff_block BlockId
block_id Block
block1 Block
block2 = do
    let emit :: Block Track -> DiffM ()
emit = UiUpdate -> DiffM ()
change forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t u. BlockId -> Block t -> Update t u
Update.Block BlockId
block_id
    let unequal :: (Block -> k) -> Bool
unequal Block -> k
f = forall k a. Eq k => (a -> k) -> a -> a -> Bool
unequal_on Block -> k
f Block
block1 Block
block2
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (Block -> k) -> Bool
unequal Block -> Text
Block.block_title) forall a b. (a -> b) -> a -> b
$
        Block Track -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ forall t. Text -> Block t
Update.BlockTitle (Block -> Text
Block.block_title Block
block2)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (Block -> k) -> Bool
unequal Block -> Config
Block.block_config) forall a b. (a -> b) -> a -> b
$
        Block Track -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ forall t. Config -> Block t
Update.BlockConfig (Block -> Config
Block.block_config Block
block2)

    let dtracks1 :: [DisplayTrack]
dtracks1 = Block -> [DisplayTrack]
Block.block_display_tracks Block
block1
        dtracks2 :: [DisplayTrack]
dtracks2 = Block -> [DisplayTrack]
Block.block_display_tracks Block
block2
    let int_skel1 :: [(Color, [(Int, Int)])]
int_skel1 = Block -> [(Color, [(Int, Int)])]
Block.integrate_skeleton Block
block1
        int_skel2 :: [(Color, [(Int, Int)])]
int_skel2 = Block -> [(Color, [(Int, Int)])]
Block.integrate_skeleton Block
block2
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (Block -> k) -> Bool
unequal Block -> Skeleton
Block.block_skeleton Bool -> Bool -> Bool
|| [(Color, [(Int, Int)])]
int_skel1 forall a. Eq a => a -> a -> Bool
/= [(Color, [(Int, Int)])]
int_skel2) forall a b. (a -> b) -> a -> b
$ do
        Block Track -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ forall t. Skeleton -> [(Color, [(Int, Int)])] -> Block t
Update.BlockSkeleton (Block -> Skeleton
Block.block_skeleton Block
block2) [(Color, [(Int, Int)])]
int_skel2
        -- Changing the skeleton may change event styles.
        [UiUpdate] -> DiffM ()
changes [forall t u. TrackId -> Track -> Update t u
Update.Track TrackId
track_id Track
Update.TrackAllEvents
            | TrackId
track_id <- Block -> [TrackId]
Block.block_track_ids Block
block2]

    let btracks1 :: [Track]
btracks1 = Block -> [Track]
Block.block_tracks Block
block1
        btracks2 :: [Track]
btracks2 = Block -> [Track]
Block.block_tracks Block
block2
    let bpairs :: [(Int, Paired Track Track)]
bpairs = forall k a. Eq k => (a -> k) -> [a] -> [a] -> [(Int, Paired a a)]
Lists.diffIndexOn Track -> TracklikeId
Block.tracklike_id [Track]
btracks1 [Track]
btracks2
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, Paired Track Track)]
bpairs forall a b. (a -> b) -> a -> b
$ \(Int
i2, Paired Track Track
paired) -> case Paired Track Track
paired of
        Lists.First Track
_ -> Block Track -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ forall t. Int -> Block t
Update.RemoveTrack Int
i2
        Lists.Second Track
track -> Block Track -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ forall t. Int -> t -> Block t
Update.InsertTrack Int
i2 Track
track
        Lists.Both Track
track1 Track
track2 | Track
track1 forall a. Eq a => a -> a -> Bool
/= Track
track2 ->
            Block Track -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ forall t. Int -> t -> Block t
Update.BlockTrack Int
i2 Track
track2
        Paired Track Track
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    let dpairs :: [(Int, Paired DisplayTrack DisplayTrack)]
dpairs = forall k a. Eq k => (a -> k) -> [a] -> [a] -> [(Int, Paired a a)]
Lists.diffIndexOn DisplayTrack -> TracklikeId
Block.dtracklike_id [DisplayTrack]
dtracks1 [DisplayTrack]
dtracks2
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, Paired DisplayTrack DisplayTrack)]
dpairs forall a b. (a -> b) -> a -> b
$ \(Int
i2, Paired DisplayTrack DisplayTrack
paired) -> case Paired DisplayTrack DisplayTrack
paired of
        -- Insert and remove are emitted for UiDamage above, but
        -- the Update.to_display conversion filters them out.
        Lists.First DisplayTrack
_ -> DisplayUpdate -> DiffM ()
change_display forall a b. (a -> b) -> a -> b
$
            forall t u. BlockId -> Block t -> Update t u
Update.Block BlockId
block_id (forall t. Int -> Block t
Update.RemoveTrack Int
i2)
        Lists.Second DisplayTrack
dtrack -> DisplayUpdate -> DiffM ()
change_display forall a b. (a -> b) -> a -> b
$
            forall t u. BlockId -> Block t -> Update t u
Update.Block BlockId
block_id (forall t. Int -> t -> Block t
Update.InsertTrack Int
i2 DisplayTrack
dtrack)
        Lists.Both DisplayTrack
dtrack1 DisplayTrack
dtrack2 | DisplayTrack
dtrack1 forall a. Eq a => a -> a -> Bool
/= DisplayTrack
dtrack2 -> DisplayUpdate -> DiffM ()
change_display forall a b. (a -> b) -> a -> b
$
            forall t u. BlockId -> Block t -> Update t u
Update.Block BlockId
block_id (forall t. Int -> t -> Block t
Update.BlockTrack Int
i2 DisplayTrack
dtrack2)
        Paired DisplayTrack DisplayTrack
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

diff_track :: Ui.State -> TrackId -> Track.Track -> Track.Track -> DiffM ()
diff_track :: State -> TrackId -> Track -> Track -> DiffM ()
diff_track State
state TrackId
track_id Track
track1 Track
track2 = do
    -- Track events updates are collected directly by the Ui.State functions
    -- as they happen.
    let emit :: Track -> DiffM ()
emit = UiUpdate -> DiffM ()
change forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t u. TrackId -> Track -> Update t u
Update.Track TrackId
track_id
    let unequal :: (Track -> k) -> Bool
unequal Track -> k
f = forall k a. Eq k => (a -> k) -> a -> a -> Bool
unequal_on Track -> k
f Track
track1 Track
track2
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (Track -> k) -> Bool
unequal Track -> Text
Track.track_title) forall a b. (a -> b) -> a -> b
$ do
        Track -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Text -> Track
Update.TrackTitle (Track -> Text
Track.track_title Track
track2)
        -- Changing the title may change the type of the track, which may
        -- change event styles.  If it's going from non-note to note track, it
        -- can also change style of siblings since has_note_children becomes
        -- true.
        [UiUpdate] -> DiffM ()
changes [forall t u. TrackId -> Track -> Update t u
Update.Track TrackId
tid Track
Update.TrackAllEvents
            | TrackId
tid <- State -> TrackId -> [TrackId]
sibling_tracks State
state TrackId
track_id]

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (Track -> k) -> Bool
unequal Track -> Color
Track.track_bg) forall a b. (a -> b) -> a -> b
$
        Track -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Color -> Track
Update.TrackBg (Track -> Color
Track.track_bg Track
track2)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (Track -> k) -> Bool
unequal Track -> RenderConfig
Track.track_render) forall a b. (a -> b) -> a -> b
$
        Track -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ RenderConfig -> Track
Update.TrackRender (Track -> RenderConfig
Track.track_render Track
track2)

sibling_tracks :: Ui.State -> TrackId -> [TrackId]
sibling_tracks :: State -> TrackId -> [TrackId]
sibling_tracks State
state TrackId
track_id = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) 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
$ do
    [(BlockId, [(Int, TracklikeId)])]
blocks <- forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(Int, TracklikeId)])]
Ui.blocks_with_track_id TrackId
track_id
    forall (m :: * -> *) a. Monad m => a -> m a
return [TrackId
tid | (BlockId
_, [(Int, TracklikeId)]
tracks) <- [(BlockId, [(Int, TracklikeId)])]
blocks, (Int
_, Block.TId TrackId
tid RulerId
_) <- [(Int, TracklikeId)]
tracks]

-- ** state

diff_state :: Update.UiDamage -> Ui.State -> Ui.State -> DiffM ()
diff_state :: UiDamage -> State -> State -> DiffM ()
diff_state UiDamage
damage State
st1 State
st2 = do
    let emit :: State -> DiffM ()
emit = UiUpdate -> DiffM ()
change forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t u. u -> Update t u
Update.State
    let pairs :: (State -> Map k a) -> (UiDamage -> Set k) -> [(k, Paired a a)]
pairs State -> Map k a
get UiDamage -> Set k
keys = forall k a val state.
Ord k =>
(Map k a -> Map k a -> val)
-> state -> state -> (state -> Map k a) -> Set k -> val
damaged forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs State
st1 State
st2 State -> Map k a
get (UiDamage -> Set k
keys UiDamage
damage)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State -> Config
Ui.state_config State
st1 forall a. Eq a => a -> a -> Bool
/= State -> Config
Ui.state_config State
st2) forall a b. (a -> b) -> a -> b
$
        State -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ Config -> State
Update.Config (State -> Config
Ui.state_config State
st2)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall {k} {a}.
Ord k =>
(State -> Map k a) -> (UiDamage -> Set k) -> [(k, Paired a a)]
pairs State -> Map BlockId Block
Ui.state_blocks UiDamage -> Set BlockId
Update._blocks) forall a b. (a -> b) -> a -> b
$ \(BlockId
block_id, Paired Block Block
paired) ->
        case Paired Block Block
paired of
            Lists.Second Block
block -> State -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ BlockId -> Block -> State
Update.CreateBlock BlockId
block_id Block
block
            Lists.First Block
_ -> State -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ BlockId -> State
Update.DestroyBlock BlockId
block_id
            Paired Block Block
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall {k} {a}.
Ord k =>
(State -> Map k a) -> (UiDamage -> Set k) -> [(k, Paired a a)]
pairs State -> Map TrackId Track
Ui.state_tracks (forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. UiDamage -> Map TrackId (Ranges TrackTime)
Update._tracks)) forall a b. (a -> b) -> a -> b
$
        \(TrackId
track_id, Paired Track Track
paired) -> case Paired Track Track
paired of
            Lists.Second Track
track -> State -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ TrackId -> Track -> State
Update.CreateTrack TrackId
track_id Track
track
            Lists.First Track
_ -> State -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ TrackId -> State
Update.DestroyTrack TrackId
track_id
            Paired Track Track
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall {k} {a}.
Ord k =>
(State -> Map k a) -> (UiDamage -> Set k) -> [(k, Paired a a)]
pairs State -> Map RulerId Ruler
Ui.state_rulers UiDamage -> Set RulerId
Update._rulers) forall a b. (a -> b) -> a -> b
$ \(RulerId
ruler_id, Paired Ruler Ruler
paired) ->
        case Paired Ruler Ruler
paired of
            Lists.Second Ruler
ruler -> State -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ RulerId -> Ruler -> State
Update.CreateRuler RulerId
ruler_id Ruler
ruler
            Lists.First Ruler
_ -> State -> DiffM ()
emit forall a b. (a -> b) -> a -> b
$ RulerId -> State
Update.DestroyRuler RulerId
ruler_id
            Paired Ruler Ruler
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- * derive diff

type DeriveDiffM a = Writer.WriterT Derive.ScoreDamage Identity.Identity a

run_derive_diff :: DeriveDiffM () -> Derive.ScoreDamage
run_derive_diff :: DeriveDiffM () -> ScoreDamage
run_derive_diff = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Writer.runWriterT

-- | This diff is meant to determine score damage for the block, which
-- determines what will have to be rederived, if anything.
--
-- This is repeating some work done in 'diff', but is fundamentally different
-- because it cares about nonvisible changes, e.g. track title change on
-- a block without a view.
derive_diff :: Ui.State -> Ui.State -> Update.UiDamage -> [Update.UiUpdate]
    -> Derive.ScoreDamage
derive_diff :: State -> State -> UiDamage -> [UiUpdate] -> ScoreDamage
derive_diff State
st1 State
st2 UiDamage
damage [UiUpdate]
updates = ScoreDamage -> ScoreDamage
postproc forall a b. (a -> b) -> a -> b
$ DeriveDiffM () -> ScoreDamage
run_derive_diff forall a b. (a -> b) -> a -> b
$
    -- If the config has changed, then everything is damaged.
    if forall k a. Eq k => (a -> k) -> a -> a -> Bool
unequal_on State -> Config
Ui.state_config State
st1 State
st2
    then forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
        { sdamage_blocks :: Set BlockId
Derive.sdamage_blocks =
            forall k a. Map k a -> Set k
Map.keysSet (State -> Map BlockId Block
Ui.state_blocks State
st1)
            forall a. Semigroup a => a -> a -> a
<> forall k a. Map k a -> Set k
Map.keysSet (State -> Map BlockId Block
Ui.state_blocks State
st2)
        }
    else do
        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 BlockId -> Paired Block Block -> DeriveDiffM ()
derive_diff_block) forall a b. (a -> b) -> a -> b
$
            forall k a val state.
Ord k =>
(Map k a -> Map k a -> val)
-> state -> state -> (state -> Map k a) -> Set k -> val
damaged forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs State
st1 State
st2 State -> Map BlockId Block
Ui.state_blocks (UiDamage -> Set BlockId
Update._blocks UiDamage
damage)
        -- This doesn't check for added or removed tracks, because for them to
        -- have any effect they must be added to or removed from a block, which
        -- 'derive_diff_block' will catch.
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
Control.uncurry3 TrackId -> Track -> Track -> DeriveDiffM ()
derive_diff_track) forall a b. (a -> b) -> a -> b
$
            forall k a val state.
Ord k =>
(Map k a -> Map k a -> val)
-> state -> state -> (state -> Map k a) -> Set k -> val
damaged forall k v1 v2. Ord k => Map k v1 -> Map k v2 -> [(k, v1, v2)]
Maps.zipIntersection State
st1 State
st2 State -> Map TrackId Track
Ui.state_tracks
                (forall k a. Map k a -> Set k
Map.keysSet (UiDamage -> Map TrackId (Ranges TrackTime)
Update._tracks UiDamage
damage))
    where
    postproc :: ScoreDamage -> ScoreDamage
postproc = State -> ScoreDamage -> ScoreDamage
postproc_damage State
st2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map RulerId [BlockId] -> [UiUpdate] -> ScoreDamage
updates_damage Map RulerId [BlockId]
block_rulers [UiUpdate]
updates <>)
    block_rulers :: Map RulerId [BlockId]
block_rulers = forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap
        [ (RulerId
ruler_id, BlockId
block_id)
        | (BlockId
block_id, Block
block) <- forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map BlockId Block
Ui.state_blocks State
st2)
        , RulerId
ruler_id <- Block -> [RulerId]
Block.block_ruler_ids Block
block
        ]

-- | Apply a function to only the damaged parts of the state, as expressed
-- by a Set of keys.
damaged :: Ord k => (Map k a -> Map k a -> val) -> state -> state
    -> (state -> Map k a) -> Set k -> val
damaged :: forall k a val state.
Ord k =>
(Map k a -> Map k a -> val)
-> state -> state -> (state -> Map k a) -> Set k -> val
damaged Map k a -> Map k a -> val
f state
st1 state
st2 state -> Map k a
get Set k
keys =
    Map k a -> Map k a -> val
f (forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (state -> Map k a
get state
st1) Set k
keys) (forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (state -> Map k a
get state
st2) Set k
keys)

-- | Fill in 'Derive.sdamage_track_blocks'.
postproc_damage :: Ui.State -> Derive.ScoreDamage -> Derive.ScoreDamage
postproc_damage :: State -> ScoreDamage -> ScoreDamage
postproc_damage State
state (Derive.ScoreDamage Map TrackId (Ranges TrackTime)
tracks Set BlockId
_ Set BlockId
blocks) =
    Map TrackId (Ranges TrackTime)
-> Set BlockId -> Set BlockId -> ScoreDamage
Derive.ScoreDamage Map TrackId (Ranges TrackTime)
tracks Set BlockId
track_blocks Set BlockId
blocks
    where
    track_blocks :: Set BlockId
track_blocks = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ (TracklikeId -> Bool)
-> Map BlockId Block -> [(BlockId, [(Int, TracklikeId)])]
Ui.find_tracks TracklikeId -> Bool
track_of_block
        (State -> Map BlockId Block
Ui.state_blocks State
state)
    track_of_block :: TracklikeId -> Bool
track_of_block (Block.TId TrackId
tid RulerId
_) = forall k a. Ord k => k -> Map k a -> Bool
Map.member TrackId
tid Map TrackId (Ranges TrackTime)
tracks
    track_of_block TracklikeId
_ = Bool
False

-- | Derive damage from UiUpdates.
updates_damage :: Map RulerId [BlockId] -> [Update.UiUpdate]
    -> Derive.ScoreDamage
updates_damage :: Map RulerId [BlockId] -> [UiUpdate] -> ScoreDamage
updates_damage Map RulerId [BlockId]
block_rulers [UiUpdate]
updates = forall a. Monoid a => a
mempty
    { sdamage_tracks :: Map TrackId (Ranges TrackTime)
Derive.sdamage_tracks = Map TrackId (Ranges TrackTime)
tracks
    , sdamage_blocks :: Set BlockId
Derive.sdamage_blocks = Set BlockId
blocks
    }
    where
    tracks :: Map TrackId (Ranges TrackTime)
tracks = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UiUpdate -> Maybe (TrackId, Ranges TrackTime)
Update.track_changed [UiUpdate]
updates
    blocks :: Set BlockId
blocks = forall a. Ord a => [a] -> Set a
Set.fromList
        [ BlockId
block_id
        | Update.Ruler RulerId
ruler_id <- [UiUpdate]
updates
        , BlockId
block_id <- forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] RulerId
ruler_id Map RulerId [BlockId]
block_rulers
        ]

derive_diff_block :: BlockId -> Lists.Paired Block.Block Block.Block
    -> DeriveDiffM ()
derive_diff_block :: BlockId -> Paired Block Block -> DeriveDiffM ()
derive_diff_block BlockId
block_id = \case
    Lists.Both Block
block1 Block
block2 -> do
        let unequal :: (Block -> k) -> Bool
unequal Block -> k
f = forall k a. Eq k => (a -> k) -> a -> a -> Bool
unequal_on Block -> k
f Block
block1 Block
block2
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (Block -> k) -> Bool
unequal (Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Text
Block.block_title)
                Bool -> Bool -> Bool
|| forall {k}. Eq k => (Block -> k) -> Bool
unequal Block -> Skeleton
Block.block_skeleton)
                -- I could check (Block.config_skeleton . Block.block_config),
                -- but it's indirect, the skeleton change is the direct affect
                -- on derivation.
            DeriveDiffM ()
block_damage
        let ([Track]
ts1, [Track]
ts2) = (Block -> [Track]
Block.block_tracks Block
block1, Block -> [Track]
Block.block_tracks Block
block2)
        let tpairs :: [(Int, Paired Track Track)]
tpairs = forall k a. Eq k => (a -> k) -> [a] -> [a] -> [(Int, Paired a a)]
Lists.diffIndexOn Track -> TracklikeId
Block.tracklike_id [Track]
ts1 [Track]
ts2
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, Paired Track Track)]
tpairs forall a b. (a -> b) -> a -> b
$ \(Int
_, Paired Track Track
pair) -> case Paired Track Track
pair of
            Lists.Both Track
track1 Track
track2
                | Track -> Track -> Bool
flags_differ Track
track1 Track
track2 -> DeriveDiffM ()
block_damage
                | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Paired Track Track
_ -> DeriveDiffM ()
block_damage
    -- This means I wind up with damage on a block that is gone.  I think this
    -- is correct, since the cache will still have recorded dependencies on
    -- that block, which will cause its dependents to be rederived, as
    -- expected.
    Lists.First Block
_ -> DeriveDiffM ()
block_damage
    Lists.Second Block
_ -> DeriveDiffM ()
block_damage
    where
    block_damage :: DeriveDiffM ()
block_damage =
        forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty { sdamage_blocks :: Set BlockId
Derive.sdamage_blocks = forall a. a -> Set a
Set.singleton BlockId
block_id }

-- | True if the tracks flags differ in an a way that will require
-- rederivation.
flags_differ :: Block.Track -> Block.Track -> Bool
flags_differ :: Track -> Track -> Bool
flags_differ Track
track1 Track
track2 = Track -> Set TrackFlag
relevant Track
track1 forall a. Eq a => a -> a -> Bool
/= Track -> Set TrackFlag
relevant Track
track2
    where
    relevant :: Track -> Set TrackFlag
relevant = forall a. (a -> Bool) -> Set a -> Set a
Set.filter TrackFlag -> Bool
must_rederive forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Set TrackFlag
Block.track_flags
    must_rederive :: TrackFlag -> Bool
must_rederive TrackFlag
flag = case TrackFlag
flag of
        -- If this was an uncollapse, I may need a track signal for it now.
        -- Another way to solve this would be to emit track signals for
        -- collapsed tracks, but lots of tracks are collapsed and usually not
        -- expanded, and I'd like derivation to be efficient.
        TrackFlag
Block.Collapse -> Bool
True
        TrackFlag
Block.Merge -> Bool
True
        -- These flags are handled by filtering in the player.
        TrackFlag
Block.Solo -> Bool
False
        TrackFlag
Block.Mute -> Bool
False
        TrackFlag
Block.Disable -> Bool
True

derive_diff_track :: TrackId -> Track.Track -> Track.Track -> DeriveDiffM ()
derive_diff_track :: TrackId -> Track -> Track -> DeriveDiffM ()
derive_diff_track TrackId
track_id Track
track1 Track
track2 =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k}. Eq k => (Track -> k) -> Bool
unequal (Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Text
Track.track_title)
            Bool -> Bool -> Bool
|| forall {k}. Eq k => (Track -> k) -> Bool
unequal Track -> RenderConfig
Track.track_render) forall a b. (a -> b) -> a -> b
$
        forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
            { sdamage_tracks :: Map TrackId (Ranges TrackTime)
Derive.sdamage_tracks = forall k a. k -> a -> Map k a
Map.singleton TrackId
track_id forall n. Ranges n
Ranges.everything }
    where
    unequal :: (Track -> k) -> Bool
unequal Track -> k
f = forall k a. Eq k => (a -> k) -> a -> a -> Bool
unequal_on Track -> k
f Track
track1 Track
track2

-- * score_changed

-- | This is like 'derive_diff', but it only needs to return a Bool.  It's also
-- more sensitive in that it's looking for any change that you might want to
-- save to disk, not just changes that could require rederivation.
score_changed :: Ui.State -> Ui.State -> Update.UiDamage -> Bool
score_changed :: State -> State -> UiDamage -> Bool
score_changed State
st1 State
st2 UiDamage
damage = forall (t :: * -> *). Foldable t => t Bool -> Bool
or
    [ UiDamage -> Bool
Update.is_score_damage UiDamage
damage
    , forall {k}. Eq k => (State -> k) -> Bool
unequal State -> Config
Ui.state_config
    ]
    where unequal :: (State -> k) -> Bool
unequal State -> k
f = forall k a. Eq k => (a -> k) -> a -> a -> Bool
unequal_on State -> k
f State
st1 State
st2

-- * events diff

-- | Diff the events on one track.  This will only emit track damage, and won't
-- emit anything if the track title changed, or was created or deleted.  Those
-- diffs should be picked up by the main 'diff'.
track_diff :: Ui.State -> Ui.State -> TrackId -> Update.UiDamage
track_diff :: State -> State -> TrackId -> UiDamage
track_diff State
st1 State
st2 TrackId
tid = case (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
tid Map TrackId Track
t1, forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
tid Map TrackId Track
t2) of
    -- TODO why does it compare track_title here?
    (Just Track
t1, Just Track
t2) | Track -> Text
Track.track_title Track
t1 forall a. Eq a => a -> a -> Bool
== Track -> Text
Track.track_title Track
t2 -> forall a. Monoid a => a
mempty
        { _tracks :: Map TrackId (Ranges TrackTime)
Update._tracks = forall k a. k -> a -> Map k a
Map.singleton TrackId
tid forall a b. (a -> b) -> a -> b
$
            Events -> Events -> Ranges TrackTime
diff_track_events (Track -> Events
Track.track_events Track
t1) (Track -> Events
Track.track_events Track
t2)
        }
    (Maybe Track, Maybe Track)
_ -> forall a. Monoid a => a
mempty
    where
    t1 :: Map TrackId Track
t1 = State -> Map TrackId Track
Ui.state_tracks State
st1
    t2 :: Map TrackId Track
t2 = State -> Map TrackId Track
Ui.state_tracks State
st2

diff_track_events :: Events.Events -> Events.Events -> Ranges.Ranges TrackTime
diff_track_events :: Events -> Events -> Ranges TrackTime
diff_track_events Events
e1 Events
e2 =
    forall n. Ord n => [(n, n)] -> Ranges n
Ranges.sorted_ranges forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Paired Event Event -> Maybe (TrackTime, TrackTime)
diff forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => (a -> k) -> [a] -> [a] -> [Paired a a]
Lists.pairSortedOn1 Event -> TrackTime
Event.start
            (Events -> [Event]
Events.ascending Events
e1) (Events -> [Event]
Events.ascending Events
e2)
    where
    diff :: Paired Event Event -> Maybe (TrackTime, TrackTime)
diff (Lists.First Event
e) = forall a. a -> Maybe a
Just (Event -> (TrackTime, TrackTime)
Event.range Event
e)
    diff (Lists.Second Event
e) = forall a. a -> Maybe a
Just (Event -> (TrackTime, TrackTime)
Event.range Event
e)
    diff (Lists.Both Event
e1 Event
e2)
        | Event
e1 forall a. Eq a => a -> a -> Bool
== Event
e2 = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just (Event -> TrackTime
Event.start Event
e1, forall a. Ord a => a -> a -> a
max (Event -> TrackTime
Event.end Event
e1) (Event -> TrackTime
Event.end Event
e2))


-- * util

unequal_on :: Eq k => (a -> k) -> a -> a -> Bool
unequal_on :: forall k a. Eq k => (a -> k) -> a -> a -> Bool
unequal_on a -> k
key a
a a
b = a -> k
key a
a forall a. Eq a => a -> a -> Bool
/= a -> k
key a
b