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
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Much.RenderTreeView (renderTreeView) where
import Blessings
import Blessings.Extra (quoteSpecialsPlain, quoteSpecialsPlain')
import Control.Arrow
import Data.CaseInsensitive qualified as CI
import Data.Char
import Data.Functor.Identity
import Data.List qualified as L
import Data.Map qualified as M
import Data.Maybe
import Data.String (fromString)
import Data.Text qualified as T
import Data.Time
import Data.Time.Format.Human
import Data.Tree
import Data.Tree.Zipper qualified as Z
import Data.WText (WText(WText))
import Much.State
import Much.TagUtils (Tag)
import Much.TreeView
import Much.TreeZipperUtils qualified as Z
import Notmuch.Message qualified as Notmuch
import Notmuch.SearchResult qualified as Notmuch
color :: (ColorConfig Identity -> Identity Pm) -> ColorConfig Identity -> Blessings WText -> Blessings WText
color key config = SGR $ runIdentity $ key config
-- TODO make configurable
humanTimeLocale :: HumanTimeLocale
humanTimeLocale = defaultHumanTimeLocale
{ justNow = "now"
, secondsAgo = \f -> (++ "s" ++ dir f)
, oneMinuteAgo = \f -> "1m" ++ dir f
, minutesAgo = \f -> (++ "m" ++ dir f)
, oneHourAgo = \f -> "1h" ++ dir f
, aboutHoursAgo = \f -> (++ "h" ++ dir f)
, at = \_ -> ("" ++)
, daysAgo = \f -> (++ "d" ++ dir f)
, weekAgo = \f -> (++ "w" ++ dir f)
, weeksAgo = \f -> (++ "w" ++ dir f)
, onYear = ("" ++)
, dayOfWeekFmt = "%a %H:%M"
, thisYearFmt = "%b %e"
, prevYearFmt = "%b %e, %Y"
}
where dir True = " from now"
dir False = " ago"
renderTreeView
:: State
-> Z.TreePos Z.Full TreeView
-> [Blessings WText]
renderTreeView q@State{..} =
renderNode
where
isFocus = (Z.label cursor==) . Z.label
renderNode loc =
renderRootLabel loc :
maybeRenderSubForest (Z.firstChild loc)
renderRootLabel loc =
renderPrefix q loc <>
renderTreeView1 q (isFocus loc) (Z.label loc)
renderSubForest loc =
renderNode loc ++
maybeRenderSubForest (Z.next loc)
maybeRenderSubForest =
maybe mempty renderSubForest
renderPrefix :: State -> Z.TreePos Z.Full TreeView -> Blessings WText
renderPrefix state =
mconcat . reverse . zipWith (curry prefix) [(1 :: Int)..] . Z.path
where
prefix (i, (_lhs, x, rhs)) = case x of
TVSearch _ -> ""
TVSearchResult _ -> spacePrefix state
TVMessage _ ->
case i of
1 ->
if null rhs
then endPrefix state
else teePrefix state
_ ->
if null rhs
then spacePrefix state
else pipePrefix state
_ ->
if not $ any (isTVMessage . rootLabel) rhs
then spacePrefix state
else pipePrefix state
spacePrefix
, teePrefix
, pipePrefix
, endPrefix
:: State -> Blessings WText
spacePrefix q = color prefix (colorConfig q) " "
teePrefix q = color prefix (colorConfig q) "├╴"
pipePrefix q = color prefix (colorConfig q) "│ "
endPrefix q = color prefix (colorConfig q) "└╴"
-- TODO locale-style: headerKey = \s -> SGR [..] (s <> ": ")
renderTreeView1 :: State -> Bool -> TreeView -> Blessings WText
renderTreeView1 q@State{..} hasFocus x = case x of
TVSearch s ->
let c = if hasFocus then color focus colorConfig else color search colorConfig
in c $ fromString s
TVSearchResult sr ->
let c
| hasFocus = color focus colorConfig
| isUnread = color unreadSearch colorConfig
| otherwise = color boring colorConfig
c_authors
| hasFocus = color focus colorConfig
| isUnread = color alt colorConfig
| otherwise = color boring colorConfig
isUnread = "unread" `elem` Notmuch.searchTags sr
authors = Plain $ WText $ Notmuch.searchAuthors sr
date = color Much.State.date colorConfig $ renderDate now x
subject = quoteSpecialsPlain (WText $ Notmuch.searchSubject sr)
tags = color Much.State.tags colorConfig $ renderTags q (Notmuch.searchTags sr)
title = if subject /= "" then subject else c_authors authors
in
c $ title <> " " <> date <> " " <> tags
TVMessage m ->
let fromSGR
| hasFocus = color focus colorConfig
| "unread" `elem` Notmuch.messageTags m = color unreadMessage colorConfig
| otherwise = color boringMessage colorConfig
from = fromSGR $ renderFrom (M.lookup "from" $ Notmuch.messageHeaders m)
date = color Much.State.date colorConfig $ renderDate now x
tags = color Much.State.tags colorConfig $ renderTags q (Notmuch.messageTags m) -- TODO filter common tags
in from <> " " <> date <> " " <> tags
TVMessageHeaderField m fieldName ->
let c = if hasFocus then color focus colorConfig else color boring colorConfig
k = Plain $ WText $ CI.original fieldName
v = maybe "nothing"
(Plain . WText)
(M.lookup fieldName $ Notmuch.messageHeaders m)
in c $ k <> ": " <> v
TVMessagePart _ p ->
let c = if hasFocus then color focus colorConfig else color boring colorConfig
i = fromString $ show $ Notmuch.partID p
t = Plain $ WText $ CI.original $ Notmuch.partContentType p
filename = maybe "" (fromString . (" "<>) . show) $ Notmuch.partContentFilename p
charset = maybe "" (fromString . (" "<>) . show) $ Notmuch.partContentCharset p
size = fromString $ show $ Notmuch.contentSize (Notmuch.partContent p)
in c $ "part#" <> i <> " " <> t <> filename <> charset <> " " <> size
TVMessageQuoteLine _ _ _ s ->
if hasFocus
then color focus colorConfig $ fromString s
else color quote colorConfig $ fromString s
TVMessageRawLine _ _ _ s ->
quoteSpecialsPlain' printableColor unprintableColor (fromString s)
where
(printableColor, unprintableColor) =
if hasFocus
then (color focus colorConfig, color unprintableFocus colorConfig)
else (color quote colorConfig, color unprintableNormal colorConfig)
TVMessageLine _ _ _ s ->
if hasFocus
then color focus colorConfig $ fromString s
else fromString s
renderDate :: UTCTime -> TreeView -> Blessings WText
renderDate now = \case
TVSearchResult sr -> f humanTimeLocale (Notmuch.searchTime sr)
TVMessage m -> f humanTimeLocale (Notmuch.messageTime m)
_ -> SGR [35,1] "timeless"
where
f timeLocale time =
Plain $ fromString $ humanReadableTimeI18N' timeLocale now time
renderFrom :: Maybe T.Text -> Blessings WText
renderFrom = \case
Just fromLine ->
Plain $
case readFrom (T.unpack fromLine) of
("", address) -> fromString address
(name, _) -> fromString name
Nothing ->
SGR [35,1] "Anonymous"
renderTags :: State -> [Tag] -> Blessings WText
renderTags state =
-- TODO sort somewhere else
mconcat . L.intersperse " " . map (renderTag state) . L.sort
renderTag :: State -> Tag -> Blessings WText
renderTag state tag = case M.lookup tag $ runIdentity $ tagMap $ colorConfig state of
Just visual -> SGR (runIdentity visual) plain
Nothing -> plain
where
plain = Plain $ WText $ fromMaybe tag $ M.lookup tag (aliases state)
readFrom :: String -> (String, String)
readFrom xs =
case L.elemIndices '<' xs of
[] ->
("", xs)
is ->
readName *** readAddress $ splitAt (last is - 1) xs
where
readAddress :: String -> String
readAddress = L.takeWhile (/='>') . dropWhile (=='<')
readName :: String -> String
readName = L.dropWhileEnd isSpace
|
