8f1ae401f4
Note the headErr/tailErr calls will print stack traces if they fail (small ones: five lines, one of which is the useful location info), which may or may not be best UX.
138 lines
7.6 KiB
Haskell
138 lines
7.6 KiB
Haskell
-- | The all-important theming engine!
|
|
--
|
|
-- Cf
|
|
-- https://hackage.haskell.org/package/vty/docs/Graphics-Vty-Attributes.html
|
|
-- http://hackage.haskell.org/package/brick/docs/Brick-AttrMap.html
|
|
-- http://hackage.haskell.org/package/brick-0.1/docs/Brick-Util.html
|
|
-- http://hackage.haskell.org/package/brick-0.1/docs/Brick-Widgets-Core.html#g:5
|
|
-- http://hackage.haskell.org/package/brick-0.1/docs/Brick-Widgets-Border.html
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Hledger.UI.Theme (
|
|
defaultTheme
|
|
,getTheme
|
|
,themes
|
|
,themeNames
|
|
)
|
|
where
|
|
|
|
import qualified Data.Map as M
|
|
import Data.Maybe
|
|
import Graphics.Vty
|
|
import Brick
|
|
import Safe (headErr)
|
|
|
|
defaultTheme :: AttrMap
|
|
defaultTheme = fromMaybe (snd $ headErr themesList) $ getTheme "white" -- PARTIAL headErr succeeds because themesList is non-null
|
|
-- the theme named here should exist;
|
|
-- otherwise it will take the first one from the list,
|
|
-- which must be non-empty.
|
|
|
|
-- | Look up the named theme, if it exists.
|
|
getTheme :: String -> Maybe AttrMap
|
|
getTheme name = M.lookup name themes
|
|
|
|
-- | A selection of named themes specifying terminal colours and styles.
|
|
-- One of these is active at a time.
|
|
--
|
|
-- A hledger-ui theme is a vty/brick AttrMap. Each theme specifies a
|
|
-- default style (Attr), plus extra styles which are applied when
|
|
-- their (hierarchical) name matches the widget rendering context.
|
|
-- "More specific styles, if present, are used and only fall back to
|
|
-- more general ones when the more specific ones are absent, but also
|
|
-- these styles get merged, so that if a more specific style only
|
|
-- provides the foreground color, its more general parent style can
|
|
-- set the background color, too."
|
|
-- For example: rendering a widget named "b" inside a widget named "a",
|
|
-- - if a style named "a" <> "b" exists, it will be used. Anything it
|
|
-- does not specify will be taken from a style named "a" if that
|
|
-- exists, otherwise from the default style.
|
|
-- - otherwise if a style named "a" exists, it will be used, and
|
|
-- anything it does not specify will be taken from the default style.
|
|
-- - otherwise (you guessed it) the default style is used.
|
|
--
|
|
themes :: M.Map String AttrMap
|
|
themes = M.fromList themesList
|
|
|
|
themeNames :: [String]
|
|
themeNames = map fst themesList
|
|
|
|
(&) = withStyle
|
|
active = fg brightWhite & bold
|
|
selectbg = yellow
|
|
select = black `on` selectbg
|
|
|
|
themesList :: [(String, AttrMap)]
|
|
themesList = [
|
|
("default", attrMap (black `on` white) [
|
|
(attrName "border" , white `on` black & dim)
|
|
,(attrName "border" <> attrName "bold" , currentAttr & bold)
|
|
,(attrName "border" <> attrName "depth" , active)
|
|
,(attrName "border" <> attrName "filename" , currentAttr)
|
|
,(attrName "border" <> attrName "key" , active)
|
|
,(attrName "border" <> attrName "minibuffer" , white `on` black & bold)
|
|
,(attrName "border" <> attrName "query" , active)
|
|
,(attrName "border" <> attrName "selected" , active)
|
|
,(attrName "error" , fg red)
|
|
,(attrName "help" , white `on` black & dim)
|
|
,(attrName "help" <> attrName "heading" , fg yellow)
|
|
,(attrName "help" <> attrName "key" , active)
|
|
-- ,(attrName "list" , black `on` white)
|
|
-- ,(attrName "list" <> attrName "amount" , currentAttr)
|
|
,(attrName "list" <> attrName "amount" <> attrName "decrease" , fg red)
|
|
-- ,(attrName "list" <> attrName "amount" <> attrName "increase" , fg green)
|
|
,(attrName "list" <> attrName "amount" <> attrName "decrease" <> attrName "selected" , red `on` selectbg & bold)
|
|
-- ,(attrName "list" <> attrName "amount" <> attrName "increase" <> attrName "selected" , green `on` selectbg & bold)
|
|
,(attrName "list" <> attrName "balance" , currentAttr & bold)
|
|
,(attrName "list" <> attrName "balance" <> attrName "negative" , fg red)
|
|
,(attrName "list" <> attrName "balance" <> attrName "positive" , fg black)
|
|
,(attrName "list" <> attrName "balance" <> attrName "negative" <> attrName "selected" , red `on` selectbg & bold)
|
|
,(attrName "list" <> attrName "balance" <> attrName "positive" <> attrName "selected" , select & bold)
|
|
,(attrName "list" <> attrName "selected" , select)
|
|
-- ,(attrName "list" <> attrName "accounts" , white `on` brightGreen)
|
|
-- ,(attrName "list" <> attrName "selected" , black `on` brightYellow)
|
|
])
|
|
|
|
,("greenterm", attrMap (green `on` black) [
|
|
(attrName "list" <> attrName "selected" , black `on` green)
|
|
])
|
|
|
|
,("terminal", attrMap defAttr [
|
|
(attrName "border" , white `on` black),
|
|
(attrName "list" , defAttr),
|
|
(attrName "list" <> attrName "selected" , defAttr & reverseVideo)
|
|
])
|
|
|
|
,("dark", attrMap (white `on` black & dim) [
|
|
(attrName "border" , white `on` black)
|
|
, (attrName "border" <> attrName "bold" , currentAttr & bold)
|
|
, (attrName "border" <> attrName "depth" , active)
|
|
, (attrName "border" <> attrName "filename" , currentAttr)
|
|
, (attrName "border" <> attrName "key" , active)
|
|
, (attrName "border" <> attrName "minibuffer" , white `on` black & bold)
|
|
, (attrName "border" <> attrName "query" , active)
|
|
, (attrName "border" <> attrName "selected" , active)
|
|
, (attrName "error" , fg red)
|
|
, (attrName "help" , currentAttr & bold)
|
|
, (attrName "help" <> attrName "heading" , fg blue)
|
|
, (attrName "help" <> attrName "key" , active)
|
|
, (attrName "list" <> attrName "amount" <> attrName "decrease" , fg red)
|
|
, (attrName "list" <> attrName "amount" <> attrName "decrease" <> attrName "selected" , red `on` black & bold)
|
|
, (attrName "list" <> attrName "balance" , currentAttr)
|
|
, (attrName "list" <> attrName "balance" <> attrName "negative" , fg red)
|
|
, (attrName "list" <> attrName "balance" <> attrName "positive" , fg white)
|
|
, (attrName "list" <> attrName "balance" <> attrName "negative" <> attrName "selected" , red `on` black & bold)
|
|
, (attrName "list" <> attrName "balance" <> attrName "positive" <> attrName "selected" , yellow `on` black & bold)
|
|
, (attrName "list" <> attrName "selected" , yellow `on` black & bold)
|
|
])
|
|
|
|
]
|
|
|
|
-- halfbrightattr = defAttr & dim
|
|
-- reverseattr = defAttr & reverseVideo
|
|
-- redattr = defAttr `withForeColor` red
|
|
-- greenattr = defAttr `withForeColor` green
|
|
-- reverseredattr = defAttr & reverseVideo `withForeColor` red
|
|
-- reversegreenattr= defAttr & reverseVideo `withForeColor` green
|