{-# 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 Style
customStyle :: Maybe Style
               -- ^ The customized style, if any.
               }
               deriving (CustomAttr -> CustomAttr -> Bool
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]
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CustomAttr] -> ShowS
$cshowList :: [CustomAttr] -> ShowS
show :: CustomAttr -> [Char]
$cshow :: CustomAttr -> [Char]
showsPrec :: Int -> CustomAttr -> ShowS
$cshowsPrec :: Int -> CustomAttr -> ShowS
Show, 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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: CustomAttr -> ()
$crnf :: 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    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    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 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    mappend :: CustomAttr -> CustomAttr -> CustomAttr
mappend = 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
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]
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ThemeDocumentation] -> ShowS
$cshowList :: [ThemeDocumentation] -> ShowS
show :: ThemeDocumentation -> [Char]
$cshow :: ThemeDocumentation -> [Char]
showsPrec :: Int -> ThemeDocumentation -> ShowS
$cshowsPrec :: Int -> ThemeDocumentation -> ShowS
Show, 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 -> ()
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
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]
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Theme] -> ShowS
$cshowList :: [Theme] -> ShowS
show :: Theme -> [Char]
$cshow :: Theme -> [Char]
showsPrec :: Int -> Theme -> ShowS
$cshowsPrec :: Int -> Theme -> ShowS
Show, 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 -> ()
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 { themeDefaultAttr :: Attr
themeDefaultAttr       = Attr
def
          , themeDefaultMapping :: Map AttrName Attr
themeDefaultMapping    = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(AttrName, Attr)]
mapping
          , themeCustomDefaultAttr :: Maybe CustomAttr
themeCustomDefaultAttr = forall a. Maybe a
Nothing
          , themeCustomMapping :: Map AttrName CustomAttr
themeCustomMapping     = 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (AttrName, Attr) -> [(AttrName, Attr)] -> [(AttrName, Attr)]
f [] (forall k a. Map k a -> [(k, a)]
M.toList 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 (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')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 = forall a. a -> Maybe a -> a
fromMaybe (Attr -> MaybeDefault Color
attrForeColor Attr
a) (CustomAttr -> Maybe (MaybeDefault Color)
customFg CustomAttr
c)
        bg :: MaybeDefault Color
bg = forall a. a -> Maybe a -> a
fromMaybe (Attr -> MaybeDefault Color
attrBackColor Attr
a) (CustomAttr -> Maybe (MaybeDefault Color)
customBg CustomAttr
c)
        sty :: MaybeDefault Style
sty = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Attr -> MaybeDefault Style
attrStyle Attr
a) forall 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 =
    forall a. Maybe a -> Bool
isNothing (CustomAttr -> Maybe (MaybeDefault Color)
customFg CustomAttr
c) Bool -> Bool -> Bool
&&
    forall a. Maybe a -> Bool
isNothing (CustomAttr -> Maybe (MaybeDefault Color)
customBg CustomAttr
c) Bool -> Bool -> 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 [Char] (MaybeDefault Color)
parseColor Text
s =
    let stripped :: Text
stripped = Text -> Text
T.strip 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 forall a. Eq a => a -> a -> Bool
== Text
"default"
          then forall a b. b -> Either a b
Right forall v. MaybeDefault v
Default
          else case Text -> Maybe Color
parseRGB Text
stripped of
              Just Color
c  -> forall a b. b -> Either a b
Right (forall v. v -> MaybeDefault v
SetTo Color
c)
              Maybe Color
Nothing -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid color: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Text
stripped) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. v -> MaybeDefault v
SetTo) forall a b. (a -> b) -> a -> b
$
                             forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
stripped (forall {b}. (Text, b) -> (Text, b)
normalize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> (b, a)
swap 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 forall a. Eq a => a -> a -> Bool
/= Char
'#'
                    then forall a. Maybe a
Nothing
                    else case 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] -> forall a. a -> Maybe a
Just (forall i. Integral i => i -> i -> i -> Color
rgbColor Int
r Int
g Int
b)
                            [Int]
_ -> forall a. Maybe a
Nothing

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

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

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

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

    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe CustomAttr)
defCustom, forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AttrName -> Map AttrName CustomAttr -> Map AttrName CustomAttr
nextAttr forall a. Monoid a => a
mempty (forall k a. Map k a -> [k]
M.keys 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 -> 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 :: [Char] -> Theme -> IO (Either [Char] Theme)
loadCustomizations [Char]
path Theme
t = do
    Text
content <- [Char] -> IO Text
T.readFile [Char]
path
    case 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [Char]
e
        Right (Maybe CustomAttr
customDef, Map AttrName CustomAttr
customMap) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Maybe CustomAttr
-> (AttrName -> Maybe CustomAttr) -> Theme -> Theme
applyCustomizations Maybe CustomAttr
customDef (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Style
n) of
    Just (Int
r,Int
g,Int
b) -> [Char] -> Text
T.pack (forall r. PrintfType r => [Char] -> r
printf [Char]
"#%02x%02x%02x" Int
r Int
g Int
b)
    Maybe (Int, Int, Int)
Nothing -> (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid color: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Color
c)
vtyColorName Color
c =
    forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid color: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Color
c)
              (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 forall a b. (a -> b) -> a -> b
$ 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 -> forall a. HasCallStack => [Char] -> a
error [Char]
"serializeCustomColor does not support KeepCurrent"
    in [[Char]] -> Text
makeFieldName [[Char]]
cs forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
cName

serializeCustomStyle :: [String] -> Style -> T.Text
serializeCustomStyle :: [[Char]] -> Style -> Text
serializeCustomStyle [[Char]]
cs Style
s =
    let activeStyles :: [(Text, Style)]
activeStyles = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
_, Style
a) -> Style
a forall a. Bits a => a -> a -> a
.&. Style
s 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
"[" forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Style)]
many) forall a. Semigroup a => a -> a -> a
<> Text
"]"
    in [[Char]] -> Text
makeFieldName [[Char]]
cs forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> Text
styleStr

serializeCustomAttr :: [String] -> CustomAttr -> [T.Text]
serializeCustomAttr :: [[Char]] -> CustomAttr -> [Text]
serializeCustomAttr [[Char]]
cs CustomAttr
c =
    forall a. [Maybe a] -> [a]
catMaybes [ [[Char]] -> MaybeDefault Color -> Text
serializeCustomColor ([[Char]]
cs forall a. Semigroup a => a -> a -> a
<> [[Char]
"fg"]) 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 forall a. Semigroup a => a -> a -> a
<> [[Char]
"bg"]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomAttr -> Maybe (MaybeDefault Color)
customBg CustomAttr
c
              , [[Char]] -> Style -> Text
serializeCustomStyle ([[Char]]
cs forall a. Semigroup a => a -> a -> a
<> [[Char]
"style"]) 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
"[" forall a. Semigroup a => a -> a -> a
<> Text
secName forall a. Semigroup a => a -> a -> a
<> 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 = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
                     [[Char]] -> CustomAttr -> [Text]
serializeCustomAttr [[Char]
"default"] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Theme -> Maybe CustomAttr
themeCustomDefaultAttr Theme
t
        mapSection :: [Text]
mapSection = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName Attr
themeDefaultMapping Theme
t) forall a b. (a -> b) -> a -> b
$ \AttrName
an ->
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([[Char]] -> CustomAttr -> [Text]
serializeCustomAttr (AttrName -> [[Char]]
attrNameComponents AttrName
an)) forall a b. (a -> b) -> a -> b
$
                     forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttrName
an forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName CustomAttr
themeCustomMapping Theme
t
        content :: Text
content = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ (Text -> [Text] -> [Text]
emitSection Text
defaultSectionName [Text]
defSection) 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"] forall a b. (a -> b) -> a -> b
$
                     forall a. a -> Maybe a -> a
fromMaybe (Attr -> CustomAttr
attrToCustom forall a b. (a -> b) -> a -> b
$ Theme -> Attr
themeDefaultAttr Theme
t) (Theme -> Maybe CustomAttr
themeCustomDefaultAttr Theme
t)
        mapSection :: [Text]
mapSection = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName Attr
themeDefaultMapping Theme
t) forall a b. (a -> b) -> a -> b
$ \(AttrName
an, Attr
def) ->
            [[Char]] -> CustomAttr -> [Text]
serializeCustomAttr (AttrName -> [[Char]]
attrNameComponents AttrName
an) forall a b. (a -> b) -> a -> b
$
                forall a. a -> Maybe a -> a
fromMaybe (Attr -> CustomAttr
attrToCustom Attr
def) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttrName
an forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName CustomAttr
themeCustomMapping Theme
t)
        content :: Text
content = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ (Text -> [Text] -> [Text]
emitSection Text
defaultSectionName [Text]
defSection) 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    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrForeColor Attr
a
               , customBg :: Maybe (MaybeDefault Color)
customBg    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrBackColor Attr
a
               , customStyle :: Maybe Style
customStyle = case Attr -> MaybeDefault Style
attrStyle Attr
a of
                   SetTo Style
s -> forall a. a -> Maybe a
Just Style
s
                   MaybeDefault Style
_       -> forall a. Maybe a
Nothing
               }