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