Adds support for attribute mapping

- App now provides appAttrMap which extracts an attribute map from
  the application state.  This enables the application to dictate
  which attributes get used for which things.
- Updates list and edit components to use the attribute map to select
  attributes.
- Updates the markup implementation to support either direct attriubute
  specification or indirect via mapped names.
- Updates the demos to show how to use attribute name maps.
- Renames and adds some core library combinators to support using either
  names or attributes.

brick.cabal

@@ -26,6 +26,7 @@ library
     Brick.Main
     Brick.Markup
     Brick.Render
+    Brick.AttrMap
     Brick.Util
     Data.Text.Markup
   other-modules:
@@ -40,6 +41,7 @@ library
                        containers,
                        lens,
                        vector,
+                       contravariant,
                        text
 
 executable brick

programs/Main.hs

@@ -17,6 +17,7 @@ import Brick.Center
 import Brick.Border
 import Brick.Border.Style
 import Brick.Util
+import Brick.AttrMap
 
 styles :: [(String, BorderStyle)]
 styles =
@@ -35,8 +36,11 @@ data St =
 
 makeLenses ''St
 
+keywordAttr :: AttrName
+keywordAttr = "app" <> "keyword"
+
 kw :: Render -> Render
-kw = withAttr (fg blue)
+kw = withAttrName keywordAttr
 
 drawUI :: St -> [Render]
 drawUI st = [withBorderStyle bs a]
@@ -44,7 +48,7 @@ drawUI st = [withBorderStyle bs a]
         (bsName, bs) = styles !! (st^.stBorderStyle)
         box = borderWithLabel bsName $
                   (hLimit 25 (
-                    (withAttr (cyan `on` blue) $ renderEditor (st^.stEditor))
+                    (renderEditor (st^.stEditor))
                     <=> hBorder
                     <=> (vLimit 10 $ renderList (st^.stList))
                   ))
@@ -86,18 +90,23 @@ initialState =
 
 listDrawElem :: Bool -> Int -> Render
 listDrawElem sel i =
-    let selAttr = white `on` blue
-        maybeSelect = if sel
-                      then withAttr selAttr
-                      else id
-    in maybeSelect $ hCenterWith (Just ' ') $ vBox $ for [1..i+1] $ \j ->
-        (txt $ "Item " <> show i <> " L" <> show j, High)
+    let selStr s = if sel then "<" <> s <> ">" else s
+    in hCenterWith (Just ' ') $ vBox $ for [1..i+1] $ \j ->
+        (txt $ "Item " <> (selStr $ show i) <> " L" <> show j, High)
+
+theAttrMap :: AttrMap
+theAttrMap = attrMap defAttr
+    [ (listSelectedAttr,   white `on` blue)
+    , (editAttr,           green `on` white)
+    , (keywordAttr,        fg blue)
+    ]
 
 theApp :: App St Event
 theApp =
     def { appDraw = drawUI
         , appChooseCursor = showFirstCursor
         , appHandleEvent = appEvent
+        , appAttrMap = const theAttrMap
         }
 
 main :: IO ()

programs/Minimal.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Main where
 
 import Data.Monoid ((<>))
@@ -10,9 +11,21 @@ import Brick.Main
 import Brick.Util
 import Brick.Render
 import Brick.Markup
+import Brick.AttrMap
 
 ui :: Render
-ui = markup $ ("Hello" @@ (green `on` blue)) <> ", " <> ("world!" @@ (red `on` black))
+ui = m1 <=> m2
+    where
+        -- Two ways to assign attributes to text in markup: via
+        -- attributes (direct) or via attribute names (indirect)
+        m1 = markup $ ("Hello" @? "kw1") <> ", " <> ("world!" @? "kw2")
+        m2 = markup $ ("Hello" @@ fg red) <> ", " <> ("world!" @@ (yellow `on` black))
+
+aMap :: [(AttrName, Attr)]
+aMap =
+    [ ("kw1", fg green)
+    , ("kw2", red `on` black)
+    ]
 
 main :: IO ()
-main = simpleMain [ui]
+main = simpleMain aMap [ui]

src/Brick/AttrMap.hs

