module Chiasma.Pack where import Control.Lens (mapMOf_) import qualified Data.List.NonEmpty as NonEmpty (reverse, toList) import qualified Data.Set as Set (fromList, size) import Prettyprinter (Doc, line, pretty, (<+>)) import qualified Chiasma.Codec.Data.Window as Codec (Window (Window)) import Chiasma.Command.Pane (movePane, resizePane) import Chiasma.Data.Axis (Axis (Horizontal, Vertical)) import Chiasma.Data.TmuxId (PaneId) import Chiasma.Data.Views (Views) import Chiasma.Data.WindowState (WindowState (..)) import Chiasma.Effect.TmuxApi (Tmux) import Chiasma.Ui.Data.Measure (MLayout (..), MPane (..), MeasureTree, MeasureTreeSub, Measured (Measured)) import Chiasma.Ui.Data.Tree (Node (Leaf, Sub), Tree (Tree)) import qualified Chiasma.Ui.Data.Tree as Tree (subTree) import Chiasma.Ui.Measure (measureTree) import Chiasma.View (viewsLog) packPane :: Members [AtomicState Views, Tmux] r => PaneId -> Axis -> PaneId -> Sem r () packPane :: forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => PaneId -> Axis -> PaneId -> Sem r () packPane PaneId refId Axis axis PaneId paneId = Bool -> Sem r () -> Sem r () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (PaneId paneId PaneId -> PaneId -> Bool forall a. Eq a => a -> a -> Bool /= PaneId refId) do PaneId -> PaneId -> Axis -> Sem r () forall (r :: EffectRow). Member Tmux r => PaneId -> PaneId -> Axis -> Sem r () movePane PaneId paneId PaneId refId Axis axis positionView :: Members [AtomicState Views, Tmux] r => Axis -> PaneId -> MeasureTreeSub -> Sem r () positionView :: forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => Axis -> PaneId -> MeasureTreeSub -> Sem r () positionView Axis axis PaneId refId = MeasureTreeSub -> Sem r () position where position :: MeasureTreeSub -> Sem r () position (Sub (Tree (Measured Int _ (MLayout PaneId layoutRef Int _ Int _ Axis _)) NonEmpty MeasureTreeSub _)) = PaneId -> Axis -> PaneId -> Sem r () forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => PaneId -> Axis -> PaneId -> Sem r () packPane PaneId refId Axis axis PaneId layoutRef position (Leaf (Measured Int _ (MPane PaneId paneId Int _ Int _))) = PaneId -> Axis -> PaneId -> Sem r () forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => PaneId -> Axis -> PaneId -> Sem r () packPane PaneId refId Axis axis PaneId paneId describeAxis :: Axis -> Doc a describeAxis :: forall a. Axis -> Doc a describeAxis = \case Axis Vertical -> Doc a "vertically" Axis Horizontal -> Doc a "horizontally" resizeView :: Members [AtomicState Views, Tmux] r => Axis -> MeasureTreeSub -> Sem r () resizeView :: forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => Axis -> MeasureTreeSub -> Sem r () resizeView Axis axis = \case Sub (Tree (Measured Int size (MLayout PaneId refId Int _ Int _ Axis _)) NonEmpty MeasureTreeSub _) -> do Doc AnsiStyle -> Sem r () forall (r :: EffectRow). Member (AtomicState Views) r => Doc AnsiStyle -> Sem r () viewsLog (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 forall ann. PaneId -> 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 ann. Int -> Doc ann 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 <+> Axis -> Doc AnsiStyle forall a. Axis -> Doc a describeAxis Axis axis) PaneId -> Axis -> Int -> Sem r () forall (r :: EffectRow). Member Tmux r => PaneId -> Axis -> Int -> Sem r () resizePane PaneId refId Axis axis Int size Leaf (Measured Int size (MPane PaneId paneId Int _ Int _)) -> do Doc AnsiStyle -> Sem r () forall (r :: EffectRow). Member (AtomicState Views) r => Doc AnsiStyle -> Sem r () viewsLog (Doc AnsiStyle -> Sem r ()) -> Doc AnsiStyle -> Sem r () 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 forall ann. PaneId -> 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 ann. Int -> Doc ann 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 <+> Axis -> Doc AnsiStyle forall a. Axis -> Doc a describeAxis Axis axis PaneId -> Axis -> Int -> Sem r () forall (r :: EffectRow). Member Tmux r => PaneId -> Axis -> Int -> Sem r () resizePane PaneId paneId Axis axis 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 a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [Int] positions unaligned :: Bool unaligned = NonEmpty MeasureTreeSub -> Int forall a. NonEmpty a -> 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 _ Axis _)) 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 Axis _)) f (Node f (Measured MLayout) (Measured MPane)) _)) = Int offPos offPosition (Leaf (Measured Int _ (MPane PaneId _ Int _ Int offPos))) = Int offPos packTree :: Members [AtomicState Views, Tmux] r => MeasureTree -> Sem r () packTree :: forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => Tree NonEmpty (Measured MLayout) (Measured MPane) -> Sem r () packTree = Tree NonEmpty (Measured MLayout) (Measured MPane) -> Sem r () forall {r :: EffectRow}. (Member (AtomicState Views) r, Member Tmux r) => Tree NonEmpty (Measured MLayout) (Measured MPane) -> Sem r () pack where pack :: Tree NonEmpty (Measured MLayout) (Measured MPane) -> Sem r () pack (Tree (Measured Int _ (MLayout PaneId ref Int _ Int _ Axis axis)) NonEmpty MeasureTreeSub sub) = do Bool -> Sem r () -> Sem r () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool needPos Sem r () runPos Getting (Sequenced () (Sem r)) (NonEmpty MeasureTreeSub) (Tree NonEmpty (Measured MLayout) (Measured MPane)) -> (Tree NonEmpty (Measured MLayout) (Measured MPane) -> Sem r ()) -> NonEmpty MeasureTreeSub -> Sem r () forall (m :: * -> *) r s a. Monad m => Getting (Sequenced r m) s a -> (a -> m r) -> s -> m () mapMOf_ ((MeasureTreeSub -> Const (Sequenced () (Sem r)) MeasureTreeSub) -> NonEmpty MeasureTreeSub -> Const (Sequenced () (Sem r)) (NonEmpty MeasureTreeSub) forall s t a b. Each s t a b => Traversal s t a b Traversal (NonEmpty MeasureTreeSub) (NonEmpty MeasureTreeSub) MeasureTreeSub MeasureTreeSub each ((MeasureTreeSub -> Const (Sequenced () (Sem r)) MeasureTreeSub) -> NonEmpty MeasureTreeSub -> Const (Sequenced () (Sem r)) (NonEmpty MeasureTreeSub)) -> ((Tree NonEmpty (Measured MLayout) (Measured MPane) -> Const (Sequenced () (Sem r)) (Tree NonEmpty (Measured MLayout) (Measured MPane))) -> MeasureTreeSub -> Const (Sequenced () (Sem r)) MeasureTreeSub) -> Getting (Sequenced () (Sem r)) (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 () (Sem r)) (Tree NonEmpty (Measured MLayout) (Measured MPane))) -> MeasureTreeSub -> Const (Sequenced () (Sem r)) MeasureTreeSub forall c (f :: * -> *) l p. HasNode c f l p => Traversal' c (Tree f l p) Traversal' MeasureTreeSub (Tree NonEmpty (Measured MLayout) (Measured MPane)) Tree.subTree) Tree NonEmpty (Measured MLayout) (Measured MPane) -> Sem r () pack NonEmpty MeasureTreeSub sub (MeasureTreeSub -> Sem r ()) -> NonEmpty MeasureTreeSub -> Sem r () forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ (Axis -> MeasureTreeSub -> Sem r () forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => Axis -> MeasureTreeSub -> Sem r () resizeView Axis axis) NonEmpty MeasureTreeSub sub where needPos :: Bool needPos = NonEmpty MeasureTreeSub -> Bool needPositioning NonEmpty MeasureTreeSub sub runPos :: Sem r () runPos = do Doc AnsiStyle -> Sem r () forall (r :: EffectRow). Member (AtomicState Views) r => Doc AnsiStyle -> Sem r () viewsLog (Doc AnsiStyle -> Sem r ()) -> Doc AnsiStyle -> Sem r () 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 ann. NonEmpty MeasureTreeSub -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty NonEmpty MeasureTreeSub sub (MeasureTreeSub -> Sem r ()) -> NonEmpty MeasureTreeSub -> Sem r () forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ (Axis -> PaneId -> MeasureTreeSub -> Sem r () forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => Axis -> PaneId -> MeasureTreeSub -> Sem r () positionView Axis axis PaneId ref) (NonEmpty MeasureTreeSub -> NonEmpty MeasureTreeSub forall a. NonEmpty a -> NonEmpty a NonEmpty.reverse NonEmpty MeasureTreeSub sub) packWindow :: Members [AtomicState Views, Tmux] r => WindowState -> Sem r () packWindow :: forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => WindowState -> Sem r () 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 -> Sem r () forall (r :: EffectRow). Member (AtomicState Views) r => Doc AnsiStyle -> Sem r () viewsLog (Doc AnsiStyle -> Sem r ()) -> Doc AnsiStyle -> Sem r () 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 forall ann. Tree NonEmpty (Measured MLayout) (Measured MPane) -> Doc ann pretty Tree NonEmpty (Measured MLayout) (Measured MPane) measures Tree NonEmpty (Measured MLayout) (Measured MPane) -> Sem r () forall (r :: EffectRow). Members '[AtomicState Views, Tmux] r => Tree NonEmpty (Measured MLayout) (Measured MPane) -> Sem r () packTree Tree NonEmpty (Measured MLayout) (Measured MPane) measures