From cf7e269056a4665f28e09c83c33ee5fb7f0a355c Mon Sep 17 00:00:00 2001 From: tv Date: Sat, 27 Dec 2014 22:59:40 +0100 Subject: test4: initial emergency commit --- TreeViewRaw.hs | 204 +++++++++++++++++++++++++++++++++++++++++ test4.hs | 280 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 484 insertions(+) create mode 100644 TreeViewRaw.hs create mode 100644 test4.hs 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 -- cgit v1.2.3