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

{- | Cmds to create and destroy blocks, views, tracks, and rulers.

    IDs are automatically created from the state_namespace and the other IDs in
    existence.  In general I think it's a bad idea to try to hard to give IDs
    descriptive names because there's nothing keeping them that way.  The
    description should be in the track title.  Even the given numbers will get
    out of date with their position in the block.

    However, I do allow some naming beyond simple numbers for things which are
    unlikely to change, like tempo tracks and rulers, which don't have any
    other title.  And block IDs are used by the sub-derive mechanism, so those
    should be nameable.
-}
module Cmd.Create where
import qualified Control.Monad.State.Strict as Monad.State
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree

import qualified Util.Lists as Lists
import qualified Util.Ranges as Ranges
import qualified Util.Rect as Rect
import qualified Util.Trees as Trees

import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Selection as Selection
import qualified Cmd.Views as Views

import qualified Ui.Block as Block
import qualified Ui.Events as Events
import qualified Ui.GenId as GenId
import qualified Ui.Id as Id
import qualified Ui.Ruler as Ruler
import qualified Ui.Sel as Sel
import qualified Ui.Track as Track
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Transform as Transform
import qualified Ui.Types as Types
import qualified Ui.Ui as Ui
import qualified Ui.Update as Update

import           Global
import           Types


-- * global modifications

-- | Set the project to the given value and renamespace the old project to the
-- new one.  'Cmd.state_save_file' is not modified, so it will keep saving to
-- the old save file.
rename_project :: Ui.M m => Id.Namespace -> m ()
rename_project :: forall (m :: * -> *). M m => Namespace -> m ()
rename_project Namespace
ns = do
    Namespace
old_ns <- forall (m :: * -> *). M m => m Namespace
Ui.get_namespace
    forall (m :: * -> *). M m => Namespace -> Namespace -> m ()
renamespace Namespace
old_ns Namespace
ns
    forall (m :: * -> *). M m => Namespace -> m ()
Ui.set_namespace Namespace
ns

-- | Rename all IDs in namespace @from@ to @to@.
renamespace :: Ui.M m => Id.Namespace -> Id.Namespace -> m ()
renamespace :: forall (m :: * -> *). M m => Namespace -> Namespace -> m ()
renamespace Namespace
from Namespace
to = forall (m :: * -> *). M m => (Namespace -> Namespace) -> m ()
Transform.map_namespace forall a b. (a -> b) -> a -> b
$ \Namespace
ns ->
    if Namespace
ns forall a. Eq a => a -> a -> Bool
== Namespace
from then Namespace
to else Namespace
ns

rename_ruler :: Ui.M m => RulerId -> RulerId -> m ()
rename_ruler :: forall (m :: * -> *). M m => RulerId -> RulerId -> m ()
rename_ruler RulerId
ruler_id RulerId
new_name = forall (m :: * -> *). M m => (Id -> Id) -> m ()
Transform.map_ruler_ids forall a b. (a -> b) -> a -> b
$ \Id
id ->
    if Id -> RulerId
Id.RulerId Id
id forall a. Eq a => a -> a -> Bool
== RulerId
ruler_id then forall a. Ident a => a -> Id
Id.unpack_id RulerId
new_name else Id
id

-- | Rename multiple RulerIds at once.  This can swap two IDs without
-- colliding.
rename_rulers :: Ui.M m => [(RulerId, Id.Id)] -> m ()
rename_rulers :: forall (m :: * -> *). M m => [(RulerId, Id)] -> m ()
rename_rulers [(RulerId, Id)]
pairs = forall (m :: * -> *). M m => (Id -> Id) -> m ()
Transform.map_ruler_ids forall a b. (a -> b) -> a -> b
$ \Id
id ->
    forall a. a -> Maybe a -> a
fromMaybe Id
id forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Id -> RulerId
Id.RulerId Id
id) [(RulerId, Id)]
pairs

rename_block :: Ui.M m => BlockId -> Id.Id -> m ()
rename_block :: forall (m :: * -> *). M m => BlockId -> Id -> m ()
rename_block BlockId
block_id Id
new_name = forall (m :: * -> *). M m => (Id -> Id) -> m ()
Transform.map_block_ids forall a b. (a -> b) -> a -> b
$ \Id
id ->
    if Id -> BlockId
Id.BlockId Id
id forall a. Eq a => a -> a -> Bool
== BlockId
block_id then Id
new_name else Id
id

copy_block :: Ui.M m => BlockId -> Id.Id -> m ()
copy_block :: forall (m :: * -> *). M m => BlockId -> Id -> m ()
copy_block BlockId
block_id Id
new_name = do
    Block
from <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => Id -> Block -> m BlockId
Ui.create_config_block Id
new_name Block
from

-- | Find tracks which are not found in any block.  Probably used to pass them
-- to Ui.destroy_track for \"gc\".
orphan_tracks :: Ui.M m => m (Set TrackId)
orphan_tracks :: forall (m :: * -> *). M m => m (Set TrackId)
orphan_tracks = do
    [Block]
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
Ui.state_blocks)
    let ref_tracks :: Set TrackId
ref_tracks = forall a. Ord a => [a] -> Set a
Set.fromList (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [TrackId]
Block.block_track_ids [Block]
blocks)
    Set TrackId
tracks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall a. Eq a => [a] -> Set a
Set.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map TrackId Track
Ui.state_tracks)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Set TrackId
tracks forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set TrackId
ref_tracks

-- | Like 'orphan_tracks' but more efficiently check if a single track is an
-- orphan.
orphan_track :: Ui.M m => TrackId -> m Bool
orphan_track :: forall (m :: * -> *). M m => TrackId -> m Bool
orphan_track TrackId
track_id = do
    [Block]
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
Ui.state_blocks)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((TrackId
track_id `elem`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [TrackId]
Block.block_track_ids) [Block]
blocks

-- | Find rulers which are not found in any block.
orphan_rulers :: Ui.M m => m [RulerId]
orphan_rulers :: forall (m :: * -> *). M m => m [RulerId]
orphan_rulers = do
    [Block]
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
Ui.state_blocks)
    let ref_rulers :: Set RulerId
ref_rulers = forall a. Ord a => [a] -> Set a
Set.fromList (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [RulerId]
Block.block_ruler_ids [Block]
blocks)
    Set RulerId
rulers <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall a. Eq a => [a] -> Set a
Set.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map RulerId Ruler
Ui.state_rulers)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList (Set RulerId
rulers forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set RulerId
ref_rulers)

