diff options
| -rw-r--r-- | TreeView.hs | 169 | ||||
| -rw-r--r-- | TreeViewRaw.hs | 150 | ||||
| -rw-r--r-- | Utils.hs | 7 | ||||
| -rw-r--r-- | test1.hs | 14 | ||||
| -rw-r--r-- | test3.hs | 323 | ||||
| -rw-r--r-- | test4.hs | 352 | ||||
| -rw-r--r-- | test5.hs | 4 |
7 files changed, 26 insertions, 993 deletions
diff --git a/TreeView.hs b/TreeView.hs index ed91ce8..d1b0c95 100644 --- a/TreeView.hs +++ b/TreeView.hs @@ -2,34 +2,20 @@ {-# LANGUAGE LambdaCase #-} -module TreeView where +module TreeView + ( TreeView (..) + , getMessage + , isTVSearchResult + , fromSearchResults + , fromMessageForest + , fromMessageTree + ) where -import Data.Default -import Graphics.Vty -import Data.List - ---import Data.Aeson ---import Data.List.Split ---import Data.Attoparsec.ByteString hiding (string) ---import Data.Maybe -import Data.Monoid ---import Data.String ---import Data.Traversable -import Data.Tree ---import qualified Data.ByteString as BS ---import qualified Data.ByteString.Lazy as LBS ---import qualified Data.ByteString.Char8 as BS8 ---import qualified Data.Text.Lazy as TL import qualified Data.CaseInsensitive as CI import qualified Data.Text as T ---import qualified Data.Text.Encoding as T ---import qualified Data.Text.IO as T ---import Data.Version (Version(..), parseVersion) ---import System.Process ---import System.IO -import qualified Data.Map as M - +import Data.Monoid +import Data.Tree import Notmuch.Message import Notmuch.SearchResult @@ -46,6 +32,7 @@ data TreeView | TVSearchResult SearchResult deriving (Show) + instance Eq TreeView where TVMessage m1 == TVMessage m2 = m1 == m2 @@ -82,27 +69,6 @@ isTVSearchResult (TVSearchResult _) = True isTVSearchResult _ = False -describe :: TreeView -> String -describe (TVMessage m) = "TVMessage " <> unMessageID (messageId m) -describe (TVMessageHeaderField m k) = "TVMessageHeaderField " <> unMessageID (messageId m) <> " " <> T.unpack (CI.original k) -describe (TVMessagePart m p) = "TVMessagePart " <> (unMessageID $ messageId m) <> " " <> show (partID p) -describe (TVMessageLine _ _ _ s) = "TVMessageLine " <> show s -describe (TVSearch s) = "TVSearch " <> show s -describe (TVSearchResult sr) = "TVSearchResult " <> show (searchTotal sr) - - -findMessage :: MessageID -> Tree TreeView -> Maybe TreeView -findMessage i = - find p . flatten - where - p (TVMessage m) = i == messageId m - p _ = False - -findTV :: TreeView -> Tree TreeView -> Maybe TreeView -findTV x = - find (==x) . flatten - - fromSearchResults :: String -> [SearchResult] -> Tree TreeView fromSearchResults query = Node (TVSearch query) . map (\r -> Node (TVSearchResult r) []) @@ -162,116 +128,3 @@ xconvLine :: Message -> MessagePart -> (LineNr, T.Text) -> Tree TreeView xconvLine m p (i, s) = Node (TVMessageLine m p i $ T.unpack s) [] - - - -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 - - - -padl :: Int -> a -> [a] -> [a] -padl n c s = - if length s < n - then padl n c (c:s) - else s diff --git a/TreeViewRaw.hs b/TreeViewRaw.hs index 114e75a..db4a899 100644 --- a/TreeViewRaw.hs +++ b/TreeViewRaw.hs @@ -1,19 +1,19 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module TreeViewRaw where +module TreeViewRaw (renderTreeView) where -import Data.Monoid -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 +import Data.Monoid +import Data.Tree +import Trammel +import TreeView +import Utils (padl) renderTreeView :: TreeView -> Tree TreeView -> [Trammel String] @@ -78,141 +78,3 @@ renderTreeView1 hasFocus = \case 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 @@ -14,3 +14,10 @@ withTempFile tmpdir template = mintercalate :: Monoid b => b -> [b] -> b mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t mintercalate _ [] = mempty + + +padl :: Int -> a -> [a] -> [a] +padl n c s = + if length s < n + then padl n c (c:s) + else s diff --git a/test1.hs b/test1.hs deleted file mode 100644 index 43f3098..0000000 --- a/test1.hs +++ /dev/null @@ -1,14 +0,0 @@ -import Data.Default -import Graphics.Vty - - -main = do - vty <- mkVty def - let line0 = string (def withForeColor $ ISOColor 3) "first line" - line1 = string (def withBackColor blue) "second line" - img = line0 <-> line1 - pic = picForImage img - update vty pic - e <- nextEvent vty - shutdown vty - print $ "Last event was: " ++ show e diff --git a/test3.hs b/test3.hs deleted file mode 100644 index 16bbe61..0000000 --- a/test3.hs +++ /dev/null @@ -1,323 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} - - -import Data.Default -import Graphics.Vty - ---import Data.List - -import Control.Applicative ---import Language.Haskell.TH.Ppr (bytesToString) ---import Data.Aeson ---import Data.List.Split ---import Data.Attoparsec.ByteString hiding (string) -import Data.Maybe -import Data.Monoid ---import Data.String ---import Data.Traversable -import Data.Tree -import qualified Data.Tree.Zipper as Z ---import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS ---import qualified Data.ByteString.Char8 as BS8 ---import qualified Data.Text.Lazy as TL -import qualified Data.Text as T ---import qualified Data.Text.Encoding as T ---import qualified Data.Text.IO as T ---import Data.Version (Version(..), parseVersion) ---import System.Process ---import System.IO ---import qualified Data.Map as M - -import System.Environment -import Notmuch -import Notmuch.Message -import Notmuch.SearchResult ---import Safe - -import Control.Exception - -import TreeView - -import TreeSearch ---import Editor (edit) -import System.Process -import System.Environment -import qualified Data.ByteString.Lazy as LBS -import System.IO -import System.Directory -import Control.Exception (bracket) -import Control.Exception -import System.IO -import Control.DeepSeq (rnf) - - -data State = State - { vty :: Vty - , cursor :: Z.TreePos Z.Full TreeView - , xoffset :: Int - , yoffset :: Int - , message :: String - } - - -toggleTag :: T.Text -> Message -> IO () -toggleTag tag m = do - _ <- if tag `elem` messageTags m - then - unsetTag tagString (unMessageID $ messageId m) - else - setTag tagString (unMessageID $ messageId m) - return () - where - tagString = T.unpack tag - - -tagMessage :: T.Text -> Message -> IO LBS.ByteString -tagMessage tag m = - setTag (T.unpack tag) (unMessageID $ messageId m) - - -untagMessage :: T.Text -> Message -> IO LBS.ByteString -untagMessage tag m = - unsetTag (T.unpack tag) (unMessageID $ messageId m) - - -main :: IO () -main = - main' "tag:inbox AND NOT tag:killed" - -main' :: String -> IO () -main' query = do - setEnv "HOME" "/home/tv" - bracket (mkVty def) finit run - where - - finit vty = do - shutdown vty - - run vty0 = do - --XXX show a single thread - --t_ <- getThread "0000000000000862" - --let v = fromMessageTree t_ - --let c = findMessage (MessageID "87egtmvj0n.fsf@write-only.cryp.to") v - --rec vty 0 c v - - r_ <- either error id <$> search query - rec State - { vty = vty0 - , cursor = Z.fromTree $ fromSearchResults query r_ - , xoffset = 0 - , yoffset = 0 - , message = "Welcome to much; quit with ^C" - } - - rec :: State -> IO () - rec q0@State{..} = do - let - img = - --string def (show i) <-> - --string def (maybe "Nothing" describe (focusPrev v cursor)) <-> - --string def (maybe "Nothing" describe cursor) <-> - --string def (maybe "Nothing" describe (focusNext v cursor)) <-> - --string def (maybe "Nothing" describe (focusPrev v cursor)) <-> - --string def (describe $ Z.label cursor) <-> - --string def (maybe "Nothing" describe (focusNext v cursor)) <-> - treeImage (Just $ Z.label cursor) (Z.toTree cursor) - --renderTree q - pic = picForImage $ - (string def message) <-> - translate xoffset yoffset img - --v = Z.root cursor - update vty pic - nextEvent vty >>= \e -> case e of - EvKey KEsc [] -> - rec q - - EvKey (KChar 'c') [MCtrl] -> - error "^C" - - EvKey (KChar 'k') [] -> - rec q { cursor = fromMaybe (Z.root cursor) $ findPrev cursor } - EvKey (KChar 'j') [] -> - rec q { cursor = fromMaybe (Z.root cursor) $ findNext cursor } - EvKey KEnter [] -> - onEnter cursor - - EvKey (KChar 'H') [] -> rec q { xoffset = xoffset - 3 } - EvKey (KChar 'L') [] -> rec q { xoffset = xoffset + 3 } - EvKey (KChar 'J') [] -> rec q { yoffset = yoffset - 3 } - EvKey (KChar 'K') [] -> rec q { yoffset = yoffset + 3 } - - EvKey (KChar 'r') [] -> - case getMessage (Z.label cursor) of - Just m -> do - replyToAll m q >>= rec - Nothing -> - rec q { message = "no message" } - --reply ToAll q >>= \case - -- Left s -> rec q { message = s } - -- Right () -> rec q - - EvResize _w _h -> - rec q - - _ -> do - rec q { message = "unbound key: " ++ show e } - where - - q = q0 { message = "" } - - onEnter c_ = case Z.label c_ of - TVMessage m -> do - toggleTag "open" m - - let loc = cursor - Just sr = findParent isTVSearchResult loc - --Just sr0 = Z.firstChild sr -- TODO can there be only one (thread per sr)? - TVSearchResult the_sr = Z.label sr - ThreadID tid = searchThread the_sr - - t_ <- return . fromMessageForest =<< getThread tid - - let loc' = Z.modifyTree (\(Node l _) -> Node l t_) sr - rec q { cursor = select (==Z.label cursor) loc' } - - TVSearchResult sr -> do - --let Just loc = findTree (==c_) $ Z.fromTree v - let loc = cursor - - let open = not $ null $ subForest $ Z.tree loc - let ThreadID tid = searchThread sr - - t_ <- - if open - then return [] - else return . fromMessageForest =<< getThread tid - - let loc' = Z.modifyTree (\(Node l _) -> Node l t_) loc - rec q { cursor = select (==Z.label cursor) loc' } - - _ -> - -- TODO make some noise - rec q - - -select :: (a -> Bool) -> Z.TreePos Z.Full a -> Z.TreePos Z.Full a -select p loc = fromMaybe (error "cannot select") $ findTree p $ Z.root loc - - -treeImage :: Maybe TreeView -> Tree TreeView -> Image -treeImage c (Node n ns) = - treeViewImage (c == Just n) n <-> - translateX 2 (vertCat $ map (treeImage c) ns) - - ---reply :: ReplyTo -> State -> IO (Either String ()) ---reply replyTo _q@State{..} = --- case getMessage (Z.label cursor) of --- Just Message{..} -> do --- x <- notmuchReply replyTo ("id:" <> unMessageID messageId) --- edit x --- return $ Right () --- Nothing -> --- return $ Left "no message" - ---edit :: LBS.ByteString -> IO () ---edit draft = do --- editor <- getEnv "EDITOR" --- logname <- getEnv "LOGNAME" --- tmpdir <- getTemporaryDirectory --- --- let template = logname ++ "_much_draft_XXX.email" --- --- bracket (openTempFile tmpdir template) cleanup $ \(path, h) -> do --- LBS.hPut h draft --- hClose h --- --hFlush h --- system (editor ++ " " ++ path) --- return () --- where --- cleanup (path, h) = do --- removeFile path --- hClose h - -replyToAll Message{..} q = do - editor <- getEnv "EDITOR" - logname <- getEnv "LOGNAME" - tmpdir <- getTemporaryDirectory - - let template = logname ++ "_much_draft_XXX.email" - - bracket (openTempFile tmpdir template) cleanup $ \(path, draftH) -> do - (_, _, _, procH) <- - withFile "/dev/null" ReadMode $ \devnull -> - createProcess - (proc "notmuch" [ "reply" , "id:" <> unMessageID messageId ]) - { std_in = UseHandle devnull - , std_out = UseHandle draftH - } - hClose draftH - waitForProcess procH - code <- system (editor ++ " " ++ path) - return q { message = show code } - where - cleanup = removeFile . fst - - -replyToAll2 = do - editor <- getEnv "EDITOR" - logname <- getEnv "LOGNAME" - tmpdir <- getTemporaryDirectory - - let template = logname ++ "_much_draft_XXX.email" - - let msgId = "20141227121335.701B43F@mx2.informatik.uni-stuttgart.de" - - bracket (openTempFile tmpdir template) cleanup $ \(path, draftH) -> do - (_, _, _, procH) <- - withFile "/dev/null" ReadMode $ \devnull -> - createProcess - (proc "notmuch" [ "reply" , "id:" <> msgId ]) - { std_in = UseHandle devnull - , std_out = UseHandle draftH - } - hClose draftH - waitForProcess procH - code <- system (editor ++ " " ++ path) - print code - --return q { message = show code } - where - cleanup = removeFile . fst - - - --- (_, Just hout, _, ph) <- createProcess (proc "notmuch" args) --- { std_out = CreatePipe } --- output <- LBS.hGetContents hout --- --- --- withForkWait (evaluate $ rnf output) $ \waitOut -> do --- --- ---- now write any input --- --unless (null input) $ --- -- ignoreSigPipe $ hPutStr inh input --- -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE --- --ignoreSigPipe $ hClose inh --- --- -- wait on the output --- waitOut --- hClose hout --- --- -- wait on the process --- _ex <- waitForProcess ph --- --return (ex, output) --- --- --case ex of --- -- ExitSuccess -> return output --- -- ExitFailure r -> processFailedException "readProcess" cmd args r --- --- return output diff --git a/test4.hs b/test4.hs deleted file mode 100644 index d9a2e74..0000000 --- a/test4.hs +++ /dev/null @@ -1,352 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -import Control.Applicative -import Control.Exception -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 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 - , headBuffer :: [Trammel String] - , treeBuffer :: [Trammel String] - } - - -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" - 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 - , headBuffer = [] - , treeBuffer = [] - } - - -run :: State -> IO () -run q0 = do - let q = render q0 - - 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 } - - -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) - <> " " <> Plain flashMessage - ] - - - -redraw :: State -> IO () -redraw _q@State{..} = do - - let image = - map (fmap $ fmap $ sub '\t' ' ') $ - map (trammelTake screenWidth . trammelDrop xoffset) $ - take screenHeight $ - headBuffer ++ drop yoffset treeBuffer - screen = - image ++ take (screenHeight - length image) (repeat "~") - - case map (<>"\ESC[K") screen of - (first : rest) -> - putStr $ pp $ "\ESC[H" <> first <> mconcat (map ("\n"<>) rest) - _ -> - return () - where - sub x x' c = if c == x then x' else c - - - -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 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[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 ('\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 - - - -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' - - -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 -> - finally (system $ editor ++ " " ++ path) charge >>= \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 |