diff options
| -rw-r--r-- | config/kmein.hs | 32 | ||||
| -rw-r--r-- | src/Much/Config.hs | 3 | ||||
| -rw-r--r-- | src/Much/Core.hs | 15 | ||||
| -rw-r--r-- | src/Much/RenderTreeView.hs | 57 | ||||
| -rw-r--r-- | src/Much/State.hs | 74 |
5 files changed, 94 insertions, 87 deletions
diff --git a/config/kmein.hs b/config/kmein.hs index 6052cd5..6d50dab 100644 --- a/config/kmein.hs +++ b/config/kmein.hs @@ -42,22 +42,22 @@ main = { keymap = myKeymap , mousemap = myMousemap , colorConfig = def - { boring = SGR [38,5,8] - , alt = SGR [38,5,182] - , search = SGR [38,5,13] - , focus = SGR [38,5,4] - , quote = SGR [38,5,7] - , prefix = SGR [38,5,235] - , date = SGR [38,5,1] - , tags = SGR [38,5,14] - , boringMessage = SGR [38,5,3] - , unreadMessage = SGR [38,5,11] - , unreadSearch = SGR [38,5,15] - , tagMap = - [ ("deleted", SGR [38,5,088]) - , ("flagged", SGR [38,5,226]) - , ("draft", SGR [38,5,63]) - , ("spam", SGR [38,5,202]) + { boring = pure [38,5,8] + , alt = pure [38,5,182] + , search = pure [38,5,13] + , focus = pure [38,5,4] + , quote = pure [38,5,7] + , prefix = pure [38,5,235] + , date = pure [38,5,1] + , tags = pure [38,5,14] + , boringMessage = pure [38,5,3] + , unreadMessage = pure [38,5,11] + , unreadSearch = pure [38,5,15] + , tagMap = pure + [ ("deleted", pure [38,5,088]) + , ("flagged", pure [38,5,226]) + , ("draft", pure [38,5,63]) + , ("spam", pure [38,5,202]) ] } , tagSymbols = 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 |