toggleFold: use {load,unload}SubForest

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