{-# 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.
--
-- 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 (@attrName "foo" <> attrName "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 @attrName "list" <> attrName "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 Word8
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
$c== :: CustomAttr -> CustomAttr -> Bool
== :: CustomAttr -> CustomAttr -> Bool
$c/= :: CustomAttr -> CustomAttr -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS CustomAttr
readsPrec :: Int -> ReadS CustomAttr
$creadList :: ReadS [CustomAttr]
readList :: ReadS [CustomAttr]
$creadPrec :: ReadPrec CustomAttr
readPrec :: ReadPrec CustomAttr
$creadListPrec :: ReadPrec [CustomAttr]
readListPrec :: ReadPrec [CustomAttr]
Read, Int -> CustomAttr -> ShowS
[CustomAttr] -> ShowS
CustomAttr -> [Char]
(Int -> CustomAttr -> ShowS)
-> (CustomAttr -> [Char])
-> ([CustomAttr] -> ShowS)
-> Show CustomAttr
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CustomAttr -> ShowS
showsPrec :: Int -> CustomAttr -> ShowS
$cshow :: CustomAttr -> [Char]
show :: CustomAttr -> [Char]
$cshowList :: [CustomAttr] -> ShowS
showList :: [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
$cfrom :: forall x. CustomAttr -> Rep CustomAttr x
from :: forall x. CustomAttr -> Rep CustomAttr x
$cto :: forall x. Rep CustomAttr x -> CustomAttr
to :: forall x. Rep CustomAttr x -> CustomAttr
Generic, CustomAttr -> ()
(CustomAttr -> ()) -> NFData CustomAttr
forall a. (a -> ()) -> NFData a
$crnf :: CustomAttr -> ()
rnf :: CustomAttr -> ()
NFData)

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

instance Monoid CustomAttr where
    mempty :: CustomAttr
mempty = Maybe (MaybeDefault Color)
-> Maybe (MaybeDefault Color) -> Maybe Word8 -> CustomAttr
CustomAttr Maybe (MaybeDefault Color)
forall a. Maybe a
Nothing Maybe (MaybeDefault Color)
forall a. Maybe a
Nothing Maybe Word8
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
$c== :: ThemeDocumentation -> ThemeDocumentation -> Bool
== :: ThemeDocumentation -> ThemeDocumentation -> Bool
$c/= :: ThemeDocumentation -> ThemeDocumentation -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS ThemeDocumentation
readsPrec :: Int -> ReadS ThemeDocumentation
$creadList :: ReadS [ThemeDocumentation]
readList :: ReadS [ThemeDocumentation]
$creadPrec :: ReadPrec ThemeDocumentation
readPrec :: ReadPrec ThemeDocumentation
$creadListPrec :: ReadPrec [ThemeDocumentation]
readListPrec :: ReadPrec [ThemeDocumentation]
Read, Int -> ThemeDocumentation -> ShowS
[ThemeDocumentation] -> ShowS
ThemeDocumentation -> [Char]
(Int -> ThemeDocumentation -> ShowS)
-> (ThemeDocumentation -> [Char])
-> ([ThemeDocumentation] -> ShowS)
-> Show ThemeDocumentation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThemeDocumentation -> ShowS
showsPrec :: Int -> ThemeDocumentation -> ShowS
$cshow :: ThemeDocumentation -> [Char]
show :: ThemeDocumentation -> [Char]
$cshowList :: [ThemeDocumentation] -> ShowS
showList :: [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
$cfrom :: forall x. ThemeDocumentation -> Rep ThemeDocumentation x
from :: forall x. ThemeDocumentation -> Rep ThemeDocumentation x
$cto :: forall x. Rep ThemeDocumentation x -> ThemeDocumentation
to :: forall x. Rep ThemeDocumentation x -> ThemeDocumentation
Generic, ThemeDocumentation -> ()
(ThemeDocumentation -> ()) -> NFData ThemeDocumentation
forall a. (a -> ()) -> NFData a
$crnf :: ThemeDocumentation -> ()
rnf :: 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
$c== :: Theme -> Theme -> Bool
== :: Theme -> Theme -> Bool
$c/= :: Theme -> Theme -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS Theme
readsPrec :: Int -> ReadS Theme
$creadList :: ReadS [Theme]
readList :: ReadS [Theme]
$creadPrec :: ReadPrec Theme
readPrec :: ReadPrec Theme
$creadListPrec :: ReadPrec [Theme]
readListPrec :: ReadPrec [Theme]
Read, Int -> Theme -> ShowS
[Theme] -> ShowS
Theme -> [Char]
(Int -> Theme -> ShowS)
-> (Theme -> [Char]) -> ([Theme] -> ShowS) -> Show Theme
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Theme -> ShowS
showsPrec :: Int -> Theme -> ShowS
$cshow :: Theme -> [Char]
show :: Theme -> [Char]
$cshowList :: [Theme] -> ShowS
showList :: [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
$cfrom :: forall x. Theme -> Rep Theme x
from :: forall x. Theme -> Rep Theme x
$cto :: forall x. Rep Theme x -> Theme
to :: forall x. Rep Theme x -> Theme
Generic, Theme -> ()
(Theme -> ()) -> NFData Theme
forall a. (a -> ()) -> NFData a
$crnf :: Theme -> ()
rnf :: 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 { 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 a b. (a -> b -> b) -> b -> [a] -> b
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 Word8
sty = MaybeDefault Word8
-> (Word8 -> MaybeDefault Word8)
-> Maybe Word8
-> MaybeDefault Word8
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Attr -> MaybeDefault Word8
attrStyle Attr
a) Word8 -> MaybeDefault Word8
forall v. v -> MaybeDefault v
SetTo (CustomAttr -> Maybe Word8
customStyle CustomAttr
c)
    in Attr
a { attrForeColor = fg
         , attrBackColor = bg
         , attrStyle = 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 Word8 -> Bool
forall a. Maybe a -> Bool
isNothing (CustomAttr -> Maybe Word8
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 [Char] (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 [Char] (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 [Char] (MaybeDefault Color)
forall a b. b -> Either a b
Right (Color -> MaybeDefault Color
forall v. v -> MaybeDefault v
SetTo Color
c)
              Maybe Color
Nothing -> Either [Char] (MaybeDefault Color)
-> (Color -> Either [Char] (MaybeDefault Color))
-> Maybe Color
-> Either [Char] (MaybeDefault Color)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] (MaybeDefault Color)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (MaybeDefault Color))
-> [Char] -> Either [Char] (MaybeDefault Color)
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid color: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
stripped) (MaybeDefault Color -> Either [Char] (MaybeDefault Color)
forall a b. b -> Either a b
Right (MaybeDefault Color -> Either [Char] (MaybeDefault Color))
-> (Color -> MaybeDefault Color)
-> Color
-> Either [Char] (MaybeDefault Color)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> MaybeDefault Color
forall v. v -> MaybeDefault v
SetTo) (Maybe Color -> Either [Char] (MaybeDefault Color))
-> Maybe Color -> Either [Char] (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 HasCallStack => Text -> Char
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 (HasCallStack => Text -> Text
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 = ([Char] -> Maybe Int)
-> ((Int, Text) -> Maybe Int)
-> Either [Char] (Int, Text)
-> Maybe Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Int -> [Char] -> 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, Word8)]
allStyles =
    [ (Text
"standout", Word8
standout)
    , (Text
"underline", Word8
underline)
    , (Text
"strikethrough", Word8
strikethrough)
    , (Text
"reversevideo", Word8
reverseVideo)
    , (Text
"blink", Word8
blink)
    , (Text
"dim", Word8
dim)
    , (Text
"bold", Word8
bold)
    , (Text
"italic", Word8
italic)
    ]

parseStyle :: T.Text -> Either String Style
parseStyle :: Text -> Either [Char] Word8
parseStyle Text
s =
    let lookupStyle :: Text -> Either [Char] (Maybe Word8)
lookupStyle Text
"" = Maybe Word8 -> Either [Char] (Maybe Word8)
forall a b. b -> Either a b
Right Maybe Word8
forall a. Maybe a
Nothing
        lookupStyle Text
n = case Text -> [(Text, Word8)] -> Maybe Word8
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
n [(Text, Word8)]
normalizedStyles of
            Just Word8
sty -> Maybe Word8 -> Either [Char] (Maybe Word8)
forall a b. b -> Either a b
Right (Maybe Word8 -> Either [Char] (Maybe Word8))
-> Maybe Word8 -> Either [Char] (Maybe Word8)
forall a b. (a -> b) -> a -> b
$ Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
sty
            Maybe Word8
Nothing  -> [Char] -> Either [Char] (Maybe Word8)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (Maybe Word8))
-> [Char] -> Either [Char] (Maybe Word8)
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
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, Word8)]
normalizedStyles = (Text, Word8) -> (Text, Word8)
forall {b}. (Text, b) -> (Text, b)
normalize ((Text, Word8) -> (Text, Word8))
-> [(Text, Word8)] -> [(Text, Word8)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Word8)]
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 = HasCallStack => Text -> Text
Text -> Text
T.tail (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
T.init Text
stripped
        parseStyleList :: Either [Char] Word8
parseStyleList = do
            [Maybe Word8]
ss <- (Text -> Either [Char] (Maybe Word8))
-> [Text] -> Either [Char] [Maybe Word8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Either [Char] (Maybe Word8)
lookupStyle ([Text] -> Either [Char] [Maybe Word8])
-> [Text] -> Either [Char] [Maybe Word8]
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
<$> HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"," Text
unbracketed
            Word8 -> Either [Char] Word8
forall a. a -> Either [Char] a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Either [Char] Word8) -> Word8 -> Either [Char] Word8
forall a b. (a -> b) -> a -> b
$ (Word8 -> Word8 -> Word8) -> Word8 -> [Word8] -> Word8
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
(.|.) Word8
0 ([Word8] -> Word8) -> [Word8] -> Word8
forall a b. (a -> b) -> a -> b
$ [Maybe Word8] -> [Word8]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Word8]
ss

    in if Bool
bracketed
       then Either [Char] Word8
parseStyleList
       else do
           Maybe Word8
result <- Text -> Either [Char] (Maybe Word8)
lookupStyle Text
stripped
           case Maybe Word8
result of
               Maybe Word8
Nothing -> [Char] -> Either [Char] Word8
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Word8) -> [Char] -> Either [Char] Word8
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid style: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
stripped
               Just Word8
