{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# 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 strings @black@, @red@,
-- @green@, @yellow@, @blue@, @magenta@, @cyan@, @white@, @brightBlack@,
-- @brightRed@, @brightGreen@, @brightYellow@, @brightBlue@,
-- @brightMagenta@, @brightCyan@, @brightWhite@, or @default@.
--
-- We also support color specifications in the common hex format @#RRGGBB@, but
-- note that this specification is lossy: terminals can only display 256 colors,
-- but hex codes can specify @256^3 = 16777216@ colors.
--
-- 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. Valid styles are @standout@,
-- @underline@, @reverseVideo@, @blink@, @dim@, @italic@,
-- @strikethrough@, and @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.DeepSeq
import Control.Monad (forM, join)
import Control.Applicative ((<|>))
import qualified Data.Text as T
import qualified Data.Text.Read as T
import qualified Data.Text.IO as T
import qualified Data.Map as M
import qualified Data.Semigroup as Sem
import Data.Tuple (swap)
import Data.List (intercalate)
import Data.Bits ((.|.), (.&.))
import Data.Maybe (fromMaybe, isNothing, catMaybes, mapMaybe)
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>))
#endif
import qualified Data.Foldable as F

import Data.Ini.Config

import Brick.AttrMap (AttrMap, AttrName, attrMap, attrNameComponents)
import Brick.Types.TH (suffixLenses)

import Text.Printf

-- | An attribute customization can specify which aspects of an
-- attribute to customize.
data CustomAttr =
    CustomAttr { CustomAttr -> Maybe (MaybeDefault Color)
customFg    :: Maybe (MaybeDefault Color)
               -- ^ The customized foreground, if any.
               , CustomAttr -> Maybe (MaybeDefault Color)
customBg    :: Maybe (MaybeDefault Color)
               -- ^ The customized background, if any.
               , CustomAttr -> Maybe Style
customStyle :: Maybe Style
               -- ^ The customized style, if any.
               }
               deriving (CustomAttr -> CustomAttr -> Bool
(CustomAttr -> CustomAttr -> Bool)
-> (CustomAttr -> CustomAttr -> Bool) -> Eq CustomAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CustomAttr -> CustomAttr -> Bool
$c/= :: CustomAttr -> CustomAttr -> Bool
== :: CustomAttr -> CustomAttr -> Bool
$c== :: CustomAttr -> CustomAttr -> Bool
Eq, ReadPrec [CustomAttr]
ReadPrec CustomAttr
Int -> ReadS CustomAttr
ReadS [CustomAttr]
(Int -> ReadS CustomAttr)
-> ReadS [CustomAttr]
-> ReadPrec CustomAttr
-> ReadPrec [CustomAttr]
-> Read CustomAttr
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CustomAttr]
$creadListPrec :: ReadPrec [CustomAttr]
readPrec :: ReadPrec CustomAttr
$creadPrec :: ReadPrec CustomAttr
readList :: ReadS [CustomAttr]
$creadList :: ReadS [CustomAttr]
readsPrec :: Int -> ReadS CustomAttr
$creadsPrec :: Int -> ReadS CustomAttr
Read, Int -> CustomAttr -> ShowS
[CustomAttr] -> ShowS
CustomAttr -> String
(Int -> CustomAttr -> ShowS)
-> (CustomAttr -> String)
-> ([CustomAttr] -> ShowS)
-> Show CustomAttr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CustomAttr] -> ShowS
$cshowList :: [CustomAttr] -> ShowS
show :: CustomAttr -> String
$cshow :: CustomAttr -> String
showsPrec :: Int -> CustomAttr -> ShowS
$cshowsPrec :: Int -> CustomAttr -> ShowS
Show, (forall x. CustomAttr -> Rep CustomAttr x)
-> (forall x. Rep CustomAttr x -> CustomAttr) -> Generic CustomAttr
forall x. Rep CustomAttr x -> CustomAttr
forall x. CustomAttr -> Rep CustomAttr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CustomAttr x -> CustomAttr
$cfrom :: forall x. CustomAttr -> Rep CustomAttr x
Generic, CustomAttr -> ()
(CustomAttr -> ()) -> NFData CustomAttr
forall a. (a -> ()) -> NFData a
rnf :: CustomAttr -> ()
$crnf :: CustomAttr -> ()
NFData)

instance Sem.Semigroup CustomAttr where
    CustomAttr
a <> :: CustomAttr -> CustomAttr -> CustomAttr
<> CustomAttr
b =
        CustomAttr :: Maybe (MaybeDefault Color)
-> Maybe (MaybeDefault Color) -> Maybe Style -> CustomAttr
CustomAttr { customFg :: Maybe (MaybeDefault Color)
customFg    = CustomAttr -> Maybe (MaybeDefault Color)
customFg CustomAttr
a    Maybe (MaybeDefault Color)
-> Maybe (MaybeDefault Color) -> Maybe (MaybeDefault Color)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CustomAttr -> Maybe (MaybeDefault Color)
customFg CustomAttr
b
                   , customBg :: Maybe (MaybeDefault Color)
customBg    = CustomAttr -> Maybe (MaybeDefault Color)
customBg CustomAttr
a    Maybe (MaybeDefault Color)
-> Maybe (MaybeDefault Color) -> Maybe (MaybeDefault Color)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CustomAttr -> Maybe (MaybeDefault Color)
customBg CustomAttr
b
                   , customStyle :: Maybe Style
customStyle = CustomAttr -> Maybe Style
customStyle CustomAttr
a Maybe Style -> Maybe Style -> Maybe Style
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CustomAttr -> Maybe Style
customStyle CustomAttr
b
                   }

