State: parametrize ColorConfig over functor

4 files changed, 78 insertions, 71 deletions

diff --git a/src/Much/Config.hs b/src/Much/Config.hs
index 53c2891..93037ed 100644
--- a/src/Much/Config.hs
+++ b/src/Much/Config.hs
@@ -2,14 +2,13 @@
 module Much.Config where
 
 import GHC.Generics (Generic)
-import GHC.Word (Word8)
 import Data.Aeson (FromJSON)
 import Much.State (ColorConfig)
 import qualified Data.Text as T
 import qualified Data.Map as M
 
 data Config = Config
-  { colorConfig :: Maybe (ColorConfig (Maybe [Word8]))
+  { colorConfig :: Maybe (ColorConfig Maybe)
   , query :: Maybe String
   , tagSymbols :: Maybe (M.Map T.Text T.Text)
   , attachmentOverwrite :: Maybe Bool
diff --git a/src/Much/Core.hs b/src/Much/Core.hs
index 9fb1ed3..d325959 100644
--- a/src/Much/Core.hs
+++ b/src/Much/Core.hs
@@ -9,6 +9,7 @@ import Control.Concurrent
 import Control.Monad
 import Data.Aeson
 import Data.Functor
+import Data.Functor.Identity
 import Data.Maybe
 import Data.Time
 import Much.API
@@ -40,16 +41,18 @@ importConfig config state = state
   , attachmentDirectory = fromMaybe (attachmentDirectory state) (Config.attachmentDirectory config)
   , attachmentOverwrite = fromMaybe (attachmentOverwrite state) (Config.attachmentOverwrite config)
   , colorConfig =
-    let fromColorConfig key1 key2 = case Config.colorConfig config of
-                                      Just colorC -> maybe (key1 (colorConfig state)) SGR (key2 colorC)
-                                      Nothing -> key1 (colorConfig state)
+    let fromColorConfig key1 key2 =
+          case Config.colorConfig config of
+            Just colorC -> maybe (key1 (colorConfig state)) Identity (key2 colorC)
+            Nothing -> key1 (colorConfig state)
     in ColorConfig
       { tagMap =
-        case tagMap <$> Config.colorConfig config of
+        case tagMap =<< Config.colorConfig config of
           Just tagMap' ->
+            Identity $
             M.foldlWithKey
-              (\previous k v -> maybe previous (\code -> M.insert k (SGR code) previous) v)
-              (tagMap (colorConfig state))
+              (\previous k v -> maybe previous (\code -> M.insert k (Identity code) previous) v)
+              (runIdentity $ tagMap (colorConfig state))
               tagMap'
           Nothing -> tagMap (colorConfig state)
       , alt = fromColorConfig alt alt
diff --git a/src/Much/RenderTreeView.hs b/src/Much/RenderTreeView.hs
index d16a75c..b4aadda 100644
--- a/src/Much/RenderTreeView.hs
+++ b/src/Much/RenderTreeView.hs
@@ -16,6 +16,7 @@ import Blessings
 import Control.Arrow
 import Data.Char
 import Data.Function
+import Data.Functor.Identity
 import Data.Maybe
 import Data.Time
 import Data.Time.Format.Human
@@ -24,6 +25,8 @@ import Much.State
 import Much.TagUtils (Tag)
 import Much.TreeView
 
+color :: (t -> Identity Pm) -> t -> Blessings a -> Blessings a
+color key config = SGR $ runIdentity $ key config
 
 -- TODO make configurable
 humanTimeLocale :: HumanTimeLocale
@@ -100,10 +103,10 @@ spacePrefix
     , pipePrefix
     , endPrefix
     :: State -> Blessings String
-spacePrefix q = prefix (colorConfig q) "  "
-teePrefix q = prefix (colorConfig q) "├╴"
-pipePrefix q = prefix (colorConfig q) "│ "
-endPrefix q = prefix (colorConfig q) "└╴"
+spacePrefix q = color prefix (colorConfig q) "  "
+teePrefix q = color prefix (colorConfig q) "├╴"
+pipePrefix q = color prefix (colorConfig q) "│ "
+endPrefix q = color prefix (colorConfig q) "└╴"
 
 
 -- TODO locale-style: headerKey = \s -> SGR [..] (s <> ": ")
@@ -113,41 +116,41 @@ renderTreeView1 :: State -> Bool -> TreeView -> Blessings String
 renderTreeView1 q@State{..} hasFocus x = case x of
 
     TVSearch s ->
-        let c = if hasFocus then focus colorConfig else search colorConfig
+        let c = if hasFocus then color focus colorConfig else color search colorConfig
         in c $ Plain s
 
     TVSearchResult sr ->
         let c
-                | hasFocus = focus colorConfig
-                | isUnread = unreadSearch colorConfig
-                | otherwise = boring colorConfig
+                | hasFocus = color focus colorConfig
+                | isUnread = color unreadSearch colorConfig
+                | otherwise = color boring colorConfig
             c_authors
-                | hasFocus = focus colorConfig
-                | isUnread = alt colorConfig
-                | otherwise = boring colorConfig
+                | hasFocus = color focus colorConfig
+                | isUnread = color alt colorConfig
+                | otherwise = color boring colorConfig
 
             isUnread = "unread" `elem` Notmuch.searchTags sr
 
             authors = Plain $ T.unpack $ Notmuch.searchAuthors sr
-            date = Much.State.date colorConfig $ renderDate now x
+            date = color Much.State.date colorConfig $ renderDate now x
             subject = Plain $ T.unpack $ Notmuch.searchSubject sr
-            tags = Much.State.tags colorConfig $ renderTags q (Notmuch.searchTags sr)
+            tags = color Much.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 = focus colorConfig
-                | "unread" `elem` Notmuch.messageTags m = unreadMessage colorConfig
-                | otherwise = boringMessage colorConfig
+                | hasFocus = color focus colorConfig
+                | "unread" `elem` Notmuch.messageTags m = color unreadMessage colorConfig
+                | otherwise = color boringMessage colorConfig
             from = fromSGR $ renderFrom (M.lookup "from" $ Notmuch.messageHeaders m)
-            date = Much.State.date colorConfig $ renderDate now x
-            tags = Much.State.tags colorConfig $ renderTags q (Notmuch.messageTags m) -- TODO filter common tags
+            date = color Much.State.date colorConfig $ renderDate now x
+            tags = color Much.State.tags colorConfig $ renderTags q (Notmuch.messageTags m) -- TODO filter common tags
         in from <> " " <> date <> " " <> tags
 
     TVMessageHeaderField m fieldName ->
-        let c = if hasFocus then focus colorConfig else boring colorConfig
+        let c = if hasFocus then color focus colorConfig else color boring colorConfig
             k = Plain $ T.unpack $ CI.original fieldName
             v = maybe "nothing"
                       (Plain . T.unpack)
@@ -155,7 +158,7 @@ renderTreeView1 q@State{..} hasFocus x = case x of
         in c $ k <> ": " <> v
 
     TVMessagePart _ p ->
-        let c = if hasFocus then focus colorConfig else boring colorConfig
+        let c = if hasFocus then color focus colorConfig else color boring colorConfig
             i = Plain $ show $ Notmuch.partID p
             t = Plain $ T.unpack $ CI.original $ Notmuch.partContentType p
             filename = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentFilename p
@@ -165,8 +168,8 @@ renderTreeView1 q@State{..} hasFocus x = case x of
 
     TVMessageQuoteLine _ _ _ s ->
         if hasFocus
-            then focus colorConfig $ Plain s
-            else quote colorConfig $ Plain s
+            then color focus colorConfig $ Plain s
+            else color quote colorConfig $ Plain s
 
     TVMessageRawLine _ _ _ s ->
         mconcat . map (uncurry renderClassifiedString) $ classifiedGroupBy isPrint s
@@ -178,8 +181,8 @@ renderTreeView1 q@State{..} hasFocus x = case x of
 
         (printableColor, unprintableColor) =
             if hasFocus
-              then (focus colorConfig, unprintableFocus colorConfig)
-              else (quote colorConfig, unprintableNormal colorConfig)
+              then (color focus colorConfig, color unprintableFocus colorConfig)
+              else (color quote colorConfig, color unprintableNormal colorConfig)
 
         showLitChar' :: String -> String
         showLitChar' = (>>= f)
@@ -192,7 +195,7 @@ renderTreeView1 q@State{..} hasFocus x = case x of
 
     TVMessageLine _ _ _ s ->
         if hasFocus
-            then focus colorConfig $ Plain s
+            then color focus colorConfig $ Plain s
             else Plain s
 
 
@@ -220,8 +223,8 @@ renderTags state =
 
 
 renderTag :: State -> Tag -> Blessings String
-renderTag state tag = case M.lookup tag (tagMap (colorConfig state)) of
-    Just visual -> visual plain
+renderTag state tag = case M.lookup tag $ runIdentity $ tagMap $ colorConfig state of
+    Just visual -> SGR (runIdentity visual) plain
     Nothing -> plain
   where
     plain = Plain $ T.unpack $ fromMaybe tag $ M.lookup tag (tagSymbols state)
diff --git a/src/Much/State.hs b/src/Much/State.hs
index f6f1d89..620a489 100644
--- a/src/Much/State.hs
+++ b/src/Much/State.hs
@@ -6,6 +6,7 @@ module Much.State where
 import Blessings
 import Data.Aeson
 import Data.Default
+import Data.Functor.Identity
 import Data.Time
 import GHC.Generics
 import Much.TreeView (TreeView(TVSearch))
@@ -34,7 +35,7 @@ data State = State
     , keymap :: String -> State -> IO State
     , mousemap :: Scan -> State -> IO State
     , tagSymbols :: M.Map T.Text T.Text
-    , colorConfig :: ColorConfig (Blessings String -> Blessings String)
+    , colorConfig :: ColorConfig Identity
     , apiConfig :: Much.API.Config.Config
     , attachmentOverwrite :: Bool
     , attachmentDirectory :: FilePath
@@ -44,46 +45,47 @@ data State = State
 instance Show (State -> IO ()) where
     show = const "λ"
 
-data ColorConfig a = ColorConfig
-    { alt :: a
-    , search :: a
-    , focus :: a
-    , quote :: a
-    , boring :: a
-    , prefix :: a
-    , date :: a
-    , tags :: a
-    , unreadSearch :: a
-    , unreadMessage :: a
-    , boringMessage :: a
-    , tagMap :: M.Map T.Text a
-    , unprintableFocus :: a
-    , unprintableNormal :: a
-    } deriving (Generic, Show)
+data ColorConfig f = ColorConfig
+    { alt :: f Pm
+    , search :: f Pm
+    , focus :: f Pm
+    , quote :: f Pm
+    , boring :: f Pm
+    , prefix :: f Pm
+    , date :: f Pm
+    , tags :: f Pm
+    , unreadSearch :: f Pm
+    , unreadMessage :: f Pm
+    , boringMessage :: f Pm
+    , tagMap :: f (M.Map T.Text (f Pm))
+    , unprintableFocus :: f Pm
+    , unprintableNormal :: f Pm
+    } deriving (Generic)
 
-instance Default (ColorConfig (Blessings String -> Blessings String)) where
+instance Applicative f => Default (ColorConfig f) where
   def = ColorConfig
-    { tagMap = M.fromList
-        [ ("killed", SGR [38,5,088])
-        , ("star", SGR [38,5,226])
-        , ("draft", SGR [38,5,202])
+    { tagMap = pure $ M.fromList
+        [ ("killed", pure [38,5,088])
+        , ("star", pure [38,5,226])
+        , ("draft", pure [38,5,202])
         ]
-    , alt = SGR [38,5,182]
-    , search = SGR [38,5,162]
-    , focus = SGR [38,5,160]
-    , unprintableFocus = SGR [38,5,204]
-    , unprintableNormal = SGR [35]
-    , 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]
+    , alt = pure [38,5,182]
+    , search = pure [38,5,162]
+    , focus = pure [38,5,160]
+    , unprintableFocus = pure [38,5,204]
+    , unprintableNormal = pure [35]
+    , quote = pure [38,5,242]
+    , boring = pure [38,5,240]
+    , prefix = pure [38,5,235]
+    , date = pure [38,5,071]
+    , tags = pure [38,5,036]
+    , boringMessage = pure [38,5,023]
+    , unreadMessage = pure [38,5,117]
+    , unreadSearch = pure [38,5,250]
     }
 
-instance FromJSON a => FromJSON (ColorConfig a)
+instance FromJSON (ColorConfig Maybe)
+instance Show (ColorConfig Maybe)
 
 instance Default State where
   def = State