git.iko.soy/reflex-vty
on develop help sign in
Line wrapping: Keep better track of how text has been transformed for rendering
1770244Ali Abrar
reflex-vty.cabal+1
compare with develop
unifiedsplit
@@ -18,6 +18,7 @@ library
18 other-modules: Reflex.Spider.Orphans
18 other-modules: Reflex.Spider.Orphans
19 build-depends:
19 build-depends:
20 base,
20 base,
21+ containers,
21 data-default,
22 data-default,
22 dependent-sum,
23 dependent-sum,
23 mtl,
24 mtl,
src/Reflex/Vty/Widget.hs+24−141
@@ -55,9 +55,7 @@ import Control.Monad.Fix (MonadFix)
55import Control.Monad.Trans (lift)
55import Control.Monad.Trans (lift)
56import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)
56import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)
57import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell)
57import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell)
58−import Data.Char
59import Data.Default
58import Data.Default
60−import Data.Maybe (fromMaybe)
61import Data.Text (Text)
59import Data.Text (Text)
62import qualified Data.Text as T
60import qualified Data.Text as T
63import Graphics.Vty (Image, Attr)
61import Graphics.Vty (Image, Attr)
@@ -65,6 +63,8 @@ import qualified Graphics.Vty as V
65import Reflex
63import Reflex
66
64
67import Reflex.Vty.Host
65import Reflex.Vty.Host
66+import Reflex.Vty.Widget.Text (TextZipper(..), DisplayLines(..))
67+import qualified Reflex.Vty.Widget.Text as TZ
68
68
69-- | The context within which a 'VtyWidget' runs
69-- | The context within which a 'VtyWidget' runs
70data VtyWidgetCtx t = VtyWidgetCtx
70data VtyWidgetCtx t = VtyWidgetCtx
@@ -448,166 +448,49 @@ wrapWithOffset maxWidth n xs =
448 let (firstLine, rest) = T.splitAt (maxWidth - n) xs
448 let (firstLine, rest) = T.splitAt (maxWidth - n) xs
449 in firstLine : (fmap (T.take maxWidth) . takeWhile (not . T.null) . iterate (T.drop maxWidth) $ rest)
449 in firstLine : (fmap (T.take maxWidth) . takeWhile (not . T.null) . iterate (T.drop maxWidth) $ rest)
450
450
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−
573data TextInputConfig t = TextInputConfig
451data TextInputConfig t = TextInputConfig
574− { _textInputConfig_initialValue :: Text
452+ { _textInputConfig_initialValue :: TextZipper
575− , _textInputConfig_modifyInputState :: Event t (InputState -> InputState)
453+ , _textInputConfig_modify :: Event t (TextZipper -> TextZipper)
576 }
454 }
577
455
578instance Reflex t => Default (TextInputConfig t) where
456instance Reflex t => Default (TextInputConfig t) where
579− def = TextInputConfig "" never
457+ def = TextInputConfig TZ.empty never
580
458
459+textInput
581−textInput :: (Reflex t, MonadHold t m, MonadFix m) => TextInputConfig t -> VtyWidget t m (Dynamic t Text)
460+ :: (Reflex t, MonadHold t m, MonadFix m)
461+ => TextInputConfig t
462+ -> VtyWidget t m (Dynamic t Text)
582textInput cfg = do
463textInput cfg = do
583 i <- input
464 i <- input
584− v <- foldDyn ($) (InputState (_textInputConfig_initialValue cfg) mempty) $ mergeWith (.)
465+ v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)
585− [ updateInputState <$> i
466+ [ TZ.updateTextZipper <$> i
586− , _textInputConfig_modifyInputState cfg
467+ , _textInputConfig_modify cfg
587 ]
468 ]
588 dw <- displayWidth
469 dw <- displayWidth
589 dh <- displayHeight
470 dh <- displayHeight
590− let img = (\w s -> wrapInputState w V.defAttr (V.withStyle V.defAttr V.reverseVideo) s) -- TODO cursor ought to blink
471+ let rows = (\w s -> TZ.displayLines w s) <$> dw <*> v
591− <$> dw
472+ img = TZ.images . _displayLines_spans <$> rows
592− <*> v
593− y <- holdUniqDyn $ snd <$> img
473+ y <- holdUniqDyn $ _displayLines_cursorY <$> rows
594 let newScrollTop st (h, cursorY)
474 let newScrollTop st (h, cursorY)
595 | cursorY < st = cursorY
475 | cursorY < st = cursorY
596 | cursorY >= st + h = cursorY - h + 1
476 | cursorY >= st + h = cursorY - h + 1
597 | otherwise = st
477 | otherwise = st
598 rec let hy = attachWith newScrollTop (current scrollTop) $ updated $ zipDyn dh y
478 rec let hy = attachWith newScrollTop (current scrollTop) $ updated $ zipDyn dh y
599 scrollTop <- holdDyn 0 hy
479 scrollTop <- holdDyn 0 hy
600− tellImages $ (\(imgs, _) st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> current scrollTop
480+ tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> current scrollTop
601− return $ inputValue <$> v
481+ return $ TZ.value <$> v
602
482
483+multilineTextInput
603−multilineTextInput :: (Reflex t, MonadHold t m, MonadFix m) => TextInputConfig t -> VtyWidget t m (Dynamic t Text)
484+ :: (Reflex t, MonadHold t m, MonadFix m)
485+ => TextInputConfig t
486+ -> VtyWidget t m (Dynamic t Text)
604multilineTextInput cfg = do
487multilineTextInput cfg = do
605 i <- input
488 i <- input
606 textInput $ cfg
489 textInput $ cfg
607− { _textInputConfig_modifyInputState = mergeWith (.)
490+ { _textInputConfig_modify = mergeWith (.)
608 [ fforMaybe i $ \case
491 [ 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"
610 _ -> Nothing
493 _ -> Nothing
611− , _textInputConfig_modifyInputState cfg
494+ , _textInputConfig_modify cfg
612 ]
495 ]
613 }
496 }
src/Reflex/Vty/Widget/Text.hs+196−2
@@ -1,8 +1,17 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
2module Reflex.Vty.Widget.Text where
4module Reflex.Vty.Widget.Text where
3
5
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+
4import Data.Text (Text)
12import Data.Text (Text)
5import qualified Data.Text as T
13import qualified Data.Text as T
14+import qualified Graphics.Vty as V
6
15
7-- | A zipper of the logical text input contents. The lines before the line containing the cursor
16-- | A zipper of the logical text input contents. The lines before the line containing the cursor
8-- are stored in reverse order. The cursor is logically _between_ the "before" and "after" text.
17-- 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
60 [] -> TextZipper lb (b <> start) a la
69 [] -> TextZipper lb (b <> start) a la
61 (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la
70 (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la
62
71
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+
63value :: TextZipper -> Text
95value :: TextZipper -> Text
64−value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat
96+value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb
65− [ reverse lb
66 , [b <> a]
97 , [b <> a]
67 , la
98 , la
68 ]
99 ]
69
100
70empty :: TextZipper
101empty :: TextZipper
71empty = TextZipper [] "" "" []
102empty = 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