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

{- | The overall UI state is described here.  This is an immutable data
    structure that contains all the tracks, rulers, note data, and so forth.
    It exports a StateT monad for modification and access.

    Since the same block may have \>=0 views, and a single track may appear in
    \>=0 blocks, these are stored as IDs rather than directly in their
    containers.  Using explicit references introduces all the usual problems
    with pointers like invalid references and unreferenced data.  The latter is
    actually a feature (e.g. having a block with no associated view is
    perfectly normal), but the former is a pain.  To ease the pain, IDs should
    only be created via the monadic create_* interface in this module, even
    though I'm forced to export their constructors to avoid circular imports.
    There may still be problems with IDs from one State being applied to
    a different State (likely an older and newer version of the same State),
    but I'll deal with that when I get there.

    A higher level interface (e.g. "Cmd.Create") may ease this by automatically
    creating objects with automatically generated IDs.
-}
module Ui.Ui (
    State(..), views, blocks, tracks, rulers, config
    , empty, create, clear
    -- * address types
    , Track(..), Range(..), TrackInfo(..)
    -- * StateT monad
    , M, StateT, StateId, get, unsafe_put, damage, get_damage
    , throw_error, throw
    , run, run_id, eval, eval_rethrow, exec, exec_rethrow
    , gets, unsafe_modify, put, modify
    , update_all
    -- ** errors
    , Error(..)
    , require, require_right

    -- * config
    , get_namespace, set_namespace
    , get_default, modify_default, get_root_id, lookup_root_id, set_root_id
    , modify_config, get_config, with_config
    , modify_meta
    , modify_allocation, allocation

    -- * view
    , get_view, lookup_view, all_view_ids
    , create_view, destroy_view, put_views
    , set_view_status
    -- ** zoom and track scroll
    , get_zoom, modify_zoom, set_track_scroll, set_view_rect
    , set_view_padding
    -- ** selections
    , get_selection, set_selection
    , shift_selection, skip_unselectable_tracks
    , selectable_tracks

    -- * block
    , get_block, lookup_block, all_block_ids, all_block_track_ids
    , create_config_block, create_block, destroy_block
    , block_of, block_id_of, views_of
    , get_block_title, set_block_title
    , modify_block_meta
    , set_integrated_block, modify_integrated_tracks, set_integrated_manual
    , set_edit_box, set_play_box
    , block_ruler_end, block_event_end, block_end, block_logical_range
    -- ** skeleton
    , set_skeleton_config
    , has_explicit_skeleton
    , get_skeleton, set_skeleton, modify_skeleton
    , toggle_skeleton_edge, add_edges, remove_edges
    , splice_skeleton_above, splice_skeleton_below
    -- ** tracks
    , insert_track, remove_track, move_track
    -- *** tracks by tracknum
    , track_count
    , block_track_at, get_block_track_at, track_at
    , event_track_at, get_event_track_at
    , ruler_track_at, block_ruler
    -- *** tracks by TrackId
    , track_ids_of, tracknums_of, block_tracknums
    , tracknum_of, get_tracknum_of
    -- *** block track
    , set_track_width, set_track_suggested_width
    , track_flags, track_collapsed
    , toggle_track_flag, add_track_flag, remove_track_flag
    , modify_track_flags
    , set_track_ruler
    , merge_track, unmerge_track, set_merged_tracks
    , track_merged
    , set_ruler_ids, replace_ruler_id, set_ruler_id
    , get_tracklike

    -- * track
    , get_track, lookup_track, all_track_ids
    , create_track, destroy_track
    , get_track_title, set_track_title, modify_track_title
    , set_track_bg
    , modify_track_render, set_render_style, modify_waveform
    , blocks_with_track_id
    -- ** events
    , insert_events, insert_block_events, insert_event
    , get_events, modify_events, modify_events_range, modify_events_from
    , modify_some_events, calculate_damage
    , remove_event, remove_events, remove_events_range
    , track_event_end, range_from

    -- * ruler
    , get_ruler, lookup_ruler, all_ruler_ids
    , create_ruler, destroy_ruler, modify_ruler
    , ruler_of, rulers_of
    , blocks_with_ruler_id
    , no_ruler

    -- * util
    , find_tracks

    -- * verify
    , quick_verify, verify -- TODO should be done automatically by put
    , fix_state

    -- * ID
    , read_id, namespace
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.State.Strict as State
import qualified Control.Monad.Trans as Trans

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.Time as Time

import qualified GHC.Stack

import qualified Util.CallStack as CallStack
import qualified Util.Lens as Lens
import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Ranges as Ranges
import qualified Util.Rect as Rect

import qualified App.Config as Config
import qualified Derive.ParseSkeleton as ParseSkeleton
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack

import qualified Ui.Block as Block
import qualified Ui.Color as Color
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Id as Id
import qualified Ui.Ruler as Ruler
import qualified Ui.Sel as Sel
import qualified Ui.Skeleton as Skeleton
import qualified Ui.Track as Track
import qualified Ui.Types as Types
import qualified Ui.UiConfig as UiConfig
import qualified Ui.Update as Update
import qualified Ui.Zoom as Zoom

import           Global
import           Types


-- * types

-- | Score state.  When you save a score, this is what is saved to disk.
data State = State {
    State -> Map ViewId View
state_views :: Map ViewId Block.View
    , State -> Map BlockId Block
state_blocks :: Map BlockId Block.Block
    , State -> Map TrackId Track
state_tracks :: Map TrackId Track.Track
    , State -> Map RulerId Ruler
state_rulers :: Map RulerId Ruler.Ruler
    , State -> Config
state_config :: UiConfig.Config
    } deriving (State -> State -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, TrackNum -> State -> ShowS
[State] -> ShowS
State -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: TrackNum -> State -> ShowS
$cshowsPrec :: TrackNum -> State -> ShowS
Show)

views :: Lens.Lens State (Map ViewId Block.View)
views :: Lens State (Map ViewId View)
views = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens State -> Map ViewId View
state_views
    (\Map ViewId View -> Map ViewId View
f State
r -> State
r { state_views :: Map ViewId View
state_views = Map ViewId View -> Map ViewId View
f (State -> Map ViewId View
state_views State
r) })

blocks :: Lens.Lens State (Map BlockId Block.Block)
blocks :: Lens State (Map BlockId Block)
blocks = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens State -> Map BlockId Block
state_blocks
    (\Map BlockId Block -> Map BlockId Block
f State
r -> State
r { state_blocks :: Map BlockId Block
state_blocks = Map BlockId Block -> Map BlockId Block
f (State -> Map BlockId Block
state_blocks State
r) })

tracks :: Lens.Lens State (Map TrackId Track.Track)
tracks :: Lens State (Map TrackId Track)
tracks = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens State -> Map TrackId Track
state_tracks
    (\Map TrackId Track -> Map TrackId Track
f State
r -> State
r { state_tracks :: Map TrackId Track
state_tracks = Map TrackId Track -> Map TrackId Track
f (State -> Map TrackId Track
state_tracks State
r) })

rulers :: Lens.Lens State (Map RulerId Ruler.Ruler)
rulers :: Lens State (Map RulerId Ruler)
rulers = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens State -> Map RulerId Ruler
state_rulers
    (\Map RulerId Ruler -> Map RulerId Ruler
f State
r -> State
r { state_rulers :: Map RulerId Ruler
state_rulers = Map RulerId Ruler -> Map RulerId Ruler
f (State -> Map RulerId Ruler
state_rulers State
r) })

config :: Lens.Lens State UiConfig.Config
config :: Lens State Config
config = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens State -> Config
state_config
    (\Config -> Config
f State
r -> State
r { state_config :: Config
state_config = Config -> Config
f (State -> Config
state_config State
r) })

empty :: State
empty :: State
empty = State
    { state_views :: Map ViewId View
state_views = forall k a. Map k a
Map.empty
    , state_blocks :: Map BlockId Block
state_blocks = forall k a. Map k a
Map.empty
    , state_tracks :: Map TrackId Track
state_tracks = forall k a. Map k a
Map.empty
    , state_rulers :: Map RulerId Ruler
state_rulers = forall k a. Map k a
Map.empty
    , state_config :: Config
state_config = Config
UiConfig.empty_config
    }

-- | Like 'empty', but the state is initialized with the current creation time.
create :: IO State
create :: IO State
create = do
    UTCTime
now <- IO UTCTime
Time.getCurrentTime
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Lens State Config
configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Meta
UiConfig.metaforall a b c. Lens a b -> Lens b c -> Lens a c
#Meta :-> UTCTime
UiConfig.creation forall f a. Lens f a -> a -> f -> f
#= UTCTime
now) State
empty

-- | Clear out data that shouldn't be saved.
clear :: State -> State
clear :: State -> State
clear State
state = State
state { state_views :: Map ViewId View
state_views = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map View -> View
clear_view (State -> Map ViewId View
state_views State
state) }
    where
    clear_view :: View -> View
clear_view View
view = View
view
        { view_status :: Map (TrackNum, Text) Text
Block.view_status = forall a. Monoid a => a
mempty
        , view_selections :: Map TrackNum Selection
Block.view_selections =
            -- Non-insert selections indicate ephemeral state.
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall k a. k -> a -> Map k a
Map.singleton TrackNum
Config.insert_selnum) forall a b. (a -> b) -> a -> b
$
                forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackNum
Config.insert_selnum (View -> Map TrackNum Selection
Block.view_selections View
view)
        }

instance Pretty State where
    format :: State -> Doc
format (State Map ViewId View
views Map BlockId Block
blocks Map TrackId Track
tracks Map RulerId Ruler
rulers Config
config) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"State"
        [ (Text
"views", forall a. Pretty a => a -> Doc
Pretty.format Map ViewId View
views)
        , (Text
"blocks", forall a. Pretty a => a -> Doc
Pretty.format Map BlockId Block
blocks)
        , (Text
"tracks", forall a. Pretty a => a -> Doc
Pretty.format Map TrackId Track
tracks)
        , (Text
"rulers", forall a. Pretty a => a -> Doc
Pretty.format Map RulerId Ruler
rulers)
        , (Text
"config", forall a. Pretty a => a -> Doc
Pretty.format Config
config)
        ]

instance DeepSeq.NFData State where
    rnf :: State -> ()
rnf (State Map ViewId View
views Map BlockId Block
blocks Map TrackId Track
tracks Map RulerId Ruler
rulers Config
config) =
        forall a. NFData a => a -> ()
DeepSeq.rnf Map ViewId View
views seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
DeepSeq.rnf Map BlockId Block
blocks
        seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
DeepSeq.rnf Map TrackId Track
tracks seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
DeepSeq.rnf Map RulerId Ruler
rulers
        seq :: forall a b. a -> b -> b
`seq` Config
config seq :: forall a b. a -> b -> b
`seq` ()

-- * address types

-- | Address a track in a block.  This is similar to a TrackId, except it
-- doesn't guarantee that the track is an event track.
data Track = Track !BlockId !TrackNum
    deriving (Track -> Track -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Track -> Track -> Bool
$c/= :: Track -> Track -> Bool
== :: Track -> Track -> Bool
$c== :: Track -> Track -> Bool
Eq, TrackNum -> Track -> ShowS
[Track] -> ShowS
Track -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Track] -> ShowS
$cshowList :: [Track] -> ShowS
show :: Track -> String
$cshow :: Track -> String
showsPrec :: TrackNum -> Track -> ShowS
$cshowsPrec :: TrackNum -> Track -> ShowS
Show)

instance Pretty Track where
    pretty :: Track -> Text
pretty (Track BlockId
block_id TrackNum
tracknum) =
        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. Show a => a -> Text
showt TrackNum
tracknum

-- | A position on a track that can be indicated on the UI.  Its Pretty
-- instance emits a string, which if logged or copy-pasted into the REPL, will
-- cause that section of score to be highlighted.
data Range = Range !(Maybe BlockId) !TrackId !TrackTime !TrackTime
    deriving (Range -> Range -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Range -> Range -> Bool
$c/= :: Range -> Range -> Bool
== :: Range -> Range -> Bool
$c== :: Range -> Range -> Bool
Eq, TrackNum -> Range -> ShowS
[Range] -> ShowS
Range -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Range] -> ShowS
$cshowList :: [Range] -> ShowS
show :: Range -> String
$cshow :: Range -> String
showsPrec :: TrackNum -> Range -> ShowS
$cshowsPrec :: TrackNum -> Range -> ShowS
Show)

instance Pretty Range where
    pretty :: Range -> Text
pretty (Range Maybe BlockId
maybe_block_id TrackId
track_id TrackTime
start TrackTime
end) =
        UiFrame -> Text
Stack.log_ui_frame (Maybe BlockId
maybe_block_id, forall a. a -> Maybe a
Just TrackId
track_id, forall a. a -> Maybe a
Just (TrackTime
start, TrackTime
end))

-- * other types

-- | Summary information on a Track.
data TrackInfo = TrackInfo {
    TrackInfo -> Text
track_title :: !Text
    , TrackInfo -> TrackId
track_id :: !TrackId
    , TrackInfo -> TrackNum
track_tracknum :: !TrackNum
    , TrackInfo -> Track
track_block :: !Block.Track
    } deriving (TrackInfo -> TrackInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TrackInfo -> TrackInfo -> Bool
$c/= :: TrackInfo -> TrackInfo -> Bool
== :: TrackInfo -> TrackInfo -> Bool
$c== :: TrackInfo -> TrackInfo -> Bool
Eq, TrackNum -> TrackInfo -> ShowS
[TrackInfo] -> ShowS
TrackInfo -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrackInfo] -> ShowS
$cshowList :: [TrackInfo] -> ShowS
show :: TrackInfo -> String
$cshow :: TrackInfo -> String
showsPrec :: TrackNum -> TrackInfo -> ShowS
$cshowsPrec :: TrackNum -> TrackInfo -> ShowS
Show)

instance Pretty TrackInfo where
    pretty :: TrackInfo -> Text
pretty (TrackInfo Text
title TrackId
track_id TrackNum
tracknum Track
_) =
        Text
"(" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords
            [Text
"TrackInfo", forall a. Show a => a -> Text
showt Text
title, forall a. Show a => a -> Text
showt TrackId
track_id, forall a. Show a => a -> Text
showt TrackNum
tracknum]
        forall a. Semigroup a => a -> a -> a
<> Text
")"

-- * StateT monad

-- | 'Update.UiDamage' is recorded directly instead of being calculated from
-- the state diff.
--
-- Is there any way it could get out of sync with the actual change?  I don't
-- see how, since the updates are stored by track_id, which should always be
-- associated with the same track, and an operation to move event positions
-- will simply generate another TrackUpdate over the whole track.
type StateStack m = State.StateT State
    (State.StateT Update.UiDamage
        (Except.ExceptT Error m))
newtype StateT m a = StateT (StateStack m a)
    deriving (forall a b. a -> StateT m b -> StateT m a
forall a b. (a -> b) -> StateT m a -> StateT m b
forall (m :: * -> *) a b.
Functor m =>
a -> StateT m b -> StateT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> StateT m a -> StateT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> StateT m b -> StateT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> StateT m b -> StateT m a
fmap :: forall a b. (a -> b) -> StateT m a -> StateT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> StateT m a -> StateT m b
Functor, forall a. a -> StateT m a
forall a b. StateT m a -> StateT m b -> StateT m b
forall a b. StateT m a -> (a -> StateT m b) -> StateT m b
forall {m :: * -> *}. Monad m => Applicative (StateT m)
forall (m :: * -> *) a. Monad m => a -> StateT m a
forall (m :: * -> *) a b.
Monad m =>
StateT m a -> StateT m b -> StateT m b
forall (m :: * -> *) a b.
Monad m =>
StateT m a -> (a -> StateT m b) -> StateT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> StateT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> StateT m a
>> :: forall a b. StateT m a -> StateT m b -> StateT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
StateT m a -> StateT m b -> StateT m b
>>= :: forall a b. StateT m a -> (a -> StateT m b) -> StateT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
StateT m a -> (a -> StateT m b) -> StateT m b
Monad, forall a. IO a -> StateT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (StateT m)
forall (m :: * -> *) a. MonadIO m => IO a -> StateT m a
liftIO :: forall a. IO a -> StateT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> StateT m a
MonadIO, Except.MonadError Error, forall a. a -> StateT m a
forall a b. StateT m a -> StateT m b -> StateT m a
forall a b. StateT m a -> StateT m b -> StateT m b
forall a b. StateT m (a -> b) -> StateT m a -> StateT m b
forall a b c.
(a -> b -> c) -> StateT m a -> StateT m b -> StateT m c
forall {m :: * -> *}. Monad m => Functor (StateT m)
forall (m :: * -> *) a. Monad m => a -> StateT m a
forall (m :: * -> *) a b.
Monad m =>
StateT m a -> StateT m b -> StateT m a
forall (m :: * -> *) a b.
Monad m =>
StateT m a -> StateT m b -> StateT m b
forall (m :: * -> *) a b.
Monad m =>
StateT m (a -> b) -> StateT m a -> StateT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> StateT m a -> StateT m b -> StateT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. StateT m a -> StateT m b -> StateT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
StateT m a -> StateT m b -> StateT m a
*> :: forall a b. StateT m a -> StateT m b -> StateT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
StateT m a -> StateT m b -> StateT m b
liftA2 :: forall a b c.
(a -> b -> c) -> StateT m a -> StateT m b -> StateT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> StateT m a -> StateT m b -> StateT m c
<*> :: forall a b. StateT m (a -> b) -> StateT m a -> StateT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
StateT m (a -> b) -> StateT m a -> StateT m b
pure :: forall a. a -> StateT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> StateT m a
Applicative)

-- | Just a convenient abbreviation.
type StateId a = StateT Identity.Identity a

instance Trans.MonadTrans StateT where
    lift :: forall (m :: * -> *) a. Monad m => m a -> StateT m a
lift = forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Monads implementing this class can call the UI state functions directly.
class (Applicative m, Monad m) => M m where
    -- Note that these aren't the MonadState get and put, and can't be, because
    -- when this monad is layered under another state monad (as it is with
    -- Cmd), MonadState couldn't tell which one you wanted.
    get :: m State
    -- | This directly modifies the state, and can break internal invariants.
    -- 'put' is slower but safer since it checks those invariants.
    unsafe_put :: State -> m ()
    damage :: Update.UiDamage -> m ()
    get_damage :: m Update.UiDamage
    throw_error :: Error -> m a

instance Monad m => M (StateT m) where
    get :: StateT m State
get = forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT forall s (m :: * -> *). MonadState s m => m s
State.get
    unsafe_put :: State -> StateT m ()
unsafe_put State
st = forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT (forall s (m :: * -> *). MonadState s m => s -> m ()
State.put State
st)
    damage :: UiDamage -> StateT m ()
damage UiDamage
upd = (forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (UiDamage
upd<>))
    get_damage :: StateT m UiDamage
get_damage = (forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) forall s (m :: * -> *). MonadState s m => m s
State.get
    throw_error :: forall a. Error -> StateT m a
throw_error = forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError

-- Basic level membership in the MTL club.
instance M m => M (State.StateT state m) where
    get :: StateT state m State
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). M m => m State
get
    unsafe_put :: State -> StateT state m ()
