State: make colors and tag symbols configurable

3 files changed, 73 insertions, 68 deletions

diff --git a/Core.hs b/Core.hs
index bc54927..5073c59 100644
--- a/Core.hs
+++ b/Core.hs
@@ -42,11 +42,25 @@ emptyState = State
     , signalHandlers = []
     , keymap = displayKey
     , mousemap = displayMouse
-    , tagVisuals =
-        [ ("killed", SGR [38,5,088])
-        , ("star", SGR [38,5,226])
-        , ("draft", SGR [38,5,202])
-        ]
+    , colorConfig = ColorConfig
+        { tagMap =
+            [ ("killed", SGR [38,5,088])
+            , ("star", SGR [38,5,226])
+            , ("draft", SGR [38,5,202])
+            ]
+        , alt = SGR [38,5,182]
+        , search = SGR [38,5,162]
+        , focus = SGR [38,5,160]
+        , quote = SGR [38,5,242]
+        , boring = SGR [38,5,240]
+        , prefix = SGR [38,5,235]
+        , date = SGR [38,5,071]
+        , tags = SGR [38,5,036]
+        , boringMessage = SGR [38,5,023]
+        , unreadMessage = SGR [38,5,117]
+        , unreadSearch = SGR [38,5,250]
+        }
+    , tagSymbols = []
     }
 
 withQuery :: String -> State -> IO State
diff --git a/RenderTreeView.hs b/RenderTreeView.hs
index 569c46b..6579ffb 100644
--- a/RenderTreeView.hs
+++ b/RenderTreeView.hs
@@ -14,6 +14,7 @@ import qualified Data.Tree.Zipper as Z
 import qualified TreeZipperUtils as Z
 import Blessings
 import Data.Char
+import Data.Maybe
 import Data.Time
 import Data.Time.Format.Human
 import Data.Tree
@@ -58,7 +59,7 @@ renderTreeView q@State{..} =
         maybeRenderSubForest (Z.firstChild loc)
 
     renderRootLabel loc =
-        renderPrefix loc <>
+        renderPrefix q loc <>
         renderTreeView1 q (isFocus loc) (Z.label loc)
 
     renderSubForest loc =
@@ -69,108 +70,82 @@ renderTreeView q@State{..} =
         maybe mempty renderSubForest
 
 
-renderPrefix :: Z.TreePos Z.Full TreeView -> Blessings String
-renderPrefix =
+renderPrefix :: State -> Z.TreePos Z.Full TreeView -> Blessings String
+renderPrefix state =
     mconcat . reverse . zipWith (curry prefix) [(1 :: Int)..] . Z.path
   where
     prefix (i, (_lhs, x, rhs)) = case x of
         TVSearch _ -> ""
-        TVSearchResult _ -> spacePrefix
+        TVSearchResult _ -> spacePrefix state
         TVMessage _ ->
             case i of
                 1 ->
                     if null rhs
-                        then endPrefix
-                        else teePrefix
+                        then endPrefix state
+                        else teePrefix state
                 _ ->
                     if null rhs
-                        then spacePrefix
-                        else pipePrefix
+                        then spacePrefix state
+                        else pipePrefix state
         _ ->
             if not $ any (isTVMessage . rootLabel) rhs
-                then spacePrefix
-                else pipePrefix
+                then spacePrefix state
+                else pipePrefix state
 
 
 spacePrefix
     , teePrefix
     , pipePrefix
     , endPrefix
-    :: Blessings String
-spacePrefix = prefixSGR "  "
-teePrefix   = prefixSGR "├╴"
-pipePrefix  = prefixSGR "│ "
-endPrefix   = prefixSGR "└╴"
+    :: State -> Blessings String
+spacePrefix q = prefix (colorConfig q) "  "
+teePrefix q = prefix (colorConfig q) "├╴"
+pipePrefix q = prefix (colorConfig q) "│ "
+endPrefix q = prefix (colorConfig q) "└╴"
 
 
 -- TODO locale-style: headerKey = \s -> SGR [..] (s <> ": ")
 
-searchSGR
-    , altSGR
-    , focusSGR
-    , quoteSGR
-    , boringSGR
-    , prefixSGR
-    , dateSGR
-    , tagsSGR
-    , boringMessageSGR
-    , unreadMessageSGR
-    , unreadSearchSGR
-    :: Blessings String -> Blessings String
-
-altSGR = SGR [38,5,182]
-searchSGR = SGR [38,5,162]
-focusSGR = SGR [38,5,160]
-quoteSGR = SGR [38,5,242]
-boringSGR = SGR [38,5,240]
-prefixSGR = SGR [38,5,235]
-dateSGR = SGR [38,5,071]
-tagsSGR = SGR [38,5,036]
-
-boringMessageSGR = SGR [38,5,023]
-unreadMessageSGR = SGR [38,5,117]
-unreadSearchSGR = SGR [38,5,250]
-
 
 renderTreeView1 :: State -> Bool -> TreeView -> Blessings String
 renderTreeView1 q@State{..} hasFocus x = case x of
 
     TVSearch s ->