@@ -0,0 +1,44 @@
+module Brick.AttrMap
+  ( AttrMap
+  , AttrName
+  , attrMap
+  , attrMapLookup
+  , setDefault
+  )
+where
+
+import qualified Data.Map as M
+import Data.Monoid
+import Data.String (IsString(..))
+import Data.Default (Default(..))
+
+import Graphics.Vty (Attr)
+
+data AttrName = AttrName [String]
+              deriving (Show, Eq, Ord)
+
+instance Default AttrName where
+    def = mempty
+
+instance Monoid AttrName where
+    mempty = AttrName []
+    mappend (AttrName as) (AttrName bs) = AttrName $ as `mappend` bs
+
+instance IsString AttrName where
+    fromString = AttrName . (:[])
+
+data AttrMap = AttrMap Attr (M.Map AttrName Attr)
+             deriving Show
+
+instance Default AttrMap where
+    def = AttrMap def mempty
+
+attrMap :: Attr -> [(AttrName, Attr)] -> AttrMap
+attrMap theDefault pairs = AttrMap theDefault (M.fromList pairs)
+
+attrMapLookup :: AttrName -> AttrMap -> Attr
+attrMapLookup (AttrName []) (AttrMap theDefault _) = theDefault
+attrMapLookup n (AttrMap theDefault m) = M.findWithDefault theDefault n m
+
+setDefault :: Attr -> AttrMap -> AttrMap
+setDefault newDefault (AttrMap _ m) = AttrMap newDefault m

src/Brick/Edit.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Brick.Edit
   ( Editor
   , editor
   , renderEditor
+  , editAttr
   )
 where
 
@@ -11,6 +13,7 @@ import Graphics.Vty (Event(..), Key(..), Modifier(..))
 import Brick.Core (Name, Location(..), HandleEvent(..))
 import Brick.Render
 import Brick.Util (clamp)