unsafe_put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => State -> m ()
unsafe_put
    damage :: UiDamage -> StateT state m ()
damage = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => UiDamage -> m ()
damage
    get_damage :: StateT state m UiDamage
get_damage = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). M m => m UiDamage
get_damage
    throw_error :: forall a. Error -> StateT state m a
throw_error = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. M m => Error -> m a
throw_error

instance M m => M (Except.ExceptT exc m) where
    get :: ExceptT exc m State
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). M m => m State
get
    unsafe_put :: State -> ExceptT exc m ()
unsafe_put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => State -> m ()
unsafe_put
    damage :: UiDamage -> ExceptT exc m ()
damage = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => UiDamage -> m ()
damage
    get_damage :: ExceptT exc m UiDamage
get_damage = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). M m => m UiDamage
get_damage
    throw_error :: forall a. Error -> ExceptT exc m a
throw_error = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. M m => Error -> m a
throw_error

throw :: (CallStack.Stack, M m) => Text -> m a
throw :: forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw Text
msg = forall (m :: * -> *) a. M m => Error -> m a
throw_error forall a b. (a -> b) -> a -> b
$ CallStack -> Text -> Error
Error Stack => CallStack
GHC.Stack.callStack Text
msg

gets :: M m => (State -> a) -> m a
gets :: forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> a
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap State -> a
f forall (m :: * -> *). M m => m State
get

-- | As with 'unsafe_put', this directly modifies the state.  'modify' is
-- the safe version.
unsafe_modify :: M m => (State -> State) -> m ()
unsafe_modify :: forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify State -> State
f = do
    State
state <- forall (m :: * -> *). M m => m State
get
    forall (m :: * -> *). M m => State -> m ()
unsafe_put forall a b. (a -> b) -> a -> b
$! State -> State
f State
state

-- | TODO verify
--
-- This updates all tracks because I don't know what you modified in there.
put :: M m => State -> m ()
put :: forall (m :: * -> *). M m => State -> m ()
put State
state = forall (m :: * -> *). M m => State -> m ()
unsafe_put State
state forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). M m => m ()
update_all

-- | An arbitrary modify.  It's unsafe because it doesn't check internal
-- invariants, and inefficient because it damages all tracks.  Use more
-- specific modify_* functions, if possible.
modify :: M m => (State -> State) -> m ()
modify :: forall (m :: * -> *). M m => (State -> State) -> m ()
modify State -> State
f = do
    State
state <- forall (m :: * -> *). M m => m State
get
    forall (m :: * -> *). M m => State -> m ()
put forall a b. (a -> b) -> a -> b
$! State -> State
f State
state

-- | Emit track updates for all tracks.  Use this when events have changed but
-- I don't know which ones, e.g. when loading a file or restoring a previous
-- state.
update_all :: M m => m ()
update_all :: forall (m :: * -> *). M m => m ()
update_all = do
    State
st <- forall (m :: * -> *). M m => m State
get
    forall (m :: * -> *). M m => UiDamage -> m ()
damage forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty { _blocks :: Set BlockId
Update._blocks = forall k a. Map k a -> Set k
Map.keysSet (State -> Map BlockId Block
state_blocks State
st) }

-- | Run the given StateT with the given initial state, and return a new
-- state along with updates.  Normally updates are produced by 'Ui.Diff.diff',
-- but for efficiency updates to track data are accumulated when they are
-- actually made.  All the UI needs is a TrackTime range to redraw in, and
-- redrawing the whole track isn't that expensive.
--
-- See the StateStack comment for more.
run :: Monad m => State -> StateT m a
    -> m (Either Error (a, State, Update.UiDamage))
run :: forall (m :: * -> *) a.
Monad m =>
State -> StateT m a -> m (Either Error (a, State, UiDamage))
run State
state StateT m a
action = do
    Either Error ((a, State), UiDamage)
res <- (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT forall a. Monoid a => a
mempty
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT State
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(StateT StateT State (StateT UiDamage (ExceptT Error m)) a
x) -> StateT State (StateT UiDamage (ExceptT Error m)) a
x)) StateT m a
action
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Error ((a, State), UiDamage)
res of
        Left Error
err -> forall a b. a -> Either a b
Left Error
err
        Right ((a
val, State
state), UiDamage
damage) ->
            forall a b. b -> Either a b
Right (a
val, State
state, Map ViewId View -> UiDamage -> UiDamage
block_to_view_damage (State -> Map ViewId View
state_views State
state) UiDamage
damage)

run_id :: State -> StateId a -> Either Error (a, State, Update.UiDamage)
run_id :: forall a. State -> StateId a -> Either Error (a, State, UiDamage)
run_id State
state StateId a
m = forall a. Identity a -> a
Identity.runIdentity (forall (m :: * -> *) a.
Monad m =>
State -> StateT m a -> m (Either Error (a, State, UiDamage))
run State
state StateId a
m)

-- | A form of 'run' that returns only the val and automatically runs in
-- Identity.
eval :: State -> StateId a -> Either Error a
eval :: forall a. State -> StateId a -> Either Error a
eval State
state StateId a
m = case Either Error (a, State, UiDamage)
result of
        Left Error
err -> forall a b. a -> Either a b
Left Error
err
        Right (a
val, State
_, UiDamage
_) -> forall a b. b -> Either a b
Right a
val
    where result :: Either Error (a, State, UiDamage)
result = forall a. Identity a -> a
Identity.runIdentity (forall (m :: * -> *) a.
Monad m =>
State -> StateT m a -> m (Either Error (a, State, UiDamage))
run State
state StateId a
m)

eval_rethrow :: M m => Text -> State -> StateId a -> m a
eval_rethrow :: forall (m :: * -> *) a. M m => Text -> State -> StateId a -> m a
eval_rethrow Text
msg State
state =
    forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
require_right (((Text
msg forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. State -> StateId a -> Either Error a
eval State
state

exec :: State -> StateId a -> Either Error State
exec :: forall a. State -> StateId a -> Either Error State
exec State
state StateId a
m = case Either Error (a, State, UiDamage)
result of
        Left Error
err -> forall a b. a -> Either a b
Left Error
err
        Right (a
_, State
state', UiDamage
_) -> forall a b. b -> Either a b
Right State
state'
    where result :: Either Error (a, State, UiDamage)
result = forall a. Identity a -> a
Identity.runIdentity (forall (m :: * -> *) a.
Monad m =>
State -> StateT m a -> m (Either Error (a, State, UiDamage))
run State
state StateId a
m)

exec_rethrow :: M m => Text -> State -> StateId a -> m State
exec_rethrow :: forall (m :: * -> *) a.
M m =>
Text -> State -> StateId a -> m State
exec_rethrow Text
msg State
state =
    forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
require_right (((Text
msg forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. State -> StateId a -> Either Error State
exec State
state

-- | Promote block damage to damage on all of that block's views.  This is run
-- before returning the UiDamage out of the Ui monad.  Otherwise, Diff isn't
-- smart enough to update views when the underlying blocks change.
block_to_view_damage :: Map ViewId Block.View -> Update.UiDamage
    -> Update.UiDamage
block_to_view_damage :: Map ViewId View -> UiDamage -> UiDamage
block_to_view_damage Map ViewId View
views UiDamage
damage
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ViewId]
view_ids = UiDamage
damage
    | Bool
otherwise = UiDamage
damage
        { _views :: Set ViewId
Update._views = UiDamage -> Set ViewId
Update._views UiDamage
damage forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
Set.fromList [ViewId]
view_ids }
    where
    -- This is O(blocks*views) because I have no index BlockId -> [ViewId].
    -- But damaged blocks and views should both be small.
    view_ids :: [ViewId]
view_ids = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap BlockId -> [ViewId]
views_of (forall a. Set a -> [a]
Set.toList (UiDamage -> Set BlockId
Update._blocks UiDamage
damage))
    views_of :: BlockId -> [ViewId]
views_of BlockId
block_id = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
==BlockId
block_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. View -> BlockId
Block.view_block 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 Map ViewId View
views


-- ** error

-- | Abort is used by Cmd, so don't throw it from here.  This isn't exactly
-- modular, but ErrorT can't be composed and extensible exceptions are too
-- much bother at the moment.
data Error = Error !GHC.Stack.CallStack !Text | Abort deriving (TrackNum -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(TrackNum -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: TrackNum -> Error -> ShowS
$cshowsPrec :: TrackNum -> Error -> ShowS
Show)

instance Pretty Error where
    pretty :: Error -> Text
pretty (Error CallStack
stack Text
msg) =
        Caller -> Text
CallStack.showCaller (CallStack -> Caller
CallStack.caller CallStack
stack) forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
msg
    pretty Error
Abort = Text
"(abort)"

require :: (CallStack.Stack, M m) => Text -> Maybe a -> m a
require :: forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require Text
err = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw Text
err) forall (m :: * -> *) a. Monad m => a -> m a
return

require_right :: (CallStack.Stack, M m) => (err -> Text) -> Either err a -> m a
require_right :: forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
require_right err -> Text
fmt_err = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
fmt_err) forall (m :: * -> *) a. Monad m => a -> m a
return

-- * config

get_namespace :: M m => m Id.Namespace
get_namespace :: forall (m :: * -> *). M m => m Namespace
get_namespace = forall (m :: * -> *) a. M m => (Config -> a) -> m a
get_config Config -> Namespace
UiConfig.config_namespace

set_namespace :: M m => Id.Namespace -> m ()
set_namespace :: forall (m :: * -> *). M m => Namespace -> m ()
set_namespace Namespace
ns = forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config forall a b. (a -> b) -> a -> b
$ \Config
st -> Config
st { config_namespace :: Namespace
UiConfig.config_namespace = Namespace
ns }

get_default :: M m => (UiConfig.Default -> a) -> m a
get_default :: forall (m :: * -> *) a. M m => (Default -> a) -> m a
get_default Default -> a
f = Default -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (Config -> a) -> m a
get_config Config -> Default
UiConfig.config_default

modify_default :: M m => (UiConfig.Default -> UiConfig.Default) -> m ()
modify_default :: forall (m :: * -> *). M m => (Default -> Default) -> m ()
modify_default Default -> Default
f = forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config forall a b. (a -> b) -> a -> b
$ \Config
st ->
    Config
st { config_default :: Default
UiConfig.config_default = Default -> Default
f (Config -> Default
UiConfig.config_default Config
st) }

get_root_id :: M m => m BlockId
get_root_id :: forall (m :: * -> *). M m => m BlockId
get_root_id = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require Text
"no root root_id" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe BlockId)
lookup_root_id

lookup_root_id :: M m => m (Maybe BlockId)
lookup_root_id :: forall (m :: * -> *). M m => m (Maybe BlockId)
lookup_root_id = forall (m :: * -> *) a. M m => (Config -> a) -> m a
get_config Config -> Maybe BlockId
UiConfig.config_root

set_root_id :: M m => BlockId -> m ()
set_root_id :: forall (m :: * -> *). M m => BlockId -> m ()
set_root_id BlockId
block_id =
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config forall a b. (a -> b) -> a -> b
$ \Config
st -> Config
st { config_root :: Maybe BlockId
UiConfig.config_root = forall a. a -> Maybe a
Just BlockId
block_id }

-- | Unlike other State fields, you can modify Config freely without worrying
-- about breaking invariants.  TODO except allocations have invariants.
modify_config :: M m => (UiConfig.Config -> UiConfig.Config) -> m ()
modify_config :: forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config Config -> Config
f = forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st ->
    State
st { state_config :: Config
state_config = Config -> Config
f (State -> Config
state_config State
st) }

modify_meta :: M m => (UiConfig.Meta -> UiConfig.Meta) -> m ()
modify_meta :: forall (m :: * -> *). M m => (Meta -> Meta) -> m ()
modify_meta Meta -> Meta
f = forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config forall a b. (a -> b) -> a -> b
$ Config :-> Meta
UiConfig.meta forall f a. Lens f a -> (a -> a) -> f -> f
%= Meta -> Meta
f

modify_allocation :: M m => ScoreT.Instrument
    -> (UiConfig.Allocation -> UiConfig.Allocation) -> m ()
modify_allocation :: forall (m :: * -> *).
M m =>
Instrument -> (Allocation -> Allocation) -> m ()
modify_allocation Instrument
inst Allocation -> Allocation
modify = do
    Allocations
allocs <- Lens State Config
configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Allocations
UiConfig.allocations forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
get
    Allocations
allocs <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
require_right ((Text
"modify " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) forall a b. (a -> b) -> a -> b
$
        Instrument
-> (Allocation -> Either Text Allocation)
-> Allocations
-> Either Text Allocations
UiConfig.modify_allocation Instrument
inst (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Allocation
modify) Allocations
allocs
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config forall a b. (a -> b) -> a -> b
$ Config :-> Allocations
UiConfig.allocations forall f a. Lens f a -> a -> f -> f
#= Allocations
allocs

get_config :: M m => (UiConfig.Config -> a) -> m a
get_config :: forall (m :: * -> *) a. M m => (Config -> a) -> m a
get_config Config -> a
f = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (Config -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
state_config)

-- | Run the action with a modified state, and restore it.
with_config :: M m => (UiConfig.Config -> UiConfig.Config) -> m a -> m a
with_config :: forall (m :: * -> *) a. M m => (Config -> Config) -> m a -> m a
with_config Config -> Config
f m a
action = do
    Config
old <- forall (m :: * -> *) a. M m => (Config -> a) -> m a
get_config forall a. a -> a
id
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config Config -> Config
f
    -- I think this is exception safe because the state is reverted after an
    -- exception, and there's no way to catch an exception.
    a
result <- m a
action
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Config
old
    forall (m :: * -> *) a. Monad m => a -> m a
return a
result

-- | TODO use this for read only.  If used for write it bypasses
-- 'UiConfig.allocate'.
allocation :: ScoreT.Instrument -> Lens State (Maybe UiConfig.Allocation)
allocation :: Instrument -> Lens State (Maybe Allocation)
allocation Instrument
inst = Lens State Config
config forall a b c. Lens a b -> Lens b c -> Lens a c
# Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall a b c. Lens a b -> Lens b c -> Lens a c
# forall k a. Ord k => k -> Lens (Map k a) (Maybe a)
Lens.map Instrument
inst

-- * view

get_view :: M m => ViewId -> m Block.View
get_view :: forall (m :: * -> *). M m => ViewId -> m View
get_view ViewId
view_id = forall k (m :: * -> *) a.
(Stack, Ord k, Show k, M m) =>
k -> Map k a -> m a
lookup_id ViewId
view_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
state_views forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m State
get

lookup_view :: M m => ViewId -> m (Maybe Block.View)
lookup_view :: forall (m :: * -> *). M m => ViewId -> m (Maybe View)
lookup_view ViewId
view_id = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ViewId
view_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
state_views)

-- | All ViewIds, in sorted order.
all_view_ids :: M m => m [ViewId]
all_view_ids :: forall (m :: * -> *). M m => m [ViewId]
all_view_ids = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
state_views)

-- | Create a new view.  Block.view_tracks can be left empty, since it will
-- be replaced by views generated from the the block.  If the caller uses the
-- 'Block.view' constructor, it won't have to worry about this.
--
-- Throw if the ViewId already exists.
create_view :: M m => Id.Id -> Block.View -> m ViewId
create_view :: forall (m :: * -> *). M m => Id -> View -> m ViewId
create_view Id
id View
view = do
    View
view <- forall (m :: * -> *). M m => View -> m View
_update_view_status View
view
    forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
k
-> a
-> (k -> m ())
-> (State -> Map k a)
-> (Map k a -> State -> State)
-> m k
insert (Id -> ViewId
Id.ViewId Id
id) View
view forall (m :: * -> *). M m => ViewId -> m ()
damage_view State -> Map ViewId View
state_views forall a b. (a -> b) -> a -> b
$ \Map ViewId View
views State
st ->
        State
st { state_views :: Map ViewId View
state_views = Map ViewId View
views }

destroy_view :: M m => ViewId -> m ()
destroy_view :: forall (m :: * -> *). M m => ViewId -> m ()
destroy_view ViewId
view_id = do
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_views :: Map ViewId View
state_views = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ViewId
view_id (State -> Map ViewId View
state_views State
st) }
    forall (m :: * -> *). M m => ViewId -> m ()
damage_view ViewId
view_id

put_views :: M m => Map ViewId Block.View -> m ()
put_views :: forall (m :: * -> *). M m => Map ViewId View -> m ()
put_views Map ViewId View
view_map = do
    let ([ViewId]
view_ids, [View]
views) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall k a. Map k a -> [(k, a)]
Map.toList Map ViewId View
view_map)
    [View]
views <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => View -> m View
_update_view_status [View]
views
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_views :: Map ViewId View
state_views = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [ViewId]
view_ids [View]
views) }
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => ViewId -> m ()
damage_view [ViewId]
view_ids

-- | Set a status variable on a view.
set_view_status :: M m => ViewId -> (Int, Text) -> Maybe Text -> m ()
set_view_status :: forall (m :: * -> *).
M m =>
ViewId -> (TrackNum, Text) -> Maybe Text -> m ()
set_view_status ViewId
view_id (TrackNum, Text)
key Maybe Text
val = forall (m :: * -> *). M m => ViewId -> (View -> View) -> m ()
modify_view ViewId
view_id forall a b. (a -> b) -> a -> b
$ \View
view -> View
view
    { view_status :: Map (TrackNum, Text) Text
Block.view_status = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a b. a -> b -> a
const Maybe Text
val) (TrackNum, Text)
key (View -> Map (TrackNum, Text) Text
Block.view_status View
view) }

_update_view_status :: M m => Block.View -> m Block.View
_update_view_status :: forall (m :: * -> *). M m => View -> m View
_update_view_status View
view = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block (View -> BlockId
Block.view_block View
view)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Block -> Maybe (BlockId, TrackDestinations)
Block.block_integrated Block
block of
        Just (BlockId
source_block, TrackDestinations
_) -> View
view
            { view_status :: Map (TrackNum, Text) Text
Block.view_status = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TrackNum, Text)
Config.status_integrate_source
                (forall a. Ident a => a -> Text
Id.ident_text BlockId
source_block) (View -> Map (TrackNum, Text) Text
Block.view_status View
view)
            }
        Maybe (BlockId, TrackDestinations)
Nothing -> View
view

-- ** zoom and track scroll

get_zoom :: M m => ViewId -> m Zoom.Zoom
get_zoom :: forall (m :: * -> *). M m => ViewId -> m Zoom
get_zoom = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap View -> Zoom
Block.view_zoom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => ViewId -> m View
get_view

modify_zoom :: M m => ViewId -> (Zoom.Zoom -> Zoom.Zoom) -> m ()
modify_zoom :: forall (m :: * -> *). M m => ViewId -> (Zoom -> Zoom) -> m ()
modify_zoom ViewId
view_id Zoom -> Zoom
modify = forall (m :: * -> *). M m => ViewId -> (View -> View) -> m ()
modify_view ViewId
view_id forall a b. (a -> b) -> a -> b
$ \View
view ->
    View
view { view_zoom :: Zoom
Block.view_zoom = Zoom -> Zoom
clamp forall a b. (a -> b) -> a -> b
$ Zoom -> Zoom
modify forall a b. (a -> b) -> a -> b
$ View -> Zoom
Block.view_zoom View
view }
    where clamp :: Zoom -> Zoom