instance Monoid CustomAttr where
    mempty :: CustomAttr
mempty = Maybe (MaybeDefault Color)
-> Maybe (MaybeDefault Color) -> Maybe Style -> CustomAttr
CustomAttr Maybe (MaybeDefault Color)
forall a. Maybe a
Nothing Maybe (MaybeDefault Color)
forall a. Maybe a
Nothing Maybe Style
forall a. Maybe a
Nothing
    mappend :: CustomAttr -> CustomAttr -> CustomAttr
mappend = CustomAttr -> CustomAttr -> CustomAttr
forall a. Semigroup a => a -> a -> a
(Sem.<>)

-- | Documentation for a theme's attributes.
data ThemeDocumentation =
    ThemeDocumentation { ThemeDocumentation -> Map AttrName Text
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 (ThemeDocumentation -> ThemeDocumentation -> Bool
(ThemeDocumentation -> ThemeDocumentation -> Bool)
-> (ThemeDocumentation -> ThemeDocumentation -> Bool)
-> Eq ThemeDocumentation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThemeDocumentation -> ThemeDocumentation -> Bool
$c/= :: ThemeDocumentation -> ThemeDocumentation -> Bool
== :: ThemeDocumentation -> ThemeDocumentation -> Bool
$c== :: ThemeDocumentation -> ThemeDocumentation -> Bool
Eq, ReadPrec [ThemeDocumentation]
ReadPrec ThemeDocumentation
Int -> ReadS ThemeDocumentation
ReadS [ThemeDocumentation]
(Int -> ReadS ThemeDocumentation)
-> ReadS [ThemeDocumentation]
-> ReadPrec ThemeDocumentation
-> ReadPrec [ThemeDocumentation]
-> Read ThemeDocumentation
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ThemeDocumentation]
$creadListPrec :: ReadPrec [ThemeDocumentation]
readPrec :: ReadPrec ThemeDocumentation
$creadPrec :: ReadPrec ThemeDocumentation
readList :: ReadS [ThemeDocumentation]
$creadList :: ReadS [ThemeDocumentation]
readsPrec :: Int -> ReadS ThemeDocumentation
$creadsPrec :: Int -> ReadS ThemeDocumentation
Read, Int -> ThemeDocumentation -> ShowS
[ThemeDocumentation] -> ShowS
ThemeDocumentation -> String
(Int -> ThemeDocumentation -> ShowS)
-> (ThemeDocumentation -> String)
-> ([ThemeDocumentation] -> ShowS)
-> Show ThemeDocumentation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThemeDocumentation] -> ShowS
$cshowList :: [ThemeDocumentation] -> ShowS
show :: ThemeDocumentation -> String
$cshow :: ThemeDocumentation -> String
showsPrec :: Int -> ThemeDocumentation -> ShowS
$cshowsPrec :: Int -> ThemeDocumentation -> ShowS
Show, (forall x. ThemeDocumentation -> Rep ThemeDocumentation x)
-> (forall x. Rep ThemeDocumentation x -> ThemeDocumentation)
-> Generic ThemeDocumentation
forall x. Rep ThemeDocumentation x -> ThemeDocumentation
forall x. ThemeDocumentation -> Rep ThemeDocumentation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ThemeDocumentation x -> ThemeDocumentation
$cfrom :: forall x. ThemeDocumentation -> Rep ThemeDocumentation x
Generic, ThemeDocumentation -> ()
(ThemeDocumentation -> ()) -> NFData ThemeDocumentation
forall a. (a -> ()) -> NFData a
rnf :: ThemeDocumentation -> ()
$crnf :: ThemeDocumentation -> ()
NFData)

-- | 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 { Theme -> Attr
themeDefaultAttr :: Attr
          -- ^ The default attribute to use.
          , Theme -> Map AttrName Attr
themeDefaultMapping :: M.Map AttrName Attr
          -- ^ The default attribute mapping to use.
          , Theme -> Maybe CustomAttr
themeCustomDefaultAttr :: Maybe CustomAttr
          -- ^ Customization for the theme's default attribute.
          , Theme -> Map AttrName CustomAttr
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 (Theme -> Theme -> Bool
(Theme -> Theme -> Bool) -> (Theme -> Theme -> Bool) -> Eq Theme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Theme -> Theme -> Bool
$c/= :: Theme -> Theme -> Bool
== :: Theme -> Theme -> Bool
$c== :: Theme -> Theme -> Bool
Eq, ReadPrec [Theme]
ReadPrec Theme
Int -> ReadS Theme
ReadS [Theme]
(Int -> ReadS Theme)
-> ReadS [Theme]
-> ReadPrec Theme
-> ReadPrec [Theme]
-> Read Theme
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Theme]
$creadListPrec :: ReadPrec [Theme]
readPrec :: ReadPrec Theme
$creadPrec :: ReadPrec Theme
readList :: ReadS [Theme]
$creadList :: ReadS [Theme]
readsPrec :: Int -> ReadS Theme
$creadsPrec :: Int -> ReadS Theme
Read, Int -> Theme -> ShowS
[Theme] -> ShowS
Theme -> String
(Int -> Theme -> ShowS)
-> (Theme -> String) -> ([Theme] -> ShowS) -> Show Theme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Theme] -> ShowS
$cshowList :: [Theme] -> ShowS
show :: Theme -> String
$cshow :: Theme -> String
showsPrec :: Int -> Theme -> ShowS
$cshowsPrec :: Int -> Theme -> ShowS
Show, (forall x. Theme -> Rep Theme x)
-> (forall x. Rep Theme x -> Theme) -> Generic Theme
forall x. Rep Theme x -> Theme
forall x. Theme -> Rep Theme x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Theme x -> Theme
$cfrom :: forall x. Theme -> Rep Theme x
Generic, Theme -> ()
(Theme -> ()) -> NFData Theme
forall a. (a -> ()) -> NFData a
rnf :: Theme -> ()
$crnf :: Theme -> ()
NFData)

