-- 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 {- | Cmd-level support for integration. These cmds interpret the output of the calls in "Derive.Call.Integrate" to create score from deriver output and merge it back into the current score. An example of track integration: - Add \" | <\" to a note track title, which causes damage and a rederive. - The integrate call @<@ collects events and puts them into derive results, which go into DeriveComplete, which winds up at 'integrate_tracks'. - 'integrate_tracks' finds no existing derived tracks, so it merges into [], which creates new tracks, and damages the whole block. - Then it sets 'Cmd.derive_immediately' on the block, which removes the usual derive wait. - Derive once again emits integrate results, which winds up at 'integrate_tracks' again, but since there are no changes this time, there is no further damage, and derivation stops. This additional integration just to find out there were no changes is inefficient, but not a big deal since it only happens the first time. Modify source track: - Track damage causes a rederive, which causes the @<@ call to collect integrated events. - 'integrate_tracks' merges the changes into the destination track (or tracks), which damages them. - This time when the derive happens, since there was no damage on the source track, it gets cached. The cache intentionally doesn't retain integrated events, so @<@ is skipped and I don't get a second derivation. Block integration is similar, except that I don't get a double derivation when the first new block is created, since the damage is separated to a different block. It might be a little more orthogonal to omit the thing where I automatically create an integrated block or track if there are none, but it's convenient in practice. It does, however, make it tricky to undo past the integrate, since if you undo the block\/track creation, the integrate call is still there and just creates another. Be quick! This also implements score integration, which is a higher level form of integration that simply copies score events directly, without the intervening derive step. -} module Cmd.Integrate (cmd_integrate, score_integrate, manual_integrate) where import qualified Data.Either as Either import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified Util.Lists as Lists import qualified Util.Log as Log import qualified Cmd.Cmd as Cmd import qualified Cmd.Create as Create import qualified Cmd.Integrate.Convert as Convert import qualified Cmd.Integrate.Merge as Merge import qualified Cmd.Msg as Msg import qualified Derive.Derive as Derive import qualified Ui.Block as Block import qualified Ui.Ui as Ui import qualified Ui.Update as Update import Global import Types -- | Derive integrate takes the result of a derivation and merges it into -- blocks or tracks which are marked as integrate destinations. A special -- derive call captures events and saves them in 'Cmd.perf_integrated'. cmd_integrate :: Cmd.M m => Msg.Msg -> m Cmd.Status cmd_integrate :: forall (m :: * -> *). M m => Msg -> m Status cmd_integrate (Msg.DeriveStatus BlockId block_id (Msg.DeriveComplete Performance perf ImStarted _)) = do -- If a block or track wants to integrate twice with different events, -- I don't know which ones to give to the destinations, and wind up -- creating a new track every time. let ([Integrated] dups, [Integrated] integrates) = forall a b. [Either a b] -> ([a], [b]) Either.partitionEithers forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map forall {a}. NonEmpty a -> Either a a is_dup forall a b. (a -> b) -> a -> b $ forall key a. Eq key => (a -> key) -> [a] -> [NonEmpty a] Lists.groupStable Integrated -> Either BlockId TrackId Derive.integrated_source (Performance -> [Integrated] Cmd.perf_integrated Performance perf) is_dup :: NonEmpty a -> Either a a is_dup (a x :| [a] xs) = if forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] xs then forall a b. b -> Either a b Right a x else forall a b. a -> Either a b Left a x forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (forall (t :: * -> *) a. Foldable t => t a -> Bool null [Integrated] dups) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). (Stack, LogMonad m) => Text -> m () Log.warn forall a b. (a -> b) -> a -> b $ Text "these blocks or tracks want to integrate twice: " forall a. Semigroup a => a -> a -> a <> Text -> [Text] -> Text Text.intercalate Text ", " (forall a b. (a -> b) -> [a] -> [b] map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either forall a. Pretty a => a -> Text pretty forall a. Pretty a => a -> Text pretty forall b c a. (b -> c) -> (a -> b) -> a -> c . Integrated -> Either BlockId TrackId Derive.integrated_source) [Integrated] dups) forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (forall (m :: * -> *). M m => BlockId -> Integrated -> m () integrate BlockId block_id) [Integrated] integrates forall (m :: * -> *) a. Monad m => a -> m a return Status Cmd.Continue cmd_integrate Msg _ = forall (m :: * -> *) a. Monad m => a -> m a return Status Cmd.Continue -- | Integrate the track information into the current state. integrate :: Cmd.M m => BlockId -> Derive.Integrated -> m () integrate :: forall (m :: * -> *). M m => BlockId -> Integrated -> m () integrate BlockId derived_block_id Integrated integrated = do Tracks tracks <- forall (m :: * -> *). M m => BlockId -> Stream Event -> m Tracks Convert.convert BlockId derived_block_id (Integrated -> Stream Event Derive.integrated_events Integrated integrated) case Integrated -> Either BlockId TrackId Derive.integrated_source Integrated integrated of Left BlockId block_id -> forall (m :: * -> *). M m => BlockId -> Tracks -> m () integrate_block BlockId block_id Tracks tracks Right TrackId track_id -> forall (m :: * -> *). M m => BlockId -> TrackId -> Tracks -> m () integrate_tracks BlockId derived_block_id TrackId track_id Tracks tracks -- | Update and replace the DeriveDestinations for the given TrackId. -- A source track can have multiple destinations, and each of those is actually -- a list of DeriveDestinations. integrate_tracks :: Cmd.M m => BlockId -> TrackId -> Convert.Tracks -> m () integrate_tracks :: forall (m :: * -> *). M m => BlockId -> TrackId -> Tracks -> m () integrate_tracks BlockId block_id TrackId track_id Tracks tracks = do Block block <- forall (m :: * -> *). M m => BlockId -> m Block Ui.get_block BlockId block_id -- This means the < call on a non-top block emitted Cmd.perf_integrated. forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (TrackId track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` Block -> [TrackId] Block.block_track_ids Block block) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. (Stack, M m) => Text -> m a Cmd.throw forall a b. (a -> b) -> a -> b $ Text "derivation of " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty BlockId block_id forall a. Semigroup a => a -> a -> a <> Text " wanted to derive " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty TrackId track_id forall a. Semigroup a => a -> a -> a <> Text ", which is not in that block" [(TrackId, TrackDestinations)] itracks <- Block -> [(TrackId, TrackDestinations)] Block.block_integrated_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 let dests :: [[NoteDestination]] dests = [ [NoteDestination] dests | (TrackId source_id, Block.DeriveDestinations [NoteDestination] dests) <- [(TrackId, TrackDestinations)] itracks , TrackId source_id forall a. Eq a => a -> a -> Bool == TrackId track_id ] [[NoteDestination]] new_dests <- if forall (t :: * -> *) a. Foldable t => t a -> Bool null [[NoteDestination]] dests then (forall a. a -> [a] -> [a] :[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => MergeTitles -> BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination] Merge.merge_tracks MergeTitles Merge.KeepTitles BlockId block_id Tracks tracks [] else forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (forall (m :: * -> *). M m => MergeTitles -> BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination] Merge.merge_tracks MergeTitles Merge.KeepTitles BlockId block_id Tracks tracks) [[NoteDestination]] dests forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (forall (t :: * -> *) a. Foldable t => t a -> Bool null [[NoteDestination]] new_dests) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). (Stack, LogMonad m) => Text -> m () Log.notice forall a b. (a -> b) -> a -> b $ Text "derive track integrate " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty BlockId block_id forall a. Semigroup a => a -> a -> a <> Text " " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty TrackId track_id forall a. Semigroup a => a -> a -> a <> Text " to " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (forall a b. (a -> b) -> [a] -> [b] map (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 . NoteDestination -> (TrackId, EventIndex) Block.dest_note)) [[NoteDestination]] new_dests) forall (m :: * -> *). M m => BlockId -> ([(TrackId, TrackDestinations)] -> [(TrackId, TrackDestinations)]) -> m () Ui.modify_integrated_tracks BlockId block_id forall a b. (a -> b) -> a -> b $ forall key a. Eq key => key -> [(key, a)] -> [(key, a)] -> [(key, a)] replace TrackId track_id [(TrackId track_id, [NoteDestination] -> TrackDestinations Block.DeriveDestinations [NoteDestination] dests) | [NoteDestination] dests <- [[NoteDestination]] new_dests] forall (m :: * -> *). M m => [BlockId] -> m () Cmd.derive_immediately [BlockId block_id] -- | Look for blocks derived from this one and replace their contents, or -- create a new block if there are no blocks derived from this one. integrate_block :: Cmd.M m => BlockId -> Convert.Tracks -> m () integrate_block :: forall (m :: * -> *). M m => BlockId -> Tracks -> m () integrate_block BlockId source_id Tracks tracks = do Map BlockId Block blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a Ui.gets State -> Map BlockId Block Ui.state_blocks [(BlockId, [NoteDestination])] dest_blocks <- case forall {a}. Map a Block -> [(a, [NoteDestination])] integrated_from Map BlockId Block blocks of [] -> do (BlockId block_id, [NoteDestination] dests) <- forall (m :: * -> *). M m => BlockId -> Tracks -> m (BlockId, [NoteDestination]) Merge.create_block BlockId source_id Tracks tracks forall (m :: * -> *). M m => BlockId -> m ViewId Create.view BlockId block_id forall (m :: * -> *) a. Monad m => a -> m a return [(BlockId block_id, [NoteDestination] dests)] [(BlockId, [NoteDestination])] integrated -> forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM [(BlockId, [NoteDestination])] integrated forall a b. (a -> b) -> a -> b $ \(BlockId dest_id, [NoteDestination] track_dests) -> (,) 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.merge_block BlockId dest_id Tracks tracks [NoteDestination] track_dests forall (m :: * -> *). (Stack, LogMonad m) => Text -> m () Log.notice forall a b. (a -> b) -> a -> b $ Text "derive integrated " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt BlockId source_id forall a. Semigroup a => a -> a -> a <> Text " to " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst [(BlockId, [NoteDestination])] dest_blocks) forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [(BlockId, [NoteDestination])] dest_blocks forall a b. (a -> b) -> a -> b $ \(BlockId dest_block_id, [NoteDestination] track_dests) -> forall (m :: * -> *). M m => BlockId -> Maybe (BlockId, TrackDestinations) -> m () Ui.set_integrated_block BlockId dest_block_id forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just (BlockId source_id, [NoteDestination] -> TrackDestinations Block.DeriveDestinations [NoteDestination] track_dests) forall (m :: * -> *). M m => [BlockId] -> m () Cmd.derive_immediately (forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst [(BlockId, [NoteDestination])] dest_blocks) where integrated_from :: Map a Block -> [(a, [NoteDestination])] integrated_from Map a Block blocks = [ (a block_id, [NoteDestination] dests) | (a block_id, Just (BlockId source_block, Block.DeriveDestinations [NoteDestination] dests)) <- forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second Block -> Maybe (BlockId, TrackDestinations) Block.block_integrated) (forall k a. Map k a -> [(k, a)] Map.toList Map a Block blocks) , BlockId source_block forall a. Eq a => a -> a -> Bool == BlockId source_id ] -- * score integrate -- | For each block with 'Block.ScoreDestinations', figure out if their sources -- have damage, and if so, re-integrate. score_integrate :: [Update.UiUpdate] -> Ui.State -> Either Ui.Error ([Log.Msg], Ui.State, Update.UiDamage) score_integrate :: [UiUpdate] -> State -> Either Error ([Msg], State, UiDamage) score_integrate [UiUpdate] updates State state = forall a. State -> StateId a -> Either Error (a, State, UiDamage) Ui.run_id State state forall a b. (a -> b) -> a -> b $ do -- These both use the passed state instead of using Ui.get when figuring -- out if there are updates that require integration. This way, a -- track integrate can't trigger a block integrate, at least not until the -- next call to this function. [Text] track_logs <- forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM forall (m :: * -> *). M m => (BlockId, TrackId) -> m [Text] score_integrate_tracks forall a b. (a -> b) -> a -> b $ [UiUpdate] -> State -> [(BlockId, TrackId)] needs_track_score_integrate [UiUpdate] updates State state [Text] block_logs <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM forall (m :: * -> *). M m => BlockId -> m Text score_integrate_block forall a b. (a -> b) -> a -> b $ [UiUpdate] -> State -> [BlockId] needs_block_score_integrate [UiUpdate] updates State state forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (Stack => Priority -> Maybe Stack -> Text -> Msg Log.msg Priority Log.Notice forall a. Maybe a Nothing) ([Text] track_logs forall a. [a] -> [a] -> [a] ++ [Text] block_logs) score_integrate_block :: Ui.M m => BlockId -> m Text score_integrate_block :: forall (m :: * -> *). M m => BlockId -> m Text score_integrate_block BlockId source_id = do Map BlockId Block blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a Ui.gets State -> Map BlockId Block Ui.state_blocks let integrated :: [(BlockId, ScoreDestinations)] integrated = forall {a}. Map a Block -> [(a, ScoreDestinations)] integrated_from Map BlockId Block blocks forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [(BlockId, ScoreDestinations)] integrated forall a b. (a -> b) -> a -> b $ \(BlockId dest_id, ScoreDestinations dests) -> do ScoreDestinations dests <- forall (m :: * -> *). M m => BlockId -> BlockId -> ScoreDestinations -> m ScoreDestinations Merge.score_merge_block BlockId source_id BlockId dest_id ScoreDestinations dests forall (m :: * -> *). M m => BlockId -> Maybe (BlockId, TrackDestinations) -> m () Ui.set_integrated_block BlockId dest_id forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just (BlockId source_id, ScoreDestinations -> TrackDestinations Block.ScoreDestinations ScoreDestinations dests) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Text "score integrated " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt BlockId source_id forall a. Semigroup a => a -> a -> a <> Text " to: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst [(BlockId, ScoreDestinations)] integrated) where integrated_from :: Map a Block -> [(a, ScoreDestinations)] integrated_from Map a Block blocks = [ (a block_id, ScoreDestinations dests) | (a block_id, Just (BlockId source_block, Block.ScoreDestinations ScoreDestinations dests)) <- forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second Block -> Maybe (BlockId, TrackDestinations) Block.block_integrated) (forall k a. Map k a -> [(k, a)] Map.toList Map a Block blocks) , BlockId source_block forall a. Eq a => a -> a -> Bool == BlockId source_id ] score_integrate_tracks :: Ui.M m => (BlockId, TrackId) -> m [Text] score_integrate_tracks :: forall (m :: * -> *). M m => (BlockId, TrackId) -> m [Text] score_integrate_tracks (BlockId block_id, TrackId track_id) = do [(TrackId, TrackDestinations)] itracks <- Block -> [(TrackId, TrackDestinations)] Block.block_integrated_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 let dests :: [ScoreDestinations] dests = [ ScoreDestinations dests | (TrackId source_id, Block.ScoreDestinations ScoreDestinations dests) <- [(TrackId, TrackDestinations)] itracks , TrackId source_id forall a. Eq a => a -> a -> Bool == TrackId track_id ] [ScoreDestinations] new_dests <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (forall (m :: * -> *). M m => BlockId -> TrackId -> ScoreDestinations -> m ScoreDestinations Merge.score_merge_tracks BlockId block_id TrackId track_id) [ScoreDestinations] dests forall (m :: * -> *). M m => BlockId -> ([(TrackId, TrackDestinations)] -> [(TrackId, TrackDestinations)]) -> m () Ui.modify_integrated_tracks BlockId block_id forall a b. (a -> b) -> a -> b $ forall key a. Eq key => key -> [(key, a)] -> [(key, a)] -> [(key, a)] replace TrackId track_id [(TrackId track_id, ScoreDestinations -> TrackDestinations Block.ScoreDestinations ScoreDestinations dests) | ScoreDestinations dests <- [ScoreDestinations] new_dests] forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map forall {a} {a} {b}. (Pretty a, Pretty a) => [(a, (a, b))] -> Text msg [ScoreDestinations] new_dests where msg :: [(a, (a, b))] -> Text msg [(a, (a, b))] dests = Text "score integrated " 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 ": " forall a. Semigroup a => a -> a -> a <> Text -> [Text] -> Text Text.intercalate Text ", " [ forall a. Pretty a => a -> Text pretty a source_id forall a. Semigroup a => a -> a -> a <> Text " -> " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty a dest_id | (a source_id, (a dest_id, b _)) <- [(a, (a, b))] dests ] replace :: Eq key => key -> [(key, a)] -> [(key, a)] -> [(key, a)] replace :: forall key a. Eq key => key -> [(key, a)] -> [(key, a)] -> [(key, a)] replace key key [(key, a)] new [(key, a)] xs = [(key, a)] new forall a. [a] -> [a] -> [a] ++ forall a. (a -> Bool) -> [a] -> [a] filter ((forall a. Eq a => a -> a -> Bool /=key key) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) [(key, a)] xs -- | Blocks which are block score integrate sources and have damage. needs_block_score_integrate :: [Update.UiUpdate] -> Ui.State -> [BlockId] needs_block_score_integrate :: [UiUpdate] -> State -> [BlockId] needs_block_score_integrate [UiUpdate] updates State state = forall a. (a -> Bool) -> [a] -> [a] filter BlockId -> Bool has_integrated forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [k] Map.keys forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> b -> a -> c flip forall k a. Ord k => Map k a -> Set k -> Map k a Map.restrictKeys Set BlockId damaged_blocks forall a b. (a -> b) -> a -> b $ State -> Map BlockId Block Ui.state_blocks State state where -- TODO this is a linear search through all blocks has_integrated :: BlockId -> Bool has_integrated BlockId block_id = Bool -> Bool not forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t a -> Bool null [ () | Just (BlockId dest_block_id, Block.ScoreDestinations {}) <- forall a b. (a -> b) -> [a] -> [b] map Block -> Maybe (BlockId, TrackDestinations) Block.block_integrated forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [a] Map.elems (State -> Map BlockId Block Ui.state_blocks State state) , BlockId block_id forall a. Eq a => a -> a -> Bool == BlockId dest_block_id ] damaged_blocks :: Set BlockId damaged_blocks = forall a. Ord a => [a] -> Set a Set.fromList forall a b. (a -> b) -> a -> b $ forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe forall {t} {u}. Update t u -> Maybe BlockId block_changed [UiUpdate] updates block_changed :: Update t u -> Maybe BlockId block_changed (Update.Block BlockId bid Block t _) = forall a. a -> Maybe a Just BlockId bid block_changed Update t u _ = forall a. Maybe a Nothing -- | Tracks which are track score integrate sources and have damage. needs_track_score_integrate :: [Update.UiUpdate] -> Ui.State -> [(BlockId, TrackId)] needs_track_score_integrate :: [UiUpdate] -> State -> [(BlockId, TrackId)] needs_track_score_integrate [UiUpdate] updates State state = forall a. Ord a => [a] -> [a] Lists.unique forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap (TrackId -> [(BlockId, TrackId)] integrated_blocks forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) forall a b. (a -> b) -> a -> b $ forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe UiUpdate -> Maybe (TrackId, Ranges ScoreTime) Update.track_changed [UiUpdate] updates where integrated_blocks :: TrackId -> [(BlockId, TrackId)] integrated_blocks TrackId track_id = [ (BlockId block_id, TrackId track_id) | (BlockId block_id, Block block) <- TrackId -> [(BlockId, Block)] blocks_with TrackId track_id , Block -> TrackId -> Bool has_integrated Block block TrackId track_id ] -- TODO this is a linear search through all blocks, as is -- Ui.blocks_with_track_id. blocks_with :: TrackId -> [(BlockId, Block)] blocks_with TrackId track_id = forall a. (a -> Bool) -> [a] -> [a] filter (TrackId -> Block -> Bool has_track TrackId track_id forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [(k, a)] Map.toList forall a b. (a -> b) -> a -> b $ State -> Map BlockId Block Ui.state_blocks State state has_track :: TrackId -> Block -> Bool has_track TrackId track_id Block block = TrackId track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` Block -> [TrackId] Block.block_track_ids Block block has_integrated :: Block -> TrackId -> Bool has_integrated Block block TrackId track_id = Bool -> Bool not forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t a -> Bool null [ () | (TrackId source_track_id, Block.ScoreDestinations {}) <- Block -> [(TrackId, TrackDestinations)] Block.block_integrated_tracks Block block , TrackId track_id forall a. Eq a => a -> a -> Bool == TrackId source_track_id ] -- * manual integrate -- | Find blocks with the source key, and merge the given tracks into them. -- -- If you are creating a new track, you need to have already done that and put -- an empty destination in it. Otherwise, this will find no existing -- destinations and do nothing. manual_integrate :: Ui.M m => Block.SourceKey -> Convert.Track -- ^ note track -> [Convert.Track] -- ^ dependent control tracks -> m () manual_integrate :: forall (m :: * -> *). M m => Text -> Track -> [Track] -> m () manual_integrate Text key Track note [Track] controls = do [(BlockId, [NoteDestination])] block_dests <- forall a. Text -> [(a, Block)] -> [(a, [NoteDestination])] manual_destinations Text key forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [(k, a)] Map.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) a. M m => (State -> a) -> m a Ui.gets State -> Map BlockId Block Ui.state_blocks forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [(BlockId, [NoteDestination])] block_dests forall a b. (a -> b) -> a -> b $ \(BlockId block_id, [NoteDestination] dests) -> do [[NoteDestination]] new_dests <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM [NoteDestination] dests forall a b. (a -> b) -> a -> b $ \NoteDestination dest -> forall (m :: * -> *). M m => MergeTitles -> BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination] Merge.merge_tracks MergeTitles Merge.KeepTitles BlockId block_id [(Track note, [Track] controls)] [NoteDestination dest] forall (m :: * -> *). M m => BlockId -> Text -> Maybe [NoteDestination] -> m () Ui.set_integrated_manual BlockId block_id Text key (forall a. a -> Maybe a Just (forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [[NoteDestination]] new_dests)) -- | Find all manual derive destinations with the given key. manual_destinations :: Block.SourceKey -> [(a, Block.Block)] -> [(a, [Block.NoteDestination])] manual_destinations :: forall a. Text -> [(a, Block)] -> [(a, [NoteDestination])] manual_destinations Text key = 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) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (forall k a. Ord k => a -> k -> Map k a -> a Map.findWithDefault [] Text key forall b c a. (b -> c) -> (a -> b) -> a -> c . Block -> ManualDestinations Block.block_integrated_manual))