summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Much/Config.hs17
-rw-r--r--src/Much/Core.hs89
-rw-r--r--src/Much/RenderTreeView.hs4
-rw-r--r--src/Much/State.hs46
4 files changed, 111 insertions, 45 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 06:54:02 +0000