-- Copyright 2013 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt {-# LANGUAGE CPP #-} {- | Merge integrated tracks into existing, possibly hand-edited tracks, using the index of the previous integration to figure out which edits were made. This proceeds in two steps: first the tracks are matched up. This takes advantage of the two-level (note, controls) hierarchy emitted by "Cmd.Integrate.Convert", since each control track is uniquely identified by its title, it's safe to just match them up by title. However, there's no key to match up the note tracks themselves, so it's done purely based on the order of the tracks. So if the integrate source emits more simultaneous notes and Convert puts them on appended tracks all will be well, but if it prepends a new track then the later tracks won't line up with the index. This will result in bogus diffs, or just events not being found at all and being considered hand-added. TODO I'll have to see from experience if this is a problem, and if so, how it can be fixed. Once tracks are matched, the events are diffed based on the 'Event.IndexKey'. -} module Cmd.Integrate.Merge ( -- * create create_block -- * merge , MergeTitles(..) , merge_block, score_merge_block, merge_tracks , score_merge_tracks , Edit(..), Modify(..), is_modified -- * diff , diff_events #ifdef TESTING , make_index , diff, diff_event, apply #endif ) where import qualified Data.Either as Either import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Traversable as Traversable import qualified Data.Tree as Tree import qualified Util.Pretty as Pretty import qualified Util.Lists as Lists import qualified Util.Trees as Trees import qualified Cmd.Create as Create import qualified Cmd.Integrate.Convert as Convert import qualified Derive.Stack as Stack import qualified Ui.Block as Block import qualified Ui.Event as Event import qualified Ui.Events as Events import qualified Ui.Skeleton as Skeleton import qualified Ui.Track as Track import qualified Ui.TrackTree as TrackTree import qualified Ui.Ui as Ui import Global import Types -- * block create_block :: Ui.M m => BlockId -> Convert.Tracks -> m (BlockId, [Block.NoteDestination]) create_block :: forall (m :: * -> *). M m => BlockId -> Tracks -> m (BlockId, [NoteDestination]) create_block BlockId source_id Tracks tracks = do RulerId ruler_id <- forall (m :: * -> *). M m => BlockId -> m RulerId Ui.block_ruler BlockId source_id BlockId dest_id <- forall (m :: * -> *). M m => RulerId -> m BlockId Create.block RulerId ruler_id (,) BlockId dest_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination] merge_block BlockId dest_id Tracks tracks [] merge_block :: Ui.M m => BlockId -> Convert.Tracks -> [Block.NoteDestination] -> m [Block.NoteDestination] merge_block :: forall (m :: * -> *). M m => BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination] merge_block = forall (m :: * -> *). M m => MergeTitles -> BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination] merge_tracks MergeTitles KeepTitles score_merge_block :: Ui.M m => BlockId -> BlockId -> Block.ScoreDestinations -> m Block.ScoreDestinations score_merge_block :: forall (m :: * -> *). M m => BlockId -> BlockId -> ScoreDestinations -> m ScoreDestinations score_merge_block BlockId source_id BlockId dest_id ScoreDestinations dests = do TrackTree tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree TrackTree.track_tree_of BlockId source_id forall (m :: * -> *). M m => BlockId -> TrackTree -> ScoreDestinations -> m ScoreDestinations score_merge BlockId dest_id TrackTree tree ScoreDestinations dests -- * tracks data MergeTitles = KeepTitles -- ^ leave the titles of merged tracks alone | ReplaceTitles -- ^ replace titles with the merge source deriving (MergeTitles -> MergeTitles -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: MergeTitles -> MergeTitles -> Bool $c/= :: MergeTitles -> MergeTitles -> Bool == :: MergeTitles -> MergeTitles -> Bool $c== :: MergeTitles -> MergeTitles -> Bool Eq, Int -> MergeTitles -> ShowS [MergeTitles] -> ShowS MergeTitles -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [MergeTitles] -> ShowS $cshowList :: [MergeTitles] -> ShowS show :: MergeTitles -> String $cshow :: MergeTitles -> String showsPrec :: Int -> MergeTitles -> ShowS $cshowsPrec :: Int -> MergeTitles -> ShowS Show) -- | Given a set of source 'Convert.Tracks' and a set of previously integrated -- destination tracks, merge them together and give new destination tracks. -- A single integrating source track can create multiple Convert.Tracks, and -- an integrating track can have >=1 destinations, so this is called once per -- (source, destination) pair. merge_tracks :: Ui.M m => MergeTitles -> BlockId -> Convert.Tracks -> [Block.NoteDestination] -> m [Block.NoteDestination] merge_tracks :: forall (m :: * -> *). M m => MergeTitles -> BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination] merge_tracks MergeTitles merge_titles BlockId block_id Tracks tracks [NoteDestination] dests = do [Maybe TrackId] track_ids <- forall (m :: * -> *). M m => BlockId -> m [Maybe TrackId] all_block_tracks BlockId block_id [NoteDestination] new_dests <- forall (m :: * -> *) a b. Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM (forall (m :: * -> *). M m => MergeTitles -> BlockId -> [TrackPair] -> m (Maybe NoteDestination) merge_pairs MergeTitles merge_titles BlockId block_id) forall a b. (a -> b) -> a -> b $ [Maybe TrackId] -> Tracks -> [NoteDestination] -> [[TrackPair]] pair_tracks [Maybe TrackId] track_ids Tracks tracks [NoteDestination] dests -- TODO doesn't this combine with the old skeleton? Why isn't that -- a problem? forall (m :: * -> *). M m => BlockId -> [NoteDestination] -> m () add_derive_skeleton BlockId block_id [NoteDestination] new_dests forall (m :: * -> *) a. Monad m => a -> m a return [NoteDestination] new_dests add_derive_skeleton :: Ui.M m => BlockId -> [Block.NoteDestination] -> m () add_derive_skeleton :: forall (m :: * -> *). M m => BlockId -> [NoteDestination] -> m () add_derive_skeleton BlockId block_id [NoteDestination] dests = forall (m :: * -> *). Monad m => m Bool -> m () -> m () whenM (forall (m :: * -> *). M m => BlockId -> m Bool Ui.has_explicit_skeleton BlockId block_id) forall a b. (a -> b) -> a -> b $ do [Maybe TrackId] track_ids <- forall (m :: * -> *). M m => BlockId -> m [Maybe TrackId] all_block_tracks BlockId block_id Skeleton skel <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a Ui.require Text "integrate somehow created a cyclic skeleton" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< [Edge] -> Skeleton -> Maybe Skeleton Skeleton.add_edges ([Maybe TrackId] -> [NoteDestination] -> [Edge] track_edges [Maybe TrackId] track_ids [NoteDestination] dests) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> m Skeleton Ui.get_skeleton BlockId block_id forall (m :: * -> *). M m => BlockId -> Skeleton -> m () Ui.set_skeleton BlockId block_id Skeleton skel track_edges :: [Maybe TrackId] -> [Block.NoteDestination] -> [(TrackNum, TrackNum)] track_edges :: [Maybe TrackId] -> [NoteDestination] -> [Edge] track_edges [Maybe TrackId] track_ids = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap NoteDestination -> [Edge] edges where edges :: NoteDestination -> [Edge] edges (Block.NoteDestination Text _ (TrackId track_id, EventIndex _) Map Text (TrackId, EventIndex) controls) = case TrackId -> Maybe Int tracknum_of TrackId track_id of Maybe Int Nothing -> [] Just Int tracknum -> let control_nums :: [Int] control_nums = forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe (TrackId -> Maybe Int tracknum_of forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) (forall k a. Map k a -> [a] Map.elems Map Text (TrackId, EventIndex) controls) in forall a b. [a] -> [b] -> [(a, b)] zip (Int tracknum forall a. a -> [a] -> [a] : [Int] control_nums) [Int] control_nums tracknum_of :: TrackId -> Maybe Int tracknum_of TrackId track_id = forall a. Eq a => a -> [a] -> Maybe Int List.elemIndex (forall a. a -> Maybe a Just TrackId track_id) [Maybe TrackId] track_ids -- | Tracks in tracknum order. Nothing for non-event tracks, like rulers. all_block_tracks :: Ui.M m => BlockId -> m [Maybe TrackId] all_block_tracks :: forall (m :: * -> *). M m => BlockId -> m [Maybe TrackId] all_block_tracks BlockId block_id = forall a b. (a -> b) -> [a] -> [b] map Track -> Maybe TrackId Block.track_id forall b c a. (b -> c) -> (a -> b) -> a -> c . Block -> [Track] Block.block_tracks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> m Block Ui.get_block BlockId block_id -- ** score -- | Update the given ScoreDestinations from the source block and track. score_merge_tracks :: Ui.M m => BlockId -> TrackId -> Block.ScoreDestinations -> m Block.ScoreDestinations score_merge_tracks :: forall (m :: * -> *). M m => BlockId -> TrackId -> ScoreDestinations -> m ScoreDestinations score_merge_tracks BlockId block_id TrackId source_id ScoreDestinations dests = do TrackTree tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree TrackTree.track_tree_of BlockId block_id Tree TrackInfo children <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a Ui.require (Text "source track not found: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt TrackId source_id) forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [Tree a] -> Maybe (Tree a) Trees.find ((forall a. Eq a => a -> a -> Bool ==TrackId source_id) forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackInfo -> TrackId Ui.track_id) TrackTree tree forall (m :: * -> *). M m => BlockId -> TrackTree -> ScoreDestinations -> m ScoreDestinations score_merge BlockId block_id [Tree TrackInfo children] ScoreDestinations dests score_merge :: Ui.M m => BlockId -> TrackTree.TrackTree -> Block.ScoreDestinations -> m Block.ScoreDestinations score_merge :: forall (m :: * -> *). M m => BlockId -> TrackTree -> ScoreDestinations -> m ScoreDestinations score_merge BlockId block_id TrackTree tree ScoreDestinations dests = do forall (m :: * -> *). Monad m => m Bool -> m () -> m () whenM (forall (m :: * -> *). M m => BlockId -> m Bool Ui.has_explicit_skeleton BlockId block_id) forall a b. (a -> b) -> a -> b $ do [Edge] remove <- forall (m :: * -> *). M m => BlockId -> [TrackId] -> m [Edge] destination_edges BlockId block_id (forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a, b) -> a fst forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) ScoreDestinations dests) forall (m :: * -> *). M m => BlockId -> (Skeleton -> Skeleton) -> m () Ui.modify_skeleton BlockId block_id ([Edge] -> Skeleton -> Skeleton Skeleton.remove_edges [Edge] remove) [Maybe TrackId] track_ids <- forall (m :: * -> *). M m => BlockId -> m [Maybe TrackId] all_block_tracks BlockId block_id [(TrackId, Track)] tracks <- forall (m :: * -> *). M m => TrackTree -> m [(TrackId, Track)] get_children TrackTree tree ScoreDestinations dests <- forall (m :: * -> *) a b. Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM (forall (m :: * -> *). M m => BlockId -> ScoreTrackPair -> m (Maybe (TrackId, (TrackId, EventIndex))) score_merge_pair BlockId block_id) forall a b. (a -> b) -> a -> b $ [Maybe TrackId] -> [(TrackId, Track)] -> ScoreDestinations -> [ScoreTrackPair] score_pair_tracks [Maybe TrackId] track_ids [(TrackId, Track)] tracks ScoreDestinations dests forall (m :: * -> *). Monad m => m Bool -> m () -> m () whenM (forall (m :: * -> *). M m => BlockId -> m Bool Ui.has_explicit_skeleton BlockId block_id) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). M m => BlockId -> [Tree Int] -> m () add_skeleton BlockId block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => BlockId -> ScoreDestinations -> [Tree TrackId] -> m [Tree Int] source_to_dest BlockId block_id ScoreDestinations dests (forall a b. (a -> b) -> [a] -> [b] map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap TrackInfo -> TrackId Ui.track_id) TrackTree tree) forall (m :: * -> *) a. Monad m => a -> m a return ScoreDestinations dests -- | Track pairs of the children of the given tree, sorted by tracknum. get_children :: Ui.M m => TrackTree.TrackTree -> m [(TrackId, Track.Track)] get_children :: forall (m :: * -> *). M m => TrackTree -> m [(TrackId, Track)] get_children = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Ord k => (a -> k) -> [a] -> [a] Lists.sortOn forall a b. (a, b) -> a fst) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM forall {m :: * -> *}. M m => TrackInfo -> m (Int, (TrackId, Track)) resolve forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall a. Tree a -> [a] Tree.flatten where resolve :: TrackInfo -> m (Int, (TrackId, Track)) resolve TrackInfo tinfo = do Track track <- forall (m :: * -> *). M m => TrackId -> m Track Ui.get_track (TrackInfo -> TrackId Ui.track_id TrackInfo tinfo) forall (m :: * -> *) a. Monad m => a -> m a return (TrackInfo -> Int Ui.track_tracknum TrackInfo tinfo, (TrackInfo -> TrackId Ui.track_id TrackInfo tinfo, Track track)) source_to_dest :: Ui.M m => BlockId -> Block.ScoreDestinations -> [Tree.Tree TrackId] -> m [Tree.Tree TrackNum] source_to_dest :: forall (m :: * -> *). M m => BlockId -> ScoreDestinations -> [Tree TrackId] -> m [Tree Int] source_to_dest BlockId block_id ScoreDestinations dests = forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) Traversable.mapM forall a b. (a -> b) -> a -> b $ \TrackId track_id -> do TrackId dest_id <- forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a Ui.throw forall a b. (a -> b) -> a -> b $ Text "no destination for " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt TrackId track_id) (forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) (forall a b. Eq a => a -> [(a, b)] -> Maybe b lookup TrackId track_id ScoreDestinations dests) forall (m :: * -> *). M m => BlockId -> TrackId -> m Int dest_tracknum BlockId block_id TrackId dest_id -- | Get the edges that are part of the destination track structure. This -- is so I can clear out the old skeleton before replacing it with the new one. -- Otherwise, adding a new track gets a mangled skeleton since the old edge -- remains. This only returns edges where both ends are in the destination -- tracks, so if you manually add a non-integrated parent or child it should -- remain that way. destination_edges :: Ui.M m => BlockId -> [TrackId] -> m [Skeleton.Edge] destination_edges :: forall (m :: * -> *). M m => BlockId -> [TrackId] -> m [Edge] destination_edges BlockId block_id [TrackId] track_ids = do [Int] tracknums <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (forall (m :: * -> *). M m => BlockId -> TrackId -> m Int dest_tracknum BlockId block_id) [TrackId] track_ids [Edge] edges <- Skeleton -> [Edge] Skeleton.flatten forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> m Skeleton Ui.get_skeleton BlockId block_id forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] filter (\(Int p, Int c) -> Int p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` [Int] tracknums Bool -> Bool -> Bool && Int c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` [Int] tracknums) [Edge] edges dest_tracknum :: Ui.M m => BlockId -> TrackId -> m TrackNum dest_tracknum :: forall (m :: * -> *). M m => BlockId -> TrackId -> m Int dest_tracknum BlockId block_id TrackId track_id = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a Ui.require (Text "integrated track " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt TrackId track_id forall a. Semigroup a => a -> a -> a <> Text " not in " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt BlockId block_id) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe Int) Ui.tracknum_of BlockId block_id TrackId track_id add_skeleton :: Ui.M m => BlockId -> [Tree.Tree TrackNum] -> m () add_skeleton :: forall (m :: * -> *). M m => BlockId -> [Tree Int] -> m () add_skeleton BlockId block_id [Tree Int] tree = do Skeleton skel <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a Ui.require Text "score integrated somehow created a cyclic skeleton" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< [Edge] -> Skeleton -> Maybe Skeleton Skeleton.add_edges (forall a. [Tree a] -> [(a, a)] Trees.edges [Tree Int] tree) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> m Skeleton Ui.get_skeleton BlockId block_id forall (m :: * -> *). M m => BlockId -> Skeleton -> m () Ui.set_skeleton BlockId block_id Skeleton skel -- ** merge -- | Merge together TrackPairs, modifying the underlying tracks, and return -- a NoteDestination. The head of the TrackPairs is assumed to be the note -- track, and the rest are its controls. -- -- Control and pitch tracks are matched or created by title, but the note track -- title is ignored. merge_pairs :: Ui.M m => MergeTitles -> BlockId -> [TrackPair] -> m (Maybe Block.NoteDestination) merge_pairs :: forall (m :: * -> *). M m => MergeTitles -> BlockId -> [TrackPair] -> m (Maybe NoteDestination) merge_pairs MergeTitles merge_titles BlockId block_id [TrackPair] pairs = do [(Text, TrackId, EventIndex)] triples <- forall (m :: * -> *) a b. Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM (forall (m :: * -> *). M m => BlockId -> TrackPair -> m (Maybe (Text, TrackId, EventIndex)) merge_pair BlockId block_id) [TrackPair] pairs case [(Text, TrackId, EventIndex)] triples of [] -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing (Text source_title, TrackId note_id, EventIndex note_index) : [(Text, TrackId, EventIndex)] controls -> do -- TODO I could merge them, but I need the previous integrated -- title -- What about the control track titles? I use those as keys, so I -- can't change them without breaking the link. forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (MergeTitles merge_titles forall a. Eq a => a -> a -> Bool == MergeTitles ReplaceTitles) forall a b. (a -> b) -> a -> b $ do forall (m :: * -> *). M m => TrackId -> Text -> m () Ui.set_track_title TrackId note_id Text source_title forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Text -> (TrackId, EventIndex) -> Map Text (TrackId, EventIndex) -> NoteDestination Block.NoteDestination Text key (TrackId note_id, EventIndex note_index) forall a b. (a -> b) -> a -> b $ forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [ (Text title, (TrackId track_id, EventIndex index)) | (Text title, TrackId track_id, EventIndex index) <- [(Text, TrackId, EventIndex)] controls ] where -- TODO once I use track keys I have to propagate this from the pairing. key :: Text key = Text "" merge_pair :: Ui.M m => BlockId -> TrackPair -> m (Maybe (Text, TrackId, Block.EventIndex)) merge_pair :: forall (m :: * -> *). M m => BlockId -> TrackPair -> m (Maybe (Text, TrackId, EventIndex)) merge_pair BlockId block_id TrackPair pair = case TrackPair pair of (Maybe Track Nothing, Left Int _) -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing -- not reached (Just (Convert.Track Text title [Event] events), Left Int tracknum) -> do -- Track was deleted or it doesn't exist yet, so create it. TrackId track_id <- forall (m :: * -> *). M m => BlockId -> Int -> Text -> Events -> m TrackId Create.track BlockId block_id Int tracknum Text title ([Event] -> Events Events.from_list (forall a b. (a -> b) -> [a] -> [b] map Event -> Event Event.unmodified [Event] events)) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just (Text title, TrackId track_id, [Event] -> EventIndex make_index [Event] events) (Maybe Track Nothing, Right (TrackId track_id, EventIndex _)) -> do -- Integrate no longer wants the track. Don't delete the track in case -- there are manually created events on it. forall (m :: * -> *). M m => TrackId -> m () clear_generated_events TrackId track_id forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing (Just (Convert.Track Text title [Event] events), Right (TrackId, EventIndex) dest) -> do forall (m :: * -> *). M m => [Event] -> (TrackId, EventIndex) -> m () merge_track [Event] events (TrackId, EventIndex) dest forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just (Text title, forall a b. (a, b) -> a fst (TrackId, EventIndex) dest, [Event] -> EventIndex make_index [Event] events) score_merge_pair :: Ui.M m => BlockId -> ScoreTrackPair -> m (Maybe (TrackId, (TrackId, Block.EventIndex))) score_merge_pair :: forall (m :: * -> *). M m => BlockId -> ScoreTrackPair -> m (Maybe (TrackId, (TrackId, EventIndex))) score_merge_pair BlockId block_id ScoreTrackPair pair = case ScoreTrackPair pair of (Maybe (TrackId, Events) Nothing, Left Int _) -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing -- not reached (Just (TrackId source_id, Events events), Left Int tracknum) -> do -- Track was deleted or never existed. let stacked :: [Event] stacked = BlockId -> TrackId -> Events -> [Event] add_event_stacks BlockId block_id TrackId source_id Events events Text title <- forall (m :: * -> *). M m => TrackId -> m Text Ui.get_track_title TrackId source_id TrackId track_id <- forall (m :: * -> *). M m => BlockId -> Int -> Text -> Events -> m TrackId Create.track BlockId block_id Int tracknum Text title ([Event] -> Events Events.from_list (forall a b. (a -> b) -> [a] -> [b] map Event -> Event Event.unmodified [Event] stacked)) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just (TrackId source_id, (TrackId track_id, [Event] -> EventIndex make_index [Event] stacked)) (Maybe (TrackId, Events) Nothing, Right (TrackId track_id, EventIndex _)) -> do -- Integrate no longer wants the track. Don't delete the track in case -- there are manually created events on it. forall (m :: * -> *). M m => TrackId -> m () clear_generated_events TrackId track_id forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing (Just (TrackId source_id, Events events), Right (TrackId, EventIndex) dest) -> do let stacked :: [Event] stacked = BlockId -> TrackId -> Events -> [Event] add_event_stacks BlockId block_id TrackId source_id Events events forall (m :: * -> *). M m => [Event] -> (TrackId, EventIndex) -> m () merge_track [Event] stacked (TrackId, EventIndex) dest forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just (TrackId source_id, (forall a b. (a, b) -> a fst (TrackId, EventIndex) dest, [Event] -> EventIndex make_index [Event] stacked)) clear_generated_events :: Ui.M m => TrackId -> m () clear_generated_events :: forall (m :: * -> *). M m => TrackId -> m () clear_generated_events TrackId track_id = forall (m :: * -> *). M m => TrackId -> (Events -> Events) -> m () Ui.modify_events TrackId track_id forall a b. (a -> b) -> a -> b $ [Event] -> Events Events.from_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] filter (forall a. Maybe a -> Bool Maybe.isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Maybe Stack Event.stack) forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> [Event] Events.ascending -- | This implements a 3-way merge. First, diff the recorded index (which -- is a pristine copy of the previous integrate) against the current contents -- of the track. This gives the edits that have been applied manually against -- the integrate output. Then those edits are replayed against the new -- integrate output. merge_track :: Ui.M m => [Event.Event] -> Dest -> m () merge_track :: forall (m :: * -> *). M m => [Event] -> (TrackId, EventIndex) -> m () merge_track [Event] source_events (TrackId track_id, EventIndex index) = do [Event] old_events <- Events -> [Event] Events.ascending forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => TrackId -> m Events Ui.get_events TrackId track_id let (Set TrackTime deletes, [Edit] edits) = EventIndex -> [Event] -> (Set TrackTime, [Edit]) diff_events EventIndex index [Event] old_events new_events :: Events new_events = Set TrackTime -> [Edit] -> [Event] -> Events apply Set TrackTime deletes [Edit] edits [Event] source_events forall (m :: * -> *). M m => TrackId -> (Events -> Events) -> m () Ui.modify_some_events TrackId track_id (forall a b. a -> b -> a const Events new_events) -- | Create an index from integrated tracks. Since they are integrated, they -- should all have stacks, so events without stacks are discarded. make_index :: [Event.Event] -> Block.EventIndex make_index :: [Event] -> EventIndex make_index [Event] events = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [(TrackTime key, Event event) | (Just TrackTime key, Event event) <- forall a k. (a -> k) -> [a] -> [(k, a)] Lists.keyOn Event -> Maybe TrackTime index_key [Event] events] -- | Unlike derive integration, the events are copied directly from the -- source, and hence don't have stacks. add_event_stacks :: BlockId -> TrackId -> Events.Events -> [Event.Event] add_event_stacks :: BlockId -> TrackId -> Events -> [Event] add_event_stacks BlockId block_id TrackId track_id = forall a b. (a -> b) -> [a] -> [b] map Event -> Event add_stack forall b c a. (b -> c) -> (a -> b) -> a -> c . Events -> [Event] Events.ascending where add_stack :: Event -> Event add_stack Event event = Lens Event (Maybe Stack) Event.stack_ forall f a. Lens f a -> a -> f -> f #= forall a. a -> Maybe a Just (Event -> Stack make_stack Event event) forall a b. (a -> b) -> a -> b $ Event event make_stack :: Event -> Stack make_stack Event event = Event.Stack { stack_stack :: Stack Event.stack_stack = [Frame] -> Stack Stack.from_innermost [TrackId -> Frame Stack.Track TrackId track_id, BlockId -> Frame Stack.Block BlockId block_id] , stack_key :: TrackTime Event.stack_key = Event -> TrackTime Event.start Event event } -- ** pair {- | If the Convert.Track is present, then that is the track being integrated in from the source. If it's not present, then this track is no longer present in the integration source. If there is a TrackNum, then this track isn't present in the destination, and should be created. Otherwise, it should be merged with the given Dest. (Nothing, Left 0) means the track is gone from both source and destination, so this TrackPair can be ignored. -} type TrackPair = (Maybe Convert.Track, Either TrackNum Dest) -- | Score integrate copies tracks 1:1, so the destination tracks always have -- a TrackId, and I can match them up by TrackId. type ScoreTrackPair = (Maybe (TrackId, Events.Events), Either TrackNum Dest) type Dest = (TrackId, Block.EventIndex) {- | Match up new tracks and integrated tracks so I know who to diff against whom. This is called once for each integrate source block. Note tracks are simply zipped up, so if a note track is added at the beginning it will look like everything changed and the diff won't work correctly. But control tracks are matched based on name, so they should be robust against controls appearing or disappearing. Also figure out TrackNums for index tracks that don't exist. An index track can not exist because it was never there, or because it was index but is no longer in the block (presumably manually deleted). TrackNums are assigned increasing from the previous track that was present, or at the end of the block if no tracks are present. This way new control tracks should be added adjacent to their sisters, and the first integrate will append the generated tracks to the end of the block. -} pair_tracks :: [Maybe TrackId] -- ^ Tracks in the block, in tracknum order. -- Nothing for non-event tracks like rulers. -> Convert.Tracks -> [Block.NoteDestination] -> [[TrackPair]] -- ^ Each [TrackPair] is (note : controls). pair_tracks :: [Maybe TrackId] -> Tracks -> [NoteDestination] -> [[TrackPair]] pair_tracks [Maybe TrackId] track_ids Tracks tracks [NoteDestination] dests = forall a b. (a -> b) -> [a] -> [b] map (forall a. (a -> Bool) -> [a] -> [a] filter forall {a} {a} {b}. (Maybe a, Either a b) -> Bool is_valid) forall a b. (a -> b) -> a -> b $ forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) List.mapAccumL forall {t :: * -> *} {a} {b}. Traversable t => Int -> t (Paired a (TrackId, b)) -> (Int, t (Maybe a, Either Int (TrackId, b))) resolve1 (forall (t :: * -> *) a. Foldable t => t a -> Int length [Maybe TrackId] track_ids) forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map Paired (Track, [Track]) NoteDestination -> [Paired Track (TrackId, EventIndex)] pairs_of forall a b. (a -> b) -> a -> b $ forall a b. [a] -> [b] -> [Paired a b] Lists.zipPadded Tracks tracks [NoteDestination] dests where -- Pair up the tracks. pairs_of :: Paired (Track, [Track]) NoteDestination -> [Paired Track (TrackId, EventIndex)] pairs_of (Lists.First (Track note, [Track] controls)) = forall a b. (a -> b) -> [a] -> [b] map forall a b. a -> Paired a b Lists.First (Track note forall a. a -> [a] -> [a] : [Track] controls) pairs_of (Lists.Second (Block.NoteDestination Text key (TrackId, EventIndex) note Map Text (TrackId, EventIndex) controls)) = forall a b. (a -> b) -> [a] -> [b] map forall a b. b -> Paired a b Lists.Second ((TrackId, EventIndex) note forall a. a -> [a] -> [a] : forall k a. Map k a -> [a] Map.elems Map Text (TrackId, EventIndex) controls) pairs_of (Lists.Both (Track, [Track]) track NoteDestination dest) = (Track, [Track]) -> NoteDestination -> [Paired Track (TrackId, EventIndex)] pair_destination (Track, [Track]) track NoteDestination dest resolve1 :: Int -> t (Paired a (TrackId, b)) -> (Int, t (Maybe a, Either Int (TrackId, b))) resolve1 Int next_tracknum t (Paired a (TrackId, b)) pairs = forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) List.mapAccumL forall {a} {b}. Int -> Paired a (TrackId, b) -> (Int, (Maybe a, Either Int (TrackId, b))) resolve Int next_tracknum t (Paired a (TrackId, b)) pairs -- Figure out tracknums. resolve :: Int -> Paired a (TrackId, b) -> (Int, (Maybe a, Either Int (TrackId, b))) resolve Int next_tracknum (Lists.First a track) = (Int next_tracknum forall a. Num a => a -> a -> a + Int 1, (forall a. a -> Maybe a Just a track, forall a b. a -> Either a b Left Int next_tracknum)) resolve Int next_tracknum (Lists.Second (TrackId, b) dest) = case TrackId -> Maybe Int tracknum_of (forall a b. (a, b) -> a fst (TrackId, b) dest) of -- Track deleted and the integrate no longer wants it. -- Ugly, but (Nothing, Left) can be code for "ignore me". Maybe Int Nothing -> (Int next_tracknum, (forall a. Maybe a Nothing, forall a b. a -> Either a b Left Int 0)) Just Int tracknum -> (Int tracknum forall a. Num a => a -> a -> a + Int 1, (forall a. Maybe a Nothing, forall a b. b -> Either a b Right (TrackId, b) dest)) resolve Int next_tracknum (Lists.Both a track (TrackId, b) dest) = case TrackId -> Maybe Int tracknum_of (forall a b. (a, b) -> a fst (TrackId, b) dest) of Maybe Int Nothing -> (Int next_tracknum forall a. Num a => a -> a -> a + Int 1, (forall a. a -> Maybe a Just a track, forall a b. a -> Either a b Left Int next_tracknum)) Just Int tracknum -> (Int tracknum forall a. Num a => a -> a -> a + Int 1, (forall a. a -> Maybe a Just a track, forall a b. b -> Either a b Right (TrackId, b) dest)) tracknum_of :: TrackId -> Maybe Int tracknum_of TrackId track_id = forall a. Eq a => a -> [a] -> Maybe Int List.elemIndex (forall a. a -> Maybe a Just TrackId track_id) [Maybe TrackId] track_ids is_valid :: (Maybe a, Either a b) -> Bool is_valid (Maybe a Nothing, Left a _) = Bool False is_valid (Maybe a, Either a b) _ = Bool True -- | Pair up the controls based on the track title, which should be the control -- name. pair_destination :: (Convert.Track, [Convert.Track]) -> Block.NoteDestination -> [Lists.Paired Convert.Track (TrackId, Block.EventIndex)] pair_destination :: (Track, [Track]) -> NoteDestination -> [Paired Track (TrackId, EventIndex)] pair_destination (Track note, [Track] controls) (Block.NoteDestination Text key (TrackId, EventIndex) note_dest Map Text (TrackId, EventIndex) control_dests) = forall a b. a -> b -> Paired a b Lists.Both Track note (TrackId, EventIndex) note_dest forall a. a -> [a] -> [a] : forall {b}. [Track] -> Map Text b -> [Paired Track b] pair_controls [Track] controls Map Text (TrackId, EventIndex) control_dests where pair_controls :: [Track] -> Map Text b -> [Paired Track b] pair_controls [Track] tracks Map Text b dests = forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ forall k a b. Ord k => [(k, a)] -> [(k, b)] -> [(k, Paired a b)] Lists.pairSorted (forall k a. Ord k => (a -> k) -> [a] -> [a] Lists.sortOn forall a b. (a, b) -> a fst [(Text, Track)] keyed) forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [(k, a)] Map.toAscList Map Text b dests where keyed :: [(Text, Track)] keyed = forall a k. (a -> k) -> [a] -> [(k, a)] Lists.keyOn Track -> Text Convert.track_title [Track] tracks -- | Pair up tracks in an analogous way to 'pair_tracks'. The difference is -- that ScoreDestinations are matched up by TrackId, so I don't have to do any -- sketchy zipping heuristics. I still have to guess about the output tracknum -- for new tracks though. score_pair_tracks :: [Maybe TrackId] -> [(TrackId, Track.Track)] -> Block.ScoreDestinations -> [ScoreTrackPair] score_pair_tracks :: [Maybe TrackId] -> [(TrackId, Track)] -> ScoreDestinations -> [ScoreTrackPair] score_pair_tracks [Maybe TrackId] track_ids [(TrackId, Track)] sources ScoreDestinations dests = forall a b. (a, b) -> b snd (forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) List.mapAccumL Int -> (TrackId, Track) -> (Int, ScoreTrackPair) pair_in_order (forall (t :: * -> *) a. Foldable t => t a -> Int length [Maybe TrackId] track_ids) [(TrackId, Track)] sources) forall a. [a] -> [a] -> [a] ++ forall {a} {a}. [(Maybe a, Either a (TrackId, EventIndex))] deleted where pair_in_order :: Int -> (TrackId, Track) -> (Int, ScoreTrackPair) pair_in_order Int next_tracknum source :: (TrackId, Track) source@(TrackId source_id, Track _) = case forall a b. Eq a => a -> [(a, b)] -> Maybe b lookup TrackId source_id ScoreDestinations dests of -- make new track Maybe (TrackId, EventIndex) Nothing -> (Int next_tracknum forall a. Num a => a -> a -> a + Int 1, (forall {a}. (a, Track) -> Maybe (a, Events) make_source (TrackId, Track) source, forall a b. a -> Either a b Left Int next_tracknum)) -- merge Just (TrackId, EventIndex) dest -> (Int tracknum forall a. Num a => a -> a -> a + Int 1, (forall {a}. (a, Track) -> Maybe (a, Events) make_source (TrackId, Track) source, forall a b. b -> Either a b Right (TrackId, EventIndex) dest)) where tracknum :: Int tracknum = forall {b}. Int -> (TrackId, b) -> Int tracknum_of Int next_tracknum (TrackId, EventIndex) dest deleted :: [(Maybe a, Either a (TrackId, EventIndex))] deleted = forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe forall {b} {a} {a}. (TrackId, b) -> Maybe (Maybe a, Either a b) deleted_track ScoreDestinations dests deleted_track :: (TrackId, b) -> Maybe (Maybe a, Either a b) deleted_track (TrackId source_id, b dest) = case forall a b. Eq a => a -> [(a, b)] -> Maybe b lookup TrackId source_id [(TrackId, Track)] sources of Maybe Track Nothing -> forall a. a -> Maybe a Just (forall a. Maybe a Nothing, forall a b. b -> Either a b Right b dest) Just Track _ -> forall a. Maybe a Nothing make_source :: (a, Track) -> Maybe (a, Events) make_source (a source_id, Track source) = forall a. a -> Maybe a Just (a source_id, Track -> Events Track.track_events Track source) tracknums :: Map TrackId Int tracknums = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [(TrackId track_id, Int tracknum) | (Int tracknum, Just TrackId track_id) <- forall a b. [a] -> [b] -> [(a, b)] zip [Int 0..] [Maybe TrackId] track_ids] tracknum_of :: Int -> (TrackId, b) -> Int tracknum_of Int deflt (TrackId source_id, b _) = forall k a. Ord k => a -> k -> Map k a -> a Map.findWithDefault Int deflt TrackId source_id Map TrackId Int tracknums -- ** diff -- | Find out how to merge new integrated output with user edits by diffing it -- against the old integrated output. diff_events :: Block.EventIndex -- ^ results of last integrate -> [Event.Event] -- ^ current events, which is last integrate plus user edits -> (Set Event.IndexKey, [Edit]) -- ^ set of deleted events, and edited events diff_events :: EventIndex -> [Event] -> (Set TrackTime, [Edit]) diff_events EventIndex index [Event] events = (Set TrackTime deletes, [Edit] edits) where deletes :: Set TrackTime deletes = forall a. Ord a => Set a -> Set a -> Set a Set.difference (forall k a. Map k a -> Set k Map.keysSet EventIndex index) forall a b. (a -> b) -> a -> b $ forall a. Ord a => [a] -> Set a Set.fromList (forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe Event -> Maybe TrackTime index_key [Event] events) edits :: [Edit] edits = forall a b. (a -> b) -> [a] -> [b] map (EventIndex -> Event -> Edit diff EventIndex index) [Event] events diff :: Block.EventIndex -> Event.Event -> Edit diff :: EventIndex -> Event -> Edit diff EventIndex index Event new = case Event -> Maybe TrackTime index_key Event new of Maybe TrackTime Nothing -> Event -> Edit Add Event new Just TrackTime key -> case forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup TrackTime key EventIndex index of -- Events with a stack but not in the index shouldn't happen, they -- indicate that the index is out of sync with the last -- integration. To be safe, they're counted as an add, and the -- stack is deleted. TODO could this multiply events endlessly? -- TODO This could be a symptom of tracks not lining up anymore. -- I should emit a warning. Maybe Event Nothing -> Event -> Edit Add (Lens Event (Maybe Stack) Event.stack_ forall f a. Lens f a -> a -> f -> f #= forall a. Maybe a Nothing forall a b. (a -> b) -> a -> b $ Event new) Just Event old -> TrackTime -> [Modify] -> Edit Edit TrackTime key (Event -> Event -> [Modify] diff_event Event old Event new) index_key :: Event.Event -> Maybe Event.IndexKey index_key :: Event -> Maybe TrackTime index_key = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Stack -> TrackTime Event.stack_key forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Maybe Stack Event.stack diff_event :: Event.Event -> Event.Event -> [Modify] diff_event :: Event -> Event -> [Modify] diff_event Event old Event new = forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ forall {a} {a}. Eq a => a -> a -> a -> [a] cmp (Event -> TrackTime Event.start Event old) (Event -> TrackTime Event.start Event new) (TrackTime -> Modify Position (Event -> TrackTime Event.start Event new)) , forall {a} {a}. Eq a => a -> a -> a -> [a] cmp (Event -> TrackTime Event.duration Event old) (Event -> TrackTime Event.duration Event new) (TrackTime -> Modify Duration (Event -> TrackTime Event.duration Event new)) , Text -> Text -> [Modify] diff_text (Event -> Text Event.text Event old) (Event -> Text Event.text Event new) ] where cmp :: a -> a -> a -> [a] cmp a x a y a val = if a x forall a. Eq a => a -> a -> Bool == a y then [] else [a val] -- | Figure out differences between the text of two events. -- -- A text change is only considered a Prefix if it occurs on a @ | @ boundary. -- This is because I want to catch a transformer addition but don't want to -- mangle text that happens to start with the same character. -- -- I don't check for suffixes because suffixing an event would change -- a generator to a transformer, which in unlikely. diff_text :: Text -> Text -> [Modify] diff_text :: Text -> Text -> [Modify] diff_text Text old Text new | Text old forall a. Eq a => a -> a -> Bool == Text new = [] | Text old Text -> Text -> Bool `Text.isSuffixOf` Text new Bool -> Bool -> Bool && Text -> Bool ends_with_pipe Text prefix = [Text -> Modify Prefix Text prefix] | Bool otherwise = [Text -> Modify Set Text new] where prefix :: Text prefix = Int -> Text -> Text Text.take (Text -> Int Text.length Text new forall a. Num a => a -> a -> a - Text -> Int Text.length Text old) Text new ends_with_pipe :: Text -> Bool ends_with_pipe Text text = Text "|" Text -> Text -> Bool `Text.isSuffixOf` Text pre Bool -> Bool -> Bool && (Char -> Bool) -> Text -> Bool Text.all (forall a. Eq a => a -> a -> Bool ==Char ' ') Text post where (Text pre, Text post) = Stack => Text -> Text -> (Text, Text) Text.breakOnEnd Text "|" Text text data Edit = -- | This event was added, and will be copied to the output. Add !Event.Event -- | This matched an existing event, which has possibly been modified, so -- I have to merge the new event while applying any modifications. | Edit !Event.IndexKey ![Modify] deriving (Edit -> Edit -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Edit -> Edit -> Bool $c/= :: Edit -> Edit -> Bool == :: Edit -> Edit -> Bool $c== :: Edit -> Edit -> Bool Eq, Int -> Edit -> ShowS [Edit] -> ShowS Edit -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Edit] -> ShowS $cshowList :: [Edit] -> ShowS show :: Edit -> String $cshow :: Edit -> String showsPrec :: Int -> Edit -> ShowS $cshowsPrec :: Int -> Edit -> ShowS Show) data Modify = Position !ScoreTime | Duration !ScoreTime | Set !Text | Prefix !Text deriving (Modify -> Modify -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Modify -> Modify -> Bool $c/= :: Modify -> Modify -> Bool == :: Modify -> Modify -> Bool $c== :: Modify -> Modify -> Bool Eq, Int -> Modify -> ShowS [Modify] -> ShowS Modify -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Modify] -> ShowS $cshowList :: [Modify] -> ShowS show :: Modify -> String $cshow :: Modify -> String showsPrec :: Int -> Modify -> ShowS $cshowsPrec :: Int -> Modify -> ShowS Show) instance Pretty Edit where format :: Edit -> Doc format (Add Event event) = Text -> [Doc] -> Doc Pretty.constructor Text "Add" [forall a. Pretty a => a -> Doc Pretty.format Event event] format (Edit TrackTime key [Modify] mods) = Text -> [Doc] -> Doc Pretty.constructor Text "Edit" [forall a. Pretty a => a -> Doc Pretty.format TrackTime key, forall a. Pretty a => a -> Doc Pretty.format [Modify] mods] instance Pretty Modify where pretty :: Modify -> Text pretty = forall a. Show a => a -> Text showt is_modified :: Edit -> Bool is_modified :: Edit -> Bool is_modified (Edit TrackTime _ [Modify] mods) = Bool -> Bool not (forall (t :: * -> *) a. Foldable t => t a -> Bool null [Modify] mods) is_modified Edit _ = Bool True -- ** apply apply :: Set Event.IndexKey -- ^ events that were deleted -> [Edit] -> [Event.Event] -- ^ results of current integrate -> Events.Events apply :: Set TrackTime -> [Edit] -> [Event] -> Events apply Set TrackTime deletes [Edit] adds_edits = [Event] -> Events make forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe Event -> Maybe Event edit where -- Adds go afterwards so they can replace coincident events. make :: [Event] -> Events make [Event] events = [Event] -> Events Events.from_list ([Event] events forall a. [a] -> [a] -> [a] ++ [Event] adds) edit :: Event -> Maybe Event edit Event event | Event -> TrackTime Event.start Event event forall a. Ord a => a -> Set a -> Bool `Set.member` Set TrackTime deletes = forall a. Maybe a Nothing | Just mods :: [Modify] mods@(Modify _:[Modify] _) <- forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup (Event -> TrackTime Event.start Event event) Map TrackTime [Modify] edit_map = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ [Modify] -> Event -> Event apply_modifications [Modify] mods Event event -- A new event from the integrate. | Bool otherwise = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Event -> Event Event.unmodified Event event edit_map :: Map TrackTime [Modify] edit_map = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList 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 :: * -> *) a. Foldable t => t a -> Bool null forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) [(TrackTime, [Modify])] edits ([Event] adds, [(TrackTime, [Modify])] edits) = forall a b. [Either a b] -> ([a], [b]) Either.partitionEithers (forall a b. (a -> b) -> [a] -> [b] map Edit -> Either Event (TrackTime, [Modify]) to_either [Edit] adds_edits) to_either :: Edit -> Either Event (TrackTime, [Modify]) to_either (Add Event event) = forall a b. a -> Either a b Left Event event to_either (Edit TrackTime key [Modify] mods) = forall a b. b -> Either a b Right (TrackTime key, [Modify] mods) apply_modifications :: [Modify] -> Event.Event -> Event.Event apply_modifications :: [Modify] -> Event -> Event apply_modifications [Modify] mods Event event = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' Event -> Modify -> Event go Event event [Modify] mods where go :: Event -> Modify -> Event go Event event Modify mod = (forall a b. (a -> b) -> a -> b $Event event) forall a b. (a -> b) -> a -> b $ case Modify mod of Position TrackTime p -> Lens Event TrackTime Event.start_ forall f a. Lens f a -> a -> f -> f #= TrackTime p Duration TrackTime d -> Lens Event TrackTime Event.duration_ forall f a. Lens f a -> a -> f -> f #= TrackTime d Set Text text -> Lens Event Text Event.text_ forall f a. Lens f a -> a -> f -> f #= Text text Prefix Text text -> Lens Event Text Event.text_ forall f a. Lens f a -> (a -> a) -> f -> f %= (Text text<>)