@@ -4,6 +4,7 @@
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
@@ -42,6 +43,10 @@ module Reflex.Vty.Widget
42 , doubleBoxStyle
43 , doubleBoxStyle
47import Control.Applicative (liftA2)
52import Control.Applicative (liftA2)
@@ -49,8 +54,13 @@ import Control.Monad.Fix (MonadFix)
49import Control.Monad.Trans (lift)
54import Control.Monad.Trans (lift)
50import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)
55import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)
51import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell)
56import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell)
59+import Data.Maybe (fromMaybe)
60+import Data.Text (Text)
61+import qualified Data.Text as T
52import Graphics.Vty (Image, Attr)
62import Graphics.Vty (Image, Attr)
53−import qualified Graphics.Vty as V
63+import qualified Graphics.Vty as V
54import Reflex
64import Reflex
56import Reflex.Vty.Host
66import Reflex.Vty.Host
@@ -63,7 +73,7 @@ data VtyWidgetCtx t = VtyWidgetCtx
63 -- ^ Whether the widget should behave as if it has focus for keyboard input.
73 -- ^ Whether the widget should behave as if it has focus for keyboard input.
64 , _vtyWidgetCtx_input :: Event t VtyEvent
74 , _vtyWidgetCtx_input :: Event t VtyEvent
65 -- ^ User input events that the widget's parent chooses to share. These will generally
75 -- ^ User input events that the widget's parent chooses to share. These will generally
66− -- be filtered for relevance:
76+ -- be filtered for relevance:
67 -- * Keyboard inputs are restricted to focused widgets
77 -- * Keyboard inputs are restricted to focused widgets
68 -- * Mouse inputs are restricted to the region in which the widget resides and are
78 -- * Mouse inputs are restricted to the region in which the widget resides and are
69 -- translated into its internal coordinates.
79 -- translated into its internal coordinates.
@@ -294,7 +304,7 @@ splitVDrag wS wA wB = do
294 let splitter0 = h0 `div` 2
304 let splitter0 = h0 `div` 2
295 rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
305 rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
296 splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]
306 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) ->
298 fromIntegral x / fromIntegral h
308 fromIntegral x / fromIntegral h
299 let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
309 let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
300 \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
310 \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
@@ -322,10 +332,10 @@ splitVDrag wS wA wB = do
322fill :: (Reflex t, Monad m) => Char -> VtyWidget t m ()
332fill :: (Reflex t, Monad m) => Char -> VtyWidget t m ()
323fill c = do
333fill c = do
324 sz <- displaySize
334 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]
326 tellImages fillImg
336 tellImages fillImg
328−-- | Fill the background with the bottom
338+-- | Fill the background with the bottom
329hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()
339hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()
330hRule boxStyle = fill (_boxStyle_s boxStyle)
340hRule boxStyle = fill (_boxStyle_s boxStyle)
@@ -337,7 +347,7 @@ modifyImages
337 => Behavior t ([Image] -> [Image])
347 => Behavior t ([Image] -> [Image])
338 -> VtyWidget t m a
348 -> VtyWidget t m a
339 -> VtyWidget t m a
349 -> VtyWidget t m a
340−modifyImages f (VtyWidget w) = VtyWidget $ flip censor w $ \wo ->
350+modifyImages f (VtyWidget w) = VtyWidget $ flip censor w $ \wo ->
341 wo { _vtyWidgetOut_images = f <*> (_vtyWidgetOut_images wo) }
351 wo { _vtyWidgetOut_images = f <*> (_vtyWidgetOut_images wo) }
343data BoxStyle = BoxStyle
353data BoxStyle = BoxStyle
@@ -351,6 +361,9 @@ data BoxStyle = BoxStyle
351 , _boxStyle_w :: Char
361 , _boxStyle_w :: Char
364+instance Default BoxStyle where
365+ def = singleBoxStyle
354hyphenBoxStyle :: BoxStyle
367hyphenBoxStyle :: BoxStyle
355hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
368hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
@@ -379,35 +392,35 @@ box style child = do
379 pane innerReg (pure True) child
392 pane innerReg (pure True) child
381 boxImages :: Region -> [Image]
394 boxImages :: Region -> [Image]
382− boxImages r@(Region left top width height) =
395+ boxImages (Region left top width height) =
383 let right = left + width - 1
396 let right = left + width - 1
384 bottom = top + height - 1
397 bottom = top + height - 1
385− sides =
398+ sides =
386 [ withinImage (Region (left + 1) top (width - 2) 1) $
399 [ 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
388 , withinImage (Region right (top + 1) 1 (height - 2)) $
401 , 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)
390 , withinImage (Region (left + 1) bottom (width - 2) 1) $
403 , 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
392 , withinImage (Region left (top + 1) 1 (height - 2)) $
405 , 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)
395 corners =
408 corners =
396 [ withinImage (Region left top 1 1) $
409 [ withinImage (Region left top 1 1) $
397− V.char mempty (_boxStyle_nw style)
410+ V.char V.defAttr (_boxStyle_nw style)
398 , withinImage (Region right top 1 1) $
411 , withinImage (Region right top 1 1) $
399− V.char mempty (_boxStyle_ne style)
412+ V.char V.defAttr (_boxStyle_ne style)
400 , withinImage (Region right bottom 1 1) $
413 , withinImage (Region right bottom 1 1) $
401− V.char mempty (_boxStyle_se style)
414+ V.char V.defAttr (_boxStyle_se style)
402 , withinImage (Region left bottom 1 1) $
415 , withinImage (Region left bottom 1 1) $
403− V.char mempty (_boxStyle_sw style)
416+ V.char V.defAttr (_boxStyle_sw style)
405 in sides ++ if width > 1 && height > 1 then corners else []
418 in sides ++ if width > 1 && height > 1 then corners else []
407−string :: (Reflex t, Monad m) => Behavior t String -> VtyWidget t m ()
420+string :: (Reflex t, Monad m) => Behavior t String -> VtyWidget t m ()
408string msg = do
421string msg = do
409 dw <- displayWidth
422 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
411 tellImages img
424 tellImages img
413regionBlankImage :: Region -> Image
426regionBlankImage :: Region -> Image
@@ -420,4 +433,137 @@ withinImage (Region left top width height)
420 | otherwise = V.translate left top . V.crop width height
433 | otherwise = V.translate left top . V.crop width height
422wrapString :: Int -> Attr -> String -> Image
435wrapString :: Int -> Attr -> String -> Image
436+wrapString maxWidth attrs = V.vertCat
423−wrapString maxWidth attrs = V.vertCat . concatMap (fmap (V.string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth)) . lines
437+ . concatMap (fmap (V.string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth))
441+ :: Int -- ^ Maximum line length
442+ -> Attr -- ^ Normal string attributes
443+ -> Attr -- ^ Cursor character attributes
444+ -> InputState -- ^ The input to render
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
468+ cursor = V.char cursorAttrs cursorChar
469+ in V.vertCat $ mconcat
470+ [ vstring <$> wrap top
471+ , vstring <$> midBeforeTop
472+ , if T.length midBefore' == maxWidth
474+ [ vstring midBefore'
482+ [ vstring midBefore'
487+ , vstring <$> midAfterBottom
488+ , vstring <$> bottom
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])
503+ x:xs -> Just (x, xs)
504+ initLast :: [a] -> Maybe ([a], a)
507+ (x:xs) -> case initLast xs of
508+ Nothing -> Just ([], x)
509+ Just (ys, y) -> Just (x:ys, y)
511+data InputState = InputState
512+ { _inputState_beforeCursor :: Text
513+ , _inputState_afterCursor :: Text
516+inputValue :: InputState -> Text
517+inputValue (InputState a b) = a <> b
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
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
527+ Just (_, a) -> InputState before a
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
532+ V.EvKey V.KRight [] -> case T.uncons after of
534+ Just (a, as) -> InputState (T.snoc before a) as
535+ V.EvKey V.KLeft [] -> case T.unsnoc before of
537+ Just (bs, b) -> InputState bs (T.cons b after)
540+data TextInputConfig t = TextInputConfig
541+ { _textInputConfig_modifyInputState :: Event t (InputState -> InputState)
544+instance Reflex t => Default (TextInputConfig t) where
545+ def = TextInputConfig never
547+textInput :: (Reflex t, MonadHold t m, MonadFix m) => TextInputConfig t -> VtyWidget t m (Dynamic t Text)
550+ v <- foldDyn ($) (InputState mempty mempty) $ mergeWith (.)
551+ [ updateInputState <$> i
552+ , _textInputConfig_modifyInputState cfg
555+ let img = (\w s -> [wrapInputState w V.defAttr (V.withStyle V.defAttr V.reverseVideo) s]) -- TODO cursor ought to blink
559+ return $ inputValue <$> v
561+multilineTextInput :: (Reflex t, MonadHold t m, MonadFix m) => TextInputConfig t -> VtyWidget t m (Dynamic t Text)
562+multilineTextInput cfg = do
564+ textInput $ TextInputConfig $ mergeWith (.)
565+ [ fforMaybe i $ \case
566+ V.EvKey V.KEnter [] -> Just $ \(InputState before after) -> InputState (T.snoc before '\n') after
568+ , _textInputConfig_modifyInputState cfg