vty-ui (empty) → 0.1
raw patch · 6 files changed
+521/−0 lines, 6 filesdep +basedep +mtldep +vtysetup-changed
Dependencies added: base, mtl, vty
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Demo.hs +102/−0
- src/Graphics/Vty/Widgets/Base.hs +234/−0
- src/Graphics/Vty/Widgets/List.hs +122/−0
- vty-ui.cabal +31/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2009, Josh Hoyt.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of the contributors may not be used to endorse or+ promote products derived from this software without specific+ prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Demo.hs view
@@ -0,0 +1,102 @@+module Main where++import Data.Maybe ( fromJust )+import Control.Applicative ( (<$>) )+import Control.Monad.Trans ( liftIO )+import Control.Monad.State ( StateT, put, get, gets, evalStateT )++import Graphics.Vty.Widgets.Base+import Graphics.Vty.Widgets.List+import Graphics.Vty++titleAttr :: Attr+titleAttr = def_attr+ `with_back_color` blue+ `with_fore_color` bright_white++bodyAttr :: Attr+bodyAttr = def_attr+ `with_back_color` black+ `with_fore_color` bright_green++selAttr :: Attr+selAttr = def_attr+ `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 "+ <++> hFill titleAttr '-' 1++ return ui++-- 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+ , theMessages :: [(String, String)]+ }++-- Process events from VTY, possibly modifying the application state.+eventloop :: Vty -> StateT AppState IO ()+eventloop vty = do+ w <- buildUi+ 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++ -- If we get 'q', quit.+ EvKey (KASCII 'q') [] -> return ()++ -- Any other key means keep looping (including terminal resize).+ _ -> eventloop vty++-- Construct the application state using the message map.+mkAppState :: [(String, String)] -> AppState+mkAppState messages =+ let list = mkList bodyAttr selAttr 3 $ map fst messages+ in AppState { theList = list+ , theMessages = messages+ }++main :: IO ()+main = do+ vty <- mkVty++ -- The data that we'll present in the interface.+ let messages = [ ("First", "the first message")+ , ("Second", "the second message")+ , ("Third", "the third message")+ , ("Fourth", "the fourth message")+ , ("Fifth", "the fifth message")+ , ("Sixth", "the sixth message")+ , ("Seventh", "the seventh message")+ ]++ evalStateT (eventloop vty) $ mkAppState messages+ -- Clear the screen.+ reserve_display $ terminal vty+ shutdown vty
+ src/Graphics/Vty/Widgets/Base.hs view
@@ -0,0 +1,234 @@+{-# 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', 'VBox'+-- and 'vBox').+module Graphics.Vty.Widgets.Base+ ( Widget(..)+ , GrowthPolicy(..)+ , mkImage+ , AnyWidget+ , Text+ , HBox+ , VBox+ , HFill+ , VFill+ , (<++>)+ , (<-->)+ , anyWidget+ , text+ , hBox+ , vBox+ , hFill+ , vFill+ )+where++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)++-- |The class of user interface widgets.+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++-- |A wrapper for all widget types used in normalizing heterogeneous+-- lists of widgets. See 'anyWidget'.+data AnyWidget = forall a. (Widget a) => AnyWidget a++-- |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++-- |A horizontal fill widget for filling available horizontal space in+-- a box layout. See 'hFill'.+data HFill = 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++-- |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++instance Widget AnyWidget where+ growthPolicy (AnyWidget w) = growthPolicy w+ render s (AnyWidget w) = render s w++instance Widget Text where+ growthPolicy _ = Static+ render _ (Text att content) = string att content++instance Widget VFill where+ growthPolicy _ = GrowVertical+ render s (VFill att c) = char_fill att c (width s) (height s)++instance Widget HFill where+ growthPolicy _ = Static+ render s (HFill att c h) = char_fill att c (width s) (toEnum h)++instance Widget VBox where+ growthPolicy (VBox top bottom) =+ if t == GrowVertical+ then t else growthPolicy bottom+ where t = growthPolicy top++ 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 HBox where+ growthPolicy (HBox left right) =+ if l == GrowHorizontal+ then l else growthPolicy right+ where l = growthPolicy left++ 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++width :: DisplayRegion -> Word+width = region_width++height :: DisplayRegion -> Word+height = region_height++region :: Word -> Word -> DisplayRegion+region = DisplayRegion++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+ -> HFill+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+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+ -> HBox+hBox = HBox++-- |An alias for 'hBox' intended as sugar to chain widgets+-- horizontally.+(<++>) :: (Widget a, Widget b) => a -> b -> HBox+(<++>) = 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++-- |An alias for 'vBox' intended as sugar to chain widgets vertically.+(<-->) :: (Widget a, Widget b) => a -> b -> VBox+(<-->) = VBox
+ src/Graphics/Vty/Widgets/List.hs view
@@ -0,0 +1,122 @@+-- |This module provides a 'List' widget for rendering a list of+-- single-line strings. A 'List' has the following features:+--+-- * A style for the list elements+--+-- * A styled cursor indicating which element is selected+--+-- * A /window size/ indicating how many elements should be visible to+-- the user+--+-- * 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+ , mkList+ , scrollDown+ , scrollUp+ , getSelected+ , getVisibleItems+ )+where++import Graphics.Vty ( Attr, (<->) )+import Graphics.Vty.Widgets.Base+ ( Widget(..)+ , text+ , GrowthPolicy(Static)+ )++-- |The list widget type.+data List = List { normalAttr :: Attr+ , selectedAttr :: Attr+ , selectedIndex :: Int+ , scrollTopIndex :: Int+ , scrollWindowSize :: Int+ , listItems :: [String]+ }++-- |Create a new list. Emtpy lists are not allowed.+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+ -> [String] -- ^The list items+ -> List+mkList _ _ _ [] = error "Lists cannot be empty"+mkList normAttr selAttr swSize contents = List normAttr selAttr 0 0 swSize contents++-- 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 = (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 }++-- |Scroll a list up one position and return the new scrolled list.+-- This automatically takes care of managing all 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 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 }++-- |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 =+ 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 List where+ -- Statically sized, because we know how many items should be+ -- visible.+ growthPolicy _ = Static++ render s w =+ foldl (<->) (head widgets) (tail widgets)+ where+ widgets = map (render s . mkWidget) (getVisibleItems w)+ mkWidget (str, selected) = let att = if selected+ then selectedAttr+ else normalAttr+ in text (att w) str
+ vty-ui.cabal view
@@ -0,0 +1,31 @@+Name: vty-ui+Version: 0.1+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.+Category: User Interfaces+Author: Jonathan Daugherty <drcygnus@gmail.com>+Maintainer: Jonathan Daugherty <drcygnus@gmail.com>+Build-Type: Simple+License: BSD3+License-File: LICENSE+Cabal-Version: >= 1.2+Homepage: http://repos.codevine.org/vty-ui/++Library+ Build-Depends:+ base >= 4 && < 5,+ vty >= 4.0 && < 4.1++ Hs-Source-Dirs: src+ Exposed-Modules:+ Graphics.Vty.Widgets.Base+ Graphics.Vty.Widgets.List++Executable vty-ui-demo+ Hs-Source-Dirs: src+ Main-is: Demo.hs+ Build-Depends:+ mtl >= 1.1 && < 1.2