{-|
Module: Data.Text.Zipper
Description: A zipper for text documents that allows convenient editing and navigation

'TextZipper' is designed to be help manipulate the contents of a text input field. It keeps track of the logical lines of text (i.e., lines separated by user-entered newlines) and the current cursor position. Several functions are defined in this module to navigate and edit the TextZipper from the cursor position.

'TextZipper's can be converted into 'DisplayLines', which describe how the contents of the zipper will be displayed when wrapped to fit within a container of a certain width. It also provides some convenience facilities for converting interactions with the rendered DisplayLines back into manipulations of the underlying TextZipper.

-}
module Data.Text.Zipper where

import Control.Exception (assert)
import Control.Monad
import Control.Monad.State (evalState, get, put)
import Data.Char (isSpace)
import Data.Map (Map)
import Data.String

import qualified Data.List as L
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Internal (Text(..), text)
import Data.Text.Internal.Fusion (stream)
import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))
import Data.Text.Unsafe

import Graphics.Text.Width (wcwidth)


-- | A zipper of the logical text input contents (the "document"). The lines
-- before the line containing the cursor are stored in reverse order.
-- The cursor is logically between the "before" and "after" text.
-- A "logical" line of input is a line of input up until a user-entered newline
-- character (as compared to a "display" line, which is wrapped to fit within
-- a given viewport width).
data TextZipper = TextZipper
  { TextZipper -> [Text]
_textZipper_linesBefore :: [Text] -- reversed
  , TextZipper -> Text
_textZipper_before :: Text
  , TextZipper -> Text
_textZipper_after :: Text -- The cursor is on top of the first character of this text
  , TextZipper -> [Text]
_textZipper_linesAfter :: [Text]
  }
  deriving (Int -> TextZipper -> ShowS
[TextZipper] -> ShowS
TextZipper -> String
(Int -> TextZipper -> ShowS)
-> (TextZipper -> String)
-> ([TextZipper] -> ShowS)
-> Show TextZipper
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextZipper] -> ShowS
$cshowList :: [TextZipper] -> ShowS
show :: TextZipper -> String
$cshow :: TextZipper -> String
showsPrec :: Int -> TextZipper -> ShowS
$cshowsPrec :: Int -> TextZipper -> ShowS
Show, TextZipper -> TextZipper -> Bool
(TextZipper -> TextZipper -> Bool)
-> (TextZipper -> TextZipper -> Bool) -> Eq TextZipper
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextZipper -> TextZipper -> Bool
$c/= :: TextZipper -> TextZipper -> Bool
== :: TextZipper -> TextZipper -> Bool
$c== :: TextZipper -> TextZipper -> Bool
Eq)

instance IsString TextZipper where
  fromString :: String -> TextZipper
fromString = Text -> TextZipper
fromText (Text -> TextZipper) -> (String -> Text) -> String -> TextZipper
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | Map a replacement function over the characters in a 'TextZipper'
mapZipper :: (Char -> Char) -> TextZipper -> TextZipper
mapZipper :: (Char -> Char) -> TextZipper -> TextZipper
mapZipper Char -> Char
f (TextZipper [Text]
lb Text
b Text
a [Text]
la) = TextZipper :: [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper
  { _textZipper_linesBefore :: [Text]
_textZipper_linesBefore = (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Char) -> Text -> Text
T.map Char -> Char
f) [Text]
lb
  , _textZipper_before :: Text
_textZipper_before = (Char -> Char) -> Text -> Text
T.map Char -> Char
f Text
b
  , _textZipper_after :: Text
_textZipper_after = (Char -> Char) -> Text -> Text
T.map Char -> Char
f Text
a
  , _textZipper_linesAfter :: [Text]
_textZipper_linesAfter = (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Char) -> Text -> Text
T.map Char -> Char
f) [Text]
la
  }

-- | Move the cursor left one character, if possible
left :: TextZipper -> TextZipper
left :: TextZipper -> TextZipper
left = Int -> TextZipper -> TextZipper
leftN Int
1

-- | Move the cursor left by the given number of characters, or, if the document
-- isn't long enough, to the beginning of the document
leftN :: Int -> TextZipper -> TextZipper
leftN :: Int -> TextZipper -> TextZipper
leftN Int
n z :: TextZipper
z@(TextZipper [Text]
lb Text
b Text
a [Text]
la) =
  if Text -> Int
T.length Text
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
    then
      let n' :: Int
