From fdeb641fde5f82c3ad617c5c801ab40955fe62af Mon Sep 17 00:00:00 2001 From: tv Date: Thu, 19 Mar 2026 22:09:58 +0100 Subject: blessings: 2 -> 3 --- src/Much/RenderTreeView.hs | 74 +++++++++++++++++++--------------------------- 1 file changed, 31 insertions(+), 43 deletions(-) (limited to 'src/Much/RenderTreeView.hs') diff --git a/src/Much/RenderTreeView.hs b/src/Much/RenderTreeView.hs index 21af597..f1eaf6e 100644 --- a/src/Much/RenderTreeView.hs +++ b/src/Much/RenderTreeView.hs @@ -4,7 +4,7 @@ module Much.RenderTreeView (renderTreeView) where import Blessings -import Blessings.String.Extra (quoteSpecials) +import Blessings.Extra (quoteSpecialsPlain, quoteSpecialsPlain') import Control.Arrow import Data.CaseInsensitive qualified as CI import Data.Char @@ -12,11 +12,13 @@ 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 @@ -25,7 +27,7 @@ import Notmuch.Message qualified as Notmuch import Notmuch.SearchResult qualified as Notmuch -color :: (ColorConfig Identity -> Identity Pm) -> ColorConfig Identity -> Blessings String -> Blessings String +color :: (ColorConfig Identity -> Identity Pm) -> ColorConfig Identity -> Blessings WText -> Blessings WText color key config = SGR $ runIdentity $ key config -- TODO make configurable @@ -53,7 +55,7 @@ humanTimeLocale = defaultHumanTimeLocale renderTreeView :: State -> Z.TreePos Z.Full TreeView - -> [Blessings String] + -> [Blessings WText] renderTreeView q@State{..} = renderNode where @@ -75,7 +77,7 @@ renderTreeView q@State{..} = maybe mempty renderSubForest -renderPrefix :: State -> Z.TreePos Z.Full TreeView -> Blessings String +renderPrefix :: State -> Z.TreePos Z.Full TreeView -> Blessings WText renderPrefix state = mconcat . reverse . zipWith (curry prefix) [(1 :: Int)..] . Z.path where @@ -102,7 +104,7 @@ spacePrefix , teePrefix , pipePrefix , endPrefix - :: State -> Blessings String + :: State -> Blessings WText spacePrefix q = color prefix (colorConfig q) " " teePrefix q = color prefix (colorConfig q) "├╴" pipePrefix q = color prefix (colorConfig q) "│ " @@ -112,12 +114,12 @@ endPrefix q = color prefix (colorConfig q) "└╴" -- TODO locale-style: headerKey = \s -> SGR [..] (s <> ": ") -renderTreeView1 :: State -> Bool -> TreeView -> Blessings String +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 $ Plain s + in c $ fromString s TVSearchResult sr -> let c @@ -131,9 +133,9 @@ renderTreeView1 q@State{..} hasFocus x = case x of isUnread = "unread" `elem` Notmuch.searchTags sr - authors = Plain $ T.unpack $ Notmuch.searchAuthors sr + authors = Plain $ WText $ Notmuch.searchAuthors sr date = color Much.State.date colorConfig $ renderDate now x - subject = quoteSpecials $ Plain $ T.unpack $ Notmuch.searchSubject sr + 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 @@ -151,88 +153,74 @@ renderTreeView1 q@State{..} hasFocus x = case x of TVMessageHeaderField m fieldName -> let c = if hasFocus then color focus colorConfig else color boring colorConfig - k = Plain $ T.unpack $ CI.original fieldName + k = Plain $ WText $ CI.original fieldName v = maybe "nothing" - (Plain . T.unpack) + (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 = 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) + 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 $ Plain s - else color quote colorConfig $ Plain s + then color focus colorConfig $ fromString s + else color quote colorConfig $ fromString s TVMessageRawLine _ _ _ s -> - mconcat . map (uncurry renderClassifiedString) $ classifiedGroupBy isPrint s + quoteSpecialsPlain' printableColor unprintableColor (fromString 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 + then color focus colorConfig $ fromString s + else fromString s -renderDate :: UTCTime -> TreeView -> Blessings String +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 $ humanReadableTimeI18N' timeLocale now time + Plain $ fromString $ humanReadableTimeI18N' timeLocale now time -renderFrom :: Maybe T.Text -> Blessings String +renderFrom :: Maybe T.Text -> Blessings WText renderFrom = \case Just fromLine -> Plain $ case readFrom (T.unpack fromLine) of - ("", address) -> address - (name, _) -> name + ("", address) -> fromString address + (name, _) -> fromString name Nothing -> SGR [35,1] "Anonymous" -renderTags :: State -> [Tag] -> Blessings String +renderTags :: State -> [Tag] -> Blessings WText renderTags state = -- TODO sort somewhere else mconcat . L.intersperse " " . map (renderTag state) . L.sort -renderTag :: State -> Tag -> Blessings String +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 $ T.unpack $ fromMaybe tag $ M.lookup tag (aliases state) + plain = Plain $ WText $ fromMaybe tag $ M.lookup tag (aliases state) readFrom :: String -> (String, String) -- cgit v1.2.3