@@ -1,7 +1,7 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE OverloadedStrings #-}
4−module Reflex.Vty.Widget.Text where
4+module Data.Text.Zipper where
55
66import Data.Char
77import Data.Map (Map)
@@ -11,10 +11,13 @@ import Control.Monad.State
1111
1212import Data.Text (Text)
1313import qualified Data.Text as T
14−import qualified Graphics.Vty as V
1514
16−-- | A zipper of the logical text input contents. The lines before the line containing the cursor
17−-- are stored in reverse order. The cursor is logically _between_ the "before" and "after" text.
15+-- | A zipper of the logical text input contents (the "document"). The lines
16+-- before the line containing the cursor are stored in reverse order.
17+-- The cursor is logically between the "before" and "after" text.
18+-- A "logical" line of input is a line of input up until a user-entered newline
19+-- character (as compared to a "display" line, which is wrapped to fit within
20+-- a given viewport width).
1821data TextZipper = TextZipper
1922 { _textZipper_linesBefore :: [Text] -- reversed
2023 , _textZipper_before :: Text
@@ -23,6 +26,7 @@ data TextZipper = TextZipper
2326 }
2427 deriving (Show)
2528
29+-- | Move the cursor left one character, if possible
2630left :: TextZipper -> TextZipper
2731left z@(TextZipper lb b a la) = case T.unsnoc b of
2832 Nothing -> case lb of
@@ -30,6 +34,7 @@ left z@(TextZipper lb b a la) = case T.unsnoc b of
3034 (l:ls) -> TextZipper ls l "" (a : la)
3135 Just (b', c) -> TextZipper lb b' (T.cons c a) la
3236
37+-- | Move the cursor right one character, if possible
3338right :: TextZipper -> TextZipper
3439right z@(TextZipper lb b a la) = case T.uncons a of
3540 Nothing -> case la of
@@ -37,6 +42,7 @@ right z@(TextZipper lb b a la) = case T.uncons a of
3742 (l:ls) -> TextZipper (b : lb) "" l ls
3843 Just (c, a') -> TextZipper lb (T.snoc b c) a' la
3944
45+-- | Move the cursor up one logical line, if possible
4046up :: TextZipper -> TextZipper
4147up z@(TextZipper lb b a la) = case lb of
4248 [] -> z
@@ -44,6 +50,7 @@ up z@(TextZipper lb b a la) = case lb of
4450 let (b', a') = T.splitAt (T.length b) l
4551 in TextZipper ls b' a' ((b <> a) : la)
4652
53+-- | Move the cursor down one logical line, if possible
4754down :: TextZipper -> TextZipper
4855down z@(TextZipper lb b a la) = case la of
4956 [] -> z
@@ -51,17 +58,25 @@ down z@(TextZipper lb b a la) = case la of
5158 let (b', a') = T.splitAt (T.length b) l
5259 in TextZipper ((b <> a) : lb) b' a' ls
5360
61+-- | Move the cursor to the beginning of the current logical line
5462home :: TextZipper -> TextZipper
5563home (TextZipper lb b a la) = TextZipper lb "" (b <> a) la
5664
65+-- | Move the cursor to the end of the current logical line
5766end :: TextZipper -> TextZipper
5867end (TextZipper lb b a la) = TextZipper lb (b <> a) "" la
5968
69+-- | Move the cursor to the top of the document
6070top :: TextZipper -> TextZipper
6171top (TextZipper lb b a la) = case reverse lb of
6272 [] -> TextZipper [] "" (b <> a) la
6373 (start:rest) -> TextZipper [] "" start (rest <> la)
6474
75+-- | Insert a character at the current cursor position
76+insertChar :: Char -> TextZipper -> TextZipper
77+insertChar i = insert (T.singleton i)
78+
79+-- | Insert text at the current cursor position
6580insert :: Text -> TextZipper -> TextZipper
6681insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of
6782 [] -> z
@@ -69,6 +84,7 @@ insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of
6984 [] -> TextZipper lb (b <> start) a la
7085 (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la
7186
87+-- | Delete the character to the left of the cursor
7288deleteLeft :: TextZipper-> TextZipper
7389deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of
7490 Nothing -> case lb of
@@ -76,6 +92,7 @@ deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of
7692 (l:ls) -> TextZipper ls l a la
7793 Just (b', _) -> TextZipper lb b' a la
7894
95+-- | Delete the character under/to the right of the cursor
7996deleteRight :: TextZipper -> TextZipper
8097deleteRight z@(TextZipper lb b a la) = case T.uncons a of
8198 Nothing -> case la of
@@ -83,6 +100,9 @@ deleteRight z@(TextZipper lb b a la) = case T.uncons a of
83100 (l:ls) -> TextZipper lb b l ls
84101 Just (_, a') -> TextZipper lb b a' la
85102
103+-- | Delete a word to the left of the cursor. Deletes all whitespace until it
104+-- finds a non-whitespace character, and then deletes contiguous non-whitespace
105+-- characters.
86106deleteLeftWord :: TextZipper -> TextZipper
87107deleteLeftWord (TextZipper lb b a la) =
88108 let b' = T.dropWhileEnd isSpace b
@@ -92,29 +112,30 @@ deleteLeftWord (TextZipper lb b a la) =
92112 (l:ls) -> deleteLeftWord $ TextZipper ls l a la
93113 else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la
94114
115+-- | The plain text contents of the zipper
95116value :: TextZipper -> Text
96117value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb
97118 , [b <> a]
98119 , la
99120 ]
100121
122+-- | The empty zipper
101123empty :: TextZipper
102124empty = TextZipper [] "" "" []
103125
126+-- | Constructs a zipper with the given contents. The cursor is placed after
127+-- the contents.
104128fromText :: Text -> TextZipper
105129fromText = flip insert empty
106130
107−-- | A span of text that makes up part of a display line
108−data Span = Span V.Attr Text
131+-- | A span of text tagged with some metadata that makes up part of a display
132+-- line.
133+data Span tag = Span tag Text
109134 deriving (Show)
110135
111−-- | Default attributes for the text cursor
112−cursorAttributes :: V.Attr
113−cursorAttributes = V.withStyle V.defAttr V.reverseVideo
114−
115136-- | Information about the documents as it is displayed (i.e., post-wrapping)
116−data DisplayLines = DisplayLines
117− { _displayLines_spans :: [[Span]]
137+data DisplayLines tag = DisplayLines
138+ { _displayLines_spans :: [[Span tag]]
118139 , _displayLines_offsetMap :: Map Int Int
119140 , _displayLines_cursorY :: Int
120141 }
@@ -127,9 +148,11 @@ data DisplayLines = DisplayLines
127148-- offset
128149displayLines
129150 :: Int -- ^ Width, used for wrapping
151+ -> tag -- ^ Metadata for normal characters
152+ -> tag -- ^ Metadata for the cursor
130153 -> TextZipper -- ^ The text input contents and cursor state
131− -> DisplayLines
132−displayLines width (TextZipper lb b a la) =
154+ -> DisplayLines tag
155+displayLines width tag cursorTag (TextZipper lb b a la) =
133156 let linesBefore :: [[Text]]
134157 linesBefore = map (wrapWithOffset width 0) $ reverse lb
135158 linesAfter :: [[Text]]
@@ -139,25 +162,19 @@ displayLines width (TextZipper lb b a la) =
139162 , [wrapWithOffset width 0 $ b <> a]
140163 , linesAfter
141164 ]
142− spansBefore = map ((:[]) . Span V.defAttr) $ concat linesBefore
143− spansAfter = map ((:[]) . Span V.defAttr) $ concat linesAfter
165+ spansBefore = map ((:[]) . Span tag) $ concat linesBefore
166+ spansAfter = map ((:[]) . Span tag) $ concat linesAfter
144167 (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
145− initLast $ map ((:[]) . Span V.defAttr) (wrapWithOffset width 0 b)
168+ initLast $ map ((:[]) . Span tag) (wrapWithOffset width 0 b)
146169 curLineOffset = spansLength spansCurLineBefore
147170 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−
154171 (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
155172 headTail $ case T.uncons a of
156− Nothing -> [[Span cursorAttributes " "]]
173+ Nothing -> [[Span cursorTag " "]]
157174 Just (c, rest) ->
158175 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
176+ cursor = Span cursorTag (T.singleton c)
177+ in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
161178 [] -> [[cursor]]
162179 (l:ls) -> (cursor : l) : ls
163180 in DisplayLines
@@ -178,7 +195,7 @@ displayLines width (TextZipper lb b a la) =
178195 ]
179196 }
180197 where
181− spansLength :: [Span] -> Int
198+ spansLength :: [Span tag] -> Int
182199 spansLength = sum . map (\(Span _ t) -> T.length t)
183200 initLast :: [a] -> Maybe ([a], a)
184201 initLast = \case
@@ -191,6 +208,9 @@ displayLines width (TextZipper lb b a la) =
191208 [] -> Nothing
192209 x:xs -> Just (x, xs)
193210
211+-- | Wraps a logical line of text to fit within the given width. The first
212+-- wrapped line is offset by the number of columns provided. Subsequent wrapped
213+-- lines are not.
194214wrapWithOffset :: Int -> Int -> Text -> [Text]
195215wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []
196216wrapWithOffset maxWidth n xs =
@@ -232,34 +252,3 @@ offsetMap ts = evalState (offsetMap' ts) (0, 0)
232252 (dl, o) <- get
233253 put (dl, o + 1)
234254 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