hmp3-ng-2.18.0: Style.hs
-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons
-- Copyright (c) 2019-2022, 2026 Galen Huntington
-- SPDX-License-Identifier: GPL-2.0-or-later
--
-- | Color manipulation
--
module Style where
import Base
import qualified UI.HSCurses.Curses as Curses
import qualified Data.Map as M (fromList, empty, lookup, Map)
------------------------------------------------------------------------
-- | User-configurable colours
-- Each component of this structure corresponds to a fg\/bg colour pair
-- for an item in the ui
data UIStyle = UIStyle {
window :: !Style -- default window colour
, modals :: !Style -- help screen
, titlebar :: !Style -- titlebar of window
, selected :: !Style -- currently playing track
, cursors :: !Style -- the scrolling cursor line
, combined :: !Style -- the style to use when the cursor is on the current track
, warnings :: !Style -- style for warnings
, blockcursor :: !Style -- style for the block cursor when typing text
, progress :: !Style -- style for the progress bar
}
------------------------------------------------------------------------
-- | A terminal color: the terminal default, reverse-video, or one of the
-- eight ANSI hues at normal or bright intensity. (Bright is rendered with
-- the bold attribute, which is how 8-color terminals expose it.)
data Color = Default | Reverse | Color !Intensity !Hue
deriving stock (Eq, Ord, Show)
data Intensity = Normal | Bright
deriving stock (Eq, Ord, Show)
data Hue = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
deriving stock (Eq, Ord, Show)
-- | Foreground and background color pairs
data Style = Style !Color !Color
deriving stock (Eq,Ord)
-- | A list of styled UTF-8 ByteString segments making up one line.
-- 'Fast' is the single-segment fast path; 'FancyS' is a multi-segment line.
data StringA
= Fast {-# UNPACK #-} !ByteString {-# UNPACK #-} !Style
| FancyS ![(ByteString, Style)]
------------------------------------------------------------------------
--
-- | Named colors for the config file and the built-in styles. The
-- \"dark\" name of each pair is the normal-intensity hue; the plain name
-- is its bright variant (so @red@ is bright, @darkred@ is normal).
--
stringToColor :: String -> Maybe Color
stringToColor s = case map toLower s of
"black" -> Just $ Color Normal Black
"grey" -> Just $ Color Bright Black
"darkred" -> Just $ Color Normal Red
"red" -> Just $ Color Bright Red
"darkgreen" -> Just $ Color Normal Green
"green" -> Just $ Color Bright Green
"brown" -> Just $ Color Normal Yellow
"yellow" -> Just $ Color Bright Yellow
"darkblue" -> Just $ Color Normal Blue
"blue" -> Just $ Color Bright Blue
"purple" -> Just $ Color Normal Magenta
"magenta" -> Just $ Color Bright Magenta
"darkcyan" -> Just $ Color Normal Cyan
"cyan" -> Just $ Color Bright Cyan
"white" -> Just $ Color Normal White
"brightwhite" -> Just $ Color Bright White
"default" -> Just Default
"reverse" -> Just Reverse
_ -> Nothing
------------------------------------------------------------------------
--
-- | Set some colours, perform an action, and then reset the colours
--
withStyle :: Style -> IO () -> IO ()
withStyle sty fn = uiAttr sty >>= setAttribute >> fn >> reset
{-# INLINE withStyle #-}
--
-- | manipulate the current attributes of the standard screen
-- Only set attr if it's different to the current one?
--
setAttribute :: (Curses.Attr, Curses.Pair) -> IO ()
setAttribute = uncurry Curses.attrSet
{-# INLINE setAttribute #-}
--
-- | Reset the screen to normal values
--
reset :: IO ()
reset = setAttribute (Curses.attr0, Curses.Pair 0)
{-# INLINE reset #-}
--
-- | And turn on the colours
--
initcolours :: UIStyle -> IO ()
initcolours sty = do
let ls = [modals sty, warnings sty, window sty,
selected sty, titlebar sty, progress sty,
blockcursor sty, cursors sty, combined sty ]
(Style fg bg) = progress sty -- bonus style
pairs <- initUiColors (ls ++ [Style bg bg, Style fg fg])
writeIORef pairMap pairs
-- set the background
uiAttr (window sty) >>= \(_,p) -> Curses.bkgrndSet nullA p
------------------------------------------------------------------------
--
-- | Set up the ui attributes, given a ui style record
--
-- Returns an association list of pairs for foreground and bg colors,
-- associated with the terminal color pair that has been defined for
-- those colors.
--
initUiColors :: [Style] -> IO PairMap
initUiColors stys = do
ls <- sequence [ uncurry fn m | m <- zip stys [1..] ]
pure (M.fromList ls)
where
fn :: Style -> Int -> IO (Style, (Curses.Attr,Curses.Pair))
fn sty p = do
let (CColor (a,fgc),CColor (b,bgc)) = style2curses sty
discardErrors $ Curses.initPair (Curses.Pair p) fgc bgc
pure (sty, (a `Curses.attrPlus` b, Curses.Pair p))
------------------------------------------------------------------------
--
-- | Getting from nice abstract colours to ncurses-settable values
-- 20% of allocss occur here! But there's only 3 or 4 colours :/
-- Every call to uiAttr
--
uiAttr :: Style -> IO (Curses.Attr, Curses.Pair)
uiAttr sty = do
m <- readIORef pairMap
pure $ lookupPair m sty
{-# INLINE uiAttr #-}
-- | Given a curses color pair, find the Curses.Pair (i.e. the pair
-- curses thinks these colors map to) from the state
lookupPair :: PairMap -> Style -> (Curses.Attr, Curses.Pair)
lookupPair m s =
fromMaybe (Curses.attr0, Curses.Pair 0) (M.lookup s m)
{-# INLINE lookupPair #-}
-- | Keep a map of nice style defs to underlying curses pairs, created at init time
type PairMap = M.Map Style (Curses.Attr, Curses.Pair)
-- | map of Curses.Color pairs to ncurses terminal Pair settings
pairMap :: IORef PairMap
pairMap = unsafePerformIO $ newIORef M.empty
{-# NOINLINE pairMap #-}
------------------------------------------------------------------------
--
-- Basic (ncurses) colours.
--
defaultColor :: Curses.Color
defaultColor = fromJust $ Curses.color "default"
--
-- Combine attribute with another attribute
--
setBoldA, setReverseA :: Curses.Attr -> Curses.Attr
setBoldA = flip Curses.setBold True
setReverseA = flip Curses.setReverse True
--
-- | Some attribute constants
--
boldA, nullA, reverseA :: Curses.Attr
nullA = Curses.attr0
boldA = setBoldA nullA
reverseA = setReverseA nullA
------------------------------------------------------------------------
newtype CColor = CColor (Curses.Attr, Curses.Color)
-- | Map an abstract 'Style' to its ncurses foreground/background pair.
style2curses :: Style -> (CColor, CColor)
style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg)
{-# INLINE style2curses #-}
-- | The ncurses color for each ANSI hue.
hueColor :: Hue -> Curses.Color
hueColor = fromJust . Curses.color . map toLower . show
-- | Foreground: bright hues take the bold attribute.
fgCursCol :: Color -> CColor
fgCursCol = \case
Default -> CColor (nullA, defaultColor)
Reverse -> CColor (reverseA, defaultColor)
Color Bright h -> CColor (boldA, hueColor h)
Color Normal h -> CColor (nullA, hueColor h)
-- | Background: a terminal can't embolden a background, so intensity is
-- dropped here.
bgCursCol :: Color -> CColor
bgCursCol = \case
Default -> CColor (nullA, defaultColor)
Reverse -> CColor (reverseA, defaultColor)
Color _ h -> CColor (nullA, hueColor h)
defaultSty :: Style
defaultSty = Style Default Default
style :: String -> String -> Style
style a b = let f = fromJust . stringToColor in Style (f a) (f b)
------------------------------------------------------------------------
--
-- Support for runtime configuration
-- We choose a simple strategy, read/showable record types, with strings
-- to represent colors
--
-- The fields must map to UIStyle
--
-- It is this data type that is stored in 'show' format in style.conf
--
data Config = Config {
hmp3_window :: (String,String)
, hmp3_modals :: (String,String)
, hmp3_titlebar :: (String,String)
, hmp3_selected :: (String,String)
, hmp3_cursors :: (String,String)
, hmp3_combined :: (String,String)
, hmp3_warnings :: (String,String)
, hmp3_blockcursor :: (String,String)
, hmp3_progress :: (String,String)
} deriving stock (Show,Read)
--
-- | Read style.conf, and construct a UIStyle from it, to insert into
--
buildStyle :: Config -> UIStyle
buildStyle bs = UIStyle {
window = f $ hmp3_window bs
, modals = f $ hmp3_modals bs
, titlebar = f $ hmp3_titlebar bs
, selected = f $ hmp3_selected bs
, cursors = f $ hmp3_cursors bs
, combined = f $ hmp3_combined bs
, warnings = f $ hmp3_warnings bs
, blockcursor = f $ hmp3_blockcursor bs
, progress = f $ hmp3_progress bs
}
where
f (x,y) = Style (g x) (g y)
g x = fromMaybe Default $ stringToColor x