1{-# LANGUAGE TupleSections #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE DeriveAnyClass #-} 4{-# LANGUAGE DeriveGeneric #-} 5{-# LANGUAGE TemplateHaskell #-} 6-- | Support for representing attribute themes and loading and saving 7-- theme customizations in INI-style files. 8-- 9-- The file format is as follows: 10-- 11-- Customization files are INI-style files with two sections, both 12-- optional: @"default"@ and @"other"@. 13-- 14-- The @"default"@ section specifies three optional fields: 15-- 16-- * @"default.fg"@ - a color specification 17-- * @"default.bg"@ - a color specification 18-- * @"default.style"@ - a style specification 19-- 20-- A color specification can be any of the strings @black@, @red@, 21-- @green@, @yellow@, @blue@, @magenta@, @cyan@, @white@, @brightBlack@, 22-- @brightRed@, @brightGreen@, @brightYellow@, @brightBlue@, 23-- @brightMagenta@, @brightCyan@, @brightWhite@, or @default@. 24-- 25-- We also support color specifications in the common hex format @#RRGGBB@, but 26-- note that this specification is lossy: terminals can only display 256 colors, 27-- but hex codes can specify @256^3 = 16777216@ colors. 28-- 29-- A style specification can be either one of the following values 30-- (without quotes) or a comma-delimited list of one or more of the 31-- following values (e.g. @"[bold,underline]"@) indicating that all 32-- of the specified styles be used. Valid styles are @standout@, 33-- @underline@, @reverseVideo@, @blink@, @dim@, @italic@, and @bold@. 34-- 35-- The @other@ section specifies for each attribute name in the theme 36-- the same @fg@, @bg@, and @style@ settings as for the default 37-- attribute. Furthermore, if an attribute name has multiple components, 38-- the fields in the INI file should use periods as delimiters. For 39-- example, if a theme has an attribute name (@"foo" <> "bar"@), then 40-- the file may specify three fields: 41-- 42-- * @foo.bar.fg@ - a color specification 43-- * @foo.bar.bg@ - a color specification 44-- * @foo.bar.style@ - a style specification 45-- 46-- Any color or style specifications omitted from the file mean that 47-- those attribute or style settings will use the theme's default value 48-- instead. 49-- 50-- Attribute names with multiple components (e.g. @attr1 <> attr2@) can 51-- be referenced in customization files by separating the names with 52-- a dot. For example, the attribute name @"list" <> "selected"@ can be 53-- referenced by using the string "list.selected". 54module Brick.Themes 55 ( CustomAttr(..) 56 , customFgL 57 , customBgL 58 , customStyleL 59 60 , Theme(..) 61 , newTheme 62 , themeDefaultAttrL 63 , themeDefaultMappingL 64 , themeCustomMappingL 65 , themeCustomDefaultAttrL 66 67 , ThemeDocumentation(..) 68 , themeDescriptionsL 69 70 , themeToAttrMap 71 , applyCustomizations 72 , loadCustomizations 73 , saveCustomizations 74 , saveTheme 75 ) 76where 77 78import GHC.Generics (Generic) 79import Graphics.Vty hiding ((<|>)) 80import Control.DeepSeq 81import Control.Monad (forM, join) 82import Control.Applicative ((<|>)) 83import qualified Data.Text as T 84import qualified Data.Text.Read as T 85import qualified Data.Text.IO as T 86import qualified Data.Map as M 87import qualified Data.Semigroup as Sem 88import Data.Tuple (swap) 89import Data.List (intercalate) 90import Data.Bits ((.|.), (.&.)) 91import Data.Maybe (fromMaybe, isNothing, catMaybes, mapMaybe) 92#if !(MIN_VERSION_base(4,11,0)) 93import Data.Monoid ((<>)) 94#endif 95import qualified Data.Foldable as F 96 97import Data.Ini.Config 98 99import Brick.AttrMap (AttrMap, AttrName, attrMap, attrNameComponents) 100import Brick.Types.TH (suffixLenses) 101 102import Text.Printf 103 104-- | An attribute customization can specify which aspects of an 105-- attribute to customize. 106data CustomAttr = 107 CustomAttr { customFg :: Maybe (MaybeDefault Color) 108 -- ^ The customized foreground, if any. 109 , customBg :: Maybe (MaybeDefault Color) 110 -- ^ The customized background, if any. 111 , customStyle :: Maybe Style 112 -- ^ The customized style, if any. 113 } 114 deriving (Eq, Read, Show, Generic, NFData) 115 116instance Sem.Semigroup CustomAttr where 117 a <> b = 118 CustomAttr { customFg = customFg a <|> customFg b 119 , customBg = customBg a <|> customBg b 120 , customStyle = customStyle a <|> customStyle b 121 } 122 123instance Monoid CustomAttr where 124 mempty = CustomAttr Nothing Nothing Nothing 125 mappend = (Sem.<>) 126 127-- | Documentation for a theme's attributes. 128data ThemeDocumentation = 129 ThemeDocumentation { themeDescriptions :: M.Map AttrName T.Text 130 -- ^ The per-attribute documentation for a theme 131 -- so e.g. documentation for theme customization 132 -- can be generated mechanically. 133 } 134 deriving (Eq, Read, Show, Generic, NFData) 135 136-- | A theme provides a set of default attribute mappings, a default 137-- attribute, and a set of customizations for the default mapping 138-- and default attribute. The idea here is that the application will 139-- always need to provide a complete specification of its attribute 140-- mapping, but if the user wants to customize any aspect of that 141-- default mapping, it can be contained here and then built into an 142-- 'AttrMap' (see 'themeToAttrMap'). We keep the defaults separate 143-- from customizations to permit users to serialize themes and their 144-- customizations to, say, disk files. 145data Theme = 146 Theme { themeDefaultAttr :: Attr 147 -- ^ The default attribute to use. 148 , themeDefaultMapping :: M.Map AttrName Attr 149 -- ^ The default attribute mapping to use. 150 , themeCustomDefaultAttr :: Maybe CustomAttr 151 -- ^ Customization for the theme's default attribute. 152 , themeCustomMapping :: M.Map AttrName CustomAttr 153 -- ^ Customizations for individual entries of the default 154 -- mapping. Note that this will only affect entries in the 155 -- default mapping; any attributes named here that are not 156 -- present in the default mapping will not be considered. 157 } 158 deriving (Eq, Read, Show, Generic, NFData) 159 160suffixLenses ''CustomAttr 161suffixLenses ''Theme 162suffixLenses ''ThemeDocumentation 163 164defaultSectionName :: T.Text 165defaultSectionName = "default" 166 167otherSectionName :: T.Text 168otherSectionName = "other" 169 170-- | Create a new theme with the specified default attribute and 171-- attribute mapping. The theme will have no customizations. 172newTheme :: Attr -> [(AttrName, Attr)] -> Theme 173newTheme def mapping = 174 Theme { themeDefaultAttr = def 175 , themeDefaultMapping = M.fromList mapping 176 , themeCustomDefaultAttr = Nothing 177 , themeCustomMapping = mempty 178 } 179 180-- | Build an 'AttrMap' from a 'Theme'. This applies all customizations 181-- in the returned 'AttrMap'. 182themeToAttrMap :: Theme -> AttrMap 183themeToAttrMap t = 184 attrMap (customizeAttr (themeCustomDefaultAttr t) (themeDefaultAttr t)) customMap 185 where 186 customMap = F.foldr f [] (M.toList $ themeDefaultMapping t) 187 f (aName, attr) mapping = 188 let a' = customizeAttr (M.lookup aName (themeCustomMapping t)) attr 189 in (aName, a'):mapping 190 191customizeAttr :: Maybe CustomAttr -> Attr -> Attr 192customizeAttr Nothing a = a 193customizeAttr (Just c) a = 194 let fg = fromMaybe (attrForeColor a) (customFg c) 195 bg = fromMaybe (attrBackColor a) (customBg c) 196 sty = maybe (attrStyle a) SetTo (customStyle c) 197 in a { attrForeColor = fg 198 , attrBackColor = bg 199 , attrStyle = sty 200 } 201 202isNullCustomization :: CustomAttr -> Bool 203isNullCustomization c = 204 isNothing (customFg c) && 205 isNothing (customBg c) && 206 isNothing (customStyle c) 207 208-- | This function is lossy in the sense that we only internally support 240 colors but 209-- the #RRGGBB format supports 16^3 colors. 210parseColor :: T.Text -> Either String (MaybeDefault Color) 211parseColor s = 212 let stripped = T.strip $ T.toLower s 213 normalize (t, c) = (T.toLower t, c) 214 in if stripped == "default" 215 then Right Default 216 else case parseRGB stripped of 217 Just c -> Right (SetTo c) 218 Nothing -> maybe (Left $ "Invalid color: " <> show stripped) (Right . SetTo) $ 219 lookup stripped (normalize <$> swap <$> allColors) 220 where 221 parseRGB t = if T.head t /= '#' 222 then Nothing 223 else case mapMaybe readHex (T.chunksOf 2 (T.tail t)) of 224 [r,g,b] -> Just (rgbColor r g b) 225 _ -> Nothing 226 227 readHex :: T.Text -> Maybe Int 228 readHex t = either (const Nothing) (Just . fst) (T.hexadecimal t) 229 230allColors :: [(Color, T.Text)] 231allColors = 232 [ (black, "black") 233 , (red, "red") 234 , (green, "green") 235 , (yellow, "yellow") 236 , (blue, "blue") 237 , (magenta, "magenta") 238 , (cyan, "cyan") 239 , (white, "white") 240 , (brightBlack, "brightBlack") 241 , (brightRed, "brightRed") 242 , (brightGreen, "brightGreen") 243 , (brightYellow, "brightYellow") 244 , (brightBlue, "brightBlue") 245 , (brightMagenta, "brightMagenta") 246 , (brightCyan, "brightCyan") 247 , (brightWhite, "brightWhite") 248 ] 249 250allStyles :: [(T.Text, Style)] 251allStyles = 252 [ ("standout", standout) 253 , ("underline", underline) 254 , ("reversevideo", reverseVideo) 255 , ("blink", blink) 256 , ("dim", dim) 257 , ("bold", bold) 258 , ("italic", italic) 259 ] 260 261parseStyle :: T.Text -> Either String Style 262parseStyle s = 263 let lookupStyle "" = Right Nothing 264 lookupStyle n = case lookup n normalizedStyles of 265 Just sty -> Right $ Just sty 266 Nothing -> Left $ T.unpack $ "Invalid style: " <> n 267 stripped = T.strip $ T.toLower s 268 normalize (n, a) = (T.toLower n, a) 269 normalizedStyles = normalize <$> allStyles 270 bracketed = "[" `T.isPrefixOf` stripped && 271 "]" `T.isSuffixOf` stripped 272 unbracketed = T.tail $ T.init stripped 273 parseStyleList = do 274 ss <- mapM lookupStyle $ T.strip <$> T.splitOn "," unbracketed 275 return $ foldr (.|.) 0 $ catMaybes ss 276 277 in if bracketed 278 then parseStyleList 279 else do 280 result <- lookupStyle stripped 281 case result of 282 Nothing -> Left $ "Invalid style: " <> show stripped 283 Just sty -> Right sty 284 285themeParser :: Theme -> IniParser (Maybe CustomAttr, M.Map AttrName CustomAttr) 286themeParser t = do 287 let parseCustomAttr basename = do 288 c <- CustomAttr <$> fieldMbOf (basename <> ".fg") parseColor 289 <*> fieldMbOf (basename <> ".bg") parseColor 290 <*> fieldMbOf (basename <> ".style") parseStyle 291 return $ if isNullCustomization c then Nothing else Just c 292 293 defCustom <- sectionMb defaultSectionName $ do 294 parseCustomAttr "default" 295 296 customMap <- sectionMb otherSectionName $ do 297 catMaybes <$> (forM (M.keys $ themeDefaultMapping t) $ \an -> 298 (fmap (an,)) <$> parseCustomAttr (makeFieldName $ attrNameComponents an) 299 ) 300 301 return (join defCustom, M.fromList $ fromMaybe [] customMap) 302 303-- | Apply customizations using a custom lookup function. Customizations 304-- are obtained for each attribute name in the theme. Any customizations 305-- already set are lost. 306applyCustomizations :: Maybe CustomAttr 307 -- ^ An optional customization for the theme's 308 -- default attribute. 309 -> (AttrName -> Maybe CustomAttr) 310 -- ^ A function to obtain a customization for the 311 -- specified attribute. 312 -> Theme 313 -- ^ The theme to customize. 314 -> Theme 315applyCustomizations customDefAttr lookupAttr t = 316 let customMap = foldr nextAttr mempty (M.keys $ themeDefaultMapping t) 317 nextAttr an m = case lookupAttr an of 318 Nothing -> m 319 Just custom -> M.insert an custom m 320 in t { themeCustomDefaultAttr = customDefAttr 321 , themeCustomMapping = customMap 322 } 323 324-- | Load an INI file containing theme customizations. Use the specified 325-- theme to determine which customizations to load. Return the specified 326-- theme with customizations set. See the module documentation for the 327-- theme file format. 328loadCustomizations :: FilePath -> Theme -> IO (Either String Theme) 329loadCustomizations path t = do 330 content <- T.readFile path 331 case parseIniFile content (themeParser t) of 332 Left e -> return $ Left e 333 Right (customDef, customMap) -> 334 return $ Right $ applyCustomizations customDef (flip M.lookup customMap) t 335 336vtyColorName :: Color -> T.Text 337vtyColorName c@(Color240 n) = case color240CodeToRGB (fromIntegral n) of 338 Just (r,g,b) -> T.pack (printf "#%02x%02x%02x" r g b) 339 Nothing -> (error $ "Invalid color: " <> show c) 340vtyColorName c = 341 fromMaybe (error $ "Invalid color: " <> show c) 342 (lookup c allColors) 343 344makeFieldName :: [String] -> T.Text 345makeFieldName cs = T.pack $ intercalate "." cs 346 347serializeCustomColor :: [String] -> MaybeDefault Color -> T.Text 348serializeCustomColor cs cc = 349 let cName = case cc of 350 Default -> "default" 351 SetTo c -> vtyColorName c 352 KeepCurrent -> error "serializeCustomColor does not support KeepCurrent" 353 in makeFieldName cs <> " = " <> cName 354 355serializeCustomStyle :: [String] -> Style -> T.Text 356serializeCustomStyle cs s = 357 let activeStyles = filter (\(_, a) -> a .&. s == a) allStyles 358 styleStr = case activeStyles of 359 [(single, _)] -> single 360 many -> "[" <> (T.intercalate ", " $ fst <$> many) <> "]" 361 in makeFieldName cs <> " = " <> styleStr 362 363serializeCustomAttr :: [String] -> CustomAttr -> [T.Text] 364serializeCustomAttr cs c = 365 catMaybes [ serializeCustomColor (cs <> ["fg"]) <$> customFg c 366 , serializeCustomColor (cs <> ["bg"]) <$> customBg c 367 , serializeCustomStyle (cs <> ["style"]) <$> customStyle c 368 ] 369 370emitSection :: T.Text -> [T.Text] -> [T.Text] 371emitSection _ [] = [] 372emitSection secName ls = ("[" <> secName <> "]") : ls 373 374-- | Save an INI file containing theme customizations. Use the specified 375-- theme to determine which customizations to save. See the module 376-- documentation for the theme file format. 377saveCustomizations :: FilePath -> Theme -> IO () 378saveCustomizations path t = do 379 let defSection = fromMaybe [] $ 380 serializeCustomAttr ["default"] <$> themeCustomDefaultAttr t 381 mapSection = concat $ flip map (M.keys $ themeDefaultMapping t) $ \an -> 382 maybe [] (serializeCustomAttr (attrNameComponents an)) $ 383 M.lookup an $ themeCustomMapping t 384 content = T.unlines $ (emitSection defaultSectionName defSection) <> 385 (emitSection otherSectionName mapSection) 386 T.writeFile path content 387 388-- | Save an INI file containing all attributes from the specified 389-- theme. Customized attributes are saved, but if an attribute is not 390-- customized, its default is saved instead. The file can later be 391-- re-loaded as a customization file. 392saveTheme :: FilePath -> Theme -> IO () 393saveTheme path t = do 394 let defSection = serializeCustomAttr ["default"] $ 395 fromMaybe (attrToCustom $ themeDefaultAttr t) (themeCustomDefaultAttr t) 396 mapSection = concat $ flip map (M.toList $ themeDefaultMapping t) $ \(an, def) -> 397 serializeCustomAttr (attrNameComponents an) $ 398 fromMaybe (attrToCustom def) (M.lookup an $ themeCustomMapping t) 399 content = T.unlines $ (emitSection defaultSectionName defSection) <> 400 (emitSection otherSectionName mapSection) 401 T.writeFile path content 402 403attrToCustom :: Attr -> CustomAttr 404attrToCustom a = 405 CustomAttr { customFg = Just $ attrForeColor a 406 , customBg = Just $ attrForeColor a 407 , customStyle = case attrStyle a of 408 SetTo s -> Just s 409 _ -> Nothing 410 } 411