summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-12-19 20:42:38 +0100
committertv <tv@shackspace.de>2014-12-19 20:42:38 +0100
commit4299cd382b10947a8a79e586f95d38823aaa9597 (patch)
tree86bb8127d0c2a72932baca9d1aa2826ea1d4dd77
initial commit
-rw-r--r--Notmuch.hs323
-rw-r--r--Notmuch/Message.hs115
-rw-r--r--Notmuch/SearchResult.hs51
-rw-r--r--README2
-rw-r--r--ThreadView.hs286
-rw-r--r--default.nix26
-rw-r--r--env.nix63
-rw-r--r--nixpkgs/vty-5.2.5.nix34
-rw-r--r--test1.hs14
-rw-r--r--test3.hs273
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
+-- ]
diff --git a/README b/README
new file mode 100644
index 0000000..6b41646
--- /dev/null
+++ b/README
@@ -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)
+ '';
+ }
diff --git a/env.nix b/env.nix
new file mode 100644
index 0000000..2a11b70
--- /dev/null
+++ b/env.nix
@@ -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 = fromMe