9c9a2ab · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

on develop help sign in

Move generic text zipper stuff; Centralize text input widgets

9c9a2abAli Abrar8 years ago

reflex-vty.cabal+3−1

compare with develop

unifiedsplit

@@ -14,7 +14,9 @@ library

14 exposed-modules: Reflex.Vty

15 , Reflex.Vty.Host

16 , Reflex.Vty.Widget

17− , Reflex.Vty.Widget.Text

17+ , Reflex.Vty.Widget.Input

18+ , Reflex.Vty.Widget.Input.Text

19+ , Data.Text.Zipper

18 other-modules: Reflex.Spider.Orphans

20 other-modules: Reflex.Spider.Orphans

19 build-depends:

21 build-depends:

20 base,

22 base,

src/Reflex/Vty/Widget/Text.hs → src/Data/Text/Zipper.hsrenamed+47−58

@@ -1,7 +1,7 @@

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

4−module Reflex.Vty.Widget.Text where

4+module Data.Text.Zipper where

6import Data.Char

7import Data.Map (Map)

@@ -11,10 +11,13 @@ import Control.Monad.State

12import Data.Text (Text)

13import qualified Data.Text as T

14−import qualified Graphics.Vty as V

16−-- | A zipper of the logical text input contents. The lines before the line containing the cursor

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−-- are stored in reverse order. The cursor is logically _between_ the "before" and "after" text.

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).

18data TextZipper = TextZipper

21data TextZipper = TextZipper

19 { _textZipper_linesBefore :: [Text] -- reversed

22 { _textZipper_linesBefore :: [Text] -- reversed

20 , _textZipper_before :: Text

23 , _textZipper_before :: Text

@@ -23,6 +26,7 @@ data TextZipper = TextZipper

23 }

26 }

24 deriving (Show)

27 deriving (Show)

29+-- | Move the cursor left one character, if possible

26left :: TextZipper -> TextZipper

30left :: TextZipper -> TextZipper

27left z@(TextZipper lb b a la) = case T.unsnoc b of

31left z@(TextZipper lb b a la) = case T.unsnoc b of

28 Nothing -> case lb of

32 Nothing -> case lb of

@@ -30,6 +34,7 @@ left z@(TextZipper lb b a la) = case T.unsnoc b of

30 (l:ls) -> TextZipper ls l "" (a : la)

34 (l:ls) -> TextZipper ls l "" (a : la)

