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

{- | Support for high level score modifications.  This is companion to
    "Cmd.ModifyEvents", which is for low level transformations.

    The main interface to this is "Cmd.Repl.LNote".

    The score language is code to to be interpreted, not data to be
    manipulated.  This is good for flexibility, but bad for direct
    transformation.  Therefore, all the functions in here rely on a certain
    amount of conventional structure to tame the flexibility.

    The lowest level, represented by a list of 'Note's, assumes that each
    note track has a single \"branch\" of control tracks underneath it, and
    each note event has control values within its extent, so each note can be
    sliced out and treated as a unit.  So it doesn't support note tracks with
    multiple parallel children, and it doesn't support order-dependent control
    tracks, which means that relative controls are out too (TODO actually
    a relative control track is fine as long as there's only one).  Also,
    since notes only carry along the controls directly underneath them,
    they can wind up with different control values when they are placed on
    a different track (TODO it would be possible to deal with this too, by
    copying the events forward).

    I initially attempted to support trees of control tracks in full
    generality, or even just an ordered list of controls, but there's a problem
    when different Notes have different controls: where do the control tracks
    get merged into a tree, relative to each other?  Not only do I have to
    invent an order, but it has to be linear, since there's also no information
    to merge into a branching skeleton.  Since I can't create one with 'Note's,
    I felt Notes shouldn't be able to parse them either.

    The 'Note's can be annotated with additional data, such as pitch, but
    of course will make it more specialized and reliant on convention.  For
    instance, the pitches have to be extracted from the pitch events, which
    will fail unless there's an easily parseable pitch in there.

    TODO it should be possible to get the pitch out of the derivation by
    finding the corresponding Score.Event by looking for its stack.
-}
module Cmd.ModifyNotes where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree
import qualified Data.Vector as Vector

import qualified Util.Lens as Lens
import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Util.Pretty as Pretty
import qualified Util.Trees as Trees

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Create as Create
import qualified Cmd.Selection as Selection

import qualified Derive.PSignal as PSignal
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack

import qualified Perform.Pitch as Pitch
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Types as Types
import qualified Ui.Ui as Ui

import           Global
import           Types


-- | This represents a single event on a note track.
data Note = Note {
    Note -> TrackTime
note_start :: !TrackTime
    , Note -> TrackTime
note_duration :: !TrackTime
    , Note -> Error
note_text :: !Text
    -- | This is the contents of the child tracks, where they overlap this
    -- Note's range.
    , Note -> Controls
note_controls :: !Controls
    , Note -> Index
note_index :: !Index
    , Note -> [TrackId]
note_control_track_ids :: ![TrackId]
    } deriving (Note -> Note -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note -> Note -> Bool
$c/= :: Note -> Note -> Bool
== :: Note -> Note -> Bool
$c== :: Note -> Note -> Bool
Eq, Index -> Note -> ShowS
[Note] -> ShowS
Note -> String
forall a.
(Index -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note] -> ShowS
$cshowList :: [Note] -> ShowS
show :: Note -> String
$cshow :: Note -> String
showsPrec :: Index -> Note -> ShowS
$cshowsPrec :: Index -> Note -> ShowS
Show)

note_end :: Note -> TrackTime
note_end :: Note -> TrackTime
note_end Note
note = Note -> TrackTime
note_start Note
note forall a. Num a => a -> a -> a
+ Note -> TrackTime
note_duration Note
note

start :: Note :-> TrackTime
start = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Note -> TrackTime
note_start
    (\TrackTime -> TrackTime
f Note
r -> Note
r { note_start :: TrackTime
note_start = TrackTime -> TrackTime
f (Note -> TrackTime
note_start Note
r) })
duration :: Note :-> TrackTime
duration = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Note -> TrackTime
note_duration
    (\TrackTime -> TrackTime
f Note
r -> Note
r { note_duration :: TrackTime
note_duration = TrackTime -> TrackTime
f (Note -> TrackTime
note_duration Note
r) })
text :: Note :-> Error
text = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Note -> Error
note_text
    (\Error -> Error
f Note
r -> Note
r { note_text :: Error
note_text = Error -> Error
f (Note -> Error
note_text Note
r) })
controls :: Note :-> Controls
controls = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Note -> Controls
note_controls
    (\Controls -> Controls
f Note
r -> Note
r { note_controls :: Controls
note_controls = Controls -> Controls
f (Note -> Controls
note_controls Note
r) })
index :: Note :-> Index
index = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Note -> Index
note_index
    (\Index -> Index
f Note
r -> Note
r { note_index :: Index
note_index = Index -> Index
f (Note -> Index
note_index Note
r) })

end :: Note :-> TrackTime
end = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Note -> TrackTime
note_end
    (\TrackTime -> TrackTime
f Note
r -> Note
r { note_start :: TrackTime
note_start = TrackTime -> TrackTime
f (Note -> TrackTime
note_end Note
r) forall a. Num a => a -> a -> a
- Note -> TrackTime
note_duration Note
r })

note_min :: Note -> TrackTime
note_min :: Note -> TrackTime
note_min Note
n = forall a. Ord a => a -> a -> a
min (Note -> TrackTime
note_start Note
n) (Note -> TrackTime
note_end Note
n)

note_max :: Note -> TrackTime
note_max :: Note -> TrackTime
note_max Note
n = forall a. Ord a => a -> a -> a
max (Note -> TrackTime
note_start Note
n) (Note -> TrackTime
note_end Note
n)

note_orientation :: Note -> Types.Orientation
note_orientation :: Note -> Orientation
note_orientation = TrackTime -> Orientation
Event.orientation_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> TrackTime
note_duration

-- | Each note has an Index, which indicates which of the selected note tracks
-- it came from, or should be written to.
type Index = Int

instance Pretty Note where
    format :: Note -> Doc
format (Note TrackTime
start TrackTime
dur Error
text Controls
controls Index
index [TrackId]
control_track_ids) =
        Doc -> [(Error, Doc)] -> Doc
Pretty.record Doc
title forall a b. (a -> b) -> a -> b
$
            (if Error
text forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty then [] else [(Error
"text", forall a. Pretty a => a -> Doc
Pretty.format Error
text)]) forall a. [a] -> [a] -> [a]
++
            [ (Error
"controls", forall a. Pretty a => a -> Doc
Pretty.format Controls
controls)
            , (Error
"index", forall a. Pretty a => a -> Doc
Pretty.format Index
index)
            , (Error
"control_track_ids", forall a. Pretty a => a -> Doc
Pretty.format [TrackId]
control_track_ids)
            ]
        where
        title :: Doc
title = Error -> Doc
Pretty.text Error
"Note" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Pretty.format (TrackTime
start, TrackTime
dur)

notes_overlap :: Note -> Note -> Bool
notes_overlap :: Note -> Note -> Bool
notes_overlap Note
n1 Note
n2 =
    Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Note -> TrackTime
note_min Note
n1 forall a. Ord a => a -> a -> Bool
>= Note -> TrackTime
note_max Note
n2 Bool -> Bool -> Bool
|| Note -> TrackTime
note_max Note
n1 forall a. Ord a => a -> a -> Bool
<= Note -> TrackTime
note_min Note
n2

-- * controls

type Controls = Map Control Events.Events

-- | A simplified version of 'ParseTitle.ControlType', since Notes don't
-- support all the forms of control tracks.  Put Pitch first so it sorts first,
-- to support the convention of putting the pitch track right after the note
-- track.
data Control = Pitch Pitch.ScaleId | Control ScoreT.Control
    deriving (Control -> Control -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Control -> Control -> Bool
$c/= :: Control -> Control -> Bool
== :: Control -> Control -> Bool
$c== :: Control -> Control -> Bool
Eq, Eq Control
Control -> Control -> Bool
Control -> Control -> Ordering
Control -> Control -> Control
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Control -> Control -> Control
$cmin :: Control -> Control -> Control
max :: Control -> Control -> Control
$cmax :: Control -> Control -> Control
>= :: Control -> Control -> Bool
$c>= :: Control -> Control -> Bool
> :: Control -> Control -> Bool
$c> :: Control -> Control -> Bool
<= :: Control -> Control -> Bool
$c<= :: Control -> Control -> Bool
< :: Control -> Control -> Bool
$c< :: Control -> Control -> Bool
compare :: Control -> Control -> Ordering
$ccompare :: Control -> Control -> Ordering
Ord, Index -> Control -> ShowS
[Control] -> ShowS
Control -> String
forall a.
(Index -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Control] -> ShowS
$cshowList :: [Control] -> ShowS
show :: Control -> String
$cshow :: Control -> String
showsPrec :: Index -> Control -> ShowS
$cshowsPrec :: Index -> Control -> ShowS
Show)

instance Pretty Control where
    pretty :: Control -> Error
pretty = Control -> Error
control_to_title

control_to_title :: Control -> Text
control_to_title :: Control -> Error
control_to_title Control
control = case Control
control of
    Control Control
c -> Typed Control -> Error
ParseTitle.control_to_title forall a b. (a -> b) -> a -> b
$ forall a. a -> Typed a
ScoreT.untyped Control
c
    Pitch ScaleId
scale_id -> ScaleId -> Error
ParseTitle.scale_to_title ScaleId
scale_id

type Error = Text

title_to_control :: Text -> Either Error Control
title_to_control :: Error -> Either Error Control
title_to_control Error
title = Error -> Either Error ControlType
ParseTitle.parse_control_type Error
title forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ParseTitle.Control (Right (ScoreT.Typed Type
ScoreT.Untyped Control
c)) Maybe TrackCall
Nothing ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Control
Control Control
c
    ParseTitle.Pitch ScaleId
scale_id (Right PControl
pcontrol)
        | PControl
pcontrol forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ScaleId -> Control
Pitch ScaleId
scale_id
    ControlType
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Error
"complicated controls unsupported: " forall a. Semigroup a => a -> a -> a
<> Error
title

-- | Put the pitch tracks next to the note, the rest go in alphabetical order.
sorted_controls :: Controls -> [(Control, Events.Events)]
sorted_controls :: Controls -> [(Control, Events)]
sorted_controls = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (forall {a}. Num a => Control -> (a, Control)
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
    where
    key :: Control -> (a, Control)
key c :: Control
c@(Pitch {}) = (a
0, Control
c)
    key c :: Control
c@(Control {}) = (a
1, Control
c)


-- * selection

-- | Modify notes.
type ModifyNotes m = BlockId -> [(Note, TrackId)] -> m [Note]

notes :: Monad m => ([Note] -> [Note]) -> ModifyNotes m
notes :: forall (m :: * -> *).
Monad m =>
([Note] -> [Note]) -> ModifyNotes m
notes [Note] -> [Note]
f BlockId
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Note] -> [Note]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst

-- | Modify a single note.
note :: Monad m => (Note -> Note) -> ModifyNotes m
note :: forall (m :: * -> *). Monad m => (Note -> Note) -> ModifyNotes m
note Note -> Note
f BlockId
_ = 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] -> [b]
map (Note -> Note
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

-- | Modify notes on the selected tracks.  Only the top level note tracks are
-- affected, so you can select an entire block and not worry about mangling
-- parent controls.
--
-- This may add new tracks, but will not delete tracks that are made empty.
-- It could, but it seems easy enough to delete the tracks by hand once
-- I verify that the transformation worked.  TODO revisit this if it's annoying
selection :: Cmd.M m => ModifyNotes m -> m ()
selection :: forall (m :: * -> *). M m => ModifyNotes m -> m ()
selection ModifyNotes m
modify = do
    [(Note, TrackId)]
old_notes <- forall (m :: * -> *). M m => m [(Note, TrackId)]
selected_notes
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    [Note]
new_notes <- ModifyNotes m
modify BlockId
block_id [(Note, TrackId)]
old_notes
    -- Clear selected events before merging in new ones.
    let ranges :: [(TrackId, Range)]
ranges = [(Note, TrackId)] -> [(TrackId, Range)]
remove_ranges [(Note, TrackId)]
old_notes
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TrackId, Range)]
ranges forall a b. (a -> b) -> a -> b
$ \(TrackId
track_id, Range
range) ->
        forall (m :: * -> *). M m => TrackId -> Range -> m ()
