summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-12-29 05:29:54 +0100
committertv <tv@shackspace.de>2014-12-29 05:29:54 +0100
commit9c2ee6b0bc7b74031439901283190bf58e8a46ce (patch)
tree8769885b1a375046e2868709a6a4b8ddb2d8e826
parentc08c599d335e12aa82553b3501e79d6defdd6f65 (diff)
keymap "t" = Just editTags -- with $EDITOR
-rw-r--r--Notmuch/SearchResult.hs2
-rw-r--r--TagUtils.hs65
-rw-r--r--env.nix8
-rw-r--r--much.cabal1
-rw-r--r--test5.hs93
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