module System.Terminal.Emulator.Term.Resize
  ( resizeTerm,
  )
where

import Control.Category ((>>>))
import Control.Exception (assert)
import Control.Lens
import qualified Data.Vector.Unboxed as VU
import System.Terminal.Emulator.Term (Term, addScrollBackLines, altScreenActive, cursorPos, numCols, numRows, scrollBackLines, scrollBottom, scrollTop, termAlt, termAttrs, termScreen)
import System.Terminal.Emulator.TermLines (TermLine, TermLines)
import qualified System.Terminal.Emulator.TermLines as TL
import Prelude hiding (lines)

-- | This should be called when the user resizes the terminal window.
--
-- You should also call 'System.Posix.Pty.resizePty', but only afterwards
--
-- The tuple is in the shape @(newWidth, newHeight)@, both must be positive
resizeTerm :: Term -> (Int, Int) -> Term
resizeTerm :: Term -> (Int, Int) -> Term
resizeTerm Term
term (Int
newWidth, Int
newHeight) =
  Bool -> Term -> Term
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
newWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$
    Bool -> Term -> Term
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
newHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$
      ( Int -> Term -> Term
resizeTermWidth Int
newWidth
          (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Int -> Term -> Term
resizeTermHeight Int
newHeight
          (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Identity Int) -> Term -> Identity Term
Lens' Term Int
scrollTop ((Int -> Identity Int) -> Term -> Identity Term)
-> Int -> Term -> Term
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
0
          (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Identity Int) -> Term -> Identity Term
Lens' Term Int
scrollBottom ((Int -> Identity Int) -> Term -> Identity Term)
-> Int -> Term -> Term
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Int
newHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      )
        Term
term

-- Internal function. Resize the terminal, only changing the width.
resizeTermWidth :: Int -> Term -> Term
resizeTermWidth :: Int -> Term -> Term
resizeTermWidth Int
newWidth Term
term =
  ( (Int -> Identity Int) -> Term -> Identity Term
Lens' Term Int
numCols ((Int -> Identity Int) -> Term -> Identity Term)
-> Int -> Term -> Term
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
newWidth
      (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (TermLines -> Identity TermLines) -> Term -> Identity Term
Lens' Term TermLines
termScreen ((TermLines -> Identity TermLines) -> Term -> Identity Term)
-> (TermLines -> TermLines) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TermLine -> TermLine) -> TermLines -> TermLines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TermLine -> TermLine
adjustLine
      (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (TermLines -> Identity TermLines) -> Term -> Identity Term
Lens' Term TermLines
termAlt ((TermLines -> Identity TermLines) -> Term -> Identity Term)
-> (TermLines -> TermLines) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TermLine -> TermLine) -> TermLines -> TermLines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TermLine -> TermLine
adjustLine
      (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (TermLines -> Identity TermLines) -> Term -> Identity Term
Lens' Term TermLines
scrollBackLines ((TermLines -> Identity TermLines) -> Term -> Identity Term)
-> (TermLines -> TermLines) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TermLine -> TermLine) -> TermLines -> TermLines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TermLine -> TermLine
adjustLine
      (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Int, Int) -> Identity (Int, Int)) -> Term -> Identity Term
Lens' Term (Int, Int)
cursorPos (((Int, Int) -> Identity (Int, Int)) -> Term -> Identity Term)
-> ((Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int))
-> (Int -> Identity Int)
-> Term
-> Identity Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Int -> Identity Int) -> Term -> Identity Term)
-> (Int -> Int) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
newWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  )
    Term
term
  where
    oldWidth :: Int
oldWidth = Term
term Term -> Getting Int Term Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Term Int
Lens' Term Int
numCols

    expandLine :: TermLine -> TermLine
    expandLine :: TermLine -> TermLine
