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