summaryrefslogtreecommitdiffstats
path: root/src/Much
diff options
context:
space:
mode:
Diffstat (limited to 'src/Much')
-rw-r--r--src/Much/API.hs6
-rw-r--r--src/Much/Action.hs24
-rw-r--r--src/Much/Config.hs8
-rw-r--r--src/Much/Core.hs46
-rw-r--r--src/Much/Event.hs3
-rw-r--r--src/Much/MBox.hs44
-rw-r--r--src/Much/MappedSets.hs12
-rw-r--r--src/Much/ParseMail.hs28
-rw-r--r--src/Much/RenderTreeView.hs93
-rw-r--r--src/Much/Screen.hs1
-rw-r--r--src/Much/State.hs25
-rw-r--r--src/Much/TagUtils.hs8
-rw-r--r--src/Much/TreeView.hs69
-rw-r--r--src/Much/TreeView/Types.hs6
-rw-r--r--src/Much/Utils.hs5
15 files changed, 196 insertions, 182 deletions
diff --git a/src/Much/API.hs b/src/Much/API.hs
index a9999ef..5ddf2c6 100644
--- a/src/Much/API.hs
+++ b/src/Much/API.hs
@@ -1,8 +1,4 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
module Much.API (module Much.API) where
@@ -11,6 +7,7 @@ import Control.Exception (catch, finally, throwIO)
import Control.Monad.IO.Class
import Data.Function ((&))
import Data.Proxy (Proxy)
+import Data.Tree.Zipper qualified as Z
import Much.API.Config as Much.API
import Much.Event
import Much.State
@@ -23,7 +20,6 @@ import Notmuch.Message
import Servant
import System.IO.Error (isDoesNotExistError)
import System.Posix.Files (removeLink)
-import qualified Data.Tree.Zipper as Z
type API =
diff --git a/src/Much/Action.hs b/src/Much/Action.hs
index d76e503..102bc2c 100644
--- a/src/Much/Action.hs
+++ b/src/Much/Action.hs
@@ -1,29 +1,31 @@
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+
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 Scanner
+import Data.Tree.Zipper qualified as Z
import Much.State
import Much.TagUtils
import Much.TreeSearch
import Much.TreeView
import Much.TreeZipperUtils
-import qualified Data.Tree.Zipper as Z
-import qualified Notmuch
-import qualified Notmuch.Message as Notmuch
-import qualified Notmuch.SearchResult as Notmuch
+import Notmuch qualified
+import Notmuch.Message qualified as Notmuch
+import Notmuch.SearchResult qualified as Notmuch
+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
@@ -35,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
@@ -162,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/Config.hs b/src/Much/Config.hs
index 36f06bf..1aa8f44 100644
--- a/src/Much/Config.hs
+++ b/src/Much/Config.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE DeriveGeneric #-}
module Much.Config where
-import GHC.Generics (Generic)
import Data.Aeson (FromJSON)
+import Data.Map qualified as M
+import Data.Text qualified as T
+import GHC.Generics (Generic)
import Much.State (ColorConfig)
-import qualified Data.Text as T
-import qualified Data.Map as M
+
data Config = Config
{ colorConfig :: Maybe (ColorConfig Maybe)
diff --git a/src/Much/Core.hs b/src/Much/Core.hs
index 1c8daa7..b7f833a 100644
--- a/src/Much/Core.hs
+++ b/src/Much/Core.hs
@@ -1,38 +1,42 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+
module Much.Core where
-import Blessings.String.WCWidth (Blessings(Plain,SGR),pp)
+import Blessings (Blessings(SGR),pp)
import Control.Concurrent
import Control.Monad
import Data.Aeson
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
import Much.Event
import Much.RenderTreeView (renderTreeView)
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(..))
+import System.Console.Terminal.Size qualified as Term
import System.Environment
import System.Exit
import System.IO
import System.Posix.Signals
-import qualified Blessings.Internal as Blessings
-import qualified Data.Map as M
-import qualified Data.Tree.Zipper as Z
-import qualified Much.Config as Config
-import qualified Notmuch
-import qualified System.Console.Terminal.Size as Term
+
importConfig :: Config.Config -> State -> State
importConfig config state = state
@@ -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/MBox.hs b/src/Much/MBox.hs
index 9299eea..5c7c0a6 100644
--- a/src/Much/MBox.hs
+++ b/src/Much/MBox.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+
module Much.MBox
(
-- TODO don't re-export MBox but use our own Message type
@@ -8,28 +9,27 @@ module Much.MBox
, toForest
) where
-import qualified Data.MBox as Export
-
-import Control.Applicative
-import qualified Data.CaseInsensitive as CI
-import qualified Data.List as List
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Maybe
-import Data.MBox
-import Data.Ord
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Text.Lazy (Text)
-import Data.Time
-import Data.Tree (Tree, Forest)
-import qualified Data.Tree as Tree
-import qualified MappedSets
-import qualified Data.Text.Lazy as Text
-import Safe
-import System.Locale
-import qualified Text.ParserCombinators.Parsec.Rfc2822 as P
-import qualified Text.ParserCombinators.Parsec as P
+import Control.Applicative
+import Data.CaseInsensitive qualified as CI
+import Data.List qualified as List
+import Data.MBox
+import Data.MBox qualified as Export
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Maybe
+import Data.Ord
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Data.Text.Lazy (Text)
+import Data.Text.Lazy qualified as Text
+import Data.Time
+import Data.Tree (Tree, Forest)
+import Data.Tree qualified as Tree
+import MappedSets qualified
+import Safe
+import System.Locale
+import Text.ParserCombinators.Parsec qualified as P
+import Text.ParserCombinators.Parsec.Rfc2822 qualified as P
type Ident = Text
diff --git a/src/Much/MappedSets.hs b/src/Much/MappedSets.hs
index ec0ae73..7db2279 100644
--- a/src/Much/MappedSets.hs
+++ b/src/Much/MappedSets.hs
@@ -1,11 +1,11 @@
module Much.MappedSets (invert, mk) where
-import Control.Arrow
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Maybe
-import Data.Set (Set)
-import qualified Data.Set as Set
+import Control.Arrow
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Maybe
+import Data.Set (Set)
+import Data.Set qualified as Set
mk :: (Ord a, Ord b) => [(a, [b])] -> Map a (Set b)
diff --git a/src/Much/ParseMail.hs b/src/Much/ParseMail.hs
index d9bb733..6644db6 100644
--- a/src/Much/ParseMail.hs
+++ b/src/Much/ParseMail.hs
@@ -1,26 +1,24 @@
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Much.ParseMail (readMail) where
-import qualified Data.Attoparsec.ByteString.Char8 as A8
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BS8
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.Lazy as LT
-import qualified Data.Text.Lazy.Encoding as LT
-import qualified Network.Email.Header.Parser as P
-import qualified Network.Email.Header.Types as H
-import qualified Network.Mail.Mime as M
import Codec.MIME.Parse
-import qualified Codec.MIME.QuotedPrintable as QP
+import Codec.MIME.QuotedPrintable qualified as QP
import Codec.MIME.Type
import Control.Applicative
+import Data.Attoparsec.ByteString.Char8 qualified as A8
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.CaseInsensitive qualified as CI
import Data.Char
-
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Data.Text.Lazy qualified as LT
+import Data.Text.Lazy.Encoding qualified as LT
+import Network.Email.Header.Parser qualified as P
+import Network.Email.Header.Types qualified as H
+import Network.Mail.Mime qualified as M
-- TODO eventually we want our completely own Address, i.e. w/o M.Address
diff --git a/src/Much/RenderTreeView.hs b/src/Much/RenderTreeView.hs
index ea81fe2..f1eaf6e 100644
--- a/src/Much/RenderTreeView.hs
+++ b/src/Much/RenderTreeView.hs
@@ -1,32 +1,33 @@
-{-# 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 Blessings.Extra (quoteSpecialsPlain, quoteSpecialsPlain')
import Control.Arrow
+import Data.CaseInsensitive qualified as CI
import Data.Char
-import Data.Function
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
+import Much.TreeZipperUtils qualified as Z
+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
@@ -54,7 +55,7 @@ humanTimeLocale = defaultHumanTimeLocale
renderTreeView
:: State
-> Z.TreePos Z.Full TreeView
- -> [Blessings String]
+ -> [Blessings WText]
renderTreeView q@State{..} =
renderNode
where
@@ -76,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
@@ -103,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) "│ "
@@ -113,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
@@ -132,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
@@ -152,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/Screen.hs b/src/Much/Screen.hs
index 47bb90c..9d75728 100644
--- a/src/Much/Screen.hs
+++ b/src/Much/Screen.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
+
module Much.Screen (Screen(..), setScreen, withScreen) where
import Control.Exception
diff --git a/src/Much/State.hs b/src/Much/State.hs
index a1de01f..30716a1 100644
--- a/src/Much/State.hs
+++ b/src/Much/State.hs
@@ -1,34 +1,35 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
+
module Much.State where
import Blessings
import Data.Aeson
+import Data.CaseInsensitive qualified as CI
import Data.Default
import Data.Functor.Identity
+import Data.Map qualified as M
+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))
+import Notmuch.Message qualified as Notmuch
import Scanner
import System.Posix.Signals
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Map as M
-import qualified Data.Text as T
-import qualified Data.Tree as Tree
-import qualified Data.Tree.Zipper as Z
-import qualified Much.API.Config
-import qualified Notmuch.Message as Notmuch
+
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/TagUtils.hs b/src/Much/TagUtils.hs
index d4e4d30..d6130e4 100644
--- a/src/Much/TagUtils.hs
+++ b/src/Much/TagUtils.hs
@@ -1,15 +1,13 @@
-{-# LANGUAGE LambdaCase #-}
-
module Much.TagUtils where
-import qualified Data.Set as Set
-import qualified Data.Text as T
import Data.Char
import Data.List.Split (wordsBy)
+import Data.Set qualified as Set
+import Data.Text qualified as T
import Data.Tree
+import Much.TreeView.Types
import Notmuch.Message
import Notmuch.SearchResult
-import Much.TreeView.Types
type Tag = T.Text
diff --git a/src/Much/TreeView.hs b/src/Much/TreeView.hs
index 9b309bc..b3d36e8 100644
--- a/src/Much/TreeView.hs
+++ b/src/Much/TreeView.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
-
module Much.TreeView
( module Export
, getMessage
@@ -17,14 +15,14 @@ module Much.TreeView
, hasUnloadedSubForest
) where
-
-import qualified Data.ByteString.Lazy.Char8 as LBS8
-import qualified Data.Text as T
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.CaseInsensitive qualified as CI
+import Data.Text qualified as T
import Data.Tree
+import Much.TreeView.Types as Export
import Notmuch
import Notmuch.Message
import Notmuch.SearchResult
-import Much.TreeView.Types as Export
import System.Exit (ExitCode(ExitSuccess))
import System.Process.ByteString.Lazy (readProcessWithExitCode)
@@ -74,7 +72,7 @@ fromMessageForest = map fromMessageTree
fromMessageTree :: Tree Message -> Tree TreeView
fromMessageTree (Node m ms) =
Node (TVMessage m)
- (xconvHead m <> xconvBody m <> map fromMessageTree ms)
+ (xconvHead m <> xconvBody m <> fromMessageForest ms)
xconvHead :: Message -> Forest TreeView
@@ -87,7 +85,8 @@ xconvHead m =
xconvBody :: Message -> Forest TreeView
-xconvBody m = map (xconvPart m) (messageBody m)
+xconvBody m =
+ [xconvPart m (messageBody m)]
xconvPart :: Message -> MessagePart -> Tree TreeView
@@ -134,16 +133,16 @@ isQuoteLine s0 = do
-- Loading / Unloading
--
-
loadSubForest :: TreeView -> IO (Either String (Forest TreeView))
loadSubForest = \case
TVMessage m ->
- Right
+ pure . Right =<<
+ loadPrimaryMessagePart m =<< id
. unloadPartsWithFilename
. map unloadReadSubForests
. concatMap subForest
. fromMessageForest
- . findFirsts messageMatch
+ . findTopmost messageMatch
<$> notmuchShow (termFromMessage m)
TVMessagePart m mp@MessagePart{partContentType="text/html"} ->
@@ -151,10 +150,8 @@ loadSubForest = \case
Left e -> return $ Left $ show e
Right html ->
readProcessWithExitCode
- "lynx"
- [ "-dump"
- , "-nomargins"
- , "-stdin"
+ "show"
+ [ T.unpack (CI.foldedCase (partContentType mp))
]
html
>>= \case
@@ -175,7 +172,13 @@ loadSubForest = \case
$ xconvPart m mp'
TVSearchResult sr ->
- Right
+ pure . Right =<<
+ mapM
+ (\case
+ Node tv@(TVMessage m) parts -> Node tv <$> loadPrimaryMessagePart m parts
+ node -> pure node
+ )
+ =<< id
. unloadPartsWithFilename
. map unloadReadSubForests
. fromMessageForest
@@ -196,6 +199,36 @@ loadSubForest = \case
termFromSearchResult = unThreadID . searchThread
+loadPrimaryMessagePart :: Message -> Forest TreeView -> IO (Forest TreeView)
+loadPrimaryMessagePart m parts =
+ mapM (rewriteTreeIO isPrimaryPart loadNode) parts
+ where
+ pid = partID (primaryMessagePart (messageBody m))
+ mid = messageId m
+
+ isPrimaryPart :: TreeView -> Bool
+ isPrimaryPart = \case
+ TVMessagePart m' mp ->
+ messageId m' == mid && partID mp == pid
+ _ -> False
+
+ loadNode :: Tree TreeView -> IO (Tree TreeView)
+ loadNode node@(Node tv _) =
+ loadSubForest tv >>= \case
+ Right subForest' -> pure (Node tv subForest')
+ Left _ -> pure node
+
+
+rewriteTreeIO :: (a -> Bool) -> (Tree a -> IO (Tree a)) -> Tree a -> IO (Tree a)
+rewriteTreeIO shouldRewrite f t@(Node v children)
+ | shouldRewrite v = do
+ Node v' children' <- f t
+ Node v' <$> mapM (rewriteTreeIO shouldRewrite f) children'
+
+ | otherwise = do
+ Node v <$> mapM (rewriteTreeIO shouldRewrite f) children
+
+
unloadSubForest :: Tree TreeView -> Forest TreeView
unloadSubForest t = case rootLabel t of
TVMessage _ ->
@@ -248,8 +281,8 @@ unloadPartsWithFilename =
in x' { subForest = map rewriteTree $ subForest x' }
-findFirsts :: (a -> Bool) -> Forest a -> Forest a
-findFirsts p =
+findTopmost :: (a -> Bool) -> Forest a -> Forest a
+findTopmost p =
concatMap rec
where
rec t@Node{..} =
diff --git a/src/Much/TreeView/Types.hs b/src/Much/TreeView/Types.hs
index f30b0bc..28ed302 100644
--- a/src/Much/TreeView/Types.hs
+++ b/src/Much/TreeView/Types.hs
@@ -1,9 +1,7 @@
-{-# LANGUAGE LambdaCase #-}
-
module Much.TreeView.Types where
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Text as T
+import Data.CaseInsensitive qualified as CI
+import Data.Text qualified as T
import Notmuch.Message
import Notmuch.SearchResult
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.3.1 (git 2.54.0) at 2026-07-21 21:56:50 +0000
[cgit] Unable to lock slot /tmp/cgit/e1100000.lock: No such file or directory (2)