summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--TreeViewRaw.hs152
-rw-r--r--default.nix10
-rw-r--r--env.nix4
-rw-r--r--much.cabal1
-rw-r--r--test5.hs14
5 files changed, 124 insertions, 57 deletions
diff --git a/TreeViewRaw.hs b/TreeViewRaw.hs
index db4a899..b10f3e6 100644
--- a/TreeViewRaw.hs
+++ b/TreeViewRaw.hs
@@ -9,72 +9,128 @@ 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.Char
import Data.Monoid
+import Data.Time
+import Data.Time.Format.Human
import Data.Tree
import Trammel
import TreeView
-import Utils (padl)
-renderTreeView :: TreeView -> Tree TreeView -> [Trammel String]
-renderTreeView cur _loc@(Node label children) =
- [ colorize $ renderTreeView1 hasFocus label ] ++
- concatMap (map (" "<>) . renderTreeView cur) children
+-- TODO make configurable
+humanTimeLocale :: HumanTimeLocale
+humanTimeLocale = defaultHumanTimeLocale
+ { justNow = "now"
+ , secondsAgo = (++ "s ago")
+ , oneMinuteAgo = "1m ago"
+ , minutesAgo = (++ "m ago")
+ , oneHourAgo = "1h ago"
+ , aboutHoursAgo = (++ "h ago")
+ , at = \_ -> ("" ++)
+ , daysAgo = (++ "d ago")
+ , weekAgo = (++ "w ago")
+ , weeksAgo = (++ "w ago")
+ , onYear = ("" ++)
+ , dayOfWeekFmt = "%a %H:%M"
+ , thisYearFmt = "%b %e"
+ , prevYearFmt = "%b %e, %Y"
+ }
+
+
+renderTreeView :: UTCTime -> TreeView -> Tree TreeView -> [Trammel String]
+renderTreeView now cur _loc@(Node label children) =
+ [ renderTreeView1 now hasFocus label ] ++
+ concatMap (map (" "<>) . renderTreeView now cur) children
where
hasFocus = cur == label
- colorize s =
- if hasFocus
- then SGR [31] s
- else s
-renderTreeView1 :: Bool -> TreeView -> Trammel String
-renderTreeView1 hasFocus = \case
+-- TODO locale-style: headerKey = \s -> SGR [..] (s <> ": ")
+
+searchSGR, focusSGR, boringSGR, dateSGR, tagsSGR, unreadMessageSGR,
+ unreadSearchSGR :: Trammel String -> Trammel String
+searchSGR = SGR [38,5,162]
+focusSGR = SGR [38,5,160]
+boringSGR = SGR [38,5,240]
+dateSGR = SGR [38,5,071]
+tagsSGR = SGR [38,5,036]
+
+unreadMessageSGR = SGR [38,5,117]
+unreadSearchSGR = SGR [38,5,250]
+
+
+renderTreeView1 :: UTCTime -> Bool -> TreeView -> Trammel String
+renderTreeView1 now hasFocus x = case x of
TVSearch s ->
- Plain s
+ let c = if hasFocus then focusSGR else searchSGR
+ in c $ Plain s
TVSearchResult sr ->
- let c = case (hasFocus, "unread" `elem` Notmuch.searchTags sr) of
- (False, False) -> SGR [38,5,240]
- (False, True) -> SGR [38,5,250]
- (True, False) -> SGR [38,5,088]
- (True, True) -> SGR [38,5,160]
- in c $
- Plain (
- (padl 11 ' ' $ T.unpack $ Notmuch.searchDateRel sr)
- ++ " (" ++ (show $ Notmuch.searchMatched sr) ++ ") "
- ++ (T.unpack $ Notmuch.searchSubject sr)
- ++ " "
- )
- <>
- mconcat (L.intersperse " " (map (SGR [38,5,036] . Plain . T.unpack) $ Notmuch.searchTags sr))
+ let c = if hasFocus then focusSGR else
+ if "unread" `elem` Notmuch.searchTags sr
+ then unreadSearchSGR
+ else boringSGR
+ date = dateSGR $ renderDate now x
+ tags = tagsSGR $ renderTags (Notmuch.searchTags sr)
+ subj = Plain $ T.unpack $ Notmuch.searchSubject sr
+ in c $ subj <> " " <> date <> " " <> tags
TVMessage m ->
- let c = case (hasFocus, "unread" `elem` Notmuch.messageTags m) of
- (False, False) -> SGR [38,5,240]
- (False, True) -> SGR [38,5,250]
- (True, False) -> SGR [38,5,088]
- (True, True) -> SGR [38,5,160]
- in c $
- Plain (
- (Notmuch.unMessageID $ Notmuch.messageId m)
- ++ " "
- ++ T.unpack (T.intercalate (T.pack ",") $ Notmuch.messageTags m)
- )
-
- TVMessageHeaderField m fieldName -> Plain $
- let k = T.unpack $ CI.original fieldName
+ let c = if hasFocus then focusSGR else
+ if "unread" `elem` Notmuch.messageTags m
+ then unreadMessageSGR
+ else boringSGR
+ from = renderFrom (M.lookup "from" $ Notmuch.messageHeaders m)
+ date = dateSGR $ renderDate now x
+ tags = tagsSGR $ renderTags (Notmuch.messageTags m) -- TODO filter common tags
+ in c $ from <> " " <> date <> " " <> tags
+
+ TVMessageHeaderField m fieldName ->
+ let c = if hasFocus then focusSGR else boringSGR
+ k = Plain $ T.unpack $ CI.original fieldName
v = maybe "nothing"
- T.unpack
+ (Plain . T.unpack)
(M.lookup fieldName $ Notmuch.messageHeaders m)
- in k ++ ": " ++ v
+ in c $ k <> ": " <> v
- TVMessagePart _ p -> Plain $
- "part#"
- ++ (show $ Notmuch.partID p)
- ++ " "
- ++ (T.unpack $ CI.original $ Notmuch.partContentType p)
+ TVMessagePart _ p ->
+ let c = if hasFocus then focusSGR else boringSGR
+ i = Plain $ show $ Notmuch.partID p
+ t = Plain $ T.unpack $ CI.original $ Notmuch.partContentType p
+ in c $ "part#" <> i <> " " <> t
TVMessageLine _ _ _ s ->
- Plain s
+ if hasFocus
+ then focusSGR $ Plain s
+ else Plain s
+
+
+
+renderDate :: UTCTime -> TreeView -> Trammel String
+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 $ humanReadableTimeI18N' timeLocale now time
+
+
+renderFrom :: Maybe T.Text -> Trammel String
+renderFrom = \case
+ Just fromLine -> Plain $ dropAddress $ T.unpack fromLine
+ Nothing -> SGR [35,1] "Anonymous"
+
+
+renderTags :: [T.Text] -> Trammel String
+renderTags ts =
+ Plain $ T.unpack $ T.intercalate " " ts
+
+
+dropAddress :: String -> String
+dropAddress xs =
+ case L.findIndices (=='<') xs of
+ [] -> xs
+ is -> L.dropWhileEnd isSpace $ take (last is) xs
diff --git a/default.nix b/default.nix
index 5901063..4b9bff1 100644
--- a/default.nix
+++ b/default.nix
@@ -2,4 +2,12 @@
, src ? ./.
, name ? "much"
}:
-pkgs.haskellPackages.buildLocalCabal src name
+let
+ inherit (pkgs.haskellPackages) buildLocalCabalWithArgs callPackage;
+in
+buildLocalCabalWithArgs {
+ inherit src name;
+ args = {
+ friendlyTime = callPackage ./nix/friendly-time {};
+ };
+}
diff --git a/env.nix b/env.nix
index 500bf3e..c4fafeb 100644
--- a/env.nix
+++ b/env.nix
@@ -28,6 +28,7 @@ let
caseInsensitive
#conduit
#conduitExtra
+ friendly-time
process
rosezipper
safe
@@ -37,8 +38,7 @@ let
hsPkgs = pkgs.haskellPackages_ghc783_profiling.override {
extension = self: super: with self; {
- #vty = callPackage ./nixpkgs/vty-5.2.5.nix { #{{{
- #}; #}}}
+ friendly-time = callPackage ./nix/friendly-time {};
};
};
diff --git a/much.cabal b/much.cabal
index 4e87d6f..71a3170 100644
--- a/much.cabal
+++ b/much.cabal
@@ -15,6 +15,7 @@ executable much
, containers >=0.5 && <0.6
, deepseq >=1.3 && <1.4
, directory >=1.2 && <1.3
+ , friendly-time >=0.3 && <0.4
, mtl >=2.1 && <2.2
, process >=1.2 && <1.3
, rosezipper >=0.2 && <0.3
diff --git a/test5.hs b/test5.hs
index a65b719..2b43942 100644
--- a/test5.hs
+++ b/test5.hs
@@ -17,6 +17,7 @@ import Control.Exception
import Control.Monad
import Data.Maybe
import Data.Monoid
+import Data.Time
import Scanner (getKey)
import System.Directory
import System.Environment
@@ -135,9 +136,10 @@ winchHandler putEvent =
run :: IO Event -> State -> IO ()
run getEvent = rec where
- rec q = rec =<<
- let q' = render q
- in redraw q' >> getEvent >>= processEvent q'
+ rec q = rec =<< do
+ now <- getCurrentTime
+ let q' = render now q
+ redraw q' >> getEvent >>= processEvent q'
processEvent :: State -> Event -> IO State
@@ -161,13 +163,13 @@ processEvent q = \case
}
-render :: State -> State
-render q@State{..} =
+render :: UTCTime -> State -> State
+render now q@State{..} =
q { treeBuffer = newTreeBuf
, headBuffer = newHeadBuf
}
where
- newTreeBuf = renderTreeView (Z.label cursor) (Z.toTree cursor)
+ newTreeBuf = renderTreeView now (Z.label cursor) (Z.toTree cursor)
newHeadBuf =
[ Plain (show screenWidth) <> "x" <> Plain (show screenHeight)
<> " " <> Plain (show $ linearPos cursor - yoffset)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 06:16:14 +0000