{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
-- | This module provides types and functions for managing an attribute
-- map which maps attribute names ('AttrName') to attributes ('Attr').
--
-- Attribute maps work by mapping hierarchical attribute names to
-- attributes and inheriting parent names' attributes when child names
-- specify partial attributes. Hierarchical names are created with 'mappend':
--
-- @
-- let n = attrName "parent" <> attrName "child"
-- @
--
-- Attribute names are mapped to attributes, but some attributes may
-- be partial (specify only a foreground or background color). When
-- attribute name lookups occur, the attribute corresponding to a more
-- specific name ('parent <> child' as above) is successively merged with
-- the parent attribute ('parent' as above) all the way to the "root"
-- of the attribute map, the map's default attribute. In this way, more
-- specific attributes inherit what they don't specify from more general
-- attributes in the same hierarchy. This allows more modularity and
-- less repetition in specifying how elements of your user interface
-- take on different attributes.
module Brick.AttrMap
  ( AttrMap
  , AttrName
  -- * Construction
  , attrMap
  , forceAttrMap
  , forceAttrMapAllowStyle
  , attrName
  -- * Inspection
  , attrNameComponents
  -- * Finding attributes from names
  , attrMapLookup
  -- * Manipulating attribute maps
  , setDefaultAttr
  , getDefaultAttr
  , applyAttrMappings
  , mergeWithDefault
  , mapAttrName
  , mapAttrNames
  )
where

import qualified Data.Semigroup as Sem

import Control.DeepSeq
import Data.Bits ((.|.))
import qualified Data.Map as M
import Data.Maybe (mapMaybe)
import Data.List (inits)
import GHC.Generics (Generic)

import Graphics.Vty (Attr(..), MaybeDefault(..), Style)

-- | An attribute name. Attribute names are hierarchical; use 'mappend'
-- ('<>') to assemble them. Hierarchy in an attribute name is used to
-- represent increasing levels of specificity in referring to the
-- attribute you want to use for a visual element, with names to the
-- left being general and names to the right being more specific. For
-- example:
--
-- @
-- attrName "window" <> attrName "border"
-- attrName "window" <> attrName "title"
-- attrName "header" <> attrName "clock" <> attrName "seconds"
-- @
data AttrName = AttrName [String]
              deriving (Int -> AttrName -> ShowS
[AttrName] -> ShowS
AttrName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttrName] -> ShowS
$cshowList :: [AttrName] -> ShowS
show :: AttrName -> String
$cshow :: AttrName -> String
showsPrec :: Int -> AttrName -> ShowS
$cshowsPrec :: Int -> AttrName -> ShowS
Show, ReadPrec [AttrName]
ReadPrec AttrName
Int -> ReadS AttrName
ReadS [AttrName]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AttrName]
$creadListPrec :: ReadPrec [AttrName]
readPrec :: ReadPrec AttrName
$creadPrec :: ReadPrec AttrName
readList :: ReadS [AttrName]
$creadList :: ReadS [AttrName]
readsPrec :: Int -> ReadS AttrName
$creadsPrec :: Int -> ReadS AttrName
Read, AttrName -> AttrName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttrName -> AttrName -> Bool
$c/= :: AttrName -> AttrName -> Bool
== :: AttrName -> AttrName -> Bool
$c== :: AttrName -> AttrName -> Bool
Eq, Eq AttrName
AttrName -> AttrName -> Bool
AttrName -> AttrName -> Ordering
AttrName -> AttrName -> AttrName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AttrName -> AttrName -> AttrName
$cmin :: AttrName -> AttrName -> AttrName
max :: AttrName -> AttrName -> AttrName
$cmax :: AttrName -> AttrName -> AttrName
>= :: AttrName -> AttrName -> Bool
$c>= :: AttrName -> AttrName -> Bool
> :: AttrName -> AttrName -> Bool
$c> :: AttrName -> AttrName -> Bool
<= :: AttrName -> AttrName -> Bool
$c<= :: AttrName -> AttrName -> Bool
< :: AttrName -> AttrName -> Bool
$c< :: AttrName -> AttrName -> Bool
compare :: AttrName -> AttrName -> Ordering
$ccompare :: AttrName -> AttrName -> Ordering
Ord, forall x. Rep AttrName x -> AttrName
forall x. AttrName -> Rep AttrName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AttrName x -> AttrName
$cfrom :: forall x. AttrName -> Rep AttrName x
Generic, AttrName -> ()
forall a. (a -> ()) -> NFData a
rnf :: AttrName -> ()
$crnf :: AttrName -> ()
NFData)