-- | Find blocks with no associated views.
orphan_blocks :: Ui.M m => m [BlockId]
orphan_blocks :: forall (m :: * -> *). M m => m [BlockId]
orphan_blocks = do
    [View]
views <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
Ui.state_views)
    let ref_blocks :: Set BlockId
ref_blocks = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map View -> BlockId
Block.view_block [View]
views)
    Set BlockId
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall a. Eq a => [a] -> Set a
Set.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map BlockId Block
Ui.state_blocks)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList (Set BlockId
blocks forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set BlockId
ref_blocks)

-- | Modify track titles with a function.
--
-- TODO this is inadequate.  I need a function to get parsed inst and control
-- track titles separately.  Use TrackTree.track_tree_of to figure inst vs.
-- control.
map_track_titles :: Ui.M m => (Text -> Text) -> m ()
map_track_titles :: forall (m :: * -> *). M m => (Text -> Text) -> m ()
map_track_titles Text -> Text
f = do
    [(TrackId, Track)]
tracks <- forall k a. Map k a -> [(k, a)]
Map.assocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map TrackId Track
Ui.state_tracks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m State
Ui.get
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TrackId, Track)]
tracks forall a b. (a -> b) -> a -> b
$ \(TrackId
track_id, Track
track) ->
        forall (m :: * -> *). M m => TrackId -> Text -> m ()
Ui.set_track_title TrackId
track_id (Text -> Text
f (Track -> Text
Track.track_title Track
track))


-- * block

block_from_template :: Ui.M m => Bool -> BlockId -> m BlockId
block_from_template :: forall (m :: * -> *). M m => Bool -> BlockId -> m BlockId
block_from_template Bool
copy_events BlockId
template_id =
    forall (m :: * -> *). M m => Bool -> BlockId -> Id -> m BlockId
named_block_from_template Bool
copy_events BlockId
template_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => Maybe BlockId -> m Id
GenId.block_id forall a. Maybe a
Nothing

-- | Create a block which is a copy of another.
named_block_from_template :: Ui.M m => Bool -- ^ copy the events
    -> BlockId -> Id.Id -> m BlockId
named_block_from_template :: forall (m :: * -> *). M m => Bool -> BlockId -> Id -> m BlockId
named_block_from_template Bool
copy_events BlockId
template_id Id
name = do
    RulerId
ruler_id <- forall (m :: * -> *). M m => BlockId -> m RulerId
Ui.block_ruler BlockId
template_id
    BlockId
block_id <- forall (m :: * -> *). M m => Id -> RulerId -> m BlockId
named_block Id
name RulerId
ruler_id
    Block
template <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
template_id
    forall (m :: * -> *). M m => BlockId -> Text -> m ()
Ui.set_block_title BlockId
block_id (Block -> Text
Block.block_title Block
template)
    let tracks :: [Track]
tracks = forall a. Int -> [a] -> [a]
drop Int
1 (Block -> [Track]
Block.block_tracks Block
template)
    [TrackId]
new_tids <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (forall {m :: * -> *}.
M m =>
BlockId -> (Int, Track) -> m (Maybe TrackId)
add_track BlockId
block_id) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Track]
tracks)
    -- Copy over the flags and merge status.  I have to merge the analogous
    -- tracks in the new block.
    let old_to_new :: Map TrackId TrackId
old_to_new = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip
            ([TracklikeId] -> [TrackId]
Block.track_ids_of (forall a b. (a -> b) -> [a] -> [b]
map Track -> TracklikeId
Block.tracklike_id [Track]
tracks))
            [TrackId]
new_tids
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Track]
tracks) forall a b. (a -> b) -> a -> b
$ \(Int
tracknum, Track
btrack) -> do
        forall (m :: * -> *).
M m =>
BlockId -> Int -> (Set TrackFlag -> Set TrackFlag) -> m ()
Ui.modify_track_flags BlockId
block_id Int
tracknum
            (forall a b. a -> b -> a
const (Track -> Set TrackFlag
Block.track_flags Track
btrack))
        forall (m :: * -> *). M m => BlockId -> Int -> Set TrackId -> m ()
Ui.set_merged_tracks BlockId
block_id Int
tracknum forall a b. (a -> b) -> a -> b
$
            forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map TrackId TrackId
old_to_new) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
            Track -> Set TrackId
Block.track_merged Track
btrack
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). M m => BlockId -> m Bool
Ui.has_explicit_skeleton BlockId
block_id) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => BlockId -> Skeleton -> m ()
Ui.set_skeleton BlockId
block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> m Skeleton
Ui.get_skeleton BlockId
template_id
    forall (m :: * -> *) a. Monad m => a -> m a
return BlockId
block_id

    where
    add_track :: BlockId -> (Int, Track) -> m (Maybe TrackId)
add_track BlockId
block_id (Int
tracknum, Track
btrack) = case Track -> TracklikeId
Block.tracklike_id Track
btrack of
        Block.TId TrackId
tid RulerId
rid -> do
            Track
track <- forall (m :: * -> *). M m => TrackId -> m Track
Ui.get_track TrackId
tid
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
BlockId -> RulerId -> Int -> Int -> Track -> m TrackId
track_events BlockId
block_id RulerId
rid Int
tracknum
                (Track -> Int
Block.track_width Track
btrack)
                (Text -> Events -> Track
Track.track (Track -> Text
Track.track_title Track
track)
                    (if Bool
copy_events then Track -> Events
Track.track_events Track
track else forall a. Monoid a => a
mempty))
        TracklikeId
_ -> do
            forall (m :: * -> *). M m => BlockId -> Int -> Track -> m ()
Ui.insert_track BlockId
block_id Int
tracknum Track
btrack
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | BlockIds look like @ns\/b1@, @ns\/b2@, etc.
block :: Ui.M m => RulerId -> m BlockId
block :: forall (m :: * -> *). M m => RulerId -> m BlockId
block = forall (m :: * -> *). M m => Maybe BlockId -> RulerId -> m BlockId
sub_block forall a. Maybe a
Nothing

-- | Create a block whose BlockId is prefixed by another: @ns/parent.b1@.
-- The relative block call mechanism supported by the default block call means
-- you can call it from the parent by just writing @.b1@.
sub_block :: Ui.M m => Maybe BlockId -> RulerId -> m BlockId
sub_block :: forall (m :: * -> *). M m => Maybe BlockId -> RulerId -> m BlockId
sub_block Maybe BlockId
maybe_parent RulerId
ruler_id = do
    Id
