Merge pull request #90 from kquick/master

Added mapAttrname, mapAttrNames, overrideAttr, and progress bar demo

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

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

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

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

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