expandLine = (TermLine -> TermLine -> TermLine
forall a. Semigroup a => a -> a -> a
<> (Int -> (Char, Attrs) -> TermLine
forall a. Unbox a => Int -> a -> Vector a
VU.replicate (Int
newWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldWidth) ((Char
' ', Attrs
0))))

    shrinkLine :: TermLine -> TermLine
    shrinkLine :: TermLine -> TermLine
shrinkLine = Int -> TermLine -> TermLine
forall a. Unbox a => Int -> Vector a -> Vector a
VU.take Int
newWidth

    adjustLine :: TermLine -> TermLine
    adjustLine :: TermLine -> TermLine
adjustLine
      | Int
newWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
oldWidth = TermLine -> TermLine
expandLine
      | Bool
otherwise = TermLine -> TermLine
shrinkLine

-- Internal function. Resize the terminal, only changing the height.
resizeTermHeight :: Int -> Term -> Term
resizeTermHeight :: Int -> Term -> Term
resizeTermHeight Int
newHeight Term
term
  | Int
newHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
oldHeight = Int -> Term -> Term
resizeTermHeight' Int
newHeight Term
term
  | Bool
otherwise =
    let term' :: Term
term' = Term -> Int -> Term
truncateTermScreenBottom Term
term (Int
oldHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
newHeight)
     in Int -> Term -> Term
resizeTermHeight' Int
newHeight Term
term'
  where
    oldHeight :: Int
oldHeight = Term
term Term -> Getting Int Term Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Term Int
Lens' Term Int
numRows