suffixLenses ''CustomAttr
suffixLenses ''Theme
suffixLenses ''ThemeDocumentation

defaultSectionName :: T.Text
defaultSectionName :: Text
defaultSectionName = Text
"default"

otherSectionName :: T.Text
otherSectionName :: Text
otherSectionName = Text
"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 :: Attr -> [(AttrName, Attr)] -> Theme
newTheme Attr
def [(AttrName, Attr)]
mapping =
    Theme :: Attr
-> Map AttrName Attr
-> Maybe CustomAttr
-> Map AttrName CustomAttr
-> Theme
Theme { themeDefaultAttr :: Attr
themeDefaultAttr       = Attr
def
          , themeDefaultMapping :: Map AttrName Attr
themeDefaultMapping    = [(AttrName, Attr)] -> Map AttrName Attr
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(AttrName, Attr)]
mapping
          , themeCustomDefaultAttr :: Maybe CustomAttr
themeCustomDefaultAttr = Maybe CustomAttr
forall a. Maybe a
Nothing
          , themeCustomMapping :: Map AttrName CustomAttr
themeCustomMapping     = Map AttrName CustomAttr
forall a. Monoid a => a
mempty
          }

-- | Build an 'AttrMap' from a 'Theme'. This applies all customizations
-- in the returned 'AttrMap'.
themeToAttrMap :: Theme -> AttrMap
themeToAttrMap :: Theme -> AttrMap
themeToAttrMap Theme
t =
    Attr -> [(AttrName, Attr)] -> AttrMap
attrMap (Maybe CustomAttr -> Attr -> Attr
customizeAttr (Theme -> Maybe CustomAttr
themeCustomDefaultAttr Theme
t) (Theme -> Attr
themeDefaultAttr Theme
t)) [(AttrName, Attr)]
customMap
    where
        customMap :: [(AttrName, Attr)]
customMap = ((AttrName, Attr) -> [(AttrName, Attr)] -> [(AttrName, Attr)])
-> [(AttrName, Attr)] -> [(AttrName, Attr)] -> [(AttrName, Attr)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (AttrName, Attr) -> [(AttrName, Attr)] -> [(AttrName, Attr)]
f [] (Map AttrName Attr -> [(AttrName, Attr)]
forall k a. Map k a -> [(k, a)]
M.toList (Map AttrName Attr -> [(AttrName, Attr)])
-> Map AttrName Attr -> [(AttrName, Attr)]
forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName Attr
themeDefaultMapping Theme
t)
        f :: (AttrName, Attr) -> [(AttrName, Attr)] -> [(AttrName, Attr)]
f (AttrName
aName, Attr
attr) [(AttrName, Attr)]
mapping =
            let a' :: Attr
a' = Maybe CustomAttr -> Attr -> Attr
customizeAttr (AttrName -> Map AttrName CustomAttr -> Maybe CustomAttr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttrName
aName (Theme -> Map AttrName CustomAttr
themeCustomMapping Theme
t)) Attr
attr
            in (AttrName
aName, Attr
a')(AttrName, Attr) -> [(AttrName, Attr)] -> [(AttrName, Attr)]
forall a. a -> [a] -> [a]
:[(AttrName, Attr)]
mapping

customizeAttr :: Maybe CustomAttr -> Attr -> Attr
customizeAttr :: Maybe CustomAttr -> Attr -> Attr
customizeAttr Maybe CustomAttr
Nothing Attr
a = Attr
a
customizeAttr (Just CustomAttr
c) Attr
a =
    let fg :: MaybeDefault Color
fg = MaybeDefault Color
-> Maybe (MaybeDefault Color) -> MaybeDefault Color
forall a. a -> Maybe a -> a
fromMaybe (Attr -> MaybeDefault Color
attrForeColor Attr
a) (CustomAttr -> Maybe (MaybeDefault Color)
customFg CustomAttr
c)
        bg :: MaybeDefault Color
bg = MaybeDefault Color
-> Maybe (MaybeDefault Color) -> MaybeDefault Color
forall a. a -> Maybe a -> a
fromMaybe (Attr -> MaybeDefault Color
attrBackColor Attr
a) (CustomAttr -> Maybe (MaybeDefault Color)
customBg CustomAttr
c)
        sty :: MaybeDefault Style
sty = MaybeDefault Style
-> (Style -> MaybeDefault Style)
-> Maybe Style
-> MaybeDefault Style
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Attr -> MaybeDefault Style
attrStyle Attr
a) Style -> MaybeDefault Style
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo (CustomAttr -> Maybe Style
customStyle CustomAttr
c)
    in Attr
a { attrForeColor :: MaybeDefault Color
attrForeColor = MaybeDefault Color
fg
         , attrBackColor :: MaybeDefault Color
attrBackColor = MaybeDefault Color
bg
         , attrStyle :: MaybeDefault Style
attrStyle = MaybeDefault Style
sty
         }

isNullCustomization :: CustomAttr -> Bool
isNullCustomization :: CustomAttr -> Bool
isNullCustomization CustomAttr
c =
    Maybe (MaybeDefault Color) -> Bool
forall a. Maybe a -> Bool
isNothing (CustomAttr -> Maybe (MaybeDefault Color)
customFg CustomAttr
c) Bool -> Bool -> Bool
&&
    Maybe (MaybeDefault Color) -> Bool
forall a. Maybe a -> Bool
isNothing (CustomAttr -> Maybe (MaybeDefault Color)
customBg CustomAttr
c) Bool -> Bool -> Bool
&&
    Maybe Style -> Bool
forall a. Maybe a -> Bool
isNothing (CustomAttr -> Maybe Style
customStyle CustomAttr
c)

-- |  This function is lossy in the sense that we only internally support 240 colors but
-- the #RRGGBB format supports 16^3 colors.
parseColor :: T.Text -> Either String (MaybeDefault Color)
parseColor :: Text -> Either String (MaybeDefault Color)
parseColor Text
s =
    let stripped :: Text
stripped = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower Text
s
        normalize :: (Text, b) -> (Text, b)
normalize (Text
t, b
c) = (Text -> Text
T.toLower Text
t, b
c)
    in if Text
stripped Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"default"
          then MaybeDefault Color -> Either String (MaybeDefault Color)
forall a b. b -> Either a b
Right MaybeDefault Color
forall v. MaybeDefault v
Default
          else case Text -> Maybe Color
parseRGB Text
stripped of
              Just Color
c  -> MaybeDefault Color -> Either String (MaybeDefault Color)
forall a b. b -> Either a b
Right (Color -> MaybeDefault Color
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo Color
c)
              Maybe Color
Nothing -> Either String (MaybeDefault Color)
-> (Color -> Either String (MaybeDefault Color))
-> Maybe Color
-> Either String (MaybeDefault Color)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String (MaybeDefault Color)
forall a b. a -> Either a b
Left (String -> Either String (MaybeDefault Color))
-> String -> Either String (MaybeDefault Color)
forall a b. (a -> b) -> a -> b
$ String
"Invalid color: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
stripped) (MaybeDefault Color -> Either String (MaybeDefault Color)
forall a b. b -> Either a b
Right (MaybeDefault Color -> Either String (MaybeDefault Color))
-> (Color -> MaybeDefault Color)
-> Color
-> Either String (MaybeDefault Color)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> MaybeDefault Color
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo) (Maybe Color -> Either String (MaybeDefault Color))
-> Maybe Color -> Either String (MaybeDefault Color)
forall a b. (a -> b) -> a -> b
$
                             Text -> [(Text, Color)] -> Maybe Color
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
stripped ((Text, Color) -> (Text, Color)
forall b. (Text, b) -> (Text, b)
normalize ((Text, Color) -> (Text, Color))
-> ((Color, Text) -> (Text, Color))
-> (Color, Text)
-> (Text, Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Color, Text) -> (Text, Color)
forall a b. (a, b) -> (b, a)
swap ((Color, Text) -> (Text, Color))
-> [(Color, Text)] -> [(Text, Color)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Color, Text)]
allColors)
  where
    parseRGB :: Text -> Maybe Color