block_id <- forall (m :: * -> *). M m => Maybe BlockId -> m Id
GenId.block_id Maybe BlockId
maybe_parent
    forall (m :: * -> *). M m => Id -> Text -> [Track] -> m BlockId
Ui.create_block Id
block_id Text
""
        [TracklikeId -> Int -> Track
Block.track (RulerId -> TracklikeId
Block.RId RulerId
ruler_id) Int
Config.ruler_width]

-- | Create a block with the given ID name.  Useful for blocks meant to be
-- sub-derived.  If the name doesn't contain a @\/@, it gets the current
-- namespace.
named_block :: Ui.M m => Id.Id -> RulerId -> m BlockId
named_block :: forall (m :: * -> *). M m => Id -> RulerId -> m BlockId
named_block Id
name RulerId
ruler_id = forall (m :: * -> *). M m => Id -> Text -> [Track] -> m BlockId
Ui.create_block Id
name Text
""
    [TracklikeId -> Int -> Track
Block.track (RulerId -> TracklikeId
Block.RId RulerId
ruler_id) Int
Config.ruler_width]

-- | Delete a block and any views it appears in.  Also delete any tracks
-- that only appeared in that block.
destroy_block :: Ui.M m => BlockId -> m ()
destroy_block :: forall (m :: * -> *). M m => BlockId -> m ()
destroy_block BlockId
block_id = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    let track_ids :: [TrackId]
track_ids = Block -> [TrackId]
Block.block_track_ids Block
block
        ruler_ids :: [RulerId]
ruler_ids = Block -> [RulerId]
Block.block_ruler_ids Block
block
    forall (m :: * -> *). M m => BlockId -> m ()
Ui.destroy_block BlockId
block_id
    Set TrackId
orphans <- forall (m :: * -> *). M m => m (Set TrackId)
orphan_tracks
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => TrackId -> m ()
Ui.destroy_track (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
orphans) [TrackId]
track_ids)
    [RulerId]
orphans <- forall (m :: * -> *). M m => m [RulerId]
orphan_rulers
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => RulerId -> m ()
Ui.destroy_ruler (forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RulerId]
orphans) [RulerId]
ruler_ids)

-- * view

-- | Create a view with the default dimensions.
unfitted_view :: Ui.M m => BlockId -> m ViewId
unfitted_view :: forall (m :: * -> *). M m => BlockId -> m ViewId
unfitted_view BlockId
block_id = do
    (Int
x, Int
y) <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets forall a b. (a -> b) -> a -> b
$ Maybe Rect -> (Int, Int) -> [Rect] -> (Int, Int)
find_rect forall a. Maybe a
Nothing (Int, Int)
Config.view_size
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map View -> Rect
Block.view_rect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
Ui.state_views
    let (Int
w, Int
h) = (Int, Int)
Config.view_size
    forall (m :: * -> *). M m => BlockId -> Rect -> m ViewId
sized_view BlockId
block_id (Int -> Int -> Int -> Int -> Rect
Rect.xywh Int
x Int
y Int
w Int
h)

sized_view :: Ui.M m => BlockId -> Rect.Rect -> m ViewId
sized_view :: forall (m :: * -> *). M m => BlockId -> Rect -> m ViewId
sized_view BlockId
block_id Rect
rect = do
    Id
view_id <- forall (m :: * -> *). M m => BlockId -> m Id
GenId.view_id BlockId
block_id
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    ViewId
view_id <- forall (m :: * -> *). M m => Id -> View -> m ViewId
Ui.create_view Id
view_id forall a b. (a -> b) -> a -> b
$
        Block -> BlockId -> Rect -> Zoom -> View
Block.view Block
block BlockId
block_id Rect
rect Zoom
Config.zoom
    -- Automatically set the selection on a new view, so it has focus.
    let maybe_tracknum :: Maybe Int
maybe_tracknum = case Block -> [Track]
Block.block_tracks Block
block of
            [] -> forall a. Maybe a
Nothing
            [Track
_] -> forall a. a -> Maybe a
Just Int
0
            [Track]
_ -> forall a. a -> Maybe a
Just Int
1
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Int
maybe_tracknum forall a b. (a -> b) -> a -> b
$ \Int
tracknum ->
        forall (m :: * -> *).
M m =>
ViewId -> Int -> Maybe Selection -> m ()
Ui.set_selection ViewId
view_id Int
Config.insert_selnum forall a b. (a -> b) -> a -> b
$
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> TrackTime -> Orientation -> Selection
Sel.point Int
tracknum TrackTime
0 Orientation
Sel.Positive
            -- TODO I should use the current orientation, but that would make
            -- this and all its callers dependent on Cmd, or need another arg.
    forall (m :: * -> *) a. Monad m => a -> m a
return ViewId
view_id

-- | This is like 'unfitted_view', but tries to fit the view size to its
-- contents.
--
-- It's in Cmd.M since it needs the screen dimensions.
--
-- Views created during setup are likely to not have the correct height.
-- That's because I haven't received the screen resolution from fltk yet so
-- I make a guess in 'Cmd.get_screen'.
view :: Cmd.M m => BlockId -> m ViewId
view :: forall (m :: * -> *). M m => BlockId -> m ViewId
view BlockId
block_id = do
    ViewId
view_id <- forall (m :: * -> *). M m => BlockId -> m ViewId
unfitted_view BlockId
block_id
    forall (m :: * -> *). M m => ViewId -> m ()
Views.maximize_and_zoom ViewId
view_id
    Rect
screen <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). M m => Maybe (Int, Int) -> m Rect
Cmd.get_screen forall a. Maybe a
Nothing) forall (m :: * -> *). M m => ViewId -> m Rect
view_screen
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe ViewId)
Cmd.lookup_focused_view
    Rect
rect <- View -> Rect
Block.view_rect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
    [Rect]
others <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\Rect
r -> Rect
r forall a. Eq a => a -> a -> Bool
/= Rect
rect Bool -> Bool -> Bool
&& Rect -> Rect -> Bool
Rect.overlaps Rect
r Rect
screen)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map View -> Rect
Block.view_rect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
Ui.state_views
    let (Int
x, Int
y) = Maybe Rect -> (Int, Int) -> [Rect] -> (Int, Int)
find_rect (forall a. a -> Maybe a
Just Rect
screen) (Rect -> Int
Rect.w Rect
rect, Rect -> Int
Rect.h Rect
rect) [Rect]
others
    forall (m :: * -> *). M m => ViewId -> Rect -> m ()
