summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Utils.hs16
-rw-r--r--env.nix1
-rw-r--r--test5.hs411
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
diff --git a/env.nix b/env.nix
index a98b518..500bf3e 100644
--- a/env.nix
+++ b/env.nix
@@ -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