diff options
| -rw-r--r-- | Notmuch.hs | 46 | ||||
| -rw-r--r-- | Notmuch/Message.hs | 5 | ||||
| -rw-r--r-- | TreeView.hs | 110 | ||||
| -rw-r--r-- | test5.hs | 40 |
4 files changed, 155 insertions, 46 deletions
@@ -3,6 +3,7 @@ module Notmuch where import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 import Control.Concurrent import Control.DeepSeq (rnf) import Control.Exception @@ -11,6 +12,7 @@ import Data.Monoid import Data.Tree import Notmuch.Message import Notmuch.SearchResult +import System.Exit import System.IO import System.Process @@ -63,11 +65,35 @@ notmuch args = do return output +notmuch' :: [String] -> IO (ExitCode, LBS.ByteString, LBS.ByteString) +notmuch' args = do + (_, Just hout, Just herr, ph) <- + createProcess (proc "notmuch" args) + { std_out = CreatePipe + , std_err = CreatePipe + } + out <- LBS.hGetContents hout + err <- LBS.hGetContents herr ---notmuch' args = do --- (_, Just hout, _, _) <- createProcess (proc "notmuch" args) --- { std_out = CreatePipe } --- BS.hGetContents hout + withForkWait (evaluate $ rnf out) $ \waitOut -> do + withForkWait (evaluate $ rnf err) $ \waitErr -> do + + ---- now write any input + --unless (null input) $ + -- ignoreSigPipe $ hPutStr inh input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + --ignoreSigPipe $ hClose inh + + -- wait on the output + waitOut + waitErr + hClose hout + hClose herr + + -- wait on the process + exitCode <- waitForProcess ph + + return (exitCode, out, err) search :: String -> IO (Either String [SearchResult]) @@ -101,6 +127,18 @@ notmuchShow term = do either error id (eitherDecode' c') +notmuchShowPart :: String -> Int -> IO (Either String MessagePart) +notmuchShowPart term partId = do + -- TODO handle partId == 0 and partId > N + (exitCode, out, err) <- + notmuch' [ "show", "--format=json", "--format-version=2" + , "--part=" <> show partId + , term ] + return $ case exitCode of + ExitSuccess -> eitherDecode' out + _ -> Left $ show exitCode <> ": " <> LBS8.unpack err + + setTag :: String -> String -> IO LBS.ByteString setTag tag i = do notmuch [ "tag", "+" <> tag , "id:" <> i ] diff --git a/Notmuch/Message.hs b/Notmuch/Message.hs index cc87801..48fdfeb 100644 --- a/Notmuch/Message.hs +++ b/Notmuch/Message.hs @@ -110,8 +110,3 @@ parseTree vs@(Array _) = do (msg, Thread t) <- parseJSON vs return $ TR.Node msg t parseTree _ = fail "Tree is not an array" - - --- message utilities -isOpen :: Message -> Bool -isOpen m = "open" `elem` messageTags m diff --git a/TreeView.hs b/TreeView.hs index 0d95133..62bded4 100644 --- a/TreeView.hs +++ b/TreeView.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module TreeView @@ -11,13 +12,18 @@ module TreeView , fromMessageForest , fromMessageTree , treeViewId + , loadSubForest + , unloadSubForest + , hasUnloadedSubForest ) where import qualified Data.CaseInsensitive as CI import qualified Data.Text as T +import Control.Applicative import Data.Monoid import Data.Tree +import Notmuch import Notmuch.Message import Notmuch.SearchResult @@ -93,6 +99,12 @@ isTVMessage = \case _ -> False +isTVMessagePart :: TreeView -> Bool +isTVMessagePart = \case + TVMessagePart _ _ -> True + _ -> False + + isTVSearchResult :: TreeView -> Bool isTVSearchResult (TVSearchResult _) = True isTVSearchResult _ = False @@ -109,16 +121,8 @@ fromMessageForest = map fromMessageTree fromMessageTree :: Tree Message -> Tree TreeView fromMessageTree (Node m ms) = - Node m' ms' - where - - m' :: TreeView - m' = TVMessage m - - ms' :: Forest TreeView - ms' = if isOpen m - then xconvHead m <> xconvBody m <> map fromMessageTree ms - else map fromMessageTree ms + Node (TVMessage m) + (xconvHead m <> xconvBody m <> map fromMessageTree ms) xconvHead :: Message -> Forest TreeView @@ -164,3 +168,89 @@ isQuoteLine s0 = do -- /^\s*>/ not (T.null s) && T.head s == '>' + + +-- +-- Loading / Unloading +-- + + +loadSubForest :: TreeView -> IO (Either String (Forest TreeView)) +loadSubForest = \case + TVMessage m -> + Right + . concatMap subForest + . fromMessageForest + . findFirsts messageMatch + <$> notmuchShow (termFromMessage m) + + TVMessagePart m mp -> + -- TODO parse --format=raw + notmuchShowPart (termFromMessage m) (partID mp) >>= return . \case + Left e -> Left $ show e + Right mp' -> Right $ subForest $ xconvPart m mp' + + TVSearchResult sr -> do + Right + . map unloadReadSubForests + . fromMessageForest + <$> notmuchShow (termFromSearchResult sr) + + TVSearch s -> do + Right + . subForest + . fromSearchResults s + . either error id + <$> Notmuch.search s + + _ -> + return $ Right [] + + where + termFromMessage = ("id:" <>) . unMessageID . messageId + termFromSearchResult = ("thread:" <>) . unThreadID . searchThread + + +unloadSubForest :: Tree TreeView -> Forest TreeView +unloadSubForest t = case rootLabel t of + TVMessage _ -> + filter (isTVMessage . rootLabel) $ subForest t + TVMessagePart _ _ -> + filter (isTVMessagePart . rootLabel) $ subForest t + _ -> + [] + + +hasUnloadedSubForest :: Tree TreeView -> Bool +hasUnloadedSubForest t = case rootLabel t of + TVMessage _ -> + null $ filter (not . isTVMessage . rootLabel) $ subForest t + TVMessagePart _ _ -> + null $ filter (not . isTVMessagePart . rootLabel) $ subForest t + _ -> + null $ subForest t + + +unloadReadSubForests :: Tree TreeView -> Tree TreeView +unloadReadSubForests t = case rootLabel t of + TVMessage m | "unread" `notElem` messageTags m -> + t { subForest = + map unloadReadSubForests $ + filter (isTVMessage . rootLabel) $ + subForest t + } + _ -> + t { subForest = + map unloadReadSubForests $ + subForest t + } + + +findFirsts :: (a -> Bool) -> Forest a -> Forest a +findFirsts p = + concatMap rec + where + rec t@Node{..} = + if p rootLabel + then [t] + else concatMap rec subForest @@ -381,36 +381,22 @@ moveCursorDownToNextUnread = moveCursorToUnread findNext botOverrun moveTreeUp -toggleFold :: State -> IO State -toggleFold q@State{..} = case Z.label cursor of - TVMessage _ -> do - q' <- toggleTagAtCursor "open" q - - let Just sr = findParent isTVSearchResult cursor - TVSearchResult the_sr = Z.label sr - Notmuch.ThreadID tid = Notmuch.searchThread the_sr - - t_ <- return . fromMessageForest =<< Notmuch.getThread tid +setSubForest :: Tree.Forest a -> Tree.Tree a -> Tree.Tree a +setSubForest sf t = t { Tree.subForest = sf } - let cursor' = Z.modifyTree (\(Tree.Node l _) -> Tree.Node l t_) sr - return q' { cursor = select (==Z.label cursor) cursor' } - - TVSearchResult sr -> do - let open = not $ null $ Tree.subForest $ Z.tree cursor - let Notmuch.ThreadID tid = Notmuch.searchThread sr - t_ <- - if open - then return [] - else return . fromMessageForest =<< Notmuch.getThread tid - - let cursor' = Z.modifyTree (\(Tree.Node l _) -> Tree.Node l t_) cursor - return q { cursor = select (==Z.label cursor) cursor' } - - _ -> - return q { flashMessage = "nothing happened" } +toggleFold :: State -> IO State +toggleFold q@State{..} = + getNewSubForest >>= return . \case + Left err -> + q { flashMessage = SGR [31] $ Plain err } + Right sf -> + q { cursor = Z.modifyTree (setSubForest sf) cursor } where - select p loc = fromMaybe (error "cannot select") $ findTree p $ Z.root loc + getNewSubForest = + if hasUnloadedSubForest (Z.tree cursor) + then loadSubForest (Z.label cursor) + else return $ Right $ unloadSubForest (Z.tree cursor) toggleTagAtCursor :: Tag -> State -> IO State |