diff options
author | tv <tv@shackspace.de> | 2014-12-29 05:29:54 +0100 |
---|---|---|
committer | tv <tv@shackspace.de> | 2014-12-29 05:29:54 +0100 |
commit | 9c2ee6b0bc7b74031439901283190bf58e8a46ce (patch) | |
tree | 8769885b1a375046e2868709a6a4b8ddb2d8e826 /TagUtils.hs | |
parent | c08c599d335e12aa82553b3501e79d6defdd6f65 (diff) |
keymap "t" = Just editTags -- with $EDITOR
Diffstat (limited to 'TagUtils.hs')
-rw-r--r-- | TagUtils.hs | 65 |
1 files changed, 65 insertions, 0 deletions
diff --git a/TagUtils.hs b/TagUtils.hs new file mode 100644 index 0000000..3befad9 --- /dev/null +++ b/TagUtils.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module TagUtils where + +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Char +import Data.List.Split (wordsBy) +import Data.Monoid +import Data.Tree +import Notmuch.Message +import Notmuch.SearchResult +import TreeView + + +type Tag = T.Text + + +data TagOp = AddTag Tag | DelTag Tag + + +parseTags :: String -> [Tag] +parseTags = + mconcat . map (map T.pack . wordsBy isSpace . takeWhile (/='#')) . lines + + +diffTags :: [Tag] -> [Tag] -> [TagOp] +diffTags old new = + let oldTags = Set.fromList old + newTags = Set.fromList new + in (map DelTag $ Set.toList $ oldTags `Set.difference` newTags) ++ + (map AddTag $ Set.toList $ newTags `Set.difference` oldTags) + + +patchRootLabelTags :: [TagOp] -> Tree TreeView -> Tree TreeView +patchRootLabelTags tagOps x = + x { rootLabel = patchTags tagOps $ rootLabel x } + + +patchTreeTags :: [TagOp] -> Tree TreeView -> Tree TreeView +patchTreeTags tagOps = + fmap (patchTags tagOps) + + +tagOpsToArgs :: [TagOp] -> [String] +tagOpsToArgs = map $ \case + AddTag t -> '+' : T.unpack t + DelTag t -> '-' : T.unpack t + + +patchTags :: [TagOp] -> TreeView -> TreeView +patchTags tagOps = \case + TVSearchResult sr -> + TVSearchResult $ sr { searchTags = foldr applyTagOp (searchTags sr) tagOps } + TVMessage m -> + TVMessage $ m { messageTags = foldr applyTagOp (messageTags m) tagOps } + x -> x -- nop + + +applyTagOp :: TagOp -> [Tag] -> [Tag] +applyTagOp = \case + AddTag t -> (t:) + DelTag t -> filter (/=t) |