From 170cbdae59cd8c56b69f8a2d890c7ef8ce5378d1 Mon Sep 17 00:00:00 2001 From: tv Date: Sat, 3 Jan 2015 13:17:38 +0100 Subject: TreeViewRaw -> RenderTreeView --- RenderTreeView.hs | 166 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ TreeViewRaw.hs | 166 ------------------------------------------------------ test5.hs | 2 +- 3 files changed, 167 insertions(+), 167 deletions(-) create mode 100644 RenderTreeView.hs delete mode 100644 TreeViewRaw.hs diff --git a/RenderTreeView.hs b/RenderTreeView.hs new file mode 100644 index 0000000..b08ff14 --- /dev/null +++ b/RenderTreeView.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module RenderTreeView (renderTreeView) where + +import qualified Notmuch.Message as Notmuch +import qualified Notmuch.SearchResult as Notmuch +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 TagUtils (Tag) +import Trammel +import TreeView + + +-- 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 + + +-- TODO locale-style: headerKey = \s -> SGR [..] (s <> ": ") + +searchSGR + , focusSGR + , quoteSGR + , boringSGR + , dateSGR + , tagsSGR + , unreadMessageSGR + , unreadSearchSGR + , killedTagSGR + , starTagSGR + :: Trammel String -> Trammel String +searchSGR = SGR [38,5,162] +focusSGR = SGR [38,5,160] +quoteSGR = SGR [38,5,242] +boringSGR = SGR [38,5,240] +dateSGR = SGR [38,5,071] +tagsSGR = SGR [38,5,036] +killedTagSGR = SGR [38,5,088] +starTagSGR = SGR [38,5,226] + +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 -> + let c = if hasFocus then focusSGR else searchSGR + in c $ Plain s + + TVSearchResult 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 = 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" + (Plain . T.unpack) + (M.lookup fieldName $ Notmuch.messageHeaders m) + in c $ k <> ": " <> v + + 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 + filename = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentFilename p + charset = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentCharset p + in c $ "part#" <> i <> " " <> t <> filename <> charset + + TVMessageQuoteLine _ _ _ s -> + if hasFocus + then focusSGR $ Plain s + else quoteSGR $ Plain s + + TVMessageLine _ _ _ 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 :: [Tag] -> Trammel String +renderTags = + -- TODO sort somewhere else + mconcat . L.intersperse " " . map renderTag . L.sort + + +renderTag :: Tag -> Trammel String +renderTag tag = case tag of + "killed" -> killedTagSGR plain + "star" -> starTagSGR plain + _ -> plain + where + plain = Plain $ T.unpack tag + + +dropAddress :: String -> String +dropAddress xs = + case L.findIndices (=='<') xs of + [] -> xs + is -> L.dropWhileEnd isSpace $ take (last is) xs diff --git a/TreeViewRaw.hs b/TreeViewRaw.hs deleted file mode 100644 index 0ec747b..0000000 --- a/TreeViewRaw.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module TreeViewRaw (renderTreeView) where - -import qualified Notmuch.Message as Notmuch -import qualified Notmuch.SearchResult as Notmuch -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 TagUtils (Tag) -import Trammel -import TreeView - - --- 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 - - --- TODO locale-style: headerKey = \s -> SGR [..] (s <> ": ") - -searchSGR - , focusSGR - , quoteSGR - , boringSGR - , dateSGR - , tagsSGR - , unreadMessageSGR - , unreadSearchSGR - , killedTagSGR - , starTagSGR - :: Trammel String -> Trammel String -searchSGR = SGR [38,5,162] -focusSGR = SGR [38,5,160] -quoteSGR = SGR [38,5,242] -boringSGR = SGR [38,5,240] -dateSGR = SGR [38,5,071] -tagsSGR = SGR [38,5,036] -killedTagSGR = SGR [38,5,088] -starTagSGR = SGR [38,5,226] - -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 -> - let c = if hasFocus then focusSGR else searchSGR - in c $ Plain s - - TVSearchResult 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 = 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" - (Plain . T.unpack) - (M.lookup fieldName $ Notmuch.messageHeaders m) - in c $ k <> ": " <> v - - 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 - filename = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentFilename p - charset = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentCharset p - in c $ "part#" <> i <> " " <> t <> filename <> charset - - TVMessageQuoteLine _ _ _ s -> - if hasFocus - then focusSGR $ Plain s - else quoteSGR $ Plain s - - TVMessageLine _ _ _ 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 :: [Tag] -> Trammel String -renderTags = - -- TODO sort somewhere else - mconcat . L.intersperse " " . map renderTag . L.sort - - -renderTag :: Tag -> Trammel String -renderTag tag = case tag of - "killed" -> killedTagSGR plain - "star" -> starTagSGR plain - _ -> plain - where - plain = Plain $ T.unpack tag - - -dropAddress :: String -> String -dropAddress xs = - case L.findIndices (=='<') xs of - [] -> xs - is -> L.dropWhileEnd isSpace $ take (last is) xs diff --git a/test5.hs b/test5.hs index 3d62872..4920219 100644 --- a/test5.hs +++ b/test5.hs @@ -21,6 +21,7 @@ import Data.Maybe import Data.Monoid import Data.Time import Event +import RenderTreeView (renderTreeView) import Scanner (scan) import System.Directory import System.Environment @@ -33,7 +34,6 @@ import TagUtils import Trammel import TreeSearch import TreeView -import TreeViewRaw import Utils -- cgit v1.2.3