From 9c9a2abeaae49a9488d23601b63aa972d684c93d Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 4 Nov 2018 02:09:44 -0500 Subject: [PATCH] Move generic text zipper stuff; Centralize text input widgets --- reflex-vty.cabal | 4 +- .../Widget/Text.hs => Data/Text/Zipper.hs} | 105 ++++++++---------- src/Reflex/Vty.hs | 6 +- src/Reflex/Vty/Widget.hs | 62 +---------- src/Reflex/Vty/Widget/Input.hs | 5 + src/Reflex/Vty/Widget/Input/Text.hs | 103 +++++++++++++++++ 6 files changed, 165 insertions(+), 120 deletions(-) rename src/{Reflex/Vty/Widget/Text.hs => Data/Text/Zipper.hs} (74%) create mode 100644 src/Reflex/Vty/Widget/Input.hs create mode 100644 src/Reflex/Vty/Widget/Input/Text.hs diff --git a/reflex-vty.cabal b/reflex-vty.cabal index f14cf25..7fa242d 100644 --- a/reflex-vty.cabal +++ b/reflex-vty.cabal @@ -14,7 +14,9 @@ library exposed-modules: Reflex.Vty , Reflex.Vty.Host , Reflex.Vty.Widget - , Reflex.Vty.Widget.Text + , Reflex.Vty.Widget.Input + , Reflex.Vty.Widget.Input.Text + , Data.Text.Zipper other-modules: Reflex.Spider.Orphans build-depends: base, diff --git a/src/Reflex/Vty/Widget/Text.hs b/src/Data/Text/Zipper.hs similarity index 74% rename from src/Reflex/Vty/Widget/Text.hs rename to src/Data/Text/Zipper.hs index a576b70..7114a83 100644 --- a/src/Reflex/Vty/Widget/Text.hs +++ b/src/Data/Text/Zipper.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Reflex.Vty.Widget.Text where +module Data.Text.Zipper where import Data.Char import Data.Map (Map) @@ -11,10 +11,13 @@ import Control.Monad.State import Data.Text (Text) import qualified Data.Text as T -import qualified Graphics.Vty as V --- | A zipper of the logical text input contents. The lines before the line containing the cursor --- are stored in reverse order. The cursor is logically _between_ the "before" and "after" text. +-- | A zipper of the logical text input contents (the "document"). The lines +-- before the line containing the cursor are stored in reverse order. +-- The cursor is logically between the "before" and "after" text. +-- A "logical" line of input is a line of input up until a user-entered newline +-- character (as compared to a "display" line, which is wrapped to fit within +-- a given viewport width). data TextZipper = TextZipper { _textZipper_linesBefore :: [Text] -- reversed , _textZipper_before :: Text @@ -23,6 +26,7 @@ data TextZipper = TextZipper } deriving (Show) +-- | Move the cursor left one character, if possible left :: TextZipper -> TextZipper left z@(TextZipper lb b a la) = case T.unsnoc b of Nothing -> case lb of @@ -30,6 +34,7 @@ left z@(TextZipper lb b a la) = case T.unsnoc b of (l:ls) -> TextZipper ls l "" (a : la) Just (b', c) -> TextZipper lb b' (T.cons c a) la +-- | Move the cursor right one character, if possible right :: TextZipper -> TextZipper right z@(TextZipper lb b a la) = case T.uncons a of Nothing -> case la of @@ -37,6 +42,7 @@ right z@(TextZipper lb b a la) = case T.uncons a of (l:ls) -> TextZipper (b : lb) "" l ls Just (c, a') -> TextZipper lb (T.snoc b c) a' la +-- | Move the cursor up one logical line, if possible up :: TextZipper -> TextZipper up z@(TextZipper lb b a la) = case lb of [] -> z @@ -44,6 +50,7 @@ up z@(TextZipper lb b a la) = case lb of let (b', a') = T.splitAt (T.length b) l in TextZipper ls b' a' ((b <> a) : la) +-- | Move the cursor down one logical line, if possible down :: TextZipper -> TextZipper down z@(TextZipper lb b a la) = case la of [] -> z @@ -51,17 +58,25 @@ down z@(TextZipper lb b a la) = case la of let (b', a') = T.splitAt (T.length b) l in TextZipper ((b <> a) : lb) b' a' ls +-- | Move the cursor to the beginning of the current logical line home :: TextZipper -> TextZipper home (TextZipper lb b a la) = TextZipper lb "" (b <> a) la +-- | Move the cursor to the end of the current logical line end :: TextZipper -> TextZipper end (TextZipper lb b a la) = TextZipper lb (b <> a) "" la +-- | Move the cursor to the top of the document top :: TextZipper -> TextZipper top (TextZipper lb b a la) = case reverse lb of [] -> TextZipper [] "" (b <> a) la (start:rest) -> TextZipper [] "" start (rest <> la) +-- | Insert a character at the current cursor position +insertChar :: Char -> TextZipper -> TextZipper +insertChar i = insert (T.singleton i) + +-- | Insert text at the current cursor position insert :: Text -> TextZipper -> TextZipper insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of [] -> z @@ -69,6 +84,7 @@ insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of [] -> TextZipper lb (b <> start) a la (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la +-- | Delete the character to the left of the cursor deleteLeft :: TextZipper-> TextZipper deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of Nothing -> case lb of @@ -76,6 +92,7 @@ deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of (l:ls) -> TextZipper ls l a la Just (b', _) -> TextZipper lb b' a la +-- | Delete the character under/to the right of the cursor deleteRight :: TextZipper -> TextZipper deleteRight z@(TextZipper lb b a la) = case T.uncons a of Nothing -> case la of @@ -83,6 +100,9 @@ deleteRight z@(TextZipper lb b a la) = case T.uncons a of (l:ls) -> TextZipper lb b l ls Just (_, a') -> TextZipper lb b a' la +-- | Delete a word to the left of the cursor. Deletes all whitespace until it +-- finds a non-whitespace character, and then deletes contiguous non-whitespace +-- characters. deleteLeftWord :: TextZipper -> TextZipper deleteLeftWord (TextZipper lb b a la) = let b' = T.dropWhileEnd isSpace b @@ -92,29 +112,30 @@ deleteLeftWord (TextZipper lb b a la) = (l:ls) -> deleteLeftWord $ TextZipper ls l a la else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la +-- | The plain text contents of the zipper value :: TextZipper -> Text value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb , [b <> a] , la ] +-- | The empty zipper empty :: TextZipper empty = TextZipper [] "" "" [] +-- | Constructs a zipper with the given contents. The cursor is placed after +-- the contents. fromText :: Text -> TextZipper fromText = flip insert empty --- | A span of text that makes up part of a display line -data Span = Span V.Attr Text +-- | A span of text tagged with some metadata that makes up part of a display +-- line. +data Span tag = Span tag Text deriving (Show) --- | Default attributes for the text cursor -cursorAttributes :: V.Attr -cursorAttributes = V.withStyle V.defAttr V.reverseVideo - -- | Information about the documents as it is displayed (i.e., post-wrapping) -data DisplayLines = DisplayLines - { _displayLines_spans :: [[Span]] +data DisplayLines tag = DisplayLines + { _displayLines_spans :: [[Span tag]] , _displayLines_offsetMap :: Map Int Int , _displayLines_cursorY :: Int } @@ -127,9 +148,11 @@ data DisplayLines = DisplayLines -- offset displayLines :: Int -- ^ Width, used for wrapping + -> tag -- ^ Metadata for normal characters + -> tag -- ^ Metadata for the cursor -> TextZipper -- ^ The text input contents and cursor state - -> DisplayLines -displayLines width (TextZipper lb b a la) = + -> DisplayLines tag +displayLines width tag cursorTag (TextZipper lb b a la) = let linesBefore :: [[Text]] linesBefore = map (wrapWithOffset width 0) $ reverse lb linesAfter :: [[Text]] @@ -139,25 +162,19 @@ displayLines width (TextZipper lb b a la) = , [wrapWithOffset width 0 $ b <> a] , linesAfter ] - spansBefore = map ((:[]) . Span V.defAttr) $ concat linesBefore - spansAfter = map ((:[]) . Span V.defAttr) $ concat linesAfter + spansBefore = map ((:[]) . Span tag) $ concat linesBefore + spansAfter = map ((:[]) . Span tag) $ concat linesAfter (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $ - initLast $ map ((:[]) . Span V.defAttr) (wrapWithOffset width 0 b) + initLast $ map ((:[]) . Span tag) (wrapWithOffset width 0 b) curLineOffset = spansLength spansCurLineBefore cursorAfterEOL = curLineOffset == width - -- (cursor, spansCurLineAfter, spansCurrentAfter) = case T.uncons a of - -- Nothing -> (Span cursorAttributes " ", [], []) - -- Just (c, rest) -> - -- ( Span cursorAttributes (T.singleton c) - -- , - (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $ headTail $ case T.uncons a of - Nothing -> [[Span cursorAttributes " "]] + Nothing -> [[Span cursorTag " "]] Just (c, rest) -> let o = if cursorAfterEOL then 1 else curLineOffset + 1 - cursor = Span cursorAttributes (T.singleton c) - in case map ((:[]) . Span V.defAttr) (wrapWithOffset width o rest) of + cursor = Span cursorTag (T.singleton c) + in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of [] -> [[cursor]] (l:ls) -> (cursor : l) : ls in DisplayLines @@ -178,7 +195,7 @@ displayLines width (TextZipper lb b a la) = ] } where - spansLength :: [Span] -> Int + spansLength :: [Span tag] -> Int spansLength = sum . map (\(Span _ t) -> T.length t) initLast :: [a] -> Maybe ([a], a) initLast = \case @@ -191,6 +208,9 @@ displayLines width (TextZipper lb b a la) = [] -> Nothing x:xs -> Just (x, xs) +-- | Wraps a logical line of text to fit within the given width. The first +-- wrapped line is offset by the number of columns provided. Subsequent wrapped +-- lines are not. wrapWithOffset :: Int -> Int -> Text -> [Text] wrapWithOffset maxWidth _ _ | maxWidth <= 0 = [] wrapWithOffset maxWidth n xs = @@ -232,34 +252,3 @@ offsetMap ts = evalState (offsetMap' ts) (0, 0) (dl, o) <- get put (dl, o + 1) return $ Map.insert dl (o + 1) $ Map.unions maps - --- click :: (Int, Int) -> Int -> DisplayLines -> TextZipper --- click (x, y) scrollTop dlines = undefined - -images :: [[Span]] -> [V.Image] -images = map (V.horizCat . map spanToImage) - -image :: [[Span]] -> V.Image -image = V.vertCat . images - -spanToImage :: Span -> V.Image -spanToImage (Span attrs t) = V.text' attrs t - -updateTextZipper :: V.Event -> TextZipper -> TextZipper -updateTextZipper ev = case ev of - -- Regular characters - V.EvKey (V.KChar k) [] -> insert $ T.singleton k - -- Deletion buttons - V.EvKey V.KBS [] -> deleteLeft - V.EvKey V.KDel [] -> deleteRight - -- Key combinations - V.EvKey (V.KChar 'u') [V.MCtrl] -> const empty - V.EvKey (V.KChar 'w') [V.MCtrl] -> deleteLeftWord - -- Arrow keys - V.EvKey V.KLeft [] -> left - V.EvKey V.KRight [] -> right - V.EvKey V.KUp [] -> up - V.EvKey V.KDown [] -> down - V.EvKey V.KHome [] -> home - V.EvKey V.KEnd [] -> end - _ -> id diff --git a/src/Reflex/Vty.hs b/src/Reflex/Vty.hs index 28e9398..859d4d0 100644 --- a/src/Reflex/Vty.hs +++ b/src/Reflex/Vty.hs @@ -1,7 +1,11 @@ module Reflex.Vty - ( module Reflex.Vty.Host + ( module Reflex + , module Reflex.Vty.Host , module Reflex.Vty.Widget + , module Reflex.Vty.Widget.Input ) where +import Reflex import Reflex.Vty.Host import Reflex.Vty.Widget +import Reflex.Vty.Widget.Input diff --git a/src/Reflex/Vty/Widget.hs b/src/Reflex/Vty/Widget.hs index 4c2bb00..0057841 100644 --- a/src/Reflex/Vty/Widget.hs +++ b/src/Reflex/Vty/Widget.hs @@ -44,10 +44,6 @@ module Reflex.Vty.Widget , doubleBoxStyle , fill , hRule - , TextInputConfig(..) - , textInput - , multilineTextInput - , def ) where import Control.Applicative (liftA2) @@ -58,13 +54,12 @@ import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell) import Data.Default import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Zipper as TZ import Graphics.Vty (Image, Attr) import qualified Graphics.Vty as V import Reflex import Reflex.Vty.Host -import Reflex.Vty.Widget.Text (TextZipper(..), DisplayLines(..)) -import qualified Reflex.Vty.Widget.Text as TZ -- | The context within which a 'VtyWidget' runs data VtyWidgetCtx t = VtyWidgetCtx @@ -439,58 +434,5 @@ withinImage (Region left top width height) wrapText :: Int -> Attr -> Text -> Image wrapText maxWidth attrs = V.vertCat - . concatMap (fmap (V.string attrs . T.unpack) . wrapWithOffset maxWidth 0) + . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n') - -wrapWithOffset :: Int -> Int -> Text -> [Text] -wrapWithOffset maxWidth _ _ | maxWidth <= 0 = [] -wrapWithOffset maxWidth n xs = - let (firstLine, rest) = T.splitAt (maxWidth - n) xs - in firstLine : (fmap (T.take maxWidth) . takeWhile (not . T.null) . iterate (T.drop maxWidth) $ rest) - -data TextInputConfig t = TextInputConfig - { _textInputConfig_initialValue :: TextZipper - , _textInputConfig_modify :: Event t (TextZipper -> TextZipper) - } - -instance Reflex t => Default (TextInputConfig t) where - def = TextInputConfig TZ.empty never - -textInput - :: (Reflex t, MonadHold t m, MonadFix m) - => TextInputConfig t - -> VtyWidget t m (Dynamic t Text) -textInput cfg = do - i <- input - v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.) - [ TZ.updateTextZipper <$> i - , _textInputConfig_modify cfg - ] - dw <- displayWidth - dh <- displayHeight - let rows = (\w s -> TZ.displayLines w s) <$> dw <*> v - img = TZ.images . _displayLines_spans <$> rows - y <- holdUniqDyn $ _displayLines_cursorY <$> rows - let newScrollTop st (h, cursorY) - | cursorY < st = cursorY - | cursorY >= st + h = cursorY - h + 1 - | otherwise = st - rec let hy = attachWith newScrollTop (current scrollTop) $ updated $ zipDyn dh y - scrollTop <- holdDyn 0 hy - tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> current scrollTop - return $ TZ.value <$> v - -multilineTextInput - :: (Reflex t, MonadHold t m, MonadFix m) - => TextInputConfig t - -> VtyWidget t m (Dynamic t Text) -multilineTextInput cfg = do - i <- input - textInput $ cfg - { _textInputConfig_modify = mergeWith (.) - [ fforMaybe i $ \case - V.EvKey V.KEnter [] -> Just $ TZ.insert "\n" - _ -> Nothing - , _textInputConfig_modify cfg - ] - } diff --git a/src/Reflex/Vty/Widget/Input.hs b/src/Reflex/Vty/Widget/Input.hs new file mode 100644 index 0000000..38086aa --- /dev/null +++ b/src/Reflex/Vty/Widget/Input.hs @@ -0,0 +1,5 @@ +module Reflex.Vty.Widget.Input + ( module Reflex.Vty.Widget.Input.Text + ) where + +import Reflex.Vty.Widget.Input.Text diff --git a/src/Reflex/Vty/Widget/Input/Text.hs b/src/Reflex/Vty/Widget/Input/Text.hs new file mode 100644 index 0000000..8084634 --- /dev/null +++ b/src/Reflex/Vty/Widget/Input/Text.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +module Reflex.Vty.Widget.Input.Text + ( module Reflex.Vty.Widget.Input.Text + , def + ) where + +import Control.Monad.Fix +import Data.Default +import Data.Text (Text) +import Data.Text.Zipper +import qualified Graphics.Vty as V +import Reflex +import Reflex.Vty.Widget + +-- | Configuration options for a 'textInput'. For more information on +-- 'TextZipper', see 'Data.Text.Zipper'. +data TextInputConfig t = TextInputConfig + { _textInputConfig_initialValue :: TextZipper + , _textInputConfig_modify :: Event t (TextZipper -> TextZipper) + } + +instance Reflex t => Default (TextInputConfig t) where + def = TextInputConfig empty never + +-- | A widget that allows text input +textInput + :: (Reflex t, MonadHold t m, MonadFix m) + => TextInputConfig t + -> VtyWidget t m (Dynamic t Text) +textInput cfg = do + i <- input + v <- foldDyn ($) (_textInputConfig_initialValue cfg) $ mergeWith (.) + [ updateTextZipper <$> i + , _textInputConfig_modify cfg + ] + dw <- displayWidth + dh <- displayHeight + let rows = (\w s -> displayLines w V.defAttr cursorAttributes s) <$> dw <*> v + img = images . _displayLines_spans <$> rows + y <- holdUniqDyn $ _displayLines_cursorY <$> rows + let newScrollTop st (h, cursorY) + | cursorY < st = cursorY + | cursorY >= st + h = cursorY - h + 1 + | otherwise = st + rec let hy = attachWith newScrollTop (current scrollTop) $ updated $ zipDyn dh y + scrollTop <- holdDyn 0 hy + tellImages $ (\imgs st -> (:[]) . V.vertCat $ drop st imgs) <$> current img <*> current scrollTop + return $ value <$> v + +-- | A widget that allows multiline text input +multilineTextInput + :: (Reflex t, MonadHold t m, MonadFix m) + => TextInputConfig t + -> VtyWidget t m (Dynamic t Text) +multilineTextInput cfg = do + i <- input + textInput $ cfg + { _textInputConfig_modify = mergeWith (.) + [ fforMaybe i $ \case + V.EvKey V.KEnter [] -> Just $ insert "\n" + _ -> Nothing + , _textInputConfig_modify cfg + ] + } + +-- | Default attributes for the text cursor +cursorAttributes :: V.Attr +cursorAttributes = V.withStyle V.defAttr V.reverseVideo + +-- | Turn a set of display line rows into a list of images (one per line) +images :: [[Span V.Attr]] -> [V.Image] +images = map (V.horizCat . map spanToImage) + +-- | Turn a set of display line rows into a single image +image :: [[Span V.Attr]] -> V.Image +image = V.vertCat . images + +-- | Turn a 'Span' into an 'Image' +spanToImage :: Span V.Attr -> V.Image +spanToImage (Span attrs t) = V.text' attrs t + +-- | Default vty event handler for text inputs +updateTextZipper :: V.Event -> TextZipper -> TextZipper +updateTextZipper ev = case ev of + -- Regular characters + V.EvKey (V.KChar k) [] -> insertChar k + -- Deletion buttons + V.EvKey V.KBS [] -> deleteLeft + V.EvKey V.KDel [] -> deleteRight + -- Key combinations + V.EvKey (V.KChar 'u') [V.MCtrl] -> const empty + V.EvKey (V.KChar 'w') [V.MCtrl] -> deleteLeftWord + -- Arrow keys + V.EvKey V.KLeft [] -> left + V.EvKey V.KRight [] -> right + V.EvKey V.KUp [] -> up + V.EvKey V.KDown [] -> down + V.EvKey V.KHome [] -> home + V.EvKey V.KEnd [] -> end + _ -> id