diff --git a/doc/ch4/FormattedText.tex b/doc/ch4/FormattedText.tex --- a/doc/ch4/FormattedText.tex +++ b/doc/ch4/FormattedText.tex @@ -14,6 +14,47 @@ ui <- (return t1) <++> (return t2) \end{haskellcode} +\subsection{Updating Text Widgets} +\label{sec:updatingText} + +The contents of a text widget can be set in one of three ways: +\begin{itemize} +\item Initially, as a parameter to \fw{plainText} and \fw{textWidget} +\item As a \fw{String} parameter to \fw{setText} +\item As a list parameter of \fw{(String, Attr)} with + \fw{setTextWithAttrs} +\end{itemize} + +All text widget update functions \textit{tokenize} their inputs, +finding contiguous sequences of whitespace and non-whitespace +characters and newlines, and store the list of tokens in the widget. +Each token is assigned a default attribute of \fw{def\_attr}, which +defaults to the ``normal'' attribute of the widget (see Section +\ref{sec:attributes} for more information on attributes). + +The \fw{setText} function merely takes a \fw{String}, tokenizes it, +and assigns the default attribute to all tokens. + +The \fw{setTextWithAttrs} function provides finer control over the +initial attribute assignment to the text because it lets you specify +the initial contents of the widget with your own attribute +assignments. This can be done instead of (or in addition to) the use +of formatters for maximum control over the final visual representation +of the text. + +In the following example, we create a text widget and then assign it a +string with different attributes for each of the words: + +\begin{haskellcode} + t <- plainText "" + setTextWithAttrs t [ ("foo", fgColor green) + , (" ", def_attr) + , ("bar", fgColor yellow) + , (" ", def_attr) + , ("baz", red `on` blue) + ] +\end{haskellcode} + \subsection{Formatters} In addition to rendering plain text strings, we can use ``formatters'' @@ -25,32 +66,37 @@ constructor function, \fw{text\-Widget}: \begin{haskellcode} - t <- textWidget "foobar" wrap + t <- textWidget wrap "foobar" \end{haskellcode} -When formatters are applied, the text is automatically broken up into -``tokens,'' each of which indicates sequences of whitespace or -non-whitespace characters. Each token stores its own attribute and it -is these tokens on which formatters operate. +When a text widget's contents are updated, the text is automatically +broken up into tokens (see Section \ref{sec:updatingText}). It is +these tokens on which formatters operate. The \fw{Text} module provides two formatters: \fw{wrap} and \fw{highlight}. \fw{wrap} wraps the text to fit into the -\fw{DisplayRegion} available at rendering time. \fw{highlight} uses -the \fw{pcre-light}\footnote{\fw{pcre-light} on Hackage: - \href{http://hackage.haskell.org/package/pcre-light-0.3.1.1}{http://hackage.haskell.org/package/pcre-light-0.3.1.1}} -library to highlight text using ``Perl-compatible'' regular -expressions. To construct a highlighting formatter, we must provide -the regular expression used to match strings as well as the attribute -that should be applied to the matches:\footnote{Since +\fw{DisplayRegion} available at rendering time, so this will end up +doing the right thing depending on the parent widget of the +\fw{FormattedText} widget. \fw{highlight} accepts a regular +expression\footnote{Any instance of \fw{RegexLike} is acceptable.} to +match text for highlighting. To construct a highlighting formatter, +we must provide the regular expression used to match strings as well +as the attribute that should be applied to the matches:\footnote{Since formatters operate on individual tokens, the \fw{highlight} formatter applies its regular expression to each token individually, so it will only ever match sequences of characters in each token - rather than matching more than one token.} + rather than matching more than one token. You can certainly write + your own formatter that considers more than one token at a time, + though.} +Here is an example using \fw{highlight} with the \fw{Regex} type from +the \fw{regex-pcre} package: + \begin{haskellcode} - let doHighlight = highlight (compile (pack "bar") []) - (fgColor bright_green) - t <- textWidget "Foo bar baz" doHighlight + let doHighlight sz t = do + Right r <- compile compUngreedy execBlank "<.*>" + highlight r (fgColor bright_green) sz t + t <- textWidget doHighlight "foo baz" \end{haskellcode} Formatters can be composed with the \fw{\&.\&} operator. This @@ -59,8 +105,11 @@ compose the built-in formatters on a single \fw{FormattedText} widget: \begin{haskellcode} - t <- textWidget "Foo bar baz" (doHighlight &.& wrap) + t <- textWidget (doHighlight &.& wrap) "Foo baz" \end{haskellcode} + +For detailed information on the token types on which the formatters +operate, see the \fw{Text.Trans.Tokenize} module. \subsubsection{Growth Policy} diff --git a/doc/macros.tex b/doc/macros.tex --- a/doc/macros.tex +++ b/doc/macros.tex @@ -1,6 +1,6 @@ % Custom macros. -\newcommand{\vtyuiversion}{1.1} +\newcommand{\vtyuiversion}{1.2} \newcommand{\fw}[1]{\texttt{#1}} \newcommand{\vtyui}{\fw{vty-ui}} diff --git a/src/ComplexDemo.hs b/src/ComplexDemo.hs --- a/src/ComplexDemo.hs +++ b/src/ComplexDemo.hs @@ -7,10 +7,10 @@ import Control.Concurrent import Data.Time.Clock import Data.Time.Format -import Text.Regex.PCRE.Light +import Text.Regex.PCRE +import Text.Regex.PCRE.String import Graphics.Vty import Graphics.Vty.Widgets.All -import qualified Data.ByteString.Char8 as BS8 -- Visual attributes. fg = white @@ -21,7 +21,9 @@ -- Formatter to apply a color to "<...>" color :: Formatter -color = highlight (compile (BS8.pack "<.*>") []) (fgColor bright_green) +color sz t = do + Right r <- compile compUngreedy execBlank "<.*>" + highlight r (fgColor bright_green) sz t -- Multi-state checkbox value type data FrostingType = Chocolate @@ -63,8 +65,8 @@ edit1 <- editWidget >>= withFocusAttribute (white `on` red) edit2 <- editWidget - edit1Header <- textWidget wrap "" >>= withNormalAttribute headerAttr - edit2Header <- textWidget wrap "" >>= withNormalAttribute headerAttr + edit1Header <- textWidget wrap [] >>= withNormalAttribute headerAttr + edit2Header <- textWidget wrap [] >>= withNormalAttribute headerAttr lst <- newList (fgColor bright_green) diff --git a/src/Graphics/Vty/Widgets/EventLoop.hs b/src/Graphics/Vty/Widgets/EventLoop.hs --- a/src/Graphics/Vty/Widgets/EventLoop.hs +++ b/src/Graphics/Vty/Widgets/EventLoop.hs @@ -16,7 +16,9 @@ import Data.IORef import Data.Typeable -import Control.Concurrent +import Control.Concurrent ( forkIO ) +import Control.Concurrent.STM ( atomically ) +import Control.Concurrent.STM.TChan import Control.Exception import Control.Monad import System.IO.Unsafe ( unsafePerformIO ) @@ -29,9 +31,9 @@ data UserEvent = ScheduledAction (IO ()) -eventChan :: Chan CombinedEvent +eventChan :: TChan CombinedEvent {-# NOINLINE eventChan #-} -eventChan = unsafePerformIO newChan +eventChan = unsafePerformIO newTChanIO -- |Run the main vty-ui event loop using the specified interface -- collection and initial rendering context. The rendering context @@ -49,24 +51,24 @@ reserve_display $ terminal vty shutdown vty -vtyEventListener :: Vty -> Chan CombinedEvent -> IO () +vtyEventListener :: Vty -> TChan CombinedEvent -> IO () vtyEventListener vty chan = forever $ do e <- next_event vty - writeChan chan $ VTYEvent e + atomically $ writeTChan chan $ VTYEvent e -- |Schedule a widget-mutating 'IO' action to be run by the main event -- loop. Use of this function is required to guarantee consistency -- between interface presentation and internal state. schedule :: IO () -> IO () -schedule act = writeChan eventChan $ UserEvent $ ScheduledAction act +schedule act = atomically $ writeTChan eventChan $ UserEvent $ ScheduledAction act -- |Schedule a vty-ui event loop shutdown. This event will preempt -- others so that it will be processed next. shutdownUi :: IO () -shutdownUi = unGetChan eventChan ShutdownUi +shutdownUi = atomically $ unGetTChan eventChan ShutdownUi -runUi' :: Vty -> Chan CombinedEvent -> Collection -> RenderContext -> IO () +runUi' :: Vty -> TChan CombinedEvent -> Collection -> RenderContext -> IO () runUi' vty chan collection ctx = do sz <- display_bounds $ terminal vty @@ -83,7 +85,7 @@ set_cursor_pos (terminal vty) w h Nothing -> hide_cursor $ terminal vty - evt <- readChan chan + evt <- atomically $ readTChan chan cont <- case evt of VTYEvent (EvKey k mods) -> handleKeyEvent fg k mods >> return True diff --git a/src/Graphics/Vty/Widgets/List.hs b/src/Graphics/Vty/Widgets/List.hs --- a/src/Graphics/Vty/Widgets/List.hs +++ b/src/Graphics/Vty/Widgets/List.hs @@ -102,7 +102,6 @@ , itemRemoveHandlers :: Handlers (RemoveItemEvent a b) , itemActivateHandlers :: Handlers (ActivateItemEvent a b) , itemHeight :: Int - -- ^Function to construct new items } instance Show (List a b) where @@ -216,6 +215,8 @@ numItems <- (length . listItems) <~~ list insertIntoList list key w numItems +-- |Insert an element into the list at the specified position. If the +-- position exceeds the length of the list, it is inserted at the end. insertIntoList :: (Show b) => Widget (List a b) -> a -> Widget b -> Int -> IO () insertIntoList list key w pos = do numItems <- (length . listItems) <~~ list diff --git a/src/Graphics/Vty/Widgets/Text.hs b/src/Graphics/Vty/Widgets/Text.hs --- a/src/Graphics/Vty/Widgets/Text.hs +++ b/src/Graphics/Vty/Widgets/Text.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} -- |This module provides functionality for rendering 'String's as -- 'Widget's, including functionality to make structural and/or visual -- changes at rendering time. To get started, turn your ordinary --- 'String' into a 'Widget' with 'plainText'; if you want access to --- the 'Text' for formatting purposes, use 'textWidget'. +-- 'String' into a 'Widget' with 'plainText'; for more control, use +-- 'textWidget'. module Graphics.Vty.Widgets.Text - ( Text(tokens) - , FormattedText - , Formatter - , setText - , prepareText - -- *Constructing Widgets + ( FormattedText + -- *Constructing Text Widgets , plainText , textWidget + -- *Setting Widget Contents + , setText + , setTextWithAttrs -- *Formatting + , Formatter , (&.&) , highlight , nullFormatter @@ -21,38 +21,32 @@ ) where -import Data.Maybe import Data.Word import Graphics.Vty import Graphics.Vty.Widgets.Core import Text.Trans.Tokenize -import Text.Regex.PCRE.Light.Char8 +import Text.Regex.Base import Graphics.Vty.Widgets.Util --- |A formatter makes changes to text at rendering time. --- --- It'd be nice if formatters were just @:: 'Text' -> 'Text'@, but --- some formatting use cases involve knowing the size of the rendering +-- |A formatter makes changes to text at rendering time. Some +-- formatting use cases involve knowing the size of the rendering -- area, which is not known until render time (e.g., text wrapping). --- Thus, a formatter takes a 'DisplayRegion' and runs at render time. -type Formatter = DisplayRegion -> Text -> Text +-- Thus, a formatter takes a 'DisplayRegion' which indicates the size +-- of screen area available for formatting. +type Formatter = DisplayRegion -> TextStream Attr -> IO (TextStream Attr) -- |Formatter composition: @a &.& b@ applies @a@ followed by @b@. (&.&) :: Formatter -> Formatter -> Formatter -f1 &.& f2 = \sz -> f2 sz . f1 sz +f1 &.& f2 = \sz t -> f1 sz t >>= f2 sz +-- |The null formatter which has no effect on text streams. nullFormatter :: Formatter -nullFormatter = const id - --- |'Text' represents a 'String' that can be manipulated with --- 'Formatter's at rendering time. -data Text = Text { tokens :: [[Token Attr]] - -- ^The tokens of the underlying text stream. - } - deriving (Show) +nullFormatter = \_ t -> return t +-- |The type of formatted text widget state. Stores the text itself +-- and the formatter used to apply attributes to the text. data FormattedText = - FormattedText { text :: Text + FormattedText { text :: TextStream Attr , formatter :: Formatter } @@ -62,50 +56,51 @@ , ", formatter = ... }" ] --- |Prepare a string for rendering. -prepareText :: String -> Text -prepareText s = Text { tokens = tokenize s def_attr - } - -- |Construct a Widget directly from a String. This is recommended if -- you don't need to use a 'Formatter'. plainText :: String -> IO (Widget FormattedText) -plainText s = textWidget nullFormatter s +plainText = textWidget nullFormatter -- |A formatter for wrapping text into the available space. This -- formatter will insert line breaks where appropriate so if you want -- to use other structure-sensitive formatters, run this formatter -- last. wrap :: Formatter -wrap sz t = t { tokens = newTokens } - where - doWrapping l = if null l then [[]] else wrapLine width l - newTokens = concatMap doWrapping $ tokens t - width = fromEnum $ region_width sz +wrap sz ts = do + let width = fromEnum $ region_width sz + return $ wrapStream width ts -- |A highlight formatter takes a regular expression used to scan the --- text and an attribute to assign to matches. Highlighters only scan --- non-whitespace tokens in the text stream. -highlight :: Regex -> Attr -> Formatter +-- text and an attribute to assign to matches. The regular expression +-- is only applied to individual string tokens (individual words, +-- whitespace strings, etc.); it is NOT applied to whole lines, +-- paragraphs, or text spanning multiple lines. If you have need of +-- that kind of functionality, apply your own attributes with your own +-- regular expression prior to calling 'setTextWithAttrs'. +highlight :: (RegexLike r String) => r -> Attr -> Formatter highlight regex attr = - \_ t -> t { tokens = map (map (annotate (matchesRegex regex) attr)) $ tokens t } - --- |Possibly annotate a token with the specified annotation value if --- the predicate matches; otherwise, return the input token unchanged. -annotate :: (Token a -> Bool) -> a -> Token a -> Token a -annotate f ann t = if f t then t `withAnnotation` ann else t + \_ (TS ts) -> return $ TS $ map highlightToken ts + where + highlightToken :: TextStreamEntity Attr -> TextStreamEntity Attr + highlightToken NL = NL + highlightToken (T t) = + if tokenAttr t /= def_attr + then T t + else T (highlightToken' t) --- |Does the specified regex match the token's string value? -matchesRegex :: Regex -> Token a -> Bool -matchesRegex r t = isJust $ match r (tokenString t) [exec_anchored] + highlightToken' :: Token Attr -> Token Attr + highlightToken' t = + if null $ matchAll regex $ tokenStr t + then t + else t { tokenAttr = attr } --- |Construct a text widget formatted with the specified formatters. --- the formatters will be applied in the order given here, so be aware --- of how the formatters will modify the text (and affect each other). +-- |Construct a text widget formatted with the specified formatters +-- and initial content. The formatters will be applied in the order +-- given here (and, depending on the formatter, order might matter). textWidget :: Formatter -> String -> IO (Widget FormattedText) textWidget format s = do wRef <- newWidget $ \w -> - w { state = FormattedText { text = prepareText s + w { state = FormattedText { text = TS [] , formatter = format } , getCursorPosition_ = const $ return Nothing @@ -113,41 +108,62 @@ \this size ctx -> do ft <- getState this f <- focused <~ this - return $ renderText (text ft) f (formatter ft) size ctx + renderText (text ft) f (formatter ft) size ctx } + setText wRef s return wRef --- |Set the text value of a 'FormattedText' widget. +-- |Set the text value of a 'FormattedText' widget. The specified +-- string will be 'tokenize'd. setText :: Widget FormattedText -> String -> IO () -setText wRef s = do +setText wRef s = setTextWithAttrs wRef [(s, def_attr)] + +-- |Set the text value of a 'FormattedText' widget directly, in case +-- you have done formatting elsewhere and already have text with +-- attributes. The specified strings will each be 'tokenize'd, and +-- tokens resulting from each 'tokenize' operation will be given the +-- specified attribute in the tuple. +setTextWithAttrs :: Widget FormattedText -> [(String, Attr)] -> IO () +setTextWithAttrs wRef pairs = do + let streams = map (\(s, a) -> tokenize s a) pairs + ts = concat $ map streamEntities streams + updateWidgetState wRef $ \st -> - st { text = (prepareText s) } + st { text = TS ts } -- |Low-level text-rendering routine. -renderText :: Text -> Bool -> Formatter -> DisplayRegion -> RenderContext -> Image -renderText t foc format sz ctx = - if region_height sz == 0 - then nullImg - else if null ls || all null ls - then nullImg - else vert_cat $ take (fromEnum $ region_height sz) lineImgs - where - -- Truncate the tokens at the specified column and split them up - -- into lines - attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx +renderText :: TextStream Attr + -> Bool + -> Formatter + -> DisplayRegion + -> RenderContext + -> IO Image +renderText t foc format sz ctx = do + TS newText <- format sz t + + -- Truncate the tokens at the specified column and split them up + -- into lines + let attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx , normalAttr ctx ] - tokenAttr tok = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx - , tokenAnnotation tok + finalAttr tok = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx + , tokenAttr tok , normalAttr ctx ] lineImgs = map mkLineImg ls - ls = map truncateLine $ tokens newText - truncateLine = truncLine (fromEnum $ region_width sz) - newText = format sz t + ls = map truncLine $ map (map entityToken) $ findLines newText + truncLine = truncateLine (fromEnum $ region_width sz) mkLineImg line = if null line then char_fill attr' ' ' (region_width sz) (1::Word) else horiz_cat $ map mkTokenImg line nullImg = string def_attr "" - mkTokenImg tok = string (tokenAttr tok) (tokenString tok) + + mkTokenImg :: Token Attr -> Image + mkTokenImg tok = string (finalAttr tok) (tokenStr tok) + + return $ if region_height sz == 0 + then nullImg + else if null ls || all null ls + then nullImg + else vert_cat $ take (fromEnum $ region_height sz) lineImgs diff --git a/src/Text/Trans/Tokenize.hs b/src/Text/Trans/Tokenize.hs --- a/src/Text/Trans/Tokenize.hs +++ b/src/Text/Trans/Tokenize.hs @@ -1,141 +1,210 @@ {-# LANGUAGE CPP #-} --- |This module provides a tokenization API for text strings. The --- idea is that if you want to make structural or representational --- changes to a text stream, it needs to be split up into reasonable --- tokens first, with structural properties intact. This is --- accomplished by the 'Token' type. To get started, call 'tokenize' --- to turn your String into tokens; then you can use the other --- operations provided here to make structural or representational --- changes. To serialize a token list to its underlying string form, --- use 'serialize'. +-- |This module provides functionality for tokenizing text streams to +-- differentiate between printed characters and structural elements +-- such as newlines. Once tokenized, such text streams can be +-- manipulated with the functions in this module. module Text.Trans.Tokenize - ( tokenize + ( TextStream(..) + , TextStreamEntity(..) + , Token(..) + + -- * To and from strings + , tokenize , serialize - , withAnnotation - , truncLine - , isWhitespace - , wrapLine + + -- * Inspection + , tokenLen + , entityToken + , streamEntities + + -- * Manipulation + , truncateLine + , wrapStream + , findLines #ifdef TESTING - , Token(..) -#else - , Token - , tokenString - , tokenAnnotation + , isWhitespace + , partitions #endif ) where import Data.List ( inits - , intercalate ) --- |The type of textual tokens. Tokens have an "annotation" type, --- which is the type of values that can be used to annotate tokens --- (e.g., position in a file, visual attributes, etc.). -data Token a = Whitespace { tokenString :: String - , tokenAnnotation :: a - } - | Token { tokenString :: String - , tokenAnnotation :: a - } - deriving (Eq) +-- |The type of text tokens. These should consist of printable +-- characters and NOT presentation characters (e.g., newlines). Each +-- type of token should have as its contents a string of characters +-- all of the same type. Tokens are generalized over an attribute +-- type which can be used to annotate each token. +data Token a = S { tokenStr :: String + -- ^The token's string. + , tokenAttr :: a + -- ^The token's attribute. + } + -- ^Non-whitespace tokens. + | WS { tokenStr :: String + -- ^The token's string. + , tokenAttr :: a + -- ^The token's attribute. + } + -- ^Whitespace tokens. +-- |A text stream entity is either a token or a structural element. +data TextStreamEntity a = T (Token a) + -- ^Constructor for ordinary tokens. + | NL + -- ^Newline. + +-- |A text stream is a list of text stream entities. A text stream +-- |combines structural elements of the text (e.g., newlines) with the +-- |text itself (words, whitespace, etc.). +data TextStream a = TS [TextStreamEntity a] + +instance (Show a) => Show (TextStream a) where + show (TS ts) = "TS " ++ show ts + +instance (Show a) => Show (TextStreamEntity a) where + show (T t) = "T " ++ show t + show NL = "NL" + instance (Show a) => Show (Token a) where - show (Whitespace s _) = "{" ++ s ++ "}" - show (Token s _) = "<" ++ s ++ ">" + show (S s a) = "S " ++ show s ++ " " ++ show a + show (WS s a) = "WS " ++ show s ++ " " ++ show a --- |General splitter function; given a list and a predicate, split the --- list into sublists wherever the predicate matches, discarding the --- matching elements. -splitWith :: (Eq a) => [a] -> (a -> Bool) -> [[a]] -splitWith [] _ = [] -splitWith es f = if null rest - then [first] - else if length rest == 1 && (f $ head rest) - then first : [[]] - else first : splitWith (tail rest) f - where - (first, rest) = break f es +instance (Eq a) => Eq (Token a) where + a == b = (tokenStr a) == (tokenStr b) && + (tokenAttr a) == (tokenAttr b) +instance (Eq a) => Eq (TextStreamEntity a) where + NL == NL = True + T a == T b = a == b + _ == _ = False + +instance (Eq a) => Eq (TextStream a) where + (TS as) == (TS bs) = as == bs + +-- |Get the entities in a stream. +streamEntities :: TextStream a -> [TextStreamEntity a] +streamEntities (TS es) = es + +-- |Get the length of a token's string. +tokenLen :: Token a -> Int +tokenLen (S s _) = length s +tokenLen (WS s _) = length s + wsChars :: [Char] wsChars = [' ', '\t'] isWs :: Char -> Bool isWs = (`elem` wsChars) --- |Tokenize a string using a default annotation value. -tokenize :: String -> a -> [[Token a]] -tokenize [] _ = [[]] -tokenize s def = map (tokenize' def) $ splitWith s (== '\n') - -tokenize' :: a -> String -> [Token a] -tokenize' _ [] = [] -tokenize' a s@(c:_) | isWs c = Whitespace ws a : tokenize' a rest - where - (ws, rest) = break (not . isWs) s -tokenize' a s = Token t a : tokenize' a rest - where - (t, rest) = break (\c -> isWs c || c == '\n') s - --- |Serialize tokens to an underlying string representation, --- discarding annotations. -serialize :: [[Token a]] -> String -serialize ls = intercalate "\n" $ map (concatMap tokenString) ls +isNL :: TextStreamEntity a -> Bool +isNL NL = True +isNL _ = False --- |Replace a token's annotation. -withAnnotation :: Token a -> a -> Token a -withAnnotation (Whitespace s _) b = Whitespace s b -withAnnotation (Token s _) b = Token s b +-- |Gets a 'Token' from an entity or raises an exception if the entity +-- does not contain a token. Used primarily for convenience +-- transformations in which the parameter is known to be a token +-- entity. +entityToken :: TextStreamEntity a -> Token a +entityToken (T t) = t +entityToken _ = error "Cannot get token from non-token entity" --- |Is the token whitespace? isWhitespace :: Token a -> Bool -isWhitespace (Whitespace _ _) = True +isWhitespace (WS _ _) = True isWhitespace _ = False +isWsEnt :: TextStreamEntity a -> Bool +isWsEnt (T (WS _ _)) = True +isWsEnt _ = False + +-- |Given a text stream, serialize the stream to its original textual +-- representation. This discards token attribute metadata. +serialize :: TextStream a -> String +serialize (TS es) = concat $ map serializeEntity es + where + serializeEntity NL = "\n" + serializeEntity (T (WS s _)) = s + serializeEntity (T (S s _)) = s + +-- |Tokenize a string and apply a default attribute to every token in +-- the resulting text stream. +tokenize :: String -> a -> TextStream a +tokenize s def = TS $ findEntities s + where + findEntities [] = [] + findEntities str@(c:_) = nextEntity : findEntities (drop nextLen str) + where + (nextEntity, nextLen) = if isWs c + then (T (WS nextWs def), length nextWs) + else if c == '\n' + then (NL, 1) + else (T (S nextStr def), length nextStr) + nextWs = takeWhile isWs str + nextStr = takeWhile (\ch -> not $ ch `elem` ('\n':wsChars)) str + -- |Given a list of tokens, truncate the list so that its underlying -- string representation does not exceed the specified column width. -truncLine :: Int -> [Token a] -> [Token a] -truncLine width ts = +truncateLine :: Int -> [Token a] -> [Token a] +truncateLine l _ | l < 0 = error $ "truncateLine cannot truncate at length = " ++ show l +truncateLine _ [] = [] +truncateLine width ts = -- If we are returning all tokens, we didn't have to do any -- truncation. But if we *did* have to truncate, return exactly -- 'width' characters' worth of tokens by constructing a new final -- token with the same attribute data. - if length tokens == length ts - then tokens - else tokens ++ [lastToken] + -- + -- If there are no passing cases (i.e., remaining is null), just + -- return 'width' characters of the first token. + if null remaining + then [first_tok { tokenStr = take width $ tokenStr first_tok }] + else if length tokens == length ts + then tokens + else if null $ tokenStr lastToken + then tokens + else tokens ++ [lastToken] where - lengths = map (length . tokenString) ts + lengths = map (length . tokenStr) ts cases = reverse $ inits lengths remaining = dropWhile ((> width) . sum) cases tokens = take (length $ head remaining) ts truncLength = sum $ head remaining - lastTokenBasis = ts !! (length tokens) - lastToken = lastTokenBasis { - tokenString = take (width - truncLength) (tokenString lastTokenBasis) - } + first_tok = ts !! 0 + last_tok = ts !! (length tokens) + lastToken = last_tok { tokenStr = take (width - truncLength) $ tokenStr last_tok } --- |Given a list of tokens without Newlines, (potentially) wrap the --- list to the specified column width. -wrapLine :: Int -> [Token a] -> [[Token a]] -wrapLine _ [] = [] -wrapLine width ts = - -- If there were no passing cases, that means the line can't be - -- wrapped so just return it as-is (e.g., one long unbroken - -- string). Otherwise, package up the acceptable tokens and - -- continue wrapping. - if null passing - then [ts] - else if null these - then if length those' == 1 - then [those'] - else [head those'] : (wrapLine width $ tail those') - else these : wrapLine width those +-- |Given a text stream and a wrapping width, return a new +-- 'TextStream' with newlines inserted in appropriate places to wrap +-- the text at the specified column. This function results in text +-- wrapped without leading or trailing whitespace on wrapped lines, +-- although it preserves leading whitespace in the text which was not +-- the cause of the wrapping transformation. +wrapStream :: (Eq a) => Int -> TextStream a -> TextStream a +wrapStream width (TS stream) = TS $ reverse $ dropWhile (== NL) $ reverse $ wrapAll' 0 stream where - lengths = map (length . tokenString) ts - cases = reverse $ inits lengths - passing = dropWhile (\c -> sum c > width) cases - numTokens = length $ head passing - (these, those') = splitAt numTokens ts - those = dropWhile isWhitespace those' + wrapAll' :: Int -> [TextStreamEntity a] -> [TextStreamEntity a] + wrapAll' _ [] = [] + wrapAll' _ (NL:rest) = NL : wrapAll' 0 rest + wrapAll' accum (T t:rest) = + if (length $ tokenStr t) + accum > width + then if isWhitespace t + then [NL] ++ wrapAll' 0 (dropWhile isWsEnt rest) + else if accum == 0 && ((length $ tokenStr t) >= width) + then [T t, NL] ++ wrapAll' 0 (dropWhile isWsEnt rest) + else [NL, T t] ++ wrapAll' (length $ tokenStr t) rest + else T t : wrapAll' (accum + (length $ tokenStr t)) rest + +partitions :: (a -> Bool) -> [a] -> [[a]] +partitions _ [] = [] +partitions f as = p : partitions f (drop (length p + 1) as) + where + p = takeWhile f as + +-- |Given a list of text stream entities, split up the list wherever +-- newlines occur. Returns a list of lines of entities, such that all +-- entities wrap tokens and none are newlines. (Safe for use with +-- 'entityToken'.) +findLines :: [TextStreamEntity a] -> [[TextStreamEntity a]] +findLines = partitions (not . isNL) diff --git a/test/src/Tests/Tokenize.hs b/test/src/Tests/Tokenize.hs --- a/test/src/Tests/Tokenize.hs +++ b/test/src/Tests/Tokenize.hs @@ -2,60 +2,96 @@ module Tests.Tokenize where import Data.Char ( isPrint ) -import Control.Applicative ( (<$>), (<*>), pure ) import Test.QuickCheck import Text.Trans.Tokenize -import Tests.Util +lineGen :: Gen [Token ()] +lineGen = listOf1 $ oneof [wsgen, strgen] + where + strgen = do + s <- stringGen + return $ S s () -instance (Arbitrary a) => Arbitrary (Token a) where - arbitrary = oneof [ Whitespace <$> ws <*> arbitrary - , Token <$> s <*> arbitrary - ] - where - ws = oneof [ pure " ", pure "\t" ] - s = replicate <$> choose (1, 10) <*> pure 'a' + wsgen = do + s <- listOf1 $ elements " \t" + return $ WS s () -tokenGen :: Gen [[Token ()]] -tokenGen = listOf $ listOf arbitrary +stringGen :: Gen String +stringGen = listOf1 charGen -lineGen :: Gen [Token ()] -lineGen = listOf1 arbitrary +charGen :: Gen Char +charGen = arbitrary `suchThat` (\c -> isPrint c) -stringGen :: Gen String -stringGen = listOf (arbitrary `suchThat` (\c -> isPrint c)) +tests :: [Property] +tests = [ label "tokenize and serialize work" $ property $ forAll stringGen $ + \s -> (serialize $ tokenize s ()) == s -checkToken :: Token a -> Bool -checkToken (Whitespace s _) = all (`elem` " \t") s -checkToken (Token s _) = all (not . (`elem` " \t")) s + , label "truncateLine leaves short lines unchanged" $ property $ forAll lineGen $ + \ts -> ts == truncateLine (length $ serialize (TS (map T ts))) ts -collapse :: [Token a] -> String -collapse = concat . map tokenString + -- Bound the truncation width at twice the size of the input + -- since huge cases are silly. + , label "truncateLine truncates long lines" $ property $ forAll lineGen $ + \ts -> forAll (choose (0, 2 * (length $ serialize (TS (map T ts))))) $ + \width -> length (serialize $ (TS (map T $ truncateLine width ts))) <= width -tests :: [Property] -tests = [ label "tokenize: round trip test" $ property $ forAll tokenGen $ - \ts -> serialize ts == (serialize $ tokenize (serialize ts) ()) + , label "wrapStream does the right thing with whitespace" $ property $ + and [ wrapStream 5 (TS [T (S "foo" ()), T (WS " " ()), T (S "bar" ())]) == + (TS [ T (S "foo" ()) + , T (WS " " ()) + , NL + , T (S "bar" ()) + ]) - , label "tokenize: token contents consistent with constructors" $ - property $ forAll stringGen $ - \s -> all (all checkToken) $ tokenize s undefined + , wrapStream 5 (TS [ T (S "foo" ()), T (WS " " ()), T (S "bar" ()) + , T (WS " " ()), T (S "baz" ())]) == + (TS [ T (S "foo" ()) + , T (WS " " ()) + , NL + , T (S "bar" ()) + , T (WS " " ()) + , NL + , T (S "baz" ()) + ]) - , label "tokenize: newlines handled properly" $ property $ forAll stringGen $ - \s -> numNewlines s + 1 == (length $ tokenize s undefined) + , wrapStream 3 (TS [ T (S "foo" ()), T (WS " " ()), T (S "bar" ())]) == + (TS [ T (S "foo" ()) + , NL + , T (S "bar" ()) + ]) - , label "tokenize: line truncation works" $ property $ forAll lineGen $ - \ts -> forAll (arbitrary :: Gen (Positive Int)) $ - \width -> let l = truncLine (fromIntegral width) ts - in length (collapse l) <= fromIntegral width + , wrapStream 6 (TS [ T (S "foo" ()), T (WS " " ()), T (S "bar" ())]) == + (TS [ T (S "foo" ()) + , T (WS " " ()) + , NL + , T (S "bar" ()) + ]) - -- wrapping: a single line wrapped should always result in - -- lines that are no greater than the wrapping width, unless - -- they have a single token. - , label "tokenize: line-wrapping works" $ property $ forAll lineGen $ - \ts -> forAll (choose (0, length ts + 10)) $ - \width -> let ls = wrapLine w ts - w = fromIntegral width - f l = length (serialize [l]) <= w || length l == 1 - in all f ls + , wrapStream 7 (TS [ T (S "foo" ()), T (WS " " ()), T (S "bar" ())]) == + (TS [ T (S "foo" ()), T (WS " " ()), T (S "bar" ())]) + + , wrapStream 3 (TS [T (WS " " ())]) == TS [T (WS " " ())] + ] + + , label "wrapStream preserves newlines" $ property $ + let ts = TS [T (S "foo" ()), NL, T (S "bar" ())] + in wrapStream 3 ts == ts + + , label "wrapStream does the right thing if unable to wrap" $ + property $ and [ wrapStream 2 (TS [T (S "FOO" ())]) == TS [T (S "FOO" ())] + , wrapStream 2 (TS [T (S "FOO" ()), (T (S "BAR" ()))]) == + (TS [T (S "FOO" ()), NL, (T (S "BAR" ()))]) + ] + + -- Each line must be wrapped and be no longer than the + -- wrapping width OR it must be one token in length, assuming + -- that token was longer than the wrapping width and couldn't + -- be broken up. + , label "wrapLine wraps long lines when possible" $ + property $ forAll lineGen $ + \ts -> forAll (choose ((length $ tokenStr $ ts !! 0), (length $ serialize (TS $ map T ts)) - 1)) $ + \width -> let ls = findLines new + TS new = wrapStream width $ TS $ map T ts + in all (\l -> (length (serialize $ TS l)) <= width || (length l == 1)) ls ] diff --git a/vty-ui.cabal b/vty-ui.cabal --- a/vty-ui.cabal +++ b/vty-ui.cabal @@ -1,5 +1,5 @@ Name: vty-ui -Version: 1.1 +Version: 1.2 Synopsis: An interactive terminal user interface library for Vty Description: An extensible library of user interface widgets @@ -76,11 +76,14 @@ base >= 4 && < 5, vty >= 4.6 && < 4.7, containers >= 0.2 && < 0.5, - pcre-light >= 0.3 && < 0.4, + regex-pcre >= 0.94 && < 0.95, + regex-base >= 0.93 && < 0.94, directory >= 1.0 && < 1.2, filepath >= 1.1 && < 1.3, unix >= 2.4 && < 2.5, - mtl >= 2.0 && < 2.1 + mtl >= 2.0 && < 2.1, + stm >= 2.1 && < 2.3, + array >= 0.3 && < 0.4 GHC-Options: -Wall @@ -108,7 +111,6 @@ Graphics.Vty.Widgets.Button Graphics.Vty.Widgets.ProgressBar Graphics.Vty.Widgets.DirBrowser - Other-Modules: Text.Trans.Tokenize Executable vty-ui-tests @@ -157,7 +159,7 @@ bytestring >= 0.9 && < 1.0, time >= 1.1 && < 1.3, old-locale >= 1.0 && < 1.1, - pcre-light >= 0.3 && < 0.4, + regex-pcre >= 0.94 && < 0.95, vty >= 4.6 && < 4.7 if !flag(demos) Buildable: False