Ui.remove_events_range TrackId
track_id Range
range
    forall (m :: * -> *).
M m =>
BlockId -> [TrackId] -> [NoteTrack] -> m ()
write_tracks BlockId
block_id (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TrackId, Range)]
ranges) ([Note] -> [NoteTrack]
merge_notes [Note]
new_notes)

remove_ranges :: [(Note, TrackId)] -> [(TrackId, Events.Range)]
remove_ranges :: [(Note, TrackId)] -> [(TrackId, Range)]
remove_ranges = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Note], TrackId) -> [(TrackId, Range)]
range forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => [(a, b)] -> [(NonNull a, b)]
Lists.groupSnd
    where
    range :: ([Note], TrackId) -> [(TrackId, Range)]
range ([], TrackId
_) = [] -- shouldn't happen, per Lists.groupSnd's postcondition
    range (notes :: [Note]
notes@(Note
note : [Note]
_), TrackId
track_id) =
        (TrackId
track_id, TrackTime -> TrackTime -> Range
Events.Range TrackTime
start TrackTime
end)
            forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (, TrackTime -> TrackTime -> Range
Events.Range TrackTime
start TrackTime
end) (Note -> [TrackId]
note_control_track_ids Note
note)
        where
        start :: TrackTime
start = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Note -> TrackTime
note_min [Note]
notes
        end :: TrackTime
end = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Note -> TrackTime
note_max [Note]
notes
        -- All Notes with the same TrackId should also have the same
        -- note_control_track_ids.

-- | Find the top-level note tracks in the selection, and reduce them down to
-- Notes.
selected_notes :: Cmd.M m => m [(Note, TrackId)]
selected_notes :: forall (m :: * -> *). M m => m [(Note, TrackId)]
selected_notes = do
    let is_note :: (TrackId, b) -> m Bool
is_note = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Error -> Bool
ParseTitle.is_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Error
Ui.get_track_title forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
    [(TrackId, [Event])]
sel <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall {b}. (TrackId, b) -> m Bool
is_note forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [(TrackId, [Event])]
Selection.events
    TrackTree
tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree
TrackTree.track_tree_of forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    forall (m :: * -> *).
M m =>
TrackTree -> [(TrackId, [Event])] -> m [(Note, TrackId)]
slice_tracks TrackTree
tree [(TrackId, [Event])]
sel

-- ** annotated transformations

type Annotated a m = [(Note, a)] -> m [Note]

annotate_nns :: Cmd.M m => Annotated (Maybe Pitch.NoteNumber) m
    -> ModifyNotes m
annotate_nns :: forall (m :: * -> *).
M m =>
Annotated (Maybe NoteNumber) m -> ModifyNotes m
annotate_nns Annotated (Maybe NoteNumber) m
modify = forall (m :: * -> *).
M m =>
Annotated (Maybe Transposed, ControlValMap) m -> ModifyNotes m
annotate_controls (Annotated (Maybe NoteNumber) m
modify 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 (Transposed -> Maybe NoteNumber
eval forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a b. (a, b) -> a
fst)))
    where eval :: Transposed -> Maybe NoteNumber
