diff options
| -rw-r--r-- | Notmuch/SearchResult.hs | 2 | ||||
| -rw-r--r-- | TagUtils.hs | 65 | ||||
| -rw-r--r-- | env.nix | 8 | ||||
| -rw-r--r-- | much.cabal | 1 | ||||
| -rw-r--r-- | test5.hs | 93 |
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) @@ -19,19 +19,13 @@ let terminfo.nativeBuildInputs ++ [ cabalInstall - dataDefault - vtyUi - - # for NotmuchCmd aeson - #blazeHtml caseInsensitive - #conduit - #conduitExtra friendly-time process rosezipper safe + split terminalSize ] ); @@ -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 @@ -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 |