vty-ui 0.2 → 0.3
raw patch · 13 files changed
+970/−436 lines, 13 filesdep +QuickCheckdep +containersdep +pcre-lightnew-component:exe:vty-ui-tests
Dependencies added: QuickCheck, containers, pcre-light
Files
- src/Demo.hs +80/−30
- src/Graphics/Vty/Widgets/All.hs +5/−3
- src/Graphics/Vty/Widgets/Base.hs +81/−180
- src/Graphics/Vty/Widgets/Borders.hs +55/−65
- src/Graphics/Vty/Widgets/Composed.hs +7/−7
- src/Graphics/Vty/Widgets/List.hs +64/−59
- src/Graphics/Vty/Widgets/Rendering.hs +284/−0
- src/Graphics/Vty/Widgets/Text.hs +151/−0
- src/Graphics/Vty/Widgets/WrappedText.hs +0/−47
- src/Text/Trans/Tokenize.hs +122/−0
- src/Text/Trans/Wrap.hs +0/−35
- test/TestDriver.hs +88/−0
- vty-ui.cabal +33/−10
src/Demo.hs view
@@ -5,9 +5,39 @@ import Control.Monad ( when ) import Control.Monad.Trans ( liftIO ) import Control.Monad.State ( StateT, get, modify, evalStateT )+import Text.Regex.PCRE.Light.Char8 ( Regex, compile ) import Graphics.Vty-import Graphics.Vty.Widgets.All+ ( Event(..), Key(..), Vty, Attr+ , mkVty, shutdown, terminal, next_event, reserve_display+ , pic_for_image, update, with_fore_color, with_back_color+ , def_attr, blue, bright_white, bright_yellow, bright_green+ , black, yellow, red+ )+import Graphics.Vty.Widgets.Base+ ( (<-->)+ , (<++>)+ , hFill+ )+import Graphics.Vty.Widgets.Rendering+ ( Widget(..)+ , mkImage+ )+import Graphics.Vty.Widgets.Text+ ( simpleText, wrap, highlight+ , prepareText, textWidget, (&.&)+ )+import Graphics.Vty.Widgets.Borders+ ( bordered, hBorder+ )+import Graphics.Vty.Widgets.Composed+ ( bottomPadded+ )+import Graphics.Vty.Widgets.List+ ( List, mkList, pageUp, pageDown, resize+ , scrollUp, scrollDown, listWidget, getSelected+ , selectedIndex+ ) titleAttr :: Attr titleAttr = def_attr@@ -29,57 +59,77 @@ `with_back_color` yellow `with_fore_color` black -buildUi :: AppState -> Bordered+regex1 :: Regex+regex1 = compile "(to|an|or|too)" []++hlAttr1 :: Attr+hlAttr1 = def_attr+ `with_back_color` black+ `with_fore_color` red++regex2 :: Regex+regex2 = compile "(text|if|you)" []++hlAttr2 :: Attr+hlAttr2 = def_attr+ `with_back_color` black+ `with_fore_color` yellow++buildUi :: AppState -> Widget buildUi appst = let body = fromJust $ lookup (fst $ getSelected list) msgs currentItem = selectedIndex list + 1- footer = (text titleAttr $ " " ++ (show currentItem) ++ "/" ++ (show $ length msgs) ++ " ")+ footer = (simpleText titleAttr $ " " ++ (show currentItem) ++ "/" ++ (show $ length msgs) ++ " ") <++> hFill titleAttr '-' 1 msgs = theMessages appst list = theList appst- in bordered boxAttr $ list+ formatter = wrap &.&+ highlight regex1 hlAttr1 &.&+ highlight regex2 hlAttr2+ in bordered boxAttr $ listWidget list <--> hBorder titleAttr- <--> (bottomPadded (wrappedText bodyAttr body))+ <--> (bottomPadded $ textWidget formatter $ prepareText bodyAttr body) <--> footer -- Construct the user interface based on the contents of the -- application state.-uiFromState :: StateT AppState IO Bordered+uiFromState :: StateT AppState IO Widget uiFromState = buildUi <$> get -- The application state; this encapsulates what can vary based on -- user input and what is used to construct the interface. This is a -- place for widgets whose state need to be stored so they can be -- modified and used to reconstruct the interface as input is handled-data AppState = AppState { theList :: List String Bordered+data AppState = AppState { theList :: List String , theMessages :: [(String, String)] } -scrollListUp :: StateT AppState IO ()-scrollListUp = modify (\appst -> appst { theList = scrollUp $ theList appst })+scrollListUp :: AppState -> AppState+scrollListUp appst = appst { theList = scrollUp $ theList appst } -scrollListDown :: StateT AppState IO ()-scrollListDown = modify (\appst -> appst { theList = scrollDown $ theList appst })+scrollListDown :: AppState -> AppState+scrollListDown appst = appst { theList = scrollDown $ theList appst } -pageListUp :: StateT AppState IO ()-pageListUp = modify (\appst -> appst { theList = pageUp $ theList appst })+pageListUp :: AppState -> AppState+pageListUp appst = appst { theList = pageUp $ theList appst } -pageListDown :: StateT AppState IO ()-pageListDown = modify (\appst -> appst { theList = pageDown $ theList appst })+pageListDown :: AppState -> AppState+pageListDown appst = appst { theList = pageDown $ theList appst } -resizeList :: Int -> StateT AppState IO ()-resizeList s = modify (\appst -> appst { theList = resize s $ theList appst })+resizeList :: Int -> AppState -> AppState+resizeList s appst = appst { theList = resize s $ theList appst } -- Process events from VTY, possibly modifying the application state.-eventloop :: (Widget a) => Vty- -> StateT AppState IO a+eventloop :: Vty+ -> StateT AppState IO Widget -> (Event -> StateT AppState IO Bool) -> StateT AppState IO () eventloop vty uiBuilder handle = do w <- uiBuilder evt <- liftIO $ do- pic_for_image <$> mkImage vty w >>= update vty- next_event vty+ (img, _) <- mkImage vty w+ update vty $ pic_for_image img+ next_event vty next <- handle evt if next then eventloop vty uiBuilder handle else@@ -92,23 +142,23 @@ stop = return False handleEvent :: Event -> StateT AppState IO Bool-handleEvent (EvKey KUp []) = scrollListUp >> continue-handleEvent (EvKey KDown []) = scrollListDown >> continue-handleEvent (EvKey KPageUp []) = pageListUp >> continue-handleEvent (EvKey KPageDown []) = pageListDown >> continue+handleEvent (EvKey KUp []) = modify scrollListUp >> continue+handleEvent (EvKey KDown []) = modify scrollListDown >> continue+handleEvent (EvKey KPageUp []) = modify pageListUp >> continue+handleEvent (EvKey KPageDown []) = modify pageListDown >> continue handleEvent (EvKey (KASCII 'q') []) = stop handleEvent (EvResize _ h) = do let newSize = ceiling (0.05 * fromIntegral h)- when (newSize > 0) $ resizeList newSize+ when (newSize > 0) $ modify (resizeList newSize) continue handleEvent _ = continue -- Construct the application state using the message map. mkAppState :: [(String, String)] -> AppState mkAppState messages =- let list = mkList bodyAttr selAttr 3 borederedLabels- borederedLabels = zip labels $ map mkWidget labels- mkWidget = bordered boxAttr . text bodyAttr+ let list = mkList bodyAttr selAttr 5 labelWidgets+ labelWidgets = zip labels $ map mkWidget labels+ mkWidget = simpleText bodyAttr labels = map fst messages in AppState { theList = list , theMessages = messages@@ -122,7 +172,7 @@ let messages = [ ("First", "This text is long enough that it will get wrapped \ \if you resize your terminal to something small. \ \It also contains enough text to get truncated at \- \the bottom if the display area is too small." )+ \the bottom if the display area is too small.\n\n\n" ) , ("Second", "the second message") , ("Third", "the third message") , ("Fourth", "the fourth message")
src/Graphics/Vty/Widgets/All.hs view
@@ -1,15 +1,17 @@ -- |A convenience module exporting everything in this library. module Graphics.Vty.Widgets.All- ( module Graphics.Vty.Widgets.Base+ ( module Graphics.Vty.Widgets.Rendering+ , module Graphics.Vty.Widgets.Base , module Graphics.Vty.Widgets.List- , module Graphics.Vty.Widgets.WrappedText , module Graphics.Vty.Widgets.Composed , module Graphics.Vty.Widgets.Borders+ , module Graphics.Vty.Widgets.Text ) where +import Graphics.Vty.Widgets.Rendering import Graphics.Vty.Widgets.Base import Graphics.Vty.Widgets.List-import Graphics.Vty.Widgets.WrappedText import Graphics.Vty.Widgets.Composed import Graphics.Vty.Widgets.Borders+import Graphics.Vty.Widgets.Text
src/Graphics/Vty/Widgets/Base.hs view
@@ -1,23 +1,9 @@-{-# LANGUAGE ExistentialQuantification #-} -- |A collection of primitive user interface widgets for composing and -- laying out 'Graphics.Vty' user interfaces. This module provides--- basic static and box layout widgets and a type class for rendering--- widgets to Vty 'Graphics.Vty.Image's.------ Each widget type supplied by this library is exported as a type and--- an associated constructor function (e.g., 'Text' and 'text', 'Box'--- and 'vBox' / 'hBox').+-- basic static and box layout widgets. module Graphics.Vty.Widgets.Base- ( Widget(..)- , mkImage- , AnyWidget- , Text- , Box- , Fill- , (<++>)+ ( (<++>) , (<-->)- , anyWidget- , text , hBox , vBox , hFill@@ -27,88 +13,52 @@ import GHC.Word ( Word ) -import Graphics.Vty ( DisplayRegion(DisplayRegion), Vty, Image, Attr- , string, char_fill, image_width, image_height- , region_width, region_height, terminal- , display_bounds, vert_cat, horiz_cat )---- |The class of user interface widgets. Note that the growth--- properties 'growHorizontal' and 'growVertical' are used to control--- rendering order; if a widget /can/ grow to fill available space,--- then neighboring fixed-size widgets will be rendered first so--- remaining space can be computed. Then, variable-sized (growable)--- widgets will be rendered last to consume that space.-class Widget w where- -- |Given a widget, render it with the given dimensions. The- -- resulting Image should not be larger than the specified- -- dimensions, but may be smaller.- render :: DisplayRegion -> w -> Image-- -- |Will this widget expand to take advantage of available- -- horizontal space?- growHorizontal :: w -> Bool-- -- |Will this widget expand to take advantage of available- -- vertical space?- growVertical :: w -> Bool-- -- |The primary attribute of this widget, used when composing- -- widgets. For example, if you want to compose a widget /A/ with- -- a space-filling widget /B/, you probably want /B/'s text- -- attributes to be identical to those of /A/.- primaryAttribute :: w -> Attr-- -- |Apply the specified attribute to this widget.- withAttribute :: w -> Attr -> w---- |A wrapper for all widget types used in normalizing heterogeneous--- lists of widgets. See 'anyWidget'.-data AnyWidget = forall a. (Widget a) => AnyWidget a--instance Widget AnyWidget where- growHorizontal (AnyWidget w) = growHorizontal w- growVertical (AnyWidget w) = growVertical w- render s (AnyWidget w) = render s w- primaryAttribute (AnyWidget w) = primaryAttribute w- withAttribute (AnyWidget w) att = AnyWidget (withAttribute w att)---- |A text widget consisting of a string rendered using an--- attribute. See 'text'.-data Text = Text Attr String--instance Widget Text where- growHorizontal _ = False- growVertical _ = False- render _ (Text att content) = string att content- primaryAttribute (Text att _) = att- withAttribute (Text _ content) att = Text att content---- |A fill widget for filling available vertical or horizontal space--- in a box layout. See 'vFill' and 'hFill'.-data Fill = VFill Attr Char- | HFill Attr Char Int--instance Widget Fill where- growHorizontal (HFill _ _ _) = True- growHorizontal (VFill _ _) = False-- growVertical (VFill _ _) = True- growVertical (HFill _ _ _) = False-- primaryAttribute (HFill att _ _) = att- primaryAttribute (VFill att _) = att-- withAttribute (HFill _ c h) att = HFill att c h- withAttribute (VFill _ c) att = VFill att c+import Graphics.Vty.Widgets.Rendering+ ( Widget(..)+ , Render+ , renderImg+ , renderMany+ , renderWidth+ , renderHeight+ , Orientation(..)+ , withHeight+ , withWidth+ )+import Graphics.Vty+ ( DisplayRegion+ , Attr+ , char_fill+ , region_width+ , region_height+ ) - render s (VFill att c) = char_fill att c (region_width s) (region_height s)- render s (HFill att c h) = char_fill att c (region_width s) (toEnum h)+-- |A vertical fill widget. Fills all available space with the+-- specified character and attribute.+vFill :: Attr -> Char -> Widget+vFill att c = Widget {+ growHorizontal = False+ , growVertical = True+ , primaryAttribute = att+ , withAttribute = flip vFill c+ , render = \s -> renderImg $ char_fill att c (region_width s)+ (region_height s)+ } -data Orientation = Horizontal | Vertical+-- |A horizontal fill widget. Fills the available horizontal space,+-- one row high, using the specified character and attribute.+hFill :: Attr -> Char -> Int -> Widget+hFill att c h = Widget {+ growHorizontal = True+ , growVertical = False+ , primaryAttribute = att+ , withAttribute = \att' -> hFill att' c h+ , render = \s -> renderImg $ char_fill att c (region_width s)+ (toEnum h)+ } -- |A box layout widget capable of containing two 'Widget's -- horizontally or vertically. See 'hBox' and 'vBox'. Boxes lay out--- their children as follows:+-- their children by using the growth properties of the children: -- -- * If both children are expandable in the same dimension (i.e., both -- vertically or both horizontally), the children are each given@@ -121,46 +71,41 @@ -- * Otherwise, both children are rendered in top-to-bottom or -- left-to-right order and the resulting container uses only as much -- space as its children combined-data Box = forall a b. (Widget a, Widget b) => Box Orientation a b--instance Widget Box where- growHorizontal (Box _ a b) =- growHorizontal a || growHorizontal b-- growVertical (Box _ a b) =- growVertical a || growVertical b-- withAttribute (Box o top bottom) att = Box o- (withAttribute top att)- (withAttribute bottom att)-- -- Not the best way to choose this, but it seems like anything- -- here is going to be arbitrary.- primaryAttribute (Box _ top _) = primaryAttribute top-- render s (Box Vertical top bottom) =- renderBox s (top, bottom) growVertical vert_cat region_height image_height withHeight- render s (Box Horizontal left right) =- renderBox s (left, right) growHorizontal horiz_cat region_width image_width withWidth+box :: Orientation -> Widget -> Widget -> Widget+box o a b = Widget {+ growHorizontal = growHorizontal a || growHorizontal b+ , growVertical = growVertical a || growVertical b+ , withAttribute =+ \att ->+ box o (withAttribute a att) (withAttribute b att)+ , primaryAttribute = primaryAttribute a+ , render =+ \s -> case o of+ Vertical ->+ renderBox s (a, b) o growVertical region_height+ renderHeight withHeight+ Horizontal ->+ renderBox s (a, b) o growHorizontal region_width+ renderWidth withWidth+ } -- Box layout rendering implementation. This is generalized over the -- two dimensions in which box layout can be performed; it takes lot -- of functions, but mostly those are to query and update the correct -- dimensions on regions and images as they are manipulated by the -- layout algorithm.-renderBox :: (Widget a, Widget b) =>- DisplayRegion- -> (a, b)- -> (AnyWidget -> Bool) -- growth comparison function- -> ([Image] -> Image) -- concatenation function+renderBox :: DisplayRegion+ -> (Widget, Widget)+ -> Orientation+ -> (Widget -> Bool) -- growth comparison function -> (DisplayRegion -> Word) -- region dimension fetch function- -> (Image -> Word) -- image dimension fetch function+ -> (Render -> Word) -- image dimension fetch function -> (DisplayRegion -> Word -> DisplayRegion) -- dimension modification function- -> Image-renderBox s (first, second) grow concatenate regDimension imgDimension withDim =- concatenate ws+ -> Render+renderBox s (first, second) orientation grow regDimension renderDimension withDim =+ renderMany orientation ws where- ws = case (grow $ anyWidget first, grow $ anyWidget second) of+ ws = case (grow first, grow second) of (True, True) -> renderHalves (False, _) -> renderOrdered first second (_, False) -> let [a, b] = renderOrdered second first@@ -169,77 +114,33 @@ half' = if regDimension s `mod` 2 == 0 then half else half `withDim` (regDimension half + 1)- in [ render half first- , render half' second ]- renderOrdered a b = let renderedA = render s a- renderedB = render s' b- remaining = regDimension s - imgDimension renderedA+ in [ render first half+ , render second half' ]+ renderOrdered a b = let renderedA = render a s+ renderedB = render b s'+ remaining = regDimension s - renderDimension renderedA s' = s `withDim` remaining- in if imgDimension renderedA >= regDimension s+ in if renderDimension renderedA >= regDimension s then [renderedA] else [renderedA, renderedB] -withWidth :: DisplayRegion -> Word -> DisplayRegion-withWidth (DisplayRegion _ h) w = DisplayRegion w h--withHeight :: DisplayRegion -> Word -> DisplayRegion-withHeight (DisplayRegion w _) h = DisplayRegion w h---- |Given a 'Widget' and a 'Vty' object, render the widget using the--- current size of the terminal controlled by Vty. Returns the--- rendered 'Widget' as an 'Image'.-mkImage :: (Widget a) => Vty -> a -> IO Image-mkImage vty w = do- size <- display_bounds $ terminal vty- return $ render size w---- |Wrap a 'Widget' in the 'AnyWidget' type for normalization--- purposes.-anyWidget :: (Widget a) => a -> AnyWidget-anyWidget = AnyWidget---- |Create a 'Text' widget.-text :: Attr -- ^The attribute to use to render the text- -> String -- ^The text to display- -> Text-text = Text---- |Create an horizonal fill widget.-hFill :: Attr -- ^The attribute to use to render the fill- -> Char -- ^The character to fill- -> Int -- ^The height, in rows, of the filled area; width of the- -- fill depends on available space- -> Fill-hFill = HFill---- |Create a vertical fill widget. The dimensions of the widget will--- depend on available space.-vFill :: Attr -- ^The attribute to use to render the fill- -> Char -- ^The character to fill- -> Fill-vFill = VFill- -- |Create a horizontal box layout widget containing two widgets side -- by side. Space consumed by the box will depend on its contents and -- the available space.-hBox :: (Widget a, Widget b) => a -- ^The left widget- -> b -- ^The right widget- -> Box-hBox = Box Horizontal+hBox :: Widget -> Widget -> Widget+hBox = box Horizontal -- |An alias for 'hBox' intended as sugar to chain widgets -- horizontally.-(<++>) :: (Widget a, Widget b) => a -> b -> Box+(<++>) :: Widget -> Widget -> Widget (<++>) = hBox -- |Create a vertical box layout widget containing two widgets. Space -- consumed by the box will depend on its contents and the available -- space.-vBox :: (Widget a, Widget b) => a -- ^The top widget- -> b -- ^The bottom widget- -> Box-vBox = Box Vertical+vBox :: Widget -> Widget -> Widget+vBox = box Vertical -- |An alias for 'vBox' intended as sugar to chain widgets vertically.-(<-->) :: (Widget a, Widget b) => a -> b -> Box+(<-->) :: Widget -> Widget -> Widget (<-->) = vBox
src/Graphics/Vty/Widgets/Borders.hs view
@@ -1,10 +1,7 @@-{-# LANGUAGE ExistentialQuantification #-} -- |This module provides visual borders to be placed between and -- around widgets. module Graphics.Vty.Widgets.Borders- ( Border- , Bordered- , vBorder+ ( vBorder , hBorder , bordered )@@ -13,76 +10,69 @@ import Graphics.Vty ( Attr , DisplayRegion(DisplayRegion)- , (<|>) , char_fill , region_height , region_width- , image_width- , image_height- , vert_cat )-import Graphics.Vty.Widgets.Base+import Graphics.Vty.Widgets.Rendering ( Widget(..)- , (<++>)- , text+ , Render+ , Orientation(..)+ , renderImg+ , renderMany+ , renderWidth+ , renderHeight )---- |A horizontal or vertical border to be placed between widgets. See--- 'hBorder' and 'vBorder'.-data Border = VBorder Attr- | HBorder Attr---- |A container widget which draws a border around all four sides of--- the widget it contains. See 'bordered'.-data Bordered = forall a. (Widget a) => Bordered Attr a--instance Widget Border where- growVertical (VBorder _) = True- growVertical (HBorder _) = False-- growHorizontal (VBorder _) = False- growHorizontal (HBorder _) = True-- primaryAttribute (VBorder a) = a- primaryAttribute (HBorder a) = a-- render s (VBorder att) =- char_fill att '|' 1 (region_height s)- render s (HBorder att) =- char_fill att '-' (region_width s) 1-- withAttribute (VBorder _) att = VBorder att- withAttribute (HBorder _) att = HBorder att--instance Widget Bordered where- growVertical (Bordered _ w) = growVertical w- growHorizontal (Bordered _ w) = growHorizontal w- primaryAttribute (Bordered att _) = att- withAttribute (Bordered _ w) att = Bordered att (withAttribute w att)- render s (Bordered att w) =- -- Render the contained widget with enough room to draw- -- borders. Then, use the size of the rendered widget to- -- constrain the space used by the (expanding) borders.- vert_cat [topBottom, middle, topBottom]- where- constrained = DisplayRegion (region_width s - 2) (region_height s - 2)- renderedChild = render constrained w- adjusted = DisplayRegion- (image_width renderedChild + 2)- (image_height renderedChild)- corner = text att "+"- topBottom = render adjusted (corner <++> hBorder att <++> corner)- leftRight = render adjusted $ vBorder att- middle = leftRight <|> renderedChild <|> leftRight+import Graphics.Vty.Widgets.Base+ ( (<++>)+ )+import Graphics.Vty.Widgets.Text+ ( simpleText+ ) -- |Create a single-row horizontal border.-hBorder :: Attr -> Border-hBorder = HBorder+hBorder :: Attr -> Widget+hBorder att = Widget {+ growVertical = False+ , growHorizontal = True+ , primaryAttribute = att+ , withAttribute = hBorder+ , render = \s -> renderImg $ char_fill att '-' (region_width s) 1+ } -- |Create a single-column vertical border.-vBorder :: Attr -> Border-vBorder = VBorder+vBorder :: Attr -> Widget+vBorder att = Widget {+ growHorizontal = False+ , growVertical = True+ , primaryAttribute = att+ , render = \s -> renderImg $ char_fill att '|' 1 (region_height s)+ , withAttribute = vBorder+ } -- |Wrap a widget in a bordering box using the specified attribute.-bordered :: (Widget a) => Attr -> a -> Bordered-bordered = Bordered+bordered :: Attr -> Widget -> Widget+bordered att w = Widget {+ growVertical = growVertical w+ , growHorizontal = growHorizontal w+ , primaryAttribute = att+ , withAttribute = \att' -> bordered att' (withAttribute w att')+ , render = renderBordered att w+ }++renderBordered :: Attr -> Widget -> DisplayRegion -> Render+renderBordered att w s =+ -- Render the contained widget with enough room to draw borders.+ -- Then, use the size of the rendered widget to constrain the+ -- space used by the (expanding) borders.+ renderMany Vertical [topBottom, middle, topBottom]+ where+ constrained = DisplayRegion (region_width s - 2) (region_height s - 2)+ renderedChild = render w constrained+ adjusted = DisplayRegion+ (renderWidth renderedChild + 2)+ (renderHeight renderedChild)+ corner = simpleText att "+"+ topBottom = render (corner <++> hBorder att <++> corner) adjusted+ leftRight = render (vBorder att) adjusted+ middle = renderMany Horizontal [leftRight, renderedChild, leftRight]
src/Graphics/Vty/Widgets/Composed.hs view
@@ -1,22 +1,22 @@--- |This module provides high-level "combined" widgets which compose--- the basic widget types to provide more interesting widgets.+-- |This module provides high-level composed widgets. module Graphics.Vty.Widgets.Composed ( bottomPadded , topPadded ) where +import Graphics.Vty.Widgets.Rendering+ ( Widget(primaryAttribute)+ ) import Graphics.Vty.Widgets.Base- ( Widget(..)- , (<-->)+ ( (<-->) , vFill- , Box ) -- |Add expanding bottom padding to a widget.-bottomPadded :: (Widget a) => a -> Box+bottomPadded :: Widget -> Widget bottomPadded w = w <--> vFill (primaryAttribute w) ' ' -- |Add expanding top padding to a widget.-topPadded :: (Widget a) => a -> Box+topPadded :: Widget -> Widget topPadded w = vFill (primaryAttribute w) ' ' <--> w
src/Graphics/Vty/Widgets/List.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ExistentialQuantification #-} -- |This module provides a 'List' widget for rendering a list of -- arbitrary widgets. A 'List' has the following features: --@@ -13,11 +12,11 @@ -- automatically shifts as the list is scrolled module Graphics.Vty.Widgets.List ( List- , SimpleList , ListItem -- ** List creation , mkList , mkSimpleList+ , listWidget -- ** List manipulation , scrollBy , scrollUp@@ -35,53 +34,80 @@ ) where -import Graphics.Vty ( Attr, vert_cat )-import Graphics.Vty.Widgets.Base+import Graphics.Vty ( Attr, DisplayRegion )+import Graphics.Vty.Widgets.Rendering ( Widget(..)- , Text- , text- , anyWidget- , hFill+ , Orientation(..)+ , Render )+import Graphics.Vty.Widgets.Rendering+ ( renderMany+ )+import Graphics.Vty.Widgets.Base+ ( hFill+ )+import Graphics.Vty.Widgets.Text+ ( simpleText+ ) -- |A list item. Each item contains an arbitrary internal identifier--- @a@ and a widget @b@ representing it.-type ListItem a b = (a, b)+-- @a@ and a 'Widget' representing it.+type ListItem a = (a, Widget) -- |The list widget type. Lists are parameterized over the /internal/ -- /identifier type/ @a@, the type of internal identifiers used to -- refer to the visible representations of the list contents, and the -- /widget type/ @b@, the type of widgets used to represent the list -- visually.-data List a b = List { normalAttr :: Attr- , selectedAttr :: Attr- , selectedIndex :: Int- -- ^The currently selected list index.- , scrollTopIndex :: Int- -- ^The start index of the window of visible list- -- items.- , scrollWindowSize :: Int- -- ^The size of the window of visible list items.- , listItems :: [ListItem a b]- -- ^The items in the list.- }--type SimpleList = List String Text+data List a = List { normalAttr :: Attr+ , selectedAttr :: Attr+ , selectedIndex :: Int+ -- ^The currently selected list index.+ , scrollTopIndex :: Int+ -- ^The start index of the window of visible list+ -- items.+ , scrollWindowSize :: Int+ -- ^The size of the window of visible list items.+ , listItems :: [ListItem a]+ -- ^The items in the list.+ } -- |Create a new list. Emtpy lists and empty scrolling windows are -- not allowed.-mkList :: (Widget b) =>- Attr -- ^The attribute of normal, non-selected items+mkList :: Attr -- ^The attribute of normal, non-selected items -> Attr -- ^The attribute of the selected item -> Int -- ^The scrolling window size, i.e., the number of items -- which should be visible to the user at any given time- -> [ListItem a b] -- ^The list items- -> List a b+ -> [ListItem a] -- ^The list items+ -> List a mkList _ _ _ [] = error "Lists cannot be empty" mkList normAttr selAttr swSize contents | swSize <= 0 = error "Scrolling window size must be > 0" | otherwise = List normAttr selAttr 0 0 swSize contents +listWidget :: List a -> Widget+listWidget list = Widget {+ growHorizontal = False+ , growVertical = False+ , withAttribute = \att -> listWidget list { normalAttr = att }+ , primaryAttribute = normalAttr list+ , render = renderListWidget list+ }++renderListWidget :: List a -> DisplayRegion -> Render+renderListWidget list s =+ renderMany Vertical ws+ where+ ws = map (\w -> render w s) (visible ++ filler)+ visible = map highlight items+ items = map (\((_, w), sel) -> (w, sel)) $ getVisibleItems list+ filler = replicate (scrollWindowSize list - length visible)+ (hFill (normalAttr list) ' ' 1)+ highlight (w, selected) = let att = if selected+ then selectedAttr+ else normalAttr+ in withAttribute w (att list)+ -- |A convenience function to create a new list using 'String's as the -- internal identifiers and 'Text' widgets to represent those strings. mkSimpleList :: Attr -- ^The attribute of normal, non-selected items@@ -90,21 +116,21 @@ -- items which should be visible to the user at -- any given time -> [String] -- ^The list items- -> SimpleList+ -> List String mkSimpleList normAttr selAttr swSize labels = mkList normAttr selAttr swSize widgets where- widgets = map (\l -> (l, text normAttr l)) labels+ widgets = map (\l -> (l, simpleText normAttr l)) labels -- note that !! here will always succeed because selectedIndex will -- never be out of bounds and the list will always be non-empty. -- |Get the currently selected list item.-getSelected :: List a b -> ListItem a b+getSelected :: List a -> ListItem a getSelected list = (listItems list) !! (selectedIndex list) -- |Set the window size of the list. This automatically adjusts the -- window position to keep the selected item visible.-resize :: Int -> List a b -> List a b+resize :: Int -> List a -> List a resize newSize list | newSize == 0 = error "Cannot resize list window to zero" -- Do nothing if the window size isn't changing.@@ -134,7 +160,7 @@ -- -- * Moves the scrolling window position if necessary (i.e., if the -- cursor moves to an item not currently in view)-scrollBy :: Int -> List a b -> List a b+scrollBy :: Int -> List a -> List a scrollBy amount list = list { scrollTopIndex = adjustedTop , selectedIndex = newSelected }@@ -161,49 +187,28 @@ else newSelected -- |Scroll a list down by one position.-scrollDown :: List a b -> List a b+scrollDown :: List a -> List a scrollDown = scrollBy 1 -- |Scroll a list up by one position.-scrollUp :: List a b -> List a b+scrollUp :: List a -> List a scrollUp = scrollBy (-1) -- |Scroll a list down by one page from the current cursor position.-pageDown :: List a b -> List a b+pageDown :: List a -> List a pageDown list = scrollBy (scrollWindowSize list) list -- |Scroll a list up by one page from the current cursor position.-pageUp :: List a b -> List a b+pageUp :: List a -> List a pageUp list = scrollBy (-1 * scrollWindowSize list) list -- |Given a 'List', return the items that are currently visible -- according to the state of the list. Returns the visible items and -- flags indicating whether each is selected.-getVisibleItems :: List a b -> [(ListItem a b, Bool)]+getVisibleItems :: List a -> [(ListItem a, Bool)] getVisibleItems list = let start = scrollTopIndex list stop = scrollTopIndex list + scrollWindowSize list adjustedStop = (min stop $ length $ listItems list) - 1 in [ (listItems list !! i, i == selectedIndex list) | i <- [start..adjustedStop] ]--instance (Widget b) => Widget (List a b) where- growHorizontal _ = False- growVertical _ = False-- withAttribute w att = w { normalAttr = att }-- primaryAttribute = normalAttr-- render s list =- vert_cat images- where- images = map (render s) (visible ++ filler)- visible = map highlight items- items = map (\((_, w), sel) -> (w, sel)) $ getVisibleItems list- filler = replicate (scrollWindowSize list - length visible)- (anyWidget $ hFill (normalAttr list) ' ' 1)- highlight (w, selected) = let att = if selected- then selectedAttr- else normalAttr- in anyWidget $ withAttribute w (att list)
+ src/Graphics/Vty/Widgets/Rendering.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE CPP #-}+-- |This module provides a basic infrastructure for modelling a user+-- interface widget and converting it to Vty's 'Image' type.+module Graphics.Vty.Widgets.Rendering+ ( Widget(..)+ , mkImage++ -- ** Rendering process+ -- |'Widget's are ultimately converted to Vty 'Image's, but this+ -- library uses an intermediate type, 'Render', to represent the+ -- physical layout of the images. A 'Render' represents the+ -- various primitive rendering constructs which support vertical+ -- and horizontal concatenation and 'Image' addressing. Once a+ -- 'Widget' has been rendered (see 'render'), the resulting+ -- 'Render' is then put through a /positioning pass/ in which the+ -- sizes and positions of any addressable image regions are stored+ -- (see 'RenderState'). The result is a single 'Image' suitable+ -- for use with Vty's 'Graphics.Vty.pic_for_image' function.+ , RenderState+#ifdef TESTING+ , Render(..)+#else+ , Render+#endif+ , renderImg+ , renderAddr+ , renderMany+ , renderWidth+ , renderHeight++ -- ** Widget addressing+ -- |Some widgets, such as editable widgets, require that their+ -- on-screen representations be known after rendering; this+ -- library supports a notion of /widget addressing/ in which a+ -- 'Widget' is marked as /addressable/ (see 'addressable').+ -- Addressable widgets' position and size information ('Address')+ -- will be recorded in the 'RenderState' during rendering in+ -- 'mkImage'.+ , Address+ , address+ , addressable+ , addrSize+ , addrPosition+ , addAddress++ -- ** Miscellaneous+ , Orientation(..)+ , withWidth+ , withHeight++#ifdef TESTING+ , mkImageSize+#endif+ )+where++import GHC.Word ( Word )+import qualified Data.Map as Map+import Control.Monad.State ( State, modify, runState )++import Graphics.Vty+ ( DisplayRegion(DisplayRegion)+ , Attr+ , Image+ , Vty(terminal)+ , display_bounds+ , (<|>)+ , (<->)+ , image_width+ , image_height+ , region_width+ , region_height+ , vert_cat+ , horiz_cat+ )++-- |A simple orientation type.+data Orientation = Horizontal | Vertical+ deriving (Eq, Show)++-- |The type of user interface widgets. A 'Widget' provides several+-- properties:+--+-- * /Growth properties/ which provide information about how to+-- allocate space to widgets depending on their propensity to+-- consume available space+--+-- * A /primary attribute/ which is the attribute most easily+-- identifiable with the widget's visual presentation+--+-- * An /attribute override/ which allows the widget and its children+-- to be rendered using a single attribute specified by the caller+--+-- * A /rendering routine/ which converts the widget's internal state+-- into a 'Render' value.+--+-- Of primary concern is the rendering routine, 'render'. The+-- rendering routine takes one parameter: the size of the space in+-- which the widget should be rendered. The space is important+-- because it provides a maximum size for the widget. For widgets+-- that consume all available space, the size of the resulting+-- 'Render' will be equal to the supplied size. For smaller widgets+-- (e.g., a simple string of text), the size of the 'Render' will+-- likely be much smaller than the supplied size. In any case, any+-- 'Widget' implementation /must/ obey the rule that the resulting+-- 'Render' must not exceed the supplied 'DisplayRegion' in size. If+-- it does, there's a good chance your interface will be garbled.+--+-- If the widget has child widgets, the supplied size should be+-- subdivided to fit the child widgets as appropriate. How the space+-- is subdivided may depend on the growth properties of the children+-- or it may be a matter of policy.+data Widget = Widget {+ -- |Render the widget with the given dimensions. The result+ -- /must/ not be larger than the specified dimensions, but may be+ -- smaller.+ render :: DisplayRegion -> Render++ -- |Will this widget expand to take advantage of available+ -- horizontal space?+ , growHorizontal :: Bool++ -- |Will this widget expand to take advantage of available+ -- vertical space?+ , growVertical :: Bool++ -- |The primary attribute of this widget, used when composing+ -- widgets. For example, if you want to compose a widget /A/ with+ -- a space-filling widget /B/, you probably want /B/'s text+ -- attributes to be identical to those of /A/.+ , primaryAttribute :: Attr++ -- |Apply the specified attribute to this widget.+ , withAttribute :: Attr -> Widget+ }++-- |Information about the rendered state of a widget.+data Address = Address { addrPosition :: DisplayRegion+ -- ^The rendered position of a widget.+ , addrSize :: DisplayRegion+ -- ^The rendered size of a widget.+ }+ deriving (Eq, Show)++-- |The collection of widget names (see 'addressable') and their+-- rendering addresses as a result of 'render'.+type RenderState = Map.Map String Address++-- |An intermediate type used in the rendering process. Widgets are+-- converted into collections of 'Image's and represented with this+-- type, using a few primitive rendering instructions to determine how+-- the rendered images are combined to form a complete terminal window+-- image. See 'render'.+data Render = Img Image+ | Addressed String Render+ | Many Orientation [Render]++-- |Annotate a widget with a rendering identifier so that its+-- rendering address will be stored by the rendering process. Once+-- the widget has been rendered, its address will be found in the+-- resulting 'RenderState'. To retrieve the address of such an+-- identifier, use 'address'.+addressable :: String+ -- ^The identifier of the widget to be used in the+ -- 'RenderState'.+ -> Widget+ -- ^The widget whose rendering address ('Address') should+ -- be stored.+ -> Widget+addressable ident w = w {+ withAttribute = addressable ident . withAttribute w+ , render = renderAddr ident . render w+ }++-- |Create a 'Render' containing a single 'Image'.+renderImg :: Image -> Render+renderImg = Img++-- |Create a 'Render' representing a render together with an+-- identifier. This type of 'Render' is used with 'addressable' to+-- locate a widget's position and dimensions in the final 'Image'.+renderAddr :: String -- ^The identifier of the widget that this+ -- 'Render' represents. Should be the same+ -- identifier that was passed to 'addressable'.+ -> Render -- ^The 'Render' to identify.+ -> Render+renderAddr = Addressed++-- |Create a 'Render' representing a collection of renders which+-- should be combined in the specified 'Orientation'.+renderMany :: Orientation -> [Render] -> Render+renderMany = Many++-- |Compute the width, in columns, of a 'Render'.+renderWidth :: Render -> Word+renderWidth (Img img) = image_width img+renderWidth (Addressed _ w) = renderWidth w+renderWidth (Many Vertical ws) = maximum $ map renderWidth ws+renderWidth (Many Horizontal ws) = sum $ map renderWidth ws++-- |Compute the height, in rows, of a 'Render'.+renderHeight :: Render -> Word+renderHeight (Img img) = image_height img+renderHeight (Addressed _ w) = renderHeight w+renderHeight (Many Vertical ws) = sum $ map renderHeight ws+renderHeight (Many Horizontal ws) = maximum $ map renderHeight ws++-- |Given a starting position (usually @'DisplayRegion' 0 0@) and a+-- 'Render', combine the 'Render''s contents into a single 'Image' and+-- track the positions and sizes of any 'Render's with positioning+-- addresses. Returns the resulting image and a 'RenderState'+-- containing the 'Address' values of all addressable widgets.+doPositioning :: DisplayRegion -> Render -> State RenderState Image+doPositioning _ (Img img) = return img+doPositioning _ (Many Vertical []) = error "got empty rendered list"+doPositioning _ (Many Horizontal []) = error "got empty rendered list"++doPositioning pos (Many Vertical widgets) = do+ let positionNext _ [] = return $ vert_cat []+ positionNext p (w:ws) = do+ img <- doPositioning p w+ let newPos = p `withHeight` (region_height p + image_height img)+ n <- positionNext newPos ws+ return (img <-> n)++ positionNext pos widgets++doPositioning pos (Many Horizontal widgets) = do+ let positionNext _ [] = return $ horiz_cat []+ positionNext p (w:ws) = do+ img <- doPositioning p w+ let newPos = p `withWidth` (region_width p + image_width img)+ n <- positionNext newPos ws+ return (img <|> n)++ positionNext pos widgets++doPositioning pos (Addressed s w) = do+ img <- doPositioning pos w+ addAddress s pos img+ return img++-- |Retrieve the rendering address for a given widget. To annotate a+-- widget to induce storage of its address, use 'addressable'.+address :: String -> RenderState -> Maybe Address+address = Map.lookup++-- |Add an address for the specified identifier, position, and 'Image'+-- to the 'RenderState'.+addAddress :: String -- ^The 'Address' identifier.+ -> DisplayRegion -- ^The position of the image.+ -> Image -- ^The image whose size should be stored.+ -> State RenderState ()+addAddress ident pos img = do+ let rinfo = Address pos (imageSize img)+ modify (Map.insert ident rinfo)++-- |Compute the size of an 'Image' as a 'DisplayRegion'.+imageSize :: Image -> DisplayRegion+imageSize img = DisplayRegion (image_width img) (image_height img)++-- |Given a 'Widget' and a 'Vty' object, render the widget using the+-- current size of the terminal controlled by Vty. Returns the+-- rendered 'Widget' as an 'Image' along with the 'RenderState'+-- containing the 'Address'es of 'addressable' widgets.+mkImage :: Vty -> Widget -> IO (Image, RenderState)+mkImage vty w = do+ size <- display_bounds $ terminal vty+ let upperLeft = DisplayRegion 0 0+ return $ mkImageSize upperLeft size w++mkImageSize :: DisplayRegion -> DisplayRegion -> Widget+ -> (Image, RenderState)+mkImageSize position size w =+ let rendered = render w size+ in runState (doPositioning position rendered) (Map.fromList [])++-- |Modify the width component of a 'DisplayRegion'.+withWidth :: DisplayRegion -> Word -> DisplayRegion+withWidth (DisplayRegion _ h) w = DisplayRegion w h++-- |Modify the height component of a 'DisplayRegion'.+withHeight :: DisplayRegion -> Word -> DisplayRegion+withHeight (DisplayRegion w _) h = DisplayRegion w h
+ src/Graphics/Vty/Widgets/Text.hs view
@@ -0,0 +1,151 @@+-- |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 'simpleText'; if you want access to+-- the 'Text' for formatting purposes, use 'prepareText' followed by+-- 'textWidget'.+module Graphics.Vty.Widgets.Text+ ( Text(defaultAttr, tokens)+ , Formatter+ -- *Text Preparation+ , prepareText+ -- *Constructing Widgets+ , simpleText+ , textWidget+ -- *Formatting+ , (&.&)+ , highlight+ , wrap+ )+where++import Data.Maybe+ ( isJust+ )+import Graphics.Vty+ ( Attr+ , DisplayRegion+ , string+ , def_attr+ , horiz_cat+ , region_width+ , region_height+ )+import Graphics.Vty.Widgets.Rendering+ ( Widget(..)+ , Render+ , Orientation(Vertical)+ , renderMany+ , renderImg+ )+import Text.Trans.Tokenize+ ( Token(..)+ , tokenize+ , withAnnotation+ , truncLine+ , wrapLine+ )+import Text.Regex.PCRE.Light.Char8+ ( Regex+ , match+ , exec_anchored+ )++-- |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+-- 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++-- |Formatter composition: @a &.& b@ applies @a@ followed by @b@.+(&.&) :: Formatter -> Formatter -> Formatter+f1 &.& f2 = \sz -> f2 sz . f1 sz++nullFormatter :: Formatter+nullFormatter = const id++-- |'Text' represents a 'String' that can be manipulated with+-- 'Formatter's at rendering time.+data Text = Text { defaultAttr :: Attr+ -- ^The default attribute for all tokens in this text+ -- object.+ , tokens :: [[Token Attr]]+ -- ^The tokens of the underlying text stream.+ }++-- |Prepare a string for rendering and assign it the specified default+-- attribute.+prepareText :: Attr -> String -> Text+prepareText att s = Text { defaultAttr = att+ , tokens = tokenize s att+ }++-- |Construct a Widget directly from an attribute and a String. This+-- is recommended if you don't need to use a 'Formatter'.+simpleText :: Attr -> String -> Widget+simpleText a s = textWidget nullFormatter $ prepareText a s++-- |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+ newTokens = concatMap (wrapLine attr width) $ tokens t+ attr = defaultAttr t+ width = fromEnum $ region_width sz++-- |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+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++-- |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]++-- |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).+textWidget :: Formatter -> Text -> Widget+textWidget formatter t = Widget {+ growHorizontal = False+ , growVertical = False+ , primaryAttribute = defaultAttr t+ , withAttribute =+ \att -> textWidget formatter $ newText att+ , render = renderText t formatter+ }+ where+ newText att = t { tokens = map (map (`withAnnotation` att)) $ tokens t }++-- |Low-level text-rendering routine.+renderText :: Text -> Formatter -> DisplayRegion -> Render+renderText t formatter sz =+ if region_height sz == 0+ then renderImg nullImg+ else if null ls || all null ls+ then renderImg nullImg+ else renderMany Vertical $ take (fromEnum $ region_height sz) lineImgs+ where+ -- Truncate the tokens at the specified column and split them up+ -- into lines+ lineImgs = map (renderImg . mkLineImg) ls+ ls = map truncateLine $ tokens newText+ truncateLine = truncLine (fromEnum $ region_width sz)+ newText = formatter sz t+ mkLineImg line = if null line+ then string (defaultAttr newText) " "+ else horiz_cat $ map mkTokenImg line+ nullImg = string def_attr ""+ mkTokenImg tok = string (tokenAnnotation tok) (tokenString tok)
− src/Graphics/Vty/Widgets/WrappedText.hs
@@ -1,47 +0,0 @@--- |This module provides a widget which automatically wraps text in--- the available space. To create a 'WrappedText', see 'wrappedText'.-module Graphics.Vty.Widgets.WrappedText- ( WrappedText- , wrappedText- )-where--import Text.Trans.Wrap ( wrap )-import Graphics.Vty- ( Attr- , region_width- , region_height- , vert_cat- )-import Graphics.Vty.Widgets.Base- ( Widget(..)- , text- , hFill- , anyWidget- )---- |A text widget which automatically wraps its contents to fit in the--- available space.-data WrappedText = WrappedText Attr String---- |Create a 'WrappedText' widget from the specified attribute and--- text.-wrappedText :: Attr -> String -> WrappedText-wrappedText = WrappedText--instance Widget WrappedText where- growHorizontal _ = True- growVertical _ = False-- primaryAttribute (WrappedText att _) = att-- withAttribute (WrappedText _ t) att = WrappedText att t-- render s (WrappedText attr str) =- let images = map (render s . convert) $ lines wrapped- wrapped = wrap (fromEnum $ region_width s) str- -- Convert empty lines into hFills because otherwise Vty- -- will collapse them.- convert [] = anyWidget $ hFill attr ' ' 1- convert line = anyWidget $ text attr line- in vert_cat $ take (fromEnum $ region_height s) images
+ src/Text/Trans/Tokenize.hs view
@@ -0,0 +1,122 @@+{-# 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'.+module Text.Trans.Tokenize+ ( tokenize+ , serialize+ , withAnnotation+ , truncLine+ , isWhitespace+ , wrapLine+#ifdef TESTING+ , Token(..)+#else+ , Token+ , tokenString+ , tokenAnnotation+#endif+ )+where++import Data.List+ ( inits+ , intercalate+ , splitAt+ )++-- |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 (Show, Eq)++-- |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++wsChars :: [Char]+wsChars = [' ', '\t']++isWs :: Char -> Bool+isWs = (`elem` wsChars)++-- |Tokenize a string using a default annotation value.+tokenize :: String -> a -> [[Token a]]+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++-- |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++-- |Is the token whitespace?+isWhitespace :: Token a -> Bool+isWhitespace (Whitespace _ _) = True+isWhitespace _ = False++-- |Given a list of tokens, truncate the list so that its underlying+-- string representation does not exceed the specified column width.+-- Note that this does not truncate /within/ a token; it merely+-- returns the largest sublist of tokens that has the required length.+truncLine :: Int -> [Token a] -> [Token a]+truncLine width ts = take (length $ head passing) ts+ where+ lengths = map (length . tokenString) ts+ cases = reverse $ inits lengths+ passing = dropWhile ((> width) . sum) cases++-- |Given a list of tokens without Newlines, (potentially) wrap the+-- list to the specified column width, using the specified default+-- annotation.+wrapLine :: (Eq a) => a -> Int -> [Token a] -> [[Token a]]+wrapLine _ _ [] = []+wrapLine def 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 these : wrapLine def width those+ 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'
− src/Text/Trans/Wrap.hs
@@ -1,35 +0,0 @@--- |This module provides text-wrapping functionality.-module Text.Trans.Wrap- ( wrap- , wrapLine- )-where--import Data.List ( intercalate )---- |Given a position @p@ and string @s@, find the greatest string--- index @i@ such that @i <= p@ and @s !! i@ is whitespace, or zero if--- the string contains no whitespace.-findBreak :: Int -> String -> Int-findBreak 0 _ = 0-findBreak pos str = if str !! pos `elem` " \t"- then pos- else findBreak (pos - 1) str---- |Given a column and string not containing newlines, break the--- string into lines each having @length <= cols@.-wrapLine :: Int -> String -> [String]-wrapLine cols str- | length str <= cols = [str]- | otherwise = let breakpoint = findBreak cols str- first = take breakpoint str- rest = drop (breakpoint + 1) str- in if breakpoint /= 0- then first:(wrapLine cols rest)- else [str]---- |Wraps the specified string (possibly containing newlines) at the--- specified column and returns a new string with newlines inserted--- where appropriate.-wrap :: Int -> String -> String-wrap cols s = intercalate "\n" $ concat $ map (wrapLine cols) $ lines s
+ test/TestDriver.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import System.Exit ( exitFailure, exitSuccess )++import Data.Word ( Word8 )+import Data.Char ( isPrint )+import Test.QuickCheck+import Test.QuickCheck.Test+import Control.Applicative ( (<$>), (<*>), pure )++import Graphics.Vty+import Graphics.Vty.Widgets.Text+import Graphics.Vty.Widgets.Rendering++import Text.Trans.Tokenize++instance (Arbitrary a, Eq a) => Arbitrary (MaybeDefault a) where+ arbitrary = oneof [ pure Default+ , pure KeepCurrent+ , SetTo <$> arbitrary+ ]++instance Arbitrary Word8 where+ arbitrary = toEnum <$> choose (0, 255)++instance Arbitrary Color where+ arbitrary = oneof [ ISOColor <$> arbitrary+ , Color240 <$> arbitrary+ ]++instance Arbitrary Attr where+ arbitrary = Attr <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary DisplayRegion where+ arbitrary = DisplayRegion <$> coord <*> coord+ where+ coord = sized $ \n -> fromIntegral <$> choose (0, n)++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'++toImage :: DisplayRegion -> Widget -> Image+toImage sz w = fst $ mkImageSize upperLeft sz w+ where upperLeft = DisplayRegion 0 0++textSize :: Property+textSize =+ property $ forAll textString $ \str attr sz ->+ let img = toImage sz $ simpleText attr str+ in+ if null str || region_height sz == 0 || region_width sz == 0+ then image_height img == 0 && image_width img == 0+ else image_width img <= (toEnum $ length str) && image_height img <= 1++imageSize :: Widget -> DisplayRegion -> Bool+imageSize w sz =+ image_width img <= region_width sz && image_height img <= region_height sz+ where+ img = toImage sz w++textString :: Gen String+textString = listOf (arbitrary `suchThat` (\c -> isPrint c && c /= '\n'))++tokenGen :: Gen [[Token ()]]+tokenGen = listOf $ listOf arbitrary++tests :: [Property]+tests = [ textSize+ , property $ forAll textString $+ \str attr -> imageSize (simpleText attr str)+ -- Round-trip property for token serialization and string+ -- tokenization.+ , property $ forAll tokenGen $+ \ts -> serialize ts == (serialize $ tokenize (serialize ts) ())+ ]++main :: IO ()+main = do+ results <- mapM quickCheckResult tests+ if all isSuccess results then+ exitSuccess else+ exitFailure
vty-ui.cabal view
@@ -1,13 +1,14 @@ Name: vty-ui-Version: 0.2+Version: 0.3 Synopsis: A user interface composition library for Vty Description: An extensible library of user interface widgets for composing and laying out Vty user interfaces.- This library provides a collection of widgets and- a type class for rendering widgets to Vty Images.- This library is intended to make non-trivial user- interfaces trivial to express and modify without- having to worry about terminal size.+ This library provides a collection of primitives+ for building and composing widgets and creating+ Vty Images. This library is intended to make+ non-trivial user interfaces trivial to express+ and modify without having to worry about terminal+ size. Category: User Interfaces Author: Jonathan Daugherty <drcygnus@gmail.com> Maintainer: Jonathan Daugherty <drcygnus@gmail.com>@@ -15,26 +16,48 @@ License: BSD3 License-File: LICENSE Cabal-Version: >= 1.2-Homepage: http://repos.codevine.org/vty-ui/+Homepage: http://codevine.org/vty-ui/ +Flag testing+ Description: Build for testing+ Default: False+ Library Build-Depends: base >= 4 && < 5,- vty >= 4.0 && < 4.1+ vty >= 4.0 && < 4.1,+ containers >= 0.2 && < 0.3,+ pcre-light >= 0.3 && < 0.4 + GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: Graphics.Vty.Widgets.All+ Graphics.Vty.Widgets.Text+ Graphics.Vty.Widgets.Rendering Graphics.Vty.Widgets.Composed Graphics.Vty.Widgets.Base Graphics.Vty.Widgets.List- Graphics.Vty.Widgets.WrappedText Graphics.Vty.Widgets.Borders Other-Modules:- Text.Trans.Wrap+ Text.Trans.Tokenize +Executable vty-ui-tests+ Build-Depends:+ QuickCheck >= 2.1 && < 2.2++ CPP-Options: -DTESTING+ GHC-Options: -Wall++ if !flag(testing)+ Buildable: False+ end+ Hs-Source-Dirs: src,test+ Main-is: TestDriver.hs+ Executable vty-ui-demo Hs-Source-Dirs: src+ GHC-Options: -Wall Main-is: Demo.hs Build-Depends: mtl >= 1.1 && < 1.2