resizeTermHeight' :: Int -> Term -> Term
resizeTermHeight' :: Int -> Term -> Term
resizeTermHeight' Int
newHeight Term
term =
  ( (Int -> Identity Int) -> Term -> Identity Term
Lens' Term Int
numRows ((Int -> Identity Int) -> Term -> Identity Term)
-> Int -> Term -> Term
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
newHeight
      (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Term -> Term
adjustScreen
      (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (TermLines -> Identity TermLines) -> Term -> Identity Term
Lens' Term TermLines
termAlt ((TermLines -> Identity TermLines) -> Term -> Identity Term)
-> (TermLines -> TermLines) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TermLines -> TermLines
adjustAltScreen
      (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Int, Int) -> Identity (Int, Int)) -> Term -> Identity Term
Lens' Term (Int, Int)
cursorPos (((Int, Int) -> Identity (Int, Int)) -> Term -> Identity Term)
-> ((Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int))
-> (Int -> Identity Int)
-> Term
-> Identity Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((Int -> Identity Int) -> Term -> Identity Term)
-> (Int -> Int) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
newHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  )
    Term
term
  where
    oldHeight :: Int
oldHeight = Term
term Term -> Getting Int Term Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Term Int
Lens' Term Int
numRows

    newBlankLine :: TermLine
newBlankLine = Int -> (Char, Attrs) -> TermLine
forall a. Unbox a => Int -> a -> Vector a
VU.replicate (Term
term Term -> Getting Int Term Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Term Int
Lens' Term Int
numCols) (Char
' ', Term
term Term -> Getting Attrs Term Attrs -> Attrs
forall s a. s -> Getting a s a -> a
^. Getting Attrs Term Attrs
Lens' Term Attrs
termAttrs)

    expandAltScreen :: TermLines -> TermLines
    expandAltScreen :: TermLines -> TermLines
expandAltScreen = (TermLines -> TermLines -> TermLines
forall a. Semigroup a => a -> a -> a
<> (Int -> TermLine -> TermLines
forall a. Int -> a -> StrictSeq a
TL.replicate (Int
newHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldHeight) TermLine
newBlankLine))

    shrinkAltScreen :: TermLines -> TermLines
    shrinkAltScreen :: TermLines -> TermLines
shrinkAltScreen = Int -> TermLines -> TermLines
forall a. Int -> StrictSeq a -> StrictSeq a
TL.take Int
newHeight

    adjustAltScreen :: TermLines -> TermLines
    adjustAltScreen :: TermLines -> TermLines
adjustAltScreen
      | Int
newHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
oldHeight = TermLines -> TermLines
expandAltScreen
      | Bool
otherwise = TermLines -> TermLines
shrinkAltScreen

    expandScreen :: Term -> Term
    expandScreen :: Term -> Term
expandScreen =
      ( (TermLines -> Identity TermLines) -> Term -> Identity Term
Lens' Term TermLines
termScreen
          ((TermLines -> Identity TermLines) -> Term -> Identity Term)
-> (TermLines -> TermLines) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( \TermLines
lines ->
                 Int -> TermLines -> TermLines
forall a. Int -> StrictSeq a -> StrictSeq a
TL.takeLast Int
numHistoryLines (Term
term Term -> Getting TermLines Term TermLines -> TermLines
forall s a. s -> Getting a s a -> a
^. Getting TermLines Term TermLines
Lens' Term TermLines
scrollBackLines)
                   TermLines -> TermLines -> TermLines
forall a. Semigroup a => a -> a -> a
<> TermLines
lines
                   TermLines -> TermLines -> TermLines
forall a. Semigroup a => a -> a -> a
<> Int -> TermLine -> TermLines
forall a. Int -> a -> StrictSeq a
TL.replicate Int
numNewBlankLines TermLine
newBlankLine
             )
      )
        (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (TermLines -> Identity TermLines) -> Term -> Identity Term
Lens' Term TermLines
scrollBackLines ((TermLines -> Identity TermLines) -> Term -> Identity Term)
-> (TermLines -> TermLines) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> TermLines -> TermLines
forall a. Int -> StrictSeq a -> StrictSeq a
TL.dropLast Int
numHistoryLines
        (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Term -> Term
moveCursorDown
      where
        numHistoryLines :: Int
numHistoryLines = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
newHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldHeight) (TermLines -> Int
forall a. StrictSeq a -> Int
TL.length (Term
term Term -> Getting TermLines Term TermLines -> TermLines
forall s a. s -> Getting a s a -> a
^. Getting TermLines Term TermLines
Lens' Term TermLines
scrollBackLines))
        numNewBlankLines :: Int
numNewBlankLines = (Int
newHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldHeight) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numHistoryLines

        moveCursorDown :: Term -> Term
        moveCursorDown :: Term -> Term
moveCursorDown
          | Term
term Term -> Getting Bool Term Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Term Bool
Lens' Term Bool
altScreenActive = Term -> Term
forall a. a -> a
id
          | Bool
otherwise = ((Int, Int) -> Identity (Int, Int)) -> Term -> Identity Term
Lens' Term (Int, Int)
cursorPos (((Int, Int) -> Identity (Int, Int)) -> Term -> Identity Term)
-> ((Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int))
-> (Int -> Identity Int)
-> Term
-> Identity Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((Int -> Identity Int) -> Term -> Identity Term)
-> (Int -> Int) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numHistoryLines)

    shrinkScreen :: Term -> Term
    shrinkScreen :: Term -> Term
shrinkScreen =
      ((TermLines -> Identity TermLines) -> Term -> Identity Term
Lens' Term TermLines
termScreen ((TermLines -> Identity TermLines) -> Term -> Identity Term)
-> (TermLines -> TermLines) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> TermLines -> TermLines
forall a. Int -> StrictSeq a -> StrictSeq a
TL.takeLast Int
newHeight)
        (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> TermLines -> Term -> Term
addScrollBackLines (Int -> TermLines -> TermLines
forall a. Int -> StrictSeq a -> StrictSeq a
TL.take Int
numShrunkLines (Term
term Term -> Getting TermLines Term TermLines -> TermLines
forall s a. s -> Getting a s a -> a
^. Getting TermLines Term TermLines
Lens' Term TermLines
termScreen))
        (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Term -> Term
moveCursorUp
      where
        numShrunkLines :: Int
numShrunkLines = Int
oldHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
newHeight
        moveCursorUp :: Term -> Term
        moveCursorUp :: Term -> Term
moveCursorUp
          | Term
term Term -> Getting Bool Term Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Term Bool
Lens' Term Bool
altScreenActive = Term -> Term
forall a. a -> a
id
          | Bool
otherwise = ((Int, Int) -> Identity (Int, Int)) -> Term -> Identity Term
Lens' Term (Int, Int)
cursorPos (((Int, Int) -> Identity (Int, Int)) -> Term -> Identity Term)
-> ((Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int))
-> (Int -> Identity Int)
-> Term
-> Identity Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int) -> (Int, Int) -> Identity (Int, Int)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((Int -> Identity Int) -> Term -> Identity Term)
-> (Int -> Int) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (\Int
y -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numShrunkLines))

    adjustScreen :: Term -> Term
adjustScreen
      | Int
newHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
oldHeight = Term -> Term
expandScreen
      | Bool
otherwise = Term -> Term
shrinkScreen

-- | Chop off up to @n@ lines from the bottom of the main screen (only if they
-- are blank and not occupied by the cursor).
--
-- Also modifies the vertical size of the screen according to the number of
-- lines removed (numLines)
truncateTermScreenBottom :: Term -> Int -> Term
truncateTermScreenBottom :: Term -> Int -> Term
truncateTermScreenBottom Term
term Int
numLines
  | Int
numLines Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Term
term
  | Term
term Term -> Getting Bool Term Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Term Bool
Lens' Term Bool
altScreenActive = Term
term
  | Term
term Term -> Getting Int Term Int -> Int
forall s a. s -> Getting a s a -> a
^. ((Int, Int) -> Const Int (Int, Int)) -> Term -> Const Int Term
Lens' Term (Int, Int)
cursorPos (((Int, Int) -> Const Int (Int, Int)) -> Term -> Const Int Term)
-> ((Int -> Const Int Int) -> (Int, Int) -> Const Int (Int, Int))
-> Getting Int Term Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> (Int, Int) -> Const Int (Int, Int)
forall s t a b. Field1 s t a b => Lens s t a b
_1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Term
term Term -> Getting Int Term Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Term Int
Lens' Term Int
numRows Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 = Term
term
  | Bool -> Bool
not (TermLine -> Bool
lineIsBlank TermLine
lastLine) = Term
term
  | Bool
otherwise =
    let term' :: Term
term' =
          ( ((TermLines -> Identity TermLines) -> Term -> Identity Term
Lens' Term TermLines
termScreen ((TermLines -> Identity TermLines) -> Term -> Identity Term)
-> (TermLines -> TermLines) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> TermLines -> TermLines
forall a. Int -> StrictSeq a -> StrictSeq a
TL.dropLast Int
1))
              (Term -> Term) -> (Term -> Term) -> Term -> Term
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Int -> Identity Int) -> Term -> Identity Term
Lens' Term Int
numRows ((Int -> Identity Int) -> Term -> Identity Term)
-> (Int -> Int) -> Term -> Term
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1))
          )
            Term
term
     in Term -> Int -> Term
truncateTermScreenBottom Term
term' (Int
numLines Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  where
    lastLine :: TermLine
lastLine = TermLines -> TermLine
forall a. StrictSeq a -> a
TL.last (Term
term Term -> Getting TermLines Term TermLines -> TermLines
forall s a. s -> Getting a s a -> a
^. Getting TermLines Term TermLines
Lens' Term TermLines
termScreen)
    lineIsBlank :: TermLine -> Bool
    lineIsBlank :: TermLine -> Bool
lineIsBlank = ((Char, Attrs) -> Bool) -> TermLine -> Bool
forall a. Unbox a => (a -> Bool) -> Vector a -> Bool
VU.all ((Char, Attrs) -> (Char, Attrs) -> Bool
forall a. Eq a => a -> a -> Bool
== (Char
' ', Attrs
0))