{-# 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
data TextZipper = TextZipper
{ _textZipper_linesBefore :: [Text]
, _textZipper_before :: Text
, _textZipper_after :: Text
, _textZipper_linesAfter :: [Text]
}
deriving (Show)
instance IsString TextZipper where
fromString = fromText . T.pack
mapZipper :: (Char -> Char) -> TextZipper -> TextZipper
mapZipper f (TextZipper lb b a la) = TextZipper
{ _textZipper_linesBefore = fmap (T.map f) lb
, _textZipper_before = T.map f b
, _textZipper_after = T.map f a
, _textZipper_linesAfter = fmap (T.map f) la
}
left :: TextZipper -> TextZipper
left = leftN 1
leftN :: Int -> TextZipper -> TextZipper
leftN n z@(TextZipper lb b a la) =
if T.length b >= n
then
let n' = T.length b - n
in TextZipper lb (T.take n' b) (T.drop n' b <> a) la
else case lb of
[] -> home z
(l:ls) -> leftN (n - T.length b - 1) $ TextZipper ls l "" ((b <> a) : la)
right :: TextZipper -> TextZipper
right = rightN 1
rightN :: Int -> TextZipper -> TextZipper
rightN n z@(TextZipper lb b a la) =
if T.length a >= n
then TextZipper lb (b <> T.take n a) (T.drop n a) la
else case la of
[] -> end z
(l:ls) -> rightN (n - T.length a - 1) $ TextZipper ((b <> a) : lb) "" l ls
up :: TextZipper -> TextZipper
up z@(TextZipper lb b a la) = case lb of
[] -> z
(l:ls) ->
let (b', a') = T.splitAt (T.length b) l
in TextZipper ls b' a' ((b <> a) : la)
down :: TextZipper -> TextZipper
down z@(TextZipper lb b a la) = case la of
[] -> z
(l:ls) ->
let (b', a') = T.splitAt (T.length b) l
in TextZipper ((b <> a) : lb) b' a' ls
pageUp :: Int -> TextZipper -> TextZipper
pageUp pageSize z = if pageSize <= 0
then z
else pageUp (pageSize - 1) $ up z
pageDown :: Int -> TextZipper -> TextZipper
pageDown pageSize z = if pageSize <= 0
then z
else pageDown (pageSize - 1) $ down z
home :: TextZipper -> TextZipper
home (TextZipper lb b a la) = TextZipper lb "" (b <> a) la
end :: TextZipper -> TextZipper
end (TextZipper lb b a la) = TextZipper lb (b <> a) "" la
top :: TextZipper -> TextZipper
top (TextZipper lb b a la) = case reverse lb of
[] -> TextZipper [] "" (b <> a) la
(start:rest) -> TextZipper [] "" start (rest <> [b <> a] <> la)
insertChar :: Char -> TextZipper -> TextZipper
insertChar i = insert (T.singleton i)
insert :: Text -> TextZipper -> TextZipper
insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of
[] -> z
(start:rest) -> case reverse rest of
[] -> TextZipper lb (b <> start) a la
(l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la
deleteLeft :: TextZipper-> TextZipper
deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of
Nothing -> case lb of
[] -> z
(l:ls) -> TextZipper ls l a la
Just (b', _) -> TextZipper lb b' a la
deleteRight :: TextZipper -> TextZipper
deleteRight z@(TextZipper lb b a la) = case T.uncons a of
Nothing -> case la of
[] -> z
(l:ls) -> TextZipper lb b l ls
Just (_, a') -> TextZipper lb b a' la
deleteLeftWord :: TextZipper -> TextZipper
deleteLeftWord (TextZipper lb b a la) =
let b' = T.dropWhileEnd isSpace b
in if T.null b'
then case lb of
[] -> TextZipper [] b' a la
(l:ls) -> deleteLeftWord $ TextZipper ls l a la
else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la
tab :: Int -> TextZipper -> TextZipper
tab n z@(TextZipper _ b _ _) =
insert (T.replicate (fromEnum $ n - (T.length b `mod` max 1 n)) " ") z
value :: TextZipper -> Text
value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb
, [b <> a]
, la
]
empty :: TextZipper
empty = TextZipper [] "" "" []
fromText :: Text -> TextZipper
fromText = flip insert empty
data Span tag = Span tag Text
deriving (Show)
data DisplayLines tag = DisplayLines
{ _displayLines_spans :: [[Span tag]]
, _displayLines_offsetMap :: Map Int Int
, _displayLines_cursorY :: Int
}
deriving (Show)
displayLines
:: Int
-> tag
-> tag
-> TextZipper
-> DisplayLines tag
displayLines width tag cursorTag (TextZipper lb b a la) =
let linesBefore :: [[Text]]
linesBefore = map (wrapWithOffset width 0) $ reverse lb
linesAfter :: [[Text]]
linesAfter = map (wrapWithOffset width 0) la
offsets :: Map Int Int
offsets = offsetMap $ mconcat
[ linesBefore
, [wrapWithOffset width 0 $ b <> a]
, linesAfter
]
spansBefore = map ((:[]) . Span tag) $ concat linesBefore
spansAfter = map ((:[]) . Span tag) $ concat linesAfter
(spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
initLast $ map ((:[]) . Span tag) (wrapWithOffset width 0 b)
curLineOffset = spansWidth spansCurLineBefore
cursorAfterEOL = curLineOffset == width
cursorCharWidth = case T.uncons a of
Nothing -> 1
Just (c, _) -> charWidth c
(spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
headTail $ case T.uncons a of
Nothing -> [[Span cursorTag " "]]
Just (c, rest) ->
let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
cursor = Span cursorTag (T.singleton c)
in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
[] -> [[cursor]]
(l:ls) -> (cursor : l) : ls
in DisplayLines
{ _displayLines_spans = concat
[ spansBefore
, spansCurrentBefore
, if cursorAfterEOL
then [ spansCurLineBefore, spansCurLineAfter ]
else [ spansCurLineBefore <> spansCurLineAfter ]
, spansCurrentAfter
, spansAfter
]
, _displayLines_offsetMap = offsets
, _displayLines_cursorY = sum
[ length spansBefore
, length spansCurrentBefore
, if cursorAfterEOL then cursorCharWidth else 0
]
}
where
initLast :: [a] -> Maybe ([a], a)
initLast = \case
[] -> Nothing
(x:xs) -> case initLast xs of
Nothing -> Just ([], x)
Just (ys, y) -> Just (x:ys, y)
headTail :: [a] -> Maybe (a, [a])
headTail = \case
[] -> Nothing
x:xs -> Just (x, xs)
wrapWithOffset
:: Int
-> Int
-> Text
-> [Text]
wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []
wrapWithOffset maxWidth n xs =
let (firstLine, rest) = splitAtWidth (maxWidth - n) xs
in firstLine : (fmap (takeWidth maxWidth) . takeWhile (not . T.null) . iterate (dropWidth maxWidth) $ rest)
splitAtWidth :: Int -> Text -> (Text, Text)
splitAtWidth n t@(Text arr off len)
| n <= 0 = (T.empty, t)
| n >= textWidth t = (t, T.empty)
| otherwise = let k = iterNWidth n t
in (text arr off k, text arr (off+k) (len-k))
where
iterNWidth :: Int -> Text -> Int
iterNWidth n' t'@(Text _ _ len') = loop 0 0
where loop !i !cnt
| i >= len' || cnt + w > n' = i
| otherwise = loop (i+d) (cnt + w)
where Iter c d = iter t' i
w = charWidth c
takeWidth :: Int -> Text -> Text
takeWidth n = fst . splitAtWidth n
dropWidth :: Int -> Text -> Text
dropWidth n = snd . splitAtWidth n
charWidth :: Char -> Int
charWidth c = case property EastAsianWidth c of
EAFull -> 2
EAWide -> 2
_ -> 1
offsetMap
:: [[Text]]
-> Map Int Int
offsetMap ts = evalState (offsetMap' ts) (0, 0)
where
offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
maps <- forM x $ \line -> do
let l = T.length line
(dl, o) <- get
put (dl + 1, o + l)
return $ Map.singleton dl o
(dl, o) <- get
put (dl, o + 1)
return $ Map.insert dl (o + 1) $ Map.unions maps
goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
goToDisplayLinePosition x y dl tz =
let offset = Map.lookup y $ _displayLines_offsetMap dl
in case offset of
Nothing -> tz
Just o ->
let displayLineLength = case drop y $ _displayLines_spans dl of
[] -> x
(s:_) -> spansWidth s
in rightN (o + min displayLineLength x) $ top tz
spansWidth :: [Span tag] -> Int
spansWidth = sum . map (\(Span _ t) -> textWidth t)
spansLength :: [Span tag] -> Int
spansLength = sum . map (\(Span _ t) -> T.length t)
textWidth :: Text -> Int
textWidth t = widthI (stream t)
widthI :: Stream Char -> Int
widthI (Stream next s0 _len) = loop_length 0 s0
where
loop_length !z s = case next s of
Done -> z
Skip s' -> loop_length z s'
Yield c s' -> loop_length (z + charWidth c) s'
{-# INLINE[0] widthI #-}