diff options
| -rw-r--r-- | config/kmein.hs | 5 | ||||
| -rw-r--r-- | much.cabal | 2 | ||||
| -rw-r--r-- | src/Much/Config.hs | 17 | ||||
| -rw-r--r-- | src/Much/Core.hs | 89 | ||||
| -rw-r--r-- | src/Much/RenderTreeView.hs | 4 | ||||
| -rw-r--r-- | src/Much/State.hs | 46 |
6 files changed, 116 insertions, 47 deletions
diff --git a/config/kmein.hs b/config/kmein.hs index 1483df2..77d14d7 100644 --- a/config/kmein.hs +++ b/config/kmein.hs @@ -17,6 +17,7 @@ import System.Posix.Signals import Text.Hyphenation import Text.LineBreak import qualified Data.Tree as Tree +import qualified Data.Map as M import qualified Data.Tree.Zipper as Z {- notmuch's special tags are: @@ -45,14 +46,14 @@ main = , boringMessage = SGR [38,5,3] , unreadMessage = SGR [38,5,11] , unreadSearch = SGR [38,5,15] - , tagMap = + , tagMap = M.fromList [ ("deleted", SGR [38,5,088]) , ("flagged", SGR [38,5,226]) , ("draft", SGR [38,5,63]) , ("spam", SGR [38,5,202]) ] } - , tagSymbols = + , tagSymbols = M.fromList [ ("flagged", "🔖") , ("attachment", "📎") , ("signed", "🔒") @@ -49,6 +49,7 @@ library hs-source-dirs: src exposed-modules: Much.Core , Much.Action + , Much.Config , Much.Event , Much.ParseMail , Much.RenderTreeView @@ -91,6 +92,7 @@ library , linebreak , network , old-locale + , optparse-applicative , process , random , rosezipper diff --git a/src/Much/Config.hs b/src/Much/Config.hs new file mode 100644 index 0000000..5f4d6db --- /dev/null +++ b/src/Much/Config.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +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])) + , query :: Maybe String + , tagSymbols :: Maybe (M.Map T.Text T.Text) + } deriving (Generic, Show) + +instance FromJSON Config diff --git a/src/Much/Core.hs b/src/Much/Core.hs index e6dec8a..20b7ee3 100644 --- a/src/Much/Core.hs +++ b/src/Much/Core.hs @@ -4,28 +4,34 @@ {-# LANGUAGE RecordWildCards #-} module Much.Core where -import Much.Action -import Much.API import Blessings.String (Blessings(Plain,SGR),pp) import Control.Concurrent import Control.Monad +import Data.Aeson import Data.Functor +import Data.Maybe import Data.Time +import Debug.Trace +import Much.API +import Much.Action import Much.Event import Much.RenderTreeView (renderTreeView) -import Scanner (scan,Scan(..)) import Much.Screen import Much.State -import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption) -import System.Environment -import System.IO -import System.Posix.Signals import Much.TreeSearch import Much.TreeView import Much.Utils +import Options.Applicative +import Scanner (scan,Scan(..)) +import System.Environment +import System.Exit +import System.IO +import System.Posix.Signals import qualified Blessings.Internal as Blessings +import qualified Data.Map as M import qualified Data.Tree as Tree import qualified Data.Tree.Zipper as Z +import qualified Much.Config as Config import qualified Notmuch import qualified System.Console.Terminal.Size as Term @@ -47,7 +53,7 @@ emptyState = State , keymap = displayKey , mousemap = displayMouse , colorConfig = ColorConfig - { tagMap = + { tagMap = M.fromList [ ("killed", SGR [38,5,088]) , ("star", SGR [38,5,226]) , ("draft", SGR [38,5,202]) @@ -64,9 +70,41 @@ emptyState = State , unreadMessage = SGR [38,5,117] , unreadSearch = SGR [38,5,250] } - , tagSymbols = [] + , tagSymbols = M.empty } + +importConfig :: Config.Config -> State -> State +importConfig config state = state + { tagSymbols = fromMaybe (tagSymbols state) (Config.tagSymbols config) + , query = fromMaybe (query state) (Config.query config) + , colorConfig = + let fromColorConfig key1 key2 = case Config.colorConfig config of + Just colorC -> maybe (key1 (colorConfig state)) SGR (key2 colorC) + Nothing -> key1 (colorConfig state) + in ColorConfig + { tagMap = + case tagMap <$> Config.colorConfig config of + Just tagMap' -> + M.foldlWithKey + (\previous k v -> maybe previous (\code -> M.insert k (SGR code) previous) v) + (tagMap (colorConfig state)) + tagMap' + Nothing -> tagMap (colorConfig state) + , alt = fromColorConfig alt alt + , search = fromColorConfig search search + , focus = fromColorConfig focus focus + , quote = fromColorConfig quote quote + , boring = fromColorConfig boring boring + , prefix = fromColorConfig prefix prefix + , date = fromColorConfig date date + , tags = fromColorConfig tags tags + , boringMessage = fromColorConfig boringMessage boringMessage + , unreadSearch = fromColorConfig unreadSearch unreadSearch + , unreadMessage = fromColorConfig unreadMessage unreadMessage + } + } + notmuchSearch :: State -> IO State notmuchSearch q@State{query} = do r_ <- either error id <$> Notmuch.search @@ -77,26 +115,31 @@ notmuchSearch q@State{query} = do return q { cursor = Z.fromTree $ fromSearchResults query r_ } + mainWithState :: State -> IO () mainWithState state = mainWithStateAndArgs state =<< getArgs mainWithStateAndArgs :: State -> [String] -> IO () mainWithStateAndArgs state@State{query = defaultSearch} args = do - usage' <- parseUsageOrExit usage - args' <- parseArgsOrExit usage' args - let query = getArgWithDefault args' defaultSearch (shortOption 'q') - withScreen s0 (\_-> notmuchSearch state { query = query } >>= runState) + (query, maybeConfigPath) <- execParser (options defaultSearch) + newState <- case maybeConfigPath of + Just configPath -> do + eitherConfig <- eitherDecodeFileStrict configPath + case eitherConfig of + Left err -> do + hPutStrLn stderr err + exitFailure + Right config -> return $ importConfig config state + Nothing -> return state + withScreen s0 (\_-> notmuchSearch newState { query = query } >>= runState) where - usage = unlines - [ "Command-line MUA using notmuch." - , "" - , "Usage:" - , " much [-q <search-term>]" - , "" - , "Options:" - , " -q <search-term>, --query=<search-term>" - , " Open specific search, defaults to " ++ show defaultSearch - ] + options defaultQuery = + info (muchArgs <**> helper) (fullDesc <> progDesc "Command-line MUA using notmuch.") + where + muchArgs = + (,) + <$> strOption (long "query" <> short 'q' <> metavar "QUERY" <> help "Open specific search" <> value defaultQuery <> showDefault) + <*> optional (strOption (long "config" <> short 'c' <> metavar "PATH" <> help "Import settings from a JSON config")) s0 = Screen False NoBuffering (BlockBuffering $ Just 4096) [ 1000 -- X & Y on button press and release diff --git a/src/Much/RenderTreeView.hs b/src/Much/RenderTreeView.hs index 60b48d6..d5999b2 100644 --- a/src/Much/RenderTreeView.hs +++ b/src/Much/RenderTreeView.hs @@ -196,11 +196,11 @@ renderTags state = renderTag :: State -> Tag -> Blessings String -renderTag state tag = case lookup tag (tagMap (colorConfig state)) of +renderTag state tag = case M.lookup tag (tagMap (colorConfig state)) of Just visual -> visual plain Nothing -> plain where - plain = Plain $ T.unpack $ fromMaybe tag $ lookup tag (tagSymbols state) + plain = Plain $ T.unpack $ fromMaybe tag $ M.lookup tag (tagSymbols state) dropAddress :: String -> String diff --git a/src/Much/State.hs b/src/Much/State.hs index b09d544..43756a7 100644 --- a/src/Much/State.hs +++ b/src/Much/State.hs @@ -1,13 +1,17 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} module Much.State where import Blessings.String (Blessings) -import qualified Data.Text as T +import Data.Aeson import Data.Time -import qualified Data.Tree.Zipper as Z +import GHC.Generics +import Much.TreeView (TreeView) import Scanner import System.Posix.Signals -import Much.TreeView (TreeView) +import qualified Data.Text as T +import qualified Data.Map as M +import qualified Data.Tree.Zipper as Z data State = State { cursor :: Z.TreePos Z.Full TreeView @@ -23,24 +27,26 @@ data State = State , query :: String , keymap :: String -> State -> IO State , mousemap :: Scan -> State -> IO State - , 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)] + , tagSymbols :: M.Map T.Text T.Text + , colorConfig :: ColorConfig (Blessings String -> Blessings String) } 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 + } deriving (Generic, Show) + +instance FromJSON a => FromJSON (ColorConfig a) |