override colors and query via JSON config

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", "🔒")
diff --git a/much.cabal b/much.cabal
index 935f148..0e5023c 100644
--- a/much.cabal
+++ b/much.cabal
@@ -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)