clamp Zoom
zoom = Zoom
zoom { offset :: TrackTime
Zoom.offset = forall a. Ord a => a -> a -> a
max TrackTime
0 (Zoom -> TrackTime
Zoom.offset Zoom
zoom) }

set_track_scroll :: M m => ViewId -> Types.Width -> m ()
set_track_scroll :: forall (m :: * -> *). M m => ViewId -> TrackNum -> m ()
set_track_scroll ViewId
view_id TrackNum
offset =
    forall (m :: * -> *). M m => ViewId -> (View -> View) -> m ()
modify_view ViewId
view_id (\View
view -> View
view { view_track_scroll :: TrackNum
Block.view_track_scroll = TrackNum
offset })

set_view_rect :: M m => ViewId -> Rect.Rect -> m ()
set_view_rect :: forall (m :: * -> *). M m => ViewId -> Rect -> m ()
set_view_rect ViewId
view_id Rect
rect =
    forall (m :: * -> *). M m => ViewId -> (View -> View) -> m ()
modify_view ViewId
view_id (\View
view -> View
view { view_rect :: Rect
Block.view_rect = Rect
rect })

-- | Only 'Cmd.Cmd.ui_update' is supposed to call this, because the UI is
-- responsible for the padding.
set_view_padding :: M m => ViewId -> Block.Padding -> m ()
set_view_padding :: forall (m :: * -> *). M m => ViewId -> Padding -> m ()
set_view_padding ViewId
view_id Padding
padding = forall (m :: * -> *). M m => ViewId -> (View -> View) -> m ()
modify_view ViewId
view_id forall a b. (a -> b) -> a -> b
$ \View
view ->
    View
view { view_padding :: Padding
Block.view_padding = Padding
padding }

-- ** selections

-- | Get @view_id@'s selection at @selnum@, or Nothing if there is none.
get_selection :: M m => ViewId -> Sel.Num -> m (Maybe Sel.Selection)
get_selection :: forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> m (Maybe Selection)
get_selection ViewId
view_id TrackNum
selnum = do
    View
view <- forall (m :: * -> *). M m => ViewId -> m View
get_view ViewId
view_id
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackNum
selnum (View -> Map TrackNum Selection
Block.view_selections View
view))

-- | Replace any selection on @view_id@ at @selnum@ with @sel@.
set_selection :: M m => ViewId -> Sel.Num -> Maybe Sel.Selection -> m ()
set_selection :: forall (m :: * -> *).
M m =>
ViewId -> TrackNum -> Maybe Selection -> m ()
set_selection ViewId
view_id TrackNum
selnum Maybe Selection
maybe_sel = do
    View
view <- forall (m :: * -> *). M m => ViewId -> m View
get_view ViewId
view_id
    forall (m :: * -> *). M m => ViewId -> View -> m ()
update_view ViewId
view_id forall a b. (a -> b) -> a -> b
$ View
view
        { view_selections :: Map TrackNum Selection
Block.view_selections =
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TrackNum
selnum) (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TrackNum
selnum) Maybe Selection
maybe_sel
                (View -> Map TrackNum Selection
Block.view_selections View
view)
        }

-- ** util

modify_view :: M m => ViewId -> (Block.View -> Block.View) -> m ()
modify_view :: forall (m :: * -> *). M m => ViewId -> (View -> View) -> m ()
modify_view ViewId
view_id View -> View
f = do
    View
view <- forall (m :: * -> *). M m => ViewId -> m View
get_view ViewId
view_id
    forall (m :: * -> *). M m => ViewId -> View -> m ()
update_view ViewId
view_id (View -> View
f View
view)

update_view :: M m => ViewId -> Block.View -> m ()
update_view :: forall (m :: * -> *). M m => ViewId -> View -> m ()
update_view ViewId
view_id View
view = do
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_views :: Map ViewId View
state_views = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall a b. a -> b -> a
const View
view) ViewId
view_id (State -> Map ViewId View
state_views State
st) }
    forall (m :: * -> *). M m => ViewId -> m ()
damage_view ViewId
view_id

-- * block

get_block :: M m => BlockId -> m Block.Block
get_block :: forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id = forall (m :: * -> *). M m => m State
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k (m :: * -> *) a.
(Stack, Ord k, Show k, M m) =>
k -> Map k a -> m a
lookup_id BlockId
block_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
state_blocks

lookup_block :: M m => BlockId -> m (Maybe Block.Block)
lookup_block :: forall (m :: * -> *). M m => BlockId -> m (Maybe Block)
lookup_block BlockId
block_id = forall (m :: * -> *). M m => m State
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
state_blocks

all_block_ids :: M m => m [BlockId]
all_block_ids :: forall (m :: * -> *). M m => m [BlockId]
all_block_ids = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
state_blocks)

-- | Get all blocks along with their tracks.
all_block_track_ids :: M m => m [(BlockId, [TrackId])]
all_block_track_ids :: forall (m :: * -> *). M m => m [(BlockId, [TrackId])]
all_block_track_ids =
    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 -> [TrackId]
Block.block_track_ids) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
state_blocks)

-- | Make a new block.  If it's the first one, it will be set as the root.
-- This is the low level version, you probably want to use 'create_block'.
--
-- Throw if the BlockId already exists.
create_config_block :: M m => Id.Id -> Block.Block -> m BlockId
create_config_block :: forall (m :: * -> *). M m => Id -> Block -> m BlockId
create_config_block Id
id Block
block = do
    BlockId
bid <- forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
k
-> a
-> (k -> m ())
-> (State -> Map k a)
-> (Map k a -> State -> State)
-> m k
insert (Id -> BlockId
Id.BlockId Id
id) Block
block forall (m :: * -> *). M m => BlockId -> m ()
damage_block State -> Map BlockId Block
state_blocks forall a b. (a -> b) -> a -> b
$
        \Map BlockId Block
blocks State
st -> State
st
            { state_blocks :: Map BlockId Block
state_blocks = Map BlockId Block
blocks
            , state_config :: Config
state_config = let c :: Config
c = State -> Config
state_config State
st
                in Config
c { config_root :: Maybe BlockId
UiConfig.config_root = if forall k a. Map k a -> TrackNum
Map.size Map BlockId Block
blocks forall a. Eq a => a -> a -> Bool
== TrackNum
1
                    then forall a. a -> Maybe a
Just (Id -> BlockId
Id.BlockId Id
id) else Config -> Maybe BlockId
UiConfig.config_root Config
c }
            }
    forall (m :: * -> *). M m => BlockId -> m ()
update_skeleton BlockId
bid
    forall (m :: * -> *) a. Monad m => a -> m a
return BlockId
bid

-- | Make a new block with the default 'Block.Config'.
create_block :: M m => Id.Id -> Text -> [Block.Track] -> m BlockId
create_block :: forall (m :: * -> *). M m => Id -> Text -> [Track] -> m BlockId
create_block Id
block_id Text
title [Track]
tracks =
    forall (m :: * -> *). M m => Id -> Block -> m BlockId
create_config_block Id
block_id (Config -> Text -> [Track] -> Block
Block.block Config
Block.default_config Text
title [Track]
tracks)

-- | Destroy the block and all the views that display it.  If the block was
-- the root, it will be be unset.  The block's tracks are left intact.
destroy_block :: M m => BlockId -> m ()
destroy_block :: forall (m :: * -> *). M m => BlockId -> m ()
destroy_block BlockId
block_id = do
    Map ViewId View
views <- forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
views_of BlockId
block_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => ViewId -> m ()
destroy_view (forall k a. Map k a -> [k]
Map.keys Map ViewId View
views)
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_blocks :: Map BlockId Block
state_blocks = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete BlockId
block_id (State -> Map BlockId Block
state_blocks State
st)
        , state_config :: Config
state_config = let c :: Config
c = State -> Config
state_config State
st in Config
c
            { config_root :: Maybe BlockId
UiConfig.config_root = if Config -> Maybe BlockId
UiConfig.config_root Config
c forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just BlockId
block_id
                then forall a. Maybe a
Nothing else Config -> Maybe BlockId
UiConfig.config_root Config
c
            }
        }
    forall (m :: * -> *). M m => BlockId -> m ()
damage_block BlockId
block_id
    [(BlockId, Block)]
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
state_blocks)
    -- Remove integration destinations of any blocks that were generated from
    -- this one.
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_block) [(BlockId, Block)]
blocks

block_of :: M m => ViewId -> m Block.Block
block_of :: forall (m :: * -> *). M m => ViewId -> m Block
block_of ViewId
view_id = forall (m :: * -> *). M m => BlockId -> m Block
get_block forall b c a. (b -> c) -> (a -> b) -> a -> c
. View -> BlockId
Block.view_block forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => ViewId -> m View
get_view ViewId
view_id

block_id_of :: M m => ViewId -> m BlockId
block_id_of :: forall (m :: * -> *). M m => ViewId -> m BlockId
block_id_of ViewId
view_id = View -> BlockId
Block.view_block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => ViewId -> m View
get_view ViewId
view_id

-- | Get all views of a given block.
views_of :: M m => BlockId -> m (Map ViewId Block.View)
views_of :: forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
views_of BlockId
block_id = do
    Map ViewId View
views <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map ViewId View
state_views
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((forall a. Eq a => a -> a -> Bool
==BlockId
block_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. View -> BlockId
Block.view_block) Map ViewId View
views

get_block_title :: M m => BlockId -> m Text
get_block_title :: forall (m :: * -> *). M m => BlockId -> m Text
get_block_title = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block -> Text
Block.block_title forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => BlockId -> m Block
get_block

set_block_title :: M m => BlockId -> Text -> m ()
set_block_title :: forall (m :: * -> *). M m => BlockId -> Text -> m ()
set_block_title BlockId
block_id Text
title =
    forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id (\Block
block -> Block
block { block_title :: Text
Block.block_title = Text
title })

modify_block_meta :: M m => BlockId -> (Block.Meta -> Block.Meta) -> m ()
modify_block_meta :: forall (m :: * -> *). M m => BlockId -> (Meta -> Meta) -> m ()
modify_block_meta BlockId
block_id Meta -> Meta
f = forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block ->
    Block
block { block_meta :: Meta
Block.block_meta = Meta -> Meta
f (Block -> Meta
Block.block_meta Block
block) }

-- | Set or clear this block as an integrate destination.  The automatic
-- integration system will update it from the given source block.
set_integrated_block :: M m => BlockId
    -> Maybe (BlockId, Block.TrackDestinations) -> m ()
set_integrated_block :: forall (m :: * -> *).
M m =>
BlockId -> Maybe (BlockId, TrackDestinations) -> m ()
set_integrated_block BlockId
block_id Maybe (BlockId, TrackDestinations)
integrated = do
    forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block ->
        Block
block { block_integrated :: Maybe (BlockId, TrackDestinations)
Block.block_integrated = Maybe (BlockId, TrackDestinations)
integrated }
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    forall (m :: * -> *). M m => Text -> StateId [Text] -> m ()
require_valid (Text
"set_integrated_block " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id)
        (forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_block BlockId
block_id Block
block)

modify_integrated_tracks :: M m => BlockId
    -> ([(TrackId, Block.TrackDestinations)]
        -> [(TrackId, Block.TrackDestinations)])
    -> m ()
modify_integrated_tracks :: forall (m :: * -> *).
M m =>
BlockId
-> ([(TrackId, TrackDestinations)]
    -> [(TrackId, TrackDestinations)])
-> m ()
modify_integrated_tracks BlockId
block_id [(TrackId, TrackDestinations)] -> [(TrackId, TrackDestinations)]
modify = do
    [TrackId]
pre <- Block -> [TrackId]
dest_track_ids forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block
        { block_integrated_tracks :: [(TrackId, TrackDestinations)]
Block.block_integrated_tracks =
            [(TrackId, TrackDestinations)] -> [(TrackId, TrackDestinations)]
modify (Block -> [(TrackId, TrackDestinations)]
Block.block_integrated_tracks Block
block)
        }
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    forall (m :: * -> *). M m => Text -> StateId [Text] -> m ()
require_valid (Text
"modify_integrated_tracks " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_tracks BlockId
block_id Block
block
    -- fix_integrated_tracks will detect integrates where the track is gone.
    -- If the track remains but a previously existing integration was deleted,
    -- clear out the corresponding Event.stacks.
    let post :: [TrackId]
post = Block -> [TrackId]
dest_track_ids Block
block
    let gone :: [TrackId]
gone = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TrackId]
post) [TrackId]
pre
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => TrackId -> m ()
clear_integration [TrackId]
gone
    where
    -- TODO This also gets derive integration, is that correct?
    dest_track_ids :: Block -> [TrackId]
dest_track_ids = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TrackDestinations -> [TrackId]
Block.dest_track_ids 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
. Block -> [(TrackId, TrackDestinations)]
Block.block_integrated_tracks

-- | Set or clear the block's manual integration 'Block.NoteDestination's.
-- This just attaches (or removes) the integrate information to the block so
-- a future integration can use it to merge, and then call this function again.
set_integrated_manual :: M m => BlockId -> Block.SourceKey
    -> Maybe [Block.NoteDestination] -> m ()
set_integrated_manual :: forall (m :: * -> *).
M m =>
BlockId -> Text -> Maybe [NoteDestination] -> m ()
set_integrated_manual BlockId
block_id Text
key Maybe [NoteDestination]
dests =
    forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block
        { block_integrated_manual :: ManualDestinations
Block.block_integrated_manual =
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
key) (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key) Maybe [NoteDestination]
dests
                (Block -> ManualDestinations
Block.block_integrated_manual Block
block)
        }
    -- TODO require_valid?

modify_block_config :: M m => BlockId -> (Block.Config -> Block.Config) -> m ()
modify_block_config :: forall (m :: * -> *). M m => BlockId -> (Config -> Config) -> m ()
modify_block_config BlockId
block_id Config -> Config
modify = forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$
    \Block
block -> Block
block { block_config :: Config
Block.block_config = Config -> Config
modify (Block -> Config
Block.block_config Block
block) }

set_edit_box :: M m => BlockId -> Block.Box -> Block.Box -> m ()
set_edit_box :: forall (m :: * -> *). M m => BlockId -> Box -> Box -> m ()
set_edit_box BlockId
block_id Box
skel Box
track = forall (m :: * -> *). M m => BlockId -> (Config -> Config) -> m ()
modify_block_config BlockId
block_id forall a b. (a -> b) -> a -> b
$
    \Config
config -> Config
config
        { config_skel_box :: Box
Block.config_skel_box = Box
skel
        , config_track_box :: Box
Block.config_track_box = Box
track
        }

-- | The play box doesn't use a char, so I leave that out.
set_play_box :: M m => BlockId -> Color.Color -> m ()
set_play_box :: forall (m :: * -> *). M m => BlockId -> Color -> m ()
set_play_box BlockId
block_id Color
color = forall (m :: * -> *). M m => BlockId -> (Config -> Config) -> m ()
modify_block_config BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Config
config -> Config
config
    { config_sb_box :: Box
Block.config_sb_box = Color -> Char -> Box
Block.Box Color
color Char
' ' }

-- | Get the end of the block according to the ruler.  This means that if the
-- block has no rulers (e.g. a clipboard block) then block_ruler_end will be 0.
block_ruler_end :: M m => BlockId -> m TrackTime
block_ruler_end :: forall (m :: * -> *). M m => BlockId -> m TrackTime
block_ruler_end BlockId
block_id = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    case Block -> [RulerId]
Block.block_ruler_ids Block
block of
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return TrackTime
0
        RulerId
ruler_id : [RulerId]
_ -> Ruler -> TrackTime
Ruler.time_end forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
ruler_id

-- | Get the end of the block according to the last event of the block.
block_event_end :: M m => BlockId -> m TrackTime
block_event_end :: forall (m :: * -> *). M m => BlockId -> m TrackTime
block_event_end BlockId
block_id = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    [TrackTime]
track_ends <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => TrackId -> m TrackTime
track_event_end (Block -> [TrackId]
Block.block_track_ids Block
block)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (TrackTime
0 forall a. a -> [a] -> [a]
: [TrackTime]
track_ends)

-- | Get the maximum of ruler end and event end.  The end may still be 0 if the
-- block is totally empty.
block_end :: M m => BlockId -> m TrackTime
block_end :: forall (m :: * -> *). M m => BlockId -> m TrackTime
block_end BlockId
block_id =
    forall a. Ord a => a -> a -> a
max forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m TrackTime
block_ruler_end BlockId
block_id forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). M m => BlockId -> m TrackTime
block_event_end BlockId
block_id

-- | The logical range is defined by 'Ruler.bounds_of' and is intended to
-- correspond to the \"note\" that this block defines.
block_logical_range :: M m => BlockId -> m (TrackTime, TrackTime)
block_logical_range :: forall (m :: * -> *). M m => BlockId -> m (TrackTime, TrackTime)
block_logical_range BlockId
block_id = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    case Block -> [RulerId]
Block.block_ruler_ids Block
block of
        [] -> (,) TrackTime
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m TrackTime
block_event_end BlockId
block_id
        RulerId
ruler_id : [RulerId]
_ -> do
            (TrackTime
start, Maybe TrackTime
end) <- Ruler -> (TrackTime, Maybe TrackTime)
Ruler.bounds_of forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
ruler_id
            TrackTime
end <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). M m => BlockId -> m TrackTime
block_event_end BlockId
block_id) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TrackTime
end
            forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime
start, TrackTime
end)

-- ** skeleton

set_skeleton_config :: M m => BlockId -> Block.Skeleton -> m ()
set_skeleton_config :: forall (m :: * -> *). M m => BlockId -> Skeleton -> m ()
set_skeleton_config BlockId
block_id Skeleton
skel = do
    forall (m :: * -> *). M m => BlockId -> (Config -> Config) -> m ()
modify_block_config BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Config
config -> Config
config
        { config_skeleton :: Skeleton
Block.config_skeleton = Skeleton
skel }
    forall (m :: * -> *). M m => BlockId -> m ()
update_skeleton BlockId
block_id
    forall (m :: * -> *). M m => m ()
damage_score

has_explicit_skeleton :: M m => BlockId -> m Bool
has_explicit_skeleton :: forall (m :: * -> *). M m => BlockId -> m Bool
has_explicit_skeleton =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. Eq a => a -> a -> Bool
==Skeleton
Block.Explicit) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Skeleton
Block.config_skeleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Config
Block.block_config)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => BlockId -> m Block
get_block

get_skeleton :: M m => BlockId -> m Skeleton.Skeleton
get_skeleton :: forall (m :: * -> *). M m => BlockId -> m Skeleton
get_skeleton BlockId
block_id = Block -> Skeleton
Block.block_skeleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id

set_skeleton :: M m => BlockId -> Skeleton.Skeleton -> m ()
set_skeleton :: forall (m :: * -> *). M m => BlockId -> Skeleton -> m ()
set_skeleton BlockId
block_id Skeleton
skel = forall (m :: * -> *).
M m =>
BlockId -> (Skeleton -> Skeleton) -> m ()
modify_skeleton BlockId
block_id (forall a b. a -> b -> a
const Skeleton
skel)