+import Brick.AttrMap
 
 data Editor =
     Editor { editStr :: !String
@@ -76,10 +79,14 @@ insertChar c theEdit =
 editor :: Name -> String -> Editor
 editor name s = Editor s (length s) name
 
+editAttr :: AttrName
+editAttr = "edit"
+
 renderEditor :: Editor -> Render
 renderEditor e =
     let cursorLoc = Location (editCursorPos e, 0)
-    in vLimit 1 $
+    in withAttrName editAttr $
+       vLimit 1 $
        viewport (editorName e) Horizontal $
        showCursor (editorName e) cursorLoc $
        visibleRegion cursorLoc (1, 1) $

src/Brick/List.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Brick.List
   ( List(listElements)
   , list
@@ -11,10 +12,13 @@ module Brick.List
   , listRemove
   , listReplace
   , listSelectedElement
+
+  , listSelectedAttr
   )
 where
 
 import Control.Applicative ((<$>))
+import Data.Monoid ((<>))
 import Data.Maybe (fromMaybe)
 import Graphics.Vty (Event(..), Key(..))
 
@@ -22,6 +26,7 @@ import Brick.Core (HandleEvent(..), Name)
 import Brick.Merge (maintainSel)
 import Brick.Render
 import Brick.Util (clamp, for)
+import Brick.AttrMap
 
 data List e =
     List { listElements :: ![e]
@@ -38,6 +43,12 @@ instance HandleEvent (List e) where
                   EvKey KDown [] -> listMoveDown
                   _ -> id
 
+listAttr :: AttrName -> AttrName
+listAttr = ("list" <>)
+
+listSelectedAttr :: AttrName
+listSelectedAttr = listAttr "selected"
+
 list :: Name -> (Bool -> e -> Render) -> [e] -> List e
 list name draw es =
     let selIndex = if null es then Nothing else Just 0
@@ -56,7 +67,9 @@ drawListElements l = drawnElements
         drawnElements = for (zip [0..] es) $ \(i, e) ->
             let isSelected = Just i == listSelected l
                 elemRender = listElementDraw l isSelected e
-                makeVisible = if isSelected then visible else id
+                makeVisible = if isSelected
+                              then (visible . withAttrName listSelectedAttr)
+                              else id
             in makeVisible elemRender
 
 listInsert :: Int -> e -> List e -> List e

src/Brick/Main.hs

@@ -26,6 +26,7 @@ import Graphics.Vty
   , Picture(..)
   , Cursor(..)
   , Event(..)
+  , Attr
   , update
   , outputIface
   , displayBounds
@@ -38,26 +39,30 @@ import System.Exit (exitSuccess)
 import Brick.Render (Render)
 import Brick.Render.Internal (renderFinal, RenderState(..))
 import Brick.Core (Location(..), CursorLocation(..))
+import Brick.AttrMap
 
 data App a e =
     App { appDraw :: a -> [Render]
         , appChooseCursor :: a -> [CursorLocation] -> Maybe CursorLocation
         , appHandleEvent :: e -> a -> IO a
+        , appAttrMap :: a -> AttrMap
         }
 
 instance Default (App a e) where
     def = App { appDraw = const def
               , appChooseCursor = neverShowCursor
               , appHandleEvent = const return
+              , appAttrMap = const def
               }
 
 defaultMain :: App a Event -> a -> IO ()
 defaultMain = defaultMainWithVty (mkVty def)
 
-simpleMain :: [Render] -> IO ()
-simpleMain ls =
+simpleMain :: [(AttrName, Attr)] -> [Render] -> IO ()
+simpleMain attrs ls =
     let app = def { appDraw = const ls
                   , appHandleEvent = const $ const exitSuccess
+                  , appAttrMap = const $ attrMap def attrs
                   }
     in defaultMain app ()
 
@@ -97,7 +102,7 @@ withVty buildVty useVty = do
 renderApp :: Vty -> App a e -> a -> RenderState -> IO RenderState
 renderApp vty app appState rs = do
     sz <- displayBounds $ outputIface vty
-    let (newRS, pic, theCursor) = renderFinal (appDraw app appState) sz (appChooseCursor app appState) rs
+    let (newRS, pic, theCursor) = renderFinal (appAttrMap app appState) (appDraw app appState) sz (appChooseCursor app appState) rs
         picWithCursor = case theCursor of
             Nothing -> pic { picCursor = NoCursor }
             Just (CursorLocation (Location (w, h)) _) -> pic { picCursor = Cursor w h }

src/Brick/Markup.hs

@@ -1,21 +1,37 @@
 module Brick.Markup
-  ( markup
+  ( Markup
+  , markup
+  , (@?)
   )
 where
 
-import Control.Applicative ((<$>))
 import Control.Lens ((.~), (&))
+import Control.Monad (forM)
 import qualified Data.Text as T
 import Data.Text.Markup
 import Data.Default (def)
 
 import Graphics.Vty (Attr, horizCat, string)
 
-import Brick.Render (Render, image)
+import Brick.Render
+import Brick.AttrMap
 
-markup :: Markup Attr -> Render
-markup m =
+class GetAttr a where
+    getAttr :: a -> RenderM Attr
+
+instance GetAttr Attr where
+    getAttr = return
+
+instance GetAttr AttrName where
+    getAttr = lookupAttrName
+
+(@?) :: T.Text -> AttrName -> Markup AttrName
+(@?) = (@@)
+
+markup :: (GetAttr a) => Markup a -> Render
+markup m = do
     let pairs = toList m
-        imgs = mkImage <$> pairs
-        mkImage (t, a) = string a $ T.unpack t
-    in return $ def & image .~ horizCat imgs
+    imgs <- forM pairs $ \(t, aSrc) -> do
+        a <- getAttr aSrc
+        return $ string a $ T.unpack t
+    return $ def & image .~ horizCat imgs

src/Brick/Render.hs

@@ -4,7 +4,9 @@ module Brick.Render
 
   , Result
   , image
+  , attr
   , cursors
+  , lookupAttrName
   , visibilityRequests
 
   , Context
@@ -26,7 +28,8 @@ module Brick.Render
   , vBox
   , hLimit
   , vLimit
-  , withAttr
+  , withDefaultAttr
+  , withAttrName
   , raw
   , withBorderStyle
   , translateBy

src/Brick/Render/Internal.hs

@@ -7,6 +7,8 @@ module Brick.Render.Internal
   ( Result(..)
   , image
   , cursors
+  , attr
+  , lookupAttrName
   , visibilityRequests
 
   , RenderState(..)
@@ -39,7 +41,8 @@ module Brick.Render.Internal
 
   , hLimit
   , vLimit
-  , withAttr
+  , withDefaultAttr
+  , withAttrName
   , raw
   , translateBy
   , cropLeftBy
@@ -54,12 +57,13 @@ module Brick.Render.Internal
 where
 
 import Control.Applicative
-import Control.Lens (makeLenses, (^.), (.~), (&), (%~), to, _1, _2, view, each)
+import Control.Lens (makeLenses, (^.), (.~), (&), (%~), to, _1, _2, view, each, to)
 import Control.Monad (when)
 import Control.Monad.Trans.State.Lazy
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Class (lift)
 import Data.Default
+import Data.Functor.Contravariant
 import Data.Monoid ((<>), mempty)
 import qualified Data.Map as M
 import qualified Data.Function as DF
@@ -71,6 +75,7 @@ import qualified Graphics.Vty as V
 import Brick.Core
 import Brick.Border.Style
 import Brick.Util (clOffset, for)
+import Brick.AttrMap
 
 data VisibilityRequest =
     VR { _vrPosition :: Location
@@ -95,10 +100,11 @@ data Result =
            deriving Show
 
 data Context =
-    Context { _attr :: V.Attr
+    Context { _attrName :: AttrName
             , _availW :: Int
             , _availH :: Int
             , _activeBorderStyle :: BorderStyle
+            , _ctxAttrs :: AttrMap
             }
 
 data Priority = High | Low
@@ -132,15 +138,16 @@ withBorderStyle bs = withReaderT (& activeBorderStyle .~ bs)
 getActiveBorderStyle :: RenderM BorderStyle
 getActiveBorderStyle = view activeBorderStyle
 
-renderFinal :: [Render]
+renderFinal :: AttrMap
+            -> [Render]
             -> V.DisplayRegion
             -> ([CursorLocation] -> Maybe CursorLocation)
             -> RenderState
             -> (RenderState, V.Picture, Maybe CursorLocation)
-renderFinal layerRenders sz chooseCursor rs = (newRS, pic, theCursor)
+renderFinal aMap layerRenders sz chooseCursor rs = (newRS, pic, theCursor)
     where
         (layerResults, newRS) = flip runState rs $ sequence $ (\p -> runReaderT p ctx) <$> (cropToContext <$> layerRenders)
-        ctx = Context V.defAttr (fst sz) (snd sz) def
+        ctx = Context def (fst sz) (snd sz) def aMap
         pic = V.picForLayers $ uncurry V.resize sz <$> (^.image) <$> layerResults
         layerCursors = (^.cursors) <$> layerResults
         theCursor = chooseCursor $ concat layerCursors
@@ -157,6 +164,14 @@ addCursorOffset off r =
 unrestricted :: Int
 unrestricted = 100000
 
+attr :: (Contravariant f, Functor f) => (V.Attr -> f V.Attr) -> Context -> f Context
+attr = to (\c -> attrMapLookup (c^.attrName) (c^.ctxAttrs))
+
+lookupAttrName :: AttrName -> RenderM V.Attr
+lookupAttrName n = do
+    c <- getContext
+    return $ attrMapLookup n (c^.ctxAttrs)
+
 txt :: String -> Render
 txt s = do
     c <- getContext
@@ -264,8 +279,11 @@ hLimit w p = withReaderT (& availW .~ w) $ cropToContext p
 vLimit :: Int -> Render -> Render
 vLimit h p = withReaderT (& availH .~ h) $ cropToContext p
 
-withAttr :: V.Attr -> Render -> Render
-withAttr a = withReaderT (& attr .~ a)
+withAttrName :: AttrName -> Render -> Render
+withAttrName an = withReaderT (& attrName .~ an)
+
+withDefaultAttr :: V.Attr -> Render -> Render
+withDefaultAttr a = withReaderT (& ctxAttrs %~ (setDefault a))
 
 raw :: V.Image -> Render
 raw img = return $ def & image .~ img