parseRGB Text
t = if Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#'
                    then Maybe Color
forall a. Maybe a
Nothing
                    else case (Text -> Maybe Int) -> [Text] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Int
readHex (Int -> Text -> [Text]
T.chunksOf Int
2 (Text -> Text
T.tail Text
t)) of
                            [Int
r,Int
g,Int
b] -> Color -> Maybe Color
forall a. a -> Maybe a
Just (Int -> Int -> Int -> Color
forall i. Integral i => i -> i -> i -> Color
rgbColor Int
r Int
g Int
b)
                            [Int]
_ -> Maybe Color
forall a. Maybe a
Nothing

    readHex :: T.Text -> Maybe Int
    readHex :: Text -> Maybe Int
readHex Text
t = (String -> Maybe Int)
-> ((Int, Text) -> Maybe Int)
-> Either String (Int, Text)
-> Maybe Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Int -> String -> Maybe Int
forall a b. a -> b -> a
const Maybe Int
forall a. Maybe a
Nothing) (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ((Int, Text) -> Int) -> (Int, Text) -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Text) -> Int
forall a b. (a, b) -> a
fst) (Reader Int
forall a. Integral a => Reader a
T.hexadecimal Text
t)

allColors :: [(Color, T.Text)]
allColors :: [(Color, Text)]
allColors =
    [ (Color
black, Text
"black")
    , (Color
red, Text
"red")
    , (Color
green, Text
"green")
    , (Color
yellow, Text
"yellow")
    , (Color
blue, Text
"blue")
    , (Color
magenta, Text
"magenta")
    , (Color
cyan, Text
"cyan")
    , (Color
white, Text
"white")
    , (Color
brightBlack, Text
"brightBlack")
    , (Color
brightRed, Text
"brightRed")
    , (Color
brightGreen, Text
"brightGreen")
    , (Color
brightYellow, Text
"brightYellow")
    , (Color
brightBlue, Text
"brightBlue")
    , (Color
brightMagenta, Text
"brightMagenta")
    , (Color
brightCyan, Text
"brightCyan")
    , (Color
brightWhite, Text
"brightWhite")
    ]

allStyles :: [(T.Text, Style)]
allStyles :: [(Text, Style)]
allStyles =
    [ (Text
"standout", Style
standout)
    , (Text
"underline", Style
underline)
    , (Text
"strikethrough", Style
strikethrough)
    , (Text
"reversevideo", Style
reverseVideo)
    , (Text
"blink", Style
blink)
    , (Text
"dim", Style
dim)
    , (Text
"bold", Style
bold)
    , (Text
"italic", Style
italic)
    ]

parseStyle :: T.Text -> Either String Style
parseStyle :: Text -> Either String Style
parseStyle Text
s =
    let lookupStyle :: Text -> Either String (Maybe Style)
lookupStyle Text
"" = Maybe Style -> Either String (Maybe Style)
forall a b. b -> Either a b
Right Maybe Style
forall a. Maybe a
Nothing
        lookupStyle Text
