path: root/ThreadView.hs

{-# 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"