modify_skeleton :: M m => BlockId
    -> (Skeleton.Skeleton -> Skeleton.Skeleton) -> m ()
modify_skeleton :: forall (m :: * -> *).
M m =>
BlockId -> (Skeleton -> Skeleton) -> m ()
modify_skeleton BlockId
block_id Skeleton -> Skeleton
modify = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    let config :: Skeleton
config = Config -> Skeleton
Block.config_skeleton (Block -> Config
Block.block_config Block
block)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Skeleton
config forall a. Eq a => a -> a -> Bool
== Skeleton
Block.Explicit) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"can't modify skeleton 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
", it's not explicit: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Skeleton
config
    forall (m :: * -> *). M m => BlockId -> Block -> Skeleton -> m ()
_set_skeleton BlockId
block_id Block
block forall a b. (a -> b) -> a -> b
$ Skeleton -> Skeleton
modify (Block -> Skeleton
Block.block_skeleton Block
block)

_set_skeleton :: M m => BlockId -> Block.Block -> Skeleton.Skeleton -> m ()
_set_skeleton :: forall (m :: * -> *). M m => BlockId -> Block -> Skeleton -> m ()
_set_skeleton BlockId
block_id Block
block Skeleton
skel = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Skeleton -> [(TrackNum, TrackNum)]
Skeleton.flatten Skeleton
skel) forall a b. (a -> b) -> a -> b
$ \(TrackNum
parent, TrackNum
child) ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Ord a => a -> a -> a -> Bool
Num.inRange TrackNum
1 TrackNum
tracks TrackNum
parent Bool -> Bool -> Bool
&& forall a. Ord a => a -> a -> a -> Bool
Num.inRange TrackNum
1 TrackNum
tracks TrackNum
child) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"modify_skeleton: edge " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (TrackNum
parent, TrackNum
child)
                forall a. Semigroup a => a -> a -> a
<> Text
" out of range for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
block_id
    forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block { block_skeleton :: Skeleton
Block.block_skeleton = Skeleton
skel }
    where tracks :: TrackNum
tracks = forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length forall a b. (a -> b) -> a -> b
$ Block -> [Track]
Block.block_tracks Block
block

-- | Toggle the given edge in the block's skeleton.  If a cycle would be
-- created, refuse to add the edge and return False.  The edge is in (parent,
-- child) order.
toggle_skeleton_edge :: M m => Bool
    -- ^ If not true, the child's existing parents will be unlinked.
    -- While a track with multiple parents is possible, and is a way to
    -- express the same score derived under different conditions, in practice
    -- I never do that.
    -> BlockId -> Skeleton.Edge -> m Bool
toggle_skeleton_edge :: forall (m :: * -> *).
M m =>
Bool -> BlockId -> (TrackNum, TrackNum) -> m Bool
toggle_skeleton_edge Bool
allow_multiple_parents BlockId
block_id edge :: (TrackNum, TrackNum)
edge@(TrackNum
_, TrackNum
child) = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Block -> (TrackNum, TrackNum) -> Maybe Text
edges_in_range Block
block (TrackNum, TrackNum)
edge) (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"toggle: "<>))
    let skel :: Skeleton
skel = Skeleton -> Skeleton
drop_parents (Block -> Skeleton
Block.block_skeleton Block
block)
    case (TrackNum, TrackNum) -> Skeleton -> Maybe Skeleton
Skeleton.toggle_edge (TrackNum, TrackNum)
edge Skeleton
skel of
        Maybe Skeleton
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just Skeleton
new_skel -> do
            forall (m :: * -> *). M m => BlockId -> Skeleton -> m ()
set_skeleton BlockId
block_id Skeleton
new_skel
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    where
    drop_parents :: Skeleton -> Skeleton
drop_parents Skeleton
skel
        | Bool
allow_multiple_parents Bool -> Bool -> Bool
|| Skeleton -> (TrackNum, TrackNum) -> Bool
Skeleton.has_edge Skeleton
skel (TrackNum, TrackNum)
edge = Skeleton
skel
        | Bool
otherwise = [(TrackNum, TrackNum)] -> Skeleton -> Skeleton
Skeleton.remove_edges [(TrackNum, TrackNum)]
parents Skeleton
skel
        where parents :: [(TrackNum, TrackNum)]
parents = forall a b. (a -> b) -> [a] -> [b]
map (, TrackNum
child) (Skeleton -> TrackNum -> [TrackNum]
Skeleton.parents Skeleton
skel TrackNum
child)

-- | Add the edges to the skeleton.  Throw if they would produce a cycle.
add_edges :: M m => BlockId -> [Skeleton.Edge] -> m ()
add_edges :: forall (m :: * -> *).
M m =>
BlockId -> [(TrackNum, TrackNum)] -> m ()
add_edges BlockId
block_id [(TrackNum, TrackNum)]
edges = do
    Skeleton
skel <- forall (m :: * -> *). M m => BlockId -> m Skeleton
get_skeleton BlockId
block_id
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map (Block -> (TrackNum, TrackNum) -> Maybe Text
edges_in_range Block
block) [(TrackNum, TrackNum)]
edges))
        (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"add_edges: " <>))
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"add_edges " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [(TrackNum, TrackNum)]
edges forall a. Semigroup a => a -> a -> a
<> Text
" to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Skeleton
skel
            forall a. Semigroup a => a -> a -> a
<> Text
" would have caused a cycle")
        (forall (m :: * -> *). M m => BlockId -> Skeleton -> m ()
set_skeleton BlockId
block_id) ([(TrackNum, TrackNum)] -> Skeleton -> Maybe Skeleton
Skeleton.add_edges [(TrackNum, TrackNum)]
edges Skeleton
skel)

remove_edges :: M m => BlockId -> [Skeleton.Edge] -> m ()
remove_edges :: forall (m :: * -> *).
M m =>
BlockId -> [(TrackNum, TrackNum)] -> m ()
remove_edges BlockId
block_id [(TrackNum, TrackNum)]
edges =
    forall (m :: * -> *).
M m =>
BlockId -> (Skeleton -> Skeleton) -> m ()
modify_skeleton BlockId
block_id ([(TrackNum, TrackNum)] -> Skeleton -> Skeleton
Skeleton.remove_edges [(TrackNum, TrackNum)]
edges)

-- | The first tracknum is spliced above the second.
splice_skeleton_above :: M m => BlockId -> TrackNum -> TrackNum -> m ()
splice_skeleton_above :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
splice_skeleton_above = forall (m :: * -> *).
M m =>
Bool -> BlockId -> TrackNum -> TrackNum -> m ()
_splice_skeleton Bool
True

-- | The first tracknum is spliced below the second.
splice_skeleton_below :: M m => BlockId -> TrackNum -> TrackNum -> m ()
splice_skeleton_below :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
splice_skeleton_below = forall (m :: * -> *).
M m =>
Bool -> BlockId -> TrackNum -> TrackNum -> m ()
_splice_skeleton Bool
False

-- | Splice the given tracknum into the skeleton, either above or below
-- the @to@ tracknum.  What this means exactly is documented in
-- 'Graphs.splice_above' and 'Graphs.slice_below'.
_splice_skeleton :: M m => Bool -> BlockId -> TrackNum -> TrackNum -> m ()
_splice_skeleton :: forall (m :: * -> *).
M m =>
Bool -> BlockId -> TrackNum -> TrackNum -> m ()
_splice_skeleton Bool
above BlockId
block_id TrackNum
new TrackNum
to = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map (Block -> TrackNum -> Maybe Text
edge_in_range Block
block) [TrackNum
new, TrackNum
to]))
        (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"splice: " <>))
    let splice :: TrackNum -> TrackNum -> Skeleton -> Maybe Skeleton
splice = if Bool
above then TrackNum -> TrackNum -> Skeleton -> Maybe Skeleton
Skeleton.splice_above else TrackNum -> TrackNum -> Skeleton -> Maybe Skeleton
Skeleton.splice_below
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"splice_skeleton: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (TrackNum
new, TrackNum
to)
            forall a. Semigroup a => a -> a -> a
<> Text
" would have caused a cycle")
        (forall (m :: * -> *). M m => BlockId -> Skeleton -> m ()
set_skeleton BlockId
block_id) (TrackNum -> TrackNum -> Skeleton -> Maybe Skeleton
splice TrackNum
new TrackNum
to (Block -> Skeleton
Block.block_skeleton Block
block))

edge_in_range :: Block.Block -> TrackNum -> Maybe Text
edge_in_range :: Block -> TrackNum -> Maybe Text
edge_in_range Block
block TrackNum
tracknum =
    case forall a. [a] -> TrackNum -> Maybe a
Lists.at (Block -> [Track]
Block.block_tracks Block
block) TrackNum
tracknum of
        Maybe Track
Nothing -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"tracknum out of range: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
tracknum
        Just Track
t -> case Track -> TracklikeId
Block.tracklike_id Track
t of
            Block.TId {} -> forall a. Maybe a
Nothing
            TracklikeId
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"edge points to non-event track: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Track
t

edges_in_range :: Block.Block -> Skeleton.Edge -> Maybe Text
edges_in_range :: Block -> (TrackNum, TrackNum) -> Maybe Text
edges_in_range Block
block (TrackNum
from, TrackNum
to) =
    Block -> TrackNum -> Maybe Text
edge_in_range Block
block TrackNum
from forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Block -> TrackNum -> Maybe Text
edge_in_range Block
block TrackNum
to

-- ** tracks

-- | Insert a track at the given TrackNum.  The TrackNum can be out of range to
-- insert a track at the beginning or append it to the end.
--
-- This will throw if it's an event track and the block already contains that
-- TrackId.  This invariant ensures that a (BlockId, TrackNum) is
-- interchangeable with a TrackId.
insert_track :: M m => BlockId -> TrackNum -> Block.Track -> m ()
insert_track :: forall (m :: * -> *). M m => BlockId -> TrackNum -> Track -> m ()
insert_track BlockId
block_id TrackNum
tracknum Track
track = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    Map ViewId View
views <- forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
views_of BlockId
block_id
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Track -> Maybe TrackId
Block.track_id Track
track) forall a b. (a -> b) -> a -> b
$ \TrackId
track_id -> do
        [TrackId]
track_ids <- forall (m :: * -> *). M m => BlockId -> m [TrackId]
track_ids_of BlockId
block_id
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TrackId
track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackId]
track_ids) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"insert_track: block " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
block_id
                forall a. Semigroup a => a -> a -> a
<> Text
" already contains " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
track_id
    -- You can only put a ruler in tracknum 0.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TrackNum
tracknum forall a. Ord a => a -> a -> Bool
> TrackNum
0 Bool -> Bool -> Bool
|| Track -> Bool
is_ruler Track
track) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"non-ruler track can't go at tracknum " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
tracknum
            forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Track
track
    let tracks :: [Track]
tracks = forall a. TrackNum -> a -> [a] -> [a]
Lists.insertAt TrackNum
tracknum Track
track (Block -> [Track]
Block.block_tracks Block
block)
        -- Make sure the views are up to date.
        views' :: Map ViewId View
views' = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Block -> TrackNum -> View -> View
insert_into_view Block
block TrackNum
tracknum) Map ViewId View
views
    Skeleton
skel <- case Config -> Skeleton
Block.config_skeleton (Block -> Config
Block.block_config Block
block) of
        Skeleton
Block.Explicit -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            TrackNum -> Skeleton -> Skeleton
Skeleton.insert TrackNum
tracknum (Block -> Skeleton
Block.block_skeleton Block
block)
        Skeleton
Block.Implicit -> forall (m :: * -> *). M m => [Track] -> m Skeleton
infer_skeleton [Track]
tracks
    forall (m :: * -> *). M m => BlockId -> Block -> m ()
set_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ Block
block
        { block_tracks :: [Track]
Block.block_tracks = [Track]
tracks
        , block_skeleton :: Skeleton
Block.block_skeleton = Skeleton
skel
        }
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_views :: Map ViewId View
state_views = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map ViewId View
views' (State -> Map ViewId View
state_views State
st) }
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => ViewId -> m ()
damage_view (forall k a. Map k a -> [k]
Map.keys Map ViewId View
views')
    where
    is_ruler :: Track -> Bool
is_ruler Track
t = case Track -> TracklikeId
Block.tracklike_id Track
t of
        Block.RId {} -> Bool
True
        TracklikeId
_ -> Bool
False

-- | Remove the track at the given tracknum.
remove_track :: M m => BlockId -> TrackNum -> m ()
remove_track :: forall (m :: * -> *). M m => BlockId -> TrackNum -> m ()
remove_track BlockId
block_id TrackNum
tracknum = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    let tracks :: [Track]
tracks = Block -> [Track]
Block.block_tracks Block
block
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TrackNum
1 forall a. Ord a => a -> a -> Bool
<= TrackNum
tracknum Bool -> Bool -> Bool
&& TrackNum
tracknum forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [Track]
tracks) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"remove_track " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
tracknum
            forall a. Semigroup a => a -> a -> a
<> Text
" out of range 1--" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [Track]
tracks)
    Map ViewId View
views <- forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Block -> TrackNum -> View -> View
remove_from_view Block
block TrackNum
tracknum) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
views_of BlockId
block_id
    forall (m :: * -> *). M m => BlockId -> Block -> m ()
set_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ Block
block
        { block_tracks :: [Track]
Block.block_tracks = forall a. TrackNum -> [a] -> [a]
Lists.removeAt TrackNum
tracknum [Track]
tracks
        , block_skeleton :: Skeleton
Block.block_skeleton =
            TrackNum -> Skeleton -> Skeleton
Skeleton.remove TrackNum
tracknum (Block -> Skeleton
Block.block_skeleton Block
block)
        }
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_views :: Map ViewId View
state_views = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map ViewId View
views (State -> Map ViewId View
state_views State
st) }
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => ViewId -> m ()
damage_view (forall k a. Map k a -> [k]
Map.keys Map ViewId View
views)
    -- Clear any orphaned integration destinations.
    forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_tracks BlockId
block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Move a track from one tracknum to another.
move_track :: M m => BlockId -> TrackNum -> TrackNum -> m ()
move_track :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
move_track BlockId
block_id TrackNum
from TrackNum
to = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    let msg :: Text
msg = Text
"move_track: from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
from forall a. Semigroup a => a -> a -> a
<> Text
" to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
to
            forall a. Semigroup a => a -> a -> a
<> Text
" out of range"
    [Track]
tracks <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require Text
msg forall a b. (a -> b) -> a -> b
$ do
        -- Things get generally messed up if you try to move an event track to
        -- the ruler spot.
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TrackNum
from forall a. Eq a => a -> a -> Bool
/= TrackNum
0 Bool -> Bool -> Bool
&& TrackNum
to forall a. Eq a => a -> a -> Bool
/= TrackNum
0)
        forall a. TrackNum -> TrackNum -> [a] -> Maybe [a]
Lists.move TrackNum
from TrackNum
to (Block -> [Track]
Block.block_tracks Block
block)
    Skeleton
skel <- case Config -> Skeleton
Block.config_skeleton (Block -> Config
Block.block_config Block
block) of
        Skeleton
Block.Explicit -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            TrackNum -> TrackNum -> Skeleton -> Skeleton
Skeleton.move TrackNum
from TrackNum
to (Block -> Skeleton
Block.block_skeleton Block
block)
        Skeleton
Block.Implicit -> forall (m :: * -> *). M m => [Track] -> m Skeleton
infer_skeleton [Track]
tracks
    forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Block
block
        { block_tracks :: [Track]
Block.block_tracks = [Track]
tracks, block_skeleton :: Skeleton
Block.block_skeleton = Skeleton
skel }

infer_skeleton :: M m => [Block.Track] -> m Skeleton.Skeleton
infer_skeleton :: forall (m :: * -> *). M m => [Track] -> m Skeleton
infer_skeleton [Track]
tracks = do
    [(TrackNum, Text)]
titles <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). M m => TrackId -> m Text
get_track_title) forall a b. (a -> b) -> a -> b
$
        forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)]
Lists.mapMaybeSnd Track -> Maybe TrackId
Block.track_id (forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] [Track]
tracks)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Track] -> Skeleton
ParseSkeleton.default_parser forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TrackNum -> Text -> Track
ParseSkeleton.Track) [(TrackNum, Text)]
titles

update_skeleton :: M m => BlockId -> m ()
update_skeleton :: forall (m :: * -> *). M m => BlockId -> m ()
update_skeleton BlockId
block_id = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    case Config -> Skeleton
Block.config_skeleton (Block -> Config
Block.block_config Block
block) of
        Skeleton
Block.Implicit -> forall (m :: * -> *). M m => BlockId -> Block -> Skeleton -> m ()
_set_skeleton BlockId
block_id Block
block
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => [Track] -> m Skeleton
infer_skeleton (Block -> [Track]
Block.block_tracks Block
block)
        Skeleton
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- *** tracks by TrackNum

-- | Number of tracks in the block.  This includes the ruler, so subtract 1 if
-- you want all non-ruler tracks.
track_count :: M m => BlockId -> m TrackNum
track_count :: forall (m :: * -> *). M m => BlockId -> m TrackNum
track_count BlockId
block_id = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length (Block -> [Track]
Block.block_tracks Block
block)

-- | Get the Track at @tracknum@, or Nothing if its out of range.
block_track_at :: M m => BlockId -> TrackNum -> m (Maybe Block.Track)
block_track_at :: forall (m :: * -> *). M m => BlockId -> TrackNum -> m (Maybe Track)
block_track_at BlockId
block_id TrackNum
tracknum
    | TrackNum
tracknum forall a. Ord a => a -> a -> Bool
< TrackNum
0 =
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"block_track_at: negative tracknum: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
tracknum
    | Bool
otherwise = do
        Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> TrackNum -> Maybe a
Lists.at (Block -> [Track]
Block.block_tracks Block
block) TrackNum
tracknum

get_block_track_at :: M m => BlockId -> TrackNum -> m Block.Track
get_block_track_at :: forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
get_block_track_at BlockId
block_id TrackNum
tracknum =
    forall {m :: * -> *} {b}.
M m =>
BlockId -> TrackNum -> Maybe b -> m b
tracknum_in_range BlockId
block_id TrackNum
tracknum forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> TrackNum -> m (Maybe Track)
block_track_at BlockId
block_id TrackNum
tracknum
    where
    tracknum_in_range :: BlockId -> TrackNum -> Maybe b -> m b
tracknum_in_range BlockId
block_id TrackNum
tracknum Maybe b
Nothing = do
        TrackNum
count <- forall (m :: * -> *). M m => BlockId -> m TrackNum
track_count BlockId
block_id
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"track " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (BlockId -> TrackNum -> Track
Track BlockId
block_id TrackNum
tracknum)
            forall a. Semigroup a => a -> a -> a
<> Text
" out of range 0--" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
count
    tracknum_in_range BlockId
_ TrackNum
_ (Just b
a) = forall (m :: * -> *) a. Monad m => a -> m a
return b
a

track_at :: M m => BlockId -> TrackNum -> m (Maybe Block.TracklikeId)
track_at :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TracklikeId)
track_at BlockId
block_id TrackNum
tracknum = do
    Maybe Track
