diff options
| -rw-r--r-- | Utils.hs | 16 | ||||
| -rw-r--r-- | env.nix | 1 | ||||
| -rw-r--r-- | test5.hs | 411 |
3 files changed, 428 insertions, 0 deletions
diff --git a/Utils.hs b/Utils.hs new file mode 100644 index 0000000..2ccf4f7 --- /dev/null +++ b/Utils.hs @@ -0,0 +1,16 @@ +module Utils where + +import Control.Exception +import Data.Monoid +import System.Directory +import System.IO + + +withTempFile :: FilePath -> String -> ((FilePath, Handle) -> IO a) -> IO a +withTempFile tmpdir template = + bracket (openTempFile tmpdir template) (removeFile . fst) + + +mintercalate :: Monoid b => b -> [b] -> b +mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t +mintercalate _ [] = mempty @@ -31,6 +31,7 @@ let process rosezipper safe + terminalSize ] ); diff --git a/test5.hs b/test5.hs new file mode 100644 index 0000000..ec90299 --- /dev/null +++ b/test5.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import qualified Data.Text as T +import qualified Data.Tree as Tree +import qualified Data.Tree.Zipper as Z +import qualified Notmuch +import qualified Notmuch.Message as Notmuch +import qualified Notmuch.SearchResult as Notmuch +import qualified System.Console.Terminal.Size as Term +import Control.Applicative +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.Maybe +import Data.Monoid +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 Trammel +import TreeSearch +import TreeView +import TreeViewRaw +import Utils + + +data Event = + EFlash (Trammel String) | + EKey String | + EReload | + EResize Int Int + deriving Show + + +data State = State + { cursor :: Z.TreePos Z.Full TreeView + , xoffset :: Int + , yoffset :: Int + , flashMessage :: Trammel String + , screenWidth :: Int + , screenHeight :: Int + , headBuffer :: [Trammel String] + , treeBuffer :: [Trammel String] + } + + +initState :: IO State +initState = do + let query = "tag:inbox AND NOT tag:killed" + + r_ <- either error id <$> Notmuch.search query + + return State + { cursor = Z.fromTree $ fromSearchResults query r_ + , xoffset = 0 + , yoffset = 0 + , flashMessage = "Welcome to much; quit with ^C" + , screenWidth = 0 + , screenHeight = 0 + , headBuffer = [] + , treeBuffer = [] + } + + +main :: IO () +main = finally startup cleanup + + +cleanup :: IO () +cleanup = do + hPutStr stdout "\ESC[?25h" + hPutStr stdout "\ESC[?1049l" + + +startup :: IO () +startup = do + + setEnv "HOME" =<< getEnv "OLDHOME" + + + hSetEcho stdin False + hSetBuffering stdin NoBuffering + hSetBuffering stdout (BlockBuffering $ Just 4096) + + q0@State{..} <- initState + + --hSetEcho stdin False + --hSetBuffering stdin NoBuffering + -- Save Cursor and use Alternate Screen Buffer + hPutStr stdout "\ESC[?1049h" + -- Hide Cursor + hPutStr stdout "\ESC[?25l" + + (putEvent, getEvent) <- do + v <- newEmptyMVar + return (putMVar v, takeMVar v) + + (shutdown, waitForShutdown) <- do + v <- newEmptyMVar + return (putMVar v (), takeMVar v) + + + mapM_ (\(s, f) -> installHandler s (Catch f) Nothing) + [ (sigINT, shutdown) + , (28, winchHandler putEvent) + ] + + threadIds <- mapM forkIO + [ inputHandler putEvent + , run getEvent q0 + ] + + winchHandler putEvent + + waitForShutdown + mapM_ killThread threadIds + + +winchHandler :: (Event -> IO ()) -> IO () +winchHandler putEvent = + Term.size >>= \case + Just (Term.Window {Term.width = w, Term.height = h}) -> + putEvent $ EResize w h + Nothing -> + return () + + +inputHandler :: (Event -> IO ()) -> IO () +inputHandler putEvent = forever $ do + -- TODO make stdin configurable + _ <- hLookAhead stdin + ((_, s), _) <- runScanner scan + putEvent $ EKey $ map toChar s + + +run :: IO Event -> State -> IO () +run getEvent = rec where + rec q = rec =<< + let q' = render q + in redraw q' >> getEvent >>= processEvent q' + + +processEvent :: State -> Event -> IO State +processEvent q = \case + EFlash t -> + return q { flashMessage = t } + EKey s -> + case keymap s of + Just a -> + a q + Nothing -> + return q { flashMessage = Plain $ show s } + EResize w h -> + return q + { screenWidth = w, screenHeight = h + , flashMessage = Plain $ "resize " <> show (w,h) + } + ev -> + return q + { flashMessage = SGR [31,1] $ Plain $ "unhandled event: " <> show ev + } + + +render :: State -> State +render q@State{..} = + q { treeBuffer = newTreeBuf + , headBuffer = newHeadBuf + } + where + newTreeBuf = renderTreeView (Z.label cursor) (Z.toTree cursor) + newHeadBuf = + [ Plain (show screenWidth) <> "x" <> Plain (show screenHeight) + <> " " <> Plain (show $ linearPos cursor - yoffset) + <> " " <> Plain (show $ topOverrun q) + <> " " <> Plain (show $ botOverrun q) + <> " " <> flashMessage + <> " " <> Plain (show (xoffset, yoffset)) + ] + +render0 :: State -> [Trammel String] +render0 _q@State{..} = do + let buffer = + map (trammelTake screenWidth . trammelDrop xoffset) $ + take screenHeight $ + headBuffer ++ drop yoffset treeBuffer + buffer ++ take (screenHeight - length buffer) (repeat "~") + + +redraw :: State -> IO () +redraw q@State{..} = do + hPutStr stdout $ map (sub '\t' ' ') $ "\ESC[H" ++ (pp $ mintercalate "\n" $ map eraseRight $ render0 q) + hFlush stdout + where + sub x x' c = if c == x then x' else c + eraseRight s = + if len s < screenWidth + then s <> "\ESC[K" + else s + + + + +keymap :: String -> Maybe (State -> IO State) + +keymap "r" = Just replyToAll +keymap "e" = Just viewSource +keymap "k" = Just $ moveCursorUp 1 +keymap "j" = Just $ moveCursorDown 1 +keymap "K" = Just $ moveTreeDown 1 +keymap "J" = Just $ moveTreeUp 1 +keymap "\ESC[A" = Just $ moveCursorUp 1 +keymap "\ESC[B" = Just $ moveCursorDown 1 +keymap "\ESC[a" = Just $ moveTreeDown 1 +keymap "\ESC[b" = Just $ moveTreeUp 1 +keymap "\ESC[c" = Just $ moveTreeLeft 1 -- S-Right +keymap "\ESC[d" = Just $ moveTreeRight 1 -- S-Left +keymap "\ESC[5~" = Just $ \q -> moveTreeDown (screenHeight q `div` 2) q -- PgUp +keymap "\ESC[6~" = Just $ \q -> moveTreeUp (screenHeight q `div` 2) q -- PgDn +keymap "\n" = Just toggleFold +keymap "\DEL" = Just moveToParent -- backspace + +keymap _ = Nothing + + + +topOverrun :: State -> Int +topOverrun State{..} = + max 0 (- (linearPos cursor - yoffset)) + + +botOverrun :: State -> Int +botOverrun State{..} = + max 0 (linearPos cursor - yoffset - (screenHeight - (length headBuffer) - 1)) + + + +moveCursorDown :: Monad m => Int -> State -> m State +moveCursorDown n q@State{..} = + let cursor' = findNextN n cursor + q' = q { cursor = cursor' } + in case botOverrun q' of + 0 -> return q' + i -> moveTreeUp i q' + + +moveCursorUp :: Monad m => Int -> State -> m State +moveCursorUp n q@State{..} = + let cursor' = findPrevN n cursor + q' = q { cursor = cursor' } + in case topOverrun q' of + 0 -> return q' + i -> moveTreeDown i q' + + +moveTreeUp :: Monad m => Int -> State -> m State +moveTreeUp n q@State{..} = + let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset + n) } + in case topOverrun q' of + 0 -> return q' + i -> moveCursorDown i q' + + +moveTreeDown :: Monad m => Int -> State -> m State +moveTreeDown n q@State{..} = + let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset - n) } + in case botOverrun q' of + 0 -> return q' + i -> moveCursorUp i q' + + +moveTreeLeft :: Monad m => Int -> State -> m State +moveTreeLeft n q@State{..} = + return q { xoffset = xoffset + n } + +moveTreeRight :: Monad m => Int -> State -> m State +moveTreeRight n q@State{..} = + return q { xoffset = max 0 (xoffset - n) } + + +moveToParent :: Monad m => State -> m State +moveToParent q@State{..} = + case Z.parent cursor of + Nothing -> return q { flashMessage = "cannot go further up" } + Just cursor' -> + let q' = q { cursor = cursor' } + in case topOverrun q' of + 0 -> return q' + i -> moveTreeDown i q' + + +toggleFold :: State -> IO State +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 :: State -> IO State +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 -> + (system $ editor ++ " " ++ path) >>= \case + ExitFailure code -> + putStrLn $ editor ++ " exit code = " ++ show code + ExitSuccess -> + return () + return q + + +viewSource :: State -> IO State +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 -> + (system $ editor ++ " " ++ path) >>= \case + ExitFailure code -> + putStrLn $ editor ++ " exit code = " ++ show code + ExitSuccess -> + return () + return q |