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