{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
-- | This module provides types and functions for managing an attribute
-- map which maps attribute names ('AttrName') to attributes ('Attr').
-- This module is designed to be used with the 'OverloadedStrings'
-- language extension to permit easy construction of 'AttrName' values
-- and you should also use 'mappend' ('<>') to combine names.
--
-- 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 sucessively 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
  , attrName
  -- * Inspection
  , attrNameComponents
  -- * Finding attributes from names
  , attrMapLookup
  -- * Manipulating attribute maps
  , setDefaultAttr
  , getDefaultAttr
  , applyAttrMappings
  , mergeWithDefault
  , mapAttrName
  , mapAttrNames
  )
where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Monoid
#endif

import qualified Data.Semigroup as Sem

import Control.DeepSeq
import Data.Bits ((.|.))
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Data.List (inits)
import Data.String (IsString(..))
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:
--
-- @
-- "window" <> "border"
-- "window" <> "title"
-- "header" <> "clock" <> "seconds"
-- @
data AttrName = AttrName [String]
              deriving (Int -> AttrName -> ShowS
[AttrName] -> ShowS
AttrName -> String
(Int -> AttrName -> ShowS)
-> (AttrName -> String) -> ([AttrName] -> ShowS) -> Show AttrName
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]
(Int -> ReadS AttrName)
-> ReadS [AttrName]
-> ReadPrec AttrName
-> ReadPrec [AttrName]
-> Read 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
(AttrName -> AttrName -> Bool)
-> (AttrName -> AttrName -> Bool) -> Eq AttrName
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
Eq AttrName
-> (AttrName -> AttrName -> Ordering)
-> (AttrName -> AttrName -> Bool)
-> (AttrName -> AttrName -> Bool)
-> (AttrName -> AttrName -> Bool)
-> (AttrName -> AttrName -> Bool)
-> (AttrName -> AttrName -> AttrName)
-> (AttrName -> AttrName -> AttrName)
-> Ord 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
$cp1Ord :: Eq AttrName
Ord, (forall x. AttrName -> Rep AttrName x)
-> (forall x. Rep AttrName x -> AttrName) -> Generic AttrName
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 -> ()
(AttrName -> ()) -> NFData 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 ([String] -> AttrName) -> [String] -> AttrName
forall a b. (a -> b) -> a -> b
$ [String]
as [String] -> [String] -> [String]
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 = AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
(Sem.<>)

instance IsString AttrName where
    fromString :: String -> AttrName
fromString = [String] -> AttrName
AttrName ([String] -> AttrName)
-> (String -> [String]) -> String -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[])

-- | An attribute map which maps 'AttrName' values to 'Attr' values.
data AttrMap = AttrMap Attr (M.Map AttrName Attr)
             | ForceAttr Attr
             deriving (Int -> AttrMap -> ShowS
[AttrMap] -> ShowS
AttrMap -> String
(Int -> AttrMap -> ShowS)
-> (AttrMap -> String) -> ([AttrMap] -> ShowS) -> Show AttrMap
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. AttrMap -> Rep AttrMap x)
-> (forall x. Rep AttrMap x -> AttrMap) -> Generic AttrMap
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 -> ()
(AttrMap -> ()) -> NFData 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 ([String] -> AttrName)
-> (String -> [String]) -> String -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
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 ([(AttrName, Attr)] -> Map AttrName Attr
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.
forceAttrMap :: Attr -> AttrMap
forceAttrMap :: Attr -> AttrMap
forceAttrMap = Attr -> AttrMap
ForceAttr

-- | 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
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 ("foo" <> "bar") (attrMap a []) == a
-- attrMapLookup ("foo" <> "bar") (attrMap (bg blue) [("foo" <> "bar", fg red)]) == red \`on\` blue
-- attrMapLookup ("foo" <> "bar") (attrMap (bg blue) [("foo" <> "bar", red `on` cyan)]) == red \`on\` cyan
-- attrMapLookup ("foo" <> "bar") (attrMap (bg blue) [("foo" <> "bar", fg red), ("foo", bg cyan)]) == red \`on\` cyan
-- attrMapLookup ("foo" <> "bar") (attrMap (bg blue) [("foo", fg red)]) == red \`on\` blue
-- @
attrMapLookup :: AttrName -> AttrMap -> Attr
attrMapLookup :: AttrName -> AttrMap -> Attr
attrMapLookup AttrName
_ (ForceAttr Attr
a) = Attr
a
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 = [Maybe Attr] -> [Attr]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Attr] -> [Attr]) -> [Maybe Attr] -> [Attr]
forall a b. (a -> b) -> a -> b
$ (\AttrName
n -> AttrName -> Map AttrName Attr -> Maybe Attr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttrName
n Map AttrName Attr
m) (AttrName -> Maybe Attr) -> [AttrName] -> [Maybe Attr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([String] -> AttrName
AttrName ([String] -> AttrName) -> [[String]] -> [AttrName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([String] -> [[String]]
forall a. [a] -> [[a]]
inits [String]
ns))
    in (Attr -> Attr -> Attr) -> Attr -> [Attr] -> Attr
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 (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 (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 MaybeDefault Color -> MaybeDefault Color -> MaybeDefault Color
forall a. MaybeDefault a -> MaybeDefault a -> MaybeDefault a
`combineMDs` MaybeDefault Color
f2)
         (MaybeDefault Color
b1 MaybeDefault Color -> MaybeDefault Color -> MaybeDefault Color
forall a. MaybeDefault a -> MaybeDefault a -> MaybeDefault a
`combineMDs` MaybeDefault Color
b2)
         (MaybeDefault Text
u1 MaybeDefault Text -> MaybeDefault Text -> MaybeDefault Text
forall a. MaybeDefault a -> MaybeDefault a -> MaybeDefault a
`combineMDs` MaybeDefault Text
u2)

combineMDs :: MaybeDefault a -> MaybeDefault a -> MaybeDefault a
combineMDs :: MaybeDefault a -> MaybeDefault a -> MaybeDefault a
combineMDs MaybeDefault a
_ (SetTo a
v) = a -> MaybeDefault a
forall v. v -> MaybeDefault v
SetTo a
v
combineMDs (SetTo a
v) MaybeDefault a
_ = a -> 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) = Style -> MaybeDefault Style
forall v. v -> MaybeDefault v
SetTo (Style -> MaybeDefault Style) -> Style -> MaybeDefault Style
forall a b. (a -> b) -> a -> b
$ Style
a Style -> Style -> Style
forall a. Bits a => a -> a -> a
.|. Style
b
combineStyles MaybeDefault Style
_ (SetTo Style
v) = Style -> MaybeDefault Style
forall v. v -> MaybeDefault v
SetTo Style
v
combineStyles (SetTo Style
v) MaybeDefault Style
_ = Style -> 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 (([(AttrName, Attr)] -> Map AttrName Attr
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(AttrName, Attr)]
ms) Map AttrName Attr -> Map AttrName Attr -> Map AttrName Attr
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map AttrName Attr
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 = ((AttrName, AttrName) -> AttrMap -> AttrMap)
-> AttrMap -> [(AttrName, AttrName)] -> AttrMap
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((AttrName -> AttrName -> AttrMap -> AttrMap)
-> (AttrName, AttrName) -> AttrMap -> AttrMap
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry AttrName -> AttrName -> AttrMap -> AttrMap
mapAttrName) AttrMap
inMap [(AttrName, AttrName)]
names