summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--TreeViewRaw.hs204
-rw-r--r--test4.hs280
2 files changed, 484 insertions, 0 deletions
diff --git a/TreeViewRaw.hs b/TreeViewRaw.hs
new file mode 100644
index 0000000..babd42d
--- /dev/null
+++ b/TreeViewRaw.hs
@@ -0,0 +1,204 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TreeViewRaw where
+
+import TreeView
+import Data.Tree
+import Trammel
+import qualified Notmuch
+import qualified Notmuch.Message as Notmuch
+import qualified Notmuch.SearchResult as Notmuch
+import qualified Data.CaseInsensitive as CI
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Data.Text as T
+
+-- Maybe TreeView -> Tree TreeView -> Image
+--hPutTreeView h cur tv =
+-- treeImage (Just $ Z.label cursor) (Z.toTree cursor)
+
+renderTreeView :: TreeView -> Tree TreeView -> [String]
+renderTreeView cur _loc@(Node label children) =
+ [ colorize $ renderTreeView1 hasFocus label ] ++
+ concatMap (map (" "++) . renderTreeView cur) children
+ where
+ hasFocus = cur == label
+ colorize s =
+ if hasFocus
+ then pp $ SGR [31] s
+ else pp s
+
+
+renderTreeView1 :: Bool -> TreeView -> Trammel String
+renderTreeView1 hasFocus = \case
+
+ TVSearch s ->
+ Plain s
+
+ TVSearchResult sr -> Plain $
+ (padl 11 ' ' $ T.unpack $ Notmuch.searchDateRel sr)
+ ++ "("
+ ++ (show $ Notmuch.searchMatched sr)
+ ++ ") "
+ ++ (T.unpack $ Notmuch.searchSubject sr)
+ -- ++ " "
+ -- ++ (let Notmuch.ThreadID tid = Notmuch.searchThread sr in tid)
+
+ TVMessage m -> Plain $
+ (Notmuch.unMessageID $ Notmuch.messageId m)
+ ++ " "
+ ++ T.unpack (T.intercalate (T.pack ",") $ Notmuch.messageTags m)
+
+ TVMessageHeaderField m fieldName -> Plain $
+ let k = T.unpack $ CI.original fieldName
+ v = maybe "nothing"
+ T.unpack
+ (M.lookup fieldName $ Notmuch.messageHeaders m)
+ in k ++ ": " ++ v
+
+ TVMessagePart _ p -> Plain $
+ "part#"
+ ++ (show $ Notmuch.partID p)
+ ++ " "
+ ++ (T.unpack $ CI.original $ Notmuch.partContentType p)
+
+ TVMessageLine _ _ _ s ->
+ Plain s
+ -- | TVMessageLine Message MessagePart LineNr String
+
+
+ --TVMessage m ->
+ -- let col = if isOpen m then om else cm
+ -- in
+ -- string col (unMessageID $ messageId m)
+ -- <|>
+ -- translateX 1 (
+ -- horizCat $
+ -- intersperse (string col ", ") $
+ -- map (text' tagColor) $
+ -- messageTags m
+ -- )
+ s ->
+ Plain $ describe s
+-- let col = if isOpen m then om else cm
+-- in
+-- string col (unMessageID $ messageId m)
+-- <|>
+-- translateX 1 (
+-- horizCat $
+-- intersperse (string col ", ") $
+-- map (text' tagColor) $
+-- messageTags m
+-- )
+
+
+--hPutTreeView h hasFocus = \case
+-- TVMessage m ->
+-- putStr
+-- _ ->
+
+
+
+--
+--treeViewImage :: Bool -> TreeView -> Image
+--treeViewImage hasFocus = \case
+-- TVMessage m ->
+-- let col = if isOpen m then om else cm
+-- in
+-- string col (unMessageID $ messageId m)
+-- <|>
+-- translateX 1 (
+-- horizCat $
+-- intersperse (string col ", ") $
+-- map (text' tagColor) $
+-- messageTags m
+-- )
+--
+-- TVMessageHeaderField m fieldName ->
+-- let k = string mhf $ T.unpack $ CI.original fieldName
+-- v = maybe (string mhf_empty "nothing")
+-- (string mhf . T.unpack)
+-- (M.lookup fieldName $ messageHeaders m)
+-- in k <|> string mhf ": " <|> v
+--
+-- TVMessagePart _ p ->
+-- string mp "TVMessagePart"
+-- <|> translateX 1 (string mp $ show $ partID p)
+-- <|> translateX 1 (string mp $ show $ partContentType p)
+--
+-- TVMessageLine _ _ _ s ->
+-- string ml s
+--
+-- TVSearch s ->
+-- string sColor s
+--
+-- TVSearchResult sr -> do
+-- --let ThreadID tid = searchThread sr
+-- --string srColor tid
+-- -- <|>
+-- --translateX 1
+-- (string srColor $ padl 11 ' ' $ T.unpack $ searchDateRel sr)
+-- <|>
+-- string srColor " ("
+-- <|>
+-- (string srColor $ show $ searchMatched sr)
+-- <|>
+-- string srColor ")"
+-- <|>
+-- string srColor " "
+-- -- <|>
+-- -- (string srColor $ show $ searchTime sr)
+-- <|>
+-- (string srColor $ T.unpack $ searchSubject sr)
+-- <|>
+-- --(string srColor $ T.unpack $ searchThread sr)
+-- (translateX 1 $ let ThreadID tid = searchThread sr in string srColor tid)
+-- --string srColor tid
+-- 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
+--
+-- mhf = if hasFocus then mhf_y else mhf_n
+-- mhf_y = withForeColor def $ color 248
+-- mhf_n = withForeColor def $ color 244
+--
+-- mhf_empty = if hasFocus then mhf_empty_y else mhf_empty_n
+-- mhf_empty_y = withForeColor def $ color 88
+-- mhf_empty_n = withForeColor def $ color 52
+--
+-- --ph = if hasFocus then ph_y else ph_n
+-- --ph_y = withForeColor def $ color 241
+-- --ph_n = withForeColor def $ color 235
+--
+-- mp = if hasFocus then mp_y else mp_n
+-- mp_y = withForeColor def $ color 199
+-- mp_n = withForeColor def $ color 162
+--
+-- sColor = if hasFocus then sColor_y else sColor_n
+-- sColor_y = withForeColor def $ color 196
+-- sColor_n = withForeColor def $ color 88
+--
+-- srColor = if hasFocus then srColor_y else srColor_n
+-- srColor_y = withForeColor def $ color 197
+-- srColor_n = withForeColor def $ color 89
+--
+-- color i = Color240 $ -16 + i
diff --git a/test4.hs b/test4.hs
new file mode 100644
index 0000000..893d120
--- /dev/null
+++ b/test4.hs
@@ -0,0 +1,280 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Data.Maybe
+import Scanner (scan, runScanner, toChar)
+import System.Directory
+import System.Environment
+import System.Exit
+import System.IO
+import System.Posix.Files
+import System.Posix.Signals
+import System.Process
+import TreeSearch
+import TreeView
+import TreeViewRaw
+import qualified Notmuch
+import qualified Notmuch.Message as Notmuch
+import qualified Notmuch.SearchResult as Notmuch
+import qualified Data.Tree.Zipper as Z
+import qualified Data.Tree as Tree
+import qualified Data.Text as T
+
+
+data State = State
+ { charge :: IO ()
+ , discharge :: IO ()
+ , cursor :: Z.TreePos Z.Full TreeView
+ , xoffset :: Int
+ , yoffset :: Int
+ , flashMessage :: String
+ , screenWidth :: Int
+ , screenHeight :: Int
+ }
+
+
+main :: IO ()
+main = do
+ setEnv "HOME" =<< getEnv "OLDHOME"
+
+ q@State{..} <- initState
+ bracket_ charge discharge $ do
+ winchHandler
+ run q
+
+
+initState :: IO State
+initState = do
+
+ let query = "tag:inbox AND NOT tag:killed"
+
+ r_ <- either error id <$> Notmuch.search query
+
+ echo0 <- hGetEcho stdin
+ buffering0 <- hGetBuffering stdin
+ return State
+ { charge = do
+ _ <- installHandler 28 (Catch winchHandler) Nothing
+ hSetEcho stdin False
+ hSetBuffering stdin NoBuffering
+ -- Save Cursor and use Alternate Screen Buffer
+ hPutStr stdout "\ESC[?1049h"
+ -- Hide Cursor
+ hPutStr stdout "\ESC[?25l"
+ -- Move the cursor to the home position
+ hPutStr stdout "\ESC[H"
+ hFlush stdout
+ , discharge = do
+ _ <- installHandler 28 Default Nothing
+ hSetEcho stdin echo0
+ hSetBuffering stdin buffering0
+ -- Use Normal Screen Buffer and restore Cursor
+ hPutStr stdout "\ESC[?1049l"
+ hFlush stdout
+ , cursor = Z.fromTree $ fromSearchResults query r_
+ , xoffset = 0
+ , yoffset = 0
+ , flashMessage = "Welcome to much; quit with ^C"
+ , screenWidth = 0
+ , screenHeight = 0
+ }
+
+
+run :: State -> IO ()
+run q = do
+
+ redraw q
+
+ _ <- hLookAhead stdin -- wait for input
+ ((_, s), _) <- runScanner scan
+
+ case keymap (map toChar s) of
+ Just a ->
+ a q >>= run
+ Nothing ->
+ run q { flashMessage = show $ map toChar s }
+
+
+redraw :: State -> IO ()
+redraw _q@State{..} = do
+
+ --putStrLn $ describe (Z.label cursor)
+ --putStr "\ESC[?2J"
+ putStr "\ESC[H"
+ --mapM_ putStr $ take screenHeight $ repeat "\ESC[2K\n"
+ --putStr "\ESC[H"
+
+ -- consumes 1 screenHeight
+ putStr $ "\ESC[2K" ++ flashMessage ++ " " ++ show (screenWidth, screenHeight)
+
+ mapM_ (putStr . ("\n\ESC[2K"++)) $
+ map (take screenWidth . drop xoffset) $
+ take (screenHeight - 1) $
+ drop yoffset $
+ renderTreeView (Z.label cursor) (Z.toTree cursor)
+
+
+
+winchHandler :: IO ()
+winchHandler = do
+ -- Report the size of the screen in characters.
+ -- Result is CSI 9 ; height ; width t
+ putStr "\ESC[19t"
+
+
+keymap :: String -> Maybe (State -> IO State)
+
+keymap "r" = Just replyToAll
+keymap "e" = Just viewSource
+keymap "k" = Just moveCursorUp
+keymap "j" = Just moveCursorDown
+keymap "K" = Just moveTreeDown
+keymap "J" = Just moveTreeUp
+keymap "\ESC[A" = Just moveCursorUp
+keymap "\ESC[B" = Just moveCursorDown
+keymap "\ESC[a" = Just moveTreeDown
+keymap "\ESC[b" = Just moveTreeUp
+keymap "\n" = Just toggleFold
+
+keymap ('\ESC':'[':'9':';':xs) = Just $ \q@State{..} -> do
+ let (h,';':w) = break (==';') (take (length xs - 1) xs) -- ^ drop (assumed) trailing 't'
+ return q { screenWidth = read w, screenHeight = read h }
+keymap _ = Nothing
+
+
+moveCursorDown q@State{..} =
+ return q { cursor = fromMaybe (Z.root cursor) $ findNext cursor }
+
+moveCursorUp q@State{..} =
+ return q { cursor = fromMaybe (Z.root cursor) $ findPrev cursor }
+
+moveTreeUp q@State{..} =
+ return q { yoffset = max 0 (yoffset + 1) }
+
+moveTreeDown q@State{..} =
+ return q { yoffset = max 0 (yoffset - 1) }
+
+
+toggleFold q@State{..} = case Z.label cursor of
+ TVMessage m -> do
+ toggleTag (T.pack "open") m
+
+ let Just sr = findParent isTVSearchResult cursor
+ TVSearchResult the_sr = Z.label sr
+ Notmuch.ThreadID tid = Notmuch.searchThread the_sr
+
+ t_ <- return . fromMessageForest =<< Notmuch.getThread tid
+
+ let cursor' = Z.modifyTree (\(Tree.Node l _) -> Tree.Node l t_) sr
+ return q { cursor = select (==Z.label cursor) cursor' }
+
+ TVSearchResult sr -> do
+ let open = not $ null $ Tree.subForest $ Z.tree cursor
+ let Notmuch.ThreadID tid = Notmuch.searchThread sr
+
+ t_ <-
+ if open
+ then return []
+ else return . fromMessageForest =<< Notmuch.getThread tid
+
+ let cursor' = Z.modifyTree (\(Tree.Node l _) -> Tree.Node l t_) cursor
+ return q { cursor = select (==Z.label cursor) cursor' }
+
+ _ ->
+ return q { flashMessage = "nothing happened" }
+ where
+ select p loc = fromMaybe (error "cannot select") $ findTree p $ Z.root loc
+
+ toggleTag :: T.Text -> Notmuch.Message -> IO ()
+ toggleTag tag m = do
+ _ <- if tag `elem` Notmuch.messageTags m
+ then
+ Notmuch.unsetTag tagString (Notmuch.unMessageID $ Notmuch.messageId m)
+ else
+ Notmuch.setTag tagString (Notmuch.unMessageID $ Notmuch.messageId m)
+ return ()
+ where
+ tagString = T.unpack tag
+
+
+
+
+replyToAll q@State{..} = case getMessage (Z.label cursor) of
+ Nothing ->
+ return q { flashMessage = "no message" }
+ Just m -> do
+ editor <- getEnv "EDITOR"
+ logname <- getEnv "LOGNAME"
+ tmpdir <- getTemporaryDirectory
+
+
+ let template = logname ++ "_much_draft_.mail"
+
+ let msgId = Notmuch.unMessageID $ Notmuch.messageId m
+
+ withTempFile tmpdir template $ \(path, draftH) -> do
+ (_, _, _, procH) <-
+ withFile "/dev/null" ReadMode $ \nullH ->
+ createProcess
+ (proc "notmuch" [ "reply" , "id:" ++ msgId ])
+ { std_in = UseHandle nullH
+ , std_out = UseHandle draftH
+ }
+ hClose draftH
+ waitForProcess procH >>= \case
+ ExitFailure code ->
+ putStrLn $ "notmuch exit code = " ++ show code
+ ExitSuccess ->
+ finally (system $ editor ++ " " ++ path) charge >>= \case
+ ExitFailure code ->
+ putStrLn $ editor ++ " exit code = " ++ show code
+ ExitSuccess ->
+ return ()
+ return q
+
+
+viewSource q@State{..} = case getMessage (Z.label cursor) of
+ Nothing ->
+ return q { flashMessage = "no message" }
+ Just m -> do
+ editor <- getEnv "EDITOR"
+ logname <- getEnv "LOGNAME"
+ tmpdir <- getTemporaryDirectory
+
+ let template = logname ++ "_much_raw_.mail"
+
+ let msgId = Notmuch.unMessageID $ Notmuch.messageId m
+
+ withTempFile tmpdir template $ \(path, draftH) -> do
+ setFileMode path 0o400
+ (_, _, _, procH) <-
+ withFile "/dev/null" ReadMode $ \nullH ->
+ createProcess
+ (proc "notmuch" [ "show", "--format=raw", "id:" ++ msgId ])
+ { std_in = UseHandle nullH
+ , std_out = UseHandle draftH
+ }
+ hClose draftH
+ waitForProcess procH >>= \case
+ ExitFailure code ->
+ putStrLn $ "notmuch exit code = " ++ show code
+ ExitSuccess ->
+ finally (system $ editor ++ " " ++ path) charge >>= \case
+ ExitFailure code ->
+ putStrLn $ editor ++ " exit code = " ++ show code
+ ExitSuccess ->
+ return ()
+ return q
+
+
+
+
+
+
+
+withTempFile :: FilePath -> String -> ((FilePath, Handle) -> IO a) -> IO a
+withTempFile tmpdir template f = do
+ bracket (openTempFile tmpdir template) (removeFile . fst) f
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 04:59:07 +0000