instance Sem.Semigroup AttrName where
    (AttrName [String]
as) <> :: AttrName -> AttrName -> AttrName
<> (AttrName [String]
bs) = [String] -> AttrName
AttrName forall a b. (a -> b) -> a -> b
$ [String]
as forall a. Monoid a => a -> a -> a
`mappend` [String]
bs

instance Monoid AttrName where
    mempty :: AttrName
mempty = [String] -> AttrName
AttrName []
    mappend :: AttrName -> AttrName -> AttrName
mappend = forall a. Semigroup a => a -> a -> a
(Sem.<>)

-- | An attribute map which maps 'AttrName' values to 'Attr' values.
data AttrMap = AttrMap Attr (M.Map AttrName Attr)
             | ForceAttr Attr
             | ForceAttrAllowStyle Attr AttrMap
             deriving (Int -> AttrMap -> ShowS
[AttrMap] -> ShowS
AttrMap -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttrMap] -> ShowS
$cshowList :: [AttrMap] -> ShowS
show :: AttrMap -> String
$cshow :: AttrMap -> String
showsPrec :: Int -> AttrMap -> ShowS
$cshowsPrec :: Int -> AttrMap -> ShowS
Show, forall x. Rep AttrMap x -> AttrMap
forall x. AttrMap -> Rep AttrMap x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AttrMap x -> AttrMap
$cfrom :: forall x. AttrMap -> Rep AttrMap x
Generic, AttrMap -> ()
forall a. (a -> ()) -> NFData a
rnf :: AttrMap -> ()
$crnf :: AttrMap -> ()
NFData)

-- | Create an attribute name from a string.
attrName :: String -> AttrName
attrName :: String -> AttrName
attrName = [String] -> AttrName
AttrName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])

-- | Get the components of an attribute name.
attrNameComponents :: AttrName -> [String]
attrNameComponents :: AttrName -> [String]
attrNameComponents (AttrName [String]
cs) = [String]
cs

-- | Create an attribute map.
attrMap :: Attr
        -- ^ The map's default attribute to be returned when a name
        -- lookup fails, and the attribute that will be merged with
        -- successful lookups.
        -> [(AttrName, Attr)]
        -- ^ The map's initial contents.
        -> AttrMap
attrMap :: Attr -> [(AttrName, Attr)] -> AttrMap
attrMap Attr
theDefault [(AttrName, Attr)]
pairs = Attr -> Map AttrName Attr -> AttrMap
AttrMap Attr
theDefault (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(AttrName, Attr)]
pairs)

-- | Create an attribute map in which all lookups map to the same
-- attribute. This is functionally equivalent to @attrMap attr []@.
forceAttrMap :: Attr -> AttrMap
forceAttrMap :: Attr -> AttrMap
forceAttrMap = Attr -> AttrMap
ForceAttr

-- | Create an attribute map in which all lookups map to the same
-- attribute. This is functionally equivalent to @attrMap attr []@.
forceAttrMapAllowStyle :: Attr -> AttrMap -> AttrMap
forceAttrMapAllowStyle :: Attr -> AttrMap -> AttrMap
forceAttrMapAllowStyle = Attr -> AttrMap -> AttrMap
ForceAttrAllowStyle