eval = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError NoteNumber
PSignal.pitch_nn

annotate_controls :: Cmd.M m
    => Annotated (Maybe PSignal.Transposed, ScoreT.ControlValMap) m
    -> ModifyNotes m
annotate_controls :: forall (m :: * -> *).
M m =>
Annotated (Maybe Transposed, ControlValMap) m -> ModifyNotes m
annotate_controls Annotated (Maybe Transposed, ControlValMap) m
modify BlockId
block_id [(Note, TrackId)]
note_track_ids = do
    Vector Event
events <- Performance -> Vector Event
Cmd.perf_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    Annotated (Maybe Transposed, ControlValMap) m
modify forall a b. (a -> b) -> a -> b
$ [(Note, TrackId)]
-> Vector Event -> [(Note, (Maybe Transposed, ControlValMap))]
find_controls [(Note, TrackId)]
note_track_ids Vector Event
events

-- | This finds the controls of each note by looking for its corresponding
-- event in the performance.  TODO matching by stack seems like it could be
-- inaccurate, and inefficient too.  Shouldn't I look up the signal directly
-- from the performance?
find_controls :: [(Note, TrackId)] -> Vector.Vector Score.Event
    -> [(Note, (Maybe PSignal.Transposed, ScoreT.ControlValMap))]
find_controls :: [(Note, TrackId)]
-> Vector Event -> [(Note, (Maybe Transposed, ControlValMap))]
find_controls [(Note, TrackId)]
note_track_ids Vector Event
events =
    forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Note, TrackId)]
note_track_ids) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (Maybe Event -> (Maybe Transposed, ControlValMap)
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Event -> (Note, TrackId) -> Maybe Event
convert Vector Event
events) [(Note, TrackId)]
note_track_ids
    where
    convert :: Vector Event -> (Note, TrackId) -> Maybe Event
convert Vector Event
events (Note
note, TrackId
track_id) = TrackId -> Note -> Vector Event -> Maybe Event
find_event TrackId
track_id Note
note Vector Event
events
    extract :: Maybe Event -> (Maybe Transposed, ControlValMap)
extract Maybe Event
Nothing = (forall a. Maybe a
Nothing, forall a. Monoid a => a
mempty)
    extract (Just Event
event) =
        ( Event -> Maybe Transposed
Score.initial_pitch Event
event
        , RealTime -> Event -> ControlValMap
Score.event_controls_at (Event -> RealTime
Score.event_start Event
event) Event
event
        )

find_event :: TrackId -> Note -> Vector.Vector Score.Event -> Maybe Score.Event
find_event :: TrackId -> Note -> Vector Event -> Maybe Event
find_event TrackId
track_id Note
note = forall a. (a -> Bool) -> Vector a -> Maybe a
Vector.find forall a b. (a -> b) -> a -> b
$ \Event
event ->
    TrackId -> TrackTime -> TrackTime -> Stack -> Bool
stack_matches TrackId
track_id (Note -> TrackTime
note_start Note
note) (Note -> TrackTime
note_end Note
note) forall a b. (a -> b) -> a -> b
$
        Event -> Stack
Score.event_stack Event
event

stack_matches :: TrackId -> TrackTime -> TrackTime -> Stack.Stack -> Bool
stack_matches :: TrackId -> TrackTime -> TrackTime -> Stack -> Bool
stack_matches TrackId
track_id TrackTime
start TrackTime
end =
    [Frame] -> Bool