n = case Text -> [(Text, Style)] -> Maybe Style
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
n [(Text, Style)]
normalizedStyles of
            Just Style
sty -> Maybe Style -> Either String (Maybe Style)
forall a b. b -> Either a b
Right (Maybe Style -> Either String (Maybe Style))
-> Maybe Style -> Either String (Maybe Style)
forall a b. (a -> b) -> a -> b
$ Style -> Maybe Style
forall a. a -> Maybe a
Just Style
sty
            Maybe Style
Nothing  -> String -> Either String (Maybe Style)
forall a b. a -> Either a b
Left (String -> Either String (Maybe Style))
-> String -> Either String (Maybe Style)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Invalid style: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n
        stripped :: Text
stripped = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower Text
s
        normalize :: (Text, b) -> (Text, b)
normalize (Text
n, b
a) = (Text -> Text
T.toLower Text
n, b
a)
        normalizedStyles :: [(Text, Style)]
normalizedStyles = (Text, Style) -> (Text, Style)
forall b. (Text, b) -> (Text, b)
normalize ((Text, Style) -> (Text, Style))
-> [(Text, Style)] -> [(Text, Style)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Style)]
allStyles
        bracketed :: Bool
bracketed = Text
"[" Text -> Text -> Bool
`T.isPrefixOf` Text
stripped Bool -> Bool -> Bool
&&
                    Text
"]" Text -> Text -> Bool
`T.isSuffixOf` Text
stripped
        unbracketed :: Text
unbracketed = Text -> Text
T.tail (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.init Text
stripped
        parseStyleList :: Either String Style
parseStyleList = do
            [Maybe Style]
ss <- (Text -> Either String (Maybe Style))
-> [Text] -> Either String [Maybe Style]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Either String (Maybe Style)
lookupStyle ([Text] -> Either String [Maybe Style])
-> [Text] -> Either String [Maybe Style]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> [Text]
T.splitOn Text
"," Text
unbracketed
            Style -> Either String Style
forall (m :: * -> *) a. Monad m => a -> m a
return (Style -> Either String Style) -> Style -> Either String Style
forall a b. (a -> b) -> a -> b
$ (Style -> Style -> Style) -> Style -> [Style] -> Style
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Style -> Style -> Style
forall a. Bits a => a -> a -> a
(.|.) Style
0 ([Style] -> Style) -> [Style] -> Style
forall a b. (a -> b) -> a -> b
$ [Maybe Style] -> [Style]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Style]
ss

    in if Bool
bracketed
       then Either String Style
parseStyleList
       else do
           Maybe Style
result <- Text -> Either String (Maybe Style)
lookupStyle Text
stripped
           case Maybe Style
result of
               Maybe Style
Nothing -> String -> Either String Style
forall a b. a -> Either a b
Left (String -> Either String Style) -> String -> Either String Style
forall a b. (a -> b) -> a -> b
$ String
"Invalid style: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
stripped
               Just Style
sty -> Style -> Either String Style
forall a b. b -> Either a b
Right Style
sty

themeParser :: Theme -> IniParser (Maybe CustomAttr, M.Map AttrName CustomAttr)
themeParser :: Theme -> IniParser (Maybe CustomAttr, Map AttrName CustomAttr)
themeParser Theme
t = do
    let parseCustomAttr :: Text -> SectionParser (Maybe CustomAttr)
parseCustomAttr Text
basename = do
          CustomAttr
c <- Maybe (MaybeDefault Color)
-> Maybe (MaybeDefault Color) -> Maybe Style -> CustomAttr
CustomAttr (Maybe (MaybeDefault Color)
 -> Maybe (MaybeDefault Color) -> Maybe Style -> CustomAttr)