Ui.set_view_rect ViewId
view_id (Int -> Int -> Rect -> Rect
Rect.place Int
x Int
y Rect
rect)
    forall (m :: * -> *) a. Monad m => a -> m a
return ViewId
view_id

-- | Create a view, or focus on it if it already exists.
view_or_focus :: Cmd.M m => BlockId -> m (Maybe ViewId)
    -- ^ Just ViewId if a new one was created.
view_or_focus :: forall (m :: * -> *). M m => BlockId -> m (Maybe ViewId)
view_or_focus BlockId
block_id = do
    Map ViewId View
views <- forall (m :: * -> *). M m => BlockId -> m (Map ViewId View)
Ui.views_of BlockId
block_id
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m ViewId
view BlockId
block_id) (\ViewId
vid -> forall (m :: * -> *). M m => ViewId -> m ()
Cmd.focus ViewId
vid forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
        (forall a. [a] -> Maybe a
Lists.head (forall k a. Map k a -> [k]
Map.keys Map ViewId View
views))

view_screen :: Cmd.M m => ViewId -> m Rect.Rect
view_screen :: forall (m :: * -> *). M m => ViewId -> m Rect
view_screen ViewId
view_id =
    forall (m :: * -> *). M m => Maybe (Int, Int) -> m Rect
Cmd.get_screen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rect -> (Int, Int)
Rect.upper_left forall b c a. (b -> c) -> (a -> b) -> a -> c
. View -> Rect
Block.view_rect
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id

block_view :: Cmd.M m => RulerId -> m ViewId
block_view :: forall (m :: * -> *). M m => RulerId -> m ViewId
block_view RulerId
ruler_id = forall (m :: * -> *). M m => RulerId -> m BlockId
block RulerId
ruler_id forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). M m => BlockId -> m ViewId
view

-- | Destroy a view, along with the underlying block if there were no other
-- views.
destroy_view :: Ui.M m => ViewId -> m ()
destroy_view :: forall (m :: * -> *). M m => ViewId -> m ()
destroy_view ViewId
view_id = do
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    forall (m :: * -> *). M m => ViewId -> m ()
Ui.destroy_view ViewId
view_id
    [BlockId]
orphans <- forall (m :: * -> *). M m => m [BlockId]
orphan_blocks
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockId
block_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BlockId]
orphans) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => BlockId -> m ()
Ui.destroy_block BlockId
block_id

-- * track

-- | Create a track and splice it below the current one.  The track will
-- be inserted to the right of the selected track.
splice_below :: Cmd.M m => m TrackId
splice_below :: forall (m :: * -> *). M m => m TrackId
splice_below = do
    -- I want to add a track to the right of the selected track.  Taking the
    -- maximum means I should splice after a merged pitch track, if there is
    -- one.
    (BlockId
block_id, [Int]
sel_tracknums, [TrackId]
_, Range
_) <- forall (m :: * -> *). M m => m (BlockId, [Int], [TrackId], Range)
Selection.tracks
    let sel_tracknum :: Int
sel_tracknum = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
1 forall a. a -> [a] -> [a]
: [Int]
sel_tracknums)
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    let tracknum :: Int
tracknum = Block -> Int -> Int
track_after Block
block Int
sel_tracknum
    TrackId
track_id <- forall (m :: * -> *). M m => Int -> m TrackId
focused_track Int
tracknum
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). M m => BlockId -> m Bool
Ui.has_explicit_skeleton BlockId
block_id) forall a b. (a -> b) -> a -> b
$
        -- If you create from track 0, it'll be (1, 1) here.
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
tracknum forall a. Eq a => a -> a -> Bool
/= Int
sel_tracknum) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). M m => BlockId -> Int -> Int -> m ()
Ui.splice_skeleton_below BlockId
block_id Int
tracknum Int
sel_tracknum
    forall (m :: * -> *) a. Monad m => a -> m a
return TrackId
track_id

splice_above :: Cmd.M m => m TrackId
splice_above :: forall (m :: * -> *). M m => m TrackId
splice_above = do
    -- This doesn't need to avoid a merged track like 'splice_below', because
    -- it inserts to the left.
    (BlockId
block_id, Int
tracknum, TrackId
_, TrackTime
_) <- forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    TrackId
track_id <- forall (m :: * -> *). M m => Int -> m TrackId
focused_track Int
tracknum
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). M m => BlockId -> m Bool
Ui.has_explicit_skeleton BlockId
block_id) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => BlockId -> Int -> Int -> m ()
Ui.splice_skeleton_above BlockId
block_id Int
tracknum (Int
tracknumforall a. Num a => a -> a -> a
+Int
1)
    forall (m :: * -> *) a. Monad m => a -> m a
return TrackId
track_id

{-
-- | Create a track and make it parent to the current one along with its
-- siblings.  If the selected track has no parent, the new track will become
-- parent to all toplevel tracks and be placed at tracknum 1.  Otherwise, it
-- will be inserted to the right of the parent.
splice_above_all :: Cmd.M m => m TrackId
splice_above_all = do
    (block_id, tracknum, _, _) <- Selection.get_insert
    tree <- Ui.track_tree_of block_id
    (_, parents) <- Cmd.require
        ("splice_above: tracknum not in tree: " ++ show tracknum) $
        Trees.findWithParents ((==tracknum) . num) tree
    let new_tracknum = maybe 1 ((+1) . num . Tree.rootLabel)
            (Lists.head parents)
    let parent = bump . num . Tree.rootLabel <$> Lists.head parents
        bump n = if n >= new_tracknum then n + 1 else n
    track_id <- empty_track block_id new_tracknum
    -- Splice above means splice below the parent!
    case parent of
        Just parent ->
            Ui.splice_skeleton_below block_id new_tracknum parent
        Nothing -> do
            -- No parent?  Becomes the parent of all toplevel tracks.
            let toplevel = map ((+1) . num . Tree.rootLabel) tree
            Ui.add_edges block_id (map ((,) new_tracknum) toplevel)
    return track_id
    where num = Ui.track_tracknum
-}

-- | Get the ancestors (topmost parents) of the selected tracks and create
-- a parent track to them.  It will be inserted to the left of the leftmost
-- ancestor.
splice_above_ancestors :: Cmd.M m => m TrackId
splice_above_ancestors :: forall (m :: * -> *). M m => m TrackId
splice_above_ancestors = do
    (BlockId
block_id, [Int]
tracknums, [TrackId]
_, Range
_) <- forall (m :: * -> *). M m => m (BlockId, [Int], [TrackId], Range)
Selection.tracks
    TrackTree
tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree
TrackTree.track_tree_of BlockId
block_id
    let ancestors :: [Int]
ancestors = forall a. Ord a => [a] -> [a]
Lists.unique forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TrackTree -> Int -> Maybe Int
ancestor TrackTree
tree) [Int]
tracknums
    Int
insert_at <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"no selected tracks" forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Maybe a
Lists.minimum [Int]
ancestors
    TrackId
track_id <- forall (m :: * -> *). M m => Int -> m TrackId
focused_track Int
insert_at
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). M m => BlockId -> m Bool
Ui.has_explicit_skeleton BlockId
block_id) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => BlockId -> [(Int, Int)] -> m ()
Ui.add_edges BlockId
block_id (forall a b. (a -> b) -> [a] -> [b]
map ((,) Int
insert_at forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Int
1)) [Int]
ancestors)
    forall (m :: * -> *) a. Monad m => a -> m a
return TrackId
track_id
    where
    ancestor :: TrackTree -> Int -> Maybe Int
ancestor TrackTree
tree Int
tracknum = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find forall {b} {c}. (TrackInfo, b, c) -> Bool
find (forall a. [Tree a] -> [(a, [a], [a])]
Trees.flatPaths TrackTree
tree) of
            Maybe (TrackInfo, [TrackInfo], [TrackInfo])
Nothing -> forall a. Maybe a
Nothing
            Just (TrackInfo
track, [TrackInfo]
parents, [TrackInfo]
_) ->
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TrackInfo -> Int
Ui.track_tracknum forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last (TrackInfo
track forall a. a -> [a] -> [a]
: [TrackInfo]
parents)
        where find :: (TrackInfo, b, c) -> Bool
find (TrackInfo
track, b
_, c
_) = TrackInfo -> Int
Ui.track_tracknum TrackInfo
track forall a. Eq a => a -> a -> Bool
== Int
tracknum

insert_branch :: Cmd.M m => m ()
insert_branch :: forall (m :: * -> *). M m => m ()
insert_branch = do
    (BlockId
block_id, Int
tracknum, TrackId
_, TrackTime
_) <- forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    forall (m :: * -> *). M m => BlockId -> Int -> m ()
insert_branch_from BlockId
block_id Int
tracknum
    forall (m :: * -> *). M m => ViewId -> m ()
widen forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view

-- | Insert tracks using the given one and its children as a template.  The
-- effect is to copy the branch below the selection.
insert_branch_from :: Cmd.M m => BlockId -> TrackNum -> m ()
insert_branch_from :: forall (m :: * -> *). M m => BlockId -> Int -> m ()
insert_branch_from BlockId
block_id Int
source = do
    TrackTree
tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree
TrackTree.track_tree_of BlockId
block_id
    (Tree TrackInfo
track, TrackTree
parents) <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"not found: "forall a. Semigroup a => a -> a -> a
<>forall a. Pretty a => a -> Text
pretty (BlockId
block_id, Int
source)) forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [Tree a] -> Maybe (Tree a, [Tree a])
Trees.findWithParents ((forall a. Eq a => a -> a -> Bool
==Int
source) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackInfo -> Int
Ui.track_tracknum) TrackTree
tree
    let right :: Int
right = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (TrackInfo -> Int
Ui.track_tracknum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree TrackInfo
track) forall a. Num a => a -> a -> a
+ Int
1
    Bool
merged <- forall (m :: * -> *). M m => BlockId -> Int -> m Bool
Ui.track_merged BlockId
block_id Int
source
    forall {m :: * -> *}. M m => Bool -> Int -> Tree TrackInfo -> m ()
append_below Bool
merged Int
right Tree TrackInfo
track
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). M m => BlockId -> m Bool
Ui.has_explicit_skeleton BlockId
block_id) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall a. [a] -> Maybe a
Lists.head TrackTree
parents) forall a b. (a -> b) -> a -> b
$ \(Tree.Node TrackInfo
parent TrackTree
_) ->
            forall (m :: * -> *). M m => BlockId -> [(Int, Int)] -> m ()
Ui.add_edges BlockId
block_id [(TrackInfo -> Int
Ui.track_tracknum TrackInfo
parent, Int
right)]
    where
    -- Starting at tracknum, insert track and its children.
    append_below :: Bool -> Int -> Tree TrackInfo -> m ()
append_below Bool
merged Int
tracknum Tree TrackInfo
track_node = do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, Text)]
tracks forall a b. (a -> b) -> a -> b
$ \(Int
n, Text
title) -> forall (m :: * -> *).
M m =>
BlockId -> Int -> Text -> Events -> m TrackId
track BlockId
block_id Int
n Text
title forall a. Monoid a => a
mempty
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). M m => BlockId -> m Bool
Ui.has_explicit_skeleton BlockId
block_id) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). M m => BlockId -> [(Int, Int)] -> m ()
Ui.add_edges BlockId
block_id [(Int, Int)]
skel
        -- Technically it's not necessarily merged with its neighbor, but
        -- that's how the usual cmds work, so I'll assume it's true.
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
merged forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => BlockId -> Int -> Int -> m ()
Ui.merge_track BlockId
block_id Int
tracknum (Int
tracknumforall a. Num a => a -> a -> a
+Int
1)
        where ([(Int, Text)]
tracks, [(Int, Int)]
skel) = Int -> TrackTree -> ([(Int, Text)], [(Int, Int)])
make_tracks Int
tracknum [Tree TrackInfo
track_node]

make_tracks :: TrackNum -> TrackTree.TrackTree
    -> ([(TrackNum, Text)], [(TrackNum, TrackNum)])
make_tracks :: Int -> TrackTree -> ([(Int, Text)], [(Int, Int)])
make_tracks Int
tracknum TrackTree
tree =
    (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Tree a -> [a]
Tree.flatten [Tree (Int, Text)]
tracks, forall a. [Tree a] -> [(a, a)]
Trees.edges (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst) [Tree (Int, Text)]
tracks))
    where tracks :: [Tree (Int, Text)]
tracks = Int -> TrackTree -> [Tree (Int, Text)]
assign_tracknums Int
tracknum TrackTree
tree

-- | Assign ascending tracknums to the given tree in depth-first order.  Return
-- (tracknum, title) pairs.
assign_tracknums :: TrackNum -> TrackTree.TrackTree
    -> [Tree.Tree (TrackNum, Text)]