31 Just (b', c) -> TextZipper lb b' (T.cons c a) la

35 Just (b', c) -> TextZipper lb b' (T.cons c a) la

37+-- | Move the cursor right one character, if possible

33right :: TextZipper -> TextZipper

38right :: TextZipper -> TextZipper

34right z@(TextZipper lb b a la) = case T.uncons a of

39right z@(TextZipper lb b a la) = case T.uncons a of

35 Nothing -> case la of

40 Nothing -> case la of

@@ -37,6 +42,7 @@ right z@(TextZipper lb b a la) = case T.uncons a of

37 (l:ls) -> TextZipper (b : lb) "" l ls

42 (l:ls) -> TextZipper (b : lb) "" l ls

38 Just (c, a') -> TextZipper lb (T.snoc b c) a' la

43 Just (c, a') -> TextZipper lb (T.snoc b c) a' la

45+-- | Move the cursor up one logical line, if possible

40up :: TextZipper -> TextZipper

46up :: TextZipper -> TextZipper

41up z@(TextZipper lb b a la) = case lb of

47up z@(TextZipper lb b a la) = case lb of

42 [] -> z

48 [] -> z

@@ -44,6 +50,7 @@ up z@(TextZipper lb b a la) = case lb of

44 let (b', a') = T.splitAt (T.length b) l

50 let (b', a') = T.splitAt (T.length b) l

45 in TextZipper ls b' a' ((b <> a) : la)

51 in TextZipper ls b' a' ((b <> a) : la)

53+-- | Move the cursor down one logical line, if possible

47down :: TextZipper -> TextZipper

54down :: TextZipper -> TextZipper

48down z@(TextZipper lb b a la) = case la of

55down z@(TextZipper lb b a la) = case la of

49 [] -> z

56 [] -> z

@@ -51,17 +58,25 @@ down z@(TextZipper lb b a la) = case la of

51 let (b', a') = T.splitAt (T.length b) l

58 let (b', a') = T.splitAt (T.length b) l

52 in TextZipper ((b <> a) : lb) b' a' ls

59 in TextZipper ((b <> a) : lb) b' a' ls

61+-- | Move the cursor to the beginning of the current logical line

54home :: TextZipper -> TextZipper

62home :: TextZipper -> TextZipper

55home (TextZipper lb b a la) = TextZipper lb "" (b <> a) la

63home (TextZipper lb b a la) = TextZipper lb "" (b <> a) la

65+-- | Move the cursor to the end of the current logical line

57end :: TextZipper -> TextZipper

66end :: TextZipper -> TextZipper

58end (TextZipper lb b a la) = TextZipper lb (b <> a) "" la

67end (TextZipper lb b a la) = TextZipper lb (b <> a) "" la

69+-- | Move the cursor to the top of the document

60top :: TextZipper -> TextZipper

70top :: TextZipper -> TextZipper

61top (TextZipper lb b a la) = case reverse lb of

71top (TextZipper lb b a la) = case reverse lb of

62 [] -> TextZipper [] "" (b <> a) la

72 [] -> TextZipper [] "" (b <> a) la

63 (start:rest) -> TextZipper [] "" start (rest <> la)

73 (start:rest) -> TextZipper [] "" start (rest <> la)

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

65insert :: Text -> TextZipper -> TextZipper

80insert :: Text -> TextZipper -> TextZipper

66insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of

81insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of

67 [] -> z

82 [] -> z

@@ -69,6 +84,7 @@ insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of

69 [] -> TextZipper lb (b <> start) a la

84 [] -> TextZipper lb (b <> start) a la

70 (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la

85 (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la

87+-- | Delete the character to the left of the cursor

72deleteLeft :: TextZipper-> TextZipper

88deleteLeft :: TextZipper-> TextZipper

73deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of

89deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of

74 Nothing -> case lb of

90 Nothing -> case lb of

@@ -76,6 +92,7 @@ deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of

76 (l:ls) -> TextZipper ls l a la

92 (l:ls) -> TextZipper ls l a la

77 Just (b', _) -> TextZipper lb b' a la

93 Just (b', _) -> TextZipper lb b' a la

95+-- | Delete the character under/to the right of the cursor

79deleteRight :: TextZipper -> TextZipper

96deleteRight :: TextZipper -> TextZipper

80deleteRight z@(TextZipper lb b a la) = case T.uncons a of

97deleteRight z@(TextZipper lb b a la) = case T.uncons a of

81 Nothing -> case la of

98 Nothing -> case la of

@@ -83,6 +100,9 @@ deleteRight z@(TextZipper lb b a la) = case T.uncons a of

83 (l:ls) -> TextZipper lb b l ls

100 (l:ls) -> TextZipper lb b l ls

84 Just (_, a') -> TextZipper lb b a' la

101 Just (_, a') -> TextZipper lb b a' la

102

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.

86deleteLeftWord :: TextZipper -> TextZipper

106deleteLeftWord :: TextZipper -> TextZipper

87deleteLeftWord (TextZipper lb b a la) =

107deleteLeftWord (TextZipper lb b a la) =

88 let b' = T.dropWhileEnd isSpace b

108 let b' = T.dropWhileEnd isSpace b

@@ -92,29 +112,30 @@ deleteLeftWord (TextZipper lb b a la) =

92 (l:ls) -> deleteLeftWord $ TextZipper ls l a la

112 (l:ls) -> deleteLeftWord $ TextZipper ls l a la

93 else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la

113 else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la

114

115+-- | The plain text contents of the zipper

95value :: TextZipper -> Text

116value :: TextZipper -> Text

96value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb

117value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb

97 , [b <> a]

118 , [b <> a]

98 , la

119 , la

99 ]

120 ]

100

121

122+-- | The empty zipper

101empty :: TextZipper

123empty :: TextZipper

102empty = TextZipper [] "" "" []

124empty = TextZipper [] "" "" []

103

125

126+-- | Constructs a zipper with the given contents. The cursor is placed after

127+-- the contents.

104fromText :: Text -> TextZipper

128fromText :: Text -> TextZipper

105fromText = flip insert empty

129fromText = flip insert empty

106

130

107−-- | A span of text that makes up part of a display line

131+-- | A span of text tagged with some metadata that makes up part of a display

132+-- line.

108−data Span = Span V.Attr Text

133+data Span tag = Span tag Text

109 deriving (Show)

134 deriving (Show)

110

135

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)

136-- | Information about the documents as it is displayed (i.e., post-wrapping)

116−data DisplayLines = DisplayLines

137+data DisplayLines tag = DisplayLines

117− { _displayLines_spans :: [[Span]]

138+ { _displayLines_spans :: [[Span tag]]

118 , _displayLines_offsetMap :: Map Int Int

139 , _displayLines_offsetMap :: Map Int Int

119 , _displayLines_cursorY :: Int

140 , _displayLines_cursorY :: Int

120 }

141 }

@@ -127,9 +148,11 @@ data DisplayLines = DisplayLines

127-- offset

148-- offset

128displayLines

149displayLines

129 :: Int -- ^ Width, used for wrapping

150 :: Int -- ^ Width, used for wrapping

151+ -> tag -- ^ Metadata for normal characters

152+ -> tag -- ^ Metadata for the cursor

130 -> TextZipper -- ^ The text input contents and cursor state

153 -> TextZipper -- ^ The text input contents and cursor state

131− -> DisplayLines

154+ -> DisplayLines tag

132−displayLines width (TextZipper lb b a la) =

155+displayLines width tag cursorTag (TextZipper lb b a la) =

133 let linesBefore :: [[Text]]

156 let linesBefore :: [[Text]]

134 linesBefore = map (wrapWithOffset width 0) $ reverse lb

157 linesBefore = map (wrapWithOffset width 0) $ reverse lb

135 linesAfter :: [[Text]]

158 linesAfter :: [[Text]]

@@ -139,25 +162,19 @@ displayLines width (TextZipper lb b a la) =

139 , [wrapWithOffset width 0 $ b <> a]

162 , [wrapWithOffset width 0 $ b <> a]

140 , linesAfter

163 , linesAfter

141 ]

164 ]

142− spansBefore = map ((:[]) . Span V.defAttr) $ concat linesBefore

165+ spansBefore = map ((:[]) . Span tag) $ concat linesBefore

143− spansAfter = map ((:[]) . Span V.defAttr) $ concat linesAfter

166+ spansAfter = map ((:[]) . Span tag) $ concat linesAfter

144 (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $

167 (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $

145− initLast $ map ((:[]) . Span V.defAttr) (wrapWithOffset width 0 b)

168+ initLast $ map ((:[]) . Span tag) (wrapWithOffset width 0 b)

146 curLineOffset = spansLength spansCurLineBefore

169 curLineOffset = spansLength spansCurLineBefore

147 cursorAfterEOL = curLineOffset == width

170 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 ([], []) $

171 (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $

155 headTail $ case T.uncons a of

172 headTail $ case T.uncons a of

156− Nothing -> [[Span cursorAttributes " "]]

173+ Nothing -> [[Span cursorTag " "]]

157 Just (c, rest) ->

174 Just (c, rest) ->

158 let o = if cursorAfterEOL then 1 else curLineOffset + 1

175 let o = if cursorAfterEOL then 1 else curLineOffset + 1

159− cursor = Span cursorAttributes (T.singleton c)

176+ cursor = Span cursorTag (T.singleton c)

160− in case map ((:[]) . Span V.defAttr) (wrapWithOffset width o rest) of

177+ in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of

161 [] -> [[cursor]]

178 [] -> [[cursor]]

162 (l:ls) -> (cursor : l) : ls

179 (l:ls) -> (cursor : l) : ls

163 in DisplayLines

180 in DisplayLines

@@ -178,7 +195,7 @@ displayLines width (TextZipper lb b a la) =

178 ]

195 ]

179 }

196 }

180 where

197 where

181− spansLength :: [Span] -> Int

198+ spansLength :: [Span tag] -> Int

182 spansLength = sum . map (\(Span _ t) -> T.length t)

199 spansLength = sum . map (\(Span _ t) -> T.length t)

183 initLast :: [a] -> Maybe ([a], a)

200 initLast :: [a] -> Maybe ([a], a)

184 initLast = \case

201 initLast = \case

@@ -191,6 +208,9 @@ displayLines width (TextZipper lb b a la) =

191 [] -> Nothing

208 [] -> Nothing

192 x:xs -> Just (x, xs)

209 x:xs -> Just (x, xs)

193

210

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.

194wrapWithOffset :: Int -> Int -> Text -> [Text]

214wrapWithOffset :: Int -> Int -> Text -> [Text]

195wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []

215wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []

196wrapWithOffset maxWidth n xs =

216wrapWithOffset maxWidth n xs =

@@ -232,34 +252,3 @@ offsetMap ts = evalState (offsetMap' ts) (0, 0)

232 (dl, o) <- get

252 (dl, o) <- get

233 put (dl, o + 1)

253 put (dl, o + 1)

234 return $ Map.insert dl (o + 1) $ Map.unions maps

254 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

src/Reflex/Vty.hs+5−1

@@ -1,7 +1,11 @@

1module Reflex.Vty

2− ( module Reflex.Vty.Host

2+ ( module Reflex

3+ , module Reflex.Vty.Host

3 , module Reflex.Vty.Widget

4 , module Reflex.Vty.Widget

5+ , module Reflex.Vty.Widget.Input

4 ) where

6 ) where

8+import Reflex

6import Reflex.Vty.Host

9import Reflex.Vty.Host

7import Reflex.Vty.Widget

10import Reflex.Vty.Widget

11+import Reflex.Vty.Widget.Input

src/Reflex/Vty/Widget.hs+2−60

@@ -44,10 +44,6 @@ module Reflex.Vty.Widget

44 , doubleBoxStyle

45 , fill

46 , hRule

47− , TextInputConfig(..)

48− , textInput

49− , multilineTextInput

50− , def

51 ) where

47 ) where

53import Control.Applicative (liftA2)

49import Control.Applicative (liftA2)

@@ -58,13 +54,12 @@ import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell)

58import Data.Default

54import Data.Default

59import Data.Text (Text)

55import Data.Text (Text)

60import qualified Data.Text as T

56import qualified Data.Text as T

57+import qualified Data.Text.Zipper as TZ

61import Graphics.Vty (Image, Attr)

58import Graphics.Vty (Image, Attr)

62import qualified Graphics.Vty as V

59import qualified Graphics.Vty as V

63import Reflex

60import Reflex

65import Reflex.Vty.Host

62import Reflex.Vty.Host

66−import Reflex.Vty.Widget.Text (TextZipper(..), DisplayLines(..))

67−import qualified Reflex.Vty.Widget.Text as TZ

69-- | The context within which a 'VtyWidget' runs

64-- | The context within which a 'VtyWidget' runs

70data VtyWidgetCtx t = VtyWidgetCtx

65data VtyWidgetCtx t = VtyWidgetCtx

@@ -439,58 +434,5 @@ withinImage (Region left top width height)

439

434

440wrapText :: Int -> Attr -> Text -> Image

435wrapText :: Int -> Attr -> Text -> Image

441wrapText maxWidth attrs = V.vertCat

436wrapText maxWidth attrs = V.vertCat

442− . concatMap (fmap (V.string attrs . T.unpack) . wrapWithOffset maxWidth 0)

437+ . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)

443 . T.split (=='\n')

438 . T.split (=='\n')

444−

445−wrapWithOffset :: Int -> Int -> Text -> [Text]

446−wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []

447−wrapWithOffset 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)

