summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2015-01-07 02:54:47 +0100
committertv <tv@shackspace.de>2015-01-07 02:54:47 +0100
commit09899454b8c4ca848ced8f491a70b9dfbf2e5368 (patch)
treefb3ce35d7765607756669007687e9dbd51c0f05a
parent34a4b81da3534912a449b06ec60e836ec6d9bbcd (diff)
toggleFold: use {load,unload}SubForest
-rw-r--r--Notmuch.hs46
-rw-r--r--Notmuch/Message.hs5
-rw-r--r--TreeView.hs110
-rw-r--r--test5.hs40
4 files changed, 155 insertions, 46 deletions
diff --git a/Notmuch.hs b/Notmuch.hs
index 59067cf..7851e17 100644
--- a/Notmuch.hs
+++ b/Notmuch.hs
@@ -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
diff --git a/test5.hs b/test5.hs
index b8071b1..c7bb314 100644
--- a/test5.hs
+++ b/test5.hs
@@ -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