{-|
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 Potato.Data.Text.Zipper where

import           Prelude

import Control.Exception (assert)
import Control.Monad.State (evalState, forM, get, put)
import Data.Char (isSpace)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text (Text)
import Data.Text.Internal (Text(..), text)
import Data.Text.Internal.Fusion (stream)
import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
import Data.Text.Unsafe
import qualified Data.List as L
import qualified Data.Map as Map
import qualified Data.Text as T

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
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
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 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
  { _textZipper_linesBefore :: [Text]
_textZipper_linesBefore = 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 = 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 forall a. Ord a => a -> a -> Bool
>= Int
n
    then
      let n' :: Int
n' = Text -> Int
T.length Text
b 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 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 forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
b forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
ls Text
l Text
"" ((Text
b forall a. Semigroup a => a -> a -> a
<> Text
a) 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 forall a. Ord a => a -> a -> Bool
>= Int
n
    then [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb (Text
b 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 forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
a forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper ((Text
b forall a. Semigroup a => a -> a -> a
<> Text
a) 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 forall a. Semigroup a => a -> a -> a
<> Text
a) 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 forall a. Semigroup a => a -> a -> a
<> Text
a) 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 forall a. Ord a => a -> a -> Bool
<= Int
0
  then TextZipper
z
  else Int -> TextZipper -> TextZipper
pageUp (Int
pageSize forall a. Num a => a -> a -> a
- Int
1) 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 forall a. Ord a => a -> a -> Bool
<= Int
0
  then TextZipper
z
  else Int -> TextZipper -> TextZipper
pageDown (Int
pageSize forall a. Num a => a -> a -> a
- Int
1) 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 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 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 forall a. [a] -> [a]
reverse [Text]
lb of
  [] -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [] Text
"" (Text
b 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 forall a. Semigroup a => a -> a -> a
<> [Text
b forall a. Semigroup a => a -> a -> a
<> Text
a] 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 (forall a. Eq a => a -> a -> Bool
==Char
'\n') Text
i of
  [] -> TextZipper
z
  (Text
start:[Text]
rest) -> case forall a. [a] -> [a]
reverse [Text]
rest of
    [] -> [Text] -> Text -> Text -> [Text] -> TextZipper
TextZipper [Text]
lb (Text
b 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 forall a. Semigroup a => a -> a -> a
<> [Text
b forall a. Semigroup a => a -> a -> a
<> Text
start] 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 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 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 (forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
b forall a. Integral a => a -> a -> a
`mod` 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" forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ forall a. [a] -> [a]
reverse [Text]
lb
  , [Text
b 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 = 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
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
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
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
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
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
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
  { forall tag. DisplayLines tag -> [[Span tag]]
_displayLines_spans :: [[Span tag]]
  , forall tag. DisplayLines tag -> OffsetMapWithAlignment
_displayLines_offsetMap :: OffsetMapWithAlignment
  , forall tag. DisplayLines tag -> (Int, Int)
_displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
  }
  deriving (DisplayLines tag -> DisplayLines tag -> Bool
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
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 forall a. Ord a => a -> a -> Bool
<= Int
0 = (Text
T.empty, Text
t)
    | Int
n 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
toLogicalIndex Int
n Text
t
                  in (Array -> Int -> Int -> Text
text Array
arr Int
off Int
k, Array -> Int -> Int -> Text
text Array
arr (Int
offforall a. Num a => a -> a -> a
+Int
k) (Int
lenforall a. Num a => a -> a -> a
-Int
k))

toLogicalIndex :: Int -> Text -> Int
toLogicalIndex :: Int -> Text -> Int
toLogicalIndex Int
n' t' :: Text
t'@(Text Array
_ Int
_ Int
len') = Int -> Int -> Int
loop Int
0 Int
0
  where loop :: Int -> Int -> Int
loop !Int
i !Int
cnt
            | Int
i forall a. Ord a => a -> a -> Bool
>= Int
len' Bool -> Bool -> Bool
|| Int
cnt forall a. Num a => a -> a -> a
+ Int
w forall a. Ord a => a -> a -> Bool
> Int
n' = Int
i
            | Bool
otherwise = Int -> Int -> Int
loop (Int
iforall a. Num a => a -> a -> a
+Int
d) (Int
cnt forall a. Num a => a -> a -> a
+ Int
w)
          where Iter Char
c Int
d = Text -> Int -> Iter
iter Text
t' Int
i
                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 = forall a b. (a, b) -> a
fst 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 = forall a b. (a, b) -> b
snd 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 :: forall tag. [Span tag] -> Int
spansWidth = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall tag. [Span tag] -> Int
spansLength = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 forall a. Ord a => a -> a -> Bool
> Int
pos then Int
i else Int -> Int -> s -> Int
loop_length (Int
iforall a. Num a => a -> a -> a
+Int
1) Int
w s
s' where
                             w :: Int
w = Int
z 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 forall a. Ord a => a -> a -> Bool
>= Int
len = [Array -> Int -> Int -> Text
Text Array
arr (Int
startforall a. Num a => a -> a -> a
+Int
off) (Int
nforall a. Num a => a -> a -> a
-Int
start) | Bool -> Bool
not (Int
start forall a. Eq a => a -> a -> Bool
== Int
n)]
        | Char -> Bool
isSpace Char
c = Int -> Int -> Bool -> [Text]
loop Int
start (Int
nforall a. Num a => a -> a -> a
+Int
d) Bool
True
        | Bool
wasSpace = Array -> Int -> Int -> Text
Text Array
arr (Int
startforall a. Num a => a -> a -> a
+Int
off) (Int
nforall a. Num a => a -> a -> a
-Int
start) 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
nforall 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 = forall a. [a] -> [a]
reverse 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'forall a. Semigroup a => a -> a -> a
<>Text
t,Bool
b) 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 [] = 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           -> forall a. HasCallStack => String -> a
error String
"should never happen"
    Just (Text
t,Char
lastChar) -> forall a. HasCallStack => Bool -> a -> a
assert (Char -> Bool
isSpace Char
lastChar) forall a b. (a -> b) -> a -> b
$ (Text
t,Bool
True)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 forall a. Num a => a -> a -> a
+ Int
cumw
    r :: [(Text, Bool)]
r = if Int
newWidth forall a. Ord a => a -> a -> Bool
> Int
maxWidth
      -- TODO index out of bounds sometimes in the presence of widechars
      then if Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ Text -> Int -> Char
T.index Text
x (Int -> Text -> Int
toLogicalIndex (Int
maxWidth 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 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
t2forall a. a -> [a] -> [a]
:[Text]
xs) Int
0 [] 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 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 forall a. Num a => a -> a -> a
- Int
cumw) Text
x
            in [Text] -> Int -> [(Text, Bool)] -> [(Text, Bool)]
loop (Text
t2forall a. a -> [a] -> [a]
:[Text]
xs) Int
0 [] 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
xforall a. a -> [a] -> [a]
:[Text]
xs) Int
0 [] 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 forall a b. (a -> b) -> a -> b
$ [(Text, Bool)] -> Text -> Bool -> [(Text, Bool)]
appendOut [(Text, Bool)]
out Text
x Bool
False



-- | 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 forall a. Ord a => a -> a -> Bool
<= Int
0 = []
wrapWithOffsetAndAlignment TextAlignment
alignment Int
maxWidth Int
n Text
txt = forall a. HasCallStack => Bool -> a -> a
assert (Int
n forall a. Ord a => a -> a -> Bool
<= Int
maxWidth) [WrappedLine]
r where
  r' :: [(Text, Bool)]
r' = Int -> [Text] -> [(Text, Bool)]
splitWordsAtDisplayWidth Int
maxWidth forall a b. (a -> b) -> a -> b
$ Text -> [Text]
wordsWithWhitespace ( Int -> Text -> Text
T.replicate Int
n Text
"." forall a. Semigroup a => a -> a -> a
<> Text
txt)
  fmapfn :: (Text, Bool) -> WrappedLine
fmapfn (Text
t,Bool
b) = case TextAlignment
alignment of
    TextAlignment
TextAlignment_Left   -> Text -> Bool -> Int -> WrappedLine
WrappedLine Text
t Bool
b Int
0
    TextAlignment
TextAlignment_Right  -> Text -> Bool -> Int -> WrappedLine
WrappedLine Text
t Bool
b (Int
maxWidthforall a. Num a => a -> a -> a
-Int
l)
    TextAlignment
TextAlignment_Center -> Text -> Bool -> Int -> WrappedLine
WrappedLine Text
t Bool
b ((Int
maxWidthforall a. Num a => a -> a -> a
-Int
l) forall a. Integral a => a -> a -> a
`div` Int
2)
    where l :: Int
l = Text -> Int
textWidth 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)forall a. a -> [a] -> [a]
:[(Text, Bool)]
xs
  r :: [WrappedLine]
r = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(WrappedLine Text
a Bool
_ Int
c) -> (Text
a,Int
c))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\(WrappedLine Text
_ Bool
b Int
_) WrappedLine
_ -> Bool -> Bool
not Bool
b)) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
offsetMapWithAlignmentInternal = [[(Text, Int)]] -> OffsetMapWithAlignment
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 = forall s a. State s a -> s -> a
evalState (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM f (f (Text, a))
xs forall a b. (a -> b) -> a -> b
$ \f (Text, a)
x -> do
      f (Map k (a, Int))
maps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM f (Text, a)
x 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) <- forall s (m :: * -> *). MonadState s m => m s
get
        forall s (m :: * -> *). MonadState s m => s -> m ()
put (k
dl forall a. Num a => a -> a -> a
+ k
1, Int
o forall a. Num a => a -> a -> a
+ Int
l)
        return $ forall k a. k -> a -> Map k a
Map.singleton k
dl (a
align, Int
o)
      (k
dl, Int
o) <- forall s (m :: * -> *). MonadState s m => m s
get
      forall s (m :: * -> *). MonadState s m => s -> m ()
put (k
dl, Int
o forall a. Num a => a -> a -> a
+ Int
1)
      -- add additional offset to last line in wrapped lines (for newline char)
      return $ forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\(a
align,Int
_)->(a
align,Int
oforall a. Num a => a -> a -> a
+Int
1)) k
dl forall a b. (a -> b) -> a -> b
$ 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 :: forall tag.
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 = forall a b. (a -> b) -> [a] -> [b]
map (TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
alignment Int
width Int
0) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Text]
lb
      linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line
      linesAfter :: [[WrappedLine]]
linesAfter = 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 forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ [[WrappedLine]]
linesBefore
        , [TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
alignment Int
width Int
0 forall a b. (a -> b) -> a -> b
$ Text
b forall a. Semigroup a => a -> a -> a
<> Text
afterWithCursor]
        , [[WrappedLine]]
linesAfter
        ]
      flattenLines :: [[WrappedLine]] -> [Text]
