-- 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 module Cmd.Repl.LView where import qualified Data.List as List import qualified Data.Map as Map import qualified Util.Pretty as Pretty import qualified Util.Rect as Rect import qualified Util.Lists as Lists import qualified Cmd.Cmd as Cmd import qualified Cmd.Create as Create import qualified Cmd.NoteTrackParse as NoteTrackParse import qualified Cmd.ViewConfig as ViewConfig import qualified Cmd.Views as Views import qualified Ui.Block as Block import qualified Ui.Ui as Ui import qualified Ui.UiConfig as UiConfig import qualified Ui.Zoom as Zoom import Global import Types list :: Cmd.CmdL [ViewId] list :: CmdL [ViewId] list = forall (m :: * -> *). M m => m [ViewId] Ui.all_view_ids -- * create create :: BlockId -> Cmd.CmdL ViewId create :: BlockId -> CmdL ViewId create = forall (m :: * -> *). M m => BlockId -> m ViewId Create.view -- | Create a view from a BlockId inferred like a block call would, from the -- selected block. create_infer :: Text -> Cmd.CmdL ViewId create_infer :: Text -> CmdL ViewId create_infer Text name = do Map BlockId Block blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a Ui.gets State -> Map BlockId Block Ui.state_blocks Namespace ns <- forall (m :: * -> *). M m => m Namespace Ui.get_namespace Maybe BlockId caller <- forall (m :: * -> *). M m => m (Maybe BlockId) Cmd.lookup_focused_block case forall a. Map BlockId a -> Namespace -> Maybe BlockId -> Text -> Maybe BlockId NoteTrackParse.to_block_id Map BlockId Block blocks Namespace ns Maybe BlockId caller Text name of Just BlockId block_id -> forall (m :: * -> *). M m => BlockId -> m ViewId Create.view BlockId block_id Maybe BlockId Nothing -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a Cmd.throw Text "blah" -- | For the current window, open enough views at the current zoom to see the -- score from the current time until the end of the block. cover :: Cmd.M m => m [ViewId] cover :: forall (m :: * -> *). M m => m [ViewId] cover = forall (m :: * -> *). M m => ViewId -> m [ViewId] ViewConfig.views_covering forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => m ViewId Cmd.get_focused_view -- * arrange -- | Crunch all the views up against each other. arrange :: Cmd.CmdL () arrange :: CmdL () arrange = do [Rect] screens <- forall (m :: * -> *) a. M m => (State -> a) -> m a Cmd.gets State -> [Rect] Cmd.state_screens forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (Int, Int) -> CmdL () arrange_screen [(Rect -> Int Rect.x Rect r, Rect -> Int Rect.y Rect r) | Rect r <- [Rect] screens] arrange_screen :: (Int, Int) -> Cmd.CmdL () arrange_screen :: (Int, Int) -> CmdL () arrange_screen (Int, Int) point = do Rect screen <- forall (m :: * -> *). M m => Maybe (Int, Int) -> m Rect Cmd.get_screen forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just (Int, Int) point [(ViewId, Rect)] view_rects <- forall a. (a -> Bool) -> [a] -> [a] filter (Rect -> Rect -> Bool Rect.overlaps Rect screen forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second View -> Rect Block.view_rect) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [(k, a)] Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> Map ViewId View Ui.state_views 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) => (a -> m b) -> t a -> m () mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry forall (m :: * -> *). M m => ViewId -> Rect -> m () Ui.set_view_rect) forall a b. (a -> b) -> a -> b $ forall a. Rect -> [(a, Rect)] -> [(a, Rect)] compact Rect screen (forall k a. Ord k => (a -> k) -> [a] -> [a] Lists.sortOn forall a b. (a, b) -> b snd [(ViewId, Rect)] view_rects) compact :: Rect.Rect -> [(a, Rect.Rect)] -> [(a, Rect.Rect)] compact :: forall a. Rect -> [(a, Rect)] -> [(a, Rect)] compact Rect screen = forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) List.mapAccumL forall {a}. (Int, Int, Int) -> (a, Rect) -> ((Int, Int, Int), (a, Rect)) go (Rect -> Int Rect.x Rect screen, Rect -> Int Rect.y Rect screen, Rect -> Int Rect.h Rect screen) where go :: (Int, Int, Int) -> (a, Rect) -> ((Int, Int, Int), (a, Rect)) go (Int x, Int y, Int min_h) (a view_id, Rect rect) = ((Int, Int, Int) next, (a view_id, Int -> Int -> Rect -> Rect Rect.place Int x Int y Rect rect)) where next :: (Int, Int, Int) next | Int x forall a. Num a => a -> a -> a + Rect -> Int Rect.w Rect rect forall a. Ord a => a -> a -> Bool < Rect -> Int Rect.r Rect screen = (Int x forall a. Num a => a -> a -> a + Rect -> Int Rect.w Rect rect, Int y, forall a. Ord a => a -> a -> a min Int min_h (Rect -> Int Rect.h Rect rect)) | Bool otherwise = (Rect -> Int Rect.x Rect screen, Int y forall a. Num a => a -> a -> a + Int min_h, Rect -> Int Rect.h Rect screen) -- * save and load -- | Show the list of saved views, with a star on the focused one. saved :: Cmd.CmdL Text saved :: CmdL Text saved = do SavedViews saved <- Lens State Config Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c #Config :-> SavedViews UiConfig.saved_views forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b <#> forall (m :: * -> *). M m => m State Ui.get forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. Pretty a => a -> Text Pretty.formatted forall a b. (a -> b) -> a -> b $ forall a b k. (a -> b) -> Map k a -> Map k b Map.map forall {a} {a}. (Eq a, Show a) => (Map a a, Maybe a) -> [Doc] pretty SavedViews saved where pretty :: (Map a a, Maybe a) -> [Doc] pretty (Map a a views, Maybe a focused) = forall a b. (a -> b) -> [a] -> [b] map (\a view_id -> Text -> Doc Pretty.text forall a b. (a -> b) -> a -> b $ (if forall a. a -> Maybe a Just a view_id forall a. Eq a => a -> a -> Bool == Maybe a focused then Text "*" else Text "") forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt a view_id) (forall k a. Map k a -> [k] Map.keys Map a a views) -- | Save the current view layout. save :: Text -> Cmd.CmdL () save :: Text -> CmdL () save = forall (m :: * -> *). M m => Text -> m () ViewConfig.save_views load :: Text -> Cmd.CmdL () load :: Text -> CmdL () load = forall (m :: * -> *). M m => Text -> m () ViewConfig.restore_views remove :: Ui.M m => Text -> m () remove :: forall (m :: * -> *). M m => Text -> m () remove = forall (m :: * -> *). M m => Text -> m () ViewConfig.remove_views prev :: Cmd.CmdL () prev :: CmdL () prev = Text -> CmdL () load Text "prev" -- * zoom -- | Copy the zoom factor from the given view to the selected one. This is -- useful when lining up parts. zoom_from :: Cmd.M m => ViewId -> m () zoom_from :: forall (m :: * -> *). M m => ViewId -> m () zoom_from ViewId from = do Double from_factor <- Zoom -> Double Zoom.factor forall b c a. (b -> c) -> (a -> b) -> a -> c . View -> Zoom Block.view_zoom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => ViewId -> m View Ui.get_view ViewId from ViewId to <- forall (m :: * -> *). M m => m ViewId Cmd.get_focused_view forall (m :: * -> *). M m => ViewId -> (Zoom -> Zoom) -> m () Views.modify_zoom ViewId to (\Zoom z -> Zoom z { factor :: Double Zoom.factor = Double from_factor })