find_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> TrackTime -> [Frame] -> [Frame]
find_region TrackTime
start TrackTime
end forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> [Frame]
Stack.innermost
    where
    find_region :: TrackTime -> TrackTime -> [Frame] -> [Frame]
find_region TrackTime
start TrackTime
end = forall a. Index -> [a] -> [a]
drop Index
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= TrackTime -> TrackTime -> Frame
Stack.Region TrackTime
start TrackTime
end)
    -- Find the Track, but abort if I see a region or block
    find_track :: [Frame] -> Bool
find_track [Frame]
frames = case [Frame]
frames of
        Stack.Track TrackId
tid : [Frame]
_ -> TrackId
track_id forall a. Eq a => a -> a -> Bool
== TrackId
tid
        Stack.Call {} : [Frame]
rest -> [Frame] -> Bool
find_track [Frame]
rest
        [Frame]
_ -> Bool
False

-- * read

slice_tracks :: Ui.M m => TrackTree.TrackTree -> [(TrackId, [Event.Event])]
    -> m [(Note, TrackId)]
slice_tracks :: forall (m :: * -> *).
M m =>
TrackTree -> [(TrackId, [Event])] -> m [(Note, TrackId)]
slice_tracks TrackTree
tree = forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM forall (m :: * -> *).
M m =>
(Index, (TrackId, [Event])) -> m [(Note, TrackId)]
slice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Index
0..]
    where
    slice :: Ui.M m => (Index, (TrackId, [Event.Event]))
        -> m [(Note, TrackId)]
    slice :: forall (m :: * -> *).
M m =>
(Index, (TrackId, [Event])) -> m [(Note, TrackId)]
slice (Index
index, (TrackId
track_id, [Event]
events)) =
        case forall a. (a -> Bool) -> [Tree a] -> Maybe (Tree a)
Trees.find ((forall a. Eq a => a -> a -> Bool
==TrackId
track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> TrackId
Ui.track_id) TrackTree
tree of
            Maybe (Tree TrackInfo)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just (Tree.Node TrackInfo
_track TrackTree
subs) -> do
                [Tree (TrackInfo, Events)]
subs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {f :: * -> *}. M f => TrackInfo -> f (TrackInfo, Events)
get_events) TrackTree
subs
                [Note]
notes <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Error) -> Either err a -> m a
Ui.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
                    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Index -> [Tree (TrackInfo, Events)] -> Event -> Either Error Note
slice_note Index
index [Tree (TrackInfo, Events)]
subs) [Event]
events
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (, TrackId
track_id) [Note]
notes
    get_events :: TrackInfo -> f (TrackInfo, Events)
get_events TrackInfo
track = (TrackInfo
track,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m Events
Ui.get_events (TrackInfo -> TrackId
Ui.track_id TrackInfo
track)

-- | The whole thing fails if a title is unparseable or the control tracks have
-- a fork in the skeleton.
--
-- This is similar to 'Derive.Slice.slice' and I initially spent some time
-- trying to reuse it, but it's different enough that most of the work that
-- slice does doesn't apply here.
slice_note :: Index -> [Tree.Tree (Ui.TrackInfo, Events.Events)]
    -> Event.Event -> Either Error Note
slice_note :: Index -> [Tree (TrackInfo, Events)] -> Event -> Either Error Note
slice_note Index
index [Tree (TrackInfo, Events)]
subs Event
event = do
    [(Control, Events)]
controls <- (TrackTime, TrackTime)
-> [Tree (TrackInfo, Events)] -> Either Error [(Control, Events)]
extract_controls (Event -> (TrackTime, TrackTime)
Event.range Event
event) [Tree (TrackInfo, Events)]
subs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Note
        { note_start :: TrackTime
note_start = Event -> TrackTime
Event.start Event
event
        , note_duration :: TrackTime
note_duration = Event -> TrackTime
Event.duration Event
event
        , note_text :: Error
note_text = Event -> Error
Event.text Event
event
        , note_controls :: Controls
note_controls = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Control, Events)]
controls
        , note_index :: Index
note_index = Index
index
        , note_control_track_ids :: [TrackId]