-> SectionParser (Maybe (MaybeDefault Color))
-> SectionParser
     (Maybe (MaybeDefault Color) -> Maybe Style -> CustomAttr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (Text -> Either String (MaybeDefault Color))
-> SectionParser (Maybe (MaybeDefault Color))
forall a.
Text -> (Text -> Either String a) -> SectionParser (Maybe a)
fieldMbOf (Text
basename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".fg")    Text -> Either String (MaybeDefault Color)
parseColor
                          SectionParser
  (Maybe (MaybeDefault Color) -> Maybe Style -> CustomAttr)
-> SectionParser (Maybe (MaybeDefault Color))
-> SectionParser (Maybe Style -> CustomAttr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text
-> (Text -> Either String (MaybeDefault Color))
-> SectionParser (Maybe (MaybeDefault Color))
forall a.
Text -> (Text -> Either String a) -> SectionParser (Maybe a)
fieldMbOf (Text
basename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".bg")    Text -> Either String (MaybeDefault Color)
parseColor
                          SectionParser (Maybe Style -> CustomAttr)
-> SectionParser (Maybe Style) -> SectionParser CustomAttr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text
-> (Text -> Either String Style) -> SectionParser (Maybe Style)
forall a.
Text -> (Text -> Either String a) -> SectionParser (Maybe a)
fieldMbOf (Text
basename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".style") Text -> Either String Style
parseStyle
          Maybe CustomAttr -> SectionParser (Maybe CustomAttr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CustomAttr -> SectionParser (Maybe CustomAttr))
-> Maybe CustomAttr -> SectionParser (Maybe CustomAttr)
forall a b. (a -> b) -> a -> b
$ if CustomAttr -> Bool
isNullCustomization CustomAttr
c then Maybe CustomAttr
forall a. Maybe a
Nothing else CustomAttr -> Maybe CustomAttr
forall a. a -> Maybe a
Just CustomAttr
c

    Maybe (Maybe CustomAttr)
defCustom <- Text
-> SectionParser (Maybe CustomAttr)
-> IniParser (Maybe (Maybe CustomAttr))
forall a. Text -> SectionParser a -> IniParser (Maybe a)
sectionMb Text
defaultSectionName (SectionParser (Maybe CustomAttr)
 -> IniParser (Maybe (Maybe CustomAttr)))
-> SectionParser (Maybe CustomAttr)
-> IniParser (Maybe (Maybe CustomAttr))
forall a b. (a -> b) -> a -> b
$ do
        Text -> SectionParser (Maybe CustomAttr)
parseCustomAttr Text
"default"

    Maybe [(AttrName, CustomAttr)]
customMap <- Text
-> SectionParser [(AttrName, CustomAttr)]
-> IniParser (Maybe [(AttrName, CustomAttr)])
forall a. Text -> SectionParser a -> IniParser (Maybe a)
sectionMb Text
otherSectionName (SectionParser [(AttrName, CustomAttr)]
 -> IniParser (Maybe [(AttrName, CustomAttr)]))
-> SectionParser [(AttrName, CustomAttr)]
-> IniParser (Maybe [(AttrName, CustomAttr)])
forall a b. (a -> b) -> a -> b
$ do
        [Maybe (AttrName, CustomAttr)] -> [(AttrName, CustomAttr)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (AttrName, CustomAttr)] -> [(AttrName, CustomAttr)])
-> SectionParser [Maybe (AttrName, CustomAttr)]
-> SectionParser [(AttrName, CustomAttr)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([AttrName]
-> (AttrName -> SectionParser (Maybe (AttrName, CustomAttr)))
-> SectionParser [Maybe (AttrName, CustomAttr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map AttrName Attr -> [AttrName]
forall k a. Map k a -> [k]
M.keys (Map AttrName Attr -> [AttrName])
-> Map AttrName Attr -> [AttrName]
forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName Attr
themeDefaultMapping Theme
t) ((AttrName -> SectionParser (Maybe (AttrName, CustomAttr)))
 -> SectionParser [Maybe (AttrName, CustomAttr)])
-> (AttrName -> SectionParser (Maybe (AttrName, CustomAttr)))
-> SectionParser [Maybe (AttrName, CustomAttr)]
forall a b. (a -> b) -> a -> b
$ \AttrName
an ->
            ((CustomAttr -> (AttrName, CustomAttr))
-> Maybe CustomAttr -> Maybe (AttrName, CustomAttr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AttrName
an,)) (Maybe CustomAttr -> Maybe (AttrName, CustomAttr))
-> SectionParser (Maybe CustomAttr)
-> SectionParser (Maybe (AttrName, CustomAttr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> SectionParser (Maybe CustomAttr)
parseCustomAttr ([String] -> Text
makeFieldName ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$ AttrName -> [String]
attrNameComponents AttrName
an)
            )

    (Maybe CustomAttr, Map AttrName CustomAttr)
-> IniParser (Maybe CustomAttr, Map AttrName CustomAttr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Maybe CustomAttr) -> Maybe CustomAttr
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe CustomAttr)
defCustom, [(AttrName, CustomAttr)] -> Map AttrName CustomAttr
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(AttrName, CustomAttr)] -> Map AttrName CustomAttr)
-> [(AttrName, CustomAttr)] -> Map AttrName CustomAttr
forall a b. (a -> b) -> a -> b
$ [(AttrName, CustomAttr)]
-> Maybe [(AttrName, CustomAttr)] -> [(AttrName, CustomAttr)]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [(AttrName, CustomAttr)]
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 :: Maybe CustomAttr
-> (AttrName -> Maybe CustomAttr) -> Theme -> Theme
applyCustomizations Maybe CustomAttr
customDefAttr AttrName -> Maybe CustomAttr
lookupAttr Theme
t =
    let customMap :: Map AttrName CustomAttr
customMap = (AttrName -> Map AttrName CustomAttr -> Map AttrName CustomAttr)
-> Map AttrName CustomAttr -> [AttrName] -> Map AttrName CustomAttr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AttrName -> Map AttrName CustomAttr -> Map AttrName CustomAttr
nextAttr Map AttrName CustomAttr
forall a. Monoid a => a
mempty (Map AttrName Attr -> [AttrName]
forall k a. Map k a -> [k]
M.keys (Map AttrName Attr -> [AttrName])
-> Map AttrName Attr -> [AttrName]
forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName Attr
themeDefaultMapping Theme
t)
        nextAttr :: AttrName -> Map AttrName CustomAttr -> Map AttrName CustomAttr
nextAttr AttrName
an Map AttrName CustomAttr
m = case AttrName -> Maybe CustomAttr
lookupAttr AttrName
an of
            Maybe CustomAttr
Nothing     -> Map AttrName CustomAttr
m
            Just CustomAttr
custom -> AttrName
-> CustomAttr -> Map AttrName CustomAttr -> Map AttrName CustomAttr
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AttrName
an CustomAttr
custom Map AttrName CustomAttr
m
    in Theme
t { themeCustomDefaultAttr :: Maybe CustomAttr
themeCustomDefaultAttr = Maybe CustomAttr
customDefAttr
         , themeCustomMapping :: Map AttrName CustomAttr
themeCustomMapping = Map AttrName CustomAttr
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 :: String -> Theme -> IO (Either String Theme)
loadCustomizations String
path Theme
t = do
    Text
content <- String -> IO Text
T.readFile String
path
    case Text
-> IniParser (Maybe CustomAttr, Map AttrName CustomAttr)
-> Either String (Maybe CustomAttr, Map AttrName CustomAttr)
forall a. Text -> IniParser a -> Either String a
parseIniFile Text
content (Theme -> IniParser (Maybe CustomAttr, Map AttrName CustomAttr)
themeParser Theme
t) of
        Left String
e -> Either String Theme -> IO (Either String Theme)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Theme -> IO (Either String Theme))
-> Either String Theme -> IO (Either String Theme)
forall a b. (a -> b) -> a -> b
$ String -> Either String Theme
forall a b. a -> Either a b
Left String
e
        Right (Maybe CustomAttr
customDef, Map AttrName CustomAttr
customMap) ->
            Either String Theme -> IO (Either String Theme)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Theme -> IO (Either String Theme))
-> Either String Theme -> IO (Either String Theme)
forall a b. (a -> b) -> a -> b
$ Theme -> Either String Theme
forall a b. b -> Either a b
Right (Theme -> Either String Theme) -> Theme -> Either String Theme
forall a b. (a -> b) -> a -> b
$ Maybe CustomAttr
-> (AttrName -> Maybe CustomAttr) -> Theme -> Theme
applyCustomizations Maybe CustomAttr
customDef ((AttrName -> Map AttrName CustomAttr -> Maybe CustomAttr)
-> Map AttrName CustomAttr -> AttrName -> Maybe CustomAttr
forall a b c. (a -> b -> c) -> b -> a -> c
flip AttrName -> Map AttrName CustomAttr -> Maybe CustomAttr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map AttrName CustomAttr
customMap) Theme
t

vtyColorName :: Color -> T.Text
vtyColorName :: Color -> Text
vtyColorName c :: Color
c@(Color240 Style
n) = case Style -> Maybe (Int, Int, Int)
color240CodeToRGB (Style -> Style
forall a b. (Integral a, Num b) => a -> b
fromIntegral Style
n) of
    Just (Int
r,Int
g,Int
b) -> String -> Text
T.pack (String -> Int -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"#%02x%02x%02x" Int
r Int
g Int
b)
    Maybe (Int, Int, Int)
Nothing -> (String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Invalid color: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Color -> String
forall a. Show a => a -> String
show Color
c)
vtyColorName Color
c =
    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Invalid color: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Color -> String
forall a. Show a => a -> String
show Color
c)
              (Color -> [(Color, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Color
c [(Color, Text)]
allColors)

makeFieldName :: [String] -> T.Text
makeFieldName :: [String] -> Text
makeFieldName [String]
cs = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
cs

serializeCustomColor :: [String] -> MaybeDefault Color -> T.Text
serializeCustomColor :: [String] -> MaybeDefault Color -> Text
serializeCustomColor [String]
cs MaybeDefault Color
cc =
    let cName :: Text
cName = case MaybeDefault Color
cc of
          MaybeDefault Color
Default -> Text
"default"
          SetTo Color
c -> Color -> Text
vtyColorName Color
c
          MaybeDefault Color
KeepCurrent -> String -> Text
forall a. HasCallStack => String -> a
error String
"serializeCustomColor does not support KeepCurrent"
    in [String] -> Text
makeFieldName [String]
cs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cName

serializeCustomStyle :: [String] -> Style -> T.Text
serializeCustomStyle :: [String] -> Style -> Text
serializeCustomStyle [String]
cs Style
s =
    let activeStyles :: [(Text, Style)]
activeStyles = ((Text, Style) -> Bool) -> [(Text, Style)] -> [(Text, Style)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
_, Style
a) -> Style
a Style -> Style -> Style
forall a. Bits a => a -> a -> a
.&. Style
s Style -> Style -> Bool
forall a. Eq a => a -> a -> Bool
== Style
a) [(Text, Style)]
allStyles
        styleStr :: Text
styleStr = case [(Text, Style)]
activeStyles of
            [(Text
single, Style
_)] -> Text
single
            [(Text, Style)]
many -> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text, Style) -> Text
forall a b. (a, b) -> a
fst ((Text, Style) -> Text) -> [(Text, Style)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Style)]
many) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    in [String] -> Text
makeFieldName [String]
cs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
styleStr

