summaryrefslogtreecommitdiffstats
path: root/test3.hs
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)