vty-ui 0.1 → 0.2
raw patch · 10 files changed
+583/−234 lines, 10 files
Files
- LICENSE +1/−1
- src/Demo.hs +74/−39
- src/Graphics/Vty/Widgets/All.hs +15/−0
- src/Graphics/Vty/Widgets/Base.hs +136/−125
- src/Graphics/Vty/Widgets/Borders.hs +88/−0
- src/Graphics/Vty/Widgets/Composed.hs +22/−0
- src/Graphics/Vty/Widgets/List.hs +155/−68
- src/Graphics/Vty/Widgets/WrappedText.hs +47/−0
- src/Text/Trans/Wrap.hs +35/−0
- vty-ui.cabal +10/−1
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009, Josh Hoyt.+Copyright (c) 2009, Jonathan Daugherty. All rights reserved. Redistribution and use in source and binary forms, with or without
src/Demo.hs view
@@ -2,18 +2,23 @@ import Data.Maybe ( fromJust ) import Control.Applicative ( (<$>) )+import Control.Monad ( when ) import Control.Monad.Trans ( liftIO )-import Control.Monad.State ( StateT, put, get, gets, evalStateT )+import Control.Monad.State ( StateT, get, modify, evalStateT ) -import Graphics.Vty.Widgets.Base-import Graphics.Vty.Widgets.List import Graphics.Vty+import Graphics.Vty.Widgets.All titleAttr :: Attr titleAttr = def_attr `with_back_color` blue `with_fore_color` bright_white +boxAttr :: Attr+boxAttr = def_attr+ `with_back_color` black+ `with_fore_color` bright_yellow+ bodyAttr :: Attr bodyAttr = def_attr `with_back_color` black@@ -24,60 +29,87 @@ `with_back_color` yellow `with_fore_color` black --- Construct the user interface based on the contents of the--- application state.-buildUi :: StateT AppState IO VBox-buildUi = do- list <- gets theList- msgs <- gets theMessages- let body = fromJust $ lookup (getSelected list) msgs- ui = list- <--> hFill titleAttr '-' 1- <--> text bodyAttr body- <--> vFill bodyAttr ' '- <--> footer- footer = text titleAttr "- Status "+buildUi :: AppState -> Bordered+buildUi appst =+ let body = fromJust $ lookup (fst $ getSelected list) msgs+ currentItem = selectedIndex list + 1+ footer = (text titleAttr $ " " ++ (show currentItem) ++ "/" ++ (show $ length msgs) ++ " ") <++> hFill titleAttr '-' 1+ msgs = theMessages appst+ list = theList appst+ in bordered boxAttr $ list+ <--> hBorder titleAttr+ <--> (bottomPadded (wrappedText bodyAttr body))+ <--> footer - return ui+-- Construct the user interface based on the contents of the+-- application state.+uiFromState :: StateT AppState IO Bordered+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+data AppState = AppState { theList :: List String Bordered , theMessages :: [(String, String)] } +scrollListUp :: StateT AppState IO ()+scrollListUp = modify (\appst -> appst { theList = scrollUp $ theList appst })++scrollListDown :: StateT AppState IO ()+scrollListDown = modify (\appst -> appst { theList = scrollDown $ theList appst })++pageListUp :: StateT AppState IO ()+pageListUp = modify (\appst -> appst { theList = pageUp $ theList appst })++pageListDown :: StateT AppState IO ()+pageListDown = modify (\appst -> appst { theList = pageDown $ theList appst })++resizeList :: Int -> StateT AppState IO ()+resizeList s = modify (\appst -> appst { theList = resize s $ theList appst })+ -- Process events from VTY, possibly modifying the application state.-eventloop :: Vty -> StateT AppState IO ()-eventloop vty = do- w <- buildUi+eventloop :: (Widget a) => Vty+ -> StateT AppState IO a+ -> (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- case evt of- -- If we got an up or down arrow key, modify the app state (list- -- widget) and continue processing events.- EvKey KUp [] -> do- appst <- get- put (appst { theList = scrollUp $ theList appst })- eventloop vty- EvKey KDown [] -> do- appst <- get- put (appst { theList = scrollDown $ theList appst })- eventloop vty+ next <- handle evt+ if next then+ eventloop vty uiBuilder handle else+ return () - -- If we get 'q', quit.- EvKey (KASCII 'q') [] -> return ()+continue :: StateT AppState IO Bool+continue = return True - -- Any other key means keep looping (including terminal resize).- _ -> eventloop vty+stop :: StateT AppState IO Bool+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 (KASCII 'q') []) = stop+handleEvent (EvResize _ h) = do+ let newSize = ceiling (0.05 * fromIntegral h)+ when (newSize > 0) $ 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 $ map fst messages+ let list = mkList bodyAttr selAttr 3 borederedLabels+ borederedLabels = zip labels $ map mkWidget labels+ mkWidget = bordered boxAttr . text bodyAttr+ labels = map fst messages in AppState { theList = list , theMessages = messages }@@ -87,7 +119,10 @@ vty <- mkVty -- The data that we'll present in the interface.- let messages = [ ("First", "the first message")+ 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." ) , ("Second", "the second message") , ("Third", "the third message") , ("Fourth", "the fourth message")@@ -96,7 +131,7 @@ , ("Seventh", "the seventh message") ] - evalStateT (eventloop vty) $ mkAppState messages+ evalStateT (eventloop vty uiFromState handleEvent) $ mkAppState messages -- Clear the screen. reserve_display $ terminal vty shutdown vty
+ src/Graphics/Vty/Widgets/All.hs view
@@ -0,0 +1,15 @@+-- |A convenience module exporting everything in this library.+module Graphics.Vty.Widgets.All+ ( 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+ )+where++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
src/Graphics/Vty/Widgets/Base.hs view
@@ -5,18 +5,15 @@ -- 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', 'VBox'--- and 'vBox').+-- an associated constructor function (e.g., 'Text' and 'text', 'Box'+-- and 'vBox' / 'hBox'). module Graphics.Vty.Widgets.Base ( Widget(..)- , GrowthPolicy(..) , mkImage , AnyWidget , Text- , HBox- , VBox- , HFill- , VFill+ , Box+ , Fill , (<++>) , (<-->) , anyWidget@@ -31,144 +28,156 @@ 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 )---- |The growth policy of a widget determines how its container will--- reserve space to render it.-data GrowthPolicy = Static- -- ^'Static' widgets have a fixed size that is not- -- influenced by available space- | GrowVertical- -- ^'GrowVertical' widgets may grow vertically with- -- available space- | GrowHorizontal- -- ^'GrowHorizontal' widgets may grow horizontally- -- with available space- deriving (Show, Eq)+ , string, char_fill, image_width, image_height+ , region_width, region_height, terminal+ , display_bounds, vert_cat, horiz_cat ) --- |The class of user interface widgets.+-- |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 - -- |The growth policy of this widget.- growthPolicy :: w -> GrowthPolicy+ -- |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 --- |A vertical fill widget for filling available vertical space in a--- box layout. See 'vFill'.-data VFill = VFill Attr Char+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 horizontal fill widget for filling available horizontal space in--- a box layout. See 'hFill'.-data HFill = HFill Attr Char Int+-- |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 --- |A vertical box layout widget capable of containing two 'Widget's.--- See 'vBox'.-data VBox = forall a b. (Widget a, Widget b) => VBox a b+instance Widget Fill where+ growHorizontal (HFill _ _ _) = True+ growHorizontal (VFill _ _) = False --- |A horizontal box layout widget capable of containing two--- 'Widget's. See 'hBox'.-data HBox = forall a b. (Widget a, Widget b) => HBox a b+ growVertical (VFill _ _) = True+ growVertical (HFill _ _ _) = False -instance Widget AnyWidget where- growthPolicy (AnyWidget w) = growthPolicy w- render s (AnyWidget w) = render s w+ primaryAttribute (HFill att _ _) = att+ primaryAttribute (VFill att _) = att -instance Widget Text where- growthPolicy _ = Static- render _ (Text att content) = string att content+ withAttribute (HFill _ c h) att = HFill att c h+ withAttribute (VFill _ c) att = VFill att c -instance Widget VFill where- growthPolicy _ = GrowVertical- render s (VFill att c) = char_fill att c (width s) (height s)+ 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) -instance Widget HFill where- growthPolicy _ = Static- render s (HFill att c h) = char_fill att c (width s) (toEnum h)+data Orientation = Horizontal | Vertical -instance Widget VBox where- growthPolicy (VBox top bottom) =- if t == GrowVertical- then t else growthPolicy bottom- where t = growthPolicy top+-- |A box layout widget capable of containing two 'Widget's+-- horizontally or vertically. See 'hBox' and 'vBox'. Boxes lay out+-- their children as follows:+--+-- * If both children are expandable in the same dimension (i.e., both+-- vertically or both horizontally), the children are each given+-- half of the parent container's available space+--+-- * If one of the children is expandable and the other is static, the+-- static child is rendered first and the remaining space is given+-- to the expandable child+--+-- * 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 - render s (VBox top bottom) =- t <-> b- where- renderHalves = let half = s `withHeight` div (height s) 2- half' = if height s `mod` 2 == 0- then half- else region (width half) (height half + 1)- in ( render half top- , render half' bottom )- renderTopFirst = let renderedTop = render s top- renderedBottom = render s' bottom- s' = s `withHeight` (height s - image_height renderedTop)- in (renderedTop, renderedBottom)- renderBottomFirst = let renderedTop = render s' top- renderedBottom = render s bottom- s' = s `withHeight` (height s - image_height renderedBottom)- in (renderedTop, renderedBottom)- (t, b) = case (growthPolicy top, growthPolicy bottom) of- (GrowVertical, GrowVertical) -> renderHalves- (Static, _) -> renderTopFirst- (_, Static) -> renderBottomFirst- -- Horizontal contents take precedence- (GrowHorizontal, _) -> renderTopFirst- (_, GrowHorizontal) -> renderBottomFirst+instance Widget Box where+ growHorizontal (Box _ a b) =+ growHorizontal a || growHorizontal b -instance Widget HBox where- growthPolicy (HBox left right) =- if l == GrowHorizontal- then l else growthPolicy right- where l = growthPolicy left+ growVertical (Box _ a b) =+ growVertical a || growVertical b - render s (HBox left right) =- t <|> b- where- renderHalves = let half = s `withWidth` div (width s) 2- half' = if width s `mod` 2 == 0- then half- else region (width half + 1) (height half)- in ( render half left- , render half' right )- renderLeftFirst = let renderedLeft = render s left- renderedRight = render s' right- s' = region (width s - image_width renderedLeft)- (image_height renderedLeft)- in (renderedLeft, renderedRight)- renderRightFirst = let renderedLeft = render s' left- renderedRight = render s right- s' = region (width s - image_width renderedRight)- (image_height renderedRight)- in (renderedLeft, renderedRight)- (t, b) = case (growthPolicy left, growthPolicy right) of- (GrowHorizontal, GrowHorizontal) -> renderHalves- (Static, _) -> renderLeftFirst- (_, Static) -> renderRightFirst- (GrowVertical, GrowVertical) -> renderHalves- (_, _) -> renderLeftFirst+ withAttribute (Box o top bottom) att = Box o+ (withAttribute top att)+ (withAttribute bottom att) -width :: DisplayRegion -> Word-width = region_width+ -- Not the best way to choose this, but it seems like anything+ -- here is going to be arbitrary.+ primaryAttribute (Box _ top _) = primaryAttribute top -height :: DisplayRegion -> Word-height = region_height+ 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 -region :: Word -> Word -> DisplayRegion-region = DisplayRegion+-- 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+ -> (DisplayRegion -> Word) -- region dimension fetch function+ -> (Image -> Word) -- image dimension fetch function+ -> (DisplayRegion -> Word -> DisplayRegion) -- dimension modification function+ -> Image+renderBox s (first, second) grow concatenate regDimension imgDimension withDim =+ concatenate ws+ where+ ws = case (grow $ anyWidget first, grow $ anyWidget second) of+ (True, True) -> renderHalves+ (False, _) -> renderOrdered first second+ (_, False) -> let [a, b] = renderOrdered second first+ in [b, a]+ renderHalves = let half = s `withDim` div (regDimension s) 2+ 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+ s' = s `withDim` remaining+ in if imgDimension renderedA >= regDimension s+ then [renderedA]+ else [renderedA, renderedB] withWidth :: DisplayRegion -> Word -> DisplayRegion withWidth (DisplayRegion _ h) w = DisplayRegion w h@@ -200,14 +209,14 @@ -> Char -- ^The character to fill -> Int -- ^The height, in rows, of the filled area; width of the -- fill depends on available space- -> HFill+ -> 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- -> VFill+ -> Fill vFill = VFill -- |Create a horizontal box layout widget containing two widgets side@@ -215,20 +224,22 @@ -- the available space. hBox :: (Widget a, Widget b) => a -- ^The left widget -> b -- ^The right widget- -> HBox-hBox = HBox+ -> Box+hBox = Box Horizontal -- |An alias for 'hBox' intended as sugar to chain widgets -- horizontally.-(<++>) :: (Widget a, Widget b) => a -> b -> HBox-(<++>) = HBox+(<++>) :: (Widget a, Widget b) => a -> b -> Box+(<++>) = 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 -> b -> VBox-vBox = VBox+vBox :: (Widget a, Widget b) => a -- ^The top widget+ -> b -- ^The bottom widget+ -> Box+vBox = Box Vertical -- |An alias for 'vBox' intended as sugar to chain widgets vertically.-(<-->) :: (Widget a, Widget b) => a -> b -> VBox-(<-->) = VBox+(<-->) :: (Widget a, Widget b) => a -> b -> Box+(<-->) = vBox
+ src/Graphics/Vty/Widgets/Borders.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE ExistentialQuantification #-}+-- |This module provides visual borders to be placed between and+-- around widgets.+module Graphics.Vty.Widgets.Borders+ ( Border+ , Bordered+ , vBorder+ , hBorder+ , bordered+ )+where++import Graphics.Vty+ ( Attr+ , DisplayRegion(DisplayRegion)+ , (<|>)+ , char_fill+ , region_height+ , region_width+ , image_width+ , image_height+ , vert_cat+ )+import Graphics.Vty.Widgets.Base+ ( Widget(..)+ , (<++>)+ , text+ )++-- |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++-- |Create a single-row horizontal border.+hBorder :: Attr -> Border+hBorder = HBorder++-- |Create a single-column vertical border.+vBorder :: Attr -> Border+vBorder = VBorder++-- |Wrap a widget in a bordering box using the specified attribute.+bordered :: (Widget a) => Attr -> a -> Bordered+bordered = Bordered
+ src/Graphics/Vty/Widgets/Composed.hs view
@@ -0,0 +1,22 @@+-- |This module provides high-level "combined" widgets which compose+-- the basic widget types to provide more interesting widgets.+module Graphics.Vty.Widgets.Composed+ ( bottomPadded+ , topPadded+ )+where++import Graphics.Vty.Widgets.Base+ ( Widget(..)+ , (<-->)+ , vFill+ , Box+ )++-- |Add expanding bottom padding to a widget.+bottomPadded :: (Widget a) => a -> Box+bottomPadded w = w <--> vFill (primaryAttribute w) ' '++-- |Add expanding top padding to a widget.+topPadded :: (Widget a) => a -> Box+topPadded w = vFill (primaryAttribute w) ' ' <--> w
src/Graphics/Vty/Widgets/List.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE ExistentialQuantification #-} -- |This module provides a 'List' widget for rendering a list of--- single-line strings. A 'List' has the following features:+-- arbitrary widgets. A 'List' has the following features: -- -- * A style for the list elements --@@ -10,96 +11,175 @@ -- -- * An internal pointer to the start of the visible window, which -- automatically shifts as the list is scrolled------ To create a list, see 'mkList'. To modify the list's state, see--- 'scrollDown' and 'scrollUp'. To inspect the list, see, see--- 'getSelected' and 'getVisibleItems'. module Graphics.Vty.Widgets.List ( List+ , SimpleList+ , ListItem+ -- ** List creation , mkList- , scrollDown+ , mkSimpleList+ -- ** List manipulation+ , scrollBy , scrollUp+ , scrollDown+ , pageUp+ , pageDown+ , resize+ -- ** List inspection+ , listItems , getSelected+ , selectedIndex+ , scrollTopIndex+ , scrollWindowSize , getVisibleItems ) where -import Graphics.Vty ( Attr, (<->) )+import Graphics.Vty ( Attr, vert_cat ) import Graphics.Vty.Widgets.Base ( Widget(..)+ , Text , text- , GrowthPolicy(Static)+ , anyWidget+ , hFill ) --- |The list widget type.-data List = List { normalAttr :: Attr- , selectedAttr :: Attr- , selectedIndex :: Int- , scrollTopIndex :: Int- , scrollWindowSize :: Int- , listItems :: [String]- }+-- |A list item. Each item contains an arbitrary internal identifier+-- @a@ and a widget @b@ representing it.+type ListItem a b = (a, b) --- |Create a new list. Emtpy lists are not allowed.-mkList :: Attr -- ^The attribute of normal, non-selected items+-- |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++-- |Create a new list. Emtpy lists and empty scrolling windows are+-- not allowed.+mkList :: (Widget b) =>+ 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- -> [String] -- ^The list items- -> List+ -> [ListItem a b] -- ^The list items+ -> List a b mkList _ _ _ [] = error "Lists cannot be empty"-mkList normAttr selAttr swSize contents = List normAttr selAttr 0 0 swSize contents+mkList normAttr selAttr swSize contents+ | swSize <= 0 = error "Scrolling window size must be > 0"+ | otherwise = List normAttr selAttr 0 0 swSize contents +-- |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+ -> 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+ -> [String] -- ^The list items+ -> SimpleList+mkSimpleList normAttr selAttr swSize labels =+ mkList normAttr selAttr swSize widgets+ where+ widgets = map (\l -> (l, text 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 -> String+getSelected :: List a b -> ListItem a b getSelected list = (listItems list) !! (selectedIndex list) --- |Scroll a list down one position and return the new scrolled list.--- This automatically takes care of managing all list state:------ * Moves the cursor down one position, unless the cursor is already--- in the last position (in which case this does nothing)------ * Moves the scrolling window position if necessary (i.e., if the--- cursor moves to an item not currently in view)-scrollDown :: List -> List-scrollDown list- -- If the list is already at the last position, do nothing.- | selectedIndex list == length (listItems list) - 1 = list- -- If the list requires scrolling the visible area, scroll it.- | selectedIndex list == scrollTopIndex list + scrollWindowSize list - 1 =- list { selectedIndex = selectedIndex list + 1- , scrollTopIndex = scrollTopIndex list + 1- }- -- Otherwise, just increment the selectedIndex.- | otherwise = list { selectedIndex = selectedIndex list + 1 }+-- |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 newSize list+ | newSize == 0 = error "Cannot resize list window to zero"+ -- Do nothing if the window size isn't changing.+ | newSize == scrollWindowSize list = list+ -- If the new window size is larger, just set it.+ | newSize > scrollWindowSize list = list { scrollWindowSize = newSize }+ -- Otherwise it's smaller, so we need to look at which item is+ -- selected and decide whether to change the scrollTopIndex.+ | otherwise = list { scrollWindowSize = newSize+ , selectedIndex = newSelected+ }+ where+ newBottomPosition = scrollTopIndex list + newSize - 1+ current = selectedIndex list+ newSelected = if current > newBottomPosition+ then newBottomPosition+ else current --- |Scroll a list up one position and return the new scrolled list.--- This automatically takes care of managing all list state:+-- |Scroll a list up or down by the specified number of positions and+-- return the new scrolled list. Scrolling by a positive amount+-- scrolls downward and scrolling by a negative amount scrolls upward.+-- This automatically takes care of managing internal list state: ----- * Moves the cursor up one position, unless the cursor is already--- in the first position (in which case this does nothing)+-- * Moves the cursor by the specified amount and clamps the cursor+-- position to the beginning or the end of the list where+-- appropriate -- -- * Moves the scrolling window position if necessary (i.e., if the -- cursor moves to an item not currently in view)-scrollUp :: List -> List-scrollUp list- -- If the list is already at the first position, do nothing.- | selectedIndex list == 0 = list- -- If the list requires scrolling the visible area, scroll it.- | selectedIndex list == scrollTopIndex list =- list { selectedIndex = selectedIndex list - 1- , scrollTopIndex = scrollTopIndex list - 1- }- -- Otherwise, just decrement the selectedIndex.- | otherwise = list { selectedIndex = selectedIndex list - 1 }+scrollBy :: Int -> List a b -> List a b+scrollBy amount list =+ list { scrollTopIndex = adjustedTop+ , selectedIndex = newSelected }+ where+ sel = selectedIndex list+ lastPos = (length $ listItems list) - 1+ validPositions = [0..lastPos]+ newPosition = sel + amount + newSelected = if newPosition `elem` validPositions+ then newPosition+ else if newPosition > lastPos+ then lastPos+ else 0++ bottomPosition = scrollTopIndex list + scrollWindowSize list - 1+ topPosition = scrollTopIndex list+ windowPositions = [topPosition..bottomPosition]++ adjustedTop = if newPosition `elem` windowPositions+ then topPosition+ else if newSelected >= bottomPosition+ then newSelected - scrollWindowSize list + 1+ else newSelected++-- |Scroll a list down by one position.+scrollDown :: List a b -> List a b+scrollDown = scrollBy 1++-- |Scroll a list up by one position.+scrollUp :: List a b -> List a b+scrollUp = scrollBy (-1)++-- |Scroll a list down by one page from the current cursor position.+pageDown :: List a b -> List a b+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 = 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 -> [(String, Bool)]+getVisibleItems :: List a b -> [(ListItem a b, Bool)] getVisibleItems list = let start = scrollTopIndex list stop = scrollTopIndex list + scrollWindowSize list@@ -107,16 +187,23 @@ in [ (listItems list !! i, i == selectedIndex list) | i <- [start..adjustedStop] ] -instance Widget List where- -- Statically sized, because we know how many items should be- -- visible.- growthPolicy _ = Static+instance (Widget b) => Widget (List a b) where+ growHorizontal _ = False+ growVertical _ = False - render s w =- foldl (<->) (head widgets) (tail widgets)+ withAttribute w att = w { normalAttr = att }++ primaryAttribute = normalAttr++ render s list =+ vert_cat images where- widgets = map (render s . mkWidget) (getVisibleItems w)- mkWidget (str, selected) = let att = if selected- then selectedAttr- else normalAttr- in text (att w) str+ 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/WrappedText.hs view
@@ -0,0 +1,47 @@+-- |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/Wrap.hs view
@@ -0,0 +1,35 @@+-- |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
vty-ui.cabal view
@@ -1,10 +1,13 @@ Name: vty-ui-Version: 0.1+Version: 0.2 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. Category: User Interfaces Author: Jonathan Daugherty <drcygnus@gmail.com> Maintainer: Jonathan Daugherty <drcygnus@gmail.com>@@ -21,8 +24,14 @@ Hs-Source-Dirs: src Exposed-Modules:+ Graphics.Vty.Widgets.All+ 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 Executable vty-ui-demo Hs-Source-Dirs: src