@@ -4,6 +4,7 @@
44{-# LANGUAGE GeneralizedNewtypeDeriving #-}
55{-# LANGUAGE LambdaCase #-}
66{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE OverloadedStrings #-}
78{-# LANGUAGE RankNTypes #-}
89{-# LANGUAGE RecursiveDo #-}
910{-# LANGUAGE TypeFamilies #-}
@@ -42,6 +43,10 @@ module Reflex.Vty.Widget
4243 , doubleBoxStyle
4344 , fill
4445 , hRule
46+
47+ , textInput
48+ , multilineTextInput
49+ , def
4550 ) where
4651
4752import Control.Applicative (liftA2)
@@ -49,8 +54,13 @@ import Control.Monad.Fix (MonadFix)
4954import Control.Monad.Trans (lift)
5055import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)
5156import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell)
57+import Data.Char
58+import Data.Default
59+import Data.Maybe (fromMaybe)
60+import Data.Text (Text)
61+import qualified Data.Text as T
5262import Graphics.Vty (Image, Attr)
53−import qualified Graphics.Vty as V
63+import qualified Graphics.Vty as V
5464import Reflex
5565
5666import Reflex.Vty.Host
@@ -63,7 +73,7 @@ data VtyWidgetCtx t = VtyWidgetCtx
6373 -- ^ Whether the widget should behave as if it has focus for keyboard input.
6474 , _vtyWidgetCtx_input :: Event t VtyEvent
6575 -- ^ User input events that the widget's parent chooses to share. These will generally
66− -- be filtered for relevance:
76+ -- be filtered for relevance:
6777 -- * Keyboard inputs are restricted to focused widgets
6878 -- * Mouse inputs are restricted to the region in which the widget resides and are
6979 -- translated into its internal coordinates.
@@ -294,7 +304,7 @@ splitVDrag wS wA wB = do
294304 let splitter0 = h0 `div` 2
295305 rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
296306 splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]
297− splitterFrac <- holdDyn (1/2) $ ffor (attach (current sz) (fst <$> dragSplitter)) $ \((_,h),x) ->
307+ splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current sz) (fst <$> dragSplitter)) $ \((_,h),x) ->
298308 fromIntegral x / fromIntegral h
299309 let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
300310 \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
@@ -322,10 +332,10 @@ splitVDrag wS wA wB = do
322332fill :: (Reflex t, Monad m) => Char -> VtyWidget t m ()
323333fill c = do
324334 sz <- displaySize
325− let fillImg = ffor (current sz) $ \(w,h) -> [V.charFill mempty c w h]
335+ let fillImg = ffor (current sz) $ \(w,h) -> [V.charFill V.defAttr c w h]
326336 tellImages fillImg
327337
328−-- | Fill the background with the bottom
338+-- | Fill the background with the bottom
329339hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()
330340hRule boxStyle = fill (_boxStyle_s boxStyle)
331341
@@ -337,7 +347,7 @@ modifyImages
337347 => Behavior t ([Image] -> [Image])
338348 -> VtyWidget t m a
339349 -> VtyWidget t m a
340−modifyImages f (VtyWidget w) = VtyWidget $ flip censor w $ \wo ->
350+modifyImages f (VtyWidget w) = VtyWidget $ flip censor w $ \wo ->
341351 wo { _vtyWidgetOut_images = f <*> (_vtyWidgetOut_images wo) }
342352
343353data BoxStyle = BoxStyle
@@ -351,6 +361,9 @@ data BoxStyle = BoxStyle
351361 , _boxStyle_w :: Char
352362 }
353363
364+instance Default BoxStyle where
365+ def = singleBoxStyle
366+
354367hyphenBoxStyle :: BoxStyle
355368hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
356369
@@ -379,35 +392,35 @@ box style child = do
379392 pane innerReg (pure True) child
380393 where
381394 boxImages :: Region -> [Image]
382− boxImages r@(Region left top width height) =
395+ boxImages (Region left top width height) =
383396 let right = left + width - 1
384397 bottom = top + height - 1
385− sides =
398+ sides =
386399 [ withinImage (Region (left + 1) top (width - 2) 1) $
387− V.charFill mempty (_boxStyle_n style) (width - 2) 1
400+ V.charFill V.defAttr (_boxStyle_n style) (width - 2) 1
388401 , withinImage (Region right (top + 1) 1 (height - 2)) $
389− V.charFill mempty (_boxStyle_e style) 1 (height - 2)
402+ V.charFill V.defAttr (_boxStyle_e style) 1 (height - 2)
390403 , withinImage (Region (left + 1) bottom (width - 2) 1) $
391− V.charFill mempty (_boxStyle_s style) (width - 2) 1
404+ V.charFill V.defAttr (_boxStyle_s style) (width - 2) 1
392405 , withinImage (Region left (top + 1) 1 (height - 2)) $
393− V.charFill mempty (_boxStyle_w style) 1 (height - 2)
406+ V.charFill V.defAttr (_boxStyle_w style) 1 (height - 2)
394407 ]
395408 corners =
396409 [ withinImage (Region left top 1 1) $
397− V.char mempty (_boxStyle_nw style)
410+ V.char V.defAttr (_boxStyle_nw style)
398411 , withinImage (Region right top 1 1) $
399− V.char mempty (_boxStyle_ne style)
412+ V.char V.defAttr (_boxStyle_ne style)
400413 , withinImage (Region right bottom 1 1) $
401− V.char mempty (_boxStyle_se style)
414+ V.char V.defAttr (_boxStyle_se style)
402415 , withinImage (Region left bottom 1 1) $
403− V.char mempty (_boxStyle_sw style)
416+ V.char V.defAttr (_boxStyle_sw style)
404417 ]
405418 in sides ++ if width > 1 && height > 1 then corners else []
406419
407−string :: (Reflex t, Monad m) => Behavior t String -> VtyWidget t m ()
420+string :: (Reflex t, Monad m) => Behavior t String -> VtyWidget t m ()
408421string msg = do
409422 dw <- displayWidth
410− let img = (\w s -> [wrapString w mempty s]) <$> current dw <*> msg
423+ let img = (\w s -> [wrapString w V.defAttr s]) <$> current dw <*> msg
411424 tellImages img
412425
413426regionBlankImage :: Region -> Image
@@ -420,4 +433,137 @@ withinImage (Region left top width height)
420433 | otherwise = V.translate left top . V.crop width height
421434
422435wrapString :: Int -> Attr -> String -> Image
423−wrapString maxWidth attrs = V.vertCat . concatMap (fmap (V.string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth)) . lines
436+wrapString maxWidth attrs = V.vertCat
437+ . concatMap (fmap (V.string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth))
438+ . lines
439+
440+wrapInputState
441+ :: Int -- ^ Maximum line length
442+ -> Attr -- ^ Normal string attributes
443+ -> Attr -- ^ Cursor character attributes
444+ -> InputState -- ^ The input to render
445+ -> Image
446+wrapInputState maxWidth attrs cursorAttrs (InputState before after) =
447+ let -- Break up the InputState into:
448+ -- * A top section of lines before the line containing the cursor
449+ -- * A part of the line containing the cursor that comes immediately before the cursor
450+ -- * The cursor character (i.e., the character the cursor is on top of)
451+ -- * The remainder of the line containing the cursor
452+ -- * The bottom section of lines after the line containing the cursor
453+ (top, midBefore, cursorChar, midAfter, bottom) = case (initLast before', headTail after') of
454+ (Nothing, Nothing) -> ([], "", ' ', "", [])
455+ (Just (top', mid), Nothing) -> (top', mid, ' ', "", [])
456+ (Nothing, Just (mid, bottom')) -> case T.uncons mid of
457+ Nothing -> ([], "", ' ', "", bottom')
458+ Just (c, rest) -> ([], "", c, rest, bottom')
459+ (Just (top', midB), Just (midA, bottom')) -> case T.uncons midA of
460+ Nothing -> (top', midB, ' ', "", bottom')
461+ Just (c, rest) -> (top', midB, c, rest, bottom')
462+ (midBeforeTop, midBefore') = fromMaybe ([], "") $ initLast $ wrap [midBefore]
463+ (midAfter', midAfterBottom) =
464+ let offset = if T.length midBefore' == maxWidth then 1 else T.length midBefore' + 1
465+ in case wrapWithOffset offset midAfter of
466+ [] -> ("", [])
467+ x:xs -> (x, xs)
468+ cursor = V.char cursorAttrs cursorChar
469+ in V.vertCat $ mconcat
470+ [ vstring <$> wrap top
471+ , vstring <$> midBeforeTop
472+ , if T.length midBefore' == maxWidth
473+ then
474+ [ vstring midBefore'
475+ , V.horizCat
476+ [ cursor
477+ , vstring midAfter'
478+ ]
479+ ]
480+ else
481+ [ V.horizCat
482+ [ vstring midBefore'
483+ , cursor
484+ , vstring midAfter'
485+ ]
486+ ]
487+ , vstring <$> midAfterBottom
488+ , vstring <$> bottom
489+ ]
490+ where
491+ before' = T.split (=='\n') before
492+ after' = T.split (=='\n') after
493+ vstring = V.string attrs . T.unpack
494+ wrapWithOffset :: Int -> Text -> [Text]
495+ wrapWithOffset n xs =
496+ let (firstLine, rest) = T.splitAt (maxWidth - n) xs
497+ in firstLine : (fmap (T.take maxWidth) . takeWhile (not . T.null) . iterate (T.drop maxWidth) $ rest)
498+ wrap :: [Text] -> [Text]
499+ wrap = concatMap (wrapWithOffset 0)
500+ headTail :: [a] -> Maybe (a, [a])
501+ headTail = \case
502+ [] -> Nothing
503+ x:xs -> Just (x, xs)
504+ initLast :: [a] -> Maybe ([a], a)
505+ initLast = \case
506+ [] -> Nothing
507+ (x:xs) -> case initLast xs of
508+ Nothing -> Just ([], x)
509+ Just (ys, y) -> Just (x:ys, y)
510+
511+data InputState = InputState
512+ { _inputState_beforeCursor :: Text
513+ , _inputState_afterCursor :: Text
514+ }
515+
516+inputValue :: InputState -> Text
517+inputValue (InputState a b) = a <> b
518+
519+updateInputState :: V.Event -> InputState -> InputState
520+updateInputState k i@(InputState before after) = case k of
521+ -- Regular characters
522+ V.EvKey (V.KChar k) [] -> InputState (T.snoc before k) after
523+ -- Deletion buttons
524+ V.EvKey V.KBS [] -> InputState (if T.null before then T.empty else T.init before) after
525+ V.EvKey V.KDel [] -> case T.uncons after of
526+ Nothing -> i
527+ Just (_, a) -> InputState before a
528+ -- Key combinations
529+ V.EvKey (V.KChar 'u') [V.MCtrl] -> InputState mempty mempty
530+ V.EvKey (V.KChar 'w') [V.MCtrl] -> InputState (T.dropWhileEnd (not . isSpace) $ T.dropWhileEnd isSpace $ before) after
531+ -- Navigation
532+ V.EvKey V.KRight [] -> case T.uncons after of
533+ Nothing -> i
534+ Just (a, as) -> InputState (T.snoc before a) as
535+ V.EvKey V.KLeft [] -> case T.unsnoc before of
536+ Nothing -> i
537+ Just (bs, b) -> InputState bs (T.cons b after)
538+ _ -> i
539+
540+data TextInputConfig t = TextInputConfig
541+ { _textInputConfig_modifyInputState :: Event t (InputState -> InputState)
542+ }
543+
544+instance Reflex t => Default (TextInputConfig t) where
545+ def = TextInputConfig never
546+
547+textInput :: (Reflex t, MonadHold t m, MonadFix m) => TextInputConfig t -> VtyWidget t m (Dynamic t Text)
548+textInput cfg = do
549+ i <- input
550+ v <- foldDyn ($) (InputState mempty mempty) $ mergeWith (.)
551+ [ updateInputState <$> i
552+ , _textInputConfig_modifyInputState cfg
553+ ]
554+ dw <- displayWidth
555+ let img = (\w s -> [wrapInputState w V.defAttr (V.withStyle V.defAttr V.reverseVideo) s]) -- TODO cursor ought to blink
556+ <$> current dw
557+ <*> current v
558+ tellImages img
559+ return $ inputValue <$> v
560+
561+multilineTextInput :: (Reflex t, MonadHold t m, MonadFix m) => TextInputConfig t -> VtyWidget t m (Dynamic t Text)
562+multilineTextInput cfg = do
563+ i <- input
564+ textInput $ TextInputConfig $ mergeWith (.)
565+ [ fforMaybe i $ \case
566+ V.EvKey V.KEnter [] -> Just $ \(InputState before after) -> InputState (T.snoc before '\n') after
567+ _ -> Nothing
568+ , _textInputConfig_modifyInputState cfg
569+ ]