From 8e92e6e11d2b3b0bfb5ac9d68f347219493e6380 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Wed, 23 Sep 2020 17:44:40 +0200 Subject: split into library + executables --- src/Much/Action.hs | 200 ++++++++++++++++++++++++++++ src/Much/Core.hs | 216 ++++++++++++++++++++++++++++++ src/Much/Event.hs | 12 ++ src/Much/MBox.hs | 156 ++++++++++++++++++++++ src/Much/MappedSets.hs | 28 ++++ src/Much/ParseMail.hs | 312 ++++++++++++++++++++++++++++++++++++++++++++ src/Much/RenderTreeView.hs | 210 +++++++++++++++++++++++++++++ src/Much/Screen.hs | 32 +++++ src/Much/State.hs | 42 ++++++ src/Much/TagUtils.hs | 62 +++++++++ src/Much/TreeSearch.hs | 87 ++++++++++++ src/Much/TreeView.hs | 229 ++++++++++++++++++++++++++++++++ src/Much/TreeView/Types.hs | 63 +++++++++ src/Much/TreeZipperUtils.hs | 52 ++++++++ src/Much/Utils.hs | 28 ++++ 15 files changed, 1729 insertions(+) create mode 100644 src/Much/Action.hs create mode 100644 src/Much/Core.hs create mode 100644 src/Much/Event.hs create mode 100644 src/Much/MBox.hs create mode 100644 src/Much/MappedSets.hs create mode 100644 src/Much/ParseMail.hs create mode 100644 src/Much/RenderTreeView.hs create mode 100644 src/Much/Screen.hs create mode 100644 src/Much/State.hs create mode 100644 src/Much/TagUtils.hs create mode 100644 src/Much/TreeSearch.hs create mode 100644 src/Much/TreeView.hs create mode 100644 src/Much/TreeView/Types.hs create mode 100644 src/Much/TreeZipperUtils.hs create mode 100644 src/Much/Utils.hs (limited to 'src/Much') diff --git a/src/Much/Action.hs b/src/Much/Action.hs new file mode 100644 index 0000000..5872964 --- /dev/null +++ b/src/Much/Action.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Much.Action where + +import Blessings.String +import Scanner +import Much.State +import Much.TagUtils +import Much.TreeSearch +import Much.TreeView +import Much.TreeZipperUtils +import qualified Data.Tree as Tree +import qualified Data.Tree.Zipper as Z +import qualified Notmuch +import qualified Notmuch.Message as Notmuch +import qualified Notmuch.SearchResult as Notmuch + +displayKey :: String -> State -> IO State +displayKey s q = return q { flashMessage = Plain $ show s } + + +displayMouse :: Scan -> State -> IO State +displayMouse info q = + return q { flashMessage = SGR [38,5,202] $ Plain $ show info } + +defaultMouse1Click :: Monad m => Int -> State -> m State +defaultMouse1Click y q@State{..} = do + let linearClickPos = + let i = (y - length headBuffer + yoffset) - 1 {-zero-based-} + in if 0 <= i && i < length treeBuffer + then Just i + else Nothing + case linearClickPos of + Nothing -> + return q + { flashMessage = Plain "nothing to click" + } + Just i -> + return q + { cursor = findNextN i $ Z.root cursor + } + + +moveCursorDown :: Monad m => Int -> State -> m State +moveCursorDown n q@State{..} = + let cursor' = findNextN n cursor + q' = q { cursor = cursor' } + in case botOverrun q' of + 0 -> return q' + i -> moveTreeUp i q' + + +moveCursorUp :: Monad m => Int -> State -> m State +moveCursorUp n q@State{..} = + let cursor' = findPrevN n cursor + q' = q { cursor = cursor' } + in case topOverrun q' of + 0 -> return q' + i -> moveTreeDown i q' + + +moveTreeUp :: Monad m => Int -> State -> m State +moveTreeUp n q@State{..} = + let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset + n) } + in case topOverrun q' of + 0 -> return q' + i -> moveCursorDown i q' + + +moveTreeDown :: Monad m => Int -> State -> m State +moveTreeDown n q@State{..} = + let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset - n) } + in case botOverrun q' of + 0 -> return q' + i -> moveCursorUp i q' + + +moveTreeLeft :: Monad m => Int -> State -> m State +moveTreeLeft n q@State{..} = + return q { xoffset = xoffset + n } + +moveTreeRight :: Monad m => Int -> State -> m State +moveTreeRight n q@State{..} = + return q { xoffset = max 0 (xoffset - n) } + + +moveToParent :: Monad m => State -> m State +moveToParent q@State{..} = + case Z.parent cursor of + Nothing -> return q { flashMessage = "cannot go further up" } + Just cursor' -> + let q' = q { cursor = cursor' } + in case topOverrun q' of + 0 -> return q' + i -> moveTreeDown i q' + + +moveCursorToUnread + :: (Num a, Monad m, Eq a) + => (Z.TreePos Z.Full TreeView -> Maybe (Z.TreePos Z.Full TreeView)) + -> (State -> a) + -> (a -> State -> m State) + -> State -> m State +moveCursorToUnread cursorMove getTreeMoveCount treeMove q@State{..} = + case cursorMove cursor >>= rec of + Just cursor' -> + let q' = q { cursor = cursor' } + in case getTreeMoveCount q' of + 0 -> return q' + i -> treeMove i q' + Nothing -> + return q { flashMessage = "no unread message in sight" } + where + rec loc = + if hasTag "unread" loc + then Just loc + else cursorMove loc >>= rec + hasTag tag loc = + case Z.label loc of + TVSearchResult sr -> + tag `elem` Notmuch.searchTags sr + TVMessage m -> + tag `elem` Notmuch.messageTags m + _ -> + False + +moveCursorUpToPrevUnread :: Monad m => State -> m State +moveCursorUpToPrevUnread = + moveCursorToUnread findPrev topOverrun moveTreeDown + +moveCursorDownToNextUnread :: Monad m => State -> m State +moveCursorDownToNextUnread = + moveCursorToUnread findNext botOverrun moveTreeUp + + +openFold :: State -> IO State +openFold q@State{..} = + handle <$> loadSubForest (Z.label cursor) + where + handle = \case + Left err -> + q { flashMessage = SGR [31] $ Plain err } + Right sf -> + q { cursor = Z.modifyTree (setSubForest sf) cursor } + +closeFold :: State -> IO State +closeFold q@State{..} = + let sf = unloadSubForest (Z.tree cursor) + in return q { cursor = Z.modifyTree (setSubForest sf) cursor } + +toggleFold :: State -> IO State +toggleFold q@State{..} = + if hasUnloadedSubForest (Z.tree cursor) + then openFold q + else closeFold q + + +toggleTagAtCursor :: Tag -> State -> IO State +toggleTagAtCursor tag q@State{..} = case Z.label cursor of + + TVSearchResult sr -> do + let tagOp = + if tag `elem` Notmuch.searchTags sr + then DelTag + else AddTag + tagOps = [tagOp tag] + Notmuch.notmuchTag tagOps sr + let cursor' = Z.modifyTree (patchTreeTags tagOps) cursor + return q { cursor = cursor' } + + TVMessage m -> do + let tagOp = + if tag `elem` Notmuch.messageTags m + then DelTag + else AddTag + tagOps = [tagOp tag] + Notmuch.notmuchTag tagOps m + let cursor' = + -- TODO this needs a nice name + modifyFirstParentLabelWhere isTVSearchResult f $ + Z.modifyLabel f cursor + f = patchTags tagOps + return q { cursor = cursor' } + + _ -> return q { flashMessage = "nothing happened" } + + +topOverrun :: State -> Int +topOverrun State{..} = + max 0 (- (linearPos cursor - yoffset)) + + +botOverrun :: State -> Int +botOverrun State{..} = + max 0 (linearPos cursor - yoffset - (screenHeight - length headBuffer - 1)) + + +setSubForest :: Tree.Forest a -> Tree.Tree a -> Tree.Tree a +setSubForest sf t = t { Tree.subForest = sf } diff --git a/src/Much/Core.hs b/src/Much/Core.hs new file mode 100644 index 0000000..353f248 --- /dev/null +++ b/src/Much/Core.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Much.Core where + +import Much.Action +import Blessings.String (Blessings(Plain,SGR),pp) +import Control.Concurrent +import Control.Monad +import Data.Time +import Much.Event +import Much.RenderTreeView (renderTreeView) +import Scanner (scan,Scan(..)) +import Much.Screen +import Much.State +import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption) +import System.Environment +import System.IO +import System.Posix.Signals +import Much.TreeSearch +import Much.TreeView +import Much.Utils +import qualified Blessings.Internal as Blessings +import qualified Data.Tree as Tree +import qualified Data.Tree.Zipper as Z +import qualified Notmuch +import qualified System.Console.Terminal.Size as Term + + + +emptyState :: State +emptyState = State + { cursor = Z.fromTree (Tree.Node (TVSearch "") []) + , xoffset = 0 + , yoffset = 0 + , flashMessage = "Welcome to much; quit with ^C" + , screenWidth = 0 + , screenHeight = 0 + , headBuffer = [] + , treeBuffer = [] + , now = UTCTime (fromGregorian 1984 5 23) 49062 + , signalHandlers = [] + , query = "tag:inbox AND NOT tag:killed" + , keymap = displayKey + , mousemap = displayMouse + , colorConfig = ColorConfig + { tagMap = + [ ("killed", SGR [38,5,088]) + , ("star", SGR [38,5,226]) + , ("draft", SGR [38,5,202]) + ] + , alt = SGR [38,5,182] + , search = SGR [38,5,162] + , focus = SGR [38,5,160] + , quote = SGR [38,5,242] + , boring = SGR [38,5,240] + , prefix = SGR [38,5,235] + , date = SGR [38,5,071] + , tags = SGR [38,5,036] + , boringMessage = SGR [38,5,023] + , unreadMessage = SGR [38,5,117] + , unreadSearch = SGR [38,5,250] + } + , tagSymbols = [] + } + +notmuchSearch :: State -> IO State +notmuchSearch q@State{query} = do + r_ <- either error id <$> Notmuch.search + [ "--offset=0" + , "--limit=100" + , query + ] + + return q { cursor = Z.fromTree $ fromSearchResults query r_ } + +mainWithState :: State -> IO () +mainWithState state = mainWithStateAndArgs state =<< getArgs + +mainWithStateAndArgs :: State -> [String] -> IO () +mainWithStateAndArgs state@State{query = defaultSearch} args = do + usage' <- parseUsageOrExit usage + args' <- parseArgsOrExit usage' args + let query = getArgWithDefault args' defaultSearch (shortOption 'q') + withScreen s0 (\_-> notmuchSearch state { query = query } >>= runState) + where + usage = unlines + [ "Command-line MUA using notmuch." + , "" + , "Usage:" + , " much [-q ]" + , "" + , "Options:" + , " -q , --query=" + , " Open specific search, defaults to " ++ show defaultSearch + ] + + s0 = Screen False NoBuffering (BlockBuffering $ Just 4096) + [ 1000 -- X & Y on button press and release + , 1005 -- UTF-8 mouse mode + , 1047 -- use alternate screen buffer + ] + [ 25 -- hide cursor + ] + +runState :: State -> IO () +runState q0 = do + + -- load-env hack + maybe (return ()) (setEnv "HOME") =<< lookupEnv "OLDHOME" + + (putEvent, getEvent) <- do + v <- newEmptyMVar + return (putMVar v, takeMVar v) + + let q1 = q0 { signalHandlers = + [ (sigINT, putEvent EShutdown) + , (28, winchHandler putEvent) + ] } + + installHandlers (signalHandlers q1) + + threadIds <- mapM forkIO + [ forever $ scan stdin >>= putEvent . EScan + ] + + winchHandler putEvent + + run getEvent q1 + mapM_ killThread threadIds + + +installHandlers :: [(Signal, IO ())] -> IO () +installHandlers = + mapM_ (\(s, h) -> installHandler s (Catch h) Nothing) + +uninstallHandlers :: [(Signal, IO ())] -> IO () +uninstallHandlers = + mapM_ (\(s, _) -> installHandler s Ignore Nothing) + + +winchHandler :: (Event -> IO ()) -> IO () +winchHandler putEvent = + Term.size >>= \case + Just Term.Window {Term.width = w, Term.height = h} -> + putEvent $ EResize w h + Nothing -> + return () + +run :: IO Event -> State -> IO () +run getEvent = rec . Right where + rec = \case + Right q -> rec =<< do + t <- getCurrentTime + let q' = render q { now = t } + redraw q' >> getEvent >>= processEvent q' + Left _q -> return () + + +processEvent :: State -> Event -> IO (Either State State) +processEvent q = \case + EFlash t -> + return $ Right q { flashMessage = t } + EScan (ScanKey s) -> + Right <$> keymap q s q + EScan info@ScanMouse{..} -> + Right <$> mousemap q info q + EShutdown -> + return $ Left q + EResize w h -> + return $ Right q + { screenWidth = w, screenHeight = h + , flashMessage = Plain $ "resize " <> show (w,h) + } + ev -> + return $ Right q + { flashMessage = SGR [31,1] $ Plain $ "unhandled event: " <> show ev + } + + +render :: State -> State +render q@State{..} = + q { treeBuffer = newTreeBuf + , headBuffer = newHeadBuf + } + 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) + <> " " <> flashMessage + <> " " <> Plain (show (xoffset, yoffset)) + ] + +render0 :: State -> [Blessings String] +render0 _q@State{..} = do + let buffer = + map (Blessings.take screenWidth . Blessings.drop xoffset) $ + take screenHeight $ + headBuffer ++ drop yoffset treeBuffer + buffer ++ replicate (screenHeight - length buffer) "~" + + +redraw :: State -> IO () +redraw q@State{..} = do + hPutStr stdout $ map (sub '\t' ' ') $ "\ESC[H" ++ pp (mintercalate "\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 + then s <> "\ESC[K" + else s diff --git a/src/Much/Event.hs b/src/Much/Event.hs new file mode 100644 index 0000000..9842327 --- /dev/null +++ b/src/Much/Event.hs @@ -0,0 +1,12 @@ +module Much.Event where + +import Blessings +import Scanner + +data Event = + EFlash (Blessings String) | + EScan Scan | + EShutdown | + EReload | + EResize Int Int + deriving Show diff --git a/src/Much/MBox.hs b/src/Much/MBox.hs new file mode 100644 index 0000000..9299eea --- /dev/null +++ b/src/Much/MBox.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Much.MBox + ( + -- TODO don't re-export MBox but use our own Message type + module Export + , getMessageId + , 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 + + +type Ident = Text + + +data IdentFields = IdentFields + { messageId :: Ident + , inReplyTo :: [Ident] + , references :: [Ident] + } + deriving Show + + +toForest :: MBox -> Forest Message +toForest mbox = + map (sortTree . fmap (\i -> fromMaybe (error "meh") $ Map.lookup i msgs)) $ + concatMap (Tree.subForest . mkSubTree) (Set.toList $ roots refs) + where + + mkSubTree rootLabel = + Tree.Node rootLabel $ + map mkSubTree (maybe [] Set.toList $ Map.lookup rootLabel backRefs) + + refs = mboxRefs mbox + backRefs = MappedSets.invert refs + msgs = unpackMBox mbox + + +-- TODO finde a new home for roots +roots :: Ord a => Map a (Set a) -> Set a +roots refs = + Set.unions $ Map.elems $ Map.filter p refs + where + messageIDs = Set.fromList $ Map.keys refs + p = Set.null . Set.intersection messageIDs + + +-- TODO finde a new home for sortTree +sortTree :: Tree Message -> Tree Message +sortTree t = + Tree.Node (Tree.rootLabel t) $ + map sortTree $ + List.sortOn (getMessageDate . Tree.rootLabel) $ + Tree.subForest t + + +getMessageDate :: Message -> Maybe UTCTime +getMessageDate msg = + parseTime defaultTimeLocale rfc822DateFormat =<< + Text.unpack . snd <$> + (lastMay $ + filter ((==CI.mk "Date") . CI.mk . Text.unpack . fst) $ + headers msg) + + +unpackMBox :: MBox -> Map Ident Message +unpackMBox = + Map.fromList . + map (\msg -> (getMessageId $ headers msg, msg)) + + +getIdentFields :: Message -> IdentFields +getIdentFields m = + IdentFields + { messageId = getMessageId hdrs + , inReplyTo = getInReplyTo hdrs + , references = getReferences hdrs + } + where + hdrs = headers m + + +-- TODO generate default Message-ID if not present +getMessageId :: [Header] -> Ident +getMessageId = + head . + headerMessageIds "Message-ID" + + +getInReplyTo :: [Header] -> [Ident] +getInReplyTo = + headerMessageIds "In-Reply-To" + + +getReferences :: [Header] -> [Ident] +getReferences = + headerMessageIds "References" + + +headerMessageIds :: P.SourceName -> [Header] -> [Ident] +headerMessageIds headerName = + concatMap ( + either ((:[]) . Text.pack . show) id . + parseMsgIds headerName . + snd + ) . + filter ((==CI.mk headerName) . CI.mk . Text.unpack . fst) + + +parseMsgIds :: P.SourceName -> Text -> Either P.ParseError [Ident] +parseMsgIds srcName = + fmap (map (Text.init . Text.tail . Text.pack)) . + P.parse obs_in_reply_to_parser srcName . + Text.unpack + where + --obs_in_reply_to_parser :: CharParser a [String] + obs_in_reply_to_parser = + --filter (not . null) <$> P.many (P.phrase >> return [] <|> P.msg_id) + P.many1 P.msg_id + + +messageRefs :: IdentFields -> [Ident] +messageRefs IdentFields{..} = + if null inReplyTo + then maybe [""] (:[]) (lastMay references) + else inReplyTo + + +mboxRefs :: MBox -> Map Ident (Set Ident) +mboxRefs = + MappedSets.mk . + map (\m -> + let x = getIdentFields m + in (messageId x, messageRefs x)) diff --git a/src/Much/MappedSets.hs b/src/Much/MappedSets.hs new file mode 100644 index 0000000..ec0ae73 --- /dev/null +++ b/src/Much/MappedSets.hs @@ -0,0 +1,28 @@ +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 + + +mk :: (Ord a, Ord b) => [(a, [b])] -> Map a (Set b) +mk = + Map.fromList . map (second Set.fromList) + + +invert :: (Ord a, Ord b) => Map a (Set b) -> Map b (Set a) +invert = + Map.foldrWithKey invert1 Map.empty + + +invert1 :: (Ord a, Ord b) => a -> Set b -> Map b (Set a) -> Map b (Set a) +invert1 k v a = + Set.foldr (upsert k) a v + + +upsert :: (Ord a, Ord b) => a -> b -> Map b (Set a) -> Map b (Set a) +upsert k = + Map.alter (Just . Set.insert k . fromMaybe Set.empty) diff --git a/src/Much/ParseMail.hs b/src/Much/ParseMail.hs new file mode 100644 index 0000000..e12737a --- /dev/null +++ b/src/Much/ParseMail.hs @@ -0,0 +1,312 @@ +{-# 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.Type +import Control.Applicative +import Data.Char + + + +-- TODO eventually we want our completely own Address, i.e. w/o M.Address +data Address = Mailbox M.Address | Group T.Text [M.Address] + deriving (Show) + + + +readMail :: T.Text -> M.Mail +readMail = + fromMIMEValue . parseMIMEMessage + + +fromMIMEValue :: MIMEValue -> M.Mail +fromMIMEValue val0 = + let m = foldr f (M.emptyMail $ M.Address Nothing "anonymous@localhost") + $ fromMIMEParams + $ mime_val_headers val0 + in m { M.mailParts = [part val0] } + where + + part val = + case mime_val_content val of + Single content -> + (:[]) $ + M.Part + -- TODO actually check if we're utf-8 or ascii(?) + { M.partType = "text/plain; charset=utf-8" + , M.partEncoding = M.QuotedPrintableText + , M.partFilename = Nothing + , M.partHeaders = [] + , M.partContent = LT.encodeUtf8 $ LT.fromStrict content + } + Multi vals -> + concatMap part vals + + --f :: H.Header -> M.Mail -> M.Mail + f (k, v) m = case k of + "from" -> + m { M.mailFrom = case parseAddress (LBS.toStrict v) of + Left msg -> error msg + Right Nothing -> M.mailFrom m + Right (Just (Mailbox a)) -> a + Right (Just (Group _ _)) -> + error "cannot use group in from header" + } + "to" -> + m { M.mailTo = + mconcat $ + map (\case + Mailbox a -> [a] + Group _ as -> as + ) $ + either error id $ + parseAddresses $ + LBS.toStrict v + } + "cc" -> + m { M.mailCc = + mconcat $ + map (\case + Mailbox a -> [a] + Group _ as -> as + ) $ + either error id $ + parseAddresses $ + LBS.toStrict v + } + "bcc" -> + m { M.mailBcc = + mconcat $ + map (\case + Mailbox a -> [a] + Group _ as -> as + ) $ + either error id $ + parseAddresses $ + LBS.toStrict v + } + _ -> + m { M.mailHeaders = + ( CI.original k + , either + (const "I am made of stupid") + LT.toStrict + (LT.decodeUtf8' v) + ) : + M.mailHeaders m + } + + +parseAddress :: BS.ByteString -> Either String (Maybe Address) +parseAddress = + A8.parseOnly (P.cfws *> (Just <$> address <|> return Nothing) <* A8.endOfInput) + + +parseAddresses :: BS.ByteString -> Either String [Address] +parseAddresses = + A8.parseOnly (P.cfws *> address `A8.sepBy1` A8.char ',' <* A8.endOfInput) + + +fromMIMEParams :: [MIMEParam] -> H.Headers +fromMIMEParams = + map $ \(MIMEParam k v) -> + (CI.mk $ T.encodeUtf8 $ CI.original k, LT.encodeUtf8 $ LT.fromStrict v) + + +-- TODO we should probably use email-header + + +-- address = mailbox ; one addressee +-- / group ; named list +address :: A8.Parser Address +address = + (A8. "address") $ + Mailbox <$> mailbox + <|> + group + + +-- group = phrase ":" [#mailbox] ";" +group :: A8.Parser Address +group = + (A8. "group") $ + Group + <$> T.intercalate "," <$> phrase + <* A8.char ':' + <*> mailbox `A8.sepBy` A8.many1 (A8.char ',') + <* A8.char ';' + + +-- mailbox = addr-spec ; simple address +-- / phrase route-addr ; name & addr-spec +mailbox :: A8.Parser M.Address +mailbox = + (A8. "mailbox") $ + M.Address Nothing <$> addrSpec <|> + M.Address . Just . T.intercalate " " <$> A8.option [] phrase <*> routeAddr + + +-- route-addr = "<" [route] addr-spec ">" +routeAddr :: A8.Parser T.Text +routeAddr = + (A8. "routeAddr") $ + P.cfws *> + A8.char '<' *> + -- TODO A8.option [] route <*> + addrSpec <* + A8.char '>' + + +---- route = 1#("@" domain) ":" ; path-relative +--route :: A8.Parser [T.Text] +--route = +-- (A8. "route") $ +-- A8.many1 (A8.char '@' *> domain) <* A8.char ':' + + +-- addr-spec = local-part "@" domain ; global address +addrSpec :: A8.Parser T.Text +addrSpec = + (A8. "addrSpec") $ do + a <- localPart + b <- T.singleton <$> A8.char '@' + c <- domain + return $ a <> b <> c + +-- local-part = word *("." word) ; uninterpreted +-- ; case-preserved +localPart :: A8.Parser T.Text +localPart = + (A8. "localPart") $ + T.intercalate "." <$> (word `A8.sepBy1` A8.char '.') + + +-- domain = sub-domain *("." sub-domain) +domain :: A8.Parser T.Text +domain = + (A8. "domain") $ + T.intercalate "." <$> (subDomain `A8.sepBy1` A8.char '.') + +-- sub-domain = domain-ref / domain-literal +subDomain :: A8.Parser T.Text +subDomain = + (A8. "subDomain") $ + domainRef <|> domainLiteral + +-- domain-ref = atom ; symbolic reference +domainRef :: A8.Parser T.Text +domainRef = + (A8. "domainRef") $ + atom + + +-- atom = 1* +atom :: A8.Parser T.Text +atom = + (A8. "atom") $ + P.cfws *> + (T.pack <$> A8.many1 (A8.satisfy $ A8.notInClass atomClass)) + + +-- domain-literal = "[" *(dtext / quoted-pair) "]" +domainLiteral :: A8.Parser T.Text +domainLiteral = + (A8. "domainLiteral") $ + T.pack <$> + (A8.char '[' *> A8.many' (dtext <|> quotedPair) <* A8.char ']') + + +-- dtext = may be folded +-- "]", "\" & CR, & including +-- linear-white-space> +dtext :: A8.Parser Char +dtext = + (A8. "dtext") $ + A8.satisfy (A8.notInClass "[]\\\CR") + + +-- phrase = 1*word +phrase :: A8.Parser [T.Text] +phrase = + (A8. "phrase") $ + A8.many1 word + + +-- qtext = , ; => may be folded +-- "\" & CR, and including +-- linear-white-space> +qtext :: A8.Parser Char +qtext = + (A8. "qtext") $ + A8.satisfy (A8.notInClass "\"\\\CR") + + +-- quoted-pair = "\" CHAR +quotedPair :: A8.Parser Char +quotedPair = + (A8. "quotedPair") $ + A8.char '\\' *> A8.anyChar + + +-- quoted-string = <"> *(qtext/quoted-pair) <">; Regular qtext or +-- ; quoted chars. +quotedString :: A8.Parser T.Text +quotedString = + (A8. "quotedString") $ + T.pack <$> (A8.char '"' *> A8.many' (qtext <|> quotedPair) <* A8.char '"') + + +encodedWord :: A8.Parser T.Text +encodedWord = + (A8. "encodedWord") $ do + _ <- A8.string "=?" + _ <- A8.string "utf-8" -- TODO 1. CI, 2. other encodings + _ <- A8.string "?Q?" + w <- A8.manyTill A8.anyChar (A8.string "?=") -- TODO all of them + return + $ T.decodeUtf8 + $ BS8.pack + $ QP.decode + -- ^ TODO this current doesn't decode + -- underscore to space + $ map (\c -> if c == '_' then ' ' else c) + $ w + + +-- word = encoded-word / atom / quoted-string +-- ^ TODO what's the correct term for that? +word :: A8.Parser T.Text +word = + (A8. "word") $ + encodedWord <|> atom <|> quotedString + + +atomClass :: [Char] +atomClass = specialClass ++ spaceClass ++ ctlClass + + +specialClass :: [Char] +specialClass = "()<>@,;:\\\".[]" + + +spaceClass :: [Char] +spaceClass = " " + + +ctlClass :: [Char] +ctlClass = map chr $ [0..31] ++ [127] diff --git a/src/Much/RenderTreeView.hs b/src/Much/RenderTreeView.hs new file mode 100644 index 0000000..60b48d6 --- /dev/null +++ b/src/Much/RenderTreeView.hs @@ -0,0 +1,210 @@ +{-# 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 Data.Char +import Data.Maybe +import Data.Time +import Data.Time.Format.Human +import Data.Tree +import Much.State +import Much.TagUtils (Tag) +import Much.TreeView + + +-- 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 = prefix (colorConfig q) " " +teePrefix q = prefix (colorConfig q) "├╴" +pipePrefix q = prefix (colorConfig q) "│ " +endPrefix q = 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 focus colorConfig else search colorConfig + in c $ Plain s + + TVSearchResult sr -> + let c + | hasFocus = focus colorConfig + | isUnread = unreadSearch colorConfig + | otherwise = boring colorConfig + c_authors + | hasFocus = focus colorConfig + | isUnread = alt colorConfig + | otherwise = boring colorConfig + + isUnread = "unread" `elem` Notmuch.searchTags sr + + authors = Plain $ T.unpack $ Notmuch.searchAuthors sr + date = Much.State.date colorConfig $ renderDate now x + subject = Plain $ T.unpack $ Notmuch.searchSubject sr + tags = 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 = focus colorConfig + | "unread" `elem` Notmuch.messageTags m = unreadMessage colorConfig + | otherwise = boringMessage colorConfig + from = fromSGR $ renderFrom (M.lookup "from" $ Notmuch.messageHeaders m) + date = Much.State.date colorConfig $ renderDate now x + tags = 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 focus colorConfig else 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 focus colorConfig else 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 focus colorConfig $ Plain s + else quote colorConfig $ Plain s + + TVMessageLine _ _ _ s -> + if hasFocus + then 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 $ dropAddress $ T.unpack fromLine + 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 lookup tag (tagMap (colorConfig state)) of + Just visual -> visual plain + Nothing -> plain + where + plain = Plain $ T.unpack $ fromMaybe tag $ lookup tag (tagSymbols state) + + +dropAddress :: String -> String +dropAddress xs = + case L.elemIndices '<' xs of + [] -> xs + is -> L.dropWhileEnd isSpace $ take (last is) xs diff --git a/src/Much/Screen.hs b/src/Much/Screen.hs new file mode 100644 index 0000000..47bb90c --- /dev/null +++ b/src/Much/Screen.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE RecordWildCards #-} +module Much.Screen (Screen(..), setScreen, withScreen) where + +import Control.Exception +import Data.List +import System.IO + +data Screen = Screen + { stdinEcho :: Bool + , stdinBufferMode :: BufferMode + , stdoutBufferMode :: BufferMode + , decsetPm :: [Int] + , decrstPm :: [Int] + } + +setScreen :: Screen -> IO Screen +setScreen Screen{..} = get <* set where + get = Screen <$> hGetEcho stdin + <*> hGetBuffering stdin + <*> hGetBuffering stdout + <*> pure decrstPm + <*> pure decsetPm + set = do + hSetEcho stdin stdinEcho + hSetBuffering stdin stdinBufferMode + hSetBuffering stdout stdoutBufferMode + hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decsetPm) ++ "h" + hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decrstPm) ++ "l" + hFlush stdout + +withScreen :: Screen -> (Screen -> IO a) -> IO a +withScreen s = bracket (setScreen s) setScreen diff --git a/src/Much/State.hs b/src/Much/State.hs new file mode 100644 index 0000000..a522e99 --- /dev/null +++ b/src/Much/State.hs @@ -0,0 +1,42 @@ +module Much.State where + +import Blessings.String (Blessings) +import qualified Data.Text as T +import Data.Time +import qualified Data.Tree.Zipper as Z +import Scanner +import System.Posix.Signals +import Much.TreeView (TreeView) + +data State = State + { cursor :: Z.TreePos Z.Full TreeView + , xoffset :: Int + , yoffset :: Int + , flashMessage :: Blessings String + , screenWidth :: Int + , screenHeight :: Int + , headBuffer :: [Blessings String] + , treeBuffer :: [Blessings String] + , now :: UTCTime + , signalHandlers :: [(Signal, IO ())] + , query :: String + , keymap :: String -> State -> IO State + , mousemap :: Scan -> State -> IO State + , tagSymbols :: [(T.Text, T.Text)] + , colorConfig :: ColorConfig + } + +data ColorConfig = ColorConfig + { alt :: Blessings String -> Blessings String + , search :: Blessings String -> Blessings String + , focus :: Blessings String -> Blessings String + , quote :: Blessings String -> Blessings String + , boring :: Blessings String -> Blessings String + , prefix :: Blessings String -> Blessings String + , date :: Blessings String -> Blessings String + , tags :: Blessings String -> Blessings String + , unreadSearch :: Blessings String -> Blessings String + , unreadMessage :: Blessings String -> Blessings String + , boringMessage :: Blessings String -> Blessings String + , tagMap :: [(T.Text, Blessings String -> Blessings String)] + } diff --git a/src/Much/TagUtils.hs b/src/Much/TagUtils.hs new file mode 100644 index 0000000..d4e4d30 --- /dev/null +++ b/src/Much/TagUtils.hs @@ -0,0 +1,62 @@ +{-# 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.Tree +import Notmuch.Message +import Notmuch.SearchResult +import Much.TreeView.Types + + +type Tag = T.Text + + +data TagOp = AddTag Tag | DelTag Tag + + +parseTags :: String -> [Tag] +parseTags = + mconcat . map (map T.pack . wordsBy isSpace . takeWhile (/='#')) . lines + + +diffTags :: [Tag] -> [Tag] -> [TagOp] +diffTags old new = + let oldTags = Set.fromList old + newTags = Set.fromList new + in map DelTag (Set.toList $ oldTags `Set.difference` newTags) ++ + map AddTag (Set.toList $ newTags `Set.difference` oldTags) + + +patchRootLabelTags :: [TagOp] -> Tree TreeView -> Tree TreeView +patchRootLabelTags tagOps x = + x { rootLabel = patchTags tagOps $ rootLabel x } + + +patchTreeTags :: [TagOp] -> Tree TreeView -> Tree TreeView +patchTreeTags tagOps = + fmap (patchTags tagOps) + + +tagOpsToArgs :: [TagOp] -> [String] +tagOpsToArgs = map $ \case + AddTag t -> '+' : T.unpack t + DelTag t -> '-' : T.unpack t + + +patchTags :: [TagOp] -> TreeView -> TreeView +patchTags tagOps = \case + TVSearchResult sr -> + TVSearchResult sr { searchTags = foldr applyTagOp (searchTags sr) tagOps } + TVMessage m -> + TVMessage m { messageTags = foldr applyTagOp (messageTags m) tagOps } + x -> x -- nop + + +applyTagOp :: TagOp -> [Tag] -> [Tag] +applyTagOp = \case + AddTag t -> (t:) + DelTag t -> filter (/=t) diff --git a/src/Much/TreeSearch.hs b/src/Much/TreeSearch.hs new file mode 100644 index 0000000..d66eb83 --- /dev/null +++ b/src/Much/TreeSearch.hs @@ -0,0 +1,87 @@ +module Much.TreeSearch where + +import Data.Tree.Zipper + + +findTree :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a) +findTree p loc = if p (label loc) + then Just loc + else depthFirst loc >>= findTree p + + +depthFirst :: TreePos Full a -> Maybe (TreePos Full a) +depthFirst loc = case firstChild loc of + Just x -> Just x + Nothing -> case next loc of + Just x -> Just x + Nothing -> parentWithNext loc + where + parentWithNext x = + case parent x of + Nothing -> Nothing + Just x' -> case next x' of + Just x'' -> Just x'' + Nothing -> parentWithNext x' + + +findNext :: TreePos Full a -> Maybe (TreePos Full a) +findNext = depthFirst + + +findPrev :: TreePos Full a -> Maybe (TreePos Full a) +findPrev loc = + case prev loc of + Just x -> trans_lastChild x + Nothing -> parent loc + where + trans_lastChild x = + case lastChild x of + Nothing -> Just x + Just x' -> trans_lastChild x' + + + +findNextN :: Eq a => Int -> TreePos Full a -> TreePos Full a +findNextN n loc + | n <= 0 = loc + | otherwise = + maybe loc (findNextN $ n - 1) (skipSame findNext loc) + + +findPrevN :: Eq a => Int -> TreePos Full a -> TreePos Full a +findPrevN n loc + | n <= 0 = loc + | otherwise = + maybe loc (findPrevN $ n - 1) (skipSame findPrev loc) + + + +findParent :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a) +findParent p loc = + if p (label loc) + then Just loc + else parent loc >>= findParent p + + +linearPos :: TreePos Full a -> Int +linearPos = + rec 0 + where + rec i loc = case findPrev loc of + Just loc' -> rec (i + 1) loc' + Nothing -> i + + + +skipSame + :: Eq a => + (TreePos Full a -> Maybe (TreePos Full a)) -> + TreePos Full a -> + Maybe (TreePos Full a) +skipSame next' loc = + case next' loc of + Nothing -> Nothing + Just loc' -> + if label loc' == label loc + then skipSame next' loc' + else Just loc' diff --git a/src/Much/TreeView.hs b/src/Much/TreeView.hs new file mode 100644 index 0000000..9487f74 --- /dev/null +++ b/src/Much/TreeView.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + + +module Much.TreeView + ( module Export + , getMessage + , getSearchTerm + , isTVMessage + , isTVSearchResult + , fromSearchResults + , fromMessageForest + , fromMessageTree + , loadSubForest + , unloadSubForest + , hasUnloadedSubForest + ) where + + +import qualified Data.Text as T +import Data.Tree +import Notmuch +import Notmuch.Message +import Notmuch.SearchResult +import Much.TreeView.Types as Export + + +getMessage :: TreeView -> Maybe Message +getMessage = \case + TVMessage m -> Just m + TVMessageHeaderField m _ -> Just m + TVMessagePart m _ -> Just m + TVMessageQuoteLine m _ _ _ -> Just m + TVMessageLine m _ _ _ -> Just m + _ -> Nothing + + +getSearchTerm :: TreeView -> Maybe String +getSearchTerm = \case + TVSearch term -> Just term + _ -> Nothing + + +isTVMessage :: TreeView -> Bool +isTVMessage = \case + TVMessage _ -> True + _ -> False + + +isTVMessagePart :: TreeView -> Bool +isTVMessagePart = \case + TVMessagePart _ _ -> True + _ -> False + + +isTVSearchResult :: TreeView -> Bool +isTVSearchResult (TVSearchResult _) = True +isTVSearchResult _ = False + + +fromSearchResults :: String -> [SearchResult] -> Tree TreeView +fromSearchResults query = + Node (TVSearch query) . map (\r -> Node (TVSearchResult r) []) + + +fromMessageForest :: Forest Message -> Forest TreeView +fromMessageForest = map fromMessageTree + + +fromMessageTree :: Tree Message -> Tree TreeView +fromMessageTree (Node m ms) = + Node (TVMessage m) + (xconvHead m <> xconvBody m <> map fromMessageTree ms) + + +xconvHead :: Message -> Forest TreeView +xconvHead m = + map conv [ "From", "To" ] + -- TODO add Subject if it differs from thread subject + where + conv k = + Node (TVMessageHeaderField m k) [] + + +xconvBody :: Message -> Forest TreeView +xconvBody m = map (xconvPart m) (messageBody m) + + +xconvPart :: Message -> MessagePart -> Tree TreeView +xconvPart m p = + Node (TVMessagePart m p) contents + where + contents = case partContent p of + ContentText t -> + zipWith (curry $ xconvLine m p) [0..] (T.lines t) + ContentMultipart parts -> + map (xconvPart m) parts + ContentMsgRFC822 _ -> + [] + + +xconvLine + :: Message -> MessagePart -> (LineNr, T.Text) -> Tree TreeView +xconvLine m p (i, s) = + Node (ctor m p i $ T.unpack s) [] + where + ctor = + if isQuoteLine s + then TVMessageQuoteLine + else TVMessageLine + + +isQuoteLine :: T.Text -> Bool +isQuoteLine s0 = do + let s = T.stripStart s0 + + -- /^\s*>/ + not (T.null s) && T.head s == '>' + + +-- +-- Loading / Unloading +-- + + +loadSubForest :: TreeView -> IO (Either String (Forest TreeView)) +loadSubForest = \case + TVMessage m -> + Right + . unloadPartsWithFilename + . map unloadReadSubForests + . concatMap subForest + . fromMessageForest + . findFirsts messageMatch + <$> notmuchShow (termFromMessage m) + + TVMessagePart m mp -> + -- TODO parse --format=raw + notmuchShowPart (termFromMessage m) (partID mp) >>= return . \case + Left e -> Left $ show e + Right mp' -> + Right + . unloadPartsWithFilename + . subForest + $ xconvPart m mp' + + TVSearchResult sr -> + Right + . unloadPartsWithFilename + . map unloadReadSubForests + . fromMessageForest + <$> notmuchShow (termFromSearchResult sr) + + TVSearch s -> + Right + . subForest + . fromSearchResults s + . either error id + <$> Notmuch.search [s] + + _ -> + return $ Right [] + + where + termFromMessage = unMessageID . messageId + termFromSearchResult = unThreadID . searchThread + + +unloadSubForest :: Tree TreeView -> Forest TreeView +unloadSubForest t = case rootLabel t of + TVMessage _ -> + filter (isTVMessage . rootLabel) $ subForest t + TVMessagePart _ _ -> + filter (isTVMessagePart . rootLabel) $ subForest t + _ -> + [] + + +hasUnloadedSubForest :: Tree TreeView -> Bool +hasUnloadedSubForest t = case rootLabel t of + TVMessage _ -> + all (isTVMessage . rootLabel) $ subForest t + TVMessagePart _ _ -> + all (isTVMessagePart . rootLabel) $ subForest t + _ -> + null $ subForest t + + +unloadReadSubForests :: Tree TreeView -> Tree TreeView +unloadReadSubForests t = case rootLabel t of + TVMessage m | "unread" `notElem` messageTags m -> + t { subForest = + map unloadReadSubForests $ + filter (isTVMessage . rootLabel) $ + subForest t + } + _ -> + t { subForest = + map unloadReadSubForests $ + subForest t + } + + +unloadPartsWithFilename :: Forest TreeView -> Forest TreeView +unloadPartsWithFilename = + map rewriteTree + where + f x@Node{..} = case rootLabel of + TVMessagePart _ mp -> + case partContentFilename mp of + Nothing -> x + Just _ -> + x { subForest = [] } + _ -> x + + rewriteTree x = + let x' = f x + in x' { subForest = map rewriteTree $ subForest x' } + + +findFirsts :: (a -> Bool) -> Forest a -> Forest a +findFirsts p = + concatMap rec + where + rec t@Node{..} = + if p rootLabel + then [t] + else concatMap rec subForest diff --git a/src/Much/TreeView/Types.hs b/src/Much/TreeView/Types.hs new file mode 100644 index 0000000..6e4ac6b --- /dev/null +++ b/src/Much/TreeView/Types.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE LambdaCase #-} + +module Much.TreeView.Types where + +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as T +import Notmuch.Message +import Notmuch.SearchResult + + +type LineNr = Int + + +data TreeView + = TVMessage Message + | TVMessageHeaderField Message (CI.CI T.Text) + | TVMessagePart Message MessagePart + | TVMessageQuoteLine Message MessagePart LineNr String + | TVMessageLine Message MessagePart LineNr String + | TVSearch String + | TVSearchResult SearchResult + deriving (Show) + + +instance Eq TreeView where + x1 == x2 = treeViewId x1 == treeViewId x2 + + +data TreeViewId + = TVIDMessage T.Text + | TVIDMessageHeaderField T.Text T.Text + | TVIDMessagePart T.Text Int + | TVIDMessageLine T.Text Int Int + | TVIDSearch T.Text + | TVIDSearchResult T.Text + deriving (Eq,Show) + + +treeViewId :: TreeView -> TreeViewId +treeViewId = \case + TVMessage m -> + TVIDMessage (fromMessage m) + + TVMessageHeaderField m mhf -> + TVIDMessageHeaderField (fromMessage m) (CI.foldedCase mhf) + + TVMessagePart m mp -> + TVIDMessagePart (fromMessage m) (partID mp) + + TVMessageLine m mp lineNr _ -> + TVIDMessageLine (fromMessage m) (partID mp) lineNr + + TVMessageQuoteLine m mp lineNr _ -> + TVIDMessageLine (fromMessage m) (partID mp) lineNr + + TVSearch s -> + TVIDSearch (T.pack s) + + TVSearchResult sr -> + TVIDSearchResult (T.pack $ unThreadID $ searchThread sr) + + where + fromMessage = T.pack . unMessageID . messageId diff --git a/src/Much/TreeZipperUtils.hs b/src/Much/TreeZipperUtils.hs new file mode 100644 index 0000000..5257c2f --- /dev/null +++ b/src/Much/TreeZipperUtils.hs @@ -0,0 +1,52 @@ +module Much.TreeZipperUtils where + +import Data.Maybe +import Data.Tree +import Data.Tree.Zipper + +-- Return loc (as parent-like structure) and parents. +path :: TreePos Full a -> [(Forest a, a, Forest a)] +path loc = toParent loc : parents loc + +-- Return parent stack compatible form of loc. +toParent :: TreePos Full a -> (Forest a, a, Forest a) +toParent loc = (before loc, label loc, after loc) + + +modifyFirstParentLabelWhere + :: (a -> Bool) + -> (a -> a) + -> TreePos Full a + -> TreePos Full a +modifyFirstParentLabelWhere p f loc0 = + case parent loc0 of + Nothing -> loc0 + Just loc0' -> go (byChildIndex loc0) loc0' + where + + go rewind loc = + if p (label loc) + then + rewind (modifyLabel f loc) + else + case parent loc of + Nothing -> rewind loc + Just loc' -> + go (rewind . byChildIndex loc) loc' + + -- generator for a rewind step + byChildIndex :: TreePos Full a -> (TreePos Full a -> TreePos Full a) + byChildIndex loc = + -- The use of fromJust is safe here because we're only modifying + -- labels and not the tree structure and thus the index is valid. + fromJust . childAt (childIndex loc) + + +-- XXX This could be named more general, like countPrevSiblings? +-- XXX Can we kill the recursion? +childIndex :: TreePos Full a -> Int +childIndex = + go 0 + where + go index = + maybe index (go $ index + 1) . prev diff --git a/src/Much/Utils.hs b/src/Much/Utils.hs new file mode 100644 index 0000000..80615fc --- /dev/null +++ b/src/Much/Utils.hs @@ -0,0 +1,28 @@ +module Much.Utils where + +import Control.Exception +import System.Directory +import System.IO + + +withTempFile :: FilePath -> String -> ((FilePath, Handle) -> IO a) -> IO a +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 + then padl n c (c:s) + else s + +padr :: Int -> a -> [a] -> [a] +padr n c s = + if length s < n + then padr n c (s ++ [c]) + else s -- cgit v1.2.3