{-|
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           Prelude

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

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
(Int -> TextZipper -> ShowS)
-> (TextZipper -> String)
-> ([TextZipper] -> ShowS)
-> Show TextZipper
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TextZipper -> ShowS
showsPrec :: Int -> TextZipper -> ShowS
$cshow :: TextZipper -> String
show :: TextZipper -> String
$cshowList :: [TextZipper] -> ShowS
showList :: [TextZipper] -> ShowS
Show)

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
  { _textZipper_linesBefore :: [Text]
_textZipper_linesBefore = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> [a] -> [b]
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 (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
$cshowsPrec :: forall tag. Show tag => Int -> Span tag -> ShowS
showsPrec :: Int -> Span tag -> ShowS
$cshow :: forall tag. Show tag => Span tag -> String
show :: Span tag -> String
$cshowList :: forall tag. Show tag => [Span tag] -> ShowS
showList :: [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
$c== :: TextAlignment -> TextAlignment -> Bool
== :: TextAlignment -> TextAlignment -> Bool
$c/= :: TextAlignment -> TextAlignment -> Bool
/= :: 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
$cshowsPrec :: Int -> TextAlignment -> ShowS
showsPrec :: Int -> TextAlignment -> ShowS
$cshow :: TextAlignment -> String
show :: TextAlignment -> String
$cshowList :: [TextAlignment] -> ShowS
showList :: [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
$c== :: WrappedLine -> WrappedLine -> Bool
== :: WrappedLine -> WrappedLine -> Bool
$c/= :: WrappedLine -> WrappedLine -> Bool
/= :: 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
$cshowsPrec :: Int -> WrappedLine -> ShowS
showsPrec :: Int -> WrappedLine -> ShowS
$cshow :: WrappedLine -> String
show :: WrappedLine -> String
$cshowList :: [WrappedLine] -> ShowS
showList :: [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 (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
$cshowsPrec :: forall tag. Show tag => Int -> DisplayLines tag -> ShowS
showsPrec :: Int -> DisplayLines tag -> ShowS
$cshow :: forall tag. Show tag => DisplayLines tag -> String
show :: DisplayLines tag -> String
$cshowList :: forall tag. Show tag => [DisplayLines tag] -> ShowS
showList :: [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
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
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))

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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len' Bool -> Bool -> Bool
|| Int
cnt 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
i
            | Bool
otherwise = Int -> Int -> Int
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) (Int
cnt Int -> Int -> Int
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 = (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 :: forall tag. [Span tag] -> Int
spansWidth = [Int] -> Int
forall a. Num a => [a] -> a
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 :: forall tag. [Span tag] -> Int
spansLength = [Int] -> Int
forall a. Num a => [a] -> a
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
$ HasCallStack => Text -> Int -> Char
Text -> Int -> Char
T.index Text
x (Int -> Text -> Int
toLogicalIndex (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



-- | 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
  -- we pad by offset amount with any non-space character which we will remove later so that no changes need to be made to splitWordsAtDisplayWidth
  r' :: [(Text, Bool)]
r' = 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) = 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
maxWidthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
l)
    TextAlignment
TextAlignment_Center -> Text -> Bool -> Int -> WrappedLine
WrappedLine Text
t Bool
b ((Int
maxWidthInt -> 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
  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 a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((WrappedLine -> (Text, Int)) -> [WrappedLine] -> [(Text, Int)]
forall a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> f a -> f b
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 a. a -> f a
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 a. a -> f a
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 :: 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 = (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 a b. (a -> b) -> [a] -> [b]
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

      ([[Span tag]]
spansCurrentBefore, [Span tag]
spansCurLineBefore) = ([[Span tag]], [Span tag])
-> Maybe ([[Span tag]], [Span tag]) -> ([[Span tag]], [Span tag])
forall a. a -> Maybe a -> a
fromMaybe ([], []) (Maybe ([[Span tag]], [Span tag]) -> ([[Span tag]], [Span tag]))
-> Maybe ([[Span tag]], [Span tag]) -> ([[Span tag]], [Span tag])
forall a b. (a -> b) -> a -> b
$
        [[Span tag]] -> Maybe ([[Span tag]], [Span tag])
forall a. [a] -> Maybe ([a], a)
initLast ([[Span tag]] -> Maybe ([[Span tag]], [Span tag]))
-> [[Span tag]] -> Maybe ([[Span tag]], [Span tag])
forall a b. (a -> b) -> a -> b
$ (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
_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
alignment Int
width Int
0 Text
b)
      -- Calculate the number of columns on the cursor's display line before the cursor
      curLineOffset :: Int
curLineOffset = [Span tag] -> Int
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 Int -> Int -> Bool
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) = ([Span tag], [[Span tag]])
-> Maybe ([Span tag], [[Span tag]]) -> ([Span tag], [[Span tag]])
forall a. a -> Maybe a -> a
fromMaybe ([], []) (Maybe ([Span tag], [[Span tag]]) -> ([Span tag], [[Span tag]]))
-> Maybe ([Span tag], [[Span tag]]) -> ([Span tag], [[Span tag]])
forall a b. (a -> b) -> a -> b
$
        [[Span tag]] -> Maybe ([Span tag], [[Span tag]])
forall a. [a] -> Maybe (a, [a])
headTail ([[Span tag]] -> Maybe ([Span tag], [[Span tag]]))
-> [[Span tag]] -> Maybe ([Span tag], [[Span tag]])
forall a b. (a -> b) -> a -> b
$ case Text -> Maybe (Char, Text)
T.uncons Text
a of
          Maybe (Char, Text)
Nothing -> [[tag -> Text -> Span tag
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cursorCharWidth
                cursor :: Span tag
cursor = tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
cursorTag (Char -> Text
T.singleton Char
c)
            in case (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
_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
alignment Int
width Int
o Text
rest) of
                  []     -> [[Span tag
cursor]]
                  ([Span tag]
l:[[Span tag]]
ls) -> (Span tag
cursor Span tag -> [Span tag] -> [Span tag]
forall a. a -> [a] -> [a]
: [Span tag]
l) [Span tag] -> [[Span tag]] -> [[Span tag]]
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 [Span tag] -> [Span tag] -> [Span tag]
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 TextAlignment -> TextAlignment -> Bool
forall a. Eq a => a -> a -> Bool
== TextAlignment
TextAlignment_Right Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cursorAfterEOL
        then case [Span tag] -> [Span tag]
forall a. [a] -> [a]
reverse [Span tag]
spansCurLineBefore of
          [] -> [[Span tag]]
curLineSpanNormalCase
          (Span tag
_ Text
x):[Span tag]
xs -> case [Span tag]
spansCurLineAfter of
            [] -> String -> [[Span tag]]
forall a. HasCallStack => String -> a
error String
"should not be possible" -- curLineSpanNormalCase
            (Span tag
_ Text
y):[Span tag]
ys -> [[Span tag] -> [Span tag]
forall a. [a] -> [a]
reverse (tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
cursorTag Text
xSpan tag -> [Span tag] -> [Span tag]
forall a. a -> [a] -> [a]
:[Span tag]
xs) [Span tag] -> [Span tag] -> [Span tag]
forall a. Semigroup a => a -> a -> a
<> ((tag -> Text -> Span tag
forall tag. tag -> Text -> Span tag
Span tag
tag Text
y)Span tag -> [Span tag] -> [Span tag]
forall a. a -> [a] -> [a]
:[Span tag]
ys)]
        else [[Span tag]]
curLineSpanNormalCase

      cursorY :: Int
cursorY = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
        [ [[Span tag]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Span tag]]
spansBefore
        , [[Span tag]] -> Int
forall a. [a] -> Int
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 ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Span tag -> Text) -> [Span tag] -> [Text]
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 = [[[Span tag]]] -> [[Span tag]]
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
      [] -> Maybe ([a], a)
forall a. Maybe a
Nothing
      (a
x:[a]
xs) -> case [a] -> Maybe ([a], a)
forall a. [a] -> Maybe ([a], a)
initLast [a]
xs of
        Maybe ([a], a)
Nothing      -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([], a
x)
        Just ([a]
ys, a
y) -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys, a
y)
    headTail :: [a] -> Maybe (a, [a])
    headTail :: forall a. [a] -> Maybe (a, [a])
headTail = \case
      [] -> Maybe (a, [a])
forall a. Maybe a
Nothing
      a
x:[a]
xs -> (a, [a]) -> Maybe (a, [a])
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 = 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 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] -> 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 :: forall tag. 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