-- 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.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Ranges as Ranges
import qualified Util.Rect as Rect
import qualified Util.Seq as Seq

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
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
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
(TrackNum -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
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 = (State -> Map ViewId View)
-> ((Map ViewId View -> Map ViewId View) -> State -> State)
-> Lens State (Map ViewId View)
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 = (State -> Map BlockId Block)
-> ((Map BlockId Block -> Map BlockId Block) -> State -> State)
-> Lens State (Map BlockId Block)
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 = (State -> Map TrackId Track)
-> ((Map TrackId Track -> Map TrackId Track) -> State -> State)
-> Lens State (Map TrackId Track)
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 = (State -> Map RulerId Ruler)
-> ((Map RulerId Ruler -> Map RulerId Ruler) -> State -> State)
-> Lens State (Map RulerId Ruler)
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 = (State -> Config)
-> ((Config -> Config) -> State -> State) -> Lens State 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 = Map ViewId View
forall k a. Map k a
Map.empty
    , state_blocks :: Map BlockId Block
state_blocks = Map BlockId Block
forall k a. Map k a
Map.empty
    , state_tracks :: Map TrackId Track
state_tracks = Map TrackId Track
forall k a. Map k a
Map.empty
    , state_rulers :: Map RulerId Ruler
state_rulers = Map RulerId Ruler
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
    State -> IO State
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> IO State) -> State -> IO State
forall a b. (a -> b) -> a -> b
$ (Lens State Config
configLens State Config -> Lens Config UTCTime -> Lens State UTCTime
forall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Meta
UiConfig.meta(Config :-> Meta) -> Lens Meta UTCTime -> Lens Config UTCTime
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Meta UTCTime
UiConfig.creation Lens State UTCTime -> UTCTime -> State -> State
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 = (View -> View) -> Map ViewId View -> Map ViewId View
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 = Map (TrackNum, Text) Text
forall a. Monoid a => a
mempty
        , view_selections :: Map TrackNum Selection
Block.view_selections =
            -- Non-insert selections indicate ephemeral state.
            Map TrackNum Selection
-> (Selection -> Map TrackNum Selection)
-> Maybe Selection
-> Map TrackNum Selection
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map TrackNum Selection
forall a. Monoid a => a
mempty (TrackNum -> Selection -> Map TrackNum Selection
forall k a. k -> a -> Map k a
Map.singleton TrackNum
Config.insert_selnum) (Maybe Selection -> Map TrackNum Selection)
-> Maybe Selection -> Map TrackNum Selection
forall a b. (a -> b) -> a -> b
$
                TrackNum -> Map TrackNum Selection -> Maybe Selection
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", Map ViewId View -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map ViewId View
views)
        , (Text
"blocks", Map BlockId Block -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map BlockId Block
blocks)
        , (Text
"tracks", Map TrackId Track -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map TrackId Track
tracks)
        , (Text
"rulers", Map RulerId Ruler -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map RulerId Ruler
rulers)
        , (Text
"config", Config -> Doc
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) =
        Map ViewId View -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf Map ViewId View
views () -> () -> ()
`seq` Map BlockId Block -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf Map BlockId Block
blocks
        () -> () -> ()
`seq` Map TrackId Track -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf Map TrackId Track
tracks () -> () -> ()
`seq` Map RulerId Ruler -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf Map RulerId Ruler
rulers
        () -> () -> ()
