diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,22 @@ Brick changelog --------------- +0.29 +---- + +API changes: + * Added Ord instances for `Location` and `BrickEvent` (thanks Tom + Sydney Kerckhove) + * `Brick.AttrMap`: attribute name components are now exposed via the + `attrNameComponents` function. Also added a Read instance for + AttrName. + +New features: + * This release adds user-customizable theme support. Please see the + "Attribute Themes" section of the User Guide for an introduction; see + the Haddock documentation for `Brick.Themes` for full details. Also, + see the new `programs/ThemeDemo.hs` for a working demonstration. + 0.28 ---- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -60,6 +60,7 @@ * `tart`, a mouse-driven ASCII art drawing program: https://github.com/jtdaugherty/tart * `silly-joy`, an interpreter for Joy in Haskell: https://github.com/rootmos/silly-joy * `herms`, a command-line tool for managing kitchen recipes: https://github.com/jackkiefer/herms + * `purebred`, a mail user agent: https://github.com/purebred-mua/purebred Getting Started --------------- @@ -98,6 +99,7 @@ * Border-drawing widgets (put borders around or in between things) * Generic scrollable viewports * Extensible widget-building API + * User-customizable attribute themes * (And many more general-purpose layout control combinators) In addition, some of `brick`'s more powerful features may not be obvious diff --git a/brick.cabal b/brick.cabal --- a/brick.cabal +++ b/brick.cabal @@ -1,5 +1,5 @@ name: brick -version: 0.28 +version: 0.29 synopsis: A declarative terminal user interface library description: Write terminal applications painlessly with 'brick'! You write an @@ -64,6 +64,7 @@ Brick.Focus Brick.Main Brick.Markup + Brick.Themes Brick.Types Brick.Util Brick.Widgets.Border @@ -89,6 +90,7 @@ microlens >= 0.3.0.0, microlens-th, microlens-mtl, + config-ini, vector, contravariant, stm >= 2.4, @@ -229,6 +231,19 @@ ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 default-language: Haskell2010 main-is: PaddingDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.18.1, + text, + microlens + +executable brick-theme-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-language: Haskell2010 + main-is: ThemeDemo.hs build-depends: base <= 5, brick, vty >= 5.18.1, diff --git a/docs/guide.rst b/docs/guide.rst --- a/docs/guide.rst +++ b/docs/guide.rst @@ -304,7 +304,7 @@ Since we often need to communicate application-specific events beyond Vty input events to the event handler, brick supports embedding your -application's custom events in the stream of ``BrickEvent``s that +application's custom events in the stream of ``BrickEvent``-s that your handler will receive. The type of these events is the type ``e`` mentioned in ``BrickEvent n e`` and ``App s e n``. @@ -751,6 +751,93 @@ * ``Brick.Widgets.Core.forceAttr`` * ``Brick.Widgets.Core.withDefAttr`` * ``Brick.Widgets.Core.overrideAttr`` + +Attribute Themes +================ + +Brick provides support for customizable attribute themes. This works as +follows: + +* The application provides a default theme built in to the program. +* The application customizes the them by loading theme customizations + from a user-specified customization file. +* The application can save new customizations to files for later + re-loading. + +Customizations are written in an INI-style file. Here's an example: + +.. code:: + + [default] + default.fg = blue + default.bg = black + + [other] + someAttribute.fg = red + someAttribute.style = underline + otherAttribute.style = [underline, bold] + otherAttribute.inner.fg = white + +In the above example, the theme's *default attribute* -- the one that is +used when no other attributes are used -- is customized. Its foreground +and background colors are set. Then, other attributes specified by +the theme -- ``someAttribute`` and ``otherAttribute`` -- are also +customized. This example shows that styles can be customized, too, and +that a custom style can either be a single style (in this example, +``underline``) or a collection of styles to be applied simutaneously +(in this example, ``underline`` and ``bold``). Lastly, the hierarchical +attribute name ``otherAttribute.inner`` refers to an attribute name +with two components, ``otherAttribute <> inner``, similar to the +``specificAttr`` attribute described in `How Attributes Work`_. Full +documentation for the format of theme customization files can be found +in the module documentation for ``Brick.Themes``. + +The above example can be used in a ``brick`` application as follows. +First, the application provides a default theme: + +.. code:: haskell + + import Brick.Themes (Theme, newTheme) + + defaultTheme :: Theme + defaultTheme = + newTheme (white `on` blue) + [ ("someAttribute", fg yellow) + , ("otherAttribute", fg magenta) + ] + +Notice that the attributes in the theme have defaults: ``someAttribute`` +will default to a yellow foreground color if it is not customized. (And +its background will default to the theme's default background color, +blue, if it not customized either.) Then, the application can customize +the theme with the user's customization file: + +.. code:: haskell + + import Brick.Themes (loadCustomizations) + + main :: IO () + main = do + customizedTheme <- loadCustomizations "custom.ini" defaultTheme + +Now we have a customized theme based on ``defaultTheme``. The next step +is to build an ``AttrMap`` from the theme: + +.. code:: haskell + + import Brick.Themes (themeToAttrMap) + + main :: IO () + main = do + customizedTheme <- loadCustomizations "custom.ini" defaultTheme + let mapping = themeToAttrMap customizedTheme + +The resulting ``AttrMap`` can then be returned by ``appAttrMap`` as +described in (see `How Attributes Work`_ and `appAttrMap: Managing +Attributes`_). + +If the theme is further customized at runtime, any changes can be saved +with ``Brick.Themes.saveCustomizations``. Wide Character Support and the TextWidth class ============================================== diff --git a/programs/ThemeDemo.hs b/programs/ThemeDemo.hs new file mode 100644 --- /dev/null +++ b/programs/ThemeDemo.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad (void) +import Graphics.Vty + ( white, blue, green, yellow, black, magenta + , Event(EvKey) + , Key(KChar, KEsc) + ) + +import Brick.Main +import Brick.Themes + ( Theme + , newTheme + , themeToAttrMap + ) +import Brick.Types + ( Widget + , BrickEvent(VtyEvent) + , EventM + , Next + ) +import Brick.Widgets.Center + ( hCenter + , center + ) +import Brick.Widgets.Core + ( (<+>) + , vBox + , str + , hLimit + , withDefAttr + ) +import Brick.Util (on, fg) +import Brick.AttrMap (AttrName) + +ui :: Widget n +ui = + center $ + hLimit 40 $ + vBox $ hCenter <$> + [ str "Press " <+> (withDefAttr keybindingAttr $ str "1") <+> str " to switch to theme 1." + , str "Press " <+> (withDefAttr keybindingAttr $ str "2") <+> str " to switch to theme 2." + ] + +keybindingAttr :: AttrName +keybindingAttr = "keybinding" + +theme1 :: Theme +theme1 = + newTheme (white `on` blue) + [ (keybindingAttr, fg magenta) + ] + +theme2 :: Theme +theme2 = + newTheme (green `on` black) + [ (keybindingAttr, fg yellow) + ] + +appEvent :: Int -> BrickEvent () e -> EventM () (Next Int) +appEvent _ (VtyEvent (EvKey (KChar '1') [])) = continue 1 +appEvent _ (VtyEvent (EvKey (KChar '2') [])) = continue 2 +appEvent s (VtyEvent (EvKey (KChar 'q') [])) = halt s +appEvent s (VtyEvent (EvKey KEsc [])) = halt s +appEvent s _ = continue s + +app :: App Int e () +app = + App { appDraw = const [ui] + , appHandleEvent = appEvent + , appStartEvent = return + , appAttrMap = \s -> + -- Note that in practice this is not ideal: we don't want + -- to build an attribute from a theme every time this is + -- invoked, because it gets invoked once per redraw. Instead + -- we'd build the attribute map at startup and store it in + -- the application state. Here I just use themeToAttrMap to + -- show the mechanics of the API. + if s == 1 + then themeToAttrMap theme1 + else themeToAttrMap theme2 + , appChooseCursor = neverShowCursor + } + +main :: IO () +main = void $ defaultMain app 1 diff --git a/src/Brick/AttrMap.hs b/src/Brick/AttrMap.hs --- a/src/Brick/AttrMap.hs +++ b/src/Brick/AttrMap.hs @@ -29,6 +29,8 @@ , attrMap , forceAttrMap , attrName + -- * Inspection + , attrNameComponents -- * Finding attributes from names , attrMapLookup -- * Manipulating attribute maps @@ -66,7 +68,7 @@ -- "header" <> "clock" <> "seconds" -- @ data AttrName = AttrName [String] - deriving (Show, Eq, Ord) + deriving (Show, Read, Eq, Ord) instance Monoid AttrName where mempty = AttrName [] @@ -83,6 +85,10 @@ -- | Create an attribute name from a string. attrName :: String -> AttrName attrName = AttrName . (:[]) + +-- | Get the components of an attribute name. +attrNameComponents :: AttrName -> [String] +attrNameComponents (AttrName cs) = cs -- | Create an attribute map. attrMap :: Attr diff --git a/src/Brick/Themes.hs b/src/Brick/Themes.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Themes.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Support for representing attribute themes and loading and saving +-- theme customizations in INI-style files. +-- +-- The file format is as follows: +-- * Customization files are INI-style files with two sections, both +-- optional: "default" and "other". +-- * The "default" section specifies three optional fields: +-- * "default.fg" - a color specification +-- * "default.bg" - a color specification +-- * "default.style" - a style specification +-- * A color specification can be any of the values (no quotes) +-- "black", "red", "green", "yellow", "blue", "magenta", "cyan", +-- "white", "brightBlack", "brightRed", "brightGreen", "brightYellow", +-- "brightBlue", "brightMagenta", "brightCyan", or "brightWhite". +-- * A style specification can be either one of the following values +-- (without quotes) or a comma-delimited list of one or more of the +-- following values (e.g. "[bold,underline]") indicating that all of +-- the specified styles be used. +-- * "standout" +-- * "underline" +-- * "reverseVideo" +-- * "blink" +-- * "dim" +-- * "bold" +-- * The "other" section specifies for each attribute name in the theme +-- the same "fg", "bg", and "style" settings as for the default +-- attribute. Furthermore, if an attribute name has multiple +-- components, the fields in the INI file should use periods as +-- delimiters. For example, if a theme has an attribute name ("foo" <> +-- "bar"), then the file may specify three fields: +-- * "foo.bar.fg" - a color specification +-- * "foo.bar.bg" - a color specification +-- * "foo.bar.style" - a style specification +-- +-- Any color or style specifications omitted from the file mean that +-- those attribute or style settings will use the theme's default value +-- instead. +-- +-- Attribute names with multiple components (e.g. attr1 <> attr2) can +-- be referenced in customization files by separating the names with +-- a dot. For example, the attribute name "list" <> "selected" can be +-- referenced by using the string "list.selected". +module Brick.Themes + ( CustomAttr(..) + , customFgL + , customBgL + , customStyleL + + , Theme(..) + , newTheme + , themeDefaultAttrL + , themeDefaultMappingL + , themeCustomMappingL + , themeCustomDefaultAttrL + + , ThemeDocumentation(..) + , themeDescriptionsL + + , themeToAttrMap + , applyCustomizations + , loadCustomizations + , saveCustomizations + , saveTheme + ) +where + +import GHC.Generics (Generic) +import Graphics.Vty hiding ((<|>)) +import Control.Monad (forM, join) +import Control.Applicative ((<|>)) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Map as M +import Data.Tuple (swap) +import Data.List (intercalate) +import Data.Bits ((.|.), (.&.)) +import Data.Maybe (fromMaybe, isNothing, catMaybes) +import Data.Monoid ((<>)) +import qualified Data.Foldable as F + +import Data.Ini.Config + +import Brick.AttrMap (AttrMap, AttrName, attrMap, attrNameComponents) +import Brick.Types.TH (suffixLenses) + +-- | An attribute customization can specify which aspects of an +-- attribute to customize. +data CustomAttr = + CustomAttr { customFg :: Maybe (MaybeDefault Color) + -- ^ The customized foreground, if any. + , customBg :: Maybe (MaybeDefault Color) + -- ^ The customized background, if any. + , customStyle :: Maybe Style + -- ^ The customized style, if any. + } + deriving (Eq, Read, Show, Generic) + +instance Monoid CustomAttr where + mempty = CustomAttr Nothing Nothing Nothing + mappend a b = + CustomAttr { customFg = customFg a <|> customFg b + , customBg = customBg a <|> customBg b + , customStyle = customStyle a <|> customStyle b + } + +-- | Documentation for a theme's attributes. +data ThemeDocumentation = + ThemeDocumentation { themeDescriptions :: M.Map AttrName T.Text + -- ^ The per-attribute documentation for a theme + -- so e.g. documentation for theme customization + -- can be generated mechanically. + } + deriving (Eq, Read, Show, Generic) + +-- | A theme provides a set of default attribute mappings, a default +-- attribute, and a set of customizations for the default mapping +-- and default attribute. The idea here is that the application will +-- always need to provide a complete specification of its attribute +-- mapping, but if the user wants to customize any aspect of that +-- default mapping, it can be contained here and then built into an +-- 'AttrMap' (see 'themeToAttrMap'). We keep the defaults separate +-- from customizations to permit users to serialize themes and their +-- customizations to, say, disk files. +data Theme = + Theme { themeDefaultAttr :: Attr + -- ^ The default attribute to use. + , themeDefaultMapping :: M.Map AttrName Attr + -- ^ The default attribute mapping to use. + , themeCustomDefaultAttr :: Maybe CustomAttr + -- ^ Customization for the theme's default attribute. + , themeCustomMapping :: M.Map AttrName CustomAttr + -- ^ Customizations for individual entries of the default + -- mapping. Note that this will only affect entries in the + -- default mapping; any attributes named here that are not + -- present in the default mapping will not be considered. + } + deriving (Eq, Read, Show, Generic) + +suffixLenses ''CustomAttr +suffixLenses ''Theme +suffixLenses ''ThemeDocumentation + +defaultSectionName :: T.Text +defaultSectionName = "default" + +otherSectionName :: T.Text +otherSectionName = "other" + +-- | Create a new theme with the specified default attribute and +-- attribute mapping. The theme will have no customizations. +newTheme :: Attr -> [(AttrName, Attr)] -> Theme +newTheme def mapping = + Theme { themeDefaultAttr = def + , themeDefaultMapping = M.fromList mapping + , themeCustomDefaultAttr = Nothing + , themeCustomMapping = mempty + } + +-- | Build an 'AttrMap' from a 'Theme'. This applies all customizations +-- in the returned 'AttrMap'. +themeToAttrMap :: Theme -> AttrMap +themeToAttrMap t = + attrMap (customizeAttr (themeCustomDefaultAttr t) (themeDefaultAttr t)) customMap + where + customMap = F.foldr f [] (M.toList $ themeDefaultMapping t) + f (aName, attr) mapping = + let a' = customizeAttr (M.lookup aName (themeCustomMapping t)) attr + in (aName, a'):mapping + +customizeAttr :: Maybe CustomAttr -> Attr -> Attr +customizeAttr Nothing a = a +customizeAttr (Just c) a = + let fg = fromMaybe (attrForeColor a) (customFg c) + bg = fromMaybe (attrBackColor a) (customBg c) + sty = maybe (attrStyle a) SetTo (customStyle c) + in a { attrForeColor = fg + , attrBackColor = bg + , attrStyle = sty + } + +isNullCustomization :: CustomAttr -> Bool +isNullCustomization c = + isNothing (customFg c) && + isNothing (customBg c) && + isNothing (customStyle c) + +parseColor :: T.Text -> Either String (MaybeDefault Color) +parseColor s = + let stripped = T.strip $ T.toLower s + in if stripped == "default" + then Right Default + else maybe (Left $ "Invalid color: " <> show s) (Right . SetTo) $ + lookup stripped (swap <$> allColors) + +allColors :: [(Color, T.Text)] +allColors = + [ (black, "black") + , (red, "red") + , (green, "green") + , (yellow, "yellow") + , (blue, "blue") + , (magenta, "magenta") + , (cyan, "cyan") + , (white, "white") + , (brightBlack, "brightBlack") + , (brightRed, "brightRed") + , (brightGreen, "brightGreen") + , (brightYellow, "brightYellow") + , (brightBlue, "brightBlue") + , (brightMagenta, "brightMagenta") + , (brightCyan, "brightCyan") + , (brightWhite, "brightWhite") + ] + +allStyles :: [(T.Text, Style)] +allStyles = + [ ("standout", standout) + , ("underline", underline) + , ("reverseVideo", reverseVideo) + , ("blink", blink) + , ("dim", dim) + , ("bold", bold) + ] + +parseStyle :: T.Text -> Either String Style +parseStyle s = + let lookupStyle n = case lookup n allStyles of + Just sty -> Right sty + Nothing -> Left $ T.unpack $ "Invalid style: " <> n + stripped = T.strip $ T.toLower s + bracketed = "[" `T.isPrefixOf` stripped && + "]" `T.isSuffixOf` stripped + unbracketed = T.tail $ T.init stripped + parseStyleList = do + ss <- mapM lookupStyle $ T.strip <$> T.splitOn "," unbracketed + return $ foldr (.|.) 0 ss + + in if bracketed + then parseStyleList + else lookupStyle stripped + +themeParser :: Theme -> IniParser (Maybe CustomAttr, M.Map AttrName CustomAttr) +themeParser t = do + let parseCustomAttr basename = do + c <- CustomAttr <$> fieldMbOf (basename <> ".fg") parseColor + <*> fieldMbOf (basename <> ".bg") parseColor + <*> fieldMbOf (basename <> ".style") parseStyle + return $ if isNullCustomization c then Nothing else Just c + + defCustom <- sectionMb defaultSectionName $ do + parseCustomAttr "default" + + customMap <- sectionMb otherSectionName $ do + catMaybes <$> (forM (M.keys $ themeDefaultMapping t) $ \an -> + (fmap (an,)) <$> parseCustomAttr (makeFieldName $ attrNameComponents an) + ) + + return (join defCustom, M.fromList $ fromMaybe [] customMap) + +-- | Apply customizations using a custom lookup function. Customizations +-- are obtained for each attribute name in the theme. Any customizations +-- already set are lost. +applyCustomizations :: Maybe CustomAttr + -- ^ An optional customization for the theme's + -- default attribute. + -> (AttrName -> Maybe CustomAttr) + -- ^ A function to obtain a customization for the + -- specified attribute. + -> Theme + -- ^ The theme to customize. + -> Theme +applyCustomizations customDefAttr lookupAttr t = + let customMap = foldr nextAttr mempty (M.keys $ themeDefaultMapping t) + nextAttr an m = case lookupAttr an of + Nothing -> m + Just custom -> M.insert an custom m + in t { themeCustomDefaultAttr = customDefAttr + , themeCustomMapping = customMap + } + +-- | Load an INI file containing theme customizations. Use the specified +-- theme to determine which customizations to load. Return the specified +-- theme with customizations set. See the module documentation for the +-- theme file format. +loadCustomizations :: FilePath -> Theme -> IO (Either String Theme) +loadCustomizations path t = do + content <- T.readFile path + case parseIniFile content (themeParser t) of + Left e -> return $ Left e + Right (customDef, customMap) -> + return $ Right $ applyCustomizations customDef (flip M.lookup customMap) t + +vtyColorName :: Color -> T.Text +vtyColorName (Color240 _) = error "Color240 space not supported yet" +vtyColorName c = + fromMaybe (error $ "Invalid color: " <> show c) + (lookup c allColors) + +makeFieldName :: [String] -> T.Text +makeFieldName cs = T.pack $ intercalate "." cs + +serializeCustomColor :: [String] -> MaybeDefault Color -> T.Text +serializeCustomColor cs cc = + let cName = case cc of + Default -> "default" + SetTo c -> vtyColorName c + KeepCurrent -> error "serializeCustomColor does not support KeepCurrent" + in makeFieldName cs <> " = " <> cName + +serializeCustomStyle :: [String] -> Style -> T.Text +serializeCustomStyle cs s = + let activeStyles = filter (\(_, a) -> a .&. s == a) allStyles + styleStr = case activeStyles of + [(single, _)] -> single + many -> "[" <> (T.intercalate ", " $ fst <$> many) <> "]" + in makeFieldName cs <> " = " <> styleStr + +serializeCustomAttr :: [String] -> CustomAttr -> [T.Text] +serializeCustomAttr cs c = + catMaybes [ serializeCustomColor (cs <> ["fg"]) <$> customFg c + , serializeCustomColor (cs <> ["bg"]) <$> customBg c + , serializeCustomStyle (cs <> ["style"]) <$> customStyle c + ] + +emitSection :: T.Text -> [T.Text] -> [T.Text] +emitSection _ [] = [] +emitSection secName ls = ("[" <> secName <> "]") : ls + +-- | Save an INI file containing theme customizations. Use the specified +-- theme to determine which customizations to save. See the module +-- documentation for the theme file format. +saveCustomizations :: FilePath -> Theme -> IO () +saveCustomizations path t = do + let defSection = fromMaybe [] $ + serializeCustomAttr ["default"] <$> themeCustomDefaultAttr t + mapSection = concat $ flip map (M.keys $ themeDefaultMapping t) $ \an -> + maybe [] (serializeCustomAttr (attrNameComponents an)) $ + M.lookup an $ themeCustomMapping t + content = T.unlines $ (emitSection defaultSectionName defSection) <> + (emitSection otherSectionName mapSection) + T.writeFile path content + +-- | Save an INI file containing all attributes from the specified +-- theme. Customized attributes are saved, but if an attribute is not +-- customized, its default is saved instead. The file can later be +-- re-loaded as a customization file. +saveTheme :: FilePath -> Theme -> IO () +saveTheme path t = do + let defSection = serializeCustomAttr ["default"] $ + fromMaybe (attrToCustom $ themeDefaultAttr t) (themeCustomDefaultAttr t) + mapSection = concat $ flip map (M.toList $ themeDefaultMapping t) $ \(an, def) -> + serializeCustomAttr (attrNameComponents an) $ + fromMaybe (attrToCustom def) (M.lookup an $ themeCustomMapping t) + content = T.unlines $ (emitSection defaultSectionName defSection) <> + (emitSection otherSectionName mapSection) + T.writeFile path content + +attrToCustom :: Attr -> CustomAttr +attrToCustom a = + CustomAttr { customFg = Just $ attrForeColor a + , customBg = Just $ attrForeColor a + , customStyle = case attrStyle a of + SetTo s -> Just s + _ -> Nothing + } diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -133,7 +133,7 @@ data Location = Location { loc :: (Int, Int) -- ^ (Column, Row) } - deriving (Show, Eq) + deriving (Show, Eq, Ord) suffixLenses ''Location @@ -210,7 +210,7 @@ -- ^ A mouse-up event on the specified region was -- received. The 'n' value is the resource name of -- the clicked widget (see 'clickable'). - deriving (Show, Eq) + deriving (Show, Eq, Ord) data RenderState n = RS { viewportMap :: M.Map n Viewport