show relative time

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)