-- | 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
  -- * Finding attributes from names
  , attrMapLookup
  -- * Manipulating attribute maps
  , setDefault
  , applyAttrMappings
  , mergeWithDefault
  , mapAttrName
  , mapAttrNames
  )
where

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

import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Data.List (inits)
import Data.String (IsString(..))

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

-- | An attribute name. Attribute names are hierarchical; use 'mappend'
-- ('<>') to assemble them. Hierachy 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 (Show, Eq, Ord)

instance Monoid AttrName where
    mempty = AttrName []
    mappend (AttrName as) (AttrName bs) = AttrName $ as `mappend` bs

instance IsString AttrName where
    fromString = AttrName . (:[])

-- | An attribute map which maps 'AttrName' values to 'Attr' values.
data AttrMap = AttrMap Attr (M.Map AttrName Attr)
             | ForceAttr Attr
             deriving Show

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

-- | 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 theDefault pairs = AttrMap theDefault (M.fromList pairs)

-- | Create an attribute map in which all lookups map to the same
-- attribute.
forceAttrMap :: Attr -> AttrMap
forceAttrMap = 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 _ (ForceAttr a) = a
mergeWithDefault a (AttrMap d _) = combineAttrs d 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. If the attribute name
-- is empty, the map's default attribute is returned. If the attribute
-- name is non-empty, very 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.
--
-- 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 _ (ForceAttr a) = a
attrMapLookup (AttrName []) (AttrMap theDefault _) = theDefault
attrMapLookup (AttrName ns) (AttrMap theDefault m) =
    let results = catMaybes $ (\n -> M.lookup n m) <$> (AttrName <$> (inits ns))
    in foldl combineAttrs theDefault results

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

combineAttrs :: Attr -> Attr -> Attr
combineAttrs (Attr s1 f1 b1) (Attr s2 f2 b2) =
    Attr (s1 `combineMDs` s2)
         (f1 `combineMDs` f2)
         (b1 `combineMDs` b2)

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

-- | Insert a set of attribute mappings to an attribute map.
applyAttrMappings :: [(AttrName, Attr)] -> AttrMap -> AttrMap
applyAttrMappings _ (ForceAttr a) = ForceAttr a
applyAttrMappings ms (AttrMap d m) = AttrMap d ((M.fromList ms) `M.union` 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 fromName ontoName inMap =
    applyAttrMappings [(ontoName, attrMapLookup fromName inMap)] 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 names inMap = foldr (uncurry mapAttrName) inMap names