450−

451−data TextInputConfig t = TextInputConfig

452− { _textInputConfig_initialValue :: TextZipper

453− , _textInputConfig_modify :: Event t (TextZipper -> TextZipper)

454− }

455−

456−instance Reflex t => Default (TextInputConfig t) where

457− def = TextInputConfig TZ.empty never

458−

459−textInput

460− :: (Reflex t, MonadHold t m, MonadFix m)

461− => TextInputConfig t

462− -> VtyWidget t m (Dynamic t Text)

463−textInput cfg = do

464− i <- input

465− v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)

466− [ TZ.updateTextZipper <$> i

467− , _textInputConfig_modify cfg

468− ]

469− dw <- displayWidth

470− dh <- displayHeight

471− let rows = (\w s -> TZ.displayLines w s) <$> dw <*> v

472− img = TZ.images . _displayLines_spans <$> rows

473− y <- holdUniqDyn $ _displayLines_cursorY <$> rows

474− let newScrollTop st (h, cursorY)

475− | cursorY < st = cursorY

476− | cursorY >= st + h = cursorY - h + 1

477− | otherwise = st

478− rec let hy = attachWith newScrollTop (current scrollTop) $ updated $ zipDyn dh y

479− scrollTop <- holdDyn 0 hy

480− tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> current scrollTop

