blob: d122ce52b6347a7a46380ed391d7433fb226aedb (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
import Data.Default
import Graphics.Vty
--import Data.List
--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 Notmuch
import Notmuch.Message
import Notmuch.SearchResult
--import Safe
import Control.Exception
import TreeView
import TreeSearch
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 =
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
Right r_ <- 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 - 1 }
EvKey (KChar 'L') [] -> rec q { xoffset = xoffset + 1 }
EvKey (KChar 'J') [] -> rec q { yoffset = yoffset - 1 }
EvKey (KChar 'K') [] -> rec q { yoffset = yoffset + 1 }
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 . (:[]) . fromMessageTree =<< 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 . (:[]) . fromMessageTree =<< 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)
|