`seq` Config
config Config -> () -> ()
`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
(Track -> Track -> Bool) -> (Track -> Track -> Bool) -> Eq Track
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
(TrackNum -> Track -> ShowS)
-> (Track -> String) -> ([Track] -> ShowS) -> Show Track
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) =
        BlockId -> Text
forall a. Pretty a => a -> Text
pretty BlockId
block_id Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
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
(Range -> Range -> Bool) -> (Range -> Range -> Bool) -> Eq Range
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
(TrackNum -> Range -> ShowS)
-> (Range -> String) -> ([Range] -> ShowS) -> Show Range
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, TrackId -> Maybe TrackId
forall a. a -> Maybe a
Just TrackId
track_id, (TrackTime, TrackTime) -> Maybe (TrackTime, TrackTime)
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
(TrackInfo -> TrackInfo -> Bool)
-> (TrackInfo -> TrackInfo -> Bool) -> Eq TrackInfo
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
(TrackNum -> TrackInfo -> ShowS)
-> (TrackInfo -> String)
-> ([TrackInfo] -> ShowS)
-> Show TrackInfo
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
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords
            [Text
"TrackInfo", Text -> Text
forall a. Show a => a -> Text
showt Text
title, TrackId -> Text
forall a. Show a => a -> Text
showt TrackId
track_id, TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
tracknum]
        Text -> Text -> Text
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 -> b) -> StateT m a -> StateT m b)
-> (forall a b. a -> StateT m b -> StateT m a)
-> Functor (StateT m)
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, Applicative (StateT m)
Applicative (StateT m)
-> (forall a b. StateT m a -> (a -> StateT m b) -> StateT m b)
-> (forall a b. StateT m a -> StateT m b -> StateT m b)
-> (forall a. a -> StateT m a)
-> Monad (StateT m)
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, Monad (StateT m)
Monad (StateT m)
-> (forall a. IO a -> StateT m a) -> MonadIO (StateT m)
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, Functor (StateT m)
Functor (StateT m)
-> (forall a. a -> StateT m a)
-> (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 a b. StateT m a -> StateT m b -> StateT m b)
-> (forall a b. StateT m a -> StateT m b -> StateT m a)
-> Applicative (StateT m)
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 = StateStack m a -> StateT m a
forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT (StateStack m a -> StateT m a)
-> (m a -> StateStack m a) -> m a -> StateT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT UiDamage (ExceptT Error m) a -> StateStack m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT UiDamage (ExceptT Error m) a -> StateStack m a)
-> (m a -> StateT UiDamage (ExceptT Error m) a)
-> m a
-> StateStack m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Error m a -> StateT UiDamage (ExceptT Error m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT Error m a -> StateT UiDamage (ExceptT Error m) a)
-> (m a -> ExceptT Error m a)
-> m a
-> StateT UiDamage (ExceptT Error m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ExceptT Error m a
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 = StateStack m State -> StateT m State
forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT StateStack m State
forall s (m :: * -> *). MonadState s m => m s
State.get
    unsafe_put :: State -> StateT m ()
unsafe_put State
st = StateStack m () -> StateT m ()
forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT (State -> StateStack m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put State
st)
    damage :: UiDamage -> StateT m ()
damage UiDamage
upd = (StateStack m () -> StateT m ()
forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT (StateStack m () -> StateT m ())
-> (StateT UiDamage (ExceptT Error m) () -> StateStack m ())
-> StateT UiDamage (ExceptT Error m) ()
-> StateT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT UiDamage (ExceptT Error m) () -> StateStack m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) ((UiDamage -> UiDamage) -> StateT UiDamage (ExceptT Error m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' (UiDamage
upd<>))
    get_damage :: StateT m UiDamage
get_damage = (StateStack m UiDamage -> StateT m UiDamage
forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT (StateStack m UiDamage -> StateT m UiDamage)
-> (StateT UiDamage (ExceptT Error m) UiDamage
    -> StateStack m UiDamage)
-> StateT UiDamage (ExceptT Error m) UiDamage
-> StateT m UiDamage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT UiDamage (ExceptT Error m) UiDamage -> StateStack m UiDamage
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) StateT UiDamage (ExceptT Error m) UiDamage
forall s (m :: * -> *). MonadState s m => m s
State.get
    throw_error :: forall a. Error -> StateT m a
throw_error = StateStack m a -> StateT m a
forall (m :: * -> *) a. StateStack m a -> StateT m a
StateT (StateStack m a -> StateT m a)
-> (Error -> StateStack m a) -> Error -> StateT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT UiDamage (ExceptT Error m) a -> StateStack m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT UiDamage (ExceptT Error m) a -> StateStack m a)
-> (Error -> StateT UiDamage (ExceptT Error m) a)
-> Error
-> StateStack m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Error m a -> StateT UiDamage (ExceptT Error m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT Error m a -> StateT UiDamage (ExceptT Error m) a)
-> (Error -> ExceptT Error m a)
-> Error
-> StateT UiDamage (ExceptT Error m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> ExceptT Error m a
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 = m State -> StateT state m State
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m State
forall (m :: * -> *). M m => m State
get
    unsafe_put :: State -> StateT state m ()
unsafe_put = m () -> StateT state m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT state m ())
-> (State -> m ()) -> State -> StateT state m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> m ()
forall (m :: * -> *). M m => State -> m ()
unsafe_put
    damage :: UiDamage -> StateT state m ()
damage = m () -> StateT state m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT state m ())
-> (UiDamage -> m ()) -> UiDamage -> StateT state m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UiDamage -> m ()
forall (m :: * -> *). M m => UiDamage -> m ()
damage
    get_damage :: StateT state m UiDamage
get_damage = m UiDamage -> StateT state m UiDamage
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m UiDamage
forall (m :: * -> *). M m => m UiDamage
get_damage
    throw_error :: forall a. Error -> StateT state m a
throw_error = m a -> StateT state m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT state m a)
-> (Error -> m a) -> Error -> StateT state m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> m a
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 = m State -> ExceptT exc m State
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m State
forall (m :: * -> *). M m => m State
get
    unsafe_put :: State -> ExceptT exc m ()
unsafe_put = m () -> ExceptT exc m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT exc m ())
-> (State -> m ()) -> State -> ExceptT exc m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> m ()
forall (m :: * -> *). M m => State -> m ()
unsafe_put
    damage :: UiDamage -> ExceptT exc m ()
damage = m () -> ExceptT exc m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT exc m ())
-> (UiDamage -> m ()) -> UiDamage -> ExceptT exc m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UiDamage -> m ()
forall (m :: * -> *). M m => UiDamage -> m ()
damage
    get_damage :: ExceptT exc m UiDamage
get_damage = m UiDamage -> ExceptT exc m UiDamage
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m UiDamage
forall (m :: * -> *). M m => m UiDamage
get_damage
    throw_error :: forall a. Error -> ExceptT exc m a
throw_error = m a -> ExceptT exc m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ExceptT exc m a)
-> (Error -> m a) -> Error -> ExceptT exc m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> m a
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 = Error -> m a
forall (m :: * -> *) a. M m => Error -> m a
throw_error (Error -> m a) -> Error -> m a
forall a b. (a -> b) -> a -> b
$ CallStack -> Text -> Error
Error CallStack
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 = (State -> a) -> m State -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap State -> a
f m State
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 <- m State
forall (m :: * -> *). M m => m State
get
    State -> m ()
forall (m :: * -> *). M m => State -> m ()
unsafe_put (State -> m ()) -> State -> m ()
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 = State -> m ()
forall (m :: * -> *). M m => State -> m ()
unsafe_put State
state m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
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 <- m State
forall (m :: * -> *). M m => m State
get
    State -> m ()
forall (m :: * -> *). M m => State -> m ()
put (State -> m ()) -> State -> m ()
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 <- m State
forall (m :: * -> *). M m => m State
get
    UiDamage -> m ()
forall (m :: * -> *). M m => UiDamage -> m ()
damage (UiDamage -> m ()) -> UiDamage -> m ()
forall a b. (a -> b) -> a -> b
$ UiDamage
forall a. Monoid a => a
mempty { _blocks :: Set BlockId
Update._blocks = Map BlockId Block -> Set BlockId
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 <- (ExceptT Error m ((a, State), UiDamage)
-> m (Either Error ((a, State), UiDamage))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (ExceptT Error m ((a, State), UiDamage)
 -> m (Either Error ((a, State), UiDamage)))
-> (StateT m a -> ExceptT Error m ((a, State), UiDamage))
-> StateT m a
-> m (Either Error ((a, State), UiDamage))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT UiDamage (ExceptT Error m) (a, State)
 -> UiDamage -> ExceptT Error m ((a, State), UiDamage))
-> UiDamage
-> StateT UiDamage (ExceptT Error m) (a, State)
-> ExceptT Error m ((a, State), UiDamage)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT UiDamage (ExceptT Error m) (a, State)
-> UiDamage -> ExceptT Error m ((a, State), UiDamage)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT UiDamage
forall a. Monoid a => a
mempty
        (StateT UiDamage (ExceptT Error m) (a, State)
 -> ExceptT Error m ((a, State), UiDamage))
-> (StateT m a -> StateT UiDamage (ExceptT Error m) (a, State))
-> StateT m a
-> ExceptT Error m ((a, State), UiDamage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT State (StateT UiDamage (ExceptT Error m)) a
 -> State -> StateT UiDamage (ExceptT Error m) (a, State))
-> State
-> StateT State (StateT UiDamage (ExceptT Error m)) a
-> StateT UiDamage (ExceptT Error m) (a, State)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT State (StateT UiDamage (ExceptT Error m)) a
-> State -> StateT UiDamage (ExceptT Error m) (a, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT State
state (StateT State (StateT UiDamage (ExceptT Error m)) a
 -> StateT UiDamage (ExceptT Error m) (a, State))
-> (StateT m a
    -> StateT State (StateT UiDamage (ExceptT Error m)) a)
-> StateT m a
-> StateT UiDamage (ExceptT Error m) (a, 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
    Either Error (a, State, UiDamage)
-> m (Either Error (a, State, UiDamage))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (a, State, UiDamage)
 -> m (Either Error (a, State, UiDamage)))
-> Either Error (a, State, UiDamage)
-> m (Either Error (a, State, UiDamage))
forall a b. (a -> b) -> a -> b
$ case Either Error ((a, State), UiDamage)
res of
        Left Error
err -> Error -> Either Error (a, State, UiDamage)
forall a b. a -> Either a b
Left Error
err
        Right ((a
val, State
state), UiDamage
damage) ->
            (a, State, UiDamage) -> Either Error (a, State, UiDamage)
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 = Identity (Either Error (a, State, UiDamage))
-> Either Error (a, State, UiDamage)
forall a. Identity a -> a
Identity.runIdentity (State -> StateId a -> Identity (Either Error (a, State, UiDamage))
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 -> Error -> Either Error a
forall a b. a -> Either a b
Left Error
err
        Right (a
val, State
_, UiDamage
_) -> a -> Either Error a
forall a b. b -> Either a b
Right a
val
    where result :: Either Error (a, State, UiDamage)
result = Identity (Either Error (a, State, UiDamage))
-> Either Error (a, State, UiDamage)
forall a. Identity a -> a
Identity.runIdentity (State -> StateId a -> Identity (Either Error (a, State, UiDamage))
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 =
    (Error -> Text) -> Either Error a -> m a
forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
require_right (((Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) (Text -> Text) -> (Error -> Text) -> Error -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Text
forall a. Pretty a => a -> Text
pretty) (Either Error a -> m a)
-> (StateId a -> Either Error a) -> StateId a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> StateId a -> Either Error a
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 -> Error -> Either Error State
forall a b. a -> Either a b
Left Error
err
        Right (a
_, State
state', UiDamage
_) -> State -> Either Error State
forall a b. b -> Either a b
Right State
state'
    where result :: Either Error (a, State, UiDamage)
result = Identity (Either Error (a, State, UiDamage))
-> Either Error (a, State, UiDamage)
forall a. Identity a -> a
Identity.runIdentity (State -> StateId a -> Identity (Either Error (a, State, UiDamage))
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 =
    (Error -> Text) -> Either Error State -> m State
forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
require_right (((Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") <>) (Text -> Text) -> (Error -> Text) -> Error -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Text
forall a. Pretty a => a -> Text
pretty) (Either Error State -> m State)
-> (StateId a -> Either Error State) -> StateId a -> m State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> StateId a -> Either Error State
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
    | [ViewId] -> Bool
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 Set ViewId -> Set ViewId -> Set ViewId
forall a. Semigroup a => a -> a -> a
<> [ViewId] -> Set ViewId
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 = (BlockId -> [ViewId]) -> [BlockId] -> [ViewId]
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap BlockId -> [ViewId]
views_of (Set BlockId -> [BlockId]
forall a. Set a -> [a]
Set.toList (UiDamage -> Set BlockId
Update._blocks UiDamage
damage))
    views_of :: BlockId -> [ViewId]
views_of BlockId
block_id = ((ViewId, View) -> ViewId) -> [(ViewId, View)] -> [ViewId]
forall a b. (a -> b) -> [a] -> [b]
map (ViewId, View) -> ViewId
forall a b. (a, b) -> a
fst ([(ViewId, View)] -> [ViewId]) -> [(ViewId, View)] -> [ViewId]
forall a b. (a -> b) -> a -> b
$
        ((ViewId, View) -> Bool) -> [(ViewId, View)] -> [(ViewId, View)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
==BlockId
block_id) (BlockId -> Bool)
-> ((ViewId, View) -> BlockId) -> (ViewId, View) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View -> BlockId
Block.view_block (View -> BlockId)
-> ((ViewId, View) -> View) -> (ViewId, View) -> BlockId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ViewId, View) -> View
forall a b. (a, b) -> b
snd) ([(ViewId, View)] -> [(ViewId, View)])
-> [(ViewId, View)] -> [(ViewId, View)]
forall a b. (a -> b) -> a -> b
$ Map ViewId View -> [(ViewId, View)]
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
(TrackNum -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
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) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> 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 = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> m a
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw Text
err) a -> m a
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 = (err -> m a) -> (a -> m a) -> Either err a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> m a
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m a) -> (err -> Text) -> err -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
fmt_err) a -> m a
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 = (Config -> Namespace) -> m 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 = (Config -> Config) -> m ()
forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config ((Config -> Config) -> m ()) -> (Config -> Config) -> m ()
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 (Default -> a) -> m Default -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Config -> Default) -> m Default
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 = (Config -> Config) -> m ()
forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config ((Config -> Config) -> m ()) -> (Config -> Config) -> m ()
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 = Text -> Maybe BlockId -> m BlockId
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require Text
"no root root_id" (Maybe BlockId -> m BlockId) -> m (Maybe BlockId) -> m BlockId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe BlockId)
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 = (Config -> Maybe BlockId) -> m (Maybe BlockId)
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 =
    (Config -> Config) -> m ()
forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config ((Config -> Config) -> m ()) -> (Config -> Config) -> m ()
forall a b. (a -> b) -> a -> b
$ \Config
st -> Config
st { config_root :: Maybe BlockId
UiConfig.config_root = BlockId -> Maybe BlockId
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 = (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
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 = (Config -> Config) -> m ()
forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config ((Config -> Config) -> m ()) -> (Config -> Config) -> m ()
forall a b. (a -> b) -> a -> b
$ Config :-> Meta
UiConfig.meta (Config :-> Meta) -> (Meta -> Meta) -> Config -> Config
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
configLens State Config
-> Lens Config Allocations -> Lens State Allocations
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Config Allocations
UiConfig.allocations Lens State Allocations -> m State -> m Allocations
forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> m State
forall (m :: * -> *). M m => m State
get
    Allocations
allocs <- (Text -> Text) -> Either Text Allocations -> m Allocations
forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
require_right ((Text
"modify " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>) (Either Text Allocations -> m Allocations)
-> Either Text Allocations -> m Allocations
forall a b. (a -> b) -> a -> b
$
        Instrument
-> (Allocation -> Either Text Allocation)
-> Allocations
-> Either Text Allocations
UiConfig.modify_allocation Instrument
inst (Allocation -> Either Text Allocation
forall a b. b -> Either a b
Right (Allocation -> Either Text Allocation)
-> (Allocation -> Allocation)
-> Allocation
-> Either Text Allocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Allocation
modify) Allocations
allocs
    (Config -> Config) -> m ()
forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config ((Config -> Config) -> m ()) -> (Config -> Config) -> m ()
forall a b. (a -> b) -> a -> b
$ Lens Config Allocations
UiConfig.allocations Lens Config Allocations -> Allocations -> Config -> Config
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 = (State -> a) -> m a
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (Config -> a
f (Config -> a) -> (State -> Config) -> State -> a
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 <- (Config -> Config) -> m Config
forall (m :: * -> *) a. M m => (Config -> a) -> m a
get_config Config -> Config
forall a. a -> a
id
    (Config -> Config) -> m ()
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
    (Config -> Config) -> m ()
forall (m :: * -> *). M m => (Config -> Config) -> m ()
modify_config ((Config -> Config) -> m ()) -> (Config -> Config) -> m ()
forall a b. (a -> b) -> a -> b
$ Config -> Config -> Config
forall a b. a -> b -> a
const Config
old
    a -> m a
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 Lens State Config
-> Lens Config (Maybe Allocation) -> Lens State (Maybe Allocation)
forall a b c. Lens a b -> Lens b c -> Lens a c
# Lens Config (Map Instrument Allocation)
UiConfig.allocations_map Lens Config (Map Instrument Allocation)
-> Lens (Map Instrument Allocation) (Maybe Allocation)
-> Lens Config (Maybe Allocation)
forall a b c. Lens a b -> Lens b c -> Lens a c
# Instrument -> Lens (Map Instrument Allocation) (Maybe Allocation)
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 = ViewId -> Map ViewId View -> m View
forall k (m :: * -> *) a.
(Stack, Ord k, Show k, M m) =>
k -> Map k a -> m a
lookup_id ViewId
view_id (Map ViewId View -> m View)
-> (State -> Map ViewId View) -> State -> m View
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
state_views (State -> m View) -> m State -> m View
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m State
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 = (State -> Maybe View) -> m (Maybe View)
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (ViewId -> Map ViewId View -> Maybe View
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ViewId
view_id (Map ViewId View -> Maybe View)
-> (State -> Map ViewId View) -> State -> Maybe View
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 = (State -> [ViewId]) -> m [ViewId]
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (Map ViewId View -> [ViewId]
forall k a. Map k a -> [k]
Map.keys (Map ViewId View -> [ViewId])
-> (State -> Map ViewId View) -> State -> [ViewId]
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 <- View -> m View
forall (m :: * -> *). M m => View -> m View
_update_view_status View
view
    ViewId
-> View
-> (ViewId -> m ())
-> (State -> Map ViewId View)
-> (Map ViewId View -> State -> State)
-> m ViewId
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 ViewId -> m ()
forall (m :: * -> *). M m => ViewId -> m ()
damage_view State -> Map ViewId View
state_views ((Map ViewId View -> State -> State) -> m ViewId)
-> (Map ViewId View -> State -> State) -> m ViewId
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
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_views :: Map ViewId View
state_views = ViewId -> Map ViewId View -> Map ViewId View
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) }
    ViewId -> m ()
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) = [(ViewId, View)] -> ([ViewId], [View])
forall a b. [(a, b)] -> ([a], [b])
unzip (Map ViewId View -> [(ViewId, View)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ViewId View
view_map)
    [View]
views <- (View -> m View) -> [View] -> m [View]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM View -> m View
forall (m :: * -> *). M m => View -> m View
_update_view_status [View]
views
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_views :: Map ViewId View
state_views = [(ViewId, View)] -> Map ViewId View
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([ViewId] -> [View] -> [(ViewId, View)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ViewId]
view_ids [View]
views) }
    (ViewId -> m ()) -> [ViewId] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ViewId -> m ()
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 = ViewId -> (View -> View) -> m ()
forall (m :: * -> *). M m => ViewId -> (View -> View) -> m ()
modify_view ViewId
view_id ((View -> View) -> m ()) -> (View -> View) -> m ()
forall a b. (a -> b) -> a -> b
$ \View
view -> View
view
    { view_status :: Map (TrackNum, Text) Text
Block.view_status = (Maybe Text -> Maybe Text)
-> (TrackNum, Text)
-> Map (TrackNum, Text) Text
-> Map (TrackNum, Text) Text
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Maybe Text -> Maybe Text -> Maybe Text
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block (View -> BlockId
Block.view_block View
view)
    View -> m View
forall (m :: * -> *) a. Monad m => a -> m a
return (View -> m View) -> View -> m View
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 = (TrackNum, Text)
-> Text -> Map (TrackNum, Text) Text -> Map (TrackNum, Text) Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TrackNum, Text)
Config.status_integrate_source
                (BlockId -> Text
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 = (View -> Zoom) -> m View -> m Zoom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap View -> Zoom
Block.view_zoom (m View -> m Zoom) -> (ViewId -> m View) -> ViewId -> m Zoom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ViewId -> m View
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 = ViewId -> (View -> View) -> m ()
forall (m :: * -> *). M m => ViewId -> (View -> View) -> m ()
modify_view ViewId
view_id ((View -> View) -> m ()) -> (View -> View) -> m ()
forall a b. (a -> b) -> a -> b
$ \View
view ->
    View
view { view_zoom :: Zoom
Block.view_zoom = Zoom -> Zoom
clamp (Zoom -> Zoom) -> Zoom -> Zoom
forall a b. (a -> b) -> a -> b
$ Zoom -> Zoom
modify (Zoom -> Zoom) -> Zoom -> Zoom
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 = TrackTime -> TrackTime -> TrackTime
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 =
    ViewId -> (View -> View) -> m ()
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 =
    ViewId -> (View -> View) -> m ()
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 = ViewId -> (View -> View) -> m ()
forall (m :: * -> *). M m => ViewId -> (View -> View) -> m ()
modify_view ViewId
view_id ((View -> View) -> m ()) -> (View -> View) -> m ()
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 <- ViewId -> m View
forall (m :: * -> *). M m => ViewId -> m View
get_view ViewId
view_id
    Maybe Selection -> m (Maybe Selection)
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackNum -> Map TrackNum Selection -> Maybe Selection
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 <- ViewId -> m View
forall (m :: * -> *). M m => ViewId -> m View
get_view ViewId
view_id
    ViewId -> View -> m ()
forall (m :: * -> *). M m => ViewId -> View -> m ()
update_view ViewId
view_id (View -> m ()) -> View -> m ()
forall a b. (a -> b) -> a -> b
$ View
view
        { view_selections :: Map TrackNum Selection
Block.view_selections =
            (Map TrackNum Selection -> Map TrackNum Selection)
-> (Selection -> Map TrackNum Selection -> Map TrackNum Selection)
-> Maybe Selection
-> Map TrackNum Selection
-> Map TrackNum Selection
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TrackNum -> Map TrackNum Selection -> Map TrackNum Selection
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TrackNum
selnum) (TrackNum
-> Selection -> Map TrackNum Selection -> Map TrackNum Selection
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 <- ViewId -> m View
forall (m :: * -> *). M m => ViewId -> m View
get_view ViewId
view_id
    ViewId -> View -> m ()
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
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_views :: Map ViewId View
state_views = (View -> View) -> ViewId -> Map ViewId View -> Map ViewId View
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (View -> View -> View
forall a b. a -> b -> a
const View
view) ViewId
view_id (State -> Map ViewId View
state_views State
st) }
    ViewId -> m ()
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 = m State
forall (m :: * -> *). M m => m State
get m State -> (State -> m Block) -> m Block
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BlockId -> Map BlockId Block -> m Block
forall k (m :: * -> *) a.
(Stack, Ord k, Show k, M m) =>
k -> Map k a -> m a
lookup_id BlockId
block_id (Map BlockId Block -> m Block)
-> (State -> Map BlockId Block) -> State -> m Block
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 = m State
forall (m :: * -> *). M m => m State
get m State -> (State -> m (Maybe Block)) -> m (Maybe Block)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Block -> m (Maybe Block)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Block -> m (Maybe Block))
-> (State -> Maybe Block) -> State -> m (Maybe Block)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> Map BlockId Block -> Maybe Block
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id (Map BlockId Block -> Maybe Block)
-> (State -> Map BlockId Block) -> State -> Maybe Block
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 = (State -> [BlockId]) -> m [BlockId]
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (Map BlockId Block -> [BlockId]
forall k a. Map k a -> [k]
Map.keys (Map BlockId Block -> [BlockId])
-> (State -> Map BlockId Block) -> State -> [BlockId]
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 =
    ((BlockId, Block) -> (BlockId, [TrackId]))
-> [(BlockId, Block)] -> [(BlockId, [TrackId])]
forall a b. (a -> b) -> [a] -> [b]
map ((Block -> [TrackId]) -> (BlockId, Block) -> (BlockId, [TrackId])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Block -> [TrackId]
Block.block_track_ids) ([(BlockId, Block)] -> [(BlockId, [TrackId])])
-> m [(BlockId, Block)] -> m [(BlockId, [TrackId])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State -> [(BlockId, Block)]) -> m [(BlockId, Block)]
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (Map BlockId Block -> [(BlockId, Block)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map BlockId Block -> [(BlockId, Block)])
-> (State -> Map BlockId Block) -> State -> [(BlockId, Block)]
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 <- BlockId
-> Block
-> (BlockId -> m ())
-> (State -> Map BlockId Block)
-> (Map BlockId Block -> State -> State)
-> m BlockId
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 BlockId -> m ()
forall (m :: * -> *). M m => BlockId -> m ()
damage_block State -> Map BlockId Block
state_blocks ((Map BlockId Block -> State -> State) -> m BlockId)
-> (Map BlockId Block -> State -> State) -> m BlockId
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 Map BlockId Block -> TrackNum
forall k a. Map k a -> TrackNum
Map.size Map BlockId Block
blocks TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
== TrackNum
1
                    then BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just (Id -> BlockId
Id.BlockId Id
id) else Config -> Maybe BlockId
UiConfig.config_root Config
c }
            }
    BlockId -> m ()
forall (m :: * -> *). M m => BlockId -> m ()
update_skeleton BlockId
bid
    BlockId -> m BlockId
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 =
    Id -> Block -> m BlockId
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 <- BlockId -> m (Map ViewId View)
forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
views_of BlockId
block_id
    (ViewId -> m ()) -> [ViewId] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ViewId -> m ()
forall (m :: * -> *). M m => ViewId -> m ()
destroy_view (Map ViewId View -> [ViewId]
forall k a. Map k a -> [k]
Map.keys Map ViewId View
views)
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_blocks :: Map BlockId Block
state_blocks = BlockId -> Map BlockId Block -> Map BlockId Block
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 Maybe BlockId -> Maybe BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
block_id
                then Maybe BlockId
forall a. Maybe a
Nothing else Config -> Maybe BlockId
UiConfig.config_root Config
c
            }
        }
    BlockId -> m ()
forall (m :: * -> *). M m => BlockId -> m ()
damage_block BlockId
block_id
    [(BlockId, Block)]
blocks <- (State -> [(BlockId, Block)]) -> m [(BlockId, Block)]
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (Map BlockId Block -> [(BlockId, Block)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map BlockId Block -> [(BlockId, Block)])
-> (State -> Map BlockId Block) -> State -> [(BlockId, Block)]
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.
    ((BlockId, Block) -> m [Text]) -> [(BlockId, Block)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((BlockId -> Block -> m [Text]) -> (BlockId, Block) -> m [Text]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry BlockId -> Block -> m [Text]
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 = BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block (BlockId -> m Block) -> (View -> BlockId) -> View -> m Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View -> BlockId
Block.view_block (View -> m Block) -> m View -> m Block
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ViewId -> m View
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 (View -> BlockId) -> m View -> m BlockId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ViewId -> m View
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 <- (State -> Map ViewId View) -> m (Map ViewId View)
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map ViewId View
state_views
    Map ViewId View -> m (Map ViewId View)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ViewId View -> m (Map ViewId View))
-> Map ViewId View -> m (Map ViewId View)
forall a b. (a -> b) -> a -> b
$ (View -> Bool) -> Map ViewId View -> Map ViewId View
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
==BlockId
block_id) (BlockId -> Bool) -> (View -> BlockId) -> View -> Bool
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 = (Block -> Text) -> m Block -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block -> Text
Block.block_title (m Block -> m Text) -> (BlockId -> m Block) -> BlockId -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> m Block
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 =
    BlockId -> (Block -> Block) -> m ()
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 = BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
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
    BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    Text -> StateId [Text] -> m ()
forall (m :: * -> *). M m => Text -> StateId [Text] -> m ()
require_valid Text
"set_integrated_block" (BlockId -> Block -> StateId [Text]
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
    BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    Text -> StateId [Text] -> m ()
forall (m :: * -> *). M m => Text -> StateId [Text] -> m ()
require_valid Text
"modify_integrated_tracks" (StateId [Text] -> m ()) -> StateId [Text] -> m ()
forall a b. (a -> b) -> a -> b
$
        BlockId -> Block -> StateId [Text]
forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_tracks BlockId
block_id Block
block

-- | 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 =
    BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block
        { block_integrated_manual :: ManualDestinations
Block.block_integrated_manual =
            (ManualDestinations -> ManualDestinations)
-> ([NoteDestination] -> ManualDestinations -> ManualDestinations)
-> Maybe [NoteDestination]
-> ManualDestinations
-> ManualDestinations
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> ManualDestinations -> ManualDestinations
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
key) (Text
-> [NoteDestination] -> ManualDestinations -> ManualDestinations
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 = BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
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 = BlockId -> (Config -> Config) -> m ()
forall (m :: * -> *). M m => BlockId -> (Config -> Config) -> m ()
modify_block_config BlockId
block_id ((Config -> Config) -> m ()) -> (Config -> Config) -> m ()
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 = BlockId -> (Config -> Config) -> m ()
forall (m :: * -> *). M m => BlockId -> (Config -> Config) -> m ()
modify_block_config BlockId
block_id ((Config -> Config) -> m ()) -> (Config -> Config) -> m ()
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    case Block -> [RulerId]
Block.block_ruler_ids Block
block of
        [] -> TrackTime -> m TrackTime
forall (m :: * -> *) a. Monad m => a -> m a
return TrackTime
0
        RulerId
ruler_id : [RulerId]
_ -> Ruler -> TrackTime
Ruler.time_end (Ruler -> TrackTime) -> m Ruler -> m TrackTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RulerId -> m Ruler
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    [TrackTime]
track_ends <- (TrackId -> m TrackTime) -> [TrackId] -> m [TrackTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TrackId -> m TrackTime
forall (m :: * -> *). M m => TrackId -> m TrackTime
track_event_end (Block -> [TrackId]
Block.block_track_ids Block
block)
    TrackTime -> m TrackTime
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackTime -> m TrackTime) -> TrackTime -> m TrackTime
forall a b. (a -> b) -> a -> b
$ [TrackTime] -> TrackTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (TrackTime
0 TrackTime -> [TrackTime] -> [TrackTime]
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 =
    TrackTime -> TrackTime -> TrackTime
forall a. Ord a => a -> a -> a
max (TrackTime -> TrackTime -> TrackTime)
-> m TrackTime -> m (TrackTime -> TrackTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m TrackTime
forall (m :: * -> *). M m => BlockId -> m TrackTime
block_ruler_end BlockId
block_id m (TrackTime -> TrackTime) -> m TrackTime -> m TrackTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockId -> m TrackTime
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 <- BlockId -> m 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 (TrackTime -> (TrackTime, TrackTime))
-> m TrackTime -> m (TrackTime, TrackTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m TrackTime
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 (Ruler -> (TrackTime, Maybe TrackTime))
-> m Ruler -> m (TrackTime, Maybe TrackTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RulerId -> m Ruler
forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
ruler_id
            TrackTime
end <- m TrackTime
-> (TrackTime -> m TrackTime) -> Maybe TrackTime -> m TrackTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BlockId -> m TrackTime
forall (m :: * -> *). M m => BlockId -> m TrackTime
block_event_end BlockId
block_id) TrackTime -> m TrackTime
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TrackTime
end
            (TrackTime, TrackTime) -> m (TrackTime, TrackTime)
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
    BlockId -> (Config -> Config) -> m ()
forall (m :: * -> *). M m => BlockId -> (Config -> Config) -> m ()
modify_block_config BlockId
block_id ((Config -> Config) -> m ()) -> (Config -> Config) -> m ()
forall a b. (a -> b) -> a -> b
$ \Config
config -> Config
config
        { config_skeleton :: Skeleton
Block.config_skeleton = Skeleton
skel }
    BlockId -> m ()
forall (m :: * -> *). M m => BlockId -> m ()
update_skeleton BlockId
block_id
    m ()
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 =
    (Block -> Bool) -> m Block -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Skeleton -> Skeleton -> Bool
forall a. Eq a => a -> a -> Bool
==Skeleton
Block.Explicit) (Skeleton -> Bool) -> (Block -> Skeleton) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Skeleton
Block.config_skeleton (Config -> Skeleton) -> (Block -> Config) -> Block -> Skeleton
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Config
Block.block_config)
        (m Block -> m Bool) -> (BlockId -> m Block) -> BlockId -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> m Block
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 (Block -> Skeleton) -> m Block -> m Skeleton
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m Block
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 = BlockId -> (Skeleton -> Skeleton) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> (Skeleton -> Skeleton) -> m ()
modify_skeleton BlockId
block_id (Skeleton -> Skeleton -> Skeleton
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 <- BlockId -> m 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)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Skeleton
config Skeleton -> Skeleton -> Bool
forall a. Eq a => a -> a -> Bool
== Skeleton
Block.Explicit) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"can't modify skeleton of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Pretty a => a -> Text
pretty BlockId
block_id
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", it's not explicit: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Skeleton -> Text
forall a. Show a => a -> Text
showt Skeleton
config
    BlockId -> Block -> Skeleton -> m ()
forall (m :: * -> *). M m => BlockId -> Block -> Skeleton -> m ()
_set_skeleton BlockId
block_id Block
block (Skeleton -> m ()) -> Skeleton -> m ()
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
    [(TrackNum, TrackNum)] -> ((TrackNum, TrackNum) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Skeleton -> [(TrackNum, TrackNum)]
Skeleton.flatten Skeleton
skel) (((TrackNum, TrackNum) -> m ()) -> m ())
-> ((TrackNum, TrackNum) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(TrackNum
parent, TrackNum
child) ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TrackNum -> TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> a -> Bool
Num.inRange TrackNum
1 TrackNum
tracks TrackNum
parent Bool -> Bool -> Bool
&& TrackNum -> TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> a -> Bool
Num.inRange TrackNum
1 TrackNum
tracks TrackNum
child) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"modify_skeleton: edge " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (TrackNum, TrackNum) -> Text
forall a. Show a => a -> Text
showt (TrackNum
parent, TrackNum
child)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" out of range for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Show a => a -> Text
showt BlockId
block_id
    BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block { block_skeleton :: Skeleton
Block.block_skeleton = Skeleton
skel }
    where tracks :: TrackNum
tracks = [Track] -> TrackNum
forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length ([Track] -> TrackNum) -> [Track] -> TrackNum
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    Maybe Text -> (Text -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Block -> (TrackNum, TrackNum) -> Maybe Text
edges_in_range Block
block (TrackNum, TrackNum)
edge) (Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> (Text -> Text) -> Text -> m ()
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 -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just Skeleton
new_skel -> do
            BlockId -> Skeleton -> m ()
forall (m :: * -> *). M m => BlockId -> Skeleton -> m ()
set_skeleton BlockId
block_id Skeleton
new_skel
            Bool -> m Bool
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 = (TrackNum -> (TrackNum, TrackNum))
-> [TrackNum] -> [(TrackNum, TrackNum)]
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 <- BlockId -> m Skeleton
forall (m :: * -> *). M m => BlockId -> m Skeleton
get_skeleton BlockId
block_id
    Block
block <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    Maybe Text -> (Text -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([Maybe Text] -> Maybe Text
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (((TrackNum, TrackNum) -> Maybe Text)
-> [(TrackNum, TrackNum)] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (Block -> (TrackNum, TrackNum) -> Maybe Text
edges_in_range Block
block) [(TrackNum, TrackNum)]
edges))
        (Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"add_edges: " <>))
    m () -> (Skeleton -> m ()) -> Maybe Skeleton -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"add_edges " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(TrackNum, TrackNum)] -> Text
forall a. Show a => a -> Text
showt [(TrackNum, TrackNum)]
edges Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Skeleton -> Text
forall a. Show a => a -> Text
showt Skeleton
skel
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" would have caused a cycle")
        (BlockId -> Skeleton -> m ()
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 =
    BlockId -> (Skeleton -> Skeleton) -> m ()
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 = Bool -> BlockId -> TrackNum -> TrackNum -> m ()
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 = Bool -> BlockId -> TrackNum -> TrackNum -> m ()
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    Maybe Text -> (Text -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([Maybe Text] -> Maybe Text
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((TrackNum -> Maybe Text) -> [TrackNum] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (Block -> TrackNum -> Maybe Text
edge_in_range Block
block) [TrackNum
new, TrackNum
to]))
        (Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> (Text -> Text) -> Text -> m ()
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
    m () -> (Skeleton -> m ()) -> Maybe Skeleton -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"splice_skeleton: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (TrackNum, TrackNum) -> Text
forall a. Show a => a -> Text
showt (TrackNum
new, TrackNum
to)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" would have caused a cycle")
        (BlockId -> Skeleton -> m ()
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 [Track] -> TrackNum -> Maybe Track
forall a. [a] -> TrackNum -> Maybe a
Seq.at (Block -> [Track]
Block.block_tracks Block
block) TrackNum
tracknum of
        Maybe Track
Nothing -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"tracknum out of range: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
tracknum
        Just Track
t -> case Track -> TracklikeId
Block.tracklike_id Track
t of
            Block.TId {} -> Maybe Text
forall a. Maybe a
Nothing
            TracklikeId
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"edge points to non-event track: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Track -> Text
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 Maybe Text -> Maybe Text -> Maybe Text
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    Map ViewId View
views <- BlockId -> m (Map ViewId View)
forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
views_of BlockId
block_id
    Maybe TrackId -> (TrackId -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Track -> Maybe TrackId
Block.track_id Track
track) ((TrackId -> m ()) -> m ()) -> (TrackId -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \TrackId
track_id -> do
        [TrackId]
track_ids <- BlockId -> m [TrackId]
forall (m :: * -> *). M m => BlockId -> m [TrackId]
track_ids_of BlockId
block_id
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TrackId
track_id TrackId -> [TrackId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TrackId]
track_ids) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"insert_track: block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Show a => a -> Text
showt BlockId
block_id
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" already contains " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackId -> Text
forall a. Show a => a -> Text
showt TrackId
track_id
    -- You can only put a ruler in tracknum 0.
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TrackNum
tracknum TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
> TrackNum
0 Bool -> Bool -> Bool
|| Track -> Bool
is_ruler Track
track) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"non-ruler track can't go at tracknum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
tracknum
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Track -> Text
forall a. Pretty a => a -> Text
pretty Track
track
    let tracks :: [Track]
tracks = TrackNum -> Track -> [Track] -> [Track]
forall a. TrackNum -> a -> [a] -> [a]
Seq.insert_at TrackNum
tracknum Track
track (Block -> [Track]
Block.block_tracks Block
block)
        -- Make sure the views are up to date.
        views' :: Map ViewId View
views' = (View -> View) -> Map ViewId View -> Map ViewId View
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 -> Skeleton -> m Skeleton
forall (m :: * -> *) a. Monad m => a -> m a
return (Skeleton -> m Skeleton) -> Skeleton -> m Skeleton
forall a b. (a -> b) -> a -> b
$
            TrackNum -> Skeleton -> Skeleton
Skeleton.insert TrackNum
tracknum (Block -> Skeleton
Block.block_skeleton Block
block)
        Skeleton
Block.Implicit -> [Track] -> m Skeleton
forall (m :: * -> *). M m => [Track] -> m Skeleton
infer_skeleton [Track]
tracks
    BlockId -> Block -> m ()
forall (m :: * -> *). M m => BlockId -> Block -> m ()
set_block BlockId
block_id (Block -> m ()) -> Block -> m ()
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
        }
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_views :: Map ViewId View
state_views = Map ViewId View -> Map ViewId View -> Map ViewId View
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) }
    (ViewId -> m ()) -> [ViewId] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ViewId -> m ()
forall (m :: * -> *). M m => ViewId -> m ()
damage_view (Map ViewId View -> [ViewId]
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    let tracks :: [Track]
tracks = Block -> [Track]
Block.block_tracks Block
block
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TrackNum
1 TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
<= TrackNum
tracknum Bool -> Bool -> Bool
&& TrackNum
tracknum TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
< [Track] -> TrackNum
forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [Track]
tracks) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"remove_track " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Show a => a -> Text
showt BlockId
block_id Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
tracknum
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" out of range 1--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
forall a. Show a => a -> Text
showt ([Track] -> TrackNum
forall (t :: * -> *) a. Foldable t => t a -> TrackNum
length [Track]
tracks)
    Map ViewId View
views <- (View -> View) -> Map ViewId View -> Map ViewId View
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) (Map ViewId View -> Map ViewId View)
-> m (Map ViewId View) -> m (Map ViewId View)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m (Map ViewId View)
forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
views_of BlockId
block_id
    BlockId -> Block -> m ()
forall (m :: * -> *). M m => BlockId -> Block -> m ()
set_block BlockId
block_id (Block -> m ()) -> Block -> m ()
forall a b. (a -> b) -> a -> b
$ Block
block
        { block_tracks :: [Track]
Block.block_tracks = TrackNum -> [Track] -> [Track]
forall a. TrackNum -> [a] -> [a]
Seq.remove_at TrackNum
tracknum [Track]
tracks
        , block_skeleton :: Skeleton
Block.block_skeleton =
            TrackNum -> Skeleton -> Skeleton
Skeleton.remove TrackNum
tracknum (Block -> Skeleton
Block.block_skeleton Block
block)
        }
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_views :: Map ViewId View
state_views = Map ViewId View -> Map ViewId View -> Map ViewId View
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) }
    (ViewId -> m ()) -> [ViewId] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ViewId -> m ()
forall (m :: * -> *). M m => ViewId -> m ()
damage_view (Map ViewId View -> [ViewId]
forall k a. Map k a -> [k]
Map.keys Map ViewId View
views)
    -- Clear any orphaned integration destinations.
    BlockId -> Block -> m [Text]
forall (m :: * -> *). M m => BlockId -> Block -> m [Text]
fix_integrated_tracks BlockId
block_id (Block -> m [Text]) -> m Block -> m [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    () -> m ()
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    let msg :: Text
msg = Text
"move_track: from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
from Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
to
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" out of range"
    [Track]
tracks <- Text -> Maybe [Track] -> m [Track]
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require Text
msg (Maybe [Track] -> m [Track]) -> Maybe [Track] -> m [Track]
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.
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TrackNum
from TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
/= TrackNum
0 Bool -> Bool -> Bool
&& TrackNum
to TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
/= TrackNum
0)
        TrackNum -> TrackNum -> [Track] -> Maybe [Track]
forall a. TrackNum -> TrackNum -> [a] -> Maybe [a]
Seq.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 -> Skeleton -> m Skeleton
forall (m :: * -> *) a. Monad m => a -> m a
return (Skeleton -> m Skeleton) -> Skeleton -> m Skeleton
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 -> [Track] -> m Skeleton
forall (m :: * -> *). M m => [Track] -> m Skeleton
infer_skeleton [Track]
tracks
    BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
forall a b. (a -> b) -> a -> b
$ Block -> Block -> Block
forall a b. a -> b -> a
const (Block -> Block -> Block) -> Block -> Block -> Block
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 <- ((TrackNum, TrackId) -> m (TrackNum, Text))
-> [(TrackNum, TrackId)] -> m [(TrackNum, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TrackId -> m Text) -> (TrackNum, TrackId) -> m (TrackNum, Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TrackId -> m Text
forall (m :: * -> *). M m => TrackId -> m Text
get_track_title) ([(TrackNum, TrackId)] -> m [(TrackNum, Text)])
-> [(TrackNum, TrackId)] -> m [(TrackNum, Text)]
forall a b. (a -> b) -> a -> b
$
        (Track -> Maybe TrackId)
-> [(TrackNum, Track)] -> [(TrackNum, TrackId)]
forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)]
Seq.map_maybe_snd Track -> Maybe TrackId
Block.track_id ([TrackNum] -> [Track] -> [(TrackNum, Track)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] [Track]
tracks)
    Skeleton -> m Skeleton
forall (m :: * -> *) a. Monad m => a -> m a
return (Skeleton -> m Skeleton) -> Skeleton -> m Skeleton
forall a b. (a -> b) -> a -> b
$ [Track] -> Skeleton
ParseSkeleton.default_parser ([Track] -> Skeleton) -> [Track] -> Skeleton
forall a b. (a -> b) -> a -> b
$
        ((TrackNum, Text) -> Track) -> [(TrackNum, Text)] -> [Track]
forall a b. (a -> b) -> [a] -> [b]
map ((TrackNum -> Text -> Track) -> (TrackNum, Text) -> Track
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 <- BlockId -> m 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 -> BlockId -> Block -> Skeleton -> m ()
forall (m :: * -> *). M m => BlockId -> Block -> Skeleton -> m ()
_set_skeleton BlockId
block_id Block
block
            (Skeleton -> m ()) -> m Skeleton -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Track] -> m Skeleton
forall (m :: * -> *). M m => [Track] -> m Skeleton
infer_skeleton (Block -> [Track]
Block.block_tracks Block
block)
        Skeleton
_ -> () -> m ()
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    TrackNum -> m TrackNum
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackNum -> m TrackNum) -> TrackNum -> m TrackNum
forall a b. (a -> b) -> a -> b
$ [Track] -> TrackNum
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 TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
< TrackNum
0 =
        Text -> m (Maybe Track)
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m (Maybe Track)) -> Text -> m (Maybe Track)
forall a b. (a -> b) -> a -> b
$ Text
"block_track_at: negative tracknum: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
tracknum
    | Bool
otherwise = do
        Block
block <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
        Maybe Track -> m (Maybe Track)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Track -> m (Maybe Track)) -> Maybe Track -> m (Maybe Track)
forall a b. (a -> b) -> a -> b
$ [Track] -> TrackNum -> Maybe Track
forall a. [a] -> TrackNum -> Maybe a
Seq.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 =
    BlockId -> TrackNum -> Maybe Track -> m Track
forall {m :: * -> *} {b}.
M m =>
BlockId -> TrackNum -> Maybe b -> m b
tracknum_in_range BlockId
block_id TrackNum
tracknum (Maybe Track -> m Track) -> m (Maybe Track) -> m Track
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId -> TrackNum -> m (Maybe Track)
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 <- BlockId -> m TrackNum
forall (m :: * -> *). M m => BlockId -> m TrackNum
track_count BlockId
block_id
        Text -> m b
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m b) -> Text -> m b
forall a b. (a -> b) -> a -> b
$ Text
"track " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Track -> Text
forall a. Pretty a => a -> Text
pretty (BlockId -> TrackNum -> Track
Track BlockId
block_id TrackNum
tracknum)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" out of range 0--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackNum -> Text
forall a. Show a => a -> Text
showt TrackNum
count
    tracknum_in_range BlockId
_ TrackNum
_ (Just b
a) = b -> m b
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 <- BlockId -> TrackNum -> m (Maybe Track)
forall (m :: * -> *). M m => BlockId -> TrackNum -> m (Maybe Track)
block_track_at BlockId
block_id TrackNum
tracknum
    Maybe TracklikeId -> m (Maybe TracklikeId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TracklikeId -> m (Maybe TracklikeId))
-> Maybe TracklikeId -> m (Maybe TracklikeId)
forall a b. (a -> b) -> a -> b
$ (Track -> TracklikeId) -> Maybe Track -> Maybe TracklikeId
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 <- BlockId -> TrackNum -> m (Maybe TracklikeId)
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TracklikeId)
track_at BlockId
block_id TrackNum
tracknum
    Maybe TrackId -> m (Maybe TrackId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TrackId -> m (Maybe TrackId))
-> Maybe TrackId -> m (Maybe TrackId)
forall a b. (a -> b) -> a -> b
$ TracklikeId -> Maybe TrackId
Block.track_id_of (TracklikeId -> Maybe TrackId)
-> Maybe TracklikeId -> Maybe TrackId
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 <- BlockId -> TrackNum -> m Track
forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
get_block_track_at BlockId
block_id TrackNum
tracknum
    Text -> Maybe TrackId -> m TrackId
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"track " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Track -> Text
forall a. Pretty a => a -> Text
pretty (BlockId -> TrackNum -> Track
Track BlockId
block_id TrackNum
tracknum)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not an event track") (Maybe TrackId -> m TrackId) -> Maybe TrackId -> m TrackId
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 <- BlockId -> TrackNum -> m (Maybe TracklikeId)
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> m (Maybe TracklikeId)
track_at BlockId
block_id TrackNum
tracknum
    Maybe RulerId -> m (Maybe RulerId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RulerId -> m (Maybe RulerId))
-> Maybe RulerId -> m (Maybe RulerId)
forall a b. (a -> b) -> a -> b
$ TracklikeId -> Maybe RulerId
Block.ruler_id_of (TracklikeId -> Maybe RulerId)
-> Maybe TracklikeId -> Maybe RulerId
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 = RulerId -> Maybe RulerId -> RulerId
forall a. a -> Maybe a -> a
fromMaybe RulerId
no_ruler (Maybe RulerId -> RulerId) -> m (Maybe RulerId) -> m RulerId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> TrackNum -> m (Maybe RulerId)
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 (Block -> [TrackId]) -> m Block -> m [TrackId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m Block
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 = ([(Track, TrackNum)] -> [(TrackId, TrackNum)])
-> m [(Track, TrackNum)] -> m [(TrackId, TrackNum)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Track -> Maybe TrackId)
-> [(Track, TrackNum)] -> [(TrackId, TrackNum)]
forall a a2 b. (a -> Maybe a2) -> [(a, b)] -> [(a2, b)]
Seq.map_maybe_fst Track -> Maybe TrackId
Block.track_id) (m [(Track, TrackNum)] -> m [(TrackId, TrackNum)])
-> (BlockId -> m [(Track, TrackNum)])
-> BlockId
-> m [(TrackId, TrackNum)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> m [(Track, TrackNum)]
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 = (Block -> [(Track, TrackNum)]) -> m Block -> m [(Track, TrackNum)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Track] -> [TrackNum] -> [(Track, TrackNum)])
-> [TrackNum] -> [Track] -> [(Track, TrackNum)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Track] -> [TrackNum] -> [(Track, TrackNum)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TrackNum
0..] ([Track] -> [(Track, TrackNum)])
-> (Block -> [Track]) -> Block -> [(Track, TrackNum)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Track]
Block.block_tracks) (m Block -> m [(Track, TrackNum)])
-> (BlockId -> m Block) -> BlockId -> m [(Track, TrackNum)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> m Block
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 = TrackId -> [(TrackId, TrackNum)] -> Maybe TrackNum
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TrackId
tid ([(TrackId, TrackNum)] -> Maybe TrackNum)
-> m [(TrackId, TrackNum)] -> m (Maybe TrackNum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> m [(TrackId, TrackNum)]
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 =
    Text -> Maybe TrackNum -> m TrackNum
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"tracknum_of: track " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TrackId -> Text
forall a. Show a => a -> Text
showt TrackId
tid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockId -> Text
forall a. Show a => a -> Text
showt BlockId
block_id)
        (Maybe TrackNum -> m TrackNum) -> m (Maybe TrackNum) -> m TrackNum
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId -> TrackId -> m (Maybe TrackNum)
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 =
    BlockId -> TrackNum -> (Track -> Track) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
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 =
    BlockId -> TrackNum -> (Track -> Track) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
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 (Track -> Set TrackFlag) -> m Track -> m (Set TrackFlag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> TrackNum -> m Track
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 =
    Track -> Bool
Block.track_collapsed (Track -> Bool) -> m Track -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> TrackNum -> m Track
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 =
    BlockId -> TrackNum -> (Set TrackFlag -> Set TrackFlag) -> m ()
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 TrackFlag -> Set TrackFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackFlag
flags = TrackFlag -> Set TrackFlag -> Set TrackFlag
forall a. Ord a => a -> Set a -> Set a
Set.delete TrackFlag
flag Set TrackFlag
flags
        | Bool
otherwise = TrackFlag -> Set TrackFlag -> Set TrackFlag
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 =
    BlockId -> TrackNum -> (Set TrackFlag -> Set TrackFlag) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Set TrackFlag -> Set TrackFlag) -> m ()
modify_track_flags BlockId
block_id TrackNum
tracknum (TrackFlag -> Set TrackFlag -> Set TrackFlag
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 =
    BlockId -> TrackNum -> (Set TrackFlag -> Set TrackFlag) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Set TrackFlag -> Set TrackFlag) -> m ()
modify_track_flags BlockId
block_id TrackNum
tracknum (TrackFlag -> Set TrackFlag -> Set 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
f =
    BlockId -> TrackNum -> (Track -> Track) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
forall a b. (a -> b) -> a -> b
$ \Track
btrack ->
        Track
btrack { track_flags :: Set TrackFlag
Block.track_flags = Set TrackFlag -> Set TrackFlag
f (Track -> Set TrackFlag
Block.track_flags Track
btrack) }

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
_ <- RulerId -> m Ruler
forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
ruler_id -- Throw if it doesn't exist.
    BlockId -> TrackNum -> (Track -> Track) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
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 <- BlockId -> TrackNum -> m TrackId
forall (m :: * -> *). M m => BlockId -> TrackNum -> m TrackId
get_event_track_at BlockId
block_id TrackNum
from
    BlockId -> TrackNum -> (Track -> Track) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
to ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
forall a b. (a -> b) -> a -> b
$ \Track
btrack -> Track
btrack
        { track_merged :: Set TrackId
Block.track_merged = TrackId -> Set TrackId -> Set TrackId
forall a. Ord a => a -> Set a -> Set a
Set.insert TrackId
from_id (Track -> Set TrackId
Block.track_merged Track
btrack) }
    BlockId -> TrackNum -> TrackFlag -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackFlag -> m ()
add_track_flag BlockId
block_id TrackNum
from TrackFlag
Block.Collapse

-- | 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 (Track -> Set TrackId) -> m Track -> m (Set TrackId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> TrackNum -> m Track
forall (m :: * -> *). M m => BlockId -> TrackNum -> m Track
get_block_track_at BlockId
block_id TrackNum
tracknum
    [TrackNum]
unmerged_tracknums <- (TrackId -> m (Maybe TrackNum)) -> [TrackId] -> m [TrackNum]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (BlockId -> TrackId -> m (Maybe TrackNum)
forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Maybe TrackNum)
tracknum_of BlockId
block_id)
        (Set TrackId -> [TrackId]
forall a. Set a -> [a]
Set.toList Set TrackId
track_ids)
    [TrackNum] -> (TrackNum -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TrackNum]
unmerged_tracknums ((TrackNum -> m ()) -> m ()) -> (TrackNum -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \TrackNum
tracknum ->
        BlockId -> TrackNum -> TrackFlag -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> TrackFlag -> m ()
remove_track_flag BlockId
block_id TrackNum
tracknum TrackFlag
Block.Collapse
    BlockId -> TrackNum -> Set TrackId -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> Set TrackId -> m ()
set_merged_tracks BlockId
block_id TrackNum
tracknum Set TrackId
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 =
    BlockId -> TrackNum -> (Track -> Track) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> TrackNum -> (Track -> Track) -> m ()
modify_block_track BlockId
block_id TrackNum
tracknum ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
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 (Bool -> Bool) -> (Track -> Bool) -> Track -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TrackId -> Bool
forall a. Set a -> Bool
Set.null (Set TrackId -> Bool) -> (Track -> Set TrackId) -> Track -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Set TrackId
Block.track_merged (Track -> Bool) -> m Track -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    BlockId -> TrackNum -> m Track
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 = BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block
    { block_tracks :: [Track]
Block.block_tracks =
        (Track -> Maybe RulerId -> Track)
-> [Track] -> [Maybe RulerId] -> [Track]
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 [Maybe RulerId] -> [Maybe RulerId] -> [Maybe RulerId]
forall a. [a] -> [a] -> [a]
++ Maybe RulerId -> [Maybe RulerId]
forall a. a -> [a]
repeat Maybe RulerId
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 = BlockId -> (RulerId -> RulerId) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> (RulerId -> RulerId) -> m ()
modify_ruler_id BlockId
block_id (RulerId -> RulerId -> RulerId
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 =
    BlockId -> (RulerId -> RulerId) -> m ()
forall (m :: * -> *).
M m =>
BlockId -> (RulerId -> RulerId) -> m ()
modify_ruler_id BlockId
block_id ((RulerId -> RulerId) -> m ()) -> (RulerId -> RulerId) -> m ()
forall a b. (a -> b) -> a -> b
$ \RulerId
rid -> if RulerId
rid RulerId -> RulerId -> Bool
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 = BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
forall a b. (a -> b) -> a -> b
$ \Block
block ->
    Block
block { block_tracks :: [Track]
Block.block_tracks = (Track -> Track) -> [Track] -> [Track]
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 (Track -> Ruler -> Tracklike) -> m Track -> m (Ruler -> Tracklike)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackId -> m Track
forall (m :: * -> *). M m => TrackId -> m Track
get_track TrackId
tid m (Ruler -> Tracklike) -> m Ruler -> m Tracklike
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RulerId -> m Ruler
forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
rid
    Block.RId RulerId
rid -> Ruler -> Tracklike
Block.R (Ruler -> Tracklike) -> m Ruler -> m Tracklike
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RulerId -> m Ruler
forall (m :: * -> *). M m => RulerId -> m Ruler
get_ruler RulerId
rid
    Block.DId Divider
divider -> Tracklike -> m Tracklike
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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    [Track]
btracks <- Text -> [Track] -> TrackNum -> (Track -> Track) -> m [Track]
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
    BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
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 = (Selection -> Selection)
-> Map TrackNum Selection -> Map TrackNum Selection
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 =
        (TrackNum -> Selection -> Maybe Selection)
-> Map TrackNum Selection -> Map TrackNum Selection
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 TrackNum -> TrackNum -> Bool
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 TrackNum -> TrackNum -> Bool
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 TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
< TrackNum
low = Selection -> Maybe Selection
forall a. a -> Maybe a
Just (Selection -> Maybe Selection) -> Selection -> Maybe Selection
forall a b. (a -> b) -> a -> b
$ Bool -> Block -> TrackNum -> Selection -> Selection
shift_selection Bool
True Block
block (-TrackNum
1) Selection
sel
    | TrackNum
tracknum TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
== TrackNum
high Bool -> Bool -> Bool
&& TrackNum
high TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
== TrackNum
low =
        if TrackNum
selnum TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
== TrackNum
Config.insert_selnum
        then Selection -> Maybe Selection
forall a. a -> Maybe a
Just (Selection -> Maybe Selection) -> Selection -> Maybe Selection
forall a b. (a -> b) -> a -> b
$ Bool -> Block -> TrackNum -> Selection -> Selection
shift_selection Bool
True Block
block (-TrackNum
1) Selection
sel
        else Maybe Selection
forall a. Maybe a
Nothing
    | TrackNum
tracknum TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
<= TrackNum
high = Selection -> Maybe Selection
forall a. a -> Maybe a
Just (Selection -> Maybe Selection) -> Selection -> Maybe Selection
forall a b. (a -> b) -> a -> b
$ TrackNum -> Selection -> Selection
Sel.expand_tracks (-TrackNum
1) Selection
sel
    | Bool
otherwise = Selection -> Maybe Selection
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 (TrackNum -> TrackNum -> TrackNum
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
                TrackNum -> TrackNum -> TrackNum
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 TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
== TrackNum
0 = TrackNum
tracknum
    | TrackNum
shift TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
> TrackNum
0 = [TrackNum] -> TrackNum
find_track ((TrackNum -> Bool) -> [TrackNum] -> [TrackNum]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
<TrackNum
tracknum) [TrackNum]
selectable)
    | Bool
otherwise = [TrackNum] -> TrackNum
find_track ((TrackNum -> Bool) -> [TrackNum] -> [TrackNum]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (TrackNum -> TrackNum -> Bool
forall a. Ord a => a -> a -> Bool
>TrackNum
tracknum) ([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]
_) =
        TrackNum -> Maybe TrackNum -> TrackNum
forall a. a -> Maybe a -> a
fromMaybe TrackNum
tracknum (Maybe TrackNum -> TrackNum) -> Maybe TrackNum -> TrackNum
forall a b. (a -> b) -> a -> b
$ [TrackNum] -> Maybe TrackNum
forall a. [a] -> Maybe a
Seq.head ([TrackNum] -> Maybe TrackNum) -> [TrackNum] -> Maybe TrackNum
forall a b. (a -> b) -> a -> b
$ TrackNum -> [TrackNum] -> [TrackNum]
forall a. TrackNum -> [a] -> [a]
drop TrackNum
abs_shift [TrackNum]
tracks
        where
        abs_shift :: TrackNum
abs_shift = if TrackNum
tracknum TrackNum -> TrackNum -> Bool
forall a. Eq a => a -> a -> Bool
/= TrackNum
first then TrackNum -> TrackNum
forall a. Num a => a -> a
abs TrackNum
shift TrackNum -> TrackNum -> TrackNum
forall a. Num a => a -> a -> a
- TrackNum
1 else TrackNum -> TrackNum
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) <- [TrackNum] -> [Track] -> [(TrackNum, 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 <- BlockId -> m Block
forall (m :: * -> *). M m => BlockId -> m Block
get_block BlockId
block_id
    BlockId -> Block -> m ()
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
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
        { state_blocks :: Map BlockId Block
state_blocks = (Block -> Block)
-> BlockId -> Map BlockId Block -> Map BlockId Block
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Block -> Block -> Block
forall a b. a -> b -> a
const Block
block) BlockId
block_id (State -> Map BlockId Block
state_blocks State
st) }
    BlockId -> m ()
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 = m State
forall (m :: * -> *). M m => m State
get m State -> (State -> m Track) -> m Track
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TrackId -> Map TrackId Track -> m Track
forall k (m :: * -> *) a.
(Stack, Ord k, Show k, M m) =>
k -> Map k a -> m a
lookup_id TrackId
track_id (Map TrackId Track -> m Track)
-> (State -> Map TrackId Track) -> State -> m Track
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 = (State -> Maybe Track) -> m (Maybe Track)
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (TrackId -> Map TrackId Track -> Maybe Track
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TrackId
track_id (Map TrackId Track -> Maybe Track)
-> (State -> Map TrackId Track) -> State -> Maybe Track
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 = (State -> [TrackId]) -> m [TrackId]
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (Map TrackId Track -> [TrackId]
forall k a. Map k a -> [k]
Map.keys (Map TrackId Track -> [TrackId])
-> (State -> Map TrackId Track) -> State -> [TrackId]
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 =
    TrackId
-> Track
-> (TrackId -> m ())
-> (State -> Map TrackId Track)
-> (Map TrackId Track -> State -> State)
-> m TrackId
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 TrackId -> m ()
forall (m :: * -> *). M m => TrackId -> m ()
damage_track State -> Map TrackId Track
state_tracks ((Map TrackId Track -> State -> State) -> m TrackId)
-> (Map TrackId Track -> State -> State) -> m TrackId
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 <- TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
blocks_with_track_id TrackId
track_id
    [(BlockId, [(TrackNum, TracklikeId)])]
-> ((BlockId, [(TrackNum, TracklikeId)]) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(BlockId, [(TrackNum, TracklikeId)])]
blocks (((BlockId, [(TrackNum, TracklikeId)]) -> m ()) -> m ())
-> ((BlockId, [(TrackNum, TracklikeId)]) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(BlockId
block_id, [(TrackNum, TracklikeId)]
tracks) -> [(TrackNum, TracklikeId)]
-> ((TrackNum, TracklikeId) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TrackNum, TracklikeId)]
tracks (((TrackNum, TracklikeId) -> m ()) -> m ())
-> ((TrackNum, TracklikeId) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(TrackNum
tracknum, TracklikeId
_) ->
        BlockId -> TrackNum -> m ()
forall (m :: * -> *). M m => BlockId -> TrackNum -> m ()
remove_track BlockId
block_id TrackNum
tracknum
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_tracks :: Map TrackId Track
state_tracks = TrackId -> Map TrackId Track -> Map TrackId Track
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) }
    TrackId -> m ()
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 <$>) (m Track -> m Text) -> (TrackId -> m Track) -> TrackId -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackId -> m Track
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 = TrackId -> (Text -> Text) -> m ()
forall (m :: * -> *). M m => TrackId -> (Text -> Text) -> m ()
modify_track_title TrackId
track_id (Text -> Text -> Text
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
    TrackId -> (Track -> Track) -> m ()
forall (m :: * -> *). M m => TrackId -> (Track -> Track) -> m ()
modify_track TrackId
track_id ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
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 <- ((BlockId, [(TrackNum, TracklikeId)]) -> BlockId)
-> [(BlockId, [(TrackNum, TracklikeId)])] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, [(TrackNum, TracklikeId)]) -> BlockId
forall a b. (a, b) -> a
fst ([(BlockId, [(TrackNum, TracklikeId)])] -> [BlockId])
-> m [(BlockId, [(TrackNum, TracklikeId)])] -> m [BlockId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
forall (m :: * -> *).
M m =>
TrackId -> m [(BlockId, [(TrackNum, TracklikeId)])]
blocks_with_track_id TrackId
track_id
    (BlockId -> m ()) -> [BlockId] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockId -> m ()
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 = TrackId -> (Track -> Track) -> m ()
forall (m :: * -> *). M m => TrackId -> (Track -> Track) -> m ()
modify_track TrackId
track_id ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
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 = TrackId -> (RenderConfig -> RenderConfig) -> m ()
forall (m :: * -> *).
M m =>
TrackId -> (RenderConfig -> RenderConfig) -> m ()
modify_track_render TrackId
track_id ((RenderConfig -> RenderConfig) -> m ())
-> (RenderConfig -> RenderConfig) -> m ()
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 = TrackId -> (Track -> Track) -> m ()
forall (m :: * -> *). M m => TrackId -> (Track -> Track) -> m ()
modify_track TrackId
track_id ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
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 = TrackId -> (Track -> Track) -> m ()
forall (m :: * -> *). M m => TrackId -> (Track -> Track) -> m ()
modify_track TrackId
track_id ((Track -> Track) -> m ()) -> (Track -> Track) -> m ()
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 ((Maybe TrackId -> Maybe TrackId -> Bool
forall a. Eq a => a -> a -> Bool
== TrackId -> Maybe TrackId
forall a. a -> Maybe a
Just TrackId
track_id) (Maybe TrackId -> Bool)
-> (TracklikeId -> Maybe TrackId) -> TracklikeId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracklikeId -> Maybe TrackId
Block.track_id_of) (Map BlockId Block -> [(BlockId, [(TrackNum, TracklikeId)])])
-> m (Map BlockId Block)
-> m [(BlockId, [(TrackNum, TracklikeId)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State -> Map BlockId Block) -> m (Map BlockId Block)
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_ = TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id ((Events -> (Events, Ranges TrackTime)) -> m ())
-> (Events -> (Events, Ranges TrackTime)) -> m ()
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 = (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map Event -> Event
clip_negative ([Event] -> [Event]) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$ (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((TrackTime -> TrackTime -> Bool
forall a. Ord a => a -> a -> Bool
<TrackTime
0) (TrackTime -> Bool) -> (Event -> TrackTime) -> Event -> Bool
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 TrackTime -> TrackTime -> Bool
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 <- BlockId -> m TrackTime
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.
    TrackId -> [Event] -> m ()
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 = TrackId -> [Event] -> m ()
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 (Track -> Events) -> m Track -> m Events
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackId -> m Track
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 = TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id ((Events -> (Events, Ranges TrackTime)) -> m ())
-> (Events -> (Events, Ranges TrackTime)) -> m ()
forall a b. (a -> b) -> a -> b
$ \Events
events ->
    (Events -> Events
f Events
events, Ranges TrackTime
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 = TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id ((Events -> (Events, Ranges TrackTime)) -> m ())
-> (Events -> (Events, Ranges TrackTime)) -> m ()
forall a b. (a -> b) -> a -> b
$ \Events
events ->
    (Events -> Events
process Events
events, (TrackTime -> TrackTime -> Ranges TrackTime)
-> (TrackTime, TrackTime) -> Ranges TrackTime
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TrackTime -> TrackTime -> Ranges TrackTime
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 Events -> Events -> Events
forall a. Semigroup a => a -> a -> a
<> Events -> Events
modify Events
within Events -> Events -> Events
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 <- TrackId -> TrackTime -> m Range
forall (m :: * -> *). M m => TrackId -> TrackTime -> m Range
range_from TrackId
track_id TrackTime
start
    TrackId -> Range -> (Events -> Events) -> m ()
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 = TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id ((Events -> (Events, Ranges TrackTime)) -> m ())
-> (Events -> (Events, Ranges TrackTime)) -> m ()
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 =
    [(TrackTime, TrackTime)] -> Ranges TrackTime
forall n. Ord n => [(n, n)] -> Ranges n
Ranges.sorted_ranges ([(TrackTime, TrackTime)] -> Ranges TrackTime)
-> [(TrackTime, TrackTime)] -> Ranges TrackTime
forall a b. (a -> b) -> a -> b
$ (Paired Event Event
 -> [(TrackTime, TrackTime)] -> [(TrackTime, TrackTime)])
-> [(TrackTime, TrackTime)]
-> [Paired Event Event]
-> [(TrackTime, TrackTime)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Paired Event Event
-> [(TrackTime, TrackTime)] -> [(TrackTime, TrackTime)]
f [] ([Paired Event Event] -> [(TrackTime, TrackTime)])
-> [Paired Event Event] -> [(TrackTime, TrackTime)]
forall a b. (a -> b) -> a -> b
$
        (Event -> TrackTime) -> [Event] -> [Event] -> [Paired Event Event]
forall k a. Ord k => (a -> k) -> [a] -> [a] -> [Paired a a]
Seq.pair_sorted_on1 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 (Seq.Second Event
new) [(TrackTime, TrackTime)]
ranges = Event -> (TrackTime, TrackTime)
Event.range Event
new (TrackTime, TrackTime)
-> [(TrackTime, TrackTime)] -> [(TrackTime, TrackTime)]
forall a. a -> [a] -> [a]
: [(TrackTime, TrackTime)]
ranges
    f (Seq.First Event
old) [(TrackTime, TrackTime)]
ranges = Event -> (TrackTime, TrackTime)
Event.range Event
old (TrackTime, TrackTime)
-> [(TrackTime, TrackTime)] -> [(TrackTime, TrackTime)]
forall a. a -> [a] -> [a]
: [(TrackTime, TrackTime)]
ranges
    f (Seq.Both Event
old Event
new) [(TrackTime, TrackTime)]
ranges
        | Event
old Event -> Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event
new = [(TrackTime, TrackTime)]
ranges
        | Bool
otherwise =
            (Event -> TrackTime
Event.start Event
old, TrackTime -> TrackTime -> TrackTime
forall a. Ord a => a -> a -> a
max (Event -> TrackTime
Event.end Event
old) (Event -> TrackTime
Event.end Event
new)) (TrackTime, TrackTime)
-> [(TrackTime, TrackTime)] -> [(TrackTime, TrackTime)]
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 = TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
forall (m :: * -> *).
M m =>
TrackId -> (Events -> (Events, Ranges TrackTime)) -> m ()
_modify_events TrackId
track_id ((Events -> (Events, Ranges TrackTime)) -> m ())
-> (Events -> (Events, Ranges TrackTime)) -> m ()
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, Ranges TrackTime
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
_ [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
remove_events TrackId
track_id [Event
event] = TrackId -> Event -> m ()
forall (m :: * -> *). M m => TrackId -> Event -> m ()
remove_event TrackId
track_id Event
event
remove_events TrackId
track_id [Event]
events = do
    TrackId -> Range -> m ()
forall (m :: * -> *). M m => TrackId -> Range -> m ()
remove_events_range TrackId
track_id (Range -> m ()) -> Range -> m ()
forall a b. (a -> b) -> a -> b
$
        TrackTime -> TrackTime -> Range
Events.Range (Event -> TrackTime
Event.min Event
first) (Event -> TrackTime
Event.max Event
last)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> Bool
Event.is_negative Event
first) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        TrackId -> Event -> m ()
forall (m :: * -> *). M m => TrackId -> Event -> m ()
remove_event TrackId
track_id Event
first
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> Bool
Event.is_positive Event
last) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        TrackId -> Event -> m ()
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 = (Event -> TrackTime) -> [Event] -> Maybe Event
forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Seq.minimum_on Event -> TrackTime
Event.start [Event]
events
    Just Event
last = (Event -> TrackTime) -> [Event] -> Maybe Event
forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Seq.maximum_on 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 =
    TrackId -> Range -> (Events -> Events) -> m ()
forall (m :: * -> *).
M m =>
TrackId -> Range -> (Events -> Events) -> m ()
modify_events_range TrackId
track_id Range
range (Events -> Events -> Events
forall a b. a -> b -> a
const Events
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 = (Events -> TrackTime) -> m Events -> m TrackTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Events -> TrackTime
Events.time_end (m Events -> m TrackTime)
-> (TrackId -> m Events) -> TrackId -> m TrackTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackId -> m Events
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 (TrackTime -> Range)
-> (TrackTime -> TrackTime) -> TrackTime -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TrackTime -> TrackTime -> TrackTime
forall a. Num a => a -> a -> a
+TrackTime
1) (TrackTime -> Range) -> m TrackTime -> m Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TrackId -> m TrackTime
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
    TrackId -> m Track
forall (m :: * -> *). M m => TrackId -> m Track
get_track TrackId
track_id -- Throw if track_id doesn't exist.
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_tracks :: Map TrackId Track
state_tracks = (Track -> Track)
-> TrackId -> Map TrackId Track -> Map TrackId Track
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) }
    TrackId -> m ()
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 <- TrackId -> m 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 }
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_tracks :: Map TrackId Track
state_tracks = TrackId -> Track -> Map TrackId Track -> Map TrackId Track
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.
    Events -> m () -> m ()
forall a b. NFData a => a -> b -> b
DeepSeq.deepseq Events
new_events (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UiDamage -> m ()
forall (m :: * -> *). M m => UiDamage -> m ()
damage (UiDamage -> m ()) -> UiDamage -> m ()
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) -> TrackTime -> TrackTime -> Ranges TrackTime
forall n. n -> n -> Ranges n
Ranges.range TrackTime
emin TrackTime
emax
    Maybe (TrackTime, TrackTime)
Nothing -> Ranges TrackTime
forall n. Ranges n
Ranges.nothing
    where
    minmax :: [Event] -> Maybe (TrackTime, TrackTime)
minmax (Event
e:[Event]
es) = (TrackTime, TrackTime) -> Maybe (TrackTime, TrackTime)
forall a. a -> Maybe a
Just ((TrackTime, TrackTime) -> Maybe (TrackTime, TrackTime))
-> (TrackTime, TrackTime) -> Maybe (TrackTime, TrackTime)
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 [] = Maybe (TrackTime, TrackTime)
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 (TrackTime -> TrackTime -> TrackTime
forall a. Ord a => a -> a -> a
min TrackTime
emin (Event -> TrackTime
Event.min Event
e)) (TrackTime -> TrackTime -> TrackTime
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 RulerId -> RulerId -> Bool
forall a. Eq a => a -> a -> Bool
== RulerId
no_ruler = Ruler -> m Ruler
forall (m :: * -> *) a. Monad m => a -> m a
return Ruler
Ruler.empty
    | Bool
otherwise = m State
forall (m :: * -> *). M m => m State
get m State -> (State -> m Ruler) -> m Ruler
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RulerId -> Map RulerId Ruler -> m Ruler
forall k (m :: * -> *) a.
(Stack, Ord k, Show k, M m) =>
k -> Map k a -> m a
lookup_id RulerId
ruler_id (Map RulerId Ruler -> m Ruler)
-> (State -> Map RulerId Ruler) -> State -> m Ruler
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 = m State
forall (m :: * -> *). M m => m State
get m State -> (State -> m (Maybe Ruler)) -> m (Maybe Ruler)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Ruler -> m (Maybe Ruler)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Ruler -> m (Maybe Ruler))
-> (State -> Maybe Ruler) -> State -> m (Maybe Ruler)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RulerId -> Map RulerId Ruler -> Maybe Ruler
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RulerId
ruler_id (Map RulerId Ruler -> Maybe Ruler)
-> (State -> Map RulerId Ruler) -> State -> Maybe Ruler
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 = (State -> [RulerId]) -> m [RulerId]
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (Map RulerId Ruler -> [RulerId]
forall k a. Map k a -> [k]
Map.keys (Map RulerId Ruler -> [RulerId])
-> (State -> Map RulerId Ruler) -> State -> [RulerId]
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 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== RulerId -> Id
forall a. Ident a => a -> Id
Id.unpack_id RulerId
no_ruler = Text -> m RulerId
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw Text
"can't insert no-ruler"
    | Bool
otherwise = RulerId
-> Ruler
-> (RulerId -> m ())
-> (State -> Map RulerId Ruler)
-> (Map RulerId Ruler -> State -> State)
-> m RulerId
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 RulerId -> m ()
forall (m :: * -> *). M m => RulerId -> m ()
damage_ruler State -> Map RulerId Ruler
state_rulers ((Map RulerId Ruler -> State -> State) -> m RulerId)
-> (Map RulerId Ruler -> State -> State) -> m RulerId
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 <- RulerId -> m [(BlockId, [(TrackNum, TracklikeId)])]
forall (m :: * -> *).
M m =>
RulerId -> m [(BlockId, [(TrackNum, TracklikeId)])]
blocks_with_ruler_id RulerId
ruler_id
    [(BlockId, [(TrackNum, TracklikeId)])]
-> ((BlockId, [(TrackNum, TracklikeId)]) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(BlockId, [(TrackNum, TracklikeId)])]
blocks (((BlockId, [(TrackNum, TracklikeId)]) -> m ()) -> m ())
-> ((BlockId, [(TrackNum, TracklikeId)]) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(BlockId
block_id, [(TrackNum, TracklikeId)]
tracks) -> do
        let tracknums :: [TrackNum]
tracknums = ((TrackNum, TracklikeId) -> TrackNum)
-> [(TrackNum, TracklikeId)] -> [TrackNum]
forall a b. (a -> b) -> [a] -> [b]
map (TrackNum, TracklikeId) -> TrackNum
forall a b. (a, b) -> a
fst [(TrackNum, TracklikeId)]
tracks
            setr :: TrackNum -> TracklikeId -> TracklikeId
setr TrackNum
i = if TrackNum
i TrackNum -> [TrackNum] -> Bool
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 TracklikeId -> TracklikeId
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
        BlockId -> (Block -> Block) -> m ()
forall (m :: * -> *). M m => BlockId -> (Block -> Block) -> m ()
modify_block BlockId
block_id ((Block -> Block) -> m ()) -> (Block -> Block) -> m ()
forall a b. (a -> b) -> a -> b
$ \Block
block -> Block
block { block_tracks :: [Track]
Block.block_tracks =
            ((TrackNum, Track) -> Track) -> [(TrackNum, Track)] -> [Track]
forall a b. (a -> b) -> [a] -> [b]
map (TrackNum, Track) -> Track
deruler ([Track] -> [(TrackNum, Track)]
forall a. [a] -> [(TrackNum, a)]
Seq.enumerate (Block -> [Track]
Block.block_tracks Block
block)) }
    (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
unsafe_modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st ->
        State
st { state_rulers :: Map RulerId Ruler
state_rulers = RulerId -> Map RulerId Ruler -> Map RulerId Ruler
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) }
    RulerId -> m ()
forall (m :: * -> *). M m => RulerId -> m ()
damage_ruler RulerId
ruler_id

modify_ruler :: M m => RulerId -> (Ruler.Ruler