flattenLines = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WrappedLine -> Text
_wrappedLines_text)
      spansBefore :: [[Span tag]]
spansBefore = forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag. tag -> Text -> Span tag
Span tag
tag) forall a b. (a -> b) -> a -> b
$ [[WrappedLine]] -> [Text]
flattenLines [[WrappedLine]]
linesBefore
      spansAfter :: [[Span tag]]
spansAfter = forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag. tag -> Text -> Span tag
Span tag
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

      ([[Span tag]]
spansCurrentBefore, [Span tag]
spansCurLineBefore) = forall a. a -> Maybe a -> a
fromMaybe ([], []) forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> Maybe ([a], a)
initLast forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag. tag -> Text -> Span tag
Span tag
tag) forall a b. (a -> b) -> a -> b
$ WrappedLine -> Text
_wrappedLines_text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
alignment Int
width Int
0 Text
b)
      -- Calculate the number of columns on the cursor's display line before the cursor
      curLineOffset :: Int
curLineOffset = forall tag. [Span tag] -> Int
spansWidth [Span tag]
spansCurLineBefore
      -- Check whether the spans on the current display line are long enough that
      -- the cursor has to go to the next line
      cursorAfterEOL :: Bool
cursorAfterEOL = Int
curLineOffset forall a. Eq a => a -> a -> Bool
== Int
width
      cursorCharWidth :: Int
