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

-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Text.Zipper where

import Data.Char (isSpace)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.String
import Control.Monad.State (evalState, forM, get, put)

import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.ICU.Char
import Data.Text.Internal (Text(..), text)
import Data.Text.Internal.Fusion (stream)
import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
import Data.Text.Unsafe

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Information about the document as it is displayed (i.e., post-wrapping)
data DisplayLines tag = DisplayLines
  { DisplayLines tag -> [[Span tag]]
_displayLines_spans :: [[Span tag]]
  , DisplayLines tag -> Map Int Int
_displayLines_offsetMap :: Map Int Int
  , DisplayLines tag -> Int
_displayLines_cursorY :: Int
  }
  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
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)

-- | Given a width and a 'TextZipper', produce a list of display lines
-- (i.e., lines of wrapped text) with special attributes applied to
-- certain segments (e.g., the cursor). Additionally, produce the current
-- y-coordinate of the cursor and a mapping from display line number to text
-- offset
displayLines
  :: Int -- ^ Width, used for wrapping
  -> tag -- ^ Metadata for normal characters
  -> tag -- ^ Metadata for the cursor
  -> TextZipper -- ^ The text input contents and cursor state
  -> DisplayLines tag
displayLines :: Int -> tag -> tag -> TextZipper -> DisplayLines tag
displayLines Int
width tag
tag tag
cursorTag (TextZipper [Text]
lb Text
b Text
a [Text]
la) =
  let linesBefore :: [[Text]] -- The wrapped lines before the cursor line
      linesBefore :: [[Text]]
linesBefore = (Text -> [Text]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Text -> [Text]
wrapWithOffset Int
width Int
0) ([Text] -> [[Text]]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
lb
      linesAfter :: [[Text]] -- The wrapped lines after the cursor line
      linesAfter :: [[Text]]
linesAfter = (Text -> [Text]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Text -> [Text]
wrapWithOffset Int
width Int
0) [Text]
la
      offsets :: Map Int Int
      offsets :: Map Int Int
offsets = [[Text]] -> Map Int Int
offsetMap ([[Text]] -> Map Int Int) -> [[Text]] -> Map Int Int
forall a b. (a -> b) -> a -> b
$ [[[Text]]] -> [[Text]]
forall a. Monoid a => [a] -> a
mconcat
        [ [[Text]]
linesBefore
        , [Int -> Int -> Text -> [Text]
wrapWithOffset Int
width Int
0 (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a]
        , [[Text]]
linesAfter
        ]
      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
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
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
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
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) (Int -> Int -> Text -> [Text]
wrapWithOffset 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) (Int -> Int -> Text -> [Text]
wrapWithOffset 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
  in  DisplayLines :: forall tag. [[Span tag]] -> Map Int Int -> Int -> DisplayLines tag
DisplayLines
        { _displayLines_spans :: [[Span tag]]
_displayLines_spans = [[[Span tag]]] -> [[Span tag]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [[Span tag]]
spansBefore
          , [[Span tag]]
spansCurrentBefore
          , 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 ]
          , [[Span tag]]
spansCurrentAfter
          , [[Span tag]]
spansAfter
          ]
        , _displayLines_offsetMap :: Map Int Int
_displayLines_offsetMap = Map Int Int
offsets
        , _displayLines_cursorY :: Int
_displayLines_cursorY = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
          [ [[Span tag]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Span tag]]
spansBefore
          , [[Span tag]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Span tag]]
spansCurrentBefore
          , if Bool
cursorAfterEOL then Int
cursorCharWidth else Int
0
          ]
        }
  where
    initLast :: [a] -> Maybe ([a], a)
    initLast :: [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 :: [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)

-- | 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
_ Text
_ | Int
maxWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = []
wrapWithOffset Int
maxWidth Int
n Text
xs =
  let (Text
firstLine, Text
rest) = Int -> Text -> (Text, Text)
splitAtWidth (Int
maxWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Text
xs
  in Text
firstLine Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text -> Text
takeWidth Int
maxWidth) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> Text -> [Text]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Text -> Text
dropWidth Int
maxWidth) (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
rest)

-- | 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
iterNWidth 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))
  where
    iterNWidth :: Int -> Text -> Int
    iterNWidth :: Int -> Text -> Int
iterNWidth 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.
charWidth :: Char -> Int
charWidth :: Char -> Int
charWidth Char
c = case EastAsianWidth_ -> Char -> EastAsianWidth
forall p v. Property p v => p -> Char -> v
property EastAsianWidth_
EastAsianWidth Char
c of
  EastAsianWidth
EAFull -> Int
2
  EastAsianWidth