maybe_track <- forall (m :: * -> *). M m => BlockId -> TrackNum -> m (Maybe Track)
block_track_at BlockId
block_id TrackNum
tracknum
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Track -> TracklikeId
Block.tracklike_id Maybe Track
maybe_track

-- | Like 'track_at', but only for event tracks.
event_track_at :: M m => BlockId -> TrackNum -> m (Maybe TrackId)
event_track_at :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TrackId)
event_track_at BlockId
block_id TrackNum
tracknum = do
    Maybe TracklikeId
maybe_track <- forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TracklikeId)
track_at BlockId
block_id TrackNum
tracknum
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TracklikeId -> Maybe TrackId
Block.track_id_of forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe TracklikeId
maybe_track

-- | Like 'event_track_at' but throws if it's not there or not an event track.
get_event_track_at :: M m => BlockId -> TrackNum -> m TrackId
get_event_track_at :: forall (m :: * -> *). M m => BlockId -> TrackNum -> m TrackId
get_event_track_at BlockId
block_id TrackNum
tracknum = do
    Track
track <- forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
get_block_track_at BlockId
block_id TrackNum
tracknum
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"track " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (BlockId -> TrackNum -> Track
Track BlockId
block_id TrackNum
tracknum)
            forall a. Semigroup a => a -> a -> a
<> Text
" not an event track") forall a b. (a -> b) -> a -> b
$
        Track -> Maybe TrackId
Block.track_id Track
track

-- | Get the RulerId of an event or ruler track, or Nothing if the tracknum is
-- out of range or doesn't have a ruler.
ruler_track_at :: M m => BlockId -> TrackNum -> m (Maybe RulerId)
ruler_track_at :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe RulerId)
ruler_track_at BlockId
block_id TrackNum
tracknum = do
    Maybe TracklikeId
maybe_track <- forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TracklikeId)
track_at BlockId
block_id TrackNum
tracknum
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TracklikeId -> Maybe RulerId
Block.ruler_id_of forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe TracklikeId
maybe_track

-- | 0 is the conventional ruler tracknum.
block_ruler :: M m => BlockId -> m RulerId
block_ruler :: forall (m :: * -> *). M m => BlockId -> m RulerId
block_ruler BlockId
block_id = forall a. a -> Maybe a -> a
fromMaybe RulerId
no_ruler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe RulerId)
ruler_track_at BlockId
block_id TrackNum
0

-- *** tracks by TrackId

-- | Get all TrackIds of the given block.
track_ids_of :: M m => BlockId -> m [TrackId]
track_ids_of :: forall (m :: * -> *). M m => BlockId -> m [TrackId]
track_ids_of BlockId
block_id = Block -> [TrackId]
Block.block_track_ids forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id

-- | Get all TrackIds of the given block, along with their tracknums.
tracknums_of :: M m => BlockId -> m [(TrackId, TrackNum)]
tracknums_of :: forall (m :: * -> *). M m => BlockId -> m [(TrackId, TrackNum)]
tracknums_of = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a a2 b. (a -> Maybe a2) -> [(a, b)] -> [(a2, b)]
Lists.mapMaybeFst Track -> Maybe TrackId
Block.track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => BlockId -> m [(Track, TrackNum)]
block_tracknums

-- | Get tracks along with their TrackNums.
block_tracknums :: M m => BlockId -> m [(Block.Track, TrackNum)]
block_tracknums :: forall (m :: * -> *). M m => BlockId -> m [(Track, TrackNum)]
block_tracknums = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Track]
Block.block_tracks) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => BlockId -> m Block
get_block

-- | There can only be one TrackId per block, which allows TrackNums and
-- TrackIds to be interchangeable.  This is enforced by 'insert_track'.
--
-- The inverse is 'event_track_at'.
tracknum_of :: M m => BlockId -> TrackId -> m (Maybe TrackNum)
tracknum_of :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe TrackNum)
tracknum_of BlockId
block_id TrackId
tid = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TrackId
tid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m [(TrackId, TrackNum)]
tracknums_of BlockId
block_id

get_tracknum_of :: M m => BlockId -> TrackId -> m TrackNum
get_tracknum_of :: forall (m :: * -> *). M m => BlockId -> TrackId -> m TrackNum
get_tracknum_of BlockId
block_id TrackId
tid =
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"tracknum_of: track " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
tid 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 TrackNum)
tracknum_of BlockId
block_id TrackId
tid

-- *** block track

set_track_width :: M m => BlockId -> TrackNum -> Types.Width -> m ()
set_track_width :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
set_track_width BlockId
block_id TrackNum
tracknum TrackNum
width =
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum forall a b. (a -> b) -> a -> b
$ \Track
btrack ->
        Track
btrack { track_width :: TrackNum
Block.track_width = TrackNum
width }

set_track_suggested_width :: M m => BlockId -> TrackNum -> Types.Width -> m ()
set_track_suggested_width :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
set_track_suggested_width BlockId
block_id TrackNum
tracknum TrackNum
width =
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum forall a b. (a -> b) -> a -> b
$ \Track
btrack ->
        Track
btrack { track_suggested_width :: TrackNum
Block.track_suggested_width = TrackNum
width }

track_flags :: M m => BlockId -> TrackNum -> m (Set Block.TrackFlag)
track_flags :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Set TrackFlag)
track_flags BlockId
block_id TrackNum
tracknum =
    Track -> Set TrackFlag
Block.track_flags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
get_block_track_at BlockId
block_id TrackNum
tracknum

track_collapsed :: M m => BlockId -> TrackNum -> m Bool
track_collapsed :: forall (m :: * -> *). M m => BlockId -> TrackNum -> m Bool
track_collapsed BlockId
block_id TrackNum
tracknum =
    Set TrackFlag -> Bool
Block.is_collapsed forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Set TrackFlag
Block.track_flags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
get_block_track_at BlockId
block_id TrackNum
tracknum

toggle_track_flag :: M m => BlockId -> TrackNum -> Block.TrackFlag -> m ()
toggle_track_flag :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackFlag -> m ()
toggle_track_flag BlockId
block_id TrackNum
tracknum TrackFlag
flag =
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Set TrackFlag -> Set TrackFlag) -> m ()
modify_track_flags BlockId
block_id TrackNum
tracknum Set TrackFlag -> Set TrackFlag
toggle
    where
    toggle :: Set TrackFlag -> Set TrackFlag
toggle Set TrackFlag
flags
        | TrackFlag
flag forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackFlag
flags = forall a. Ord a => a -> Set a -> Set a
Set.delete TrackFlag
flag Set TrackFlag
flags
        | Bool
otherwise = forall a. Ord a => a -> Set a -> Set a
Set.insert TrackFlag
flag Set TrackFlag
flags

add_track_flag, remove_track_flag
    :: M m => BlockId -> TrackNum -> Block.TrackFlag -> m ()
add_track_flag :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackFlag -> m ()
add_track_flag BlockId
block_id TrackNum
tracknum TrackFlag
flag =
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Set TrackFlag -> Set TrackFlag) -> m ()
modify_track_flags BlockId
block_id TrackNum
tracknum forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert TrackFlag
flag
remove_track_flag :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackFlag -> m ()
remove_track_flag BlockId
block_id TrackNum
tracknum TrackFlag
flag =
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Set TrackFlag -> Set TrackFlag) -> m ()
modify_track_flags BlockId
block_id TrackNum
tracknum forall a b. (a -> b) -> a -> b
$ case TrackFlag
flag of
        -- Block.Merge -> Set.delete flag . Set.delete Block.Collapse
        TrackFlag
_ -> forall a. Ord a => a -> Set a -> Set a
Set.delete TrackFlag
flag

modify_track_flags :: M m => BlockId -> TrackNum
    -> (Set Block.TrackFlag -> Set Block.TrackFlag) -> m ()
modify_track_flags :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Set TrackFlag -> Set TrackFlag) -> m ()
modify_track_flags BlockId
block_id TrackNum
tracknum Set TrackFlag -> Set TrackFlag
modify =
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum forall a b. (a -> b) -> a -> b
$ \Track
btrack ->
        -- Don't allow both Merge and Collapse to be set, prefer Merge.
        -- This is so I can Collapse a bunch of tracks, and the Merged ones
        -- will stay the way they are.  Merge also has priority in
        -- Block.display_track, but having both set leads to confusing UI.
        let flags :: Set TrackFlag
flags = Set TrackFlag -> Set TrackFlag
modify (Track -> Set TrackFlag
Block.track_flags Track
btrack)
        in Track
btrack
            { track_flags :: Set TrackFlag
Block.track_flags = if forall a. Ord a => a -> Set a -> Bool
Set.member TrackFlag
Block.Merge Set TrackFlag
flags
                then forall a. Ord a => a -> Set a -> Set a
Set.delete TrackFlag
Block.Collapse Set TrackFlag
flags
                else Set TrackFlag
flags
            }

set_track_ruler :: M m => BlockId -> TrackNum -> RulerId -> m ()
set_track_ruler :: forall (m :: * -> *). M m => BlockId -> TrackNum -> RulerId -> m ()
set_track_ruler BlockId
block_id TrackNum
tracknum RulerId
ruler_id = do
    Ruler
_ <- forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
ruler_id -- Throw if it doesn't exist.
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum forall a b. (a -> b) -> a -> b
$
        (TracklikeId -> TracklikeId) -> Track -> Track
Block.modify_id (RulerId -> TracklikeId -> TracklikeId
Block.set_ruler_id RulerId
ruler_id)

-- | Merge the @from@ tracknum into the @to@ tracknum and collapse @from@.
merge_track :: M m => BlockId -> TrackNum -> TrackNum -> m ()
merge_track :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackNum -> m ()
merge_track BlockId
block_id TrackNum
to TrackNum
from = do
    TrackId
from_id <- forall (m :: * -> *). M m => BlockId -> TrackNum -> m TrackId
get_event_track_at BlockId
block_id TrackNum
from
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
to forall a b. (a -> b) -> a -> b
$ \Track
btrack -> Track
btrack
        { track_merged :: Set TrackId
Block.track_merged = forall a. Ord a => a -> Set a -> Set a
Set.insert TrackId
from_id (Track -> Set TrackId
Block.track_merged Track
btrack) }
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackFlag -> m ()
add_track_flag BlockId
block_id TrackNum
from TrackFlag
Block.Merge

-- | Reverse 'merge_track': remove the merged tracks and expand their
-- occurrances in the given block.  \"Unmerge\" is not a graceful term, but at
-- least it's obviously the opposite of \"merge\".
unmerge_track :: M m => BlockId -> TrackNum -> m ()
unmerge_track :: forall (m :: * -> *). M m => BlockId -> TrackNum -> m ()
unmerge_track BlockId
block_id TrackNum
tracknum = do
    Set TrackId
track_ids <- Track -> Set TrackId
Block.track_merged forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
get_block_track_at BlockId
block_id TrackNum
tracknum
    [TrackNum]
unmerged_tracknums <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe TrackNum)
tracknum_of BlockId
block_id)
        (forall a. Set a -> [a]
Set.toList Set TrackId
track_ids)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TrackNum]
unmerged_tracknums forall a b. (a -> b) -> a -> b
$ \TrackNum
tracknum ->
        forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackFlag -> m ()
remove_track_flag BlockId
block_id TrackNum
tracknum TrackFlag
Block.Merge
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> Set TrackId -> m ()
set_merged_tracks BlockId
block_id TrackNum
tracknum forall a. Monoid a => a
mempty

set_merged_tracks :: M m => BlockId -> TrackNum -> Set TrackId -> m ()
set_merged_tracks :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> Set TrackId -> m ()
set_merged_tracks BlockId
block_id TrackNum
tracknum Set TrackId
merged =
    forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum forall a b. (a -> b) -> a -> b
$ \Track
btrack ->
        Track
btrack { track_merged :: Set TrackId
Block.track_merged = Set TrackId
merged }

track_merged :: M m => BlockId -> TrackNum -> m Bool
track_merged :: forall (m :: * -> *). M m => BlockId -> TrackNum -> m Bool
track_merged BlockId
block_id TrackNum
tracknum = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Set TrackId
Block.track_merged forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
get_block_track_at BlockId
block_id TrackNum
tracknum

-- | Set rulers, one per track.
set_ruler_ids :: M m => BlockId -> [Maybe RulerId] -> m ()
set_ruler_ids :: forall (m :: * -> *). M m => BlockId -> [Maybe RulerId] -> m ()
set_ruler_ids BlockId
block_id [Maybe RulerId]
ruler_ids = forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block
    { block_tracks :: [Track]
Block.block_tracks =
        forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Track -> Maybe RulerId -> Track
set (Block -> [Track]
Block.block_tracks Block
block) ([Maybe RulerId]
ruler_ids forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat forall a. Maybe a
Nothing)
    }
    where
    set :: Track -> Maybe RulerId -> Track
set Track
track (Just RulerId
ruler_id) = Track
track
        { tracklike_id :: TracklikeId
Block.tracklike_id =
            RulerId -> TracklikeId -> TracklikeId
Block.set_ruler_id RulerId
ruler_id (Track -> TracklikeId
Block.tracklike_id Track
track)
        }
    set Track
track Maybe RulerId
Nothing = Track
track

set_ruler_id :: M m => BlockId -> RulerId -> m ()
set_ruler_id :: forall (m :: * -> *). M m => BlockId -> RulerId -> m ()
set_ruler_id BlockId
block_id RulerId
ruler_id = forall (m :: * -> *).
M m =>
BlockId -> (RulerId -> RulerId) -> m ()
modify_ruler_id BlockId
block_id (forall a b. a -> b -> a
const RulerId
ruler_id)

-- | Replace one RulerId with another on the given block.
--
-- It's more convenient to do here than removing and inserting tracks, and easy
-- since there's no "one per block" invariant to maintain with ruler ids.
replace_ruler_id :: M m => BlockId -> RulerId -> RulerId -> m ()
replace_ruler_id :: forall (m :: * -> *). M m => BlockId -> RulerId -> RulerId -> m ()
replace_ruler_id BlockId
block_id RulerId
from RulerId
to =
    forall (m :: * -> *).
M m =>
BlockId -> (RulerId -> RulerId) -> m ()
modify_ruler_id BlockId
block_id forall a b. (a -> b) -> a -> b
$ \RulerId
rid -> if RulerId
rid forall a. Eq a => a -> a -> Bool
== RulerId
from then RulerId
to else RulerId
from

modify_ruler_id :: M m => BlockId -> (RulerId -> RulerId) -> m ()
modify_ruler_id :: forall (m :: * -> *).
M m =>
BlockId -> (RulerId -> RulerId) -> m ()
modify_ruler_id BlockId
block_id RulerId -> RulerId
modify = forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block ->
    Block
block { block_tracks :: [Track]
Block.block_tracks = forall a b. (a -> b) -> [a] -> [b]
map Track -> Track
replace_track (Block -> [Track]
Block.block_tracks Block
block) }
    where
    replace_track :: Track -> Track
replace_track Track
track = Track
track
        { tracklike_id :: TracklikeId
Block.tracklike_id = TracklikeId -> TracklikeId
replace (Track -> TracklikeId
Block.tracklike_id Track
track) }
    replace :: TracklikeId -> TracklikeId
replace TracklikeId
tlike_id = case TracklikeId -> Maybe RulerId
Block.ruler_id_of TracklikeId
tlike_id of
        Just RulerId
rid -> RulerId -> TracklikeId -> TracklikeId
Block.set_ruler_id (RulerId -> RulerId
modify RulerId
rid) TracklikeId
tlike_id
        Maybe RulerId
Nothing -> TracklikeId
tlike_id

-- | Resolve a TracklikeId to a Tracklike.
get_tracklike :: M m => Block.TracklikeId -> m Block.Tracklike
get_tracklike :: forall (m :: * -> *). M m => TracklikeId -> m Tracklike
get_tracklike TracklikeId
track = case TracklikeId
track of
    Block.TId TrackId
tid RulerId
rid -> Track -> Ruler -> Tracklike
Block.T forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m Track
get_track TrackId
tid forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
rid
    Block.RId RulerId
rid -> Ruler -> Tracklike
Block.R forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
rid
    Block.DId Divider
divider -> forall (m :: * -> *) a. Monad m => a -> m a
return (Divider -> Tracklike
Block.D Divider
divider)

modify_block_track :: M m => BlockId -> TrackNum
    -> (Block.Track -> Block.Track) -> m ()
modify_block_track :: forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum Track -> Track
modify = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    [Track]
btracks <- forall (m :: * -> *) a.
M m =>
Text -> [a] -> TrackNum -> (a -> a) -> m [a]
modify_at Text
"modify_block_track"
        (Block -> [Track]
Block.block_tracks Block
block) TrackNum
tracknum Track -> Track
modify
    forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
b -> Block
b { block_tracks :: [Track]
Block.block_tracks = [Track]
btracks }

-- *** track util

-- | Insert a new track into Block.view_tracks, moving selections as
-- appropriate.  @tracknum@ is clipped to be in range.
insert_into_view :: Block.Block -> TrackNum -> Block.View -> Block.View
insert_into_view :: Block -> TrackNum -> View -> View
insert_into_view Block
block TrackNum
tracknum View
view = View
view
    { view_selections :: Map TrackNum Selection
Block.view_selections = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Block -> TrackNum -> Selection -> Selection
insert_into_selection Block
block TrackNum
tracknum)
        (View -> Map TrackNum Selection
Block.view_selections View
view)
    }

-- | Remove @tracknum@ from Block.view_tracks, moving selections as
-- appropriate.  Ignored if @tracknum@ is out of range.
remove_from_view :: Block.Block -> TrackNum -> Block.View -> Block.View
remove_from_view :: Block -> TrackNum -> View -> View
remove_from_view Block
block TrackNum
tracknum View
view = View
view
    { view_selections :: Map TrackNum Selection
Block.view_selections =
        forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey (Block -> TrackNum -> TrackNum -> Selection -> Maybe Selection
remove_from_selection Block
block TrackNum
tracknum)
            (View -> Map TrackNum Selection
Block.view_selections View
view)
    }

-- | If tracknum is before or at the selection, push it to the right.  If it's
-- inside, extend it.  If it's to the right, do nothing.
insert_into_selection :: Block.Block -> TrackNum -> Sel.Selection
    -> Sel.Selection
insert_into_selection :: Block -> TrackNum -> Selection -> Selection
insert_into_selection Block
block TrackNum
tracknum Selection
sel
    | TrackNum
tracknum forall a. Ord a => a -> a -> Bool
<= TrackNum
low = Bool -> Block -> TrackNum -> Selection -> Selection
shift_selection Bool
True Block
block TrackNum
1 Selection
sel
    | TrackNum
tracknum forall a. Ord a => a -> a -> Bool
<= TrackNum
high = TrackNum -> Selection -> Selection
Sel.expand_tracks TrackNum
1 Selection
sel
    | Bool
otherwise = Selection
sel
    where (TrackNum
low, TrackNum
high) = Selection -> (TrackNum, TrackNum)
Sel.track_range Selection
sel

-- | Remove the given track from the selection.  The selection will be moved or
-- shrunk as per 'insert_into_selection', possibly to nothing if the selection
-- was only on the deleted track.  Config.insert_selnum is an exception, it
-- moves one track to the left, if possible.  That's because it's convenient to
-- delete consecutive tracks.
remove_from_selection :: Block.Block -> TrackNum
    -> Sel.Num -> Sel.Selection -> Maybe Sel.Selection