cursorCharWidth = case Text -> Maybe (Char, Text)
T.uncons Text
a of
        Maybe (Char, Text)
Nothing     -> Int
1
        Just (Char
c, Text
_) -> Char -> Int
charWidth Char
c

      -- Separate the span after the cursor into
      -- * spans that are on the same display line, and
      -- * spans that are on later display lines (though on the same logical line)

      ([Span tag]
spansCurLineAfter, [[Span tag]]
spansCurrentAfter) = forall a. a -> Maybe a -> a
fromMaybe ([], []) forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> Maybe (a, [a])
headTail forall a b. (a -> b) -> a -> b
$ case Text -> Maybe (Char, Text)
T.uncons Text
a of
          Maybe (Char, Text)
Nothing -> [[forall tag. tag -> Text -> Span tag
Span tag
cursorTag Text
" "]]
          Just (Char
c, Text
rest) ->
            let o :: Int
o = if Bool
cursorAfterEOL then Int
cursorCharWidth else Int
curLineOffset forall a. Num a => a -> a -> a
+ Int
cursorCharWidth
                cursor :: Span tag
cursor = forall tag. tag -> Text -> Span tag
Span tag
cursorTag (Char -> Text
T.singleton Char
c)
            in case forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag. tag -> Text -> Span tag
Span tag
tag) forall a b. (a -> b) -> a -> b
$ WrappedLine -> Text
_wrappedLines_text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TextAlignment -> Int -> Int -> Text -> [WrappedLine]
wrapWithOffsetAndAlignment TextAlignment
alignment Int
width Int
o Text
rest) of
                  []     -> [[Span tag
cursor]]
                  ([Span tag]
l:[[Span tag]]
ls) -> (Span tag
cursor forall a. a -> [a] -> [a]
: [Span tag]
l) forall a. a -> [a] -> [a]
: [[Span tag]]
ls

      curLineSpanNormalCase :: [[Span tag]]
