blessings: 2 -> 3

11 files changed, 120 insertions, 118 deletions

diff --git a/app/much.hs b/app/much.hs
index 87d73c0..aba074c 100644
--- a/app/much.hs
+++ b/app/much.hs
@@ -3,9 +3,9 @@
 
 module Main (main) where
 
-import Blessings.String.WCWidth
 import Data.Default
 import Data.Maybe
+import Data.String (fromString)
 import Data.Tree qualified as Tree
 import Data.Tree.Zipper qualified as Z
 import Much.API qualified
@@ -99,12 +99,12 @@ myKeymap "=" = \q@State{..} ->
 
 -- <F1>
 myKeymap "\ESC[11~" = \q@State{..} ->
-    return q { flashMessage = Plain $ show $ treeViewId $ Z.label cursor }
+    return q { flashMessage = fromString $ show $ treeViewId $ Z.label cursor }
 
 -- <F2>
 myKeymap "\ESC[12~" = \q@State{..} ->
     return q { flashMessage =
-                  Plain $
+                  fromString $
                   show $
                   maybe Nothing (Just . Notmuch.messageFilename) $
                   getMessage $
@@ -112,8 +112,8 @@ myKeymap "\ESC[12~" = \q@State{..} ->
               }
 
 -- TODO Stuff Vim sends after exit (also there is more...)
-myKeymap "\ESC[2;2R" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
-myKeymap "\ESC[>85;95;0c" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
+myKeymap "\ESC[2;2R" = \q -> return q { flashMessage = flashMessage q <> " " <> "stupid" }
+myKeymap "\ESC[>85;95;0c" = \q -> return q { flashMessage = flashMessage q <> " " <> "stupid" }
 
 myKeymap s = displayKey s
 
diff --git a/much.cabal b/much.cabal
index 53b5da3..a600617 100644
--- a/much.cabal
+++ b/much.cabal
@@ -8,7 +8,9 @@ build-type:     Simple
 
 common common-stuff
   build-depends:
-    blessings >= 2.5.0
+      blessings >= 3.0.0
+    , mono-traversable
+    , text-wcwidth
 
 executable much
   import:           common-stuff
@@ -59,7 +61,7 @@ library
                  , Notmuch.Class
                  , Notmuch.Message
                  , Notmuch.SearchResult
-  other-modules:   Blessings.String.Extra
+  other-modules:   Blessings.Extra
                  , Codec.MIME.Base64
                  , Codec.MIME.Decode
                  , Codec.MIME.Parse
@@ -67,6 +69,7 @@ library
                  , Codec.MIME.Type
                  , Data.Aeson.Extends
                  , Data.Tree.Extra
+                 , Data.WText.Aeson
   build-depends:   base
                  , aeson
                  , attoparsec
