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