remove_from_selection :: Block -> TrackNum -> TrackNum -> Selection -> Maybe Selection
remove_from_selection Block
block TrackNum
tracknum TrackNum
selnum Selection
sel
    | TrackNum
tracknum forall a. Ord a => a -> a -> Bool
< TrackNum
low = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> Block -> TrackNum -> Selection -> Selection
shift_selection Bool
True Block
block (-TrackNum
1) Selection
sel
    | TrackNum
tracknum forall a. Eq a => a -> a -> Bool
== TrackNum
high Bool -> Bool -> Bool
&& TrackNum
high forall a. Eq a => a -> a -> Bool
== TrackNum
low =
        if TrackNum
selnum forall a. Eq a => a -> a -> Bool
== TrackNum
Config.insert_selnum
        then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> Block -> TrackNum -> Selection -> Selection
shift_selection Bool
True Block
block (-TrackNum
1) Selection
sel
        else forall a. Maybe a
Nothing
    | TrackNum
tracknum forall a. Ord a => a -> a -> Bool
<= TrackNum
high = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TrackNum -> Selection -> Selection
Sel.expand_tracks (-TrackNum
1) Selection
sel
    | Bool
otherwise = forall a. a -> Maybe a
Just Selection
sel
    where (TrackNum
low, TrackNum
high) = Selection -> (TrackNum, TrackNum)
Sel.track_range Selection
sel

-- | Shift the selection, clipping if it's out of range.  While the
-- sel_cur_track won't be on a non-selectable track after this, the selection
-- may still include one.
shift_selection :: Bool -- ^ skip unselectable tracks
    -> Block.Block -> TrackNum -> Sel.Selection -> Sel.Selection
shift_selection :: Bool -> Block -> TrackNum -> Selection -> Selection
shift_selection Bool
skip_unselectable Block
block TrackNum
shift Selection
sel =
    (TrackNum -> TrackNum) -> Selection -> Selection
Sel.modify_tracks (forall a. Num a => a -> a -> a
+TrackNum
shift2) Selection
sel
    where
    shift2 :: TrackNum
shift2
        | Bool
skip_unselectable =
            Block -> TrackNum -> TrackNum -> TrackNum
skip_unselectable_tracks Block
block (Selection -> TrackNum
Sel.cur_track Selection
sel) TrackNum
shift
                forall a. Num a => a -> a -> a
- Selection -> TrackNum
Sel.cur_track Selection
sel
        | Bool
otherwise = TrackNum
shift

-- | Shift a tracknum to another track, skipping unselectable tracks.
skip_unselectable_tracks :: Block.Block -> TrackNum -> Int -> TrackNum
skip_unselectable_tracks :: Block -> TrackNum -> TrackNum -> TrackNum
skip_unselectable_tracks Block
block TrackNum
tracknum TrackNum
shift
    | TrackNum
shift forall a. Eq a => a -> a -> Bool
== TrackNum
0 = TrackNum
tracknum
    | TrackNum
shift forall a. Ord a => a -> a -> Bool
> TrackNum
0 = [TrackNum] -> TrackNum
find_track (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
<TrackNum
tracknum) [TrackNum]
selectable)
    | Bool
otherwise = [TrackNum] -> TrackNum
find_track (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
>TrackNum
tracknum) (forall a. [a] -> [a]
List.reverse [TrackNum]
selectable))
    where
    selectable :: [TrackNum]
selectable = Block -> [TrackNum]
selectable_tracks Block
block
    find_track :: [TrackNum] -> TrackNum
find_track [] = TrackNum
tracknum
    find_track tracks :: [TrackNum]
tracks@(TrackNum
first:[TrackNum]
_) =
        forall a. a -> Maybe a -> a
fromMaybe TrackNum
tracknum forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.head forall a b. (a -> b) -> a -> b
$ forall a. TrackNum -> [a] -> [a]
drop TrackNum
abs_shift [TrackNum]
tracks
        where
        abs_shift :: TrackNum
abs_shift = if TrackNum
tracknum forall a. Eq a => a -> a -> Bool
/= TrackNum
first then forall a. Num a => a -> a
abs TrackNum
shift forall a. Num a => a -> a -> a
- TrackNum
1 else forall a. Num a => a -> a
abs TrackNum
shift

-- | Get the tracknums from a block that should be selectable.
selectable_tracks :: Block.Block -> [TrackNum]
selectable_tracks :: Block -> [TrackNum]
selectable_tracks Block
block =
    [ TrackNum
tracknum | (TrackNum
tracknum, Track
track) <- forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] (Block -> [Track]
Block.block_tracks Block
block)
    , Track -> Bool
Block.track_selectable Track
track
    ]

-- ** util

modify_block :: M m => BlockId -> (Block.Block -> Block.Block) -> m ()
modify_block :: forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id Block -> Block
f = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    forall (m :: * -> *). M m => BlockId -> Block -> m ()
set_block BlockId
block_id (Block -> Block
f Block
block)

set_block :: M m => BlockId -> Block.Block -> m ()
set_block :: forall (m :: * -> *). M m => BlockId -> Block -> m ()
set_block BlockId
block_id Block
block = do
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_blocks :: Map BlockId Block
state_blocks = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall a b. a -> b -> a
const Block
block) BlockId
block_id (State -> Map BlockId Block
state_blocks State
st) }
    forall (m :: * -> *). M m => BlockId -> m ()
damage_block BlockId
block_id

-- * track

get_track :: M m => TrackId -> m Track.Track
get_track :: forall (m :: * -> *). M m => TrackId -> m Track
get_track TrackId
track_id = forall (m :: * -> *). M m => m State
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k (m :: * -> *) a.
(Stack, Ord k, Show k, M m) =>
k -> Map k a -> m a
lookup_id TrackId
track_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map TrackId Track
state_tracks

lookup_track :: M m => TrackId -> m (Maybe Track.Track)
lookup_track :: forall (m :: * -> *). M m => TrackId -> m (Maybe Track)
lookup_track TrackId
track_id = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map TrackId Track
state_tracks)

all_track_ids :: M m => m [TrackId]
all_track_ids :: forall (m :: * -> *). M m => m [TrackId]
all_track_ids = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map TrackId Track
state_tracks)

-- | Insert the given track with the given ID.
--
-- Throw if the TrackId already exists.
create_track :: M m => Id.Id -> Track.Track -> m TrackId
create_track :: forall (m :: * -> *). M m => Id -> Track -> m TrackId
create_track Id
id Track
track =
    forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
k
-> a
-> (k -> m ())
-> (State -> Map k a)
-> (Map k a -> State -> State)
-> m k
insert (Id -> TrackId
Id.TrackId Id
id) Track
track forall (m :: * -> *). M m => TrackId -> m ()
damage_track State -> Map TrackId Track
state_tracks forall a b. (a -> b) -> a -> b
$ \Map TrackId Track
tracks State
st ->
        State
st { state_tracks :: Map TrackId Track
state_tracks = Map TrackId Track
tracks }

-- | Destroy the track and remove it from all the blocks it's in.  No-op if
-- the TrackId doesn't exist.
destroy_track :: M m => TrackId -> m ()
destroy_track :: forall (m :: * -> *). M m => TrackId -> m ()
destroy_track TrackId
track_id = do
    [(BlockId, [(TrackNum, TracklikeId)])]
blocks <- forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
blocks_with_track_id TrackId
track_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(BlockId, [(TrackNum, TracklikeId)])]
blocks forall a b. (a -> b) -> a -> b
$ \(BlockId
block_id, [(TrackNum, TracklikeId)]
tracks) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TrackNum, TracklikeId)]
tracks forall a b. (a -> b) -> a -> b
$ \(TrackNum
tracknum, TracklikeId
_) ->
        forall (m :: * -> *). M m => BlockId -> TrackNum -> m ()
remove_track BlockId
block_id TrackNum
tracknum
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_tracks :: Map TrackId Track
state_tracks = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TrackId
track_id (State -> Map TrackId Track
state_tracks State
st) }
    forall (m :: * -> *). M m => TrackId -> m ()
damage_track TrackId
track_id

get_track_title :: M m => TrackId -> m Text
get_track_title :: forall (m :: * -> *). M m => TrackId -> m Text
get_track_title = (Track -> Text
Track.track_title <$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Track
get_track

set_track_title :: M m => TrackId -> Text -> m ()
set_track_title :: forall (m :: * -> *). M m => TrackId -> Text -> m ()
set_track_title TrackId
track_id Text
text = forall (m :: * -> *). M m => TrackId -> (Text -> Text) -> m ()
modify_track_title TrackId
track_id (forall a b. a -> b -> a
const Text
text)

modify_track_title :: M m => TrackId -> (Text -> Text) -> m ()
modify_track_title :: forall (m :: * -> *). M m => TrackId -> (Text -> Text) -> m ()
modify_track_title TrackId
track_id Text -> Text
modify = do
    forall (m :: * -> *). M m => TrackId -> (Track -> Track) -> m ()
modify_track TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Track
track ->
        Track
track { track_title :: Text
Track.track_title = Text -> Text
modify (Track -> Text
Track.track_title Track
track) }
    [BlockId]
block_ids <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
blocks_with_track_id TrackId
track_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => BlockId -> m ()
update_skeleton [BlockId]
block_ids

set_track_bg :: M m => TrackId -> Color.Color -> m ()
set_track_bg :: forall (m :: * -> *). M m => TrackId -> Color -> m ()
set_track_bg TrackId
track_id Color
color = forall (m :: * -> *). M m => TrackId -> (Track -> Track) -> m ()
modify_track TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Track
track ->
    Track
track { track_bg :: Color
Track.track_bg = Color
color }

set_render_style :: M m => Track.RenderStyle -> TrackId -> m ()
set_render_style :: forall (m :: * -> *). M m => RenderStyle -> TrackId -> m ()
set_render_style RenderStyle
style TrackId
track_id = forall (m :: * -> *).
M m =>
TrackId -> (RenderConfig -> RenderConfig) -> m ()
modify_track_render TrackId
track_id forall a b. (a -> b) -> a -> b
$
    \RenderConfig
render -> RenderConfig
render { render_style :: RenderStyle
Track.render_style = RenderStyle
style }

modify_track_render :: M m => TrackId
    -> (Track.RenderConfig -> Track.RenderConfig) -> m ()
modify_track_render :: forall (m :: * -> *).
M m =>
TrackId -> (RenderConfig -> RenderConfig) -> m ()
modify_track_render TrackId
track_id RenderConfig -> RenderConfig
modify = forall (m :: * -> *). M m => TrackId -> (Track -> Track) -> m ()
modify_track TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Track
track ->
    Track
track { track_render :: RenderConfig
Track.track_render = RenderConfig -> RenderConfig
modify (Track -> RenderConfig
Track.track_render Track
track) }

modify_waveform :: M m => TrackId -> (Bool -> Bool) -> m ()
modify_waveform :: forall (m :: * -> *). M m => TrackId -> (Bool -> Bool) -> m ()
modify_waveform TrackId
track_id Bool -> Bool
modify = forall (m :: * -> *). M m => TrackId -> (Track -> Track) -> m ()
modify_track TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Track
track ->
    Track
track { track_waveform :: Bool
Track.track_waveform = Bool -> Bool
modify (Track -> Bool
Track.track_waveform Track
track) }

-- | Find @track_id@ in all the blocks it exists in, and return the track info
-- for each tracknum at which @track_id@ lives.  Blocks with no matching tracks
-- won't be returned, so the return track lists will always be non-null.
blocks_with_track_id :: M m =>
    TrackId -> m [(BlockId, [(TrackNum, Block.TracklikeId)])]
blocks_with_track_id :: forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
blocks_with_track_id TrackId
track_id =
    (TracklikeId -> Bool)
-> Map BlockId Block -> [(BlockId, [(TrackNum, TracklikeId)])]
find_tracks ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TrackId
track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracklikeId -> Maybe TrackId
Block.track_id_of) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map BlockId Block
state_blocks

-- ** events

{- There are two interpretations of a range: the strict one is that when
    start==end nothing can be selected.  A more relaxed one is that start==end
    will still select an event at start.  The relaxed one is often convenient
    for commands, so there are typically three variants of each ranged command:
    select events in the strict half-open range (functions end with _range),
    select an event at a certain point (functions use the singular), and select
    events in the relaxed half-open range (functions use the plural).
-}

-- | Insert events into track_id as per 'Events.insert'.
insert_events :: M m => TrackId -> [Event.Event] -> m ()
insert_events :: forall (m :: * -> *). M m => TrackId -> [Event] -> m ()
insert_events TrackId
track_id [Event]
events_ = forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Events
old_events ->
    ([Event] -> Events -> Events
Events.insert [Event]
events Events
old_events, [Event] -> Ranges TrackTime
events_range [Event]
events)
    where
    events :: [Event]
events = forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
clip_negative forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<TrackTime
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> TrackTime
Event.start) [Event]
events_
    clip_negative :: Event -> Event
clip_negative Event
event
        | Event -> TrackTime
Event.end Event
event forall a. Ord a => a -> a -> Bool
< TrackTime
0 = TrackTime -> Event -> Event
Event.set_end TrackTime
0 Event
event
        | Bool
otherwise = Event
event

{- | Like 'insert_events', but clip the events to the end of a block.

    This is necessarily block specific, because block duration is defined by its
    ruler.  Still, you should use this in preference to 'insert_events'.

    This uses 'block_end', which means that if events don't already go past the
    end of the ruler, they won't after this is called.  If they are already
    past (e.g. there is no ruler), then they will only be clipped if they move
    to later in time.  This might be confusing, but it seems generally
    convenient to not have to constantly manually trim events when they get
    moved past the end of the ruler, but definitely inconvenient for events to
    just disappear when there is no ruler.
-}
insert_block_events :: M m => BlockId -> TrackId -> [Event.Event] -> m ()
insert_block_events :: forall (m :: * -> *). M m => BlockId -> TrackId -> [Event] -> m ()
insert_block_events BlockId
block_id TrackId
track_id [Event]
events = do
    TrackTime
end <- forall (m :: * -> *). M m => BlockId -> m TrackTime
block_end BlockId
block_id
    -- allow_zero=True because zero-dur events at the end of a block are used
    -- for negative/final notes.
    forall (m :: * -> *). M m => TrackId -> [Event] -> m ()
insert_events TrackId
track_id (Bool -> TrackTime -> [Event] -> [Event]
Events.clip_list Bool
True TrackTime
end [Event]
events)

insert_event :: M m => TrackId -> Event.Event -> m ()
insert_event :: forall (m :: * -> *). M m => TrackId -> Event -> m ()
insert_event TrackId
track_id Event
event = forall (m :: * -> *). M m => TrackId -> [Event] -> m ()
insert_events TrackId
track_id [Event
event]

get_events :: M m => TrackId -> m Events.Events
get_events :: forall (m :: * -> *). M m => TrackId -> m Events
get_events TrackId
track_id = Track -> Events
Track.track_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m Track
get_track TrackId
track_id

-- | Modify the events on a track, and assume the entire track has been
-- damaged.
modify_events :: M m => TrackId -> (Events.Events -> Events.Events) -> m ()
modify_events :: forall (m :: * -> *). M m => TrackId -> (Events -> Events) -> m ()
modify_events TrackId
track_id Events -> Events
f = forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Events
events ->
    (Events -> Events
f Events
events, forall n. Ranges n
Ranges.everything)

modify_events_range :: M m => TrackId -> Events.Range
    -> (Events.Events -> Events.Events) -> m ()
modify_events_range :: forall (m :: * -> *).
M m =>
TrackId -> Range -> (Events -> Events) -> m ()
modify_events_range TrackId
track_id Range
range Events -> Events
modify = forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Events
events ->
    (Events -> Events
process Events
events, forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall n. n -> n -> Ranges n
Ranges.range (Range -> (TrackTime, TrackTime)
Events.range_times Range
range))
    where
    -- A range to the end should be inclusive, because I frequently have a
    -- positive event at the end.
    process :: Events -> Events
process Events
events = (Events
pre forall a. Semigroup a => a -> a -> a
<> Events -> Events
modify Events
within forall a. Semigroup a => a -> a -> a
<> Events
post)
        where (Events
pre, Events
within, Events
post) = Range -> Events -> (Events, Events, Events)
Events.split_range Range
range Events
events

modify_events_from :: M m => TrackId -> TrackTime
    -> (Events.Events -> Events.Events) -> m ()
modify_events_from :: forall (m :: * -> *).
M m =>
TrackId -> TrackTime -> (Events -> Events) -> m ()
modify_events_from TrackId
track_id TrackTime
start Events -> Events
modify = do
    Range
range <- forall (m :: * -> *). M m => TrackId -> TrackTime -> m Range
range_from TrackId
track_id TrackTime
start
    forall (m :: * -> *).
M m =>
TrackId -> Range -> (Events -> Events) -> m ()
modify_events_range TrackId
track_id Range
range Events -> Events
modify

-- | Just like 'modify_events', except that it expects you only modified a few
-- events, and will only emit damage for the changed parts.
modify_some_events :: M m => TrackId -> (Events.Events -> Events.Events)
    -> m ()
modify_some_events :: forall (m :: * -> *). M m => TrackId -> (Events -> Events) -> m ()
modify_some_events TrackId
track_id Events -> Events
f = forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Events
events ->
    let new_events :: Events
new_events = Events -> Events
f Events
events
    in (Events
new_events, Events -> Events -> Ranges TrackTime
calculate_damage Events
events Events
new_events)

calculate_damage :: Events.Events -> Events.Events -> Ranges.Ranges TrackTime
calculate_damage :: Events -> Events -> Ranges TrackTime
calculate_damage Events
old Events
new =
    forall n. Ord n => [(n, n)] -> Ranges n
Ranges.sorted_ranges forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Paired Event Event
-> [(TrackTime, TrackTime)] -> [(TrackTime, TrackTime)]
f [] forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => (a -> k) -> [a] -> [a] -> [Paired a a]
Lists.pairSortedOn1 Event -> TrackTime
Event.start
            (Events -> [Event]
Events.ascending Events
old) (Events -> [Event]
Events.ascending Events
new)
    where
    f :: Paired Event Event
-> [(TrackTime, TrackTime)] -> [(TrackTime, TrackTime)]
f (Lists.Second Event
new) [(TrackTime, TrackTime)]
ranges = Event -> (TrackTime, TrackTime)
Event.range Event
new forall a. a -> [a] -> [a]
: [(TrackTime, TrackTime)]
ranges
    f (Lists.First Event
old) [(TrackTime, TrackTime)]
ranges = Event -> (TrackTime, TrackTime)
Event.range Event
old forall a. a -> [a] -> [a]
: [(TrackTime, TrackTime)]
ranges
    f (Lists.Both Event
old Event
new) [(TrackTime, TrackTime)]
ranges
        | Event
old forall a. Eq a => a -> a -> Bool
== Event
new = [(TrackTime, TrackTime)]
ranges
        | Bool
otherwise =
            (Event -> TrackTime
Event.start Event
old, forall a. Ord a => a -> a -> a
max (Event -> TrackTime
Event.end Event
old) (Event -> TrackTime
Event.end Event
new)) forall a. a -> [a] -> [a]
: [(TrackTime, TrackTime)]
ranges