sty -> Word8 -> Either [Char] Word8
forall a b. b -> Either a b
Right Word8
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 Word8 -> CustomAttr
CustomAttr (Maybe (MaybeDefault Color)
 -> Maybe (MaybeDefault Color) -> Maybe Word8 -> CustomAttr)
-> SectionParser (Maybe (MaybeDefault Color))
-> SectionParser
     (Maybe (MaybeDefault Color) -> Maybe Word8 -> CustomAttr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (Text -> Either [Char] (MaybeDefault Color))
-> SectionParser (Maybe (MaybeDefault Color))
forall a.
Text -> (Text -> Either [Char] a) -> SectionParser (Maybe a)
fieldMbOf (Text
basename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".fg")    Text -> Either [Char] (MaybeDefault Color)
parseColor
                          SectionParser
  (Maybe (MaybeDefault Color) -> Maybe Word8 -> CustomAttr)
-> SectionParser (Maybe (MaybeDefault Color))
-> SectionParser (Maybe Word8 -> CustomAttr)
forall a b.
SectionParser (a -> b) -> SectionParser a -> SectionParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text
-> (Text -> Either [Char] (MaybeDefault Color))
-> SectionParser (Maybe (MaybeDefault Color))
forall a.
Text -> (Text -> Either [Char] a) -> SectionParser (Maybe a)
fieldMbOf (Text
basename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".bg")    Text -> Either [Char] (MaybeDefault Color)
parseColor
                          SectionParser (Maybe Word8 -> CustomAttr)
-> SectionParser (Maybe Word8) -> SectionParser CustomAttr
forall a b.
SectionParser (a -> b) -> SectionParser a -> SectionParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text
-> (Text -> Either [Char] Word8) -> SectionParser (Maybe Word8)
forall a.
Text -> (Text -> Either [Char] a) -> SectionParser (Maybe a)
fieldMbOf (Text
basename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".style") Text -> Either [Char] Word8
parseStyle
          Maybe CustomAttr -> SectionParser (Maybe CustomAttr)
forall a. a -> SectionParser a
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 a b. (a -> b) -> Maybe a -> Maybe b
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 ([[Char]] -> Text
makeFieldName ([[Char]] -> Text) -> [[Char]] -> Text
forall a b. (a -> b) -> a -> b
$ AttrName -> [[Char]]
attrNameComponents AttrName
an)
            )

    (Maybe CustomAttr, Map AttrName CustomAttr)