serializeCustomAttr :: [String] -> CustomAttr -> [T.Text]
serializeCustomAttr :: [String] -> CustomAttr -> [Text]
serializeCustomAttr [String]
cs CustomAttr
c =
    [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [ [String] -> MaybeDefault Color -> Text
serializeCustomColor ([String]
cs [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"fg"]) (MaybeDefault Color -> Text)
-> Maybe (MaybeDefault Color) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomAttr -> Maybe (MaybeDefault Color)
customFg CustomAttr
c
              , [String] -> MaybeDefault Color -> Text
serializeCustomColor ([String]
cs [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"bg"]) (MaybeDefault Color -> Text)
-> Maybe (MaybeDefault Color) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomAttr -> Maybe (MaybeDefault Color)
customBg CustomAttr
c
              , [String] -> Style -> Text
serializeCustomStyle ([String]
cs [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"style"]) (Style -> Text) -> Maybe Style -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomAttr -> Maybe Style
customStyle CustomAttr
c
              ]

emitSection :: T.Text -> [T.Text] -> [T.Text]
emitSection :: Text -> [Text] -> [Text]
emitSection Text
_ [] = []
emitSection Text
secName [Text]
ls = (Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
secName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
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 :: String -> Theme -> IO ()
saveCustomizations String
path Theme
t = do
    let defSection :: [Text]
defSection = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
                     [String] -> CustomAttr -> [Text]
serializeCustomAttr [String
"default"] (CustomAttr -> [Text]) -> Maybe CustomAttr -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Theme -> Maybe CustomAttr
themeCustomDefaultAttr Theme
t
        mapSection :: [Text]
mapSection = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((AttrName -> [Text]) -> [AttrName] -> [[Text]])
-> [AttrName] -> (AttrName -> [Text]) -> [[Text]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (AttrName -> [Text]) -> [AttrName] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (Map AttrName Attr -> [AttrName]
forall k a. Map k a -> [k]
M.keys (Map AttrName Attr -> [AttrName])
-> Map AttrName Attr -> [AttrName]
forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName Attr
themeDefaultMapping Theme
t) ((AttrName -> [Text]) -> [[Text]])
-> (AttrName -> [Text]) -> [[Text]]
forall a b. (a -> b) -> a -> b
$ \AttrName
an ->
            [Text] -> (CustomAttr -> [Text]) -> Maybe CustomAttr -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([String] -> CustomAttr -> [Text]
serializeCustomAttr (AttrName -> [String]
attrNameComponents AttrName
an)) (Maybe CustomAttr -> [Text]) -> Maybe CustomAttr -> [Text]
forall a b. (a -> b) -> a -> b
$
                     AttrName -> Map AttrName CustomAttr -> Maybe CustomAttr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttrName
an (Map AttrName CustomAttr -> Maybe CustomAttr)
-> Map AttrName CustomAttr -> Maybe CustomAttr
forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName CustomAttr
themeCustomMapping Theme
t
        content :: Text
content = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> [Text] -> [Text]
emitSection Text
defaultSectionName [Text]
defSection) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<>
                              (Text -> [Text] -> [Text]
emitSection Text
otherSectionName [Text]
mapSection)
    String -> Text -> IO ()
T.writeFile String
path Text
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 :: String -> Theme -> IO ()
saveTheme String
path Theme
t = do
    let defSection :: [Text]
defSection = [String] -> CustomAttr -> [Text]
serializeCustomAttr [String
"default"] (CustomAttr -> [Text]) -> CustomAttr -> [Text]
forall a b. (a -> b) -> a -> b
$
                     CustomAttr -> Maybe CustomAttr -> CustomAttr
forall a. a -> Maybe a -> a
fromMaybe (Attr -> CustomAttr
attrToCustom (Attr -> CustomAttr) -> Attr -> CustomAttr
forall a b. (a -> b) -> a -> b
$ Theme -> Attr
themeDefaultAttr Theme
t) (Theme -> Maybe CustomAttr
themeCustomDefaultAttr Theme
t)
        mapSection :: [Text]
mapSection = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ (((AttrName, Attr) -> [Text]) -> [(AttrName, Attr)] -> [[Text]])
-> [(AttrName, Attr)] -> ((AttrName, Attr) -> [Text]) -> [[Text]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((AttrName, Attr) -> [Text]) -> [(AttrName, Attr)] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (Map AttrName Attr -> [(AttrName, Attr)]
forall k a. Map k a -> [(k, a)]
M.toList (Map AttrName Attr -> [(AttrName, Attr)])
-> Map AttrName Attr -> [(AttrName, Attr)]
forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName Attr
themeDefaultMapping Theme
t) (((AttrName, Attr) -> [Text]) -> [[Text]])
-> ((AttrName, Attr) -> [Text]) -> [[Text]]
forall a b. (a -> b) -> a -> b
$ \(AttrName
an, Attr
def) ->
            [String] -> CustomAttr -> [Text]
serializeCustomAttr (AttrName -> [String]
attrNameComponents AttrName
an) (CustomAttr -> [Text]) -> CustomAttr -> [Text]
forall a b. (a -> b) -> a -> b
$
                CustomAttr -> Maybe CustomAttr -> CustomAttr
forall a. a -> Maybe a -> a
fromMaybe (Attr -> CustomAttr
attrToCustom Attr
def) (AttrName -> Map AttrName CustomAttr -> Maybe CustomAttr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttrName
an (Map AttrName CustomAttr -> Maybe CustomAttr)
-> Map AttrName CustomAttr -> Maybe CustomAttr
forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName CustomAttr
themeCustomMapping Theme
t)
        content :: Text
content = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> [Text] -> [Text]
emitSection Text
defaultSectionName [Text]
defSection) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<>
                              (Text -> [Text] -> [Text]
emitSection Text
otherSectionName [Text]
mapSection)
    String -> Text -> IO ()
T.writeFile String
path Text
content

attrToCustom :: Attr -> CustomAttr
attrToCustom :: Attr -> CustomAttr
attrToCustom Attr
a =
    CustomAttr :: Maybe (MaybeDefault Color)
-> Maybe (MaybeDefault Color) -> Maybe Style -> CustomAttr
CustomAttr { customFg :: Maybe (MaybeDefault Color)
customFg    = MaybeDefault Color -> Maybe (MaybeDefault Color)
forall a. a -> Maybe a
Just (MaybeDefault Color -> Maybe (MaybeDefault Color))
-> MaybeDefault Color -> Maybe (MaybeDefault Color)
forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrForeColor Attr
a
               , customBg :: Maybe (MaybeDefault Color)
customBg    = MaybeDefault Color -> Maybe (MaybeDefault Color)
forall a. a -> Maybe a
Just (MaybeDefault Color -> Maybe (MaybeDefault Color))
-> MaybeDefault Color -> Maybe (MaybeDefault Color)
forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrForeColor Attr
a
               , customStyle :: Maybe Style
customStyle = case Attr -> MaybeDefault Style
attrStyle Attr
a of
                   SetTo Style
s -> Style -> Maybe Style
forall a. a -> Maybe a
Just Style
s
                   MaybeDefault Style
_       -> Maybe Style
forall a. Maybe a
Nothing
               }