assign_tracknums :: Int -> TrackTree -> [Tree (Int, Text)]
assign_tracknums Int
tracknum TrackTree
tree =
    forall s a. State s a -> s -> a
Monad.State.evalState (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {a}.
(MonadState a m, Num a) =>
Tree TrackInfo -> m (Tree (a, Text))
assign TrackTree
tree) Int
tracknum
    where
    assign :: Tree TrackInfo -> m (Tree (a, Text))
assign (Tree.Node TrackInfo
track TrackTree
children) = do
        a
tracknum <- m a
next
        [Tree (a, Text)]
children <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Tree TrackInfo -> m (Tree (a, Text))
assign TrackTree
children
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
Tree.Node (a
tracknum, TrackInfo -> Text
Ui.track_title TrackInfo
track) [Tree (a, Text)]
children
        where next :: m a
next = forall s (m :: * -> *). MonadState s m => m s
Monad.State.get forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
Monad.State.modify (forall a. Num a => a -> a -> a
+a
1)

-- | Insert a track after the selection, or just append one if there isn't one.
-- This is useful for empty blocks which of course have no selection.
insert_track_right :: Cmd.M m => m TrackId
insert_track_right :: forall (m :: * -> *). M m => m TrackId
insert_track_right = forall (m :: * -> *). M m => m (Maybe (ViewId, AnyPoint))
Selection.lookup_any_insert forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ViewId, AnyPoint)
Nothing -> forall (m :: * -> *). M m => m TrackId
append_track
    Just (ViewId
_, (BlockId
block_id, Int
tracknum, TrackTime
_)) -> do
        Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
        forall (m :: * -> *). M m => Int -> m TrackId
focused_track (Block -> Int -> Int
track_after Block
block Int
tracknum)

append_track :: Cmd.M m => m TrackId
append_track :: forall (m :: * -> *). M m => m TrackId
append_track = forall (m :: * -> *). M m => Int -> m TrackId
focused_track Int
99999

focused_track :: Cmd.M m => TrackNum -> m TrackId
focused_track :: forall (m :: * -> *). M m => Int -> m TrackId
focused_track Int
tracknum = do
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    forall (m :: * -> *). M m => Bool -> ViewId -> Int -> m TrackId
track_and_widen Bool
True ViewId
view_id Int
tracknum

-- | Add a new track, and widen the view to make sure it's visible.  Give
-- keyboard focus to the title.  If there's a point selection, move it to
-- the new track too.
track_and_widen :: Ui.M m => Bool -> ViewId -> TrackNum -> m TrackId
track_and_widen :: forall (m :: * -> *). M m => Bool -> ViewId -> Int -> m TrackId
track_and_widen Bool
focus ViewId
view_id Int
tracknum = do
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    TrackId
track_id <- forall (m :: * -> *).
M m =>
BlockId -> Int -> Text -> Events -> m TrackId
track BlockId
block_id Int
tracknum Text
"" Events
Events.empty
    forall (m :: * -> *). M m => ViewId -> m ()
widen ViewId
view_id
    Int
tracknum <- forall (m :: * -> *). M m => BlockId -> Int -> m Int
clip_tracknum BlockId
block_id Int
tracknum
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
focus forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
            { _title_focus :: Maybe (ViewId, Maybe Int)
Update._title_focus = forall a. a -> Maybe a
Just (ViewId
view_id, forall a. a -> Maybe a
Just Int
tracknum) }
        forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (forall (m :: * -> *). M m => ViewId -> m (Maybe Selection)
Selection.lookup_view ViewId
view_id) forall a b. (a -> b) -> a -> b
$ \Selection
sel ->
            if Bool -> Bool
not (Selection -> Bool
Sel.is_point Selection
sel) then forall (m :: * -> *) a. Monad m => a -> m a
return ()
                else forall (m :: * -> *). M m => ViewId -> Maybe Selection -> m ()
Selection.set_view ViewId
view_id forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                    (Int -> Int) -> Selection -> Selection
Sel.modify_tracks (forall a b. a -> b -> a
const Int
tracknum) Selection
sel
    forall (m :: * -> *) a. Monad m => a -> m a
return TrackId
track_id

-- | Expand the view horizontally to to fit all tracks.
widen :: Ui.M m => ViewId -> m ()
widen :: forall (m :: * -> *). M m => ViewId -> m ()
widen ViewId
view_id = do
    View
view <- forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
    Rect
embiggened <- forall (m :: * -> *). M m => View -> m Rect
Views.contents_rect View
view
    let rect :: Rect
rect = View -> Rect
Block.view_rect View
view
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rect -> Int
Rect.w Rect
embiggened forall a. Ord a => a -> a -> Bool
> Rect -> Int
Rect.w Rect
rect) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => ViewId -> Rect -> m ()
Ui.set_view_rect ViewId
view_id forall a b. (a -> b) -> a -> b
$
            Int -> Int -> Rect -> Rect
Rect.resize (Rect -> Int
Rect.w Rect
embiggened) (Rect -> Int
Rect.h Rect
rect) Rect
rect

empty_track :: Ui.M m => BlockId -> TrackNum -> m TrackId
empty_track :: forall (m :: * -> *). M m => BlockId -> Int -> m TrackId
empty_track BlockId
block_id Int
tracknum = forall (m :: * -> *).
M m =>
BlockId -> Int -> Text -> Events -> m TrackId
track BlockId
block_id Int
tracknum Text
"" Events
Events.empty

-- | Like 'track_events', but copy the ruler from the track to the left.
track :: Ui.M m => BlockId -> TrackNum -> Text -> Events.Events
    -> m TrackId
track :: forall (m :: * -> *).
M m =>
BlockId -> Int -> Text -> Events -> m TrackId
track BlockId
block_id Int
tracknum Text
title Events
events = do
    -- Clip to valid range so callers can use an out of range tracknum.
    Int
tracknum <- forall (m :: * -> *). M m => BlockId -> Int -> m Int
clip_tracknum BlockId
block_id Int
tracknum
    RulerId
ruler_id <- forall {m :: * -> *}. M m => Int -> m RulerId
find_ruler (Int
tracknumforall a. Num a => a -> a -> a
-Int
1)
    forall (m :: * -> *).