diff --git a/src/Blessings/Extra.hs b/src/Blessings/Extra.hs
new file mode 100644
index 0000000..caa8e2d
--- /dev/null
+++ b/src/Blessings/Extra.hs
@@ -0,0 +1,37 @@
+module Blessings.Extra where
+
+import Blessings
+import Data.Char (isPrint,showLitChar)
+import Data.MonoTraversable (Element, oall, ofoldMap)
+import Data.Sequences (singleton)
+import Data.String (fromString)
+
+quoteSpecials :: (Blessable a, Element a ~ Char) => Blessings a -> Blessings a
+quoteSpecials = cataBlessings quoteSpecialsPlain SGR Append
+
+quoteSpecialsPlain :: (Blessable a, Element a ~ Char) => a -> Blessings a
+quoteSpecialsPlain =
+    quoteSpecialsPlain' id (SGR [35])
+
+quoteSpecialsPlain'
+    :: forall a. (Blessable a, Element a ~ Char)
+    => (Blessings a -> Blessings a)
+    -> (Blessings a -> Blessings a)
+    -> a
+    -> Blessings a
+quoteSpecialsPlain' printable unprintable s =
+    if oall isPrint s
+      then printable (Plain s)
+      else normalize (ofoldMap quoteSpecialChar s)
+  where
+
+    quoteSpecialChar :: (Blessable a, Element a ~ Char) => Char -> Blessings a
+    quoteSpecialChar c =
+        if isPrint c
+          then printable (Plain (singleton c))
+          else unprintable (Plain (fromString (showLitChar' c)))
+
+    showLitChar' :: Char -> String
+    showLitChar' = \case
+        '\ESC' -> "^["
+        c -> showLitChar c ""
diff --git a/src/Blessings/String/Extra.hs b/src/Blessings/String/Extra.hs
deleted file mode 100644
index 74c4ef0..0000000
--- a/src/Blessings/String/Extra.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-module Blessings.String.Extra where
-
-import Blessings
-import Control.Arrow ((&&&))
-import Data.Char (isPrint,showLitChar)
-import Data.Function (on)
-import Data.List (groupBy)
-
-
-quoteSpecials :: Blessings String -> Blessings String
-quoteSpecials = \case
-  Plain s -> quoteSpecials' s
-  SGR pm x -> SGR pm (quoteSpecials x)
-  Append a b -> Append (quoteSpecials a) (quoteSpecials b)
-  Empty -> Empty
-
-
-quoteSpecials' :: String -> Blessings String
-quoteSpecials' 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) =
-        (id, SGR [35])
-        --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) . groupBy ((==) `on` f)
diff --git a/src/Data/WText/Aeson.hs b/src/Data/WText/Aeson.hs
new file mode 100644
index 0000000..06aa4fb
--- /dev/null
+++ b/src/Data/WText/Aeson.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DerivingVia #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.WText.Aeson where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Text (Text)
+import Data.WText (WText(WText))
+
+
+deriving via Text instance FromJSON WText
+deriving via Text instance ToJSON WText
diff --git a/src/Much/Action.hs b/src/Much/Action.hs
index e798357..102bc2c 100644
--- a/src/Much/Action.hs
+++ b/src/Much/Action.hs
@@ -3,8 +3,9 @@
 
 module Much.Action where
 
-import Blessings.String.WCWidth
+import Blessings (Blessings(SGR))
 import Data.Maybe
+import Data.String (fromString)
 import Data.Tree.Extra (setSubForest)
 import Data.Tree.Zipper qualified as Z
 import Much.State
@@ -19,12 +20,12 @@ import Scanner
 
 
 displayKey :: String -> State -> IO State
-displayKey s q = return q { flashMessage = Plain $ show s }
+displayKey s q = return q { flashMessage = fromString (show s) }
 
 
 displayMouse :: Scan -> State -> IO State
 displayMouse info q =
-    return q { flashMessage = SGR [38,5,202] $ Plain $ show info }
+    return q { flashMessage = SGR [38,5,202] $ fromString (show info) }
 
 defaultMouse1Click :: Monad m => Int -> State -> m State
 defaultMouse1Click y q@State{..} = do
@@ -36,7 +37,7 @@ defaultMouse1Click y q@State{..} = do
     case linearClickPos of
         Nothing ->
             return q
-                { flashMessage = Plain "nothing to click"
+                { flashMessage = "nothing to click"
                 }
         Just i ->
             return q
@@ -163,7 +164,7 @@ openFold q@State{..} =
   where
     handle = \case
         Left err ->
-            q { flashMessage = SGR [31] $ Plain err }
+            q { flashMessage = SGR [31] $ fromString err }
         Right sf ->
             q { cursor = Z.modifyTree (setSubForest sf) cursor }
 
diff --git a/src/Much/Core.hs b/src/Much/Core.hs
index 996d31b..b7f833a 100644
--- a/src/Much/Core.hs
+++ b/src/Much/Core.hs
@@ -3,8 +3,7 @@
 
 module Much.Core where
 
-import Blessings.Internal qualified as Blessings
-import Blessings.String.WCWidth (Blessings(Plain,SGR),pp)
+import Blessings (Blessings(SGR),pp)
 import Control.Concurrent
 import Control.Monad
 import Data.Aeson
@@ -12,8 +11,14 @@ import Data.Functor
 import Data.Functor.Identity
 import Data.Map qualified as M
 import Data.Maybe
+import Data.MonoTraversable (ointercalate)
+import Data.Sequences qualified as S
+import Data.String (fromString)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
 import Data.Time
 import Data.Tree.Zipper qualified as Z
+import Data.WText (WText(unWText))
 import Much.API
 import Much.Action
 import Much.Config qualified as Config
@@ -23,7 +28,6 @@ import Much.Screen
 import Much.State
 import Much.TreeSearch
 import Much.TreeView
-import Much.Utils
 import Notmuch qualified
 import Options.Applicative
 import Scanner (scan,Scan(..))
@@ -180,13 +184,13 @@ processEvent q = \case
     EResize w h ->
         return $ Right q
             { screenWidth = w, screenHeight = h
-            , flashMessage = Plain $ "resize " <> show (w,h)
+            , flashMessage = fromString $ "resize " <> show (w,h)
             }
     EStateGet f ->
         forkIO (f q) $> Right q
     ev ->
         return $ Right q
-            { flashMessage = SGR [31,1] $ Plain $ "unhandled event: " <> show ev
+            { flashMessage = SGR [31,1] $ fromString $ "unhandled event: " <> show ev
             }
 
 
@@ -198,18 +202,18 @@ render q@State{..} =
   where
     newTreeBuf = renderTreeView q (Z.root cursor)
     newHeadBuf =
-        [ Plain (show screenWidth) <> "x" <> Plain (show screenHeight)
-          <> " " <> Plain (show $ linearPos cursor - yoffset)
-          <> " " <> Plain (show $ topOverrun q)
-          <> " " <> Plain (show $ botOverrun q)
+        [ fromString (show screenWidth) <> "x" <> fromString (show screenHeight)
+          <> " " <> fromString (show $ linearPos cursor - yoffset)
+          <> " " <> fromString (show $ topOverrun q)
+          <> " " <> fromString (show $ botOverrun q)
           <> " " <> flashMessage
-          <> " " <> Plain (show (xoffset, yoffset))
+          <> " " <> fromString (show (xoffset, yoffset))
         ]
 
-render0 :: State -> [Blessings String]
+render0 :: State -> [Blessings WText]
 render0 _q@State{..} = do
     let buffer =
-            map (Blessings.take screenWidth . Blessings.drop xoffset) $
+            map (S.take screenWidth . S.drop xoffset) $
             take screenHeight $
             headBuffer ++ drop yoffset treeBuffer
     buffer ++ replicate (screenHeight - length buffer) "~"
@@ -217,11 +221,11 @@ render0 _q@State{..} = do
 
 redraw :: State -> IO ()
 redraw q@State{..} = do
-    hPutStr stdout $ map (sub '\t' ' ') $ "\ESC[H" ++ pp (mintercalate "\n" $ map eraseRight $ render0 q)
+    T.hPutStr stdout $ T.map (sub '\t' ' ') $ unWText $ "\ESC[H" <> pp (ointercalate "\n" $ map eraseRight $ render0 q)
     hFlush stdout
   where
     sub x x' c = if c == x then x' else c
     eraseRight s =
-        if Blessings.length s < screenWidth
+        if S.lengthIndex s < screenWidth
             then s <> "\ESC[K"
             else s
diff --git a/src/Much/Event.hs b/src/Much/Event.hs
index 5edb5d2..76b3a05 100644
--- a/src/Much/Event.hs
+++ b/src/Much/Event.hs
@@ -1,11 +1,12 @@
 module Much.Event where
 
 import Blessings
+import Data.WText (WText)
 import Much.State
 import Scanner
 
 data Event =
-    EFlash (Blessings String) |
+    EFlash (Blessings WText) |
     EScan Scan |
     EShutdown |
     EReload |
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)
diff --git a/src/Much/State.hs b/src/Much/State.hs
index c42460e..30716a1 100644
--- a/src/Much/State.hs
+++ b/src/Much/State.hs
@@ -12,6 +12,7 @@ import Data.Text qualified as T
 import Data.Time
 import Data.Tree qualified as Tree
 import Data.Tree.Zipper qualified as Z
+import Data.WText (WText)
 import GHC.Generics
 import Much.API.Config qualified
 import Much.TreeView (TreeView(TVSearch))
@@ -24,11 +25,11 @@ data State = State
     { cursor :: Z.TreePos Z.Full TreeView
     , xoffset :: Int
     , yoffset :: Int
-    , flashMessage :: Blessings String
+    , flashMessage :: Blessings WText
     , screenWidth :: Int
     , screenHeight :: Int
-    , headBuffer :: [Blessings String]
-    , treeBuffer :: [Blessings String]
+    , headBuffer :: [Blessings WText]
+    , treeBuffer :: [Blessings WText]
     , now :: UTCTime
     , signalHandlers :: [(Signal, IO ())]
     , query :: String
diff --git a/src/Much/Utils.hs b/src/Much/Utils.hs
index 80615fc..df23c82 100644
--- a/src/Much/Utils.hs
+++ b/src/Much/Utils.hs
@@ -10,11 +10,6 @@ withTempFile tmpdir template =
     bracket (openTempFile tmpdir template) (removeFile . fst)
 
 
-mintercalate :: Monoid b => b -> [b] -> b
-mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t
-mintercalate _ [] = mempty
-
-
 padl :: Int -> a -> [a] -> [a]
 padl n c s =
     if length s < n