note_control_track_ids = forall a b. (a -> b) -> [a] -> [b]
map (TrackInfo -> TrackId
Ui.track_id 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 (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Tree a -> [a]
Tree.flatten [Tree (TrackInfo, Events)]
subs
        }

extract_controls :: (TrackTime, TrackTime)
    -> [Tree.Tree (Ui.TrackInfo, Events.Events)]
    -> Either Error [(Control, Events.Events)]
extract_controls :: (TrackTime, TrackTime)
-> [Tree (TrackInfo, Events)] -> Either Error [(Control, Events)]
extract_controls (TrackTime, TrackTime)
range [Tree (TrackInfo, Events)]
tracks = case [Tree (TrackInfo, Events)]
tracks of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    [Tree.Node (TrackInfo
track, Events
events) [Tree (TrackInfo, Events)]
subs] -> do
        Control
control <- forall a. Error -> Either Error a -> Either Error a
annotate (forall a. Show a => a -> Error
showt (TrackInfo -> TrackId
Ui.track_id TrackInfo
track)) forall a b. (a -> b) -> a -> b
$
            Error -> Either Error Control
title_to_control (TrackInfo -> Error
Ui.track_title TrackInfo
track)
        [(Control, Events)]
rest <- (TrackTime, TrackTime)
-> [Tree (TrackInfo, Events)] -> Either Error [(Control, Events)]
extract_controls (TrackTime, TrackTime)
range [Tree (TrackInfo, Events)]
subs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Control
control, (TrackTime, TrackTime) -> Events -> Events
slice (TrackTime, TrackTime)
range Events
events) forall a. a -> [a] -> [a]
: [(Control, Events)]
rest
    [Tree (TrackInfo, Events)]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Error
">1 subtrack: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Error
showt (forall a b. (a -> b) -> [a] -> [b]
map (TrackInfo -> TrackId
Ui.track_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
Tree.rootLabel) [Tree (TrackInfo, Events)]
tracks)
    where
    slice :: (TrackTime, TrackTime) -> Events -> Events
slice (TrackTime
start, TrackTime
end) Events
e = Range -> Events -> Events
Events.in_range (TrackTime -> TrackTime -> Range
Events.Range TrackTime
start TrackTime
end) Events
e

annotate :: Text -> Either Error a -> Either Error a
annotate :: forall a. Error -> Either Error a -> Either Error a
annotate Error
prefix = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Error
prefix forall a. Semigroup a => a -> a -> a
<> Error
": ") <>)

-- * write

data NoteTrack = NoteTrack Events.Events Controls
    deriving (NoteTrack -> NoteTrack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteTrack -> NoteTrack -> Bool
$c/= :: NoteTrack -> NoteTrack -> Bool
== :: NoteTrack -> NoteTrack -> Bool
$c== :: NoteTrack -> NoteTrack -> Bool
Eq, Index -> NoteTrack -> ShowS
[NoteTrack] -> ShowS
NoteTrack -> String
forall a.
(Index -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteTrack] -> ShowS
$cshowList :: [NoteTrack] -> ShowS
show :: NoteTrack -> String
$cshow :: NoteTrack -> String
showsPrec :: Index -> NoteTrack -> ShowS
$cshowsPrec :: Index -> NoteTrack -> ShowS
Show)

instance Semigroup NoteTrack where
    NoteTrack Events
events1 Controls
controls1 <> :: NoteTrack -> NoteTrack -> NoteTrack
<> NoteTrack Events
events2 Controls
controls2 =
        Events -> Controls -> NoteTrack
NoteTrack (Events
events1 forall a. Semigroup a => a -> a -> a
<> Events
events2) (forall k a. (Ord k, Monoid a) => Map k a -> Map k a -> Map k a
Maps.mappend Controls
controls1 Controls
controls2)
instance Monoid NoteTrack where
    mempty :: NoteTrack
mempty = Events -> Controls -> NoteTrack
NoteTrack forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: NoteTrack -> NoteTrack -> NoteTrack
mappend = forall a. Semigroup a => a -> a -> a
(<>)

merge_notes :: [Note] -> [NoteTrack]
merge_notes :: [Note] -> [NoteTrack]
merge_notes = forall a b. (a -> b) -> [a] -> [b]
map [Note] -> NoteTrack
make_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> [a] -> [[a]]
Lists.groupSort Note -> Index
note_index
    where
    make_track :: [Note] -> NoteTrack
    make_track :: [Note] -> NoteTrack
make_track = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Semigroup a => a -> a -> a
(<>) forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Note -> NoteTrack
note_track
    note_track :: Note -> NoteTrack
note_track Note
note = Events -> Controls -> NoteTrack
NoteTrack (Event -> Events
Events.singleton Event
event) (Note -> Controls
note_controls Note
note)
        where
        event :: Event
event = TrackTime -> TrackTime -> Error -> Event
Event.event (Note -> TrackTime
note_start Note
note) (Note -> TrackTime
note_duration Note
note)
            (Note -> Error
note_text Note
note)

-- | Write NoteTracks to the given block.  It may create new tracks, but won't
-- delete ones that are made empty.
write_tracks :: Ui.M m => BlockId
    -> [TrackId] -- ^ The TrackIds are expected to line up with NoteTracks.
    -- If there are more NoteTracks than TrackIds, new tracks will be created.
    -> [NoteTrack] -> m ()
