summaryrefslogtreecommitdiffstats
path: root/TreeView.hs
diff options
context:
space:
mode:
Diffstat (limited to 'TreeView.hs')
-rw-r--r--TreeView.hs229
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