From 7fcf3e68e9b1ae6e7496fdf8a0b5726785ad27fd Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Wed, 26 Oct 2016 22:43:48 -0700 Subject: [PATCH] Added mapAttrname, mapAttrNames, and overrideAttr functions, with ProgressBarDemo to demonstrate their usage. --- brick.cabal | 15 ++++++ docs/guide.rst | 7 +++ programs/ProgressBarDemo.hs | 104 ++++++++++++++++++++++++++++++++++++ src/Brick/AttrMap.hs | 17 ++++++ src/Brick/Widgets/Core.hs | 8 +++ 5 files changed, 151 insertions(+) create mode 100644 programs/ProgressBarDemo.hs diff --git a/brick.cabal b/brick.cabal index 402e338..8ffa441 100644 --- a/brick.cabal +++ b/brick.cabal @@ -297,3 +297,18 @@ executable brick-border-demo data-default, text, microlens + +executable brick-progressbar-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-extensions: CPP + default-language: Haskell2010 + main-is: ProgressBarDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.5.0, + data-default, + text, + microlens diff --git a/docs/guide.rst b/docs/guide.rst index f00a7dd..453d2d6 100644 --- a/docs/guide.rst +++ b/docs/guide.rst @@ -670,6 +670,7 @@ map combinators: * ``Brick.Widgets.Core.updateAttrMap`` * ``Brick.Widgets.Core.forceAttr`` * ``Brick.Widgets.Core.withDefAttr`` +* ``Brick.Widgets.Core.overrideAttr`` Viewports ========= @@ -938,6 +939,12 @@ widgets. If you don't want to crop in this way, you can use any of ``vty``'s cropping functions to operate on the ``Result`` image as desired. +Sub-widgets may specify specific attribute name values influencing +that sub-widget. If the custom widget utilizes its own attribute +names but needs to render the sub-widget, it can use ``overrideAttr`` +or ``mapAttrNames`` to convert its custom names to the names that the +sub-widget uses for rendering its output. + .. _vty: https://github.com/coreyoconnor/vty .. _Hackage: http://hackage.haskell.org/ .. _microlens: http://hackage.haskell.org/package/microlens diff --git a/programs/ProgressBarDemo.hs b/programs/ProgressBarDemo.hs new file mode 100644 index 0000000..3984568 --- /dev/null +++ b/programs/ProgressBarDemo.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +-- import Lens.Micro ((^.)) +import Control.Monad (void) +import Data.Monoid +-- import Data.Maybe (fromMaybe) +import qualified Graphics.Vty as V + +import qualified Brick.AttrMap as A +import qualified Brick.Main as M +import qualified Brick.Types as T +import qualified Brick.Widgets.ProgressBar as P +import Brick.Types + ( Widget + ) +import Brick.Widgets.Core + ( (<+>), (<=>) + , str + , updateAttrMap + , overrideAttr + ) +import Brick.Util (fg, bg, on, clamp) + +data MyAppState n = MyAppState { x, y, z :: Float } + +drawUI :: MyAppState () -> [Widget ()] +drawUI p = [ui] + where + -- use mapAttrNames + xBar = updateAttrMap + (A.mapAttrNames [ (xDoneAttr, P.progressCompleteAttr) + , (xToDoAttr, P.progressIncompleteAttr) + ] + ) $ bar $ x p + -- or use individual mapAttrName calls + yBar = updateAttrMap + (A.mapAttrName yDoneAttr P.progressCompleteAttr . + A.mapAttrName yToDoAttr P.progressIncompleteAttr) $ + bar $ y p + -- or use overrideAttr calls + zBar = overrideAttr P.progressCompleteAttr zDoneAttr $ + overrideAttr P.progressIncompleteAttr zToDoAttr $ + bar $ z p + lbl c = Just $ show $ fromEnum $ c * 100 + bar v = P.progressBar (lbl v) v + ui = (str "X: " <+> xBar) <=> + (str "Y: " <+> yBar) <=> + (str "Z: " <+> zBar) <=> + str "" <=> + str "Hit 'x', 'y', or 'z' to advance progress, or 'q' to quit" + + +appEvent :: MyAppState () -> V.Event -> T.EventM () (T.Next (MyAppState ())) +appEvent p e = + let valid = clamp (0.0 :: Float) 1.0 + in case e of + V.EvKey (V.KChar 'x') [] -> M.continue $ p { x = valid $ x p + 0.05 } + V.EvKey (V.KChar 'y') [] -> M.continue $ p { y = valid $ y p + 0.03 } + V.EvKey (V.KChar 'z') [] -> M.continue $ p { z = valid $ z p + 0.02 } + V.EvKey (V.KChar 'q') [] -> M.halt p + _ -> M.continue p + +initialState :: MyAppState () +initialState = MyAppState 0.25 0.18 0.63 + +theBaseAttr :: A.AttrName +theBaseAttr = A.attrName "theBase" + +xDoneAttr, xToDoAttr :: A.AttrName +xDoneAttr = theBaseAttr <> A.attrName "X:done" +xToDoAttr = theBaseAttr <> A.attrName "X:remaining" + +yDoneAttr, yToDoAttr :: A.AttrName +yDoneAttr = theBaseAttr <> A.attrName "Y:done" +yToDoAttr = theBaseAttr <> A.attrName "Y:remaining" + +zDoneAttr, zToDoAttr :: A.AttrName +zDoneAttr = theBaseAttr <> A.attrName "Z:done" +zToDoAttr = theBaseAttr <> A.attrName "Z:remaining" + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (theBaseAttr, bg V.brightBlack) + , (xDoneAttr, V.black `on` V.white) + , (xToDoAttr, V.white `on` V.black) + , (yDoneAttr, V.magenta `on` V.yellow) + , (zDoneAttr, V.blue `on` V.green) + , (zToDoAttr, V.blue `on` V.red) + , (P.progressIncompleteAttr, fg V.yellow) + ] + +theApp :: M.App (MyAppState ()) V.Event () +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return + , M.appAttrMap = const theMap + , M.appLiftVtyEvent = id + } + +main :: IO () +main = void $ M.defaultMain theApp initialState diff --git a/src/Brick/AttrMap.hs b/src/Brick/AttrMap.hs index 7d69730..6d6878a 100644 --- a/src/Brick/AttrMap.hs +++ b/src/Brick/AttrMap.hs @@ -35,6 +35,8 @@ module Brick.AttrMap , setDefault , applyAttrMappings , mergeWithDefault + , mapAttrName + , mapAttrNames ) where @@ -169,3 +171,18 @@ combineMDs _ v = v applyAttrMappings :: [(AttrName, Attr)] -> AttrMap -> AttrMap applyAttrMappings _ (ForceAttr a) = ForceAttr a applyAttrMappings ms (AttrMap d m) = AttrMap d ((M.fromList ms) `M.union` m) + +-- | Update an attribute map such that a lookup of 'ontoName' returns +-- the attribute value specified by 'fromName'. This is useful for +-- composite widgets with specific attribute names mapping those names +-- to the sub-widget's expected name when calling that sub-widget's +-- rendering function. See the ProgressBarDemo for an example usage, +-- and 'overrideAttr' for an alternate syntax. +mapAttrName :: AttrName -> AttrName -> AttrMap -> AttrMap +mapAttrName fromName ontoName inMap = + applyAttrMappings [(ontoName, attrMapLookup fromName inMap)] inMap + +-- | Map several attributes to return the value associated with an +-- alternate name. Applies 'mapAttrName' across a list of mappings. +mapAttrNames :: [(AttrName, AttrName)] -> AttrMap -> AttrMap +mapAttrNames names inMap = foldr (uncurry mapAttrName) inMap names diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs index 60010e3..d7f753c 100644 --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -35,6 +35,7 @@ module Brick.Widgets.Core , withDefAttr , withAttr , forceAttr + , overrideAttr , updateAttrMap -- * Border style management @@ -481,6 +482,13 @@ forceAttr an p = c <- getContext withReaderT (& ctxAttrMapL .~ (forceAttrMap (attrMapLookup an (c^.ctxAttrMapL)))) (render p) +-- | Override the lookup of 'targetName' to return the attribute value +-- associated with 'fromName' when rendering the specified widget. +-- See also 'mapAttrName'. +overrideAttr :: AttrName -> AttrName -> Widget n -> Widget n +overrideAttr targetName fromName = + updateAttrMap (mapAttrName fromName targetName) + -- | Build a widget directly from a raw Vty image. raw :: V.Image -> Widget n raw img = Widget Fixed Fixed $ return $ def & imageL .~ img