keymap "t" = Just editTags -- with $EDITOR

5 files changed, 161 insertions, 8 deletions

diff --git a/Notmuch/SearchResult.hs b/Notmuch/SearchResult.hs
index 3dbf6bc..6d3f9be 100644
--- a/Notmuch/SearchResult.hs
+++ b/Notmuch/SearchResult.hs
@@ -9,7 +9,7 @@ import Data.Time.Clock
 import Data.Time.Clock.POSIX
 
 
-newtype ThreadID = ThreadID String
+newtype ThreadID = ThreadID { unThreadID :: String }
   deriving (Show,Read,Eq,FromJSON,ToJSON)
 
 
diff --git a/TagUtils.hs b/TagUtils.hs
new file mode 100644
index 0000000..3befad9
--- /dev/null
+++ b/TagUtils.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module TagUtils where
+
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Data.Char
+import Data.List.Split (wordsBy)
+import Data.Monoid
+import Data.Tree
+import Notmuch.Message
+import Notmuch.SearchResult
+import TreeView
+
+
+type Tag = T.Text
+
+
+data TagOp = AddTag Tag | DelTag Tag
+
+
+parseTags :: String -> [Tag]
+parseTags =
+    mconcat . map (map T.pack . wordsBy isSpace . takeWhile (/='#')) . lines
+
+
+diffTags :: [Tag] -> [Tag] -> [TagOp]
+diffTags old new =
+    let oldTags = Set.fromList old
+        newTags = Set.fromList new
+    in (map DelTag $ Set.toList $ oldTags `Set.difference` newTags) ++
+       (map AddTag $ Set.toList $ newTags `Set.difference` oldTags)
+
+
+patchRootLabelTags :: [TagOp] -> Tree TreeView -> Tree TreeView
+patchRootLabelTags tagOps x =
+    x { rootLabel = patchTags tagOps $ rootLabel x }
+
+
+patchTreeTags :: [TagOp] -> Tree TreeView -> Tree TreeView
+patchTreeTags tagOps =
+    fmap (patchTags tagOps)
+
+
+tagOpsToArgs :: [TagOp] -> [String]
+tagOpsToArgs = map $ \case
+    AddTag t -> '+' : T.unpack t
+    DelTag t -> '-' : T.unpack t
+
+
+patchTags :: [TagOp] -> TreeView -> TreeView
+patchTags tagOps = \case
+    TVSearchResult sr ->
+        TVSearchResult $ sr { searchTags = foldr applyTagOp (searchTags sr) tagOps }
+    TVMessage m ->
+        TVMessage $ m { messageTags = foldr applyTagOp (messageTags m) tagOps }
+    x -> x -- nop
+
+
+applyTagOp :: TagOp -> [Tag] -> [Tag]
+applyTagOp = \case
+    AddTag t -> (t:)
+    DelTag t -> filter (/=t)
diff --git a/env.nix b/env.nix
index c4fafeb..51e5ddd 100644
--- a/env.nix
+++ b/env.nix
@@ -19,19 +19,13 @@ let
     terminfo.nativeBuildInputs ++
     [
       cabalInstall
-      dataDefault
-      vtyUi
-
-      # for NotmuchCmd
       aeson
-      #blazeHtml
       caseInsensitive
-      #conduit
-      #conduitExtra
       friendly-time
       process
       rosezipper
       safe
+      split
       terminalSize
     ]
   );
diff --git a/much.cabal b/much.cabal
index 71a3170..620c93e 100644
--- a/much.cabal
+++ b/much.cabal
@@ -19,6 +19,7 @@ executable much
                 , mtl >=2.1 && <2.2
                 , process >=1.2 && <1.3
                 , rosezipper >=0.2 && <0.3
+                , split >=0.2 && <0.3
                 , terminal-size >= 0.3 && <0.4
                 , text >=1.2 && <1.3
                 , time >=1.4 && <1.5
diff --git a/test5.hs b/test5.hs
index 2b43942..c7a4468 100644
--- a/test5.hs
+++ b/test5.hs
@@ -5,6 +5,7 @@
 module Main (main) where
 
 import qualified Data.Text as T
+import qualified Data.Text.IO as T
 import qualified Data.Tree as Tree
 import qualified Data.Tree.Zipper as Z
 import qualified Notmuch
@@ -26,6 +27,7 @@ import System.IO
 import System.Posix.Files
 import System.Posix.Signals
 import System.Process
+import TagUtils
 import Trammel
 import TreeSearch
 import TreeView
