vty-ui 1.1 → 1.2
raw patch · 9 files changed
+431/−254 lines, 9 filesdep +arraydep +regex-basedep +regex-pcredep −pcre-light
Dependencies added: array, regex-base, regex-pcre, stm
Dependencies removed: pcre-light
Files
- doc/ch4/FormattedText.tex +66/−17
- doc/macros.tex +1/−1
- src/ComplexDemo.hs +7/−5
- src/Graphics/Vty/Widgets/EventLoop.hs +11/−9
- src/Graphics/Vty/Widgets/List.hs +2/−1
- src/Graphics/Vty/Widgets/Text.hs +91/−75
- src/Text/Trans/Tokenize.hs +169/−100
- test/src/Tests/Tokenize.hs +77/−41
- vty-ui.cabal +7/−5
doc/ch4/FormattedText.tex view
@@ -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 <bar> 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 <bar> 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}
doc/macros.tex view
@@ -1,6 +1,6 @@ % Custom macros. -\newcommand{\vtyuiversion}{1.1}+\newcommand{\vtyuiversion}{1.2} \newcommand{\fw}[1]{\texttt{#1}} \newcommand{\vtyui}{\fw{vty-ui}}
src/ComplexDemo.hs view
@@ -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)
src/Graphics/Vty/Widgets/EventLoop.hs view
@@ -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
src/Graphics/Vty/Widgets/List.hs view
@@ -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
src/Graphics/Vty/Widgets/Text.hs view
@@ -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
src/Text/Trans/Tokenize.hs view
@@ -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)
test/src/Tests/Tokenize.hs view
@@ -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 ]
vty-ui.cabal view
@@ -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