{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Much.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 qualified Data.Tree.Zipper as Z import qualified Much.TreeZipperUtils as Z import Blessings import Blessings.String.Extra (quoteSpecials) import Control.Arrow import Data.Char import Data.Function import Data.Functor.Identity import Data.Maybe import Data.Time import Data.Time.Format.Human import Data.Tree import Much.State import Much.TagUtils (Tag) import Much.TreeView color :: (ColorConfig Identity -> Identity Pm) -> ColorConfig Identity -> Blessings String -> Blessings String 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 String] 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 String 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 String 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 String renderTreeView1 q@State{..} hasFocus x = case x of TVSearch s -> let c = if hasFocus then color focus colorConfig else color search colorConfig in c $ Plain 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 $ T.unpack $ Notmuch.searchAuthors sr date = color Much.State.date colorConfig $ renderDate now x subject = quoteSpecials $ Plain $ T.unpack $ 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 $ 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 color focus colorConfig else color boring colorConfig 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 size = Plain $ show $ Notmuch.contentSize (Notmuch.partContent p) in c $ "part#" <> i <> " " <> t <> filename <> charset <> " " <> size TVMessageQuoteLine _ _ _ s -> if hasFocus then color focus colorConfig $ Plain s else color quote colorConfig $ Plain s TVMessageRawLine _ _ _ s -> mconcat . map (uncurry renderClassifiedString) $ classifiedGroupBy isPrint s where renderClassifiedString :: Bool -> String -> Blessings String renderClassifiedString = \case True -> printableColor . Plain False -> unprintableColor . Plain . showLitChar' (printableColor, unprintableColor) = if hasFocus then (color focus colorConfig, color unprintableFocus colorConfig) else (color quote colorConfig, color unprintableNormal colorConfig) showLitChar' :: String -> String showLitChar' = (>>= f) where f '\ESC' = "^[" f c = showLitChar c "" classifiedGroupBy :: Eq b => (a -> b) -> [a] -> [(b, [a])] classifiedGroupBy f = map (f . head &&& id) . L.groupBy ((==) `on` f) TVMessageLine _ _ _ s -> if hasFocus then color focus colorConfig $ Plain s else Plain s renderDate :: UTCTime -> TreeView -> Blessings 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 -> Blessings String renderFrom = \case Just fromLine -> Plain $ case readFrom (T.unpack fromLine) of ("", address) -> address (name, _) -> name Nothing -> SGR [35,1] "Anonymous" renderTags :: State -> [Tag] -> Blessings String renderTags state = -- TODO sort somewhere else mconcat . L.intersperse " " . map (renderTag state) . L.sort renderTag :: State -> Tag -> Blessings String renderTag state tag = case M.lookup tag $ runIdentity $ tagMap $ colorConfig state of Just visual -> SGR (runIdentity visual) plain Nothing -> plain where plain = Plain $ T.unpack $ 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