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