diff options
| -rw-r--r-- | Notmuch.hs | 13 | ||||
| -rw-r--r-- | Notmuch/Class.hs | 4 | ||||
| -rw-r--r-- | Notmuch/Message.hs | 4 | ||||
| -rw-r--r-- | Notmuch/SearchResult.hs | 5 | ||||
| -rw-r--r-- | TagUtils.hs | 2 | ||||
| -rw-r--r-- | TreeView.hs | 60 | ||||
| -rw-r--r-- | TreeView/Types.hs | 63 | ||||
| -rw-r--r-- | test5.hs | 30 |
8 files changed, 104 insertions, 77 deletions
@@ -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 @@ -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" } |