curLineSpanNormalCase = if Bool
cursorAfterEOL
        then [ [Span tag]
spansCurLineBefore, [Span tag]
spansCurLineAfter ]
        else [ [Span tag]
spansCurLineBefore forall a. Semigroup a => a -> a -> a
<> [Span tag]
spansCurLineAfter ]

      -- for right alignment, we want draw the cursor tag to be on the character just before the logical cursor position
      curLineSpan :: [[Span tag]]
curLineSpan = if TextAlignment
alignment forall a. Eq a => a -> a -> Bool
== TextAlignment
TextAlignment_Right Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cursorAfterEOL
        then case forall a. [a] -> [a]
reverse [Span tag]
spansCurLineBefore of
          [] -> [[Span tag]]
curLineSpanNormalCase
          (Span tag
_ Text
x):[Span tag]
xs -> case [Span tag]
spansCurLineAfter of
            [] -> forall a. HasCallStack => String -> a
error String
"should not be possible" -- curLineSpanNormalCase
            (Span tag
_ Text
y):[Span tag]
ys -> [forall a. [a] -> [a]
reverse (forall tag. tag -> Text -> Span tag
Span tag
cursorTag Text
xforall a. a -> [a] -> [a]
:[Span tag]
xs) forall a. Semigroup a => a -> a -> a
<> ((forall tag. tag -> Text -> Span tag
Span tag
tag Text
y)forall a. a -> [a] -> [a]
:[Span tag]
ys)]
        else [[Span tag]]
curLineSpanNormalCase

      cursorY :: Int
cursorY = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
        [ forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Span tag]]
spansBefore
        , forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Span tag]]
spansCurrentBefore
        , if Bool
cursorAfterEOL then Int
1 else Int
0
        ]
      -- a little silly to convert back to text but whatever, it works
      cursorX :: Int
cursorX = if Bool
cursorAfterEOL then Int
0 else Text -> Int
textWidth (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Span tag
_ Text
t) -> Text
t) [Span tag]
spansCurLineBefore)

  in  DisplayLines
        { _displayLines_spans :: [[Span tag]]
_displayLines_spans = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [[Span tag]]
spansBefore
          , [[Span tag]]
spansCurrentBefore
          , [[Span tag]]
curLineSpan
          , [[Span tag]]
spansCurrentAfter
          , [[Span tag]]
spansAfter
          ]
        , _displayLines_offsetMap :: OffsetMapWithAlignment
_displayLines_offsetMap = OffsetMapWithAlignment
offsets
        , _displayLines_cursorPos :: (Int, Int)
_displayLines_cursorPos = (Int
cursorX, Int
cursorY)
        }
  where
    initLast :: [a] -> Maybe ([a], a)
    initLast :: forall a. [a] -> Maybe ([a], a)
initLast = \case
      [] -> forall a. Maybe a
Nothing
      (a
x:[a]
xs) -> case forall a. [a] -> Maybe ([a], a)
initLast [a]
xs of
        Maybe ([a], a)
Nothing      -> forall a. a -> Maybe a
Just ([], a
x)
        Just ([a]
ys, a
y) -> forall a. a -> Maybe a
Just (a
xforall a. a -> [a] -> [a]
:[a]
ys, a
y)
    headTail :: [a] -> Maybe (a, [a])
    headTail :: forall a. [a] -> Maybe (a, [a])
headTail = \case
      [] -> forall a. Maybe a
Nothing
      a
x:[a]
xs -> forall a. a -> Maybe a
Just (a
x, [a]
xs)


-- | 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 :: forall tag.
Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
goToDisplayLinePosition Int
x Int
y DisplayLines tag
dl TextZipper
tz =
  let offset :: Maybe (Int, Int)
offset = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
y forall a b. (a -> b) -> a -> b
$ 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 = forall a. Ord a => a -> a -> a
max Int
0 (Int
x forall a. Num a => a -> a -> a
- Int
alignOff)
            moveRight :: Int
moveRight = case forall a. Int -> [a] -> [a]
drop Int
y forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Stream Char
stream forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Span tag
_ Text
t) -> Text
t) forall a b. (a -> b) -> a -> b
$ [Span tag]
s
          in  Int -> TextZipper -> TextZipper
rightN (Int
o forall a. Num a => a -> a -> a
+ Int
moveRight) 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 :: forall tag. Int -> tag -> tag -> TextZipper -> DisplayLines tag
displayLines = 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 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