diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/src/Demo.hs b/src/Demo.hs --- a/src/Demo.hs +++ b/src/Demo.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/All.hs b/src/Graphics/Vty/Widgets/All.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/All.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/Base.hs b/src/Graphics/Vty/Widgets/Base.hs --- a/src/Graphics/Vty/Widgets/Base.hs +++ b/src/Graphics/Vty/Widgets/Base.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/Borders.hs b/src/Graphics/Vty/Widgets/Borders.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Borders.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/Composed.hs b/src/Graphics/Vty/Widgets/Composed.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/Composed.hs @@ -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 diff --git a/src/Graphics/Vty/Widgets/List.hs b/src/Graphics/Vty/Widgets/List.hs --- a/src/Graphics/Vty/Widgets/List.hs +++ b/src/Graphics/Vty/Widgets/List.hs @@ -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) diff --git a/src/Graphics/Vty/Widgets/WrappedText.hs b/src/Graphics/Vty/Widgets/WrappedText.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/Widgets/WrappedText.hs @@ -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 diff --git a/src/Text/Trans/Wrap.hs b/src/Text/Trans/Wrap.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trans/Wrap.hs @@ -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 diff --git a/vty-ui.cabal b/vty-ui.cabal --- a/vty-ui.cabal +++ b/vty-ui.cabal @@ -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 Maintainer: Jonathan Daugherty @@ -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