-        let c = if hasFocus then focusSGR else searchSGR
+        let c = if hasFocus then focus colorConfig else search colorConfig
         in c $ Plain s
 
     TVSearchResult sr ->
         let c
-                | hasFocus = focusSGR
-                | isUnread = unreadSearchSGR
-                | otherwise = boringSGR
+                | hasFocus = focus colorConfig
+                | isUnread = unreadSearch colorConfig
+                | otherwise = boring colorConfig
             c_authors
-                | hasFocus = focusSGR
-                | isUnread = altSGR
-                | otherwise = boringSGR
+                | hasFocus = focus colorConfig
+                | isUnread = alt colorConfig
+                | otherwise = boring colorConfig
 
             isUnread = "unread" `elem` Notmuch.searchTags sr
 
             authors = Plain $ T.unpack $ Notmuch.searchAuthors sr
-            date = dateSGR $ renderDate now x
+            date = State.date colorConfig $ renderDate now x
             subject = Plain $ T.unpack $ Notmuch.searchSubject sr
-            tags = tagsSGR $ renderTags q (Notmuch.searchTags sr)
+            tags = State.tags colorConfig $ renderTags q (Notmuch.searchTags sr)
             title = if subject /= "" then subject else c_authors authors
         in
           c $ title <> " " <> date <> " " <> tags
 
     TVMessage m ->
         let fromSGR
-                | hasFocus = focusSGR
-                | "unread" `elem` Notmuch.messageTags m = unreadMessageSGR
-                | otherwise = boringMessageSGR
+                | hasFocus = focus colorConfig
+                | "unread" `elem` Notmuch.messageTags m = unreadMessage colorConfig
+                | otherwise = boringMessage colorConfig
             from = fromSGR $ renderFrom (M.lookup "from" $ Notmuch.messageHeaders m)
-            date = dateSGR $ renderDate now x
-            tags = tagsSGR $ renderTags q (Notmuch.messageTags m) -- TODO filter common tags
+            date = State.date colorConfig $ renderDate now x
+            tags = State.tags colorConfig $ renderTags q (Notmuch.messageTags m) -- TODO filter common tags
         in from <> " " <> date <> " " <> tags
 
     TVMessageHeaderField m fieldName ->
-        let c = if hasFocus then focusSGR else boringSGR
+        let c = if hasFocus then focus colorConfig else boring colorConfig
             k = Plain $ T.unpack $ CI.original fieldName
             v = maybe "nothing"
                       (Plain . T.unpack)
@@ -178,7 +153,7 @@ renderTreeView1 q@State{..} hasFocus x = case x of
         in c $ k <> ": " <> v
 
     TVMessagePart _ p ->
-        let c = if hasFocus then focusSGR else boringSGR
+        let c = if hasFocus then focus colorConfig else boring colorConfig
             i = Plain $ show $ Notmuch.partID p
             t = Plain $ T.unpack $ CI.original $ Notmuch.partContentType p
             filename = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentFilename p
@@ -188,12 +163,12 @@ renderTreeView1 q@State{..} hasFocus x = case x of
 
     TVMessageQuoteLine _ _ _ s ->
         if hasFocus
-            then focusSGR $ Plain s
-            else quoteSGR $ Plain s
+            then focus colorConfig $ Plain s
+            else quote colorConfig $ Plain s
 
     TVMessageLine _ _ _ s ->
         if hasFocus
-            then focusSGR $ Plain s
+            then focus colorConfig $ Plain s
             else Plain s
 
 
@@ -221,11 +196,11 @@ renderTags state =
 
 
 renderTag :: State -> Tag -> Blessings String
-renderTag state tag = case lookup tag (tagVisuals state) of
+renderTag state tag = case lookup tag (tagMap (colorConfig state)) of
     Just visual -> visual plain
     Nothing -> plain
   where
-    plain = Plain $ T.unpack tag
+    plain = Plain $ T.unpack $ fromMaybe tag $ lookup tag (tagSymbols state)
 
 
 dropAddress :: String -> String
diff --git a/State.hs b/State.hs
index d333f95..abd25b0 100644
--- a/State.hs
+++ b/State.hs
@@ -22,5 +22,21 @@ data State = State
     , signalHandlers :: [(Signal, IO ())]
     , keymap :: String -> State -> IO State
     , mousemap :: Scan -> State -> IO State
-    , tagVisuals :: [(T.Text, Blessings String -> Blessings String)]
+    , tagSymbols :: [(T.Text, T.Text)]
+    , colorConfig :: ColorConfig
+    }
+
+data ColorConfig = ColorConfig
+    { alt :: Blessings String -> Blessings String
+    , search :: Blessings String -> Blessings String
+    , focus :: Blessings String -> Blessings String
+    , quote :: Blessings String -> Blessings String
+    , boring :: Blessings String -> Blessings String
+    , prefix :: Blessings String -> Blessings String
+    , date :: Blessings String -> Blessings String
+    , tags :: Blessings String -> Blessings String
+    , unreadSearch :: Blessings String -> Blessings String
+    , unreadMessage :: Blessings String -> Blessings String
+    , boringMessage :: Blessings String -> Blessings String
+    , tagMap :: [(T.Text, Blessings String -> Blessings String)]
     }