M m =>
BlockId -> RulerId -> Int -> Int -> Track -> m TrackId
track_events BlockId
block_id RulerId
ruler_id Int
tracknum Int
Config.track_width
        (Text -> Events -> Track
Track.track Text
title Events
events)
    where
    find_ruler :: Int -> m RulerId
find_ruler Int
tracknum
        | Int
tracknum forall a. Ord a => a -> a -> Bool
< Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return RulerId
Ui.no_ruler
        | Bool
otherwise = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> m RulerId
find_ruler (Int
tracknumforall a. Num a => a -> a -> a
-Int
1)) forall (m :: * -> *) a. Monad m => a -> m a
return
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> Int -> m (Maybe RulerId)
Ui.ruler_track_at BlockId
block_id Int
tracknum

-- | Lowest level track creator.  The new TrackId will be in the same namespace
-- as the given BlockId.
track_events :: Ui.M m =>
    BlockId -> RulerId -> TrackNum -> Types.Width -> Track.Track -> m TrackId
track_events :: forall (m :: * -> *).
M m =>
BlockId -> RulerId -> Int -> Int -> Track -> m TrackId
track_events BlockId
block_id RulerId
ruler_id Int
tracknum Int
width Track
track = do
    Id
track_id <- forall (m :: * -> *). M m => BlockId -> m Id
GenId.track_id BlockId
block_id
    TrackId
tid <- forall (m :: * -> *). M m => Id -> Track -> m TrackId
Ui.create_track Id
track_id Track
track
    forall (m :: * -> *). M m => BlockId -> Int -> Track -> m ()
Ui.insert_track BlockId
block_id Int
tracknum
        (TracklikeId -> Int -> Track
Block.track (TrackId -> RulerId -> TracklikeId
Block.TId TrackId
tid RulerId
ruler_id) Int
width)
    forall (m :: * -> *) a. Monad m => a -> m a
return TrackId
tid

-- | Create a track with the given name, in the same namespace as the BlockId.
named_track :: Ui.M m =>
    BlockId -> RulerId -> TrackNum -> Text -> Track.Track -> m TrackId
named_track :: forall (m :: * -> *).
M m =>
BlockId -> RulerId -> Int -> Text -> Track -> m TrackId
named_track BlockId
block_id RulerId
ruler_id Int
tracknum Text
name Track
track = do
    Id
ident <- forall a (m :: * -> *). (Stack, Ident a, M m) => Text -> m a
Ui.read_id (forall a. Ident a => a -> Text
Id.ident_name BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
name)
    Map TrackId Track
all_tracks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map TrackId Track
Ui.state_tracks
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Id -> TrackId
Id.TrackId Id
ident forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TrackId Track
all_tracks) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw forall a b. (a -> b) -> a -> b
$ Text
"track " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Id
ident forall a. Semigroup a => a -> a -> a
<> Text
" already exists"
    TrackId
tid <- forall (m :: * -> *). M m => Id -> Track -> m TrackId
Ui.create_track Id
ident Track
track
    forall (m :: * -> *). M m => BlockId -> Int -> Track -> m ()
Ui.insert_track BlockId
block_id Int
tracknum
        (TracklikeId -> Int -> Track
Block.track (TrackId -> RulerId -> TracklikeId
Block.TId TrackId
tid RulerId
ruler_id) Int
Config.track_width)
    forall (m :: * -> *) a. Monad m => a -> m a
return TrackId
tid

remove_selected_tracks :: Cmd.M m => m ()
remove_selected_tracks :: forall (m :: * -> *). M m => m ()
remove_selected_tracks = do
    (BlockId
block_id, [Int]
tracknums, [TrackId]
_, Range
_) <- forall (m :: * -> *). M m => m (BlockId, [Int], [TrackId], Range)
Selection.tracks
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => BlockId -> Int -> m ()
Ui.remove_track BlockId
block_id) (forall a. [a] -> [a]
reverse [Int]
tracknums)

destroy_selected_tracks :: Cmd.M m => m ()
destroy_selected_tracks :: forall (m :: * -> *). M m => m ()
destroy_selected_tracks = do
    (BlockId
block_id, [Int]
tracknums, [TrackId]
_, Range
_) <- forall (m :: * -> *). M m => m (BlockId, [Int], [TrackId], Range)
Selection.tracks
    -- Deleting each track will decrease the tracknum of the ones after it.
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => BlockId -> Int -> m ()
destroy_track BlockId
block_id) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) [Int]
tracknums [Int
0..])

-- | Remove a track from a block.  If that was the only block it appeared in,
-- delete the underlying track.  Rulers are never deleted automatically.
destroy_track :: Ui.M m => BlockId -> TrackNum -> m ()
destroy_track :: forall (m :: * -> *). M m => BlockId -> Int -> m ()
destroy_track BlockId
block_id Int
tracknum = do
    TracklikeId
tracklike <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Ui.require (Text
"invalid tracknum: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
tracknum)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
BlockId -> Int -> m (Maybe TracklikeId)
Ui.track_at BlockId
block_id Int
tracknum
    forall (m :: * -> *). M m => BlockId -> Int -> m ()
Ui.remove_track BlockId
block_id Int
tracknum
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (TracklikeId -> Maybe TrackId
Block.track_id_of TracklikeId
tracklike) forall a b. (a -> b) -> a -> b
$ \TrackId
track_id ->
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). M m => TrackId -> m Bool
orphan_track TrackId
track_id) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). M m => TrackId -> m ()
Ui.destroy_track TrackId
track_id

-- | Swap the tracks at the given tracknums.  If one of the tracknums is out
-- of range, the track at the other tracknum will be moved to the beginning or
-- end, i.e. swapped with empty space.
swap_tracks :: Ui.M m => BlockId -> TrackNum -> TrackNum -> m ()
swap_tracks :: forall (m :: * -> *). M m => BlockId -> Int -> Int -> m ()
swap_tracks BlockId
block_id Int
num0 Int
num1 = do
    Maybe Track
track0 <- forall (m :: * -> *). M m => BlockId -> Int -> m (Maybe Track)
Ui.block_track_at BlockId
block_id Int
num0
    Maybe Track
track1 <- forall (m :: * -> *). M m => BlockId -> Int -> m (Maybe Track)
Ui.block_track_at BlockId
block_id Int
num1
    case (Maybe Track
track0, Maybe Track
track1) of
        (Maybe Track
Nothing, Maybe Track
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Just Track
t0, Maybe Track
Nothing) -> Int -> m ()
remove Int
num0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Track -> m ()
insert Int
num1 Track
t0
        (Maybe Track
Nothing, Just Track
t1) -> Int -> m ()
remove Int
num1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Track -> m ()
insert Int
num0 Track
t1
        (Just Track
t0, Just Track
t1) -> do
            Int -> m ()
