15 files changed, 1729 insertions, 0 deletions

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 "<emptyState>") [])
+    , 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 <search-term>]"
+      , ""
+      , "Options:"
+      , "  -q <search-term>, --query=<search-term>"
+      , "        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*<any CHAR except specials, SPACE and CTLs>
+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       =  <any CHAR excluding "[",     ; => 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       =  <any CHAR excepting <">,     ; => 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