n' = Text -> Int
T.length Text
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n
      in  [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb (Int -> Text -> Text
T.take Int
n' Text
b) (Int -> Text -> Text
T.drop Int
n' Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a) [Text]
la
    else case [Text]
lb of
           [] -> TextZipper -> TextZipper
home TextZipper
z
           (Text
l:[Text]
ls) -> Int -> TextZipper -> TextZipper
leftN (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
ls Text
l Text
"" ((Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
la)

-- | Move the cursor right one character, if possible
right :: TextZipper -> TextZipper
right :: TextZipper -> TextZipper
right = Int -> TextZipper -> TextZipper
rightN Int
1

-- | Move the character right by the given number of characters, or, if the document
-- isn't long enough, to the end of the document
rightN :: Int -> TextZipper -> TextZipper
rightN :: Int -> TextZipper -> TextZipper
rightN Int
n z :: TextZipper
z@(TextZipper [Text]
lb Text
b Text
a [Text]
la) =
  if Text -> Int
T.length Text
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
    then [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb (Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.take Int
n Text
a) (Int -> Text -> Text
T.drop Int
n Text
a) [Text]
la
    else case [Text]
la of
           [] -> TextZipper -> TextZipper
end TextZipper
z
           (Text
l:[Text]
ls) -> Int -> TextZipper -> TextZipper
rightN (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper ((Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
lb) Text
"" Text
l [Text]
ls

-- | Move the cursor up one logical line, if possible
up :: TextZipper -> TextZipper
up :: TextZipper -> TextZipper
up z :: TextZipper
z@(TextZipper [Text]
lb Text
b Text
a [Text]
la) = case [Text]
lb of
  [] -> TextZipper
z
  (Text
l:[Text]
ls) ->
    let (Text
b', Text
a') = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
b) Text
l
    in [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
ls Text
b' Text
a' ((Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
la)

-- | Move the cursor down one logical line, if possible
down :: TextZipper -> TextZipper
down :: TextZipper -> TextZipper
down z :: TextZipper
z@(TextZipper [Text]
lb Text
b Text
a [Text]
la) = case [Text]
la of
  [] -> TextZipper
z
  (Text
l:[Text]
ls) ->
    let (Text
b', Text
a') = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
b) Text
l
    in [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper ((Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
lb) Text
b' Text
a' [Text]
ls

-- | Move the cursor up by the given number of lines
pageUp :: Int -> TextZipper -> TextZipper
pageUp :: Int -> TextZipper -> TextZipper
pageUp Int
pageSize TextZipper
z = if Int
pageSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
  then TextZipper
z
  else Int -> TextZipper -> TextZipper
pageUp (Int
pageSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall a b. (a -> b) -> a -> b
$ TextZipper -> TextZipper
up TextZipper
z

-- | Move the cursor down by the given number of lines
pageDown :: Int -> TextZipper -> TextZipper
pageDown :: Int -> TextZipper -> TextZipper
pageDown Int
pageSize TextZipper
z = if Int
pageSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
  then TextZipper
z
  else Int -> TextZipper -> TextZipper
pageDown (Int
pageSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall a b. (a -> b) -> a -> b
$ TextZipper -> TextZipper
down TextZipper
z

-- | Move the cursor to the beginning of the current logical line
home :: TextZipper -> TextZipper
home :: TextZipper -> TextZipper
home (TextZipper [Text]
lb Text
b Text
a [Text]
la) = [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb Text
"" (Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a) [Text]
la

-- | Move the cursor to the end of the current logical line
end :: TextZipper -> TextZipper
end :: TextZipper -> TextZipper
end (TextZipper [Text]
lb Text
b Text
a [Text]
la) = [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb (Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a) Text
"" [Text]
la

-- | Move the cursor to the top of the document
top :: TextZipper -> TextZipper
top :: TextZipper -> TextZipper
top (TextZipper [Text]
lb Text
b Text
a [Text]
la) = case [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
lb of
  [] -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [] Text
"" (Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a) [Text]
la
  (Text
start:[Text]
rest) -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [] Text
"" Text
start ([Text]
rest [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
la)

-- | Insert a character at the current cursor position
insertChar :: Char -> TextZipper -> TextZipper
insertChar :: Char -> TextZipper -> TextZipper
insertChar Char
i = Text -> TextZipper -> TextZipper
insert (Char -> Text
T.singleton Char
i)

-- | Insert text at the current cursor position
insert :: Text -> TextZipper -> TextZipper
insert :: Text -> TextZipper -> TextZipper
insert Text
i z :: TextZipper
z@(TextZipper [Text]
lb Text
b Text
a [Text]
la) = case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') Text
i of
  [] -> TextZipper
z
  (Text
start:[Text]
rest) -> case [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
rest of
    [] -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb (Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
start) Text
a [Text]
la
    (Text
l:[Text]
ls) -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper ([Text]
ls [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
start] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
lb) Text
l Text
a [Text]
la

-- | Delete the character to the left of the cursor
deleteLeft :: TextZipper-> TextZipper
deleteLeft :: TextZipper -> TextZipper
deleteLeft z :: TextZipper
z@(TextZipper [Text]
lb Text
b Text
a [Text]
la) = case Text -> Maybe (Text, Char)
T.unsnoc Text
b of
  Maybe (Text, Char)
Nothing -> case [Text]
lb of
    [] -> TextZipper
z
    (Text
l:[Text]
ls) -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
ls Text
l Text
a [Text]
la
  Just (Text
b', Char
_) -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb Text
b' Text
a [Text]
la

-- | Delete the character under/to the right of the cursor
deleteRight :: TextZipper -> TextZipper
deleteRight :: TextZipper -> TextZipper
deleteRight z :: TextZipper
z@(TextZipper [Text]
lb Text
b Text
a [Text]
la) = case Text -> Maybe (Char, Text)
T.uncons Text
a of
  Maybe (Char, Text)
Nothing -> case [Text]
la of
    [] -> TextZipper
z
    (Text
l:[Text]
ls) -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb Text
b Text
l [Text]
ls
  Just (Char
_, Text
a') -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb Text
b Text
a' [Text]
la

-- | Delete a word to the left of the cursor. Deletes all whitespace until it
-- finds a non-whitespace character, and then deletes contiguous non-whitespace
-- characters.
deleteLeftWord :: TextZipper -> TextZipper
deleteLeftWord :: TextZipper -> TextZipper
deleteLeftWord (TextZipper [Text]
lb Text
b Text
a [Text]
la) =
  let b' :: Text
b' = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isSpace Text
b
  in  if Text -> Bool
T.null Text
b'
        then case [Text]
lb of
          [] -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [] Text
b' Text
a [Text]
la
          (Text
l:[Text]
ls) -> TextZipper -> TextZipper
deleteLeftWord (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
ls Text
l Text
a [Text]
la
        else [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb ((Char -> Bool) -> Text -> Text
T.dropWhileEnd (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
b') Text
a [Text]
la

-- | Insert up to n spaces to get to the next logical column that is a multiple of n
tab :: Int -> TextZipper -> TextZipper
tab :: Int -> TextZipper -> TextZipper
tab Int
n z :: TextZipper
z@(TextZipper [Text]
_ Text
b Text
_ [Text]
_) =
  Text -> TextZipper -> TextZipper
insert (Int -> Text -> Text
T.replicate (Int -> Int
forall a. Enum a => a -> Int
fromEnum (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
b Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n) Text
" ") TextZipper
z

-- | The plain text contents of the zipper
value :: TextZipper -> Text
value :: TextZipper -> Text
value (TextZipper [Text]
lb Text
b Text
a [Text]
la) = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall a. Monoid a => [a] -> a
mconcat [ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
lb
  , [Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a]
  , [Text]
la
  ]

-- | The empty zipper
empty :: TextZipper
empty :: TextZipper
empty = [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [] Text
"" Text
"" []

-- | Constructs a zipper with the given contents. The cursor is placed after
-- the contents.
fromText :: Text -> TextZipper
fromText :: Text -> TextZipper
fromText = (Text -> TextZipper -> TextZipper)
-> TextZipper -> Text -> TextZipper
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> TextZipper -> TextZipper
insert TextZipper
empty

-- | A span of text tagged with some metadata that makes up part of a display
-- line.
data Span tag = Span tag Text
  deriving (Span tag -> Span tag -> Bool
(Span tag -> Span tag -> Bool)
-> (Span tag -> Span tag -> Bool) -> Eq (Span tag)
forall tag. Eq tag => Span tag -> Span tag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Span tag -> Span tag -> Bool
$c/= :: forall tag. Eq tag => Span tag -> Span tag -> Bool
== :: Span tag -> Span tag -> Bool
$c== :: forall tag. Eq tag => Span tag -> Span tag -> Bool
Eq, Int -> Span tag -> ShowS
[Span tag] -> ShowS
Span tag -> String
(Int -> Span tag -> ShowS)
-> (Span tag -> String) -> ([Span tag] -> ShowS) -> Show (Span tag)
forall tag. Show tag => Int -> Span tag -> ShowS
forall tag. Show tag => [Span tag] -> ShowS
forall tag. Show tag => Span tag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Span tag] -> ShowS
$cshowList :: forall tag. Show tag => [Span tag] -> ShowS
show :: Span tag -> String
$cshow :: forall tag. Show tag => Span tag -> String
showsPrec :: Int -> Span tag -> ShowS
$cshowsPrec :: forall tag. Show tag => Int -> Span tag -> ShowS
Show)

-- | Text alignment type
data TextAlignment =
  TextAlignment_Left
  | TextAlignment_Right
  | TextAlignment_Center
  deriving (TextAlignment -> TextAlignment -> Bool
(TextAlignment -> TextAlignment -> Bool)
-> (TextAlignment -> TextAlignment -> Bool) -> Eq TextAlignment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextAlignment -> TextAlignment -> Bool
$c/= :: TextAlignment -> TextAlignment -> Bool
== :: TextAlignment -> TextAlignment -> Bool
$c== :: TextAlignment -> TextAlignment -> Bool
Eq, Int -> TextAlignment -> ShowS
[TextAlignment] -> ShowS
TextAlignment -> String
(Int -> TextAlignment -> ShowS)
-> (TextAlignment -> String)
-> ([TextAlignment] -> ShowS)
-> Show TextAlignment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextAlignment] -> ShowS
$cshowList :: [TextAlignment] -> ShowS
show :: TextAlignment -> String
$cshow :: TextAlignment -> String
showsPrec :: Int -> TextAlignment -> ShowS
$cshowsPrec :: Int -> TextAlignment -> ShowS
Show)

-- | A map from the index (row) of display line to (fst,snd)
-- fst: leading empty spaces from left (may be negative) to adjust for alignment
-- snd: the text offset from the beginning of the document
-- to the first character of the display line
type OffsetMapWithAlignment = Map Int (Int, Int)

-- | Helper type representing a single visual line that may be part of a wrapped logical line
data WrappedLine = WrappedLine
  { WrappedLine -> Text
_wrappedLines_text :: Text
  , WrappedLine -> Bool
_wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character
  , WrappedLine -> Int
_wrappedLines_offset :: Int -- ^ offset from beginning of line
  }
  deriving (WrappedLine -> WrappedLine -> Bool
(WrappedLine -> WrappedLine -> Bool)
-> (WrappedLine -> WrappedLine -> Bool) -> Eq WrappedLine
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WrappedLine -> WrappedLine -> Bool
$c/= :: WrappedLine -> WrappedLine -> Bool
== :: WrappedLine -> WrappedLine -> Bool
$c== :: WrappedLine -> WrappedLine -> Bool
Eq, Int -> WrappedLine -> ShowS
[WrappedLine] -> ShowS
WrappedLine -> String
(Int -> WrappedLine -> ShowS)
-> (WrappedLine -> String)
-> ([WrappedLine] -> ShowS)
-> Show WrappedLine
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WrappedLine] -> ShowS
$cshowList :: [WrappedLine] -> ShowS
show :: WrappedLine -> String
$cshow :: WrappedLine -> String
showsPrec :: Int -> WrappedLine -> ShowS
$cshowsPrec :: Int -> WrappedLine -> ShowS
Show)

-- | Information about the document as it is displayed (i.e., post-wrapping)
data DisplayLines tag = DisplayLines {
    DisplayLines tag -> [[Span tag]]
_displayLines_spans :: [[Span tag]]
    -- ^ NOTE this will contain a dummy space character if the cursor is at the end
    , DisplayLines tag -> OffsetMapWithAlignment
_displayLines_offsetMap :: OffsetMapWithAlignment
    -- ^ NOTE this will not include offsets for the y position of dummy ' ' character if it is on its own line
    , DisplayLines tag -> (Int, Int)
_displayLines_cursorPos :: (Int, Int) -- ^ cursor position relative to upper left hand corner
  }
  deriving (DisplayLines tag -> DisplayLines tag -> Bool
(DisplayLines tag -> DisplayLines tag -> Bool)
-> (DisplayLines tag -> DisplayLines tag -> Bool)
-> Eq (DisplayLines tag)
forall tag. Eq tag => DisplayLines tag -> DisplayLines tag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DisplayLines tag -> DisplayLines tag -> Bool
$c/= :: forall tag. Eq tag => DisplayLines tag -> DisplayLines tag -> Bool
== :: DisplayLines tag -> DisplayLines tag -> Bool
$c== :: forall tag. Eq tag => DisplayLines tag -> DisplayLines tag -> Bool
Eq, Int -> DisplayLines tag -> ShowS
[DisplayLines tag] -> ShowS
DisplayLines tag -> String
(Int -> DisplayLines tag -> ShowS)
-> (DisplayLines tag -> String)
-> ([DisplayLines tag] -> ShowS)
-> Show (DisplayLines tag)
forall tag. Show tag => Int -> DisplayLines tag -> ShowS
forall tag. Show tag => [DisplayLines tag] -> ShowS
forall tag. Show tag => DisplayLines tag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DisplayLines tag] -> ShowS
$cshowList :: forall tag. Show tag => [DisplayLines tag] -> ShowS
show :: DisplayLines tag -> String
$cshow :: forall tag. Show tag => DisplayLines tag -> String
showsPrec :: Int -> DisplayLines tag -> ShowS
$cshowsPrec :: forall tag. Show tag => Int -> DisplayLines tag -> ShowS
Show)

-- | Split a 'Text' at the given column index. For example
--
-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
--
-- because the first character has a width of two (see 'charWidth' for more on that).
splitAtWidth :: Int -> Text -> (Text, Text)
splitAtWidth :: Int -> Text -> (Text, Text)
splitAtWidth Int
n t :: Text
t@(Text Array
arr Int
off Int
len)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = (Text
T.empty, Text
t)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Text -> Int
textWidth Text
t = (Text
t, Text
T.empty)
    | Bool
otherwise = let k :: Int
k = Int -> Text -> Int
characterIndexFromWidth Int
n Text
t
                  in (Array -> Int -> Int -> Text
text Array
arr Int
off Int
k, Array -> Int -> Int -> Text
text Array
arr (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
k) (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
k))

-- | Convert a physical width index to a character index. For example, the
-- physical index 3 of the string "ᄀabc" corresponds to the character index 2,
-- because the first character has a width of 2.
characterIndexFromWidth :: Int -> Text -> Int
characterIndexFromWidth :: Int -> Text -> Int
characterIndexFromWidth Int
n' t' :: Text
t'@(Text Array
_ Int
_ Int
len') = Int -> Int -> Int -> Int
loop Int
0 Int
0 Int
0
  where
    loop
      :: Int -- Byte index of the 'Text' we're traversing
      -> Int -- The accumulated logical index so far
      -> Int -- The accumulated physical width
      -> Int -- The new logical index
    loop :: Int -> Int -> Int -> Int
loop !Int
bytes !Int
li !Int
cumw
        -- if we've gone past the last byte
        | Int
bytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len' = Int
liInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
        -- if we hit our target
        | Int
cumw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n' = Int
li
        -- advance one character
        | Bool
otherwise = Int -> Int -> Int -> Int
loop (Int
bytesInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
byteWidth) (Int
liInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
cumw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w)
      where Iter Char
c Int
byteWidth = Text -> Int -> Iter
iter Text
t' Int
bytes
            w :: Int
w = Char -> Int
charWidth Char
c

-- | Takes the given number of columns of characters. For example
--
-- > takeWidth 3 "ᄀabc" == "ᄀa"
--
-- because the first character has a width of 2 (see 'charWidth' for more on that).
-- This function will not take a character if its width exceeds the width it seeks to take.
takeWidth :: Int -> Text -> Text
takeWidth :: Int -> Text -> Text
takeWidth Int
n = (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> (Text, Text)
splitAtWidth Int
n

-- | Drops the given number of columns of characters. For example
--
-- > dropWidth 2 "ᄀabc" == "abc"
--
-- because the first character has a width of 2 (see 'charWidth' for more on that).
-- This function will not drop a character if its width exceeds the width it seeks to drop.
dropWidth :: Int -> Text -> Text
dropWidth :: Int -> Text -> Text
dropWidth Int
n = (Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> (Text, Text)
splitAtWidth Int
n

-- | Get the display width of a 'Char'. "Full width" and "wide" characters
-- take two columns and everything else takes a single column. See
-- <https://www.unicode.org/reports/tr11/> for more information
-- This is implemented using wcwidth from Vty such that it matches what will
-- be displayed on the terminal. Note that this method can change depending
-- on how vty is configed. Please see vty documentation for details.
charWidth :: Char -> Int
charWidth :: Char -> Int
charWidth = Char -> Int
wcwidth

-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
spansWidth :: [Span tag] -> Int
spansWidth :: [Span tag] -> Int
spansWidth = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> ([Span tag] -> [Int]) -> [Span tag] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Span tag -> Int) -> [Span tag] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Span tag
_ Text
t) -> Text -> Int
textWidth Text
t)

-- | Get the length (number of characters) of the text in a set of 'Span's
spansLength :: [Span tag] -> Int
spansLength :: [Span tag] -> Int
spansLength = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> ([Span tag] -> [Int]) -> [Span tag] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Span tag -> Int) -> [Span tag] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Span tag
_ Text
t) -> Text -> Int
T.length Text
t)

-- | Compute the width of some 'Text', taking into account fullwidth
-- unicode forms.
textWidth :: Text -> Int
textWidth :: Text -> Int
textWidth Text
t = Stream Char -> Int
widthI (Text -> Stream Char
stream Text
t)

-- | Compute the width of a stream of characters, taking into account
-- fullwidth unicode forms.
widthI :: Stream Char -> Int
widthI :: Stream Char -> Int
widthI (Stream s -> Step s Char
next s
s0 Size
_len) = Int -> s -> Int
loop_length Int
0 s
s0
    where
      loop_length :: Int -> s -> Int
loop_length !Int
z s
s  = case s -> Step s Char
next s
s of
                           Step s Char
Done       -> Int
z
                           Skip    s
s' -> Int -> s -> Int
loop_length Int
z s
s'
                           Yield Char
c s
s' -> Int -> s -> Int
loop_length (Int
z Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
charWidth Char
c) s
s'
{-# INLINE[0] widthI #-}

-- | Compute the logical index position of a stream of characters from a visual
-- position taking into account fullwidth unicode forms.
charIndexAt :: Int -> Stream Char -> Int
charIndexAt :: Int -> Stream Char -> Int
charIndexAt Int
pos (Stream s -> Step s Char
next s
s0 Size
_len) = Int -> Int -> s -> Int
loop_length Int
0 Int
0 s
s0
    where
      loop_length :: Int -> Int -> s -> Int
loop_length Int
i !Int
z s
s  = case s -> Step s Char
next s
s of
                           Step s Char
Done       -> Int
i
                           Skip    s
s' -> Int -> Int -> s -> Int
loop_length Int
i Int
z s
s'
                           Yield Char
c s
s' -> if Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pos then Int
i else Int -> Int -> s -> Int
loop_length (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
w s
s' where
                             w :: Int
w = Int
z Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
charWidth Char
c
{-# INLINE[0] charIndexAt #-}




-- | Same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...])
-- 'Char's representing white space.
wordsWithWhitespace :: Text -> [Text]
wordsWithWhitespace :: Text -> [Text]
wordsWithWhitespace t :: Text
t@(Text Array
arr Int
off Int
len) = Int -> Int -> Bool -> [Text]
loop Int
0 Int
0 Bool
False
  where
    loop :: Int -> Int -> Bool -> [Text]
loop !Int
start !Int
n !Bool
wasSpace
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = [Array -> Int -> Int -> Text
Text Array
arr (Int
startInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
off) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
start) | Bool -> Bool
not (Int
start Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n)]
        | Char -> Bool
isSpace Char
c = Int -> Int -> Bool -> [Text]
loop Int
start (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Bool
True
        | Bool
wasSpace = Array -> Int -> Int -> Text
Text Array
arr (Int
startInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
off) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
start) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> Int -> Bool -> [Text]
loop Int
n Int
n Bool
False
        | Bool
otherwise = Int -> Int -> Bool -> [Text]
loop Int
start (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Bool
False
        where Iter Char
c Int
d = Text -> Int -> Iter
iter Text
t Int
n
{-# INLINE wordsWithWhitespace #-}

-- | Split words into logical lines, 'True' in the tuple indicates line ends with a whitespace character that got deleted
splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]
splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]
splitWordsAtDisplayWidth Int
maxWidth [Text]
wwws = [(Text, Bool)] -> [(Text, Bool)]
forall a. [a] -> [a]
reverse ([(Text, Bool)] -> [(Text, Bool)])
-> [(Text, Bool)] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ [Text] -> Int -> [(Text, Bool)] -> [(Text, Bool)]
loop [Text]
wwws Int
0 [] where
  appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]
  appendOut :: [(Text, Bool)] -> Text -> Bool -> [(Text, Bool)]
appendOut [] Text
t Bool
b           = [(Text
t,Bool
b)]
  appendOut ((Text
t',Bool
_):[(Text, Bool)]
ts') Text
t Bool
b = (Text
t'Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
t,Bool
b) (Text, Bool) -> [(Text, Bool)] -> [(Text, Bool)]
forall a. a -> [a] -> [a]
: [(Text, Bool)]
ts'

  -- remove the last whitespace in output
  modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]
  modifyOutForNewLine :: [(Text, Bool)] -> [(Text, Bool)]
modifyOutForNewLine [] = String -> [(Text, Bool)]
forall a. HasCallStack => String -> a
error String
"should never happen"
  modifyOutForNewLine ((Text
t',Bool
_):[(Text, Bool)]
ts) = case Text -> Maybe (Text, Char)
T.unsnoc Text
t' of
    Maybe (Text, Char)
Nothing           -> String -> [(Text, Bool)]
forall a. HasCallStack => String -> a
error String
"should never happen"
    Just (Text
t,Char
lastChar) -> Bool -> [(Text, Bool)] -> [(Text, Bool)]
forall a. HasCallStack => Bool -> a -> a
assert (Char -> Bool
isSpace Char
lastChar) ([(Text, Bool)] -> [(Text, Bool)])
-> [(Text, Bool)] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ (Text
t,Bool
True)(Text, Bool) -> [(Text, Bool)] -> [(Text, Bool)]
forall a. a -> [a] -> [a]
:[(Text, Bool)]
ts -- assume last char is whitespace

  loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]
  loop :: [Text] -> Int -> [(Text, Bool)] -> [(Text, Bool)]
loop [] Int
_ [(Text, Bool)]
out = [(Text, Bool)]
out
  loop (Text
x:[Text]
xs) Int
cumw [(Text, Bool)]
out = [(Text, Bool)]
r where
    newWidth :: Int
newWidth = Text -> Int
textWidth Text
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cumw
    r :: [(Text, Bool)]
r = if Int
newWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxWidth
      then if Char -> Bool
isSpace (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Char
T.index Text
x (Int -> Text -> Int
characterIndexFromWidth (Int
maxWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
cumw) Text
x)
        -- if line runs over but character of splitting is whitespace then split on the whitespace
        then let (Text
t1,Text
t2) = Int -> Text -> (Text, Text)
splitAtWidth (Int
maxWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
cumw) Text
x
          in [Text] -> Int -> [(Text, Bool)] -> [(Text, Bool)]
loop (Int -> Text -> Text
T.drop Int
1 Text
t2Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs) Int
0 [] [(Text, Bool)] -> [(Text, Bool)] -> [(Text, Bool)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Bool)] -> Text -> Bool -> [(Text, Bool)]
appendOut [(Text, Bool)]
out Text
t1 Bool
True
        else if Int
cumw Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          -- single word exceeds max width, so just split on the word
          then let (Text
t1,Text
t2) = Int -> Text -> (Text, Text)
splitAtWidth (Int
maxWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
cumw) Text
x
            in [Text] -> Int -> [(Text, Bool)] -> [(Text, Bool)]
loop (Text
t2Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs) Int
0 [] [(Text, Bool)] -> [(Text, Bool)] -> [(Text, Bool)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Bool)] -> Text -> Bool -> [(Text, Bool)]
appendOut [(Text, Bool)]
out Text
t1 Bool
False
          -- otherwise start a new line
          else [Text] -> Int -> [(Text, Bool)] -> [(Text, Bool)]
loop (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs) Int
0 [] [(Text, Bool)] -> [(Text, Bool)] -> [(Text, Bool)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Bool)] -> [(Text, Bool)]
modifyOutForNewLine [(Text, Bool)]
out
      else [Text] -> Int -> [(Text, Bool)] -> [(Text, Bool)]
loop [Text]
xs Int
newWidth ([(Text, Bool)] -> [(Text, Bool)])
-> [(Text, Bool)] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ [(Text, Bool)] -> Text -> Bool -> [(Text, Bool)]
appendOut [(Text, Bool)]
out Text
x Bool
False

-- | Calculate the offset that will result in rendered text being aligned left,
-- right, or center
alignmentOffset
  :: TextAlignment
  -> Int
  -> Text
  -> Int
alignmentOffset :: TextAlignment -> Int -> Text -> Int
alignmentOffset TextAlignment
alignment Int
maxWidth Text
t = case TextAlignment
alignment of
  TextAlignment
TextAlignment_Left   -> Int
0
  TextAlignment
TextAlignment_Right  -> (Int
maxWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l)
  TextAlignment
TextAlignment_Center -> (Int
maxWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  where
    l :: Int
l = Text -> Int
textWidth Text
t

-- | Wraps a logical line of text to fit within the given width. The first
-- wrapped line is offset by the number of columns provided. Subsequent wrapped
-- lines are not.
wrapWithOffsetAndAlignment
  :: TextAlignment
  -> Int -- ^ Maximum width
  -> Int -- ^ Offset for first line
  -> Text -- ^ Text to be wrapped
  -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line)
wrapWithOffsetAndAlignment :: TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
_ Int
maxWidth Int
_ Text
_ | Int
maxWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = []
wrapWithOffsetAndAlignment TextAlignment
alignment Int
maxWidth Int
n Text
txt = Bool -> [WrappedLine] -> [WrappedLine]
forall a. HasCallStack => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxWidth) [WrappedLine]
r where
  r' :: [(Text, Bool)]
r' = if Text -> Bool
T.null Text
txt
    then [(Text
"",Bool
False)]
    -- I'm not sure why this is working, the "." padding will mess up splitWordsAtDisplayWidth for the next line if a single line exceeds the display width (but it doesn't)
    -- it should be `T.replicate n " "` instead (which also works but makes an extra "" Wrappedline somewhere)
    else Int -> [Text] -> [(Text, Bool)]
splitWordsAtDisplayWidth Int
maxWidth ([Text] -> [(Text, Bool)]) -> [Text] -> [(Text, Bool)]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
wordsWithWhitespace ( Int -> Text -> Text
T.replicate Int
n Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt)
  fmapfn :: (Text, Bool) -> WrappedLine
fmapfn (Text
t,Bool
b) = Text -> Bool -> Int -> WrappedLine
WrappedLine Text
t Bool
b (Int -> WrappedLine) -> Int -> WrappedLine
forall a b. (a -> b) -> a -> b
$ TextAlignment -> Int -> Text -> Int
alignmentOffset TextAlignment
alignment Int
maxWidth Text
t
  r'' :: [(Text, Bool)]
r'' =  case [(Text, Bool)]
r' of
    []       -> []
    (Text
x,Bool
b):[(Text, Bool)]
xs -> (Int -> Text -> Text
T.drop Int
n Text
x,Bool
b)(Text, Bool) -> [(Text, Bool)] -> [(Text, Bool)]
forall a. a -> [a] -> [a]
:[(Text, Bool)]
xs
  r :: [WrappedLine]
r = ((Text, Bool) -> WrappedLine) -> [(Text, Bool)] -> [WrappedLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Bool) -> WrappedLine
fmapfn [(Text, Bool)]
r''

-- | converts deleted eol spaces into logical lines
eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]
eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]
eolSpacesToLogicalLines = ([WrappedLine] -> [(Text, Int)])
-> [[WrappedLine]] -> [[(Text, Int)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((WrappedLine -> (Text, Int)) -> [WrappedLine] -> [(Text, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(WrappedLine Text
a Bool
_ Int
c) -> (Text
a,Int
c))) ([[WrappedLine]] -> [[(Text, Int)]])
-> ([[WrappedLine]] -> [[WrappedLine]])
-> [[WrappedLine]]
-> [[(Text, Int)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  ([WrappedLine] -> [[WrappedLine]])
-> [[WrappedLine]] -> [[WrappedLine]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((WrappedLine -> WrappedLine -> Bool)
-> [WrappedLine] -> [[WrappedLine]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\(WrappedLine Text
_ Bool
b Int
_) WrappedLine
_ -> Bool -> Bool
not Bool
b))

offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
offsetMapWithAlignmentInternal = [[(Text, Int)]] -> OffsetMapWithAlignment
offsetMapWithAlignment ([[(Text, Int)]] -> OffsetMapWithAlignment)
-> ([[WrappedLine]] -> [[(Text, Int)]])
-> [[WrappedLine]]
-> OffsetMapWithAlignment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[WrappedLine]] -> [[(Text, Int)]]
eolSpacesToLogicalLines

offsetMapWithAlignment
  :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines
  -> OffsetMapWithAlignment
offsetMapWithAlignment :: [[(Text, Int)]] -> OffsetMapWithAlignment
offsetMapWithAlignment [[(Text, Int)]]
ts = State (Int, Int) OffsetMapWithAlignment
-> (Int, Int) -> OffsetMapWithAlignment
forall s a. State s a -> s -> a
evalState ([[(Text, Int)]] -> State (Int, Int) OffsetMapWithAlignment
forall k (f :: * -> *) (f :: * -> *) (f :: * -> *) a.
(Ord k, Traversable f, Traversable f, MonadState (k, Int) f,
 Num k) =>
f (f (Text, a)) -> f (Map k (a, Int))
offsetMap' [[(Text, Int)]]
ts) (Int
0, Int
0)
  where
    offsetMap' :: f (f (Text, a)) -> f (Map k (a, Int))
offsetMap' f (f (Text, a))
xs = (f (Map k (a, Int)) -> Map k (a, Int))
-> f (f (Map k (a, Int))) -> f (Map k (a, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Map k (a, Int)) -> Map k (a, Int)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (f (f (Map k (a, Int))) -> f (Map k (a, Int)))
-> f (f (Map k (a, Int))) -> f (Map k (a, Int))
forall a b. (a -> b) -> a -> b
$ f (f (Text, a))
-> (f (Text, a) -> f (Map k (a, Int))) -> f (f (Map k (a, Int)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM f (f (Text, a))
xs ((f (Text, a) -> f (Map k (a, Int))) -> f (f (Map k (a, Int))))
-> (f (Text, a) -> f (Map k (a, Int))) -> f (f (Map k (a, Int)))
forall a b. (a -> b) -> a -> b
$ \f (Text, a)
x -> do
      f (Map k (a, Int))
maps <- f (Text, a)
-> ((Text, a) -> f (Map k (a, Int))) -> f (f (Map k (a, Int)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM f (Text, a)
x (((Text, a) -> f (Map k (a, Int))) -> f (f (Map k (a, Int))))
-> ((Text, a) -> f (Map k (a, Int))) -> f (f (Map k (a, Int)))
forall a b. (a -> b) -> a -> b
$ \(Text
line,a
align) -> do
        let l :: Int
l = Text -> Int
T.length Text
line
        (k
dl, Int
o) <- f (k, Int)
forall s (m :: * -> *). MonadState s m => m s
get
        (k, Int) -> f ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (k
dl k -> k -> k
forall a. Num a => a -> a -> a
+ k
1, Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l)
        Map k (a, Int) -> f (Map k (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k (a, Int) -> f (Map k (a, Int)))
-> Map k (a, Int) -> f (Map k (a, Int))
forall a b. (a -> b) -> a -> b
$ k -> (a, Int) -> Map k (a, Int)
forall k a. k -> a -> Map k a
Map.singleton k
dl (a
align, Int
o)
      (k
dl, Int
o) <- f (k, Int)
forall s (m :: * -> *). MonadState s m => m s
get
      (k, Int) -> f ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (k
dl, Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      -- add additional offset to last line in wrapped lines (for newline char)
      Map k (a, Int) -> f (Map k (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k (a, Int) -> f (Map k (a, Int)))
-> Map k (a, Int) -> f (Map k (a, Int))
forall a b. (a -> b) -> a -> b
$ ((a, Int) -> (a, Int)) -> k -> Map k (a, Int) -> Map k (a, Int)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\(a
align,Int
_)->(a
align,Int
oInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) k
dl (Map k (a, Int) -> Map k (a, Int))
-> Map k (a, Int) -> Map k (a, Int)
forall a b. (a -> b) -> a -> b
$ f (Map k (a, Int)) -> Map k (a, Int)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions f (Map k (a, Int))
maps


-- | Given a width and a 'TextZipper', produce a list of display lines
-- (i.e., lines of wrapped text) with special attributes applied to
-- certain segments (e.g., the cursor). Additionally, produce the current
-- y-coordinate of the cursor and a mapping from display line number to text
-- offset
displayLinesWithAlignment
  :: TextAlignment
  -> Int -- ^ Width, used for wrapping
  -> tag -- ^ Metadata for normal characters
  -> tag -- ^ Metadata for the cursor
  -> TextZipper -- ^ The text input contents and cursor state
  -> DisplayLines tag
displayLinesWithAlignment :: TextAlignment
-> Int -> tag -> tag -> TextZipper -> DisplayLines tag
displayLinesWithAlignment TextAlignment
alignment Int
width tag
tag tag
cursorTag (TextZipper [Text]
lb Text
b Text
a [Text]
la) =
  let
      linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line
      linesBefore :: [[WrappedLine]]
linesBefore = (Text -> [WrappedLine]) -> [Text] -> [[WrappedLine]]
forall a b. (a -> b) -> [a] -> [b]
map (TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
alignment Int
width Int
0) ([Text] -> [[WrappedLine]]) -> [Text] -> [[WrappedLine]]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
lb
      linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line
      linesAfter :: [[WrappedLine]]
linesAfter = (Text -> [WrappedLine]) -> [Text] -> [[WrappedLine]]
forall a b. (a -> b) -> [a] -> [b]
map (TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
alignment Int
width Int
0) [Text]
la

      -- simulate trailing cursor character when computing OffsetMap
      afterWithCursor :: Text
afterWithCursor = if Text -> Bool
T.null Text
a then Text
" " else Text
a
      offsets :: OffsetMapWithAlignment
      offsets :: OffsetMapWithAlignment
offsets = [[WrappedLine]] -> OffsetMapWithAlignment
offsetMapWithAlignmentInternal ([[WrappedLine]] -> OffsetMapWithAlignment)
-> [[WrappedLine]] -> OffsetMapWithAlignment
forall a b. (a -> b) -> a -> b
$ [[[WrappedLine]]] -> [[WrappedLine]]
forall a. Monoid a => [a] -> a
mconcat
        [ [[WrappedLine]]
linesBefore
        , [TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
alignment Int
width Int
0 (Text -> [WrappedLine]) -> Text -> [WrappedLine]
forall a b. (a -> b) -> a -> b
$ Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
afterWithCursor]
        , [[WrappedLine]]
linesAfter
        ]
      flattenLines :: [[WrappedLine]] -> [Text]
flattenLines = ([WrappedLine] -> [Text]) -> [[WrappedLine]] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((WrappedLine -> Text) -> [WrappedLine] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WrappedLine -> Text
_wrappedLines_text)
      spansBefore :: [[Span tag]]
spansBefore = (Text -> [Span tag]) -> [Text] -> [[Span tag]]
forall a b. (a -> b) -> [a] -> [b]
map ((Span tag -> [Span tag] -> [Span tag]
forall a. a -> [a] -> [a]
:[]) (Span tag -> [Span tag])
-> (Text -> Span tag) -> Text -> [Span tag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
tag) ([Text] -> [[Span tag]]) -> [Text] -> [[Span tag]]
forall a b. (a -> b) -> a -> b
$ [[WrappedLine]] -> [Text]
flattenLines [[WrappedLine]]
linesBefore
      spansAfter :: [[Span tag]]
spansAfter = (Text -> [Span tag]) -> [Text] -> [[Span tag]]
forall a b. (a -> b) -> [a] -> [b]
map ((Span tag -> [Span tag] -> [Span tag]
forall a. a -> [a] -> [a]
:[]) (Span tag -> [Span tag])
-> (Text -> Span tag) -> Text -> [Span tag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
tag) ([Text] -> [[Span tag]]) -> [Text] -> [[Span tag]]
forall a b. (a -> b) -> a -> b
$ [[WrappedLine]] -> [Text]
flattenLines [[WrappedLine]]
linesAfter
      -- Separate the spans before the cursor into
      -- * spans that are on earlier display lines (though on the same logical line), and
      -- * spans that are on the same display line

      -- do the current line
      curlinetext :: Text
curlinetext = Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a
      curwrappedlines :: [WrappedLine]
curwrappedlines = (TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
alignment Int
width Int
0 Text
curlinetext)
      blength :: Int
blength = Text -> Int
T.length Text
b

      -- map to spans and highlight the cursor
      -- accumulator type (accumulated text length, Either (current y position) (cursor y and x position))
      --mapaccumlfn :: (Int, Either Int (Int, Int)) -> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag])
      mapaccumlfn :: (Int, Either Int (Int, Int))
-> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag])
mapaccumlfn (Int
acclength, Either Int (Int, Int)
ecpos) (WrappedLine Text
t Bool
dwseol Int
xoff) = ((Int, Either Int (Int, Int)), [Span tag])
r where
        tlength :: Int
tlength = Text -> Int
T.length Text
t
        -- how many words we've gone through
        nextacclength :: Int
nextacclength = Int
acclength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tlength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Bool
dwseol then Int
1 else Int
0
        nextacc :: (Int, Either Int (Int, Int))
nextacc = (Int
nextacclength, Either Int (Int, Int)
nextecpos)
        cursoroncurspan :: Bool
cursoroncurspan = Int
nextacclength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
blength Bool -> Bool -> Bool
&& (Int
blength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
acclength)
        charsbeforecursor :: Int
charsbeforecursor = Int
blengthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
acclength
        ctlength :: Int
ctlength = Text -> Int
textWidth (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take Int
charsbeforecursor Text
t
        cursorx :: Int
cursorx = Int
xoff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ctlength
        nextecpos :: Either Int (Int, Int)
nextecpos = case Either Int (Int, Int)
ecpos of
          Left Int
y -> if Bool
cursoroncurspan
            then if Int
ctlength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
width
              -- cursor wraps to next line case
              then (Int, Int) -> Either Int (Int, Int)
forall a b. b -> Either a b
Right (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
0)
              else (Int, Int) -> Either Int (Int, Int)
forall a b. b -> Either a b
Right (Int
y, Int
cursorx)
            else Int -> Either Int (Int, Int)
forall a b. a -> Either a b
Left (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          Right (Int, Int)
x -> (Int, Int) -> Either Int (Int, Int)
forall a b. b -> Either a b
Right (Int, Int)
x

        beforecursor :: Text
beforecursor = Int -> Text -> Text
T.take Int
charsbeforecursor Text
t
        cursortext :: Text
cursortext = Int -> Text -> Text
T.take Int
1 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
charsbeforecursor Text
t
        aftercursor :: Text
aftercursor = Int -> Text -> Text
T.drop (Int
charsbeforecursorInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Text
t

        cursorspans :: [Span tag]
cursorspans = [tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
tag Text
beforecursor, tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
cursorTag Text
cursortext] [Span tag] -> [Span tag] -> [Span tag]
forall a. Semigroup a => a -> a -> a
<> if Text -> Bool
T.null Text
aftercursor then [] else [tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
tag Text
aftercursor]

        r :: ((Int, Either Int (Int, Int)), [Span tag])
r = if Bool
cursoroncurspan
          then ((Int, Either Int (Int, Int))
nextacc, [Span tag]
cursorspans)
          else ((Int, Either Int (Int, Int))
nextacc, [tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
tag Text
t])
      ((Int
_, Either Int (Int, Int)
ecpos_out), [[Span tag]]
curlinespans) = if Text -> Bool
T.null Text
curlinetext
        -- manually handle empty case because mapaccumlfn doesn't handle it
        then ((Int
0, (Int, Int) -> Either Int (Int, Int)
forall a b. b -> Either a b
Right (Int
0, TextAlignment -> Int -> Text -> Int
alignmentOffset TextAlignment
alignment Int
width Text
"")), [[tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
cursorTag Text
""]])
        else ((Int, Either Int (Int, Int))
 -> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag]))
-> (Int, Either Int (Int, Int))
-> [WrappedLine]
-> ((Int, Either Int (Int, Int)), [[Span tag]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
L.mapAccumL (Int, Either Int (Int, Int))
-> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag])
mapaccumlfn (Int
0, Int -> Either Int (Int, Int)
forall a b. a -> Either a b
Left Int
0) [WrappedLine]
curwrappedlines

      (Int
cursorY', Int
cursorX) = case Either Int (Int, Int)
ecpos_out of
        Right (Int
y,Int
x) -> (Int
y,Int
x)
        -- if we never hit the cursor position, this means it's at the beginning of the next line
        Left Int
y      -> (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, TextAlignment -> Int -> Text -> Int
alignmentOffset TextAlignment
alignment Int
width Text
"")
      cursorY :: Int
cursorY = Int
cursorY' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [[Span tag]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Span tag]]
spansBefore

  in  DisplayLines :: forall tag.
[[Span tag]]
-> OffsetMapWithAlignment -> (Int, Int) -> DisplayLines tag
DisplayLines
        { _displayLines_spans :: [[Span tag]]
_displayLines_spans = [[[Span tag]]] -> [[Span tag]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [[Span tag]]
spansBefore
          , [[Span tag]]
curlinespans
          , [[Span tag]]
spansAfter
          ]
        , _displayLines_offsetMap :: OffsetMapWithAlignment
_displayLines_offsetMap = OffsetMapWithAlignment
offsets
        , _displayLines_cursorPos :: (Int, Int)
_displayLines_cursorPos = (Int
cursorX, Int
cursorY)
        }

-- | Move the cursor of the given 'TextZipper' to the logical position indicated
-- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment'
-- information.  If the x coordinate is beyond the end of a line, the cursor is
-- moved to the end of the line.
goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
goToDisplayLinePosition Int
x Int
y DisplayLines tag
dl TextZipper
tz =
  let offset :: Maybe (Int, Int)
offset = Int -> OffsetMapWithAlignment -> Maybe (Int, Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
y (OffsetMapWithAlignment -> Maybe (Int, Int))
-> OffsetMapWithAlignment -> Maybe (Int, Int)
forall a b. (a -> b) -> a -> b
$ DisplayLines tag -> OffsetMapWithAlignment
forall tag. DisplayLines tag -> OffsetMapWithAlignment
_displayLines_offsetMap DisplayLines tag
dl
  in  case Maybe (Int, Int)
offset of
        Maybe (Int, Int)
Nothing -> TextZipper
tz
        Just (Int
alignOff,Int
o) ->
          let
            trueX :: Int
trueX = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
alignOff)
            moveRight :: Int
moveRight = case Int -> [[Span tag]] -> [[Span tag]]
forall a. Int -> [a] -> [a]
drop Int
y ([[Span tag]] -> [[Span tag]]) -> [[Span tag]] -> [[Span tag]]
forall a b. (a -> b) -> a -> b
$ DisplayLines tag -> [[Span tag]]
forall tag. DisplayLines tag -> [[Span tag]]
_displayLines_spans DisplayLines tag
dl of
                []    -> Int
0
                ([Span tag]
s:[[Span tag]]
_) -> Int -> Stream Char -> Int
charIndexAt Int
trueX (Stream Char -> Int)
-> ([Span tag] -> Stream Char) -> [Span tag] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Stream Char
stream (Text -> Stream Char)
-> ([Span tag] -> Text) -> [Span tag] -> Stream Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Span tag] -> [Text]) -> [Span tag] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Span tag -> Text) -> [Span tag] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Span tag
_ Text
t) -> Text
t) ([Span tag] -> Int) -> [Span tag] -> Int
forall a b. (a -> b) -> a -> b
$ [Span tag]
s
          in  Int -> TextZipper -> TextZipper
rightN (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
moveRight) (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall a b. (a -> b) -> a -> b
$ TextZipper -> TextZipper
top TextZipper
tz

-- | Given a width and a 'TextZipper', produce a list of display lines
-- (i.e., lines of wrapped text) with special attributes applied to
-- certain segments (e.g., the cursor). Additionally, produce the current
-- y-coordinate of the cursor and a mapping from display line number to text
-- offset
displayLines
  :: Int -- ^ Width, used for wrapping
  -> tag -- ^ Metadata for normal characters
  -> tag -- ^ Metadata for the cursor
  -> TextZipper -- ^ The text input contents and cursor state
  -> DisplayLines tag
displayLines :: Int -> tag -> tag -> TextZipper -> DisplayLines tag
displayLines = TextAlignment
-> Int -> tag -> tag -> TextZipper -> DisplayLines tag
forall tag.
TextAlignment
-> Int -> tag -> tag -> TextZipper -> DisplayLines tag
displayLinesWithAlignment TextAlignment
TextAlignment_Left

-- | Wraps a logical line of text to fit within the given width. The first
-- wrapped line is offset by the number of columns provided. Subsequent wrapped
-- lines are not.
wrapWithOffset
  :: Int -- ^ Maximum width
  -> Int -- ^ Offset for first line
  -> Text -- ^ Text to be wrapped
  -> [Text]
wrapWithOffset :: Int -> Int -> Text -> [Text]
wrapWithOffset Int
maxWidth Int
n Text
xs = WrappedLine -> Text
_wrappedLines_text (WrappedLine -> Text) -> [WrappedLine] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
TextAlignment_Left Int
maxWidth Int
n Text
xs