initial commit

1 files changed, 273 insertions, 0 deletions

diff --git a/test3.hs b/test3.hs
new file mode 100644
index 0000000..3dfa036
--- /dev/null
+++ b/test3.hs
@@ -0,0 +1,273 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
+
+
+import Data.Default
+import Graphics.Vty
+
+--import Data.List
+
+--import Language.Haskell.TH.Ppr (bytesToString)
+--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 -- hiding (focusPrev, focusNext)
+--import Safe
+
+import Control.Exception
+
+import ThreadView
+
+
+
+
+
+
+
+
+--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
+--
+--focusMessage t_cur t = do
+--    i <- findIndex ((==t_cur) . messageId) msgs
+--    msgs `atMay` i
+--  where
+--    msgs = flatten t
+
+
+toggleTag :: T.Text -> ThreadView -> IO ()
+toggleTag tag = \case
+    OpenMessage m -> f m
+    ClosedMessage m -> f m
+    _ -> return ()
+  where
+    f m = do
+        _ <- if tag `elem` messageTags m
+            then
+                unsetTag tagString (unMessageID $ messageId m)
+            else
+                setTag tagString (unMessageID $ messageId m)
+        return ()
+    tagString = T.unpack tag
+
+
+--toggleTag tag t_cur t =
+--    case focusMessage t_cur t of
+--        Nothing -> return ()
+--        Just m -> do
+--            if tag `elem` messageTags m
+--                then
+--                    unsetTag tagString (unMessageID $ messageId m)
+--                else
+--                    setTag tagString (unMessageID $ messageId m)
+--            return ()
+--  where
+--    tagString = T.unpack tag
+
+tagMessage :: T.Text -> Message -> IO LBS.ByteString
+tagMessage tag m =
+  setTag (T.unpack tag) (unMessageID $ messageId m)
+
+
+untagMessage :: T.Text -> Message -> IO LBS.ByteString
+untagMessage tag m =
+  unsetTag (T.unpack tag) (unMessageID $ messageId m)
+
+
+
+main :: IO ()
+main =
+    bracket (mkVty def) finit run
+  where
+
+    finit vty = do
+        shutdown vty
+
+    run vty = do
+        t_ <- getThread tid
+        let v = fromMessageTree t_
+        let c = findMessage (MessageID cid) v
+        rec vty 0 c v
+
+    tid = "0000000000000862"
+    cid = "87egtmvj0n.fsf@write-only.cryp.to"
+
+    --rec vty t_cur t = do
+    rec :: Vty -> Int -> Maybe ThreadView -> Tree ThreadView -> IO ()
+    rec vty i c v = do
+        let --img = threadImage t_cur (fromMessageTree t)
+            img =
+                (
+                  string def (show i)
+                  <|>
+                  translateX 1
+                    (
+                      string def (maybe "Nothing" describe c)
+                    )
+                )
+                <->
+                threadImage c v
+            pic = picForImage img
+        update vty pic
+        nextEvent vty >>= \e -> case e of
+            EvKey KUp [] ->
+                --case focusPrev t_cur t of
+                --case focusPrev c v of
+                --    Just t_prev ->
+                --        --rec vty t_prev t
+                --        rec vty (i + 1) t_prev v
+                --    Nothing ->
+                --        --rec vty t_cur t
+                --        rec vty (i + 1) c v
+                rec vty (i + 1) (focusPrev c v) v
+            EvKey KDown [] ->
+                --case focusNext t_cur t of
+                --case focusNext c v of
+                --    Just t_next ->
+                --        --rec vty t_next t
+                --        rec vty (i + 1) t_next v
+                --    Nothing ->
+                --        --rec vty t_cur t
+                --        rec vty (i + 1) c v
+                rec vty (i + 1) (focusNext c v) v
+            EvKey KEnter [] ->
+                case c of
+                    Nothing -> error "no cursor"
+                    Just c_ -> do
+                        --toggleTag "open" t_cur t
+                        toggleTag "open" c_
+                        t'_ <- getThread tid
+                        let v' = fromMessageTree t'_
+                        let c' = findTV c_ v'
+                        if c' == Nothing
+                            then error $ "couldn't find" ++ show (c_, v')
+                            else return ()
+                        --rec vty t_cur t'
+                        rec vty (i + 1) c' v'
+
+            EvResize _w _h ->
+                --rec vty t_cur t
+                rec vty (i + 1) c v
+
+            _ -> do
+                print $ "Last event was: " ++ show e
+
+
+
+
+threadImage :: Maybe ThreadView -> Tree ThreadView -> Image
+--threadImage t_cur (Node n ns) =
+threadImage c (Node n ns) =
+    --messageImage hasFocus n
+    --threadViewImage (hasFocus n) n
+    threadViewImage (c == Just n) n
+    <->
+    translateX 2 (vertCat $ map (threadImage c) ns)
+  --where
+  --  --hasFocus = t_cur == messageId n
+  --  hasFocus :: ThreadView -> Bool
+  --  hasFocus (OpenMessage m) = c == m
+  --  hasFocus (ClosedMessage m) = c == m
+  --  hasFocus _ = False
+
+
+--showTree' :: Tree Message -> [String]
+--showTree' (Node n ns) =
+--    -- (if length ns == 0
+--    --     then indentMessageInit $ drawMessage n
+--    --     else indentMessageLast $ drawMessage n)
+--    drawMessage n
+--    ++
+--    concat (indentChildren (map showTree' ns))
+
+
+--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 _) = string def "ContentMultipart"
+--partContentImage (ContentMsgRFC822 _) = string def "ContentMsgRFC822"
+
+
+
+
+
+
+
+--    ----unMessageID messageId
+--    --show messageTime
+--    --  -- <> " " <> T.unpack messageDateRel
+--    --  <> "\n" <> show (fromJust $ M.lookup "From" messageHeaders)
+--    --  <> "\n" <> show (fromJust $ M.lookup "Subject" messageHeaders)
+--    [ gray (unMessageID messageId)
+--      <> " " <> T.unpack (fromJust $ M.lookup "From" messageHeaders)
+--      <> " " <> gray (show messageDateRel)
+--      <> " " <> T.unpack (T.intercalate ", " $ map magenta messageTags)
+--    -- , T.unpack $ fromJust $ M.lookup "Subject" messageHeaders
+--    ]
+--    ++
+--    (if "open" `elem` messageTags
+--        then concat (map (map green . lines . drawMessagePart) messageBody)
+--        else [])
+--    --map drawMessagePart messageBody