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