reflex-vty 0.4.1.1 → 0.5.0.0
raw patch · 12 files changed
+365/−171 lines, 12 files
Files
- ChangeLog.md +13/−1
- reflex-vty.cabal +2/−1
- src-bin/example.hs +39/−3
- src/Data/Text/Zipper.hs +107/−97
- src/Reflex/Vty.hs +2/−0
- src/Reflex/Vty/Widget.hs +16/−7
- src/Reflex/Vty/Widget/Box.hs +18/−11
- src/Reflex/Vty/Widget/Input.hs +8/−0
- src/Reflex/Vty/Widget/Layout.hs +0/−1
- src/Reflex/Vty/Widget/Scroll.hs +110/−0
- src/Reflex/Vty/Widget/Text.hs +13/−34
- test/Data/Text/ZipperSpec.hs +37/−16
ChangeLog.md view
@@ -1,5 +1,17 @@ # Revision history for reflex-vty +## 0.5.0.0++* *Breaking change*:+ * `scrollableText` now takes a `ScrollableConfiguration` instead of just an `Event t Int` of lines to scroll by. Replacing a `scrollableText myEvent` invocation with `scrollableText (def { _scrollableConfig_scrollBy = myEvent })` should recover the old behavior.+ * `scrollableText` now returns a `Scrollable t` instead of a `Behavior (Int, Int)`. The second `Int`, representing the total number of lines, is part of the `Scrollable` record. The first `Int`, representing the current scroll position is replaced by the `ScrollPos` in the `Scrollable` output. `ScrollPos` is a new type that captures whether a `scrollableText` is scrolled to the very top, very bottom, or somewhere in between.+* `scrollableText` can now be given a starting scroll position and an event that scrolls it to a particular position.+* `scrollableText` can be configured to remain scrolled to the bottom on new output, either always or whenever the user is scrolled to the bottom and new output appears.+* Added a new `scrollable` widget in `Reflex.Vty.Widget.Scroll` that allows vertical scrolling when an `Image` is taller than the widget's height.+* Add `ctrlc`, a convenience function that returns an event that fires when a Ctrl+c keypress is detected+* Fix several issues with wide chars, cursor position and word wrapping in Zipper.hs+* Add `centerText` function to Reflex.Vty.Widget.Box+ ## 0.4.1.1 * Support ghc-9.6@@ -18,7 +30,7 @@ * Mouse drag sequences that start ON the region and drag off ARE reported * Introduce `MonadHold` constraint to `pane` * Added `MonadHold` constraint to several methods that use `pane`- + ## 0.3.1.1 * Loosen version bounds and support GHC 9.4
reflex-vty.cabal view
@@ -1,5 +1,5 @@ name: reflex-vty-version: 0.4.1.1+version: 0.5.0.0 synopsis: Reflex FRP host and widgets for VTY applications description: Build terminal applications using functional reactive programming (FRP) with Reflex FRP (<https://reflex-frp.org>).@@ -33,6 +33,7 @@ , Reflex.Vty.Widget.Input.Mouse , Reflex.Vty.Widget.Input.Text , Reflex.Vty.Widget.Layout+ , Reflex.Vty.Widget.Scroll , Reflex.Vty.Widget.Split , Reflex.Vty.Widget.Text , Data.Text.Zipper
src-bin/example.hs view
@@ -1,6 +1,8 @@ import Control.Applicative+import Control.Concurrent import Control.Monad import Control.Monad.Fix+import Control.Monad.IO.Class import Data.Functor import Data.Functor.Misc import Data.Map (Map)@@ -9,6 +11,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Zipper as TZ+import Data.Time (getCurrentTime) import qualified Graphics.Vty as V import Reflex import Reflex.Network@@ -232,13 +235,46 @@ -- * Scrollable text example -scrolling :: (VtyExample t m, MonadHold t m, Manager t m, PostBuild t m) => m ()+scrolling+ :: ( VtyExample t m+ , MonadHold t m+ , Manager t m+ , PostBuild t m+ , MonadIO (Performable m)+ , TriggerEvent t m+ , PerformEvent t m+ )+ => m () scrolling = col $ do grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"- (fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."+ (fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText def $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant." pb <- getPostBuild requestFocus $ Refocus_Id fid <$ pb- grout (fixed 1) $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)+ grout (fixed 1) $ text $ ffor (_scrollable_scrollPosition out) $ \p -> "Scrolled to " <> case p of+ ScrollPos_Top -> "top"+ ScrollPos_Bottom -> "bottom"+ ScrollPos_Line n -> "line " <> T.pack (show n)+ e <- performEventAsync $ ffor pb $ \_ cb -> liftIO $ void $ forkIO $ forever $ do+ threadDelay 1000000+ t <- getCurrentTime+ cb $ [T.pack $ show t]+ xs <- foldDyn (flip (<>)) [] e+ grout (fixed 3) blank+ tile (fixed 10) $ col $ do+ grout (fixed 1) $ text "This one scrolls automatically as the output grows:"+ Scrollable pos total h <- tile flex $+ scrollableText (ScrollableConfig never never ScrollPos_Bottom (pure $ Just ScrollToBottom_Maintain)) $+ T.unlines <$> xs+ grout (fixed 5) $ boxStatic def $ do+ grout (fixed 1) $ row $ do+ grout (fixed 8) (text "Height:")+ grout flex $ display h+ grout (fixed 1) $ row $ do+ grout (fixed 8) $ text "Scroll:"+ grout flex $ display pos+ grout (fixed 1) $ row $ do+ grout (fixed 8) $ text "Length:"+ grout flex $ display total -- * Text editor example with resizable boxes
src/Data/Text/Zipper.hs view
@@ -9,25 +9,21 @@ -} module Data.Text.Zipper where -import Prelude- import Control.Exception (assert)+import Control.Monad+import Control.Monad.State (evalState, get, put) import Data.Char (isSpace) import Data.Map (Map)-import Data.Maybe (fromMaybe) import Data.String-import Control.Monad-import Control.Monad.Fix-import Control.Monad.State (evalState, get, put) +import qualified Data.List as L+import qualified Data.Map as Map import Data.Text (Text)+import qualified Data.Text as T import Data.Text.Internal (Text(..), text) import Data.Text.Internal.Fusion (stream)-import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))+import Data.Text.Internal.Fusion.Types (Step(..), Stream(..)) import Data.Text.Unsafe-import qualified Data.List as L-import qualified Data.Map as Map-import qualified Data.Text as T import Graphics.Text.Width (wcwidth) @@ -44,7 +40,7 @@ , _textZipper_after :: Text -- The cursor is on top of the first character of this text , _textZipper_linesAfter :: [Text] }- deriving (Show)+ deriving (Show, Eq) instance IsString TextZipper where fromString = fromText . T.pack@@ -194,7 +190,7 @@ -- | A span of text tagged with some metadata that makes up part of a display -- line. data Span tag = Span tag Text- deriving (Show)+ deriving (Eq, Show) -- | Text alignment type data TextAlignment =@@ -203,13 +199,13 @@ | TextAlignment_Center deriving (Eq, Show) --- A map from the index (row) of display line to (fst,snd)+-- | A map from the index (row) of display line to (fst,snd) -- fst: leading empty spaces from left (may be negative) to adjust for alignment -- snd: the text offset from the beginning of the document -- to the first character of the display line type OffsetMapWithAlignment = Map Int (Int, Int) --- helper type representing a single visual line that may be part of a wrapped logical line+-- | Helper type representing a single visual line that may be part of a wrapped logical line data WrappedLine = WrappedLine { _wrappedLines_text :: Text , _wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character@@ -218,12 +214,14 @@ deriving (Eq, Show) -- | Information about the document as it is displayed (i.e., post-wrapping)-data DisplayLines tag = DisplayLines- { _displayLines_spans :: [[Span tag]]- , _displayLines_offsetMap :: OffsetMapWithAlignment- , _displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner+data DisplayLines tag = DisplayLines {+ _displayLines_spans :: [[Span tag]]+ -- ^ NOTE this will contain a dummy space character if the cursor is at the end+ , _displayLines_offsetMap :: OffsetMapWithAlignment+ -- ^ NOTE this will not include offsets for the y position of dummy ' ' character if it is on its own line+ , _displayLines_cursorPos :: (Int, Int) -- ^ cursor position relative to upper left hand corner }- deriving (Show)+ deriving (Eq, Show) -- | Split a 'Text' at the given column index. For example --@@ -234,16 +232,29 @@ splitAtWidth n t@(Text arr off len) | n <= 0 = (T.empty, t) | n >= textWidth t = (t, T.empty)- | otherwise = let k = toLogicalIndex n t+ | otherwise = let k = characterIndexFromWidth n t in (text arr off k, text arr (off+k) (len-k)) -toLogicalIndex :: Int -> Text -> Int-toLogicalIndex n' t'@(Text _ _ len') = loop 0 0- where loop !i !cnt- | i >= len' || cnt + w > n' = i- | otherwise = loop (i+d) (cnt + w)- where Iter c d = iter t' i- w = charWidth c+-- | Convert a physical width index to a character index. For example, the+-- physical index 3 of the string "ᄀabc" corresponds to the character index 2,+-- because the first character has a width of 2.+characterIndexFromWidth :: Int -> Text -> Int+characterIndexFromWidth n' t'@(Text _ _ len') = loop 0 0 0+ where+ loop+ :: Int -- Byte index of the 'Text' we're traversing+ -> Int -- The accumulated logical index so far+ -> Int -- The accumulated physical width+ -> Int -- The new logical index+ loop !bytes !li !cumw+ -- if we've gone past the last byte+ | bytes >= len' = li-1+ -- if we hit our target+ | cumw + w > n' = li+ -- advance one character+ | otherwise = loop (bytes+byteWidth) (li+1) (cumw + w)+ where Iter c byteWidth = iter t' bytes+ w = charWidth c -- | Takes the given number of columns of characters. For example --@@ -343,7 +354,7 @@ loop (x:xs) cumw out = r where newWidth = textWidth x + cumw r = if newWidth > maxWidth- then if isSpace $ T.index x (toLogicalIndex (maxWidth - cumw) x)+ then if isSpace $ T.index x (characterIndexFromWidth (maxWidth - cumw) x) -- if line runs over but character of splitting is whitespace then split on the whitespace then let (t1,t2) = splitAtWidth (maxWidth - cumw) x in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True@@ -355,7 +366,19 @@ else loop (x:xs) 0 [] <> modifyOutForNewLine out else loop xs newWidth $ appendOut out x False -+-- | Calculate the offset that will result in rendered text being aligned left,+-- right, or center+alignmentOffset+ :: TextAlignment+ -> Int+ -> Text+ -> Int+alignmentOffset alignment maxWidth t = case alignment of+ TextAlignment_Left -> 0+ TextAlignment_Right -> (maxWidth - l)+ TextAlignment_Center -> (maxWidth - l) `div` 2+ where+ l = textWidth t -- | 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@@ -368,25 +391,22 @@ -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line) wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = [] wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where- -- we pad by offset amount with any non-space character which we will remove later so that no changes need to be made to splitWordsAtDisplayWidth- r' = splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)- fmapfn (t,b) = case alignment of- TextAlignment_Left -> WrappedLine t b 0- TextAlignment_Right -> WrappedLine t b (maxWidth-l)- TextAlignment_Center -> WrappedLine t b ((maxWidth-l) `div` 2)- where l = textWidth t+ r' = if T.null txt+ then [("",False)]+ -- I'm not sure why this is working, the "." padding will mess up splitWordsAtDisplayWidth for the next line if a single line exceeds the display width (but it doesn't)+ -- it should be `T.replicate n " "` instead (which also works but makes an extra "" Wrappedline somewhere)+ else splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)+ fmapfn (t,b) = WrappedLine t b $ alignmentOffset alignment maxWidth t r'' = case r' of [] -> [] (x,b):xs -> (T.drop n x,b):xs r = fmap fmapfn r'' --- converts deleted eol spaces into logical lines+-- | converts deleted eol spaces into logical lines eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]-eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b))--offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment-offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines+eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . ((L.groupBy (\(WrappedLine _ b _) _ -> not b)) =<<) +-- | Convert logical lines to a map of displayed rows of aligned text offsetMapWithAlignment :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines -> OffsetMapWithAlignment@@ -403,6 +423,9 @@ -- add additional offset to last line in wrapped lines (for newline char) return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps +-- | Convert logical lines to a map of displayed rows of aligned text+offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment+offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines -- | Given a width and a 'TextZipper', produce a list of display lines -- (i.e., lines of wrapped text) with special attributes applied to@@ -417,7 +440,8 @@ -> TextZipper -- ^ The text input contents and cursor state -> DisplayLines tag displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =- let linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line+ let+ linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la@@ -437,75 +461,61 @@ -- * spans that are on earlier display lines (though on the same logical line), and -- * spans that are on the same display line - (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $- initLast $ map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width 0 b)- -- Calculate the number of columns on the cursor's display line before the cursor- curLineOffset = spansWidth spansCurLineBefore- -- Check whether the spans on the current display line are long enough that- -- the cursor has to go to the next line- cursorAfterEOL = curLineOffset == width- cursorCharWidth = case T.uncons a of- Nothing -> 1- Just (c, _) -> charWidth c+ -- do the current line+ curlinetext = b <> a+ curwrappedlines = (wrapWithOffsetAndAlignment alignment width 0 curlinetext)+ blength = T.length b - -- Separate the span after the cursor into- -- * spans that are on the same display line, and- -- * spans that are on later display lines (though on the same logical line)+ -- map to spans and highlight the cursor+ -- accumulator type (accumulated text length, Either (current y position) (cursor y and x position))+ --mapaccumlfn :: (Int, Either Int (Int, Int)) -> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag])+ mapaccumlfn (acclength, ecpos') (WrappedLine t dwseol xoff) = r where+ tlength = T.length t+ -- how many words we've gone through+ nextacclength = acclength + tlength + if dwseol then 1 else 0+ nextacc = (nextacclength, nextecpos)+ cursoroncurspan = nextacclength >= blength && (blength >= acclength)+ charsbeforecursor = blength-acclength+ ctlength = textWidth $ T.take charsbeforecursor t+ cursorx = xoff + ctlength+ nextecpos = case ecpos' of+ Left y -> if cursoroncurspan+ then if ctlength == width+ -- cursor wraps to next line case+ then Right (y+1, 0)+ else Right (y, cursorx)+ else Left (y+1)+ Right x -> Right x - (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $- headTail $ case T.uncons a of- Nothing -> [[Span cursorTag " "]]- Just (c, rest) ->- let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth- cursor = Span cursorTag (T.singleton c)- in case map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width o rest) of- [] -> [[cursor]]- (l:ls) -> (cursor : l) : ls+ beforecursor = T.take charsbeforecursor t+ cursortext = T.take 1 $ T.drop charsbeforecursor t+ aftercursor = T.drop (charsbeforecursor+1) t - curLineSpanNormalCase = if cursorAfterEOL- then [ spansCurLineBefore, spansCurLineAfter ]- else [ spansCurLineBefore <> spansCurLineAfter ]+ cursorspans = [Span tag beforecursor, Span cursorTag cursortext] <> if T.null aftercursor then [] else [Span tag aftercursor] - -- for right alignment, we want draw the cursor tag to be on the character just before the logical cursor position- curLineSpan = if alignment == TextAlignment_Right && not cursorAfterEOL- then case reverse spansCurLineBefore of- [] -> curLineSpanNormalCase- (Span _ x):xs -> case spansCurLineAfter of- [] -> error "should not be possible" -- curLineSpanNormalCase- (Span _ y):ys -> [reverse (Span cursorTag x:xs) <> ((Span tag y):ys)]- else curLineSpanNormalCase+ r = if cursoroncurspan+ then (nextacc, cursorspans)+ else (nextacc, [Span tag t])+ ((_, ecpos), curlinespans) = if T.null curlinetext+ -- manually handle empty case because mapaccumlfn doesn't handle it+ then ((0, Right (0, alignmentOffset alignment width "")), [[Span tag ""]])+ else L.mapAccumL mapaccumlfn (0, Left 0) curwrappedlines - cursorY = sum- [ length spansBefore- , length spansCurrentBefore- , if cursorAfterEOL then 1 else 0- ]- -- a little silly to convert back to text but whatever, it works- cursorX = if cursorAfterEOL then 0 else textWidth (mconcat $ fmap (\(Span _ t) -> t) spansCurLineBefore)+ (cursorY', cursorX) = case ecpos of+ Right (y,x) -> (y,x)+ -- if we never hit the cursor position, this means it's at the beginning of the next line+ Left y -> (y+1, alignmentOffset alignment width "")+ cursorY = cursorY' + length spansBefore in DisplayLines { _displayLines_spans = concat [ spansBefore- , spansCurrentBefore- , curLineSpan- , spansCurrentAfter+ , curlinespans , spansAfter ] , _displayLines_offsetMap = offsets , _displayLines_cursorPos = (cursorX, cursorY) }- where- initLast :: [a] -> Maybe ([a], a)- initLast = \case- [] -> Nothing- (x:xs) -> case initLast xs of- Nothing -> Just ([], x)- Just (ys, y) -> Just (x:ys, y)- headTail :: [a] -> Maybe (a, [a])- headTail = \case- [] -> Nothing- x:xs -> Just (x, xs)- -- | Move the cursor of the given 'TextZipper' to the logical position indicated -- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment'
src/Reflex/Vty.hs view
@@ -17,6 +17,7 @@ , module Reflex.Vty.Widget.Box , module Reflex.Vty.Widget.Input , module Reflex.Vty.Widget.Layout+ , module Reflex.Vty.Widget.Scroll , module Reflex.Vty.Widget.Split , module Reflex.Vty.Widget.Text , module Control.Monad.NodeId@@ -28,6 +29,7 @@ import Reflex.Vty.Widget.Box import Reflex.Vty.Widget.Input import Reflex.Vty.Widget.Layout+import Reflex.Vty.Widget.Scroll import Reflex.Vty.Widget.Split import Reflex.Vty.Widget.Text
src/Reflex/Vty/Widget.hs view
@@ -232,7 +232,7 @@ return $ case e of V.EvKey _ _ | not focused -> Nothing V.EvMouseDown x y btn m ->- if tracking == Tracking btn || (tracking == WaitingForInput && isWithin reg' x y)+ if tracking == Tracking btn || (tracking == WaitingForInput && withinRegion reg' x y) then Just (Tracking btn, Just $ V.EvMouseDown (x - l) (y - t) btn m) else Just (NotTracking, Nothing) V.EvMouseUp x y mbtn -> case mbtn of@@ -268,11 +268,20 @@ regionSize :: Region -> (Int, Int) regionSize (Region _ _ w h) = (w, h) -isWithin :: Region -> Int -> Int -> Bool-isWithin (Region l t w h) x y = not . or $ [ x < l- , y < t- , x >= l + w- , y >= t + h ]+-- | Check whether the x,y coordinates are within the specified region+withinRegion+ :: Region+ -> Int+ -- ^ x-coordinate+ -> Int+ -- ^ y-coordinate+ -> Bool+withinRegion (Region l t w h) x y = not . or $+ [ x < l+ , y < t+ , x >= l + w+ , y >= t + h+ ] -- | Produces an 'Image' that fills a region with space characters regionBlankImage :: V.Attr -> Region -> Image@@ -579,9 +588,9 @@ -- that the child widget receives such that: -- * unfocused widgets receive no key events -- * mouse inputs inside the region have their coordinates translated such+-- that (0,0) is the top-left corner of the region -- * mouse drag sequences that start OFF the region are ignored -- * mouse drag sequences that start ON the region and drag off are NOT ignored--- that (0,0) is the top-left corner of the region pane :: (MonadFix m, MonadHold t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m) => Dynamic t Region
src/Reflex/Vty/Widget/Box.hs view
@@ -79,7 +79,7 @@ sides = [ withinImage (Region (left + 1) top (width - 2) 1) $ V.text' attr $- hPadText title' (_boxStyle_n style) (width - 2)+ centerText title' (_boxStyle_n style) (width - 2) , withinImage (Region right (top + 1) 1 (height - 2)) $ V.charFill attr (_boxStyle_e style) 1 (height - 2) , withinImage (Region (left + 1) bottom (width - 2) 1) $@@ -98,16 +98,23 @@ V.char attr (_boxStyle_sw style) ] in sides ++ if width > 1 && height > 1 then corners else []- hPadText :: T.Text -> Char -> Int -> T.Text- hPadText t c l = if lt >= l- then t- else left <> t <> right- where- lt = T.length t- delta = l - lt- mkHalf n = T.replicate (n `div` 2) (T.singleton c)- left = mkHalf $ delta + 1- right = mkHalf delta++-- | Pad text on the left and right with the given character so that it is+-- centered+centerText+ :: T.Text -- ^ Text to center+ -> Char -- ^ Padding character+ -> Int -- ^ Width+ -> T.Text -- ^ Padded text+centerText t c l = if lt >= l+ then t+ else left <> t <> right+ where+ lt = T.length t+ delta = l - lt+ mkHalf n = T.replicate (n `div` 2) (T.singleton c)+ left = mkHalf $ delta + 1+ right = mkHalf delta -- | A box without a title box :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
src/Reflex/Vty/Widget/Input.hs view
@@ -161,3 +161,11 @@ where combineStyles :: V.Attr -> [V.Style] -> V.Attr combineStyles x xs = foldl' V.withStyle x xs++-- | The ctrl-c keypress event+ctrlc :: (Monad m, HasInput t m, Reflex t) => m (Event t ())+ctrlc = do+ inp <- input+ return $ fforMaybe inp $ \case+ V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()+ _ -> Nothing
src/Reflex/Vty/Widget/Layout.hs view
@@ -9,7 +9,6 @@ import Control.Applicative (liftA2) import Control.Monad.Morph import Control.Monad.NodeId (MonadNodeId(..), NodeId)-import Control.Monad import Control.Monad.Fix import Control.Monad.Reader import Data.List (mapAccumL)
+ src/Reflex/Vty/Widget/Scroll.hs view
@@ -0,0 +1,110 @@+{-| Description: Widgets that scroll when their contents don't fit+-}+module Reflex.Vty.Widget.Scroll where++import Control.Monad.Fix+import Data.Default+import qualified Graphics.Vty as V+import Reflex+import Reflex.Vty.Widget+import Reflex.Vty.Widget.Input.Mouse++-- | Configuration options for automatic scroll-to-bottom behavior+data ScrollToBottom+ = ScrollToBottom_Always+ -- ^ Always scroll to the bottom on new output+ | ScrollToBottom_Maintain+ -- ^ Scroll down with new output only when, prior to the new output being+ -- added, the widget was scrolled all the way to the bottom.+ deriving (Eq, Ord, Show)++-- | Configuration for the scrollable element. Controls scroll behavior.+data ScrollableConfig t = ScrollableConfig+ { _scrollableConfig_scrollBy :: Event t Int+ -- ^ Number of lines to scroll by+ , _scrollableConfig_scrollTo :: Event t ScrollPos+ -- ^ Specific position to scroll to+ , _scrollableConfig_startingPosition :: ScrollPos+ -- ^ The initial scroll position+ , _scrollableConfig_scrollToBottom :: Behavior t (Maybe ScrollToBottom)+ -- ^ How the scroll position should be adjusted as new content is added+ }++instance Reflex t => Default (ScrollableConfig t) where+ def = ScrollableConfig never never ScrollPos_Top (pure Nothing)++-- | The scroll position+data ScrollPos = ScrollPos_Top | ScrollPos_Line Int | ScrollPos_Bottom+ deriving (Show, Eq, Ord)++-- | The output of a 'scrollable', indicating its current scroll position.+data Scrollable t = Scrollable+ { _scrollable_scrollPosition :: Behavior t ScrollPos+ , _scrollable_totalLines :: Behavior t Int+ , _scrollable_scrollHeight :: Behavior t Int+ }++-- | Scrollable widget. The output exposes the current scroll position and+-- total number of lines (including those that are hidden)+scrollable+ :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)+ => ScrollableConfig t+ -> (m (Behavior t V.Image, Event t ()))+ -> m (Scrollable t)+scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend) mkImg = do+ (img, update) <- mkImg+ let sz = V.imageHeight <$> img+ kup <- key V.KUp+ kdown <- key V.KDown+ m <- mouseScroll+ let requestedScroll :: Event t Int+ requestedScroll = leftmost+ [ 1 <$ kdown+ , (-1) <$ kup+ , ffor m $ \case+ ScrollDirection_Up -> (-1)+ ScrollDirection_Down -> 1+ , scrollBy+ ]+ dh <- displayHeight+ lineIndex <- foldDynMaybe ($) startingPos $ leftmost+ [ (\((totalLines, h), d) sp -> Just $ scrollByLines sp totalLines h d) <$> attach ((,) <$> sz <*> current dh) requestedScroll+ , (\((totalLines, h), newScrollPosition) _ -> Just $ case newScrollPosition of+ ScrollPos_Line n -> scrollToLine totalLines h n+ ScrollPos_Top -> ScrollPos_Top+ ScrollPos_Bottom -> ScrollPos_Bottom+ ) <$> attach ((,) <$> sz <*> current dh) scrollTo+ , (\cfg sp -> case cfg of+ Just ScrollToBottom_Always -> case sp of+ ScrollPos_Bottom -> Nothing+ _ -> Just ScrollPos_Bottom+ _ -> Nothing) <$> tag onAppend update+ ]+ let imgsToTell height scrollPos totalLines images = case scrollPos of+ ScrollPos_Bottom -> V.translateY ((-1) * max 0 (totalLines - height)) images+ ScrollPos_Top -> images -- take height images+ ScrollPos_Line n -> V.translateY ((-1) * n) images+ tellImages $ fmap (:[]) $ imgsToTell <$> current dh <*> current lineIndex <*> sz <*> img+ return $ Scrollable+ { _scrollable_scrollPosition = current lineIndex+ , _scrollable_totalLines = sz+ , _scrollable_scrollHeight = current dh+ }++-- | Modify the scroll position by the given number of lines+scrollByLines :: ScrollPos -> Int -> Int -> Int -> ScrollPos+scrollByLines sp totalLines height delta =+ let newPos = min (max 0 (start sp + delta)) totalLines+ in scrollToLine totalLines height newPos+ where+ start ScrollPos_Top = 0+ start ScrollPos_Bottom = totalLines - height+ start (ScrollPos_Line n) = n++-- | Scroll to a particular line+scrollToLine :: Int -> Int -> Int -> ScrollPos+scrollToLine totalLines height newPos = if+ | totalLines <= height -> ScrollPos_Top+ | newPos == 0 -> ScrollPos_Top+ | newPos + height >= totalLines -> ScrollPos_Bottom+ | otherwise -> ScrollPos_Line newPos
src/Reflex/Vty/Widget/Text.hs view
@@ -11,7 +11,7 @@ import qualified Graphics.Vty as V import Reflex import Reflex.Vty.Widget-import Reflex.Vty.Widget.Input.Mouse+import Reflex.Vty.Widget.Scroll -- | Fill the background with a particular character. fill :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) => Behavior t Char -> m ()@@ -64,39 +64,6 @@ bt <- theme richText (RichTextConfig bt) t --- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those--- that are hidden)-scrollableText- :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)- => Event t Int- -- ^ Number of lines to scroll by- -> Behavior t Text- -> m (Behavior t (Int, Int))- -- ^ (Current scroll position, total number of lines)-scrollableText scrollBy t = do- dw <- displayWidth- bt <- theme- let imgs = wrap <$> bt <*> current dw <*> t- kup <- key V.KUp- kdown <- key V.KDown- m <- mouseScroll- let requestedScroll :: Event t Int- requestedScroll = leftmost- [ 1 <$ kdown- , (-1) <$ kup- , ffor m $ \case- ScrollDirection_Up -> (-1)- ScrollDirection_Down -> 1- , scrollBy- ]- updateLine maxN delta ix = min (max 0 (ix + delta)) maxN- lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $- attach (length <$> imgs) requestedScroll- tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs- return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)- where- wrap attr maxWidth = concatMap (fmap (V.string attr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')- -- | Renders any behavior whose value can be converted to -- 'String' as text display@@ -104,3 +71,15 @@ => Behavior t a -> m () display a = text $ T.pack . show <$> a++-- | Scrollable text widget. The output exposes the current scroll position and+-- total number of lines (including those that are hidden)+scrollableText+ :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m, PostBuild t m)+ => ScrollableConfig t+ -> Dynamic t Text+ -> m (Scrollable t)+scrollableText cfg t = do+ scrollable cfg $ do+ ((), images) <- runImageWriter $ text (current t)+ pure $ (V.vertCat <$> images, () <$ updated t)
test/Data/Text/ZipperSpec.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Data.Text.ZipperSpec(+module Data.Text.ZipperSpec ( spec ) where @@ -14,9 +14,12 @@ import Data.Text.Zipper -+someSentence :: T.Text someSentence = "12345 1234 12" +newlineSentence :: T.Text+newlineSentence = "\n\n\n\n\n"+ splitSentenceAtDisplayWidth :: Int -> T.Text -> [(T.Text, Bool)] splitSentenceAtDisplayWidth w t = splitWordsAtDisplayWidth w (wordsWithWhitespace t) @@ -41,8 +44,6 @@ wrapWithOffsetAndAlignment TextAlignment_Center 5 0 someSentence `shouldBe` [(WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 1)] wrapWithOffsetAndAlignment TextAlignment_Left 5 1 someSentence `shouldBe` [(WrappedLine "1234" False 0), (WrappedLine "5" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)] - -- leading spaces and offset case- wrapWithOffsetAndAlignment TextAlignment_Left 5 1 (" " <> someSentence) `shouldBe` [(WrappedLine " " True 0), (WrappedLine "12345" True 0), (WrappedLine "1234" True 0), (WrappedLine "12" False 0)] it "eolSpacesToLogicalLines" $ do eolSpacesToLogicalLines [@@ -72,15 +73,38 @@ , (4, (2,8)) -- jump by 2 for char and 1 for space , (5, (3,11)) -- jump by 2 for char and 1 for space ]+ it "displayLinesWithAlignment - spans" $ do+ let+ makespans = fmap (fmap (Span ()))+ insertcharnewlinesentence = insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ insertChar '\n' $ fromText ""+ cursorspan = [[Span () " "]]+ -- newline cases+ dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText newlineSentence)+ dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\naoeu")+ dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "\n\n\naoeu")+ dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n\n\n")++ insertcharnewlinesentence `shouldBe` fromText newlineSentence++ -- NOTE last " " is the generated cursor span char+ _displayLines_spans dl0 `shouldBe` makespans [[""],[""],[""],[""],[""],[""]]+ _displayLines_spans dl1 `shouldBe` makespans [["aoeu"],[""],[""],["aoeu", ""]]+ _displayLines_spans dl2 `shouldBe` makespans [[""],[""],[""],["aoeu", ""]]+ _displayLines_spans dl3 `shouldBe` makespans [["aoeu"],[""],[""],[""]]+++ it "displayLines - cursorPos" $ do let- dl0 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "")- dl1 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu")- dl2 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "aoeu\n")- dl3 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "0123456789")- dl4 = displayLinesWithAlignment TextAlignment_Right 10 () () (insertChar 'a' $ fromText "aoeu")- dl5 = displayLinesWithAlignment TextAlignment_Right 10 () () (left $ insertChar 'a' $ fromText "aoeu")- dl6 = displayLinesWithAlignment TextAlignment_Right 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu")+ dl0 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "")+ dl1 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu")+ dl2 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "aoeu\n")+ dl3 = displayLinesWithAlignment TextAlignment_Left 10 () () (fromText "0123456789")+ dl4 = displayLinesWithAlignment TextAlignment_Left 10 () () (insertChar 'a' $ fromText "aoeu")+ dl5 = displayLinesWithAlignment TextAlignment_Left 10 () () (left $ insertChar 'a' $ fromText "aoeu")+ dl6 = displayLinesWithAlignment TextAlignment_Left 10 () () (deleteLeft $ insertChar 'a' $ fromText "aoeu")+ dl7 = displayLinesWithAlignment TextAlignment_Right 10 () () (fromText "")+ _displayLines_cursorPos dl0 `shouldBe` (0,0) _displayLines_cursorPos dl1 `shouldBe` (4,0) _displayLines_cursorPos dl2 `shouldBe` (0,1)@@ -88,15 +112,12 @@ _displayLines_cursorPos dl4 `shouldBe` (5,0) _displayLines_cursorPos dl5 `shouldBe` (4,0) _displayLines_cursorPos dl6 `shouldBe` (4,0)- it "displayLines - offsetMap" $ do- let- dl0 = displayLinesWithAlignment TextAlignment_Left 5 () () (end $ fromText "aoeku")- _displayLines_cursorPos dl0 `shouldBe` (0,1)- Map.size (_displayLines_offsetMap dl0) `shouldBe` 2 -- cursor character is on second line+ _displayLines_cursorPos dl7 `shouldBe` (10,0) it "displayLinesWithAlignment - spans" $ do let someText = top $ fromText "0123456789abcdefgh" -- outer span length should be invariant when changing TextAlignment and CursorPosition+ --print $ displayLinesWithAlignment TextAlignment_Left 5 () () someText forM_ [0..4] $ \x -> do forM_ [TextAlignment_Left, TextAlignment_Center, TextAlignment_Right] $ \ta -> do let t = rightN x $ someText