diff options
Diffstat (limited to 'TreeView.hs')
| -rw-r--r-- | TreeView.hs | 229 |
1 files changed, 0 insertions, 229 deletions
diff --git a/TreeView.hs b/TreeView.hs deleted file mode 100644 index ecd25c8..0000000 --- a/TreeView.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} - - -module TreeView - ( module Export - , getMessage - , getSearchTerm - , isTVMessage - , isTVSearchResult - , fromSearchResults - , fromMessageForest - , fromMessageTree - , loadSubForest - , unloadSubForest - , hasUnloadedSubForest - ) where - - -import qualified Data.Text as T -import Data.Tree -import Notmuch -import Notmuch.Message -import Notmuch.SearchResult -import TreeView.Types as Export - - -getMessage :: TreeView -> Maybe Message -getMessage = \case - TVMessage m -> Just m - TVMessageHeaderField m _ -> Just m - TVMessagePart m _ -> Just m - TVMessageQuoteLine m _ _ _ -> Just m - TVMessageLine m _ _ _ -> Just m - _ -> Nothing - - -getSearchTerm :: TreeView -> Maybe String -getSearchTerm = \case - TVSearch term -> Just term - _ -> Nothing - - -isTVMessage :: TreeView -> Bool -isTVMessage = \case - TVMessage _ -> True - _ -> False - - -isTVMessagePart :: TreeView -> Bool -isTVMessagePart = \case - TVMessagePart _ _ -> True - _ -> False - - -isTVSearchResult :: TreeView -> Bool -isTVSearchResult (TVSearchResult _) = True -isTVSearchResult _ = False - - -fromSearchResults :: String -> [SearchResult] -> Tree TreeView -fromSearchResults query = - Node (TVSearch query) . map (\r -> Node (TVSearchResult r) []) - - -fromMessageForest :: Forest Message -> Forest TreeView -fromMessageForest = map fromMessageTree - - -fromMessageTree :: Tree Message -> Tree TreeView -fromMessageTree (Node m ms) = - Node (TVMessage m) - (xconvHead m <> xconvBody m <> map fromMessageTree ms) - - -xconvHead :: Message -> Forest TreeView -xconvHead m = - map conv [ "From", "To" ] - -- TODO add Subject if it differs from thread subject - where - conv k = - Node (TVMessageHeaderField m k) [] - - -xconvBody :: Message -> Forest TreeView -xconvBody m = map (xconvPart m) (messageBody m) - - -xconvPart :: Message -> MessagePart -> Tree TreeView -xconvPart m p = - Node (TVMessagePart m p) contents - where - contents = case partContent p of - ContentText t -> - zipWith (curry $ xconvLine m p) [0..] (T.lines t) - ContentMultipart parts -> - map (xconvPart m) parts - ContentMsgRFC822 _ -> - [] - - -xconvLine - :: Message -> MessagePart -> (LineNr, T.Text) -> Tree TreeView -xconvLine m p (i, s) = - Node (ctor m p i $ T.unpack s) [] - where - ctor = - if isQuoteLine s - then TVMessageQuoteLine - else TVMessageLine - - -isQuoteLine :: T.Text -> Bool -isQuoteLine s0 = do - let s = T.stripStart s0 - - -- /^\s*>/ - not (T.null s) && T.head s == '>' - - --- --- Loading / Unloading --- - - -loadSubForest :: TreeView -> IO (Either String (Forest TreeView)) -loadSubForest = \case - TVMessage m -> - Right - . unloadPartsWithFilename - . map unloadReadSubForests - . 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 - . unloadPartsWithFilename - . subForest - $ xconvPart m mp' - - TVSearchResult sr -> - Right - . unloadPartsWithFilename - . map unloadReadSubForests - . fromMessageForest - <$> notmuchShow (termFromSearchResult sr) - - TVSearch s -> - Right - . subForest - . fromSearchResults s - . either error id - <$> Notmuch.search [s] - - _ -> - return $ Right [] - - where - termFromMessage = unMessageID . messageId - termFromSearchResult = 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 _ -> - all (isTVMessage . rootLabel) $ subForest t - TVMessagePart _ _ -> - all (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 - } - - -unloadPartsWithFilename :: Forest TreeView -> Forest TreeView -unloadPartsWithFilename = - map rewriteTree - where - f x@Node{..} = case rootLabel of - TVMessagePart _ mp -> - case partContentFilename mp of - Nothing -> x - Just _ -> - x { subForest = [] } - _ -> x - - rewriteTree x = - let x' = f x - in x' { subForest = map rewriteTree $ subForest x' } - - -findFirsts :: (a -> Bool) -> Forest a -> Forest a -findFirsts p = - concatMap rec - where - rec t@Node{..} = - if p rootLabel - then [t] - else concatMap rec subForest |