summaryrefslogtreecommitdiffstats
path: root/ThreadView.hs
diff options
context:
space:
mode:
Diffstat (limited to 'ThreadView.hs')
-rw-r--r--ThreadView.hs286
1 files changed, 286 insertions, 0 deletions
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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-18 12:57:16 +0000