-- | Given an attribute and a map, merge the attribute with the map's
-- default attribute. If the map is forcing all lookups to a specific
-- attribute, the forced attribute is returned without merging it with
-- the one specified here. Otherwise the attribute given here is merged
-- with the attribute map's default attribute in that any aspect of the
-- specified attribute that is not provided falls back to the map
-- default. For example,
--
-- @
-- mergeWithDefault (fg blue) $ attrMap (bg red) []
-- @
--
-- returns
--
-- @
-- blue \`on\` red
-- @
mergeWithDefault :: Attr -> AttrMap -> Attr
mergeWithDefault :: Attr -> AttrMap -> Attr
mergeWithDefault Attr
_ (ForceAttr Attr
a) = Attr
a
mergeWithDefault Attr
_ (ForceAttrAllowStyle Attr
f AttrMap
_) = Attr
f
mergeWithDefault Attr
a (AttrMap Attr
d Map AttrName Attr
_) = Attr -> Attr -> Attr
combineAttrs Attr
d Attr
a

-- | Look up the specified attribute name in the map. Map lookups
-- proceed as follows. If the attribute map is forcing all lookups to a
-- specific attribute, that attribute is returned along with its style
-- settings. If the attribute name is empty, the map's default attribute
-- is returned. If the attribute name is non-empty, every subsequence of
-- names from the specified name are used to perform a lookup and the
-- results are combined as in 'mergeWithDefault', with more specific
-- results taking precedence over less specific ones. As attributes are
-- merged, styles are also merged. If a more specific attribute name
-- introduces a style (underline, say) and a less specific attribute
-- name introduces an additional style (bold, say) then the final result
-- will include both styles.
--
-- For example:
--
-- @
-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap a []) == a
-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap (bg blue) [(attrName "foo" <> attrName "bar", fg red)]) == red \`on\` blue
-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap (bg blue) [(attrName "foo" <> attrName "bar", red `on` cyan)]) == red \`on\` cyan
-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap (bg blue) [(attrName "foo" <> attrName "bar", fg red), ("foo", bg cyan)]) == red \`on\` cyan
-- attrMapLookup (attrName "foo" <> attrName "bar") (attrMap (bg blue) [(attrName "foo", fg red)]) == red \`on\` blue
-- @
attrMapLookup :: AttrName -> AttrMap -> Attr
attrMapLookup :: AttrName -> AttrMap -> Attr
attrMapLookup AttrName
_ (ForceAttr Attr
a) = Attr
a
attrMapLookup AttrName
a (ForceAttrAllowStyle Attr
forced AttrMap
m) =
    -- Look up the attribute in the contained map, then keep only its
    -- style.
    let result :: Attr
result = AttrName -> AttrMap -> Attr
attrMapLookup AttrName
a AttrMap
m
    in Attr
forced { attrStyle :: MaybeDefault Style
attrStyle = Attr -> MaybeDefault Style
attrStyle Attr
forced MaybeDefault Style -> MaybeDefault Style -> MaybeDefault Style
`combineStyles` Attr -> MaybeDefault Style
attrStyle Attr
result
              }
attrMapLookup (AttrName []) (AttrMap Attr
theDefault Map AttrName Attr
_) = Attr
theDefault
attrMapLookup (AttrName [String]
ns) (AttrMap Attr
theDefault Map AttrName Attr
m) =
    let results :: [Attr]
results = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\[String]
n -> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ([String] -> AttrName
AttrName [String]
n) Map AttrName Attr
m) (forall a. [a] -> [[a]]
inits [String]
ns)
    in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Attr -> Attr -> Attr
combineAttrs Attr
theDefault [Attr]
results

-- | Set the default attribute value in an attribute map.
setDefaultAttr :: Attr -> AttrMap -> AttrMap
setDefaultAttr :: Attr -> AttrMap -> AttrMap
setDefaultAttr Attr
_ (ForceAttr Attr
a) = Attr -> AttrMap
ForceAttr Attr
a
setDefaultAttr Attr
newDefault (ForceAttrAllowStyle Attr
a AttrMap
m) =
    Attr -> AttrMap -> AttrMap
ForceAttrAllowStyle Attr
a (Attr -> AttrMap -> AttrMap
setDefaultAttr Attr
newDefault AttrMap
m)
setDefaultAttr Attr
newDefault (AttrMap Attr
_ Map AttrName Attr
m) = Attr -> Map AttrName Attr -> AttrMap
AttrMap Attr
newDefault Map AttrName Attr
m

-- | Get the default attribute value in an attribute map.
getDefaultAttr :: AttrMap -> Attr
getDefaultAttr :: AttrMap -> Attr
getDefaultAttr (ForceAttr Attr
a) = Attr
a
getDefaultAttr (ForceAttrAllowStyle Attr
_ AttrMap
m) = AttrMap -> Attr
getDefaultAttr AttrMap
m
getDefaultAttr (AttrMap Attr
d Map AttrName Attr
_) = Attr
d

combineAttrs :: Attr -> Attr -> Attr
combineAttrs :: Attr -> Attr -> Attr
combineAttrs (Attr MaybeDefault Style
s1 MaybeDefault Color
f1 MaybeDefault Color
b1 MaybeDefault Text
u1) (Attr MaybeDefault Style
s2 MaybeDefault Color
f2 MaybeDefault Color
b2 MaybeDefault Text
u2) =
    MaybeDefault Style
-> MaybeDefault Color
-> MaybeDefault Color
-> MaybeDefault Text
-> Attr
Attr (MaybeDefault Style
s1 MaybeDefault Style -> MaybeDefault Style -> MaybeDefault Style
`combineStyles` MaybeDefault Style
s2)
         (MaybeDefault Color
f1 forall a. MaybeDefault a -> MaybeDefault a -> MaybeDefault a
`combineMDs` MaybeDefault Color
f2)
         (MaybeDefault Color
b1 forall a. MaybeDefault a -> MaybeDefault a -> MaybeDefault a
`combineMDs` MaybeDefault Color
b2)
         (MaybeDefault Text
u1 forall a. MaybeDefault a -> MaybeDefault a -> MaybeDefault a
`combineMDs` MaybeDefault Text
u2)

combineMDs :: MaybeDefault a -> MaybeDefault a -> MaybeDefault a
combineMDs :: forall a. MaybeDefault a -> MaybeDefault a -> MaybeDefault a
combineMDs MaybeDefault a
_ (SetTo a
v) = forall v. v -> MaybeDefault v
SetTo a
v
combineMDs (SetTo a
v) MaybeDefault a
_ = forall v. v -> MaybeDefault v
SetTo a
v
combineMDs MaybeDefault a
_ MaybeDefault a
v = MaybeDefault a
v

combineStyles :: MaybeDefault Style -> MaybeDefault Style -> MaybeDefault Style
combineStyles :: MaybeDefault Style -> MaybeDefault Style -> MaybeDefault Style
combineStyles (SetTo Style
a) (SetTo Style
b) = forall v. v -> MaybeDefault v
SetTo forall a b. (a -> b) -> a -> b
$ Style
a forall a. Bits a => a -> a -> a
.|. Style
b
combineStyles MaybeDefault Style
_ (SetTo Style
v) = forall v. v -> MaybeDefault v
SetTo Style
v
combineStyles (SetTo Style
v) MaybeDefault Style
_ = forall v. v -> MaybeDefault v
SetTo Style
v
combineStyles MaybeDefault Style
_ MaybeDefault Style
v = MaybeDefault Style
v

-- | Insert a set of attribute mappings to an attribute map.
applyAttrMappings :: [(AttrName, Attr)] -> AttrMap -> AttrMap
applyAttrMappings :: [(AttrName, Attr)] -> AttrMap -> AttrMap
applyAttrMappings [(AttrName, Attr)]
_ (ForceAttr Attr
a) = Attr -> AttrMap
ForceAttr Attr
a
applyAttrMappings [(AttrName, Attr)]
ms (AttrMap Attr
d Map AttrName Attr
m) = Attr -> Map AttrName Attr -> AttrMap
AttrMap Attr
d ((forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(AttrName, Attr)]
ms) forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map AttrName Attr
m)
applyAttrMappings [(AttrName, Attr)]
ms (ForceAttrAllowStyle Attr
a AttrMap
m) = Attr -> AttrMap -> AttrMap
ForceAttrAllowStyle Attr
a ([(AttrName, Attr)] -> AttrMap -> AttrMap
applyAttrMappings [(AttrName, Attr)]
ms AttrMap
m)

-- | Update an attribute map such that a lookup of 'ontoName' returns
-- the attribute value specified by 'fromName'.  This is useful for
-- composite widgets with specific attribute names mapping those names
-- to the sub-widget's expected name when calling that sub-widget's
-- rendering function.  See the ProgressBarDemo for an example usage,
-- and 'overrideAttr' for an alternate syntax.
mapAttrName :: AttrName -> AttrName -> AttrMap -> AttrMap
mapAttrName :: AttrName -> AttrName -> AttrMap -> AttrMap
mapAttrName AttrName
fromName AttrName
ontoName AttrMap
inMap =
    [(AttrName, Attr)] -> AttrMap -> AttrMap
applyAttrMappings [(AttrName
ontoName, AttrName -> AttrMap -> Attr
attrMapLookup AttrName
fromName AttrMap
inMap)] AttrMap
inMap

-- | Map several attributes to return the value associated with an
-- alternate name.  Applies 'mapAttrName' across a list of mappings.
mapAttrNames :: [(AttrName, AttrName)] -> AttrMap -> AttrMap
mapAttrNames :: [(AttrName, AttrName)] -> AttrMap -> AttrMap
mapAttrNames [(AttrName, AttrName)]
names AttrMap
inMap = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry AttrName -> AttrName -> AttrMap -> AttrMap
mapAttrName) AttrMap
inMap [(AttrName, AttrName)]
names