write_tracks :: forall (m :: * -> *).
M m =>
BlockId -> [TrackId] -> [NoteTrack] -> m ()
write_tracks BlockId
block_id [TrackId]
track_ids [NoteTrack]
tracks = do
    TrackTree
old_tree <- forall (m :: * -> *). M m => BlockId -> [TrackId] -> m TrackTree
extract_note_trees BlockId
block_id [TrackId]
track_ids
    forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ forall {m :: * -> *}. M m => Tree TrackInfo -> NoteTrack -> m ()
merge TrackTree
old_tree [NoteTrack]
tracks
    Index
next_tracknum <- forall (m :: * -> *). M m => BlockId -> [TrackId] -> m Index
tracknum_after BlockId
block_id [TrackId]
track_ids
    forall {m :: * -> *}. M m => Index -> [NoteTrack] -> m ()
create Index
next_tracknum (forall a. Index -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Index
length TrackTree
old_tree) [NoteTrack]
tracks)
    where
    merge :: Tree TrackInfo -> NoteTrack -> m ()
merge (Tree.Node TrackInfo
track TrackTree
subs) (NoteTrack Events
events Controls
controls) = do
        forall (m :: * -> *). M m => TrackId -> [Event] -> m ()
Ui.insert_events (TrackInfo -> TrackId
Ui.track_id TrackInfo
track) (Events -> [Event]
Events.ascending Events
events)
        forall (m :: * -> *).
M m =>
BlockId -> TrackId -> TrackTree -> [(Control, Events)] -> m ()
merge_controls BlockId
block_id (TrackInfo -> TrackId
Ui.track_id TrackInfo
track) TrackTree
subs forall a b. (a -> b) -> a -> b
$
            Controls -> [(Control, Events)]
sorted_controls Controls
controls
    -- | Create new tracks.
    create :: Index -> [NoteTrack] -> m ()
create Index
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    create Index
tracknum (NoteTrack Events
events Controls
controls : [NoteTrack]
rest)
        | Events -> Bool
Events.null Events
events = Index -> [NoteTrack] -> m ()
create Index
tracknum [NoteTrack]
rest
        | Bool
otherwise = do
            let tracks :: [(Error, Events)]
tracks = (Error
">", Events
events)
                    forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Control -> Error
control_to_title) (Controls -> [(Control, Events)]
sorted_controls Controls
controls)
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Index
tracknum..] [(Error, Events)]
tracks) forall a b. (a -> b) -> a -> b
$ \(Index
n, (Error
title, Events
events)) ->
                forall (m :: * -> *).
M m =>
BlockId -> Index -> Error -> Events -> m TrackId
Create.track BlockId
block_id Index
n Error
title Events
events
            forall (m :: * -> *). M m => BlockId -> [Edge] -> m ()
Ui.add_edges BlockId
block_id forall a b. (a -> b) -> a -> b
$ forall a. Index -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Index
length [(Error, Events)]
tracks forall a. Num a => a -> a -> a
- Index
1) forall a b. (a -> b) -> a -> b
$
                forall a b. [a] -> [b] -> [(a, b)]
zip [Index
tracknum..] [Index
tracknumforall a. Num a => a -> a -> a
+Index
1..]
            Maybe TrackInfo
parent <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe TrackInfo)
parent_of BlockId
block_id)
                (forall a. [a] -> Maybe a
Lists.head [TrackId]
track_ids)
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe TrackInfo
parent forall a b. (a -> b) -> a -> b
$ \TrackInfo
p ->
                forall (m :: * -> *). M m => BlockId -> [Edge] -> m ()
Ui.add_edges BlockId
block_id [(TrackInfo -> Index
Ui.track_tracknum TrackInfo
p, Index
tracknum)]
            Index -> [NoteTrack] -> m ()
create (Index
tracknum forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Index
length [(Error, Events)]
tracks) [NoteTrack]
rest

extract_note_trees :: Ui.M m => BlockId -> [TrackId] -> m TrackTree.TrackTree
extract_note_trees :: forall (m :: * -> *). M m => BlockId -> [TrackId] -> m TrackTree
extract_note_trees BlockId
block_id [TrackId]
track_ids =
    forall a. (a -> Bool) -> [Tree a] -> [Tree a]
Trees.findAll (Set TrackId -> TrackInfo -> Bool
wanted_track (forall a. Ord a => [a] -> Set a
Set.fromList [TrackId]
track_ids)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *). M m => BlockId -> m TrackTree
TrackTree.track_tree_of BlockId
block_id
    where
    -- | Accept the top level note tracks.
    wanted_track :: Set TrackId -> TrackInfo -> Bool
wanted_track Set TrackId
track_ids TrackInfo
track =
        Error -> Bool
ParseTitle.is_note_track (TrackInfo -> Error
Ui.track_title TrackInfo
track)
        Bool -> Bool -> Bool