remove Int
num0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Track -> m ()
insert Int
num0 Track
t1
            Int -> m ()
remove Int
num1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Track -> m ()
insert Int
num1 Track
t0
    where
    remove :: Int -> m ()
remove = forall (m :: * -> *). M m => BlockId -> Int -> m ()
Ui.remove_track BlockId
block_id
    insert :: Int -> Track -> m ()
insert = forall (m :: * -> *). M m => BlockId -> Int -> Track -> m ()
Ui.insert_track BlockId
block_id

-- ** util

-- | Clip the tracknum to within the valid range.
clip_tracknum :: Ui.M m => BlockId -> TrackNum -> m TrackNum
clip_tracknum :: forall (m :: * -> *). M m => BlockId -> Int -> m Int
clip_tracknum BlockId
block_id Int
tracknum = do
    Int
tracks <- forall (m :: * -> *). M m => BlockId -> m Int
Ui.track_count BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
0 (forall a. Ord a => a -> a -> a
min Int
tracks Int
tracknum)

-- | Get the track to the right of the given tracknum.  This isn't just (+1)
-- because it skips collapsed tracks.
track_after :: Block.Block -> TrackNum -> TrackNum
track_after :: Block -> Int -> Int
track_after Block
block Int
tracknum
    -- It must already be the rightmost tracknum.
    | Int
tracknum forall a. Eq a => a -> a -> Bool
== Int
next_tracknum = forall (t :: * -> *) a. Foldable t => t a -> Int
length (Block -> [Track]
Block.block_tracks Block
block)
    | Bool
otherwise = Int
next_tracknum
    where next_tracknum :: Int
next_tracknum = Block -> Int -> Int -> Int
Ui.skip_unselectable_tracks Block
block Int
tracknum Int
1

-- * ruler

-- | Create a ruler with the given name.
ruler :: Ui.M m => Text -> Ruler.Ruler -> m RulerId
ruler :: forall (m :: * -> *). M m => Text -> Ruler -> m RulerId
ruler Text
name Ruler
ruler = do
    Id
ident <- forall a (m :: * -> *). (Stack, Ident a, M m) => Text -> m a
Ui.read_id Text
name
    forall (m :: * -> *). M m => Id -> Ruler -> m RulerId
Ui.create_ruler Id
ident Ruler
ruler

-- | Set a block to a new ruler.
new_ruler :: Ui.M m => BlockId -> Text -> Ruler.Ruler -> m RulerId
new_ruler :: forall (m :: * -> *). M m => BlockId -> Text -> Ruler -> m RulerId
new_ruler BlockId
block_id Text
name Ruler
r = do
    RulerId
ruler_id <- forall (m :: * -> *). M m => Text -> Ruler -> m RulerId
ruler Text
name Ruler
r
    forall (m :: * -> *). M m => RulerId -> BlockId -> m ()
set_block_ruler RulerId
ruler_id BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return RulerId
ruler_id

set_block_ruler :: Ui.M m => RulerId -> BlockId -> m ()
set_block_ruler :: forall (m :: * -> *). M m => RulerId -> BlockId -> m ()
set_block_ruler RulerId
ruler_id BlockId
block_id =
    forall (m :: * -> *).
M m =>
BlockId -> (TracklikeId -> TracklikeId) -> m ()
Transform.tracks BlockId
block_id (RulerId -> TracklikeId -> TracklikeId
Block.set_ruler_id RulerId
ruler_id)

-- * general util

-- | Find a place to fit the given rect.  This is like a tiny window manager.
find_rect :: Maybe Rect.Rect -> (Int, Int) -> [Rect.Rect] -> (Int, Int)
find_rect :: Maybe Rect -> (Int, Int) -> [Rect] -> (Int, Int)
find_rect Maybe Rect
maybe_screen (Int
w, Int
_h) [Rect]
rects =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
0, Int
0) Rect -> (Int, Int)
Rect.upper_left forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn Rect -> (Int, Int)
delta [Rect]
holes
    where
    -- First pick holes that fit, by increasing size, then pick the ones
    -- that don't fit, by decreasing size.
    delta :: Rect -> (Int, Int)
delta Rect
rect = (if Int
diff forall a. Eq a => a -> a -> Bool
== Int
0 then -Int
1 else forall a. Num a => a -> a
negate (forall a. Num a => a -> a
signum Int
diff), forall a. Num a => a -> a
abs Int
diff)
        where diff :: Int
diff = Rect -> Int
Rect.w Rect
rect forall a. Num a => a -> a -> a
- Int
w
    holes :: [Rect]
holes = case Maybe Rect
maybe_screen of
        Maybe Rect
Nothing -> [Int -> Int -> Int -> Int -> Rect
Rect.xywh Int
right Int
0 Int
1 Int
1]
        Just Rect
screen -> [Rect] -> Rect -> [Rect]
find_holes [Rect]
rects Rect
screen
    right :: Int
right = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ Int
0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Rect -> Int
Rect.r [Rect]
rects

find_holes :: [Rect.Rect] -> Rect.Rect -> [Rect.Rect]
find_holes :: [Rect] -> Rect -> [Rect]
find_holes [Rect]
rects Rect
screen = case forall n. Ranges n -> Maybe [(n, n)]
Ranges.extract Ranges Int
ranges of
    Maybe [(Int, Int)]
Nothing -> [Rect
screen]
    Just [(Int, Int)]
rs -> [Int -> Int -> Int -> Int -> Rect
Rect.xywh Int
x1 (Rect -> Int
Rect.y Rect
screen) (Int
x2forall a. Num a => a -> a -> a
-Int
x1) (Rect -> Int
Rect.h Rect
screen)
        | (Int
x1, Int
x2) <- [(Int, Int)]
rs]
    where
    extent :: Rect -> (Int, Int)
extent Rect
r = (Rect -> Int
Rect.x Rect
r, Rect -> Int
Rect.r Rect
r)
    ranges :: Ranges Int
ranges = forall n. Ord n => (n, n) -> Ranges n -> Ranges n
Ranges.invert (Rect -> (Int, Int)
extent Rect
screen) forall a b. (a -> b) -> a -> b
$ forall n. Ord n => [(n, n)] -> Ranges n
Ranges.ranges forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Rect -> (Int, Int)
extent [Rect]
rects