diff options
Diffstat (limited to 'test3.hs')
| -rw-r--r-- | test3.hs | 273 |
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 |