diff options
Diffstat (limited to 'test4.hs')
| -rw-r--r-- | test4.hs | 280 |
1 files changed, 280 insertions, 0 deletions
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 |