EAWide -> Int
2
  EastAsianWidth
_ -> Int
1

-- | For a given set of wrapped logical lines, computes a map
-- from display line index to text offset in the original text.
-- This is used to help determine how interactions with the displayed
-- text map back to the original text.
-- For example, given the document @\"AA\\nBBB\\nCCCCCCCC\\n\"@ wrapped to 5 columns,
-- this function will compute the offset in the original document of each character
-- in column 1:
--
-- >   AA...      (0, 0)
-- >   BBB..      (1, 3)
-- >   CCCCC      (2, 7)  -- (this line wraps to the next row)
-- >   CCC..      (3, 12)
-- >   .....      (4, 16)
offsetMap
  :: [[Text]] -- ^ The outer list represents logical lines, and the
              -- inner list represents the display lines into which
              -- the logical line has been wrapped
  -> Map Int Int -- ^ A map from the index (row) of display line to
                 -- the text offset from the beginning of the document
                 -- to the first character of the display line
offsetMap :: [[Text]] -> Map Int Int
offsetMap [[Text]]
ts = State (Int, Int) (Map Int Int) -> (Int, Int) -> Map Int Int
forall s a. State s a -> s -> a
evalState ([[Text]] -> State (Int, Int) (Map Int Int)
forall k (f :: * -> *) (f :: * -> *) (f :: * -> *).
(Ord k, Traversable f, Traversable f, MonadState (k, Int) f,
 Num k) =>
f (f Text) -> f (Map k Int)
offsetMap' [[Text]]
ts) (Int
0, Int
0)
  where
    offsetMap' :: f (f Text) -> f (Map k Int)
offsetMap' f (f Text)
xs = (f (Map k Int) -> Map k Int) -> f (f (Map k Int)) -> f (Map k Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Map k Int) -> Map k Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (f (f (Map k Int)) -> f (Map k Int))
-> f (f (Map k Int)) -> f (Map k Int)
forall a b. (a -> b) -> a -> b
$ f (f Text) -> (f Text -> f (Map k Int)) -> f (f (Map k Int))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM f (f Text)
xs ((f Text -> f (Map k Int)) -> f (f (Map k Int)))
-> (f Text -> f (Map k Int)) -> f (f (Map k Int))
forall a b. (a -> b) -> a -> b
$ \f Text
x -> do
      f (Map k Int)
maps <- f Text -> (Text -> f (Map k Int)) -> f (f (Map k Int))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM f Text
x ((Text -> f (Map k Int)) -> f (f (Map k Int)))
-> (Text -> f (Map k Int)) -> f (f (Map k Int))
forall a b. (a -> b) -> a -> b
$ \Text
line -> 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 Int -> f (Map k Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k Int -> f (Map k Int)) -> Map k Int -> f (Map k Int)
forall a b. (a -> b) -> a -> b
$ k -> Int -> Map k Int
forall k a. k -> a -> Map k a
Map.singleton k
dl 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)
      Map k Int -> f (Map k Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k Int -> f (Map k Int)) -> Map k Int -> f (Map k Int)
forall a b. (a -> b) -> a -> b
$ k -> Int -> Map k Int -> Map k Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
dl (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Map k Int -> Map k Int) -> Map k Int -> Map k Int
forall a b. (a -> b) -> a -> b
$ f (Map k Int) -> Map k Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions f (Map k Int)
maps

-- | Move the cursor of the given 'TextZipper' to the logical position indicated
-- by the given display line coordinates, using the provided 'DisplayLines'
-- information.  If the x coordinate is beyond the end of a line, the cursor is
-- moved to the end of the line.
goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
goToDisplayLinePosition Int
x Int
y DisplayLines tag
dl TextZipper
tz =
  let offset :: Maybe Int
offset = Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
y (Map Int Int -> Maybe Int) -> Map Int Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ DisplayLines tag -> Map Int Int
forall tag. DisplayLines tag -> Map Int Int
_displayLines_offsetMap DisplayLines tag
dl
  in  case Maybe Int
offset of
        Maybe Int
Nothing -> TextZipper
tz
        Just Int
o ->
          let displayLineLength :: Int
displayLineLength = 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
x
                ([Span tag]
s:[[Span tag]]
_) -> [Span tag] -> Int
forall tag. [Span tag] -> Int
spansWidth [Span tag]
s
          in  Int -> TextZipper -> TextZipper
rightN (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
displayLineLength Int
x) (TextZipper -> TextZipper) -> TextZipper -> TextZipper
forall a b. (a -> b) -> a -> b
$ TextZipper -> TextZipper
top TextZipper
tz

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

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

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

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