From 4299cd382b10947a8a79e586f95d38823aaa9597 Mon Sep 17 00:00:00 2001 From: tv Date: Fri, 19 Dec 2014 20:42:38 +0100 Subject: initial commit --- ThreadView.hs | 286 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 286 insertions(+) create mode 100644 ThreadView.hs (limited to 'ThreadView.hs') diff --git a/ThreadView.hs b/ThreadView.hs new file mode 100644 index 0000000..e2b1a4b --- /dev/null +++ b/ThreadView.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + + +module ThreadView where + +import Data.Default +import Graphics.Vty + +import Data.List + +--import Data.Aeson +--import Data.List.Split +--import Data.Attoparsec.ByteString hiding (string) +--import Data.Maybe +import Data.Monoid +--import Data.String +--import Data.Traversable +import Data.Tree +--import qualified Data.ByteString as BS +--import qualified Data.ByteString.Lazy as LBS +--import qualified Data.ByteString.Char8 as BS8 +--import qualified Data.Text.Lazy as TL +import qualified Data.Text as T +--import qualified Data.Text.Encoding as T +--import qualified Data.Text.IO as T +--import Data.Version (Version(..), parseVersion) +--import System.Process +--import System.IO +--import qualified Data.Map as M + +--import Notmuch.SearchResult +import Notmuch.Message +--import Notmuch +import Safe + + +type LineNr = Int + + +data ThreadView + = ClosedMessage Message + | OpenMessage Message + | MessageLine Message MessagePart LineNr String + | TVMessagePart Message MessagePart + deriving (Show) + +instance Eq ThreadView where + MessageLine m1 mp1 ln1 _s1 == MessageLine m2 mp2 ln2 _s2 = + m1 == m2 && mp1 == mp2 && ln1 == ln2 + a == b = + isMessage a && isMessage b && tvMsgId a == tvMsgId b + + +isMessage :: ThreadView -> Bool +isMessage (ClosedMessage _) = True +isMessage (OpenMessage _) = True +isMessage _ = False + + +tvMsgId :: ThreadView -> Maybe MessageID +tvMsgId (ClosedMessage m) = Just $ messageId m +tvMsgId (OpenMessage m) = Just $ messageId m +tvMsgId _ = Nothing + + + +describe :: ThreadView -> String +describe (ClosedMessage m) = "ClosedMessage " <> unMessageID (messageId m) +describe (OpenMessage m) = "OpenMessage " <> unMessageID (messageId m) +describe (MessageLine _ _ _ s) = "MessageLine " <> show s +describe (TVMessagePart _ p) = "TVMessagePart " <> show (partID p) + + +--focusPrev t_cur t = do +-- i <- findIndex ((==t_cur) . messageId) msgs +-- m' <- msgs `atMay` (i - 1) +-- return $ messageId m' +-- where +-- msgs = flatten t +-- +--focusNext t_cur t = do +-- i <- findIndex ((==t_cur) . messageId) msgs +-- m' <- msgs `atMay` (i + 1) +-- return $ messageId m' +-- where +-- msgs = flatten t + +focusPrev :: Maybe ThreadView -> Tree ThreadView -> Maybe ThreadView +focusPrev Nothing v = lastMay (flatten v) +focusPrev (Just cur) v = do + i <- elemIndex cur items + maybe (lastMay items) Just $ atMay items (i - 1) + where + items = flatten v + +focusNext :: Maybe ThreadView -> Tree ThreadView -> Maybe ThreadView +focusNext Nothing v = headMay (flatten v) +focusNext (Just cur) v = do + i <- elemIndex cur items + maybe (headMay items) Just $ atMay items (i + 1) + where + items = flatten v + + +findMessage :: MessageID -> Tree ThreadView -> Maybe ThreadView +findMessage i = + find p . flatten + where + p (ClosedMessage m) = i == messageId m + p (OpenMessage m) = i == messageId m + p _ = False + +findTV :: ThreadView -> Tree ThreadView -> Maybe ThreadView +findTV x = + find (==x) . flatten + + + +fromMessageTree :: Tree Message -> Tree ThreadView +fromMessageTree (Node m ms) = + Node m' ms' + where + isOpen = "open" `elem` messageTags m + + m' :: ThreadView + m' = + if isOpen + then OpenMessage m + else ClosedMessage m + + ms' :: Forest ThreadView + ms' = if isOpen + then xconvBody m <> map fromMessageTree ms + else map fromMessageTree ms + +xconvBody :: Message -> Forest ThreadView +xconvBody m = mconcat $ map (xconvPart m) (messageBody m) + +xconvPart :: Message -> MessagePart -> Forest ThreadView +xconvPart m p = xconvPartContent m p $ partContent p + +xconvPartContent + :: Message -> MessagePart -> MessageContent -> Forest ThreadView +xconvPartContent m p = \case + ContentText t -> + map (xconvLine m p) $ zip [0..] (T.lines t) + ContentMultipart parts -> + map (xconvPart2 m) parts + -- [Node (MessageLine m p 0 "ContentMultipart") []] + ContentMsgRFC822 _ -> + [Node (MessageLine m p 0 "ContentMsgRFC822") []] + + +xconvPart2 :: Message -> MessagePart -> Tree ThreadView +xconvPart2 m p = + Node (TVMessagePart m p) [] + + +xconvLine + :: Message -> MessagePart -> (LineNr, T.Text) -> Tree ThreadView +xconvLine m p (i, s) = + Node (MessageLine m p i $ T.unpack s) [] + + + +threadViewImage :: Bool -> ThreadView -> Image +threadViewImage hasFocus = \case + ClosedMessage m -> + string cm (unMessageID $ messageId m) + <|> + translateX 1 ( + horizCat $ + intersperse (string cm ", ") $ + map (text' tagColor) $ + messageTags m + ) + + OpenMessage m -> + string om (unMessageID $ messageId m) + <|> + translateX 1 ( + horizCat $ + intersperse (string om ", ") $ + map (text' tagColor) $ + messageTags m + ) + + MessageLine _ _ _ s -> + string ml s + + TVMessagePart _ p -> + string def "TVMessagePart" + <|> translateX 1 (string def $ show $ partContentType p) + <-> translateX 2 (partImage p) + + where + --c1 = if hasFocus then c1_focus else c1_nofocus + --c1_nofocus = withForeColor def $ Color240 $ -16 + 238 + --c1_focus = withForeColor def $ Color240 $ -16 + 244 + --c2 = withForeColor def $ Color240 $ -16 + 106 + --c3 = withForeColor def $ Color240 $ -16 + 199 + + tagColor = if hasFocus then tagColor_y else tagColor_n + tagColor_y = withForeColor def $ color 230 + tagColor_n = withForeColor def $ color 200 + + cm = if hasFocus then cm_y else cm_n + cm_y = withForeColor def $ color 46 + cm_n = withForeColor def $ color 22 + + om = if hasFocus then om_y else om_n + om_y = withForeColor def $ color 82 + om_n = withForeColor def $ color 58 + + ml = if hasFocus then ml_y else ml_n + ml_y = withForeColor def $ color 226 + ml_n = withForeColor def $ color 202 + + --ph = if hasFocus then ph_y else ph_n + --ph_y = withForeColor def $ color 241 + --ph_n = withForeColor def $ color 235 + + color i = Color240 $ -16 + i + + + +partImage :: MessagePart -> Image +partImage p = case partContentType p of + "text/plain" -> + partContentImage $ partContent p + --string def (show $ partContent p) + "multipart/alternative" -> + partContentImage $ partContent p + "multipart/signed" -> + partContentImage $ partContent p + _ -> + mempty + + + +partTextLineImage :: String -> Image +partTextLineImage s = + string def s + + +--messageImage hasFocus m@Message{..} = +-- string c1 (unMessageID messageId) +-- <|> +-- translateX 1 ( +-- text' c2 (fromJust $ M.lookup "From" messageHeaders) +-- ) +-- <|> +-- translateX 1 ( +-- horizCat $ intersperse (string c1 ", ") $ map (text' c3) messageTags +-- ) +-- <-> +-- translateX 4 +-- (if "open" `elem` messageTags +-- then messageBodyImage m +-- else mempty) +-- +-- where +-- c1 = if hasFocus then c1_focus else c1_nofocus +-- c1_nofocus = withForeColor def $ Color240 $ -16 + 238 +-- c1_focus = withForeColor def $ Color240 $ -16 + 244 +-- c2 = withForeColor def $ Color240 $ -16 + 106 +-- c3 = withForeColor def $ Color240 $ -16 + 199 +-- +-- +-- +-- +--messageBodyImage = vertCat . map messagePartImage . messageBody +-- +--messagePartImage = partContentImage . partContent +-- + +partContentImage (ContentText t) = + vertCat $ map (text' def) $ T.lines t + +partContentImage (ContentMultipart parts) = + --string def "ContentMultipart" + vertCat $ map partImage parts + + +partContentImage (ContentMsgRFC822 _) = string def "ContentMsgRFC822" -- cgit v1.2.3