summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-12-28 22:16:47 +0100
committertv <tv@shackspace.de>2014-12-28 22:16:47 +0100
commitb1aa17616f56517fa83607296c25ee6c333968c1 (patch)
treeb9c2ed97dc1a7446b3009f5597cd7ca5183fea2f
parent1e2180c07b45a31de87439160fbe5dde64a24dab (diff)
purge a bit of legacy & cruft
There's still both around, though..^_^
-rw-r--r--TreeView.hs169
-rw-r--r--TreeViewRaw.hs150
-rw-r--r--Utils.hs7
-rw-r--r--test1.hs14
-rw-r--r--test3.hs323
-rw-r--r--test4.hs352
-rw-r--r--test5.hs4
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
diff --git a/Utils.hs b/Utils.hs
index 2ccf4f7..8d1f624 100644
--- a/Utils.hs
+++ b/Utils.hs
@@ -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" ReadM