module Data.Text.Zipper where
import Prelude
import Control.Exception (assert)
import Control.Monad.State (evalState, forM, get, put)
import Data.Char (isSpace)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text (Text)
import Data.Text.Internal (Text(..), text)
import Data.Text.Internal.Fusion (stream)
import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
import Data.Text.Unsafe
import qualified Data.List as L
import qualified Data.Map as Map
import qualified Data.Text as T
import Graphics.Text.Width (wcwidth)
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 TextAlignment =
TextAlignment_Left
| TextAlignment_Right
| TextAlignment_Center
deriving (Eq, Show)
type OffsetMapWithAlignment = Map Int (Int, Int)
data WrappedLine = WrappedLine
{ _wrappedLines_text :: Text
, _wrappedLines_hiddenWhitespace :: Bool
, _wrappedLines_offset :: Int
}
deriving (Eq, Show)
data DisplayLines tag = DisplayLines
{ _displayLines_spans :: [[Span tag]]
, _displayLines_offsetMap :: OffsetMapWithAlignment
, _displayLines_cursorPos :: (Int, Int)
}
deriving (Show)
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 = toLogicalIndex n t
in (text arr off k, text arr (off+k) (len-k))
toLogicalIndex :: Int -> Text -> Int
toLogicalIndex 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 = wcwidth
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 #-}
charIndexAt :: Int -> Stream Char -> Int
charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
where
loop_length i !z s = case next s of
Done -> i
Skip s' -> loop_length i z s'
Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
w = z + charWidth c
{-# INLINE[0] charIndexAt #-}
wordsWithWhitespace :: Text -> [Text]
wordsWithWhitespace t@(Text arr off len) = loop 0 0 False
where
loop !start !n !wasSpace
| n >= len = [Text arr (start+off) (n-start) | not (start == n)]
| isSpace c = loop start (n+d) True
| wasSpace = Text arr (start+off) (n-start) : loop n n False
| otherwise = loop start (n+d) False
where Iter c d = iter t n
{-# INLINE wordsWithWhitespace #-}
splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]
splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]
appendOut [] t b = [(t,b)]
appendOut ((t',_):ts') t b = (t'<>t,b) : ts'
modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]
modifyOutForNewLine [] = error "should never happen"
modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of
Nothing -> error "should never happen"
Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts
loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]
loop [] _ out = out
loop (x:xs) cumw out = r where
newWidth = textWidth x + cumw
r = if newWidth > maxWidth
then if isSpace $ T.index x (toLogicalIndex (maxWidth - cumw) x)
then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True
else if cumw == 0
then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
in loop (t2:xs) 0 [] <> appendOut out t1 False
else loop (x:xs) 0 [] <> modifyOutForNewLine out
else loop xs newWidth $ appendOut out x False
wrapWithOffsetAndAlignment
:: TextAlignment
-> Int
-> Int
-> Text
-> [WrappedLine]
wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []
wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where
r' = splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)
fmapfn (t,b) = case alignment of
TextAlignment_Left -> WrappedLine t b 0
TextAlignment_Right -> WrappedLine t b (maxWidth-l)
TextAlignment_Center -> WrappedLine t b ((maxWidth-l) `div` 2)
where l = textWidth t
r'' = case r' of
[] -> []
(x,b):xs -> (T.drop n x,b):xs
r = fmap fmapfn r''
eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]
eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b))
offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines
offsetMapWithAlignment
:: [[(Text, Int)]]
-> OffsetMapWithAlignment
offsetMapWithAlignment ts = evalState (offsetMap' ts) (0, 0)
where
offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
maps <- forM x $ \(line,align) -> do
let l = T.length line
(dl, o) <- get
put (dl + 1, o + l)
return $ Map.singleton dl (align, o)
(dl, o) <- get
put (dl, o + 1)
return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps
displayLinesWithAlignment
:: TextAlignment
-> Int
-> tag
-> tag
-> TextZipper
-> DisplayLines tag
displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =
let linesBefore :: [[WrappedLine]]
linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb
linesAfter :: [[WrappedLine]]
linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la
afterWithCursor = if T.null a then " " else a
offsets :: OffsetMapWithAlignment
offsets = offsetMapWithAlignmentInternal $ mconcat
[ linesBefore
, [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor]
, linesAfter
]
flattenLines = concatMap (fmap _wrappedLines_text)
spansBefore = map ((:[]) . Span tag) $ flattenLines linesBefore
spansAfter = map ((:[]) . Span tag) $ flattenLines linesAfter
(spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
initLast $ map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment 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) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width o rest) of
[] -> [[cursor]]
(l:ls) -> (cursor : l) : ls
curLineSpanNormalCase = if cursorAfterEOL
then [ spansCurLineBefore, spansCurLineAfter ]
else [ spansCurLineBefore <> spansCurLineAfter ]
curLineSpan = if alignment == TextAlignment_Right && not cursorAfterEOL
then case reverse spansCurLineBefore of
[] -> curLineSpanNormalCase
(Span _ x):xs -> case spansCurLineAfter of
[] -> error "should not be possible"
(Span _ y):ys -> [reverse (Span cursorTag x:xs) <> ((Span tag y):ys)]
else curLineSpanNormalCase
cursorY = sum
[ length spansBefore
, length spansCurrentBefore
, if cursorAfterEOL then 1 else 0
]
cursorX = if cursorAfterEOL then 0 else textWidth (mconcat $ fmap (\(Span _ t) -> t) spansCurLineBefore)
in DisplayLines
{ _displayLines_spans = concat
[ spansBefore
, spansCurrentBefore
, curLineSpan
, spansCurrentAfter
, spansAfter
]
, _displayLines_offsetMap = offsets
, _displayLines_cursorPos = (cursorX, cursorY)
}
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)
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 (alignOff,o) ->
let
trueX = max 0 (x - alignOff)
moveRight = case drop y $ _displayLines_spans dl of
[] -> 0
(s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s
in rightN (o + moveRight) $ top tz
displayLines
:: Int
-> tag
-> tag
-> TextZipper
-> DisplayLines tag
displayLines = displayLinesWithAlignment TextAlignment_Left
wrapWithOffset
:: Int
-> Int
-> Text
-> [Text]
wrapWithOffset maxWidth n xs = _wrappedLines_text <$> wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs