module Chiasma.Pack where import qualified Chiasma.Codec.Data as Codec (Window(Window)) import Chiasma.Command.Pane (movePane, resizePane) import Chiasma.Data.TmuxId (PaneId) import Chiasma.Data.TmuxThunk (TmuxThunk) import Chiasma.Data.Views (Views) import Chiasma.Data.WindowState (WindowState(..)) import Chiasma.Ui.Data.Measure (MLayout(..), MPane(..), MeasureTree, MeasureTreeSub, Measured(Measured)) import Chiasma.Ui.Data.Tree (Node(Sub, Leaf), Tree(Tree)) import qualified Chiasma.Ui.Data.Tree as Tree (subTree) import Chiasma.Ui.Measure (measureTree) import Chiasma.View (viewsLog) import Control.Lens (each, mapMOf_) import Control.Monad.Free.Class (MonadFree) import qualified Data.List.NonEmpty as NonEmpty (reverse, toList) import qualified Data.Set as Set (fromList, size) import Data.Text.Prettyprint.Doc (Doc, line, pretty, (<+>)) packPane :: (MonadDeepState s Views m, MonadFree TmuxThunk m) => PaneId -> Bool -> PaneId -> m () packPane :: PaneId -> Bool -> PaneId -> m () packPane PaneId refId Bool vertical PaneId paneId = Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (PaneId paneId PaneId -> PaneId -> Bool forall a. Eq a => a -> a -> Bool /= PaneId refId) (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ PaneId -> PaneId -> Bool -> m () forall (m :: * -> *). MonadFree TmuxThunk m => PaneId -> PaneId -> Bool -> m () movePane PaneId paneId PaneId refId Bool vertical positionView :: (MonadDeepState s Views m, MonadFree TmuxThunk m) => Bool -> PaneId -> MeasureTreeSub -> m () positionView :: Bool -> PaneId -> MeasureTreeSub -> m () positionView Bool vertical PaneId refId = MeasureTreeSub -> m () position where position :: MeasureTreeSub -> m () position (Sub (Tree (Measured Int _ (MLayout PaneId layoutRef Int _ Int _ Bool _)) NonEmpty MeasureTreeSub _)) = PaneId -> Bool -> PaneId -> m () forall s (m :: * -> *). (MonadDeepState s Views m, MonadFree TmuxThunk m) => PaneId -> Bool -> PaneId -> m () packPane PaneId refId Bool vertical PaneId layoutRef position (Leaf (Measured Int _ (MPane PaneId paneId Int _ Int _))) = PaneId -> Bool -> PaneId -> m () forall s (m :: * -> *). (MonadDeepState s Views m, MonadFree TmuxThunk m) => PaneId -> Bool -> PaneId -> m () packPane PaneId refId Bool vertical PaneId paneId describeVertical :: Bool -> Doc a describeVertical :: Bool -> Doc a describeVertical Bool True = Doc a "vertically" describeVertical Bool False = Doc a "horizontally" resizeView :: MonadDeepState s Views m => MonadFree TmuxThunk m => Bool -> MeasureTreeSub -> m () resizeView :: Bool -> MeasureTreeSub -> m () resizeView Bool vertical (Sub (Tree (Measured Int size (MLayout PaneId refId Int _ Int _ Bool _)) NonEmpty MeasureTreeSub _)) = do Doc AnsiStyle -> m () forall s (m :: * -> *). MonadDeepState s Views m => Doc AnsiStyle -> m () viewsLog (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m () forall a b. (a -> b) -> a -> b $ Doc AnsiStyle "resizing layout with ref" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall ann. Doc ann -> Doc ann -> Doc ann <+> PaneId -> Doc AnsiStyle forall a ann. Pretty a => a -> Doc ann pretty PaneId refId Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc AnsiStyle "to" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall ann. Doc ann -> Doc ann -> Doc ann <+> Int -> Doc AnsiStyle forall a ann. Pretty a => a -> Doc ann pretty Int size Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall ann. Doc ann -> Doc ann -> Doc ann <+> Bool -> Doc AnsiStyle forall a. Bool -> Doc a describeVertical Bool vertical PaneId -> Bool -> Int -> m () forall (m :: * -> *). MonadFree TmuxThunk m => PaneId -> Bool -> Int -> m () resizePane PaneId refId Bool vertical Int size resizeView Bool vertical (Leaf (Measured Int size (MPane PaneId paneId Int _ Int _))) = do Doc AnsiStyle -> m () forall s (m :: * -> *). MonadDeepState s Views m => Doc AnsiStyle -> m () viewsLog (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m () forall a b. (a -> b) -> a -> b $ Doc AnsiStyle "resizing pane" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall ann. Doc ann -> Doc ann -> Doc ann <+> PaneId -> Doc AnsiStyle forall a ann. Pretty a => a -> Doc ann pretty PaneId paneId Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc AnsiStyle "to" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall ann. Doc ann -> Doc ann -> Doc ann <+> Int -> Doc AnsiStyle forall a ann. Pretty a => a -> Doc ann pretty Int size Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall ann. Doc ann -> Doc ann -> Doc ann <+> Bool -> Doc AnsiStyle forall a. Bool -> Doc a describeVertical Bool vertical PaneId -> Bool -> Int -> m () forall (m :: * -> *). MonadFree TmuxThunk m => PaneId -> Bool -> Int -> m () resizePane PaneId paneId Bool vertical Int size needPositioning :: NonEmpty MeasureTreeSub -> Bool needPositioning :: NonEmpty MeasureTreeSub -> Bool needPositioning NonEmpty MeasureTreeSub sub = Bool wrongOrder Bool -> Bool -> Bool || Bool wrongDirection Bool -> Bool -> Bool || Bool unaligned where wrongOrder :: Bool wrongOrder = [Int] -> [Int] forall a. Ord a => [a] -> [a] sort [Int] positions [Int] -> [Int] -> Bool forall a. Eq a => a -> a -> Bool /= [Int] positions wrongDirection :: Bool wrongDirection = Set Int -> Int forall a. Set a -> Int Set.size ([Int] -> Set Int forall a. Ord a => [a] -> Set a Set.fromList [Int] positions) Int -> Int -> Bool forall a. Eq a => a -> a -> Bool /= [Int] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [Int] positions unaligned :: Bool unaligned = NonEmpty MeasureTreeSub -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length NonEmpty MeasureTreeSub sub Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int 1 Bool -> Bool -> Bool && Set Int -> Int forall a. Set a -> Int Set.size ([Int] -> Set Int forall a. Ord a => [a] -> Set a Set.fromList [Int] offPositions) Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int 1 positions :: [Int] positions = NonEmpty Int -> [Int] forall a. NonEmpty a -> [a] NonEmpty.toList (NonEmpty Int -> [Int]) -> NonEmpty Int -> [Int] forall a b. (a -> b) -> a -> b $ MeasureTreeSub -> Int forall (f :: * -> *). Node f (Measured MLayout) (Measured MPane) -> Int position (MeasureTreeSub -> Int) -> NonEmpty MeasureTreeSub -> NonEmpty Int forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> NonEmpty MeasureTreeSub sub position :: Node f (Measured MLayout) (Measured MPane) -> Int position (Sub (Tree (Measured Int _ (MLayout PaneId _ Int mainPos Int _ Bool _)) f (Node f (Measured MLayout) (Measured MPane)) _)) = Int mainPos position (Leaf (Measured Int _ (MPane PaneId _ Int mainPos Int _))) = Int mainPos offPositions :: [Int] offPositions = NonEmpty Int -> [Int] forall a. NonEmpty a -> [a] NonEmpty.toList (NonEmpty Int -> [Int]) -> NonEmpty Int -> [Int] forall a b. (a -> b) -> a -> b $ MeasureTreeSub -> Int forall (f :: * -> *). Node f (Measured MLayout) (Measured MPane) -> Int offPosition (MeasureTreeSub -> Int) -> NonEmpty MeasureTreeSub -> NonEmpty Int forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> NonEmpty MeasureTreeSub sub offPosition :: Node f (Measured MLayout) (Measured MPane) -> Int offPosition (Sub (Tree (Measured Int _ (MLayout PaneId _ Int _ Int offPos Bool _)) f (Node f (Measured MLayout) (Measured MPane)) _)) = Int offPos offPosition (Leaf (Measured Int _ (MPane PaneId _ Int _ Int offPos))) = Int offPos packTree :: (MonadDeepState s Views m, MonadFree TmuxThunk m) => MeasureTree -> m () packTree :: Tree NonEmpty (Measured MLayout) (Measured MPane) -> m () packTree = Tree NonEmpty (Measured MLayout) (Measured MPane) -> m () forall s (m :: * -> *). (MonadDeepState s Views m, MonadFree TmuxThunk m) => Tree NonEmpty (Measured MLayout) (Measured MPane) -> m () pack where pack :: Tree NonEmpty (Measured MLayout) (Measured MPane) -> m () pack (Tree (Measured Int _ (MLayout PaneId ref Int _ Int _ Bool vertical)) NonEmpty MeasureTreeSub sub) = do Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool needPos m () runPos Getting (Sequenced () m) (NonEmpty MeasureTreeSub) (Tree NonEmpty (Measured MLayout) (Measured MPane)) -> (Tree NonEmpty (Measured MLayout) (Measured MPane) -> m ()) -> NonEmpty MeasureTreeSub -> m () forall (m :: * -> *) r s a. Monad m => Getting (Sequenced r m) s a -> (a -> m r) -> s -> m () mapMOf_ ((MeasureTreeSub -> Const (Sequenced () m) MeasureTreeSub) -> NonEmpty MeasureTreeSub -> Const (Sequenced () m) (NonEmpty MeasureTreeSub) forall s t a b. Each s t a b => Traversal s t a b each ((MeasureTreeSub -> Const (Sequenced () m) MeasureTreeSub) -> NonEmpty MeasureTreeSub -> Const (Sequenced () m) (NonEmpty MeasureTreeSub)) -> ((Tree NonEmpty (Measured MLayout) (Measured MPane) -> Const (Sequenced () m) (Tree NonEmpty (Measured MLayout) (Measured MPane))) -> MeasureTreeSub -> Const (Sequenced () m) MeasureTreeSub) -> Getting (Sequenced () m) (NonEmpty MeasureTreeSub) (Tree NonEmpty (Measured MLayout) (Measured MPane)) forall b c a. (b -> c) -> (a -> b) -> a -> c . (Tree NonEmpty (Measured MLayout) (Measured MPane) -> Const (Sequenced () m) (Tree NonEmpty (Measured MLayout) (Measured MPane))) -> MeasureTreeSub -> Const (Sequenced () m) MeasureTreeSub forall c (f :: * -> *) l p. HasNode c f l p => Traversal' c (Tree f l p) Tree.subTree) Tree NonEmpty (Measured MLayout) (Measured MPane) -> m () pack NonEmpty MeasureTreeSub sub (MeasureTreeSub -> m ()) -> NonEmpty MeasureTreeSub -> m () forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ (Bool -> MeasureTreeSub -> m () forall s (m :: * -> *). (MonadDeepState s Views m, MonadFree TmuxThunk m) => Bool -> MeasureTreeSub -> m () resizeView Bool vertical) NonEmpty MeasureTreeSub sub where needPos :: Bool needPos = NonEmpty MeasureTreeSub -> Bool needPositioning NonEmpty MeasureTreeSub sub runPos :: m () runPos = do Doc AnsiStyle -> m () forall s (m :: * -> *). MonadDeepState s Views m => Doc AnsiStyle -> m () viewsLog (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m () forall a b. (a -> b) -> a -> b $ Doc AnsiStyle "repositioning views" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall ann. Doc ann -> Doc ann -> Doc ann <+> NonEmpty MeasureTreeSub -> Doc AnsiStyle forall a ann. Pretty a => a -> Doc ann pretty NonEmpty MeasureTreeSub sub (MeasureTreeSub -> m ()) -> NonEmpty MeasureTreeSub -> m () forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ (Bool -> PaneId -> MeasureTreeSub -> m () forall s (m :: * -> *). (MonadDeepState s Views m, MonadFree TmuxThunk m) => Bool -> PaneId -> MeasureTreeSub -> m () positionView Bool vertical PaneId ref) (NonEmpty MeasureTreeSub -> NonEmpty MeasureTreeSub forall a. NonEmpty a -> NonEmpty a NonEmpty.reverse NonEmpty MeasureTreeSub sub) packWindow :: (MonadDeepState s Views m, MonadFree TmuxThunk m) => WindowState -> m () packWindow :: WindowState -> m () packWindow (WindowState (Codec.Window WindowId _ Int width Int height) Pane _ Ident _ RenderableTree tree PaneId _) = do let measures :: Tree NonEmpty (Measured MLayout) (Measured MPane) measures = RenderableTree -> Int -> Int -> Tree NonEmpty (Measured MLayout) (Measured MPane) measureTree RenderableTree tree Int width Int height Doc AnsiStyle -> m () forall s (m :: * -> *). MonadDeepState s Views m => Doc AnsiStyle -> m () viewsLog (Doc AnsiStyle -> m ()) -> Doc AnsiStyle -> m () forall a b. (a -> b) -> a -> b $ Doc AnsiStyle "measured tree:" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall a. Semigroup a => a -> a -> a <> Doc AnsiStyle forall ann. Doc ann line Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle forall a. Semigroup a => a -> a -> a <> Tree NonEmpty (Measured MLayout) (Measured MPane) -> Doc AnsiStyle forall a ann. Pretty a => a -> Doc ann pretty Tree NonEmpty (Measured MLayout) (Measured MPane) measures Tree NonEmpty (Measured MLayout) (Measured MPane) -> m () forall s (m :: * -> *). (MonadDeepState s Views m, MonadFree TmuxThunk m) => Tree NonEmpty (Measured MLayout) (Measured MPane) -> m () packTree Tree NonEmpty (Measured MLayout) (Measured MPane) measures