481− return $ TZ.value <$> v

482−

483−multilineTextInput

484− :: (Reflex t, MonadHold t m, MonadFix m)

485− => TextInputConfig t

486− -> VtyWidget t m (Dynamic t Text)

487−multilineTextInput cfg = do

488− i <- input

489− textInput $ cfg

490− { _textInputConfig_modify = mergeWith (.)

491− [ fforMaybe i $ \case

492− V.EvKey V.KEnter [] -> Just $ TZ.insert "\n"

493− _ -> Nothing

494− , _textInputConfig_modify cfg

495− ]

496− }

src/Reflex/Vty/Widget/Input.hsnew file+5

@@ -0,0 +1,5 @@

1+module Reflex.Vty.Widget.Input

2+ ( module Reflex.Vty.Widget.Input.Text

3+ ) where

5+import Reflex.Vty.Widget.Input.Text

src/Reflex/Vty/Widget/Input/Text.hsnew file+103

@@ -0,0 +1,103 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE RecursiveDo #-}

5+module Reflex.Vty.Widget.Input.Text

6+ ( module Reflex.Vty.Widget.Input.Text

7+ , def

8+ ) where

10+import Control.Monad.Fix

11+import Data.Default

12+import Data.Text (Text)

13+import Data.Text.Zipper

