summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--app/much.hs10
-rw-r--r--much.cabal7
-rw-r--r--src/Blessings/Extra.hs37
-rw-r--r--src/Blessings/String/Extra.hs40
-rw-r--r--src/Data/WText/Aeson.hs12
-rw-r--r--src/Much/Action.hs11
-rw-r--r--src/Much/Core.hs32
-rw-r--r--src/Much/Event.hs3
-rw-r--r--src/Much/RenderTreeView.hs74
-rw-r--r--src/Much/State.hs7
-rw-r--r--src/Much/Utils.hs5
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-20 19:51:43 +0000