&& TrackInfo -> TrackId
Ui.track_id TrackInfo
track forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
track_ids

merge_controls :: Ui.M m => BlockId -> TrackId -> TrackTree.TrackTree
    -> [(Control, Events.Events)] -> m ()
merge_controls :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> TrackTree -> [(Control, Events)] -> m ()
merge_controls BlockId
block_id TrackId
note_track_id TrackTree
tree [(Control, Events)]
controls = do
    -- Don't use Ui.track_tracknum because it will be out of date if
    -- an earlier merge inserted a new track.
    Index
next_tracknum <- forall (m :: * -> *). M m => BlockId -> [TrackId] -> m Index
tracknum_after BlockId
block_id forall a b. (a -> b) -> a -> b
$
        TrackId
note_track_id forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> TrackId
Ui.track_id [TrackInfo]
tracks
    forall {m :: * -> *}. M m => Index -> [(Control, Events)] -> m ()
go Index
next_tracknum [(Control, Events)]
controls
    where
    go :: Index -> [(Control, Events)] -> m ()
go Index
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go Index
tracknum ((Control
control, Events
events) : [(Control, Events)]
controls) = case Control -> Maybe TrackInfo
find Control
control of
        Just TrackInfo
track -> do
            forall (m :: * -> *). M m => TrackId -> [Event] -> m ()
Ui.insert_events (TrackInfo -> TrackId
Ui.track_id TrackInfo
track) (Events -> [Event]
Events.ascending Events
events)
            Index -> [(Control, Events)] -> m ()
go Index
tracknum [(Control, Events)]
controls
        Maybe TrackInfo
Nothing -> do
            forall (m :: * -> *).
M m =>
BlockId -> Index -> Error -> Events -> m TrackId
Create.track BlockId
block_id Index
tracknum (Control -> Error
control_to_title Control
control) Events
events
            -- Link the new track into the skeleton below the bottom control.
            Maybe TrackInfo
parent <- forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe TrackInfo)
bottom_track BlockId
block_id TrackId
note_track_id
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe TrackInfo
parent forall a b. (a -> b) -> a -> b
$ \TrackInfo
p ->
                forall (m :: * -> *). M m => BlockId -> [Edge] -> m ()
Ui.add_edges BlockId
block_id [(TrackInfo -> Index
Ui.track_tracknum TrackInfo
p, Index
tracknum)]
            Index -> [(Control, Events)] -> m ()
go (Index
tracknumforall a. Num a => a -> a -> a
+Index
1) [(Control, Events)]
controls
    find :: Control -> Maybe TrackInfo
find Control
control =
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
== Control -> Error
control_to_title Control
control) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> Error
Ui.track_title) [TrackInfo]
tracks
    tracks :: [TrackInfo]
tracks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Tree a -> [a]
Tree.flatten TrackTree
tree

-- | Get the tracknum after the given tracks.
tracknum_after :: Ui.M m => BlockId -> [TrackId] -> m TrackNum
tracknum_after :: forall (m :: * -> *). M m => BlockId -> [TrackId] -> m Index
tracknum_after BlockId
block_id [TrackId]
track_ids = do
    [Index]
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 Index
Ui.get_tracknum_of BlockId
block_id) [TrackId]
track_ids
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). M m => BlockId -> m Index
Ui.track_count BlockId
block_id) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Index
1)) (forall a. Ord a => [a] -> Maybe a
Lists.maximum [Index]
tracknums)

-- | Get the bottom track below the given TrackId.  If there are more than one,
-- pick the one with the highest TrackNum.
bottom_track :: Ui.M m => BlockId -> TrackId -> m (Maybe Ui.TrackInfo)
bottom_track :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe TrackInfo)
bottom_track BlockId
block_id TrackId
track_id = do
    TrackTree
tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree
TrackTree.track_tree_of BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.maximumOn TrackInfo -> Index
Ui.track_tracknum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> [a]
Trees.leaves
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. (a -> Bool) -> [Tree a] -> Maybe (Tree a)
Trees.find ((forall a. Eq a => a -> a -> Bool
==TrackId
track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> TrackId
Ui.track_id) TrackTree
tree

parent_of :: Ui.M m => BlockId -> TrackId -> m (Maybe Ui.TrackInfo)
parent_of :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe TrackInfo)
parent_of BlockId
block_id TrackId
track_id = do
    TrackTree
tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree
TrackTree.track_tree_of BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.head
        [ TrackInfo
track
        | (TrackInfo
track, [TrackInfo]
_, [TrackInfo]
children) <- forall a. [Tree a] -> [(a, [a], [a])]
Trees.flatPaths TrackTree
tree
        , TrackId
track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map TrackInfo -> TrackId
Ui.track_id [TrackInfo]
children
        ]