14+import qualified Graphics.Vty as V

15+import Reflex

16+import Reflex.Vty.Widget

17+

18+-- | Configuration options for a 'textInput'. For more information on

19+-- 'TextZipper', see 'Data.Text.Zipper'.

20+data TextInputConfig t = TextInputConfig

21+ { _textInputConfig_initialValue :: TextZipper

22+ , _textInputConfig_modify :: Event t (TextZipper -> TextZipper)

23+ }

24+

25+instance Reflex t => Default (TextInputConfig t) where

26+ def = TextInputConfig empty never

27+

28+-- | A widget that allows text input

29+textInput

30+ :: (Reflex t, MonadHold t m, MonadFix m)

31+ => TextInputConfig t

32+ -> VtyWidget t m (Dynamic t Text)

33+textInput cfg = do

34+ i <- input

35+ v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.)

36+ [ updateTextZipper <$> i

37+ , _textInputConfig_modify cfg

38+ ]

39+ dw <- displayWidth

40+ dh <- displayHeight

41+ let rows = (\w s -> displayLines w V.defAttr cursorAttributes s) <$> dw <*> v

42+ img = images . _displayLines_spans <$> rows

43+ y <- holdUniqDyn $ _displayLines_cursorY <$> rows

44+ let newScrollTop st (h, cursorY)

45+ | cursorY < st = cursorY

46+ | cursorY >= st + h = cursorY - h + 1

47+ | otherwise = st

48+ rec let hy = attachWith newScrollTop (current scrollTop) $ updated $ zipDyn dh y

49+ scrollTop <- holdDyn 0 hy

50+ tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> current scrollTop

51+ return $ value <$> v

52+

53+-- | A widget that allows multiline text input

54+multilineTextInput

55+ :: (Reflex t, MonadHold t m, MonadFix m)

56+ => TextInputConfig t

57+ -> VtyWidget t m (Dynamic t Text)

58+multilineTextInput cfg = do

59+ i <- input

60+ textInput $ cfg

61+ { _textInputConfig_modify = mergeWith (.)

62+ [ fforMaybe i $ \case

63+ V.EvKey V.KEnter [] -> Just $ insert "\n"

64+ _ -> Nothing

65+ , _textInputConfig_modify cfg

66+ ]

67+ }

68+

69+-- | Default attributes for the text cursor

70+cursorAttributes :: V.Attr

71+cursorAttributes = V.withStyle V.defAttr V.reverseVideo

72+

73+-- | Turn a set of display line rows into a list of images (one per line)

74+images :: [[Span V.Attr]] -> [V.Image]

75+images = map (V.horizCat . map spanToImage)

76+

77+-- | Turn a set of display line rows into a single image

78+image :: [[Span V.Attr]] -> V.Image

79+image = V.vertCat . images

80+

81+-- | Turn a 'Span' into an 'Image'

82+spanToImage :: Span V.Attr -> V.Image

83+spanToImage (Span attrs t) = V.text' attrs t

84+

85+-- | Default vty event handler for text inputs

86+updateTextZipper :: V.Event -> TextZipper -> TextZipper

87+updateTextZipper ev = case ev of

88+ -- Regular characters

89+ V.EvKey (V.KChar k) [] -> insertChar k

90+ -- Deletion buttons

91+ V.EvKey V.KBS [] -> deleteLeft

92+ V.EvKey V.KDel [] -> deleteRight

93+ -- Key combinations

94+ V.EvKey (V.KChar 'u') [V.MCtrl] -> const empty

95+ V.EvKey (V.KChar 'w') [V.MCtrl] -> deleteLeftWord

96+ -- Arrow keys

97+ V.EvKey V.KLeft [] -> left

98+ V.EvKey V.KRight [] -> right

99+ V.EvKey V.KUp [] -> up

100+ V.EvKey V.KDown [] -> down

101+ V.EvKey V.KHome [] -> home

102+ V.EvKey V.KEnd [] -> end

103+ _ -> id