-> IniParser (Maybe CustomAttr, Map AttrName CustomAttr)
forall a. a -> IniParser a
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 a b. (a -> b -> b) -> b -> [a] -> b
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 = 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 :: [Char] -> Theme -> IO (Either [Char] Theme)
loadCustomizations [Char]
path Theme
t = do
    Text
content <- [Char] -> IO Text
T.readFile [Char]
path
    case Text
-> IniParser (Maybe CustomAttr, Map AttrName CustomAttr)
-> Either [Char] (Maybe CustomAttr, Map AttrName CustomAttr)
forall a. Text -> IniParser a -> Either [Char] a
parseIniFile Text
content (Theme -> IniParser (Maybe CustomAttr, Map AttrName CustomAttr)
themeParser Theme
t) of
        Left [Char]
e -> Either [Char] Theme -> IO (Either [Char] Theme)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Theme -> IO (Either [Char] Theme))
-> Either [Char] Theme -> IO (Either [Char] Theme)
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Theme
forall a b. a -> Either a b
Left [Char]
e
        Right (Maybe CustomAttr
customDef, Map AttrName CustomAttr
customMap) ->
            Either [Char] Theme -> IO (Either [Char] Theme)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Theme -> IO (Either [Char] Theme))
-> Either [Char] Theme -> IO (Either [Char] Theme)
forall a b. (a -> b) -> a -> b
$ Theme -> Either [Char] Theme
forall a b. b -> Either a b
Right (Theme -> Either [Char] Theme) -> Theme -> Either [Char] 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 Word8
n) = case Word8 -> Maybe (Int, Int, Int)
color240CodeToRGB (Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) of
    Just (Int
r,Int
g,Int
b) -> [Char] -> Text
T.pack ([Char] -> Int -> Int -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"#%02x%02x%02x" Int
r Int
g Int
b)
    Maybe (Int, Int, Int)
Nothing -> ([Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid color: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Color -> [Char]
forall a. Show a => a -> [Char]
show Color
c)
vtyColorName Color
c =
    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid color: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Color -> [Char]
forall a. Show a => a -> [Char]
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 :: [[Char]] -> Text
makeFieldName [[Char]]
cs = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." [[Char]]
cs

serializeCustomColor :: [String] -> MaybeDefault Color -> T.Text
serializeCustomColor :: [[Char]] -> MaybeDefault Color -> Text
serializeCustomColor [[Char]]
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 -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"serializeCustomColor does not support KeepCurrent"
    in [[Char]] -> Text
makeFieldName [[Char]]
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 :: [[Char]] -> Word8 -> Text
serializeCustomStyle [[Char]]
cs Word8
s =
    let activeStyles :: [(Text, Word8)]
activeStyles = ((Text, Word8) -> Bool) -> [(Text, Word8)] -> [(Text, Word8)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
_, Word8
a) -> Word8
a Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
s Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
a) [(Text, Word8)]
allStyles
        styleStr :: Text
styleStr = case [(Text, Word8)]
activeStyles of
            [(Text
single, Word8
_)] -> Text
single
            [(Text, Word8)]
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, Word8) -> Text
forall a b. (a, b) -> a
fst ((Text, Word8) -> Text) -> [(Text, Word8)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Word8)]
many) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    in [[Char]] -> Text
makeFieldName [[Char]]
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 :: [[Char]] -> CustomAttr -> [Text]
serializeCustomAttr [[Char]]
cs CustomAttr
c =
    [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes [ [[Char]] -> MaybeDefault Color -> Text
serializeCustomColor ([[Char]]
cs [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"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
              , [[Char]] -> MaybeDefault Color -> Text
serializeCustomColor ([[Char]]
cs [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"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
              , [[Char]] -> Word8 -> Text
serializeCustomStyle ([[Char]]
cs [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"style"]) (Word8 -> Text) -> Maybe Word8 -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomAttr -> Maybe Word8
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 :: [Char] -> Theme -> IO ()
saveCustomizations [Char]
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
$
                     [[Char]] -> CustomAttr -> [Text]
serializeCustomAttr [[Char]
"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 [] ([[Char]] -> CustomAttr -> [Text]
serializeCustomAttr (AttrName -> [[Char]]
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)
    [Char] -> Text -> IO ()
T.writeFile [Char]
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 :: [Char] -> Theme -> IO ()
saveTheme [Char]
path Theme
t = do
    let defSection :: [Text]
defSection = [[Char]] -> CustomAttr -> [Text]
serializeCustomAttr [[Char]
"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) ->
            [[Char]] -> CustomAttr -> [Text]
serializeCustomAttr (AttrName -> [[Char]]
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)
    [Char] -> Text -> IO ()
T.writeFile [Char]
path Text
content

attrToCustom :: Attr -> CustomAttr
attrToCustom :: Attr -> CustomAttr
attrToCustom Attr
a =
    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
attrBackColor Attr
a
               , customStyle :: Maybe Word8
customStyle = case Attr -> MaybeDefault Word8
attrStyle Attr
a of
                   SetTo Word8
s -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
s
                   MaybeDefault Word8
_       -> Maybe Word8
forall a. Maybe a
Nothing
               }