summaryrefslogtreecommitdiffstats
path: root/src/Much
diff options
context:
space:
mode:
Diffstat (limited to 'src/Much')
-rw-r--r--src/Much/Config.hs3
-rw-r--r--src/Much/Core.hs15
-rw-r--r--src/Much/RenderTreeView.hs57
-rw-r--r--src/Much/State.hs74
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 01:53:57 +0000