initial commit

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 = 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 ()