-- | Remove a single event by start and orientation.
-- TODO I think 'remove_events_range' is now just as expressive and can be just
-- as efficient
remove_event :: M m => TrackId -> Event.Event -> m ()
remove_event :: forall (m :: * -> *). M m => TrackId -> Event -> m ()
remove_event TrackId
track_id Event
event = forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id forall a b. (a -> b) -> a -> b
$ \Events
events ->
    case TrackTime -> Orientation -> Events -> Maybe Event
Events.at TrackTime
t (Event -> Orientation
Event.orientation Event
event) Events
events of
        Maybe Event
Nothing -> (Events
events, forall n. Ranges n
Ranges.nothing)
        Just Event
event ->
            ( Range -> Events -> Events
Events.remove (TrackTime -> Orientation -> Range
Events.Point TrackTime
t (Event -> Orientation
Event.orientation Event
event)) Events
events
            , [Event] -> Ranges TrackTime
events_range [Event
event]
            )
    where t :: TrackTime
t = Event -> TrackTime
Event.start Event
event

-- | Just like @mapM_ (remove_event track_id)@ but more efficient.
-- TODO at least I hope, it got sort of complicated.
remove_events :: M m => TrackId -> [Event.Event] -> m ()
remove_events :: forall (m :: * -> *). M m => TrackId -> [Event] -> m ()
remove_events TrackId
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
remove_events TrackId
track_id [Event
event] = forall (m :: * -> *). M m => TrackId -> Event -> m ()
remove_event TrackId
track_id Event
event
remove_events TrackId
track_id [Event]
events = do
    forall (m :: * -> *). M m => TrackId -> Range -> m ()
remove_events_range TrackId
track_id forall a b. (a -> b) -> a -> b
$
        TrackTime -> TrackTime -> Range
Events.Range (Event -> TrackTime
Event.min Event
first) (Event -> TrackTime
Event.max Event
last)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> Bool
Event.is_negative Event
first) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => TrackId -> Event -> m ()
remove_event TrackId
track_id Event
first
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> Bool
Event.is_positive Event
last) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => TrackId -> Event -> m ()
remove_event TrackId
track_id Event
last
    where
    -- Events is non-empty due to the pattern match above.
    Just Event
first = forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn Event -> TrackTime
Event.start [Event]
events
    Just Event
last = forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.maximumOn Event -> TrackTime
Event.start [Event]
events

remove_events_range :: M m => TrackId -> Events.Range -> m ()
remove_events_range :: forall (m :: * -> *). M m => TrackId -> Range -> m ()
remove_events_range TrackId
track_id Range
range =
    forall (m :: * -> *).
M m =>
TrackId -> Range -> (Events -> Events) -> m ()
modify_events_range TrackId
track_id Range
range (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty)

-- | Get the end of the last event of the block.
track_event_end :: M m => TrackId -> m TrackTime
track_event_end :: forall (m :: * -> *). M m => TrackId -> m TrackTime
track_event_end = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Events -> TrackTime
Events.time_end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Events
get_events

range_from :: M m => TrackId -> TrackTime -> m Events.Range
range_from :: forall (m :: * -> *). M m => TrackId -> TrackTime -> m Range
range_from TrackId
track_id TrackTime
start =
    TrackTime -> TrackTime -> Range
Events.Range TrackTime
start forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+TrackTime
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m TrackTime
track_event_end TrackId
track_id
    -- +1 to get a final 0 dur positive event.

-- ** util

-- | Don't use this to modify the events, because it won't create damage.
-- TODO should I try to protect against that?
-- TODO except now there's only one kind of track damage, so it doesn't matter
modify_track :: M m => TrackId -> (Track.Track -> Track.Track) -> m ()
modify_track :: forall (m :: * -> *). M m => TrackId -> (Track -> Track) -> m ()
modify_track TrackId
track_id Track -> Track
f = do
    forall (m :: * -> *). M m => TrackId -> m Track
get_track TrackId
track_id -- Throw if track_id doesn't exist.
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_tracks :: Map TrackId Track
state_tracks = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Track -> Track
f TrackId
track_id (State -> Map TrackId Track
state_tracks State
st) }
    forall (m :: * -> *). M m => TrackId -> m ()
damage_track TrackId
track_id

-- | Low level modify events.  The function can modify Events however it
-- pleases, but should return Ranges indicating where the modification
-- happened.  This must be done manually, and there is no enforcement, but if
-- you get it wrong, 'Update.UiDamage' will be wrong, which will mess up UI
-- updates, undo, rederivation, etc.
--
-- TODO could figure this out automatically if Events supported efficient diff.
_modify_events :: M m => TrackId
    -> (Events.Events -> (Events.Events, Ranges.Ranges TrackTime))
    -> m ()
_modify_events :: forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id Events -> (Events, Ranges TrackTime)
f = do
    Track
track <- forall (m :: * -> *). M m => TrackId -> m Track
get_track TrackId
track_id
    let (Events
new_events, Ranges TrackTime
ranges) = Events -> (Events, Ranges TrackTime)
f (Track -> Events
Track.track_events Track
track)
        new_track :: Track
new_track = Track
track { track_events :: Events
Track.track_events = Events
new_events }
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_tracks :: Map TrackId Track
state_tracks = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TrackId
track_id Track
new_track (State -> Map TrackId Track
state_tracks State
st) }
    -- Force out whatever transformations might be in the new events.  The
    -- main reason is to force out any IO exceptions that might be hiding in
    -- REPL expressions, but it seems better for memory in general to keep
    -- State in normal form.
    forall a b. NFData a => a -> b -> b
DeepSeq.deepseq Events
new_events forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => UiDamage -> m ()
damage forall a b. (a -> b) -> a -> b
$ TrackId -> Ranges TrackTime -> UiDamage
Update.track_damage TrackId
track_id Ranges TrackTime
ranges

events_range :: [Event.Event] -> Ranges.Ranges TrackTime
events_range :: [Event] -> Ranges TrackTime
events_range [Event]
events = case [Event] -> Maybe (TrackTime, TrackTime)
minmax [Event]
events of
    Just (TrackTime
emin, TrackTime
emax) -> forall n. n -> n -> Ranges n
Ranges.range TrackTime
emin TrackTime
emax
    Maybe (TrackTime, TrackTime)
Nothing -> forall n. Ranges n
Ranges.nothing
    where
    minmax :: [Event] -> Maybe (TrackTime, TrackTime)
minmax (Event
e:[Event]
es) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TrackTime -> TrackTime -> [Event] -> (TrackTime, TrackTime)
go (Event -> TrackTime
Event.min Event
e) (Event -> TrackTime
Event.max Event
e) [Event]
es
    minmax [] = forall a. Maybe a
Nothing
    go :: TrackTime -> TrackTime -> [Event] -> (TrackTime, TrackTime)
go !TrackTime
emin !TrackTime
emax (Event
e:[Event]
es) =
        TrackTime -> TrackTime -> [Event] -> (TrackTime, TrackTime)
go (forall a. Ord a => a -> a -> a
min TrackTime
emin (Event -> TrackTime
Event.min Event
e)) (forall a. Ord a => a -> a -> a
max TrackTime
emax (Event -> TrackTime
Event.max Event
e)) [Event]
es
    go TrackTime
emin TrackTime
emax [] = (TrackTime
emin, TrackTime
emax)

-- * ruler

get_ruler :: M m => RulerId -> m Ruler.Ruler
get_ruler :: forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
ruler_id
    | RulerId
ruler_id forall a. Eq a => a -> a -> Bool
== RulerId
no_ruler = forall (m :: * -> *) a. Monad m => a -> m a
return Ruler
Ruler.empty
    | Bool
otherwise = forall (m :: * -> *). M m => m State
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k (m :: * -> *) a.
(Stack, Ord k, Show k, M m) =>
k -> Map k a -> m a
lookup_id RulerId
ruler_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map RulerId Ruler
state_rulers

lookup_ruler :: M m => RulerId -> m (Maybe Ruler.Ruler)
lookup_ruler :: forall (m :: * -> *). M m => RulerId -> m (Maybe Ruler)
lookup_ruler RulerId
ruler_id = forall (m :: * -> *). M m => m State
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RulerId
ruler_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map RulerId Ruler
state_rulers

all_ruler_ids :: M m => m [RulerId]
all_ruler_ids :: forall (m :: * -> *). M m => m [RulerId]
all_ruler_ids = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map RulerId Ruler
state_rulers)

-- | Insert the given ruler with the given ID.
--
-- Throw if the RulerId already exists.
create_ruler :: M m => Id.Id -> Ruler.Ruler -> m RulerId
create_ruler :: forall (m :: * -> *). M m => Id -> Ruler -> m RulerId
create_ruler Id
id Ruler
ruler
    -- no_ruler is global and assumed to always exist.
    | Id
id forall a. Eq a => a -> a -> Bool
== forall a. Ident a => a -> Id
Id.unpack_id RulerId
no_ruler = forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw Text
"can't insert no-ruler"
    | Bool
otherwise = forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
k
-> a
-> (k -> m ())
-> (State -> Map k a)
-> (Map k a -> State -> State)
-> m k
insert (Id -> RulerId
Id.RulerId Id
id) Ruler
ruler forall (m :: * -> *). M m => RulerId -> m ()
damage_ruler State -> Map RulerId Ruler
state_rulers forall a b. (a -> b) -> a -> b
$
        \Map RulerId Ruler
rulers State
st -> State
st { state_rulers :: Map RulerId Ruler
state_rulers = Map RulerId Ruler
rulers }

-- | Destroy the ruler and remove it from all the blocks it's in.
destroy_ruler :: M m => RulerId -> m ()
destroy_ruler :: forall (m :: * -> *). M m => RulerId -> m ()
destroy_ruler RulerId
ruler_id = do
    [(BlockId, [(TrackNum, TracklikeId)])]
blocks <- forall (m :: * -> *).
M m =>
RulerId -> m [(BlockId, [(TrackNum, TracklikeId)])]
blocks_with_ruler_id RulerId
ruler_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(BlockId, [(TrackNum, TracklikeId)])]
blocks forall a b. (a -> b) -> a -> b
$ \(BlockId
block_id, [(TrackNum, TracklikeId)]
tracks) -> do
        let tracknums :: [TrackNum]
tracknums = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TrackNum, TracklikeId)]
tracks
            setr :: TrackNum -> TracklikeId -> TracklikeId
setr TrackNum
i = if TrackNum
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackNum]
tracknums
                then RulerId -> TracklikeId -> TracklikeId
Block.set_ruler_id RulerId
no_ruler else forall a. a -> a
id
            deruler :: (TrackNum, Track) -> Track
deruler (TrackNum
i, Track
track) = (TracklikeId -> TracklikeId) -> Track -> Track
Block.modify_id (TrackNum -> TracklikeId -> TracklikeId
setr TrackNum
i) Track
track
        forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block { block_tracks :: [Track]
Block.block_tracks =
            forall a b. (a -> b) -> [a] -> [b]
map (TrackNum, Track) -> Track
deruler (forall a. [a] -> [(TrackNum, a)]
Lists.enumerate (Block -> [Track]
Block.block_tracks Block
block)) }
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_rulers :: Map RulerId Ruler
state_rulers = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete RulerId
ruler_id (State -> Map RulerId Ruler
state_rulers State
st) }
    forall (m :: * -> *). M m => RulerId -> m ()
damage_ruler RulerId
ruler_id

modify_ruler :: M m => RulerId -> (Ruler.Ruler -> Either Text Ruler.Ruler)
    -> m ()
modify_ruler :: forall (m :: * -> *).
M m =>
RulerId -> (Ruler -> Either Text Ruler) -> m ()
modify_ruler RulerId
ruler_id Ruler -> Either Text Ruler
modify = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RulerId
ruler_id forall a. Eq a => a -> a -> Bool
== RulerId
no_ruler) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw Text
"can't modify no_ruler"
    Ruler
ruler <- forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
ruler_id
    let msg :: Text
msg = Text
"modify_ruler " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RulerId
ruler_id forall a. Semigroup a => a -> a -> a
<> Text
": "
    Ruler
modified <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
require_right (Text
msg<>) forall a b. (a -> b) -> a -> b
$ Ruler -> Either Text Ruler
modify Ruler
ruler
    forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_rulers :: Map RulerId Ruler
state_rulers = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RulerId
ruler_id Ruler
modified (State -> Map RulerId Ruler
state_rulers State
st) }
    forall (m :: * -> *). M m => RulerId -> m ()
damage_ruler RulerId
ruler_id

ruler_of :: M m => BlockId -> m RulerId
ruler_of :: forall (m :: * -> *). M m => BlockId -> m RulerId
ruler_of BlockId
block_id = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"no ruler 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 a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [RulerId]
Block.block_ruler_ids forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id

rulers_of :: M m => BlockId -> m [RulerId]
rulers_of :: forall (m :: * -> *). M m => BlockId -> m [RulerId]
rulers_of BlockId
block_id = forall a. Ord a => [a] -> [a]
Lists.unique forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [RulerId]
Block.block_ruler_ids forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id

-- | Just like 'blocks_with_track_id' except for ruler_id.
blocks_with_ruler_id :: M m =>
    RulerId -> m [(BlockId, [(TrackNum, Block.TracklikeId)])]
blocks_with_ruler_id :: forall (m :: * -> *).
M m =>
RulerId -> m [(BlockId, [(TrackNum, TracklikeId)])]
blocks_with_ruler_id RulerId
ruler_id =
    (TracklikeId -> Bool)
-> Map BlockId Block -> [(BlockId, [(TrackNum, TracklikeId)])]
find_tracks ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just RulerId
ruler_id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracklikeId -> Maybe RulerId
Block.ruler_id_of) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map BlockId Block
state_blocks

-- | Since all TracklikeIds must have a ruler, all States have a special empty
-- ruler that can be used in a \"no ruler\" situation.
--
-- This RulerId is implicitly present in every block.  It's not actually in
-- 'state_rulers' to avoid it getting renamed or deleted, but 'get_ruler' will
-- pretend it exists.  As long as everyone that cares about no_ruler (which is
-- only 'verify' and 'get_tracklike' for "Ui.Sync") uses 'get_ruler' then
-- they won't be confused by tracks that have no_ruler.
no_ruler :: RulerId
no_ruler :: RulerId
no_ruler = Id -> RulerId
Id.RulerId (Text -> Id
Id.global Text
"-no-ruler-")


-- * util

find_tracks :: (Block.TracklikeId -> Bool) -> Map BlockId Block.Block
    -> [(BlockId, [(TrackNum, Block.TracklikeId)])]
find_tracks :: (TracklikeId -> Bool)
-> Map BlockId Block -> [(BlockId, [(TrackNum, TracklikeId)])]
find_tracks TracklikeId -> Bool
f Map BlockId Block
blocks = do
    (BlockId
bid, Block
b) <- forall k a. Map k a -> [(k, a)]
Map.assocs Map BlockId Block
blocks
    let tracks :: [(TrackNum, TracklikeId)]
tracks = Block -> [(TrackNum, TracklikeId)]
get_tracks Block
b
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TrackNum, TracklikeId)]
tracks))
    forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
bid, [(TrackNum, TracklikeId)]
tracks)
    where
    all_tracks :: Block -> [(TrackNum, Track)]
all_tracks Block
block = forall a. [a] -> [(TrackNum, a)]
Lists.enumerate (Block -> [Track]
Block.block_tracks Block
block)
    get_tracks :: Block -> [(TrackNum, TracklikeId)]
get_tracks Block
block =
        [ (TrackNum
tracknum, Track -> TracklikeId
Block.tracklike_id Track
track)
        | (TrackNum
tracknum, Track
track) <- Block -> [(TrackNum, Track)]
all_tracks Block
block, TracklikeId -> Bool
f (Track -> TracklikeId
Block.tracklike_id Track
track)
        ]

-- | Lookup @map!key@, throwing if it doesn't exist.
lookup_id :: (CallStack.Stack, Ord k, Show k, M m) => k -> Map k a -> m a
lookup_id :: forall k (m :: * -> *) a.
(Stack, Ord k, Show k, M m) =>
k -> Map k a -> m a
lookup_id k
key Map k a
map = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
key Map k a
map of
    Maybe a
Nothing -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"State.lookup: unknown " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt k
key
    Just a
val -> forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- | Insert @val@ at @key@ in @get_map state@, throwing if it already exists.
-- Put the map back into @state@ by applying @set_map new_map state@ to it.
insert :: (M m, Ord k, Show k)
    => k -> a
    -> (k -> m ())
    -> (State -> Map k a)
    -> (Map k a -> State -> State)
    -> m k
insert :: forall (m :: * -> *) k a.
(M m, Ord k, Show k) =>
k
-> a
-> (k -> m ())
-> (State -> Map k a)
-> (Map k a -> State -> State)
-> m k
insert k
key a
val k -> m ()
updated State -> Map k a
get_map Map k a -> State -> State
set_map = do
    State
state <- forall (m :: * -> *). M m => m State
get
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (k
key forall k a. Ord k => k -> Map k a -> Bool
`Map.member` State -> Map k a
get_map State
state) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showt k
key forall a. Semigroup a => a -> a -> a
<> Text
" already exists"
    forall (m :: * -> *). M m => State -> m ()
unsafe_put (Map k a -> State -> State
set_map (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
key a
val (State -> Map k a
get_map State
state)) State
state)
    k -> m ()
updated k
key
    forall (m :: * -> *) a. Monad m => a -> m a
return k
key

-- | Modify the @i@th element of @xs@ by applying @f@ to it.
modify_at :: M m => Text -> [a] -> Int -> (a -> a) -> m [a]
modify_at :: forall (m :: * -> *) a.
M m =>
Text -> [a] -> TrackNum -> (a -> a) -> m [a]
modify_at Text
msg [a]
xs TrackNum
i a -> a
f = case [a]
post of
    [] -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
msg forall a. Semigroup a => a -> a -> a
<> Text
": can't replace index " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
i
        forall a. Semigroup a => a -> a -> a
<> Text
" of list with length " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [a]
xs)
    (a
elt:[a]
rest) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
pre forall a. [a] -> [a] -> [a]
++ a -> a
f a
elt forall a. a -> [a] -> [a]
: [a]
rest)
    where ([a]
pre, [a]
post) = forall a. TrackNum -> [a] -> ([a], [a])
splitAt TrackNum
i [a]
xs

{-
-- | Modify the @i@th element of @xs@ by applying @f@ to it.
--
-- As an optimization, this returns Nothing if the modification had no effect.
-- This assumes that comparing before and after is cheaper than going through
-- with the modification.  I don't know if it is.  Probably it doesn't matter.
modify_at :: (M m, Eq a) => Text -> [a] -> Int -> (a -> a) -> m (Maybe [a])
modify_at msg xs i f = case post of
    [] -> throw $ msg <> ": can't replace index " <> showt i
        <> " of list with length " <> showt (length xs)
    elt : rest
        | elt == after -> return Nothing
        | otherwise -> return $ Just $ pre ++ after : rest
        where after = f elt
    where (pre, post) = splitAt i xs
-}

-- * verify

-- | Run a @fix_*@ function, and throw an error if it found problems.
require_valid :: M m => Text -> StateId [Text] -> m ()
require_valid :: forall (m :: * -> *). M m => Text -> StateId [Text] -> m ()
require_valid Text
caller StateId [Text]
verify = do
    State
state <- forall (m :: * -> *). M m => m State
get
    case forall a. State -> StateId a -> Either Error (a, State, UiDamage)
run_id State
state StateId [Text]
verify of
        Left Error
err -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": error validating: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Error
err
        Right ([Text]
errs, State
state, UiDamage
_)
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise -> do
                -- The exception should cause the state to be rolled back, but
                -- I might as well not let a known broken state stick around.
                forall (m :: * -> *). M m => State -> m ()
put State
state
                forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": aborted due to validation actions: "
                    forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"; " [Text]
errs

-- | Unfortunately there are some invariants to protect within State.
-- They can all be fixed by dropping things, so this will fix them and return
-- a list of warnings.
verify :: State -> (State, [Text])
verify :: State -> (State, [Text])
verify State
state = case forall a. State -> StateId a -> Either Error (a, State, UiDamage)
run_id State
state forall (m :: * -> *). M m => m [Text]
fix_state of
    Left Error
err -> (State
state, [Text
"exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Error
err])
    Right ([Text]
errs, State
state, UiDamage
_) -> (State
state, [Text]
errs)

-- | This is like 'verify', but less complete.  It returns Left if it wants
-- you to reject the new state entirely.
--
-- 'verify' is better, but more expensive, so I'm reluctant to run it on every
-- single cmd.  If I run 'verify' before unsafe puts and trust this module to
-- maintain invariants then I don't need to, but I don't fully trust this
-- module.
--
-- TODO a better approach would be to make sure Sync can't be broken by State.
quick_verify :: Update.UiDamage -> State -> Either String (State, [Text])
quick_verify :: UiDamage -> State -> Either String (State, [Text])
quick_verify UiDamage
damage State
state = case forall a. State -> StateId a -> Either Error (a, State, UiDamage)
run_id State
state StateId [Text]
quick_fix of
    Left Error
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
prettys Error
err
    Right ([Text]
errs, State
state, UiDamage
_) -> forall a b. b -> Either a b
Right (State
state, [Text]
errs)
    where
    quick_fix :: StateId [Text]
quick_fix = do
        State
st <- forall (m :: * -> *). M m => m State
get
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *}. M m => Block -> m ()
verify_block forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (State -> Map BlockId Block
state_blocks State
st) (UiDamage -> Set BlockId
Update._blocks UiDamage
damage)
        -- Disappearing views can happen if you undo past a block rename.
        -- In that case I should track the rename rather than disappearing
        -- the view, but in any case I don't want dangling ViewIds and
        -- disappearing the view is relatively harmless.
        forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *). M m => ViewId -> View -> m [Text]
verify_view) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (State -> Map ViewId View
state_views State
st) (UiDamage -> Set ViewId
Update._views UiDamage
damage)
    verify_block :: Block -> m ()
verify_block Block
block = do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => TrackId -> m Track
get_track (Block -> [TrackId]
Block.block_track_ids Block
block)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler (Block -> [RulerId]
Block.block_ruler_ids Block
block)

fix_state :: M m => m [Text]
fix_state :: forall (m :: * -> *). M m => m [Text]
fix_state = do
    [(ViewId, View)]
views <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
state_views)
    [Text]
view_errs <- forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *). M m => ViewId -> View -> m [Text]
verify_view) [(ViewId, View)]
views
    [(BlockId, Block)]
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
state_blocks)
    [Text]
block_errs <- forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_block) [(BlockId, Block)]
blocks
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text]
view_errs forall a. [a] -> [a] -> [a]
++ [Text]
block_errs

-- | Drop views with invalid BlockIds.
verify_view :: M m => ViewId -> Block.View -> m [Text]
verify_view :: forall (m :: * -> *). M m => ViewId -> View -> m [Text]
verify_view ViewId
view_id View
view = do
    Maybe Block
block <- forall (m :: * -> *). M m => BlockId -> m (Maybe Block)
lookup_block (View -> BlockId
Block.view_block View
view)
    case Maybe Block
block of
        Just Block
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Maybe Block
Nothing -> do
            forall (m :: * -> *). M m => ViewId -> m ()
destroy_view ViewId
view_id
            forall (m :: * -> *) a. Monad m => a -> m a
return [forall a. Show a => a -> Text
showt ViewId
view_id forall a. Semigroup a => a -> a -> a
<> Text
": dropped because of invalid "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (View -> BlockId
Block.view_block View
view)]

fix_block :: M m => BlockId -> Block.Block -> m [Text]
fix_block :: forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_block BlockId
block_id Block
block =
    forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Show a => a -> Text
showt BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_track_ids BlockId
block_id Block
block
        , forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
unique_track_ids BlockId
block_id Block
block
        , forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_ruler_ids BlockId
block_id Block
block
        , forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_skeleton BlockId
block_id Block
block
        , forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (forall (m :: * -> *).
M m =>
BlockId -> (TrackNum, Track) -> m [Text]
fix_merged BlockId
block_id) [(TrackNum, Track)]
tracks
        , forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_block BlockId
block_id Block
block
        , forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_tracks BlockId
block_id Block
block
        ]
    where tracks :: [(TrackNum, Track)]
tracks = forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] (Block -> [Track]
Block.block_tracks Block
block)

-- | Drop invalid track ids.
fix_track_ids :: M m => BlockId -> Block.Block -> m [Text]
fix_track_ids :: forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_track_ids BlockId
block_id Block
block = do
    Map TrackId Track
all_track_ids <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map TrackId Track
state_tracks
    let is_valid :: TrackId -> Bool
is_valid = (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TrackId Track
all_track_ids)
    let invalid :: [(TrackNum, TrackId)]
invalid = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackId -> Bool
is_valid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (Block -> [(TrackNum, TrackId)]
block_event_tracknums Block
block)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => BlockId -> TrackNum -> m ()
remove_track BlockId
block_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(TrackNum, TrackId)]
invalid
    forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"tracknum " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
tracknum forall a. Semigroup a => a -> a -> a
<> Text
": dropped invalid "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
track_id | (TrackNum
tracknum, TrackId
track_id) <- [(TrackNum, TrackId)]
invalid]

-- | Replace invalid ruler ids with no_ruler.
fix_ruler_ids :: M m => BlockId -> Block.Block -> m [Text]
fix_ruler_ids :: forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_ruler_ids BlockId
_block_id Block
_block = forall (m :: * -> *) a. Monad m => a -> m a
return [] -- TODO

-- | Each TrackId of a block is unique.
unique_track_ids :: M m => BlockId -> Block.Block -> m [Text]
unique_track_ids :: forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
unique_track_ids BlockId
block_id Block
block = do
    let invalid :: [(TrackNum, TrackId)]
invalid = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => (a -> k) -> [a] -> ([a], [(a, [a])])
Lists.partitionDups forall a b. (a, b) -> b
snd (Block -> [(TrackNum, TrackId)]
block_event_tracknums Block
block)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => BlockId -> TrackNum -> m ()
remove_track BlockId
block_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(TrackNum, TrackId)]
invalid
    forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"tracknum " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
tracknum forall a. Semigroup a => a -> a -> a
<> Text
": dropped duplicate "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
track_id | (TrackNum
tracknum, TrackId
track_id) <- [(TrackNum, TrackId)]
invalid]

-- | Skeleton tracknums in range.
fix_skeleton :: M m => BlockId -> Block.Block -> m [Text]
fix_skeleton :: forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_skeleton BlockId
_block_id Block
_block = forall (m :: * -> *) a. Monad m => a -> m a
return [] -- TODO

-- | Strip invalid Block.track_merged.
fix_merged :: M m => BlockId -> (TrackNum, Block.Track) -> m [Text]
fix_merged :: forall (m :: * -> *).
M m =>
BlockId -> (TrackNum, Track) -> m [Text]
fix_merged BlockId
block_id (TrackNum
tracknum, Track
track) = do
    Map TrackId Track
all_track_ids <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map TrackId Track
state_tracks
    let is_valid :: TrackId -> Bool
is_valid = (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TrackId Track
all_track_ids)
    let (Set TrackId
valid, Set TrackId
invalid) = forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition TrackId -> Bool
is_valid (Track -> Set TrackId
Block.track_merged Track
track)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Bool
Set.null Set TrackId
invalid) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum
            (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Track
track { track_merged :: Set TrackId
Block.track_merged = Set TrackId
valid })
    forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"tracknum " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackNum
tracknum forall a. Semigroup a => a -> a -> a
<> Text
": stripped invalid merged "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
track_id | TrackId
track_id <- forall a. Set a -> [a]
Set.toList Set TrackId
invalid]

-- | Drop block_integrated if the source BlockId doesn't exist, and strip out
-- TrackDestinations whose TrackIds aren't in this block.
-- 'Event.clear_integration' on any events that no longer have a source.
fix_integrated_block :: M m => BlockId -> Block.Block -> m [Text]
fix_integrated_block :: forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_block BlockId
block_id Block
block = do
    Map BlockId Block
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map BlockId Block
state_blocks
    let (Bool
source_gone, Maybe (BlockId, TrackDestinations)
integrated, [Text]
errs) =
            forall {a}.
(Ord a, Show a) =>
Map a Block
-> Maybe (a, TrackDestinations)
-> (Bool, Maybe (a, TrackDestinations), [Text])
fix Map BlockId Block
blocks (Block -> Maybe (BlockId, TrackDestinations)
Block.block_integrated Block
block)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block
            { block_integrated :: Maybe (BlockId, TrackDestinations)
Block.block_integrated = Maybe (BlockId, TrackDestinations)
integrated }
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
source_gone forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => TrackId -> m ()
clear_integration (Block -> [TrackId]
Block.block_track_ids Block
block)
    forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
errs
    where
    track_ids :: [TrackId]
track_ids = Block -> [TrackId]
Block.block_track_ids Block
block
    fix :: Map a Block
-> Maybe (a, TrackDestinations)
-> (Bool, Maybe (a, TrackDestinations), [Text])
fix Map a Block
_ Maybe (a, TrackDestinations)
Nothing = (Bool
False, forall a. Maybe a
Nothing, [])
    fix Map a Block
blocks (Just (a
source_id, TrackDestinations
dests)) = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
source_id Map a Block
blocks of
        Maybe Block
Nothing ->
            ( Bool
True
            , forall a. Maybe a
Nothing
            , [Text
"removed invalid integrated block: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
source_id]
            )
        Just Block
source -> (Bool
False, forall a. a -> Maybe a
Just (a
source_id, TrackDestinations
valid), [Text]
errs)
            where
            (TrackDestinations
valid, [Text]
errs) = Text
-> [TrackId]
-> [TrackId]
-> TrackDestinations
-> (TrackDestinations, [Text])
fix_track_destinations
                (Text
"block of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
source_id)
                (Block -> [TrackId]
Block.block_track_ids Block
source) [TrackId]
track_ids TrackDestinations
dests

-- | Drop integrated tracks whose source TrackId isn't in this block, and
-- TrackDestinations whose TrackIds aren't in this block.
-- 'Event.clear_integration' on any events that no longer have a source.
--
-- TODO
-- - No TrackIds duplicated between DeriveDestinations.
-- - No TrackIds duplicated across integrated tracks.
fix_integrated_tracks :: M m => BlockId -> Block.Block -> m [Text]
fix_integrated_tracks :: forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_tracks BlockId
block_id Block
block = do
    let gone :: [TrackId]
gone = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ TrackDestinations -> [TrackId]
Block.dest_track_ids TrackDestinations
dests
            | (TrackId
track_id, TrackDestinations
dests) <- Block -> [(TrackId, TrackDestinations)]
Block.block_integrated_tracks Block
block
            , TrackId
track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TrackId]
track_ids
            ]
    let ([(TrackId, TrackDestinations)]
dests, [Text]
errs) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. [Maybe a] -> [a]
Maybe.catMaybes forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map (TrackId, TrackDestinations)
-> (Maybe (TrackId, TrackDestinations), [Text])
fix (Block -> [(TrackId, TrackDestinations)]
Block.block_integrated_tracks Block
block)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block
            { block_integrated_tracks :: [(TrackId, TrackDestinations)]
Block.block_integrated_tracks = [(TrackId, TrackDestinations)]
dests }
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => TrackId -> m ()
clear_integration [TrackId]
gone
    forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
errs
    where
    track_ids :: [TrackId]
track_ids = Block -> [TrackId]
Block.block_track_ids Block
block
    fix :: (TrackId, TrackDestinations)
-> (Maybe (TrackId, TrackDestinations), [Text])
fix (TrackId
track_id, TrackDestinations
dests)
        | TrackId
track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TrackId]
track_ids =
            (forall a. Maybe a
Nothing, [Text
"removed invalid integrated track: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
track_id])
        | Bool
otherwise = (forall a. a -> Maybe a
Just (TrackId
track_id, TrackDestinations
valid), [Text]
errs)
        where
        (TrackDestinations
valid, [Text]
errs) = Text
-> [TrackId]
-> [TrackId]
-> TrackDestinations
-> (TrackDestinations, [Text])
fix_track_destinations (Text
"track of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
track_id)
            [TrackId]
track_ids [TrackId]
track_ids TrackDestinations
dests

fix_track_destinations :: Text -> [TrackId] -> [TrackId]
    -> Block.TrackDestinations -> (Block.TrackDestinations, [Text])
fix_track_destinations :: Text
-> [TrackId]
-> [TrackId]
-> TrackDestinations
-> (TrackDestinations, [Text])
fix_track_destinations Text
err_msg [TrackId]
source_track_ids [TrackId]
track_ids TrackDestinations
d = case TrackDestinations
d of
    Block.DeriveDestinations [NoteDestination]
dests ->
        ( [NoteDestination] -> TrackDestinations
Block.DeriveDestinations [NoteDestination]
valid
        , forall {a}. Pretty a => [a] -> [Text]
errs (forall a b. (a -> b) -> [a] -> [b]
map NoteDestination -> [TrackId]
Block.note_dest_track_ids [NoteDestination]
invalid)
        )
        where ([NoteDestination]
valid, [NoteDestination]
invalid) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition NoteDestination -> Bool
derive_valid [NoteDestination]
dests
    Block.ScoreDestinations ScoreDestinations
dests ->
        (ScoreDestinations -> TrackDestinations
Block.ScoreDestinations ScoreDestinations
valid, forall {a}. Pretty a => [a] -> [Text]
errs (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {b}. (a, (b, b)) -> (a, b)
score_track_ids ScoreDestinations
invalid))
        where (ScoreDestinations
valid, ScoreDestinations
invalid) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition forall {b}. (TrackId, (TrackId, b)) -> Bool
score_valid ScoreDestinations
dests
    where
    errs :: [a] -> [Text]
errs [a]
invalid = [Text
"integrated " forall a. Semigroup a => a -> a -> a
<> Text
err_msg
        forall a. Semigroup a => a -> a -> a
<> Text
": track destination has track ids not in the right block: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
dest | a
dest <- [a]
invalid]
    score_track_ids :: (a, (b, b)) -> (a, b)
score_track_ids (a
source_id, (b
dest_id, b
_)) = (a
source_id, b
dest_id)
    derive_valid :: NoteDestination -> Bool
derive_valid = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackId]
track_ids) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDestination -> [TrackId]
Block.note_dest_track_ids
    score_valid :: (TrackId, (TrackId, b)) -> Bool
score_valid (TrackId
source_id, (TrackId
dest_id, b
_index)) =
        TrackId
source_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackId]
source_track_ids Bool -> Bool -> Bool
&& TrackId
dest_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackId]
track_ids

clear_integration :: M m => TrackId -> m ()
clear_integration :: forall (m :: * -> *). M m => TrackId -> m ()
clear_integration TrackId
track_id = forall (m :: * -> *). M m => TrackId -> (Events -> Events) -> m ()
modify_events TrackId
track_id forall a b. (a -> b) -> a -> b
$
    (Event -> Event) -> Events -> Events
Events.map_events Event -> Event
Event.clear_integration

block_event_tracknums :: Block.Block -> [(TrackNum, TrackId)]
block_event_tracknums :: Block -> [(TrackNum, TrackId)]
block_event_tracknums Block
block =
    [(TrackNum
tracknum, TrackId
track_id) | (TrackNum
tracknum, Just TrackId
track_id) <- forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] [Maybe TrackId]
track_ids]
    where track_ids :: [Maybe TrackId]
track_ids = forall a b. (a -> b) -> [a] -> [b]
map Track -> Maybe TrackId
Block.track_id (Block -> [Track]
Block.block_tracks Block
block)

-- * IDs

-- | Read an ID of the form \"namespace/name\", or just \"name\", filling in
-- the current namespace if it's not present.
read_id :: (CallStack.Stack, Id.Ident a, M m) => Text -> m a
read_id :: forall a (m :: * -> *). (Stack, Ident a, M m) => Text -> m a
read_id Text
name = do
    Namespace
ns <- forall (m :: * -> *). M m => m Namespace
get_namespace
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"invalid characters in id name: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
name) forall a b. (a -> b) -> a -> b
$
        forall a. Ident a => Id -> Maybe a
Id.make forall a b. (a -> b) -> a -> b
$ Namespace -> Text -> Id
Id.id Namespace
ns Text
name

namespace :: M m => Text -> m Id.Namespace
namespace :: forall (m :: * -> *). M m => Text -> m Namespace
namespace Text
ns = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Id.valid_symbol Text
ns) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall a b. (a -> b) -> a -> b
$ Text
"invalid characters in namespace: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
ns
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Namespace
Id.namespace Text
ns

-- * damage

damage_view :: M m => ViewId -> m ()
damage_view :: forall (m :: * -> *). M m => ViewId -> m ()
damage_view = forall (m :: * -> *). M m => UiDamage -> m ()
damage forall b c a. (b -> c) -> (a -> b) -> a -> c
. ViewId -> UiDamage
Update.view_damage

damage_block :: M m => BlockId -> m ()
damage_block :: forall (m :: * -> *). M m => BlockId -> m ()
damage_block = forall (m :: * -> *). M m => UiDamage -> m ()
damage forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> UiDamage
Update.block_damage

damage_track :: M m => TrackId -> m ()
damage_track :: forall (m :: * -> *). M m => TrackId -> m ()
damage_track TrackId
track_id = forall (m :: * -> *). M m => UiDamage -> m ()
damage forall a b. (a -> b) -> a -> b
$ TrackId -> Ranges TrackTime -> UiDamage
Update.track_damage TrackId
track_id forall n. Ranges n
Ranges.everything

damage_ruler :: M m => RulerId -> m ()
damage_ruler :: forall (m :: * -> *). M m => RulerId -> m ()
damage_ruler = forall (m :: * -> *). M m => UiDamage -> m ()
damage forall b c a. (b -> c) -> (a -> b) -> a -> c
. RulerId -> UiDamage
Update.ruler_damage

damage_score :: M m => m ()
damage_score :: forall (m :: * -> *). M m => m ()
damage_score = forall (m :: * -> *). M m => UiDamage -> m ()
damage forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty { _score_damage :: Bool
Update._score_damage = Bool
True }