summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Notmuch.hs13
-rw-r--r--Notmuch/Class.hs4
-rw-r--r--Notmuch/Message.hs4
-rw-r--r--Notmuch/SearchResult.hs5
-rw-r--r--TagUtils.hs2
-rw-r--r--TreeView.hs60
-rw-r--r--TreeView/Types.hs63
-rw-r--r--test5.hs30
8 files changed, 104 insertions, 77 deletions
diff --git a/Notmuch.hs b/Notmuch.hs
index c39c4c0..eb839fd 100644
--- a/Notmuch.hs
+++ b/Notmuch.hs
@@ -10,11 +10,13 @@ import Control.Exception
import Data.Aeson
import Data.Monoid
import Data.Tree
+import Notmuch.Class
import Notmuch.Message
import Notmuch.SearchResult
import System.Exit
import System.IO
import System.Process
+import TagUtils
-- | Fork a thread while doing something else, but kill it if there's an
@@ -177,11 +179,6 @@ notmuchShowPart term partId = do
_ -> Left $ show exitCode <> ": " <> LBS8.unpack err
-setTag :: String -> String -> IO LBS.ByteString
-setTag tag i = do
- notmuch [ "tag", "+" <> tag , i ]
-
-
-unsetTag :: String -> String -> IO LBS.ByteString
-unsetTag tag i = do
- notmuch [ "tag", "-" <> tag , i ]
+notmuchTag :: HasNotmuchId a => [TagOp] -> a -> IO ()
+notmuchTag tagOps x =
+ notmuch ("tag" : tagOpsToArgs tagOps ++ [notmuchId x]) >> return ()
diff --git a/Notmuch/Class.hs b/Notmuch/Class.hs
new file mode 100644
index 0000000..2d2b416
--- /dev/null
+++ b/Notmuch/Class.hs
@@ -0,0 +1,4 @@
+module Notmuch.Class where
+
+class HasNotmuchId a where
+ notmuchId :: a -> String
diff --git a/Notmuch/Message.hs b/Notmuch/Message.hs
index 29ca5ec..dd1e809 100644
--- a/Notmuch/Message.hs
+++ b/Notmuch/Message.hs
@@ -9,6 +9,7 @@ import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Monoid
+import Notmuch.Class
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.CaseInsensitive as CI
@@ -88,6 +89,9 @@ instance Eq Message where
a == b = messageId a == messageId b
+instance HasNotmuchId Message where
+ notmuchId = unMessageID . messageId
+
instance FromJSON Message where
parseJSON (Object v) = Message <$> (MessageID . ("id:"<>) <$> v .: "id")
diff --git a/Notmuch/SearchResult.hs b/Notmuch/SearchResult.hs
index 3a75e96..52b8c20 100644
--- a/Notmuch/SearchResult.hs
+++ b/Notmuch/SearchResult.hs
@@ -7,6 +7,7 @@ import Data.Aeson
import Data.Text
import Data.Time.Clock
import Data.Time.Clock.POSIX
+import Notmuch.Class
newtype ThreadID = ThreadID { unThreadID :: String }
@@ -33,6 +34,10 @@ instance Eq SearchResult where
searchThread s1 == searchThread s2
+instance HasNotmuchId SearchResult where
+ notmuchId = unThreadID . searchThread
+
+
instance FromJSON SearchResult where
parseJSON (Object v) = SearchResult <$> ((ThreadID . ("thread:"++)) <$> v .: "thread")
<*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp")
diff --git a/TagUtils.hs b/TagUtils.hs
index a5df807..e8f17eb 100644
--- a/TagUtils.hs
+++ b/TagUtils.hs
@@ -12,7 +12,7 @@ import Data.Monoid
import Data.Tree
import Notmuch.Message
import Notmuch.SearchResult
-import TreeView
+import TreeView.Types
type Tag = T.Text
diff --git a/TreeView.hs b/TreeView.hs
index 470913b..dff50e8 100644
--- a/TreeView.hs
+++ b/TreeView.hs
@@ -4,7 +4,7 @@
module TreeView
- ( TreeView (..)
+ ( module Export
, getMessage
, getSearchTerm
, isTVMessage
@@ -12,14 +12,12 @@ module TreeView
, fromSearchResults
, 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
@@ -27,61 +25,7 @@ import Data.Tree
import Notmuch
import Notmuch.Message
import Notmuch.SearchResult
-
-
-type LineNr = Int
-
-
-data TreeView
- = TVMessage Message
- | TVMessageHeaderField Message (CI.CI T.Text)
- | TVMessagePart Message MessagePart
- | TVMessageQuoteLine Message MessagePart LineNr String
- | TVMessageLine Message MessagePart LineNr String
- | TVSearch String
- | TVSearchResult SearchResult
- deriving (Show)
-
-
-instance Eq TreeView where
- x1 == x2 = treeViewId x1 == treeViewId x2
-
-
-data TreeViewId
- = TVIDMessage T.Text
- | TVIDMessageHeaderField T.Text T.Text
- | TVIDMessagePart T.Text Int
- | TVIDMessageLine T.Text Int Int
- | TVIDSearch T.Text
- | TVIDSearchResult T.Text
- deriving (Eq,Show)
-
-
-treeViewId :: TreeView -> TreeViewId
-treeViewId = \case
- TVMessage m ->
- TVIDMessage (fromMessage m)
-
- TVMessageHeaderField m mhf ->
- TVIDMessageHeaderField (fromMessage m) (CI.foldedCase mhf)
-
- TVMessagePart m mp ->
- TVIDMessagePart (fromMessage m) (partID mp)
-
- TVMessageLine m mp lineNr _ ->
- TVIDMessageLine (fromMessage m) (partID mp) lineNr
-
- TVMessageQuoteLine m mp lineNr _ ->
- TVIDMessageLine (fromMessage m) (partID mp) lineNr
-
- TVSearch s ->
- TVIDSearch (T.pack s)
-
- TVSearchResult sr ->
- TVIDSearchResult (T.pack $ unThreadID $ searchThread sr)
-
- where
- fromMessage = T.pack . unMessageID . messageId
+import TreeView.Types as Export
getMessage :: TreeView -> Maybe Message
diff --git a/TreeView/Types.hs b/TreeView/Types.hs
new file mode 100644
index 0000000..0dd1290
--- /dev/null
+++ b/TreeView/Types.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TreeView.Types where
+
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as T
+import Notmuch.Message
+import Notmuch.SearchResult
+
+
+type LineNr = Int
+
+
+data TreeView
+ = TVMessage Message
+ | TVMessageHeaderField Message (CI.CI T.Text)
+ | TVMessagePart Message MessagePart
+ | TVMessageQuoteLine Message MessagePart LineNr String
+ | TVMessageLine Message MessagePart LineNr String
+ | TVSearch String
+ | TVSearchResult SearchResult
+ deriving (Show)
+
+
+instance Eq TreeView where
+ x1 == x2 = treeViewId x1 == treeViewId x2
+
+
+data TreeViewId
+ = TVIDMessage T.Text
+ | TVIDMessageHeaderField T.Text T.Text
+ | TVIDMessagePart T.Text Int
+ | TVIDMessageLine T.Text Int Int
+ | TVIDSearch T.Text
+ | TVIDSearchResult T.Text
+ deriving (Eq,Show)
+
+
+treeViewId :: TreeView -> TreeViewId
+treeViewId = \case
+ TVMessage m ->
+ TVIDMessage (fromMessage m)
+
+ TVMessageHeaderField m mhf ->
+ TVIDMessageHeaderField (fromMessage m) (CI.foldedCase mhf)
+
+ TVMessagePart m mp ->
+ TVIDMessagePart (fromMessage m) (partID mp)
+
+ TVMessageLine m mp lineNr _ ->
+ TVIDMessageLine (fromMessage m) (partID mp) lineNr
+
+ TVMessageQuoteLine m mp lineNr _ ->
+ TVIDMessageLine (fromMessage m) (partID mp) lineNr
+
+ TVSearch s ->
+ TVIDSearch (T.pack s)
+
+ TVSearchResult sr ->
+ TVIDSearchResult (T.pack $ unThreadID $ searchThread sr)
+
+ where
+ fromMessage = T.pack . unMessageID . messageId
diff --git a/test5.hs b/test5.hs
index b9ca124..4133e76 100644
--- a/test5.hs
+++ b/test5.hs
@@ -422,18 +422,28 @@ toggleFold q@State{..} =
toggleTagAtCursor :: Tag -> State -> IO State
toggleTagAtCursor tag q@State{..} = case Z.label cursor of
+
+ TVSearchResult sr -> do
+ let tagOp =
+ if tag `elem` Notmuch.searchTags sr
+ then DelTag
+ else AddTag
+ tagOps = [tagOp tag]
+ Notmuch.notmuchTag tagOps sr
+ -- TODO reload or patch whole thread
+ let cursor' = Z.modifyTree (patchRootLabelTags tagOps) cursor
+ return q { cursor = cursor' }
+
TVMessage m -> do
-- TODO modify search result tags
- -- TODO check Notmuch.{set,unset}Tag result
- if tag `elem` Notmuch.messageTags m
- then do
- Notmuch.unsetTag (T.unpack tag) (Notmuch.unMessageID $ Notmuch.messageId m)
- let cursor' = Z.modifyTree (patchRootLabelTags [DelTag tag]) cursor
- return q { cursor = cursor' }
- else do
- Notmuch.setTag (T.unpack tag) (Notmuch.unMessageID $ Notmuch.messageId m)
- let cursor' = Z.modifyTree (patchRootLabelTags [AddTag tag]) cursor
- return q { cursor = cursor' }
+ let tagOp =
+ if tag `elem` Notmuch.messageTags m
+ then DelTag
+ else AddTag
+ tagOps = [tagOp tag]
+ Notmuch.notmuchTag tagOps m
+ let cursor' = Z.modifyTree (patchRootLabelTags tagOps) cursor
+ return q { cursor = cursor' }
_ -> return q { flashMessage = "nothing happened" }