@@ -206,6 +208,7 @@ keymap :: String -> Maybe (State -> IO State)
 
 keymap "r" = Just replyToAll
 keymap "e" = Just viewSource
+keymap "t" = Just $ editTags
 keymap "k" = Just $ moveCursorUp 1
 keymap "j" = Just $ moveCursorDown 1
 keymap "K" = Just $ moveTreeDown 1
@@ -221,6 +224,10 @@ keymap "\ESC[6~" = Just $ \q -> moveTreeUp (screenHeight q `div` 2) q     -- PgD
 keymap "\n" = Just toggleFold
 keymap "\DEL" = Just moveToParent -- backspace
 
+-- TODO Stuff Vim sends after exit (also there is more...)
+keymap "\ESC[2;2R" = Just $ \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
+keymap "\ESC[>85;95;0c" = Just $ \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
+
 keymap _ = Nothing
 
 
@@ -403,3 +410,89 @@ viewSource q@State{..} = case getMessage (Z.label cursor) of
                         ExitSuccess ->
                             return ()
         return q
+
+
+-- TODO editTags is too convoluted
+editTags :: State -> IO State
+editTags q@State{..} = case Z.label cursor of
+    TVSearchResult sr -> do
+        edit
+            (Notmuch.searchTags sr)
+            ("thread:" <> (Notmuch.unThreadID $ Notmuch.searchThread sr))
+            (\tagOps loc ->
+                Z.modifyTree (patchTreeTags tagOps) loc
+            )
+
+    TVMessage m -> do
+        edit
+            (Notmuch.messageTags m)
+            ("id:" <> (Notmuch.unMessageID $ Notmuch.messageId m)) -- TODO describe war besser
+            (\tagOps mloc ->
+                -- TODO this needs test cases
+                let
+                    -- patch message
+                    mloc' = Z.modifyTree (patchRootLabelTags tagOps) mloc
+
+                    -- find search result of message
+                    srloc = fromMaybe (error "could not find search result of message")
+                                      (findParent isTVSearchResult mloc')
+
+                    -- patch search result
+                    srloc' = Z.modifyTree (patchRootLabelTags tagOps) srloc
+
+                in
+                  -- return message
+                  fromMaybe (error "could not find message again")
+                            (findTree (==Z.label mloc) srloc')
+                )
+    _ ->
+        return q { flashMessage = "cannot edit tags here" }
+  where
+    edit tags query patch = do
+        editor <- getEnv "EDITOR"
+        logname <- getEnv "LOGNAME"
+        tmpdir <- getTemporaryDirectory
+
+        let template = logname ++ "_much_.tags"
+
+        withTempFile tmpdir template $ \(path, draftH) -> do
+            hPutStr stdout "\ESC[?1049h" -- TODO geht besser
+            hPutStr stdout "\ESC[?25l" -- TODO war mal besser
+            setFileMode path 0o600
+
+            -- generate draft
+            T.hPutStrLn draftH $ T.intercalate " " tags
+            hPutStrLn draftH $ "# " <> query
+
+            hClose draftH
+            -- TODO factorize editor
+            (system $ editor ++ " " ++ path) >>= \case
+                ExitFailure code -> do
+                    return q { flashMessage = Plain $ editor ++ " exit code = " ++ show code }
+                ExitSuccess -> do
+                    -- TODO parse could fail
+                    tags' <- parseTags <$> readFile path
+
+                    case diffTags tags tags' of
+                        [] ->
+                            return q { flashMessage = Plain "nothing happened" } -- TODO highlight
+                        tagOps -> do
+                            (_, _, _, procH) <-
+                                withFile "/dev/null" ReadWriteMode $ \nullH ->
+                                    -- TODO batch tagging(?)
+                                    -- TODO proper type for query
+                                    createProcess
+                                        (proc "notmuch" $ [ "tag" ] ++ tagOpsToArgs tagOps ++ [ "--", query ])
+                                            { std_in = UseHandle nullH
+                                            , std_out = UseHandle nullH
+                                            }
+                            waitForProcess procH >>= \case
+                                ExitFailure code ->
+                                    return q { flashMessage = Plain $ "notmuch exit code = " ++ show code }
+                                ExitSuccess ->
+                                    return q { cursor = select (==Z.label cursor) (patch tagOps cursor) }
+
+    -- TODO DRY select
+    select p loc =
+        let root = Z.root loc
+        in fromMaybe root $ findTree p root