diff options
| -rw-r--r-- | Notmuch.hs | 323 | ||||
| -rw-r--r-- | Notmuch/Message.hs | 115 | ||||
| -rw-r--r-- | Notmuch/SearchResult.hs | 51 | ||||
| -rw-r--r-- | README | 2 | ||||
| -rw-r--r-- | ThreadView.hs | 286 | ||||
| -rw-r--r-- | default.nix | 26 | ||||
| -rw-r--r-- | env.nix | 63 | ||||
| -rw-r--r-- | nixpkgs/vty-5.2.5.nix | 34 | ||||
| -rw-r--r-- | test1.hs | 14 | ||||
| -rw-r--r-- | test3.hs | 273 |
10 files changed, 1187 insertions, 0 deletions
diff --git a/Notmuch.hs b/Notmuch.hs new file mode 100644 index 0000000..7ff6a92 --- /dev/null +++ b/Notmuch.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +module Notmuch where + +--import Language.Haskell.TH.Ppr (bytesToString) +import Data.Aeson +--import Data.List.Split +--import Data.Attoparsec.ByteString hiding (try) +import Data.Maybe +import Data.Monoid +import Data.String +--import Data.Traversable +import Data.Tree +--import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +--import qualified Data.ByteString.Char8 as BS8 +--import qualified Data.Text.Lazy as TL +import qualified Data.Text as T +--import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +--import Data.Version (Version(..), parseVersion) +import System.Process +--import System.IO +import qualified Data.Map as M + +import Notmuch.SearchResult +import Notmuch.Message + + +import Control.Concurrent +--import Control.Concurrent.MVar +import Control.Exception +import System.IO +import Control.DeepSeq (rnf) + + +-- | Fork a thread while doing something else, but kill it if there's an +-- exception. +-- +-- This is important in the cases above because we want to kill the thread +-- that is holding the Handle lock, because when we clean up the process we +-- try to close that handle, which could otherwise deadlock. +-- +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either throwIO return + restore (body wait) `onException` killThread tid + + + + +notmuch :: [String] -> IO LBS.ByteString +notmuch args = do + (_, Just hout, _, ph) <- createProcess (proc "notmuch" args) + { std_out = CreatePipe } + output <- LBS.hGetContents hout + + + withForkWait (evaluate $ rnf output) $ \waitOut -> do + + ---- now write any input + --unless (null input) $ + -- ignoreSigPipe $ hPutStr inh input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + --ignoreSigPipe $ hClose inh + + -- wait on the output + waitOut + hClose hout + + -- wait on the process + _ex <- waitForProcess ph + --return (ex, output) + + --case ex of + -- ExitSuccess -> return output + -- ExitFailure r -> processFailedException "readProcess" cmd args r + + return output + + + +--notmuch' args = do +-- (_, Just hout, _, _) <- createProcess (proc "notmuch" args) +-- { std_out = CreatePipe } +-- BS.hGetContents hout + + +search :: String -> IO () +search term = do + c <- notmuch [ "search", "--format=json", "--format-version=2", term ] + + let results = case eitherDecode' c :: Either String [SearchResult] of + Left err -> error err + Right x -> x + + mapM_ (T.putStrLn . drawSearchResult) results + + +showThread :: String -> IO () +showThread tid = do + c' <- notmuch [ "show", "--format=json", "--format-version=2" + , "thread:" <> tid ] + + let threads = case eitherDecode' c' :: Either String [Thread] of + Left err -> error err + Right x -> x + --threadsF = map threadForest threads + ttt = head $ threadForest $ head $ threads + + --Prelude.putStrLn $ drawTree $ fmap drawMessage ttt + Prelude.putStrLn $ showTree $ ttt + + +getThread :: String -> IO (Tree Message) +getThread tid = do + c' <- notmuch [ "show", "--format=json", "--format-version=2" + , "thread:" <> tid ] + + let threads = case eitherDecode' c' :: Either String [Thread] of + Left err -> error err + Right x -> x + --threadsF = map threadForest threads + ttt = head $ threadForest $ head $ threads + return ttt + + + +setTag :: String -> String -> IO LBS.ByteString +setTag tag i = do + notmuch [ "tag", "+" <> tag , "id:" <> i ] + + +unsetTag :: String -> String -> IO LBS.ByteString +unsetTag tag i = do + notmuch [ "tag", "-" <> tag , "id:" <> i ] + + +openMessage :: String -> IO () +openMessage i = do + notmuch [ "tag", "+open" , "id:" <> i ] >> return () + + +closeMessage :: String -> IO () +closeMessage i = do + notmuch [ "tag", "-open" , "id:" <> i ] >> return () + + + + + + +---- | Neat 2-dimensional drawing of a tree. +--drawTree :: Tree String -> String +--drawTree = unlines . draw +-- +---- | Neat 2-dimensional drawing of a forest. +--drawForest :: Forest String -> String +--drawForest = unlines . map drawTree +-- +draw :: Tree Message -> [String] +draw (Node x ts0) = (show $ drawMessage x) : drawSubTrees ts0 + where + drawSubTrees [] = [] + drawSubTrees [t] = + -- "|" : shift "`- " " " (draw t) + shift "`- " " " (draw t) + + drawSubTrees (t:ts) = + -- "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts + shift "+- " "| " (draw t) ++ drawSubTrees ts + + shift first other = zipWith (++) (first : repeat other) + + +indentMessageInit :: [String] -> [String] +indentMessageInit [] = [] +indentMessageInit (s:ss) = (red "─╴" ++ s) : map (red " " ++) ss + +indentMessageLast :: [String] -> [String] +indentMessageLast [] = [] +indentMessageLast (s:ss) = (red "┬╴" ++ s) : map (red "│ " ++) ss + +indentInit :: [String] -> [String] +indentInit [] = [] +indentInit (s:ss) = (red "├╴" ++ s) : map (red "│ " ++) ss + +indentLast :: [String] -> [String] +indentLast [] = [] +indentLast (s:ss) = (red "└╴" ++ s) : map (red " " ++) ss + +indentChildren :: [[String]] -> [[String]] +indentChildren [] = [] +indentChildren ns = map indentInit (init ns) ++ [indentLast (last ns)] + +appLast :: [String] -> String -> [String] +appLast ss s = init ss ++ [last ss ++ s] + +showTree' :: Tree Message -> [String] +showTree' (Node n ns) = + -- (if length ns == 0 + -- then indentMessageInit $ drawMessage n + -- else indentMessageLast $ drawMessage n) + drawMessage n + ++ + concat (indentChildren (map showTree' ns)) + +-- | Show a 'Tree' using Unicode art +showTree :: Tree Message -> String +showTree = unlines . showTree' + + + + + + +drawMessage :: Message -> [String] +drawMessage Message{..} = + ----unMessageID messageId + --show messageTime + -- -- <> " " <> T.unpack messageDateRel + -- <> "\n" <> show (fromJust $ M.lookup "From" messageHeaders) + -- <> "\n" <> show (fromJust $ M.lookup "Subject" messageHeaders) + [ gray (unMessageID messageId) + <> " " <> T.unpack (fromJust $ M.lookup "From" messageHeaders) + <> " " <> gray (show messageDateRel) + <> " " <> T.unpack (T.intercalate ", " $ map magenta messageTags) + -- , T.unpack $ fromJust $ M.lookup "Subject" messageHeaders + ] + ++ + (if "open" `elem` messageTags + then concat (map (map green . lines . drawMessagePart) messageBody) + else []) + --map drawMessagePart messageBody + +drawMessagePart :: MessagePart -> String +drawMessagePart p = drawPartContent (partContent p) + +drawPartContent :: MessageContent -> String +drawPartContent (ContentText t) = T.unpack t +--drawPartContent (ContentText t) = "ContentText" +drawPartContent (ContentMultipart _) = "ContentMultipart" +drawPartContent (ContentMsgRFC822 _) = "ContentMsgRFC822" + +-- otherAuthors are non-matched authors in the same thread +drawSearchResult :: SearchResult -> T.Text +drawSearchResult SearchResult{..} = do + let (matchedAuthors, otherAuthors) = + case T.splitOn "| " searchAuthors of + [a,b] -> (T.splitOn ", " a, T.splitOn ", " b) + [a] -> (T.splitOn ", " a, []) + + a' = map green matchedAuthors + b' = map red otherAuthors + --qa = maybe [] (T.splitOn " ") (searchQuery !! 0) + --qb = maybe [] (T.splitOn " ") (searchQuery !! 1) + ThreadID tid = searchThread + + (T.pack tid) + -- <> " " <> (T.pack $ show $ searchTime) + <> " " <> "[" <> (T.pack $ show searchMatched) <> "/" + <> (T.pack $ show searchTotal) <> "]" + <> " " <> searchDateRel + <> " " <> searchSubject + <> " " <> T.intercalate ", " (a' <> b') + <> " " <> T.intercalate ", " (map magenta searchTags) + + + + +red, green, magenta, gray :: (Monoid m, IsString m) => m -> m +red = ("\ESC[31m"<>) . (<>"\ESC[m") +green = ("\ESC[32m"<>) . (<>"\ESC[m") +magenta = ("\ESC[35m"<>) . (<>"\ESC[m") +gray = ("\ESC[30;1m"<>) . (<>"\ESC[39;22m") + + + + + --case fromJSON c of + -- Error e -> error e + -- Success x -> return x + +-- c <- hGetContents hout +-- +-- let v = +-- +-- +-- putStrLn $ show c + +-- let fixTags :: Char -> Char +-- fixTags '+' = '-' +-- fixTags '~' = '-' +-- fixTags c = c +-- let vStr = map fixTags $ words out !! 1 +-- let vs = filter (\(_,r) -> r == "") $ readP_to_S parseVersion vStr +-- case vs of +-- ((v,_):_) -> return v +-- _ -> throw $ NotmuchError $ "Unable to parse version: " ++ vStr + + + +-- | The version of notmuch +--notmuchVersion :: MonadIO m => m Version +--notmuchVersion = do +-- out <- liftIO $ readProcess "notmuch" ["--version"] "" +-- let fixTags :: Char -> Char +-- fixTags '+' = '-' +-- fixTags '~' = '-' +-- fixTags c = c +-- let vStr = map fixTags $ words out !! 1 +-- let vs = filter (\(_,r) -> r == "") $ readP_to_S parseVersion vStr +-- case vs of +-- ((v,_):_) -> return v +-- _ -> throw $ NotmuchError $ "Unable to parse version: " ++ vStr +-- +-- +-- r <- createProcess (proc "ls" []) +-- +--proc diff --git a/Notmuch/Message.hs b/Notmuch/Message.hs new file mode 100644 index 0000000..3889e7c --- /dev/null +++ b/Notmuch/Message.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Notmuch.Message where + +import Control.Applicative +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Map as M +import qualified Data.CaseInsensitive as CI +import qualified Data.Vector as V + +import qualified Data.Tree as TR + + +newtype MessageID = MessageID { unMessageID :: String } + deriving (Show, Read, Eq, FromJSON) + +type MessageHeaders = M.Map (CI.CI T.Text) T.Text + +data MessageContent = ContentText T.Text + | ContentMultipart [MessagePart] + | ContentMsgRFC822 [(MessageHeaders, [MessagePart])] + deriving (Show) + +data MessagePart = MessagePart { + partID :: Int + , partContentType :: CI.CI T.Text + , partContentCharset :: Maybe (CI.CI T.Text) + , partContentFilename :: Maybe T.Text + , partContent :: MessageContent +} + deriving (Show) + +instance Eq MessagePart where + a == b = partID a == partID b + + +parseRFC822 :: V.Vector Value -> Parser MessageContent +parseRFC822 lst = ContentMsgRFC822 . V.toList <$> V.mapM p lst + where + p (Object o) = do h <- M.mapKeys CI.mk <$> o .: "headers" + b <- o .: "body" + return (h, b) + p _ = fail "Invalid rfc822 body" + +instance FromJSON MessagePart where + parseJSON (Object v) = do + i <- v .: "id" + t <- CI.mk . T.toLower <$> v .: "content-type" + x <- v .:? "content" + f <- v .:? "filename" + cs <- fmap CI.mk <$> v .:? "content-charset" + let ctype = CI.map (T.takeWhile (/= '/')) t + case (ctype, x) of + ("multipart", Just (Array _)) -> MessagePart i t cs f . ContentMultipart <$> v .: "content" + ("message", Just (Array lst)) | t == "message/rfc822" -> MessagePart i t cs f <$> parseRFC822 lst + (_, Just (String c)) -> return $ MessagePart i t cs f $ ContentText c + (_, Just _) -> return $ MessagePart i t cs f $ ContentText $ "Unknown content-type: " <> CI.original t + (_, Nothing) -> return $ MessagePart i t cs f $ ContentText "" + + parseJSON x = fail $ "Error parsing part: " ++ show x + + +data Message = Message { + messageId :: MessageID + , messageDateRel :: T.Text + , messageTime :: UTCTime + , messageHeaders :: MessageHeaders + , messageBody :: [MessagePart] + , messageExcluded :: Bool + , messageMatch :: Bool + , messageTags :: [T.Text] + , messageFilename :: FilePath +} + deriving (Show) + +instance Eq Message where + a == b = messageId a == messageId b + + + +instance FromJSON Message where + parseJSON (Object v) = Message <$> v .: "id" + <*> v .: "date_relative" + <*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp") + <*> (M.mapKeys CI.mk <$> v .: "headers") + <*> v .: "body" + <*> v .: "excluded" + <*> v .: "match" + <*> v .: "tags" + <*> v .: "filename" + parseJSON (Array _) = return $ Message (MessageID "") "" defTime M.empty [] True False [] "" + where defTime = UTCTime (ModifiedJulianDay 0) (fromInteger 0) + parseJSON x = fail $ "Error parsing message: " ++ show x + + + + +data Thread = Thread { threadForest :: TR.Forest Message } + +instance FromJSON Thread where + parseJSON (Array vs) = Thread <$> (mapM parseTree $ V.toList vs) + parseJSON _ = fail "Thread is not an array" + +parseTree :: Value -> Parser (TR.Tree Message) +parseTree vs@(Array _) = do + (msg, Thread t) <- parseJSON vs + return $ TR.Node msg t +parseTree _ = fail "Tree is not an array" + diff --git a/Notmuch/SearchResult.hs b/Notmuch/SearchResult.hs new file mode 100644 index 0000000..164c5b3 --- /dev/null +++ b/Notmuch/SearchResult.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Notmuch.SearchResult where + +import Control.Applicative +import Data.Aeson +import Data.Text +import Data.Time.Clock +import Data.Time.Clock.POSIX + + +newtype ThreadID = ThreadID String + deriving (Show,Read,Eq,FromJSON,ToJSON) + + +-- | A single entry returned from the notmuch search command. +data SearchResult = SearchResult { + searchThread :: ThreadID + , searchTime :: UTCTime + , searchDateRel :: Text + , searchSubject :: Text + , searchAuthors :: Text + , searchQuery :: [Maybe Text] -- TODO (Text, Maybe Text) + , searchTags :: [Text] + , searchMatched :: Int + , searchTotal :: Int + } + deriving (Show,Eq) + +instance FromJSON SearchResult where + parseJSON (Object v) = SearchResult <$> v .: "thread" + <*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp") + <*> v .: "date_relative" + <*> v .:? "subject" .!= "" + <*> v .:? "authors" .!= "" + <*> v .:? "query" .!= [] + <*> v .: "tags" + <*> v .: "matched" + <*> v .: "total" + parseJSON x = fail $ "Error parsing search: " ++ show x + +--instance ToJSON SearchResult where +-- toJSON s = object [ "thread" .= searchThread s +-- , "time" .= searchTime s +-- , "date_relative" .= searchDateRel s +-- , "subject" .= searchSubject s +-- , "authors" .= searchAuthors s +-- , "tags" .= searchTags s +-- , "matched" .= searchMatched s +-- , "total" .= searchTotal s +-- ] @@ -0,0 +1,2 @@ +2014-08-26T13:49:27Z + vty cannot colorize diff --git a/ThreadView.hs b/ThreadView.hs new file mode 100644 index 0000000..e2b1a4b --- /dev/null +++ b/ThreadView.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + + +module ThreadView where + +import Data.Default +import Graphics.Vty + +import Data.List + +--import Data.Aeson +--import Data.List.Split +--import Data.Attoparsec.ByteString hiding (string) +--import Data.Maybe +import Data.Monoid +--import Data.String +--import Data.Traversable +import Data.Tree +--import qualified Data.ByteString as BS +--import qualified Data.ByteString.Lazy as LBS +--import qualified Data.ByteString.Char8 as BS8 +--import qualified Data.Text.Lazy as TL +import qualified Data.Text as T +--import qualified Data.Text.Encoding as T +--import qualified Data.Text.IO as T +--import Data.Version (Version(..), parseVersion) +--import System.Process +--import System.IO +--import qualified Data.Map as M + +--import Notmuch.SearchResult +import Notmuch.Message +--import Notmuch +import Safe + + +type LineNr = Int + + +data ThreadView + = ClosedMessage Message + | OpenMessage Message + | MessageLine Message MessagePart LineNr String + | TVMessagePart Message MessagePart + deriving (Show) + +instance Eq ThreadView where + MessageLine m1 mp1 ln1 _s1 == MessageLine m2 mp2 ln2 _s2 = + m1 == m2 && mp1 == mp2 && ln1 == ln2 + a == b = + isMessage a && isMessage b && tvMsgId a == tvMsgId b + + +isMessage :: ThreadView -> Bool +isMessage (ClosedMessage _) = True +isMessage (OpenMessage _) = True +isMessage _ = False + + +tvMsgId :: ThreadView -> Maybe MessageID +tvMsgId (ClosedMessage m) = Just $ messageId m +tvMsgId (OpenMessage m) = Just $ messageId m +tvMsgId _ = Nothing + + + +describe :: ThreadView -> String +describe (ClosedMessage m) = "ClosedMessage " <> unMessageID (messageId m) +describe (OpenMessage m) = "OpenMessage " <> unMessageID (messageId m) +describe (MessageLine _ _ _ s) = "MessageLine " <> show s +describe (TVMessagePart _ p) = "TVMessagePart " <> show (partID p) + + +--focusPrev t_cur t = do +-- i <- findIndex ((==t_cur) . messageId) msgs +-- m' <- msgs `atMay` (i - 1) +-- return $ messageId m' +-- where +-- msgs = flatten t +-- +--focusNext t_cur t = do +-- i <- findIndex ((==t_cur) . messageId) msgs +-- m' <- msgs `atMay` (i + 1) +-- return $ messageId m' +-- where +-- msgs = flatten t + +focusPrev :: Maybe ThreadView -> Tree ThreadView -> Maybe ThreadView +focusPrev Nothing v = lastMay (flatten v) +focusPrev (Just cur) v = do + i <- elemIndex cur items + maybe (lastMay items) Just $ atMay items (i - 1) + where + items = flatten v + +focusNext :: Maybe ThreadView -> Tree ThreadView -> Maybe ThreadView +focusNext Nothing v = headMay (flatten v) +focusNext (Just cur) v = do + i <- elemIndex cur items + maybe (headMay items) Just $ atMay items (i + 1) + where + items = flatten v + + +findMessage :: MessageID -> Tree ThreadView -> Maybe ThreadView +findMessage i = + find p . flatten + where + p (ClosedMessage m) = i == messageId m + p (OpenMessage m) = i == messageId m + p _ = False + +findTV :: ThreadView -> Tree ThreadView -> Maybe ThreadView +findTV x = + find (==x) . flatten + + + +fromMessageTree :: Tree Message -> Tree ThreadView +fromMessageTree (Node m ms) = + Node m' ms' + where + isOpen = "open" `elem` messageTags m + + m' :: ThreadView + m' = + if isOpen + then OpenMessage m + else ClosedMessage m + + ms' :: Forest ThreadView + ms' = if isOpen + then xconvBody m <> map fromMessageTree ms + else map fromMessageTree ms + +xconvBody :: Message -> Forest ThreadView +xconvBody m = mconcat $ map (xconvPart m) (messageBody m) + +xconvPart :: Message -> MessagePart -> Forest ThreadView +xconvPart m p = xconvPartContent m p $ partContent p + +xconvPartContent + :: Message -> MessagePart -> MessageContent -> Forest ThreadView +xconvPartContent m p = \case + ContentText t -> + map (xconvLine m p) $ zip [0..] (T.lines t) + ContentMultipart parts -> + map (xconvPart2 m) parts + -- [Node (MessageLine m p 0 "ContentMultipart") []] + ContentMsgRFC822 _ -> + [Node (MessageLine m p 0 "ContentMsgRFC822") []] + + +xconvPart2 :: Message -> MessagePart -> Tree ThreadView +xconvPart2 m p = + Node (TVMessagePart m p) [] + + +xconvLine + :: Message -> MessagePart -> (LineNr, T.Text) -> Tree ThreadView +xconvLine m p (i, s) = + Node (MessageLine m p i $ T.unpack s) [] + + + +threadViewImage :: Bool -> ThreadView -> Image +threadViewImage hasFocus = \case + ClosedMessage m -> + string cm (unMessageID $ messageId m) + <|> + translateX 1 ( + horizCat $ + intersperse (string cm ", ") $ + map (text' tagColor) $ + messageTags m + ) + + OpenMessage m -> + string om (unMessageID $ messageId m) + <|> + translateX 1 ( + horizCat $ + intersperse (string om ", ") $ + map (text' tagColor) $ + messageTags m + ) + + MessageLine _ _ _ s -> + string ml s + + TVMessagePart _ p -> + string def "TVMessagePart" + <|> translateX 1 (string def $ show $ partContentType p) + <-> translateX 2 (partImage p) + + where + --c1 = if hasFocus then c1_focus else c1_nofocus + --c1_nofocus = withForeColor def $ Color240 $ -16 + 238 + --c1_focus = withForeColor def $ Color240 $ -16 + 244 + --c2 = withForeColor def $ Color240 $ -16 + 106 + --c3 = withForeColor def $ Color240 $ -16 + 199 + + tagColor = if hasFocus then tagColor_y else tagColor_n + tagColor_y = withForeColor def $ color 230 + tagColor_n = withForeColor def $ color 200 + + cm = if hasFocus then cm_y else cm_n + cm_y = withForeColor def $ color 46 + cm_n = withForeColor def $ color 22 + + om = if hasFocus then om_y else om_n + om_y = withForeColor def $ color 82 + om_n = withForeColor def $ color 58 + + ml = if hasFocus then ml_y else ml_n + ml_y = withForeColor def $ color 226 + ml_n = withForeColor def $ color 202 + + --ph = if hasFocus then ph_y else ph_n + --ph_y = withForeColor def $ color 241 + --ph_n = withForeColor def $ color 235 + + color i = Color240 $ -16 + i + + + +partImage :: MessagePart -> Image +partImage p = case partContentType p of + "text/plain" -> + partContentImage $ partContent p + --string def (show $ partContent p) + "multipart/alternative" -> + partContentImage $ partContent p + "multipart/signed" -> + partContentImage $ partContent p + _ -> + mempty + + + +partTextLineImage :: String -> Image +partTextLineImage s = + string def s + + +--messageImage hasFocus m@Message{..} = +-- string c1 (unMessageID messageId) +-- <|> +-- translateX 1 ( +-- text' c2 (fromJust $ M.lookup "From" messageHeaders) +-- ) +-- <|> +-- translateX 1 ( +-- horizCat $ intersperse (string c1 ", ") $ map (text' c3) messageTags +-- ) +-- <-> +-- translateX 4 +-- (if "open" `elem` messageTags +-- then messageBodyImage m +-- else mempty) +-- +-- where +-- c1 = if hasFocus then c1_focus else c1_nofocus +-- c1_nofocus = withForeColor def $ Color240 $ -16 + 238 +-- c1_focus = withForeColor def $ Color240 $ -16 + 244 +-- c2 = withForeColor def $ Color240 $ -16 + 106 +-- c3 = withForeColor def $ Color240 $ -16 + 199 +-- +-- +-- +-- +--messageBodyImage = vertCat . map messagePartImage . messageBody +-- +--messagePartImage = partContentImage . partContent +-- + +partContentImage (ContentText t) = + vertCat $ map (text' def) $ T.lines t + +partContentImage (ContentMultipart parts) = + --string def "ContentMultipart" + vertCat $ map partImage parts + + +partContentImage (ContentMsgRFC822 _) = string def "ContentMsgRFC822" diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..4e369d2 --- /dev/null +++ b/default.nix @@ -0,0 +1,26 @@ +let + pkgs = import <nixpkgs> {}; + inherit (pkgs) callPackage; + hsEnv = pkgs.haskellPackages.ghcWithPackagesOld (hsPkgs : with hsPkgs; [ + dataDefault + vty + + # for NotmuchCmd + aeson + #blazeHtml + caseInsensitive + #conduit + #conduitExtra + process + ]); +in + pkgs.myEnvFun rec { + name = "much"; + buildInputs = with pkgs; [ + hsEnv + ]; + extraCmds = '' + export HISTFILE=/home/tv/.history/env-${name} + $(grep export ${hsEnv.outPath}/bin/ghc) + ''; + } @@ -0,0 +1,63 @@ +{ nixpkgs ? import <nixpkgs> {} }: + +let + name = "much"; + version = "1"; + + buildInputs = with pkgs; [ + hsEnv + ]; + + extraCmds = with pkgs; '' + export HISTFILE="\$HOME/.history/env-${name}" + $(grep export ${hsEnv.outPath}/bin/ghc) + ${mkExports staticPkgs} + ''; + + # ghcWithPackagesOld b/c terminfo collision + hsEnv = hsPkgs.ghcWithPackagesOld (self: with self; + terminfo.nativeBuildInputs ++ + [ + cabalInstall + dataDefault + vtyUi + + # for NotmuchCmd + aeson + #blazeHtml + caseInsensitive + #conduit + #conduitExtra + process + safe + ] + ); + + hsPkgs = pkgs.haskellPackages_ghc783_profiling.override { + extension = self: super: with self; { + #vty = callPackage ./nixpkgs/vty-5.2.5.nix { #{{{ + #}; #}}} + }; + }; + + pkgs = nixpkgs // staticPkgs; + staticPkgs = with nixpkgs; { + }; + + #{{{ mkExports : set -> string + # Create shell script that exports a set's attributes. + mkExports = set: with builtins; with pkgs.lib.strings; + let + # XXX attribute names are not escaped, they have to be sane + # XXX the value should not contain <newline> + mkExport = k: "export ${k}=${escapeSh (getAttr k set)}"; + escapeSh = stringAsChars (c: "\\${c}"); + in + concatStringsSep "\n" (map mkExport (attrNames set)); + #}}} + +in pkgs.myEnvFun { + name = "${name}-${version}"; + inherit buildInputs extraCmds; +} +# vim: set fdm=marker : diff --git a/nixpkgs/vty-5.2.5.nix b/nixpkgs/vty-5.2.5.nix new file mode 100644 index 0000000..6d552ed --- /dev/null +++ b/nixpkgs/vty-5.2.5.nix @@ -0,0 +1,34 @@ +# This file was auto-generated by cabal2nix. Please do NOT edit manually! + +{ cabal, blazeBuilder, Cabal, dataDefault, deepseq, filepath +, hashable, HUnit, lens, mtl, parallel, parsec, QuickCheck +, quickcheckAssertions, random, smallcheck, stringQq, terminfo +, testFramework, testFrameworkHunit, testFrameworkSmallcheck, text +, transformers, utf8String, vector +}: + +cabal.mkDerivation (self: { + pname = "vty"; + version = "5.2.5"; + sha256 = "15c49nzmkld4vcdmjbh0azlzsqrqmfb0z87zfixqxcl0bafpzrjy"; + isLibrary = true; + isExecutable = true; + buildDepends = [ + blazeBuilder dataDefault deepseq filepath hashable lens mtl + parallel parsec terminfo text transformers utf8String vector + ]; + testDepends = [ + blazeBuilder Cabal dataDefault deepseq HUnit lens mtl QuickCheck + quickcheckAssertions random smallcheck stringQq terminfo + testFramework testFrameworkHunit testFrameworkSmallcheck text + utf8String vector + ]; + meta = { + homepage = "https://github.com/coreyoconnor/vty"; + description = "A simple terminal UI library"; + license = self.stdenv.lib.licenses.bsd3; + platforms = self.ghc.meta.platforms; + }; + doCheck = false; + jailbreak = true; +}) diff --git a/test1.hs b/test1.hs new file mode 100644 index 0000000..43f3098 --- /dev/null +++ b/test1.hs @@ -0,0 +1,14 @@ +import Data.Default +import Graphics.Vty + + +main = do + vty <- mkVty def + let line0 = string (def withForeColor $ ISOColor 3) "first line" + line1 = string (def withBackColor blue) "second line" + img = line0 <-> line1 + pic = picForImage img + update vty pic + e <- nextEvent vty + shutdown vty + print $ "Last event was: " ++ show e diff --git a/test3.hs b/test3.hs new file mode 100644 index 0000000..3dfa036 --- /dev/null +++ b/test3.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} + + +import Data.Default +import Graphics.Vty + +--import Data.List + +--import Language.Haskell.TH.Ppr (bytesToString) +--import Data.Aeson +--import Data.List.Split +--import Data.Attoparsec.ByteString hiding (string) +--import Data.Maybe +--import Data.Monoid +--import Data.String +--import Data.Traversable +import Data.Tree +--import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +--import qualified Data.ByteString.Char8 as BS8 +--import qualified Data.Text.Lazy as TL +import qualified Data.Text as T +--import qualified Data.Text.Encoding as T +--import qualified Data.Text.IO as T +--import Data.Version (Version(..), parseVersion) +--import System.Process +--import System.IO +--import qualified Data.Map as M + +--import Notmuch.SearchResult +import Notmuch.Message +import Notmuch -- hiding (focusPrev, focusNext) +--import Safe + +import Control.Exception + +import ThreadView + + + + + + + + +--focusPrev t_cur t = do +-- i <- findIndex ((==t_cur) . messageId) msgs +-- m' <- msgs `atMay` (i - 1) +-- return $ messageId m' +-- where +-- msgs = flatten t +-- +--focusNext t_cur t = do +-- i <- findIndex ((==t_cur) . messageId) msgs +-- m' <- msgs `atMay` (i + 1) +-- return $ messageId m' +-- where +-- msgs = flatten t +-- +--focusMessage t_cur t = do +-- i <- findIndex ((==t_cur) . messageId) msgs +-- msgs `atMay` i +-- where +-- msgs = flatten t + + +toggleTag :: T.Text -> ThreadView -> IO () +toggleTag tag = \case + OpenMessage m -> f m + ClosedMessage m -> f m + _ -> return () + where + f m = do + _ <- if tag `elem` messageTags m + then + unsetTag tagString (unMessageID $ messageId m) + else + setTag tagString (unMessageID $ messageId m) + return () + tagString = T.unpack tag + + +--toggleTag tag t_cur t = +-- case focusMessage t_cur t of +-- Nothing -> return () +-- Just m -> do +-- if tag `elem` messageTags m +-- then +-- unsetTag tagString (unMessageID $ messageId m) +-- else +-- setTag tagString (unMessageID $ messageId m) +-- return () +-- where +-- tagString = T.unpack tag + +tagMessage :: T.Text -> Message -> IO LBS.ByteString +tagMessage tag m = + setTag (T.unpack tag) (unMessageID $ messageId m) + + +untagMessage :: T.Text -> Message -> IO LBS.ByteString +untagMessage tag m = + unsetTag (T.unpack tag) (unMessageID $ messageId m) + + + +main :: IO () +main = + bracket (mkVty def) finit run + where + + finit vty = do + shutdown vty + + run vty = do + t_ <- getThread tid + let v = fromMessageTree t_ + let c = findMessage (MessageID cid) v + rec vty 0 c v + + tid = "0000000000000862" + cid = "87egtmvj0n.fsf@write-only.cryp.to" + + --rec vty t_cur t = do + rec :: Vty -> Int -> Maybe ThreadView -> Tree ThreadView -> IO () + rec vty i c v = do + let --img = threadImage t_cur (fromMessageTree t) + img = + ( + string def (show i) + <|> + translateX 1 + ( + string def (maybe "Nothing" describe c) + ) + ) + <-> + threadImage c v + pic = picForImage img + up |