git.iko.soy/reflex-vty
on develop help sign in
Line wrapping: Keep better track of how text has been transformed for rendering

Also fixes some issues with deleteLeft and deleteRight

commit17702449c5110f2e734ae09ece89f2d6b7bfc947 authorAli Abrar <aliabrar@gmail.com> dateSun 4 Nov 2018, 01:59 (8 years ago) parentf162842
3 files changed+221−143
compare with develop
unifiedsplit
reflex-vty.cabal+1 src/Reflex/Vty/Widget.hs+24−141 src/Reflex/Vty/Widget/Text.hs+196−2
reflex-vty.cabal+1
@@ -18,6 +18,7 @@ library
1818 other-modules: Reflex.Spider.Orphans
1919 build-depends:
2020 base,
21+ containers,
2122 data-default,
2223 dependent-sum,
2324 mtl,
src/Reflex/Vty/Widget.hs+24−141
@@ -55,9 +55,7 @@ import Control.Monad.Fix (MonadFix)
5555import Control.Monad.Trans (lift)
5656import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)
5757import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell)
58−import Data.Char
5958import Data.Default
60−import Data.Maybe (fromMaybe)
6159import Data.Text (Text)
6260import qualified Data.Text as T
6361import Graphics.Vty (Image, Attr)
@@ -65,6 +63,8 @@ import qualified Graphics.Vty as V
6563import Reflex
6664
6765import Reflex.Vty.Host
66+import Reflex.Vty.Widget.Text (TextZipper(..), DisplayLines(..))
67+import qualified Reflex.Vty.Widget.Text as TZ
6868
6969-- | The context within which a 'VtyWidget' runs
7070data VtyWidgetCtx t = VtyWidgetCtx
@@ -448,166 +448,49 @@ wrapWithOffset maxWidth n xs =
448448 let (firstLine, rest) = T.splitAt (maxWidth - n) xs
449449 in firstLine : (fmap (T.take maxWidth) . takeWhile (not . T.null) . iterate (T.drop maxWidth) $ rest)
450450
451−wrapInputState
452− :: Int -- ^ Maximum line length
453− -> Attr -- ^ Normal string attributes
454− -> Attr -- ^ Cursor character attributes
455− -> InputState -- ^ The input to render
456− -> ([Image], Int)
457−wrapInputState maxWidth attrs cursorAttrs (InputState before after) =
458− let -- Break up the InputState into:
459− -- * A top section of lines before the line containing the cursor
460− -- * A part of the line containing the cursor that comes immediately before the cursor
461− -- * The cursor character (i.e., the character the cursor is on top of)
462− -- * The remainder of the line containing the cursor
463− -- * The bottom section of lines after the line containing the cursor
464− (top, midBefore, cursorChar, midAfter, bottom) = case (initLast before', headTail after') of
465− (Nothing, Nothing) -> ([], "", ' ', "", [])
466− (Just (top', mid), Nothing) -> (top', mid, ' ', "", [])
467− (Nothing, Just (mid, bottom')) -> case T.uncons mid of
468− Nothing -> ([], "", ' ', "", bottom')
469− Just (c, rest) -> ([], "", c, rest, bottom')
470− (Just (top', midB), Just (midA, bottom')) -> case T.uncons midA of
471− Nothing -> (top', midB, ' ', "", bottom')
472− Just (c, rest) -> (top', midB, c, rest, bottom')
473− wrappedTop = wrap top
474− wrappedBottom = wrap bottom
475− (midBeforeTop, midBefore') = fromMaybe ([], "") $ initLast $ wrap [midBefore]
476− cursorAfterEOL = T.length midBefore' == maxWidth
477− (midAfter', midAfterBottom) =
478− let offset = if cursorAfterEOL then 1 else T.length midBefore' + 1
479− in case wrapWithOffset maxWidth offset midAfter of
480− [] -> ("", [])
481− x:xs -> (x, xs)
482− cursor = V.char cursorAttrs cursorChar
483− images = mconcat
484− [ vstring <$> wrappedTop
485− , vstring <$> midBeforeTop
486− , if cursorAfterEOL
487− then
488− [ vstring midBefore'
489− , V.horizCat
490− [ cursor
491− , vstring midAfter'
492− ]
493− ]
494− else
495− [ V.horizCat
496− [ vstring midBefore'
497− , cursor
498− , vstring midAfter'
499− ]
500− ]
501− , vstring <$> midAfterBottom
502− , vstring <$> wrappedBottom
503− ]
504− cursorY = length wrappedTop + length midBeforeTop + if cursorAfterEOL then 1 else 0
505− in (images, cursorY)
506− where
507− before' = T.split (=='\n') before
508− after' = T.split (=='\n') after
509− vstring = V.string attrs . T.unpack
510− wrap :: [Text] -> [Text]
511− wrap = concatMap (wrapWithOffset maxWidth 0)
512− headTail :: [a] -> Maybe (a, [a])
513− headTail = \case
514− [] -> Nothing
515− x:xs -> Just (x, xs)
516− initLast :: [a] -> Maybe ([a], a)
517− initLast = \case
518− [] -> Nothing
519− (x:xs) -> case initLast xs of
520− Nothing -> Just ([], x)
521− Just (ys, y) -> Just (x:ys, y)
522−
523−data InputState = InputState
524− { _inputState_beforeCursor :: Text
525− , _inputState_afterCursor :: Text
526− }
527−
528−inputValue :: InputState -> Text
529−inputValue (InputState a b) = a <> b
530−
531−updateInputState :: V.Event -> InputState -> InputState
532−updateInputState ev i@(InputState before after) = case ev of
533− -- Regular characters
534− V.EvKey (V.KChar k) [] -> InputState (T.snoc before k) after
535− -- Deletion buttons
536− V.EvKey V.KBS [] -> InputState (if T.null before then T.empty else T.init before) after
537− V.EvKey V.KDel [] -> case T.uncons after of
538− Nothing -> i
539− Just (_, a) -> InputState before a
540− -- Key combinations
541− V.EvKey (V.KChar 'u') [V.MCtrl] -> InputState mempty mempty
542− V.EvKey (V.KChar 'w') [V.MCtrl] -> InputState (T.dropWhileEnd (not . isSpace) $ T.dropWhileEnd isSpace $ before) after
543− -- Arrow keys
544− V.EvKey V.KRight [] -> case T.uncons after of
545− Nothing -> i
546− Just (a, as) -> InputState (T.snoc before a) as
547− V.EvKey V.KLeft [] -> case T.unsnoc before of
548− Nothing -> i
549− Just (bs, b) -> InputState bs (T.cons b after)
550− V.EvKey V.KUp [] ->
551− let (pre, post) = T.breakOnEnd "\n" before
552− (top, previousLine) = T.breakOnEnd "\n" (T.dropEnd 1 pre)
553− (previousLineBefore, previousLineAfter) = T.splitAt (T.length post) previousLine
554− in if T.null pre
555− then i
556− else InputState (top <> previousLineBefore) (previousLineAfter <> "\n" <> post <> after)
557− V.EvKey V.KDown [] ->
558− let offset = T.length $ T.takeWhileEnd (/='\n') before
559− (pre, post) = T.breakOn "\n" after
560− (nextLine, rest) = T.breakOn "\n" (T.drop 1 post)
561− (nextLineBefore, nextLineAfter) = T.splitAt offset nextLine
562− in if T.null post
563− then i
564− else InputState (before <> pre <> "\n" <> nextLineBefore) (nextLineAfter <> rest)
565− V.EvKey V.KHome [] ->
566− let (pre, post) = T.breakOnEnd "\n" before
567− in InputState pre (post <> after)
568− V.EvKey V.KEnd [] ->
569− let (pre, post) = T.breakOn "\n" after
570− in InputState (before <> pre) post
571− _ -> i
572−
573451data TextInputConfig t = TextInputConfig
574− { _textInputConfig_initialValue :: Text
575− , _textInputConfig_modifyInputState :: Event t (InputState -> InputState)
452+ { _textInputConfig_initialValue :: TextZipper
453+ , _textInputConfig_modify :: Event t (TextZipper -> TextZipper)
576454 }
577455
578456instance Reflex t => Default (TextInputConfig t) where
579− def = TextInputConfig "" never
457+ def = TextInputConfig TZ.empty never
580458
581−textInput :: (Reflex t, MonadHold t m, MonadFix m) => TextInputConfig t -> VtyWidget t m (Dynamic t Text)
459+textInput
460+ :: (Reflex t, MonadHold t m, MonadFix m)
461+ => TextInputConfig t
462+ -> VtyWidget t m (Dynamic t Text)
582463textInput cfg = do
583464 i <- input
584− v <- foldDyn ($) (InputState (_textInputConfig_initialValue cfg) mempty) $ mergeWith (.)
585− [ updateInputState <$> i
586− , _textInputConfig_modifyInputState cfg
465+ v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
466+ [ TZ.updateTextZipper <$> i
467+ , _textInputConfig_modify cfg
587468 ]
588469 dw <- displayWidth
589470 dh <- displayHeight
590− let img = (\w s -> wrapInputState w V.defAttr (V.withStyle V.defAttr V.reverseVideo) s) -- TODO cursor ought to blink
591− <$> dw
592− <*> v
593− y <- holdUniqDyn $ snd <$> img
471+ let rows = (\w s -> TZ.displayLines w s) <$> dw <*> v
472+ img = TZ.images . _displayLines_spans <$> rows
473+ y <- holdUniqDyn $ _displayLines_cursorY <$> rows
594474 let newScrollTop st (h, cursorY)
595475 | cursorY < st = cursorY
596476 | cursorY >= st + h = cursorY - h + 1
597477 | otherwise = st
598478 rec let hy = attachWith newScrollTop (current scrollTop) $ updated $ zipDyn dh y
599479 scrollTop <- holdDyn 0 hy
600− tellImages $ (\(imgs, _) st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> current scrollTop
601− return $ inputValue <$> v
480+ tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> current scrollTop
481+ return $ TZ.value <$> v
602482
603−multilineTextInput :: (Reflex t, MonadHold t m, MonadFix m) => TextInputConfig t -> VtyWidget t m (Dynamic t Text)
483+multilineTextInput
484+ :: (Reflex t, MonadHold t m, MonadFix m)
485+ => TextInputConfig t
486+ -> VtyWidget t m (Dynamic t Text)
604487multilineTextInput cfg = do
605488 i <- input
606489 textInput $ cfg
607− { _textInputConfig_modifyInputState = mergeWith (.)
490+ { _textInputConfig_modify = mergeWith (.)
608491 [ fforMaybe i $ \case
609− V.EvKey V.KEnter [] -> Just $ \(InputState before after) -> InputState (T.snoc before '\n') after
492+ V.EvKey V.KEnter [] -> Just $ TZ.insert "\n"
610493 _ -> Nothing
611− , _textInputConfig_modifyInputState cfg
494+ , _textInputConfig_modify cfg
612495 ]
613496 }
src/Reflex/Vty/Widget/Text.hs+196−2
@@ -1,8 +1,17 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE LambdaCase #-}
13{-# LANGUAGE OverloadedStrings #-}
24module Reflex.Vty.Widget.Text where
35
6+import Data.Char
7+import Data.Map (Map)
8+import qualified Data.Map as Map
9+import Data.Maybe (fromMaybe)
10+import Control.Monad.State
11+
412import Data.Text (Text)
513import qualified Data.Text as T
14+import qualified Graphics.Vty as V
615
716-- | A zipper of the logical text input contents. The lines before the line containing the cursor
817-- are stored in reverse order. The cursor is logically _between_ the "before" and "after" text.
@@ -60,12 +69,197 @@ insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of
6069 [] -> TextZipper lb (b <> start) a la
6170 (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la
6271
72+deleteLeft :: TextZipper-> TextZipper
73+deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of
74+ Nothing -> case lb of
75+ [] -> z
76+ (l:ls) -> TextZipper ls l a la
77+ Just (b', _) -> TextZipper lb b' a la
78+
79+deleteRight :: TextZipper -> TextZipper
80+deleteRight z@(TextZipper lb b a la) = case T.uncons a of
81+ Nothing -> case la of
82+ [] -> z
83+ (l:ls) -> TextZipper lb b l ls
84+ Just (_, a') -> TextZipper lb b a' la
85+
86+deleteLeftWord :: TextZipper -> TextZipper
87+deleteLeftWord (TextZipper lb b a la) =
88+ let b' = T.dropWhileEnd isSpace b
89+ in if T.null b'
90+ then case lb of
91+ [] -> TextZipper [] b' a la
92+ (l:ls) -> deleteLeftWord $ TextZipper ls l a la
93+ else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la
94+
6395value :: TextZipper -> Text
64−value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat
65− [ reverse lb
96+value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb
6697 , [b <> a]
6798 , la
6899 ]
69100
70101empty :: TextZipper
71102empty = TextZipper [] "" "" []
103+
104+fromText :: Text -> TextZipper
105+fromText = flip insert empty
106+
107+-- | A span of text that makes up part of a display line
108+data Span = Span V.Attr Text
109+ deriving (Show)
110+
111+-- | Default attributes for the text cursor
112+cursorAttributes :: V.Attr
113+cursorAttributes = V.withStyle V.defAttr V.reverseVideo
114+
115+-- | Information about the documents as it is displayed (i.e., post-wrapping)
116+data DisplayLines = DisplayLines
117+ { _displayLines_spans :: [[Span]]
118+ , _displayLines_offsetMap :: Map Int Int
119+ , _displayLines_cursorY :: Int
120+ }
121+ deriving (Show)
122+
123+-- | Given a width and a 'TextZipper', produce a list of display lines
124+-- (i.e., lines of wrapped text) with special attributes applied to
125+-- certain segments (e.g., the cursor). Additionally, produce the current
126+-- y-coordinate of the cursor and a mapping from display line number to text
127+-- offset
128+displayLines
129+ :: Int -- ^ Width, used for wrapping
130+ -> TextZipper -- ^ The text input contents and cursor state
131+ -> DisplayLines
132+displayLines width (TextZipper lb b a la) =
133+ let linesBefore :: [[Text]]
134+ linesBefore = map (wrapWithOffset width 0) $ reverse lb
135+ linesAfter :: [[Text]]
136+ linesAfter = map (wrapWithOffset width 0) la
137+ offsets = offsetMap $ mconcat
138+ [ linesBefore
139+ , [wrapWithOffset width 0 $ b <> a]
140+ , linesAfter
141+ ]
142+ spansBefore = map ((:[]) . Span V.defAttr) $ concat linesBefore
143+ spansAfter = map ((:[]) . Span V.defAttr) $ concat linesAfter
144+ (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
145+ initLast $ map ((:[]) . Span V.defAttr) (wrapWithOffset width 0 b)
146+ curLineOffset = spansLength spansCurLineBefore
147+ cursorAfterEOL = curLineOffset == width
148+ -- (cursor, spansCurLineAfter, spansCurrentAfter) = case T.uncons a of
149+ -- Nothing -> (Span cursorAttributes " ", [], [])
150+ -- Just (c, rest) ->
151+ -- ( Span cursorAttributes (T.singleton c)
152+ -- ,
153+
154+ (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
155+ headTail $ case T.uncons a of
156+ Nothing -> [[Span cursorAttributes " "]]
157+ Just (c, rest) ->
158+ let o = if cursorAfterEOL then 1 else curLineOffset + 1
159+ cursor = Span cursorAttributes (T.singleton c)
160+ in case map ((:[]) . Span V.defAttr) (wrapWithOffset width o rest) of
161+ [] -> [[cursor]]
162+ (l:ls) -> (cursor : l) : ls
163+ in DisplayLines
164+ { _displayLines_spans = concat
165+ [ spansBefore
166+ , spansCurrentBefore
167+ , if cursorAfterEOL
168+ then [ spansCurLineBefore, spansCurLineAfter ]
169+ else [ spansCurLineBefore <> spansCurLineAfter ]
170+ , spansCurrentAfter
171+ , spansAfter
172+ ]
173+ , _displayLines_offsetMap = offsets
174+ , _displayLines_cursorY = sum
175+ [ length spansBefore
176+ , length spansCurrentBefore
177+ , if cursorAfterEOL then 1 else 0
178+ ]
179+ }
180+ where
181+ spansLength :: [Span] -> Int
182+ spansLength = sum . map (\(Span _ t) -> T.length t)
183+ initLast :: [a] -> Maybe ([a], a)
184+ initLast = \case
185+ [] -> Nothing
186+ (x:xs) -> case initLast xs of
187+ Nothing -> Just ([], x)
188+ Just (ys, y) -> Just (x:ys, y)
189+ headTail :: [a] -> Maybe (a, [a])
190+ headTail = \case
191+ [] -> Nothing
192+ x:xs -> Just (x, xs)
193+
194+wrapWithOffset :: Int -> Int -> Text -> [Text]
195+wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []
196+wrapWithOffset maxWidth n xs =
197+ let (firstLine, rest) = T.splitAt (maxWidth - n) xs
198+ in firstLine : (fmap (T.take maxWidth) . takeWhile (not . T.null) . iterate (T.drop maxWidth) $ rest)
199+
200+-- | For a given set of wrapped logical lines, computes a map
201+-- from display line index to text offset in the original text.
202+-- This is used to help determine how interactions with the displayed
203+-- text map back to the original text.
204+-- For example, given the document @"AA\nBBB\nCCCCCCCC\n"@ wrapped to 5 columns,
205+-- this function will compute the offset in the original document of each character
206+-- in column 1:
207+-- @
208+--
209+-- AA... (0, 0)
210+-- BBB.. (1, 3)
211+-- CCCCC (2, 7) -- (this line wraps to the next row)
212+-- CCC.. (3, 12)
213+-- ..... (4, 16)
214+--
215+--
216+-- @
217+offsetMap
218+ :: [[Text]] -- ^ The outer list represents logical lines, and the
219+ -- inner list represents the display lines into which
220+ -- the logical line has been wrapped
221+ -> Map Int Int -- ^ A map from the index (row) of display line to
222+ -- the text offset from the beginning of the document
223+ -- to the first character of the display line
224+offsetMap ts = evalState (offsetMap' ts) (0, 0)
225+ where
226+ offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
227+ maps <- forM x $ \line -> do
228+ let l = T.length line
229+ (dl, o) <- get
230+ put (dl + 1, o + l)
231+ return $ Map.singleton dl o
232+ (dl, o) <- get
233+ put (dl, o + 1)
234+ return $ Map.insert dl (o + 1) $ Map.unions maps
235+
236+-- click :: (Int, Int) -> Int -> DisplayLines -> TextZipper
237+-- click (x, y) scrollTop dlines = undefined
238+
239+images :: [[Span]] -> [V.Image]
240+images = map (V.horizCat . map spanToImage)
241+
242+image :: [[Span]] -> V.Image
243+image = V.vertCat . images
244+
245+spanToImage :: Span -> V.Image
246+spanToImage (Span attrs t) = V.text' attrs t
247+
248+updateTextZipper :: V.Event -> TextZipper -> TextZipper
249+updateTextZipper ev = case ev of
250+ -- Regular characters
251+ V.EvKey (V.KChar k) [] -> insert $ T.singleton k
252+ -- Deletion buttons
253+ V.EvKey V.KBS [] -> deleteLeft
254+ V.EvKey V.KDel [] -> deleteRight
255+ -- Key combinations
256+ V.EvKey (V.KChar 'u') [V.MCtrl] -> const empty
257+ V.EvKey (V.KChar 'w') [V.MCtrl] -> deleteLeftWord
258+ -- Arrow keys
259+ V.EvKey V.KLeft [] -> left
260+ V.EvKey V.KRight [] -> right
261+ V.EvKey V.KUp [] -> up
262+ V.EvKey V.KDown [] -> down
263+ V.EvKey V.KHome [] -> home
264+ V.EvKey V.KEnd [] -> end
265+ _ -> id