purge a bit of legacy & cruft

There's still both around, though..^_^

7 files changed, 26 insertions, 993 deletions

diff --git a/TreeView.hs b/TreeView.hs
index ed91ce8..d1b0c95 100644
--- a/TreeView.hs
+++ b/TreeView.hs
@@ -2,34 +2,20 @@
 {-# LANGUAGE LambdaCase #-}
 
 
-module TreeView where
+module TreeView
+    ( TreeView (..)
+    , getMessage
+    , isTVSearchResult
+    , fromSearchResults
+    , fromMessageForest
+    , fromMessageTree
+    ) 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.CaseInsensitive as CI
 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 Data.Monoid
+import Data.Tree
 import Notmuch.Message
 import Notmuch.SearchResult
 
@@ -46,6 +32,7 @@ data TreeView
     | TVSearchResult SearchResult
   deriving (Show)
 
+
 instance Eq TreeView where
     TVMessage m1 == TVMessage m2 =
         m1 == m2
@@ -82,27 +69,6 @@ isTVSearchResult (TVSearchResult _) = True
 isTVSearchResult _ = False
 
 
-describe :: TreeView -> String
-describe (TVMessage m) = "TVMessage " <> unMessageID (messageId m)
-describe (TVMessageHeaderField m k) = "TVMessageHeaderField " <> unMessageID (messageId m) <> " " <> T.unpack (CI.original k)
-describe (TVMessagePart m p) = "TVMessagePart " <> (unMessageID $ messageId m) <> " " <> show (partID p)
-describe (TVMessageLine _ _ _ s) = "TVMessageLine " <> show s
-describe (TVSearch s) = "TVSearch " <> show s
-describe (TVSearchResult sr) = "TVSearchResult " <> show (searchTotal sr)
-
-
-findMessage :: MessageID -> Tree TreeView -> Maybe TreeView
-findMessage i =
-    find p . flatten
-  where
-    p (TVMessage m) = i == messageId m
-    p _ = False
-
-findTV :: TreeView -> Tree TreeView -> Maybe TreeView
-findTV x =
-    find (==x) . flatten
-
-
 fromSearchResults :: String -> [SearchResult] -> Tree TreeView
 fromSearchResults query =
     Node (TVSearch query) . map (\r -> Node (TVSearchResult r) [])
@@ -162,116 +128,3 @@ xconvLine
   :: Message -> MessagePart -> (LineNr, T.Text) -> Tree TreeView
 xconvLine m p (i, s) =
     Node (TVMessageLine m p i $ T.unpack s) []
-
-
-
-treeViewImage :: Bool -> TreeView -> Image
-treeViewImage hasFocus = \case
-    TVMessage m ->
-        let col = if isOpen m then om else cm
-        in
-        string col (unMessageID $ messageId m)
-        <|>
-        translateX 1 (
-          horizCat $
-              intersperse (string col ", ") $
-              map (text' tagColor) $
-              messageTags m
-        )
-
-    TVMessageHeaderField m fieldName ->
-        let k = string mhf $ T.unpack $ CI.original fieldName
-            v = maybe (string mhf_empty "nothing")
-                      (string mhf . T.unpack)
-                      (M.lookup fieldName $ messageHeaders m)
-        in k <|> string mhf ": " <|> v
-
-    TVMessagePart _ p ->
-        string mp "TVMessagePart"
-          <|> translateX 1 (string mp $ show $ partID p)
-          <|> translateX 1 (string mp $ show $ partContentType p)
-
-    TVMessageLine _ _ _ s ->
-        string ml s
-
-    TVSearch s ->
-        string sColor s
-
-    TVSearchResult sr -> do
-        --let ThreadID tid = searchThread sr
-        --string srColor tid
-        -- <|>
-        --translateX 1
-        (string srColor $ padl 11 ' ' $ T.unpack $ searchDateRel sr)
-        <|>
-        string srColor " ("
-        <|>
-        (string srColor $ show $ searchMatched sr)
-        <|>
-        string srColor ")"
-        <|>
-        string srColor "  "
-        -- <|>
-        -- (string srColor $ show $ searchTime sr)
-        <|>
-        (string srColor $ T.unpack $ searchSubject sr)
-        <|>
-        --(string srColor $ T.unpack $ searchThread sr)
-        (translateX 1 $ let ThreadID tid = searchThread sr in string srColor tid)
-        --string srColor tid
-  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
-
-    mhf = if hasFocus then mhf_y else mhf_n
-    mhf_y = withForeColor def $ color 248
-    mhf_n = withForeColor def $ color 244
-
-    mhf_empty = if hasFocus then mhf_empty_y else mhf_empty_n
-    mhf_empty_y = withForeColor def $ color 88
-    mhf_empty_n = withForeColor def $ color 52
-
-    --ph = if hasFocus then ph_y else ph_n
-    --ph_y = withForeColor def $ color 241
-    --ph_n = withForeColor def $ color 235
-
-    mp = if hasFocus then mp_y else mp_n
-    mp_y = withForeColor def $ color 199
-    mp_n = withForeColor def $ color 162
-
-    sColor = if hasFocus then sColor_y else sColor_n
-    sColor_y = withForeColor def $ color 196
-    sColor_n = withForeColor def $ color  88
-
-    srColor = if hasFocus then srColor_y else srColor_n
-    srColor_y = withForeColor def $ color 197
-    srColor_n = withForeColor def $ color  89
-
-    color i = Color240 $ -16 + i
-
-
-
-padl :: Int -> a -> [a] -> [a]
-padl n c s =
-    if length s < n
-        then padl n c (c:s)
-        else s
diff --git a/TreeViewRaw.hs b/TreeViewRaw.hs
index 114e75a..db4a899 100644
--- a/TreeViewRaw.hs
+++ b/TreeViewRaw.hs
@@ -1,19 +1,19 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module TreeViewRaw where
+module TreeViewRaw (renderTreeView) where
 
-import Data.Monoid
-import TreeView
-import Data.Tree
-import Trammel
-import qualified Notmuch
 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 Data.Monoid
+import Data.Tree
+import Trammel
+import TreeView
+import Utils (padl)
 
 
 renderTreeView :: TreeView -> Tree TreeView -> [Trammel String]
@@ -78,141 +78,3 @@ renderTreeView1 hasFocus = \case
 
     TVMessageLine _ _ _ s ->
         Plain s
-    -- | TVMessageLine Message MessagePart LineNr String
-
-
-    --TVMessage m ->
-    --    let col = if isOpen m then om else cm
-    --    in
-    --    string col (unMessageID $ messageId m)
-    --    <|>
-    --    translateX 1 (
-    --      horizCat $
-    --          intersperse (string col ", ") $
-    --          map (text' tagColor) $
-    --          messageTags m
-    --    )
-    s ->
-      Plain $ describe s
---        let col = if isOpen m then om else cm
---        in
---        string col (unMessageID $ messageId m)
---        <|>
---        translateX 1 (
---          horizCat $
---              intersperse (string col ", ") $
---              map (text' tagColor) $
---              messageTags m
---        )
-
-
---hPutTreeView h hasFocus = \case
---    TVMessage m ->
---        putStr
---    _ ->
-
-
-
---
---treeViewImage :: Bool -> TreeView -> Image
---treeViewImage hasFocus = \case
---    TVMessage m ->
---        let col = if isOpen m then om else cm
---        in
---        string col (unMessageID $ messageId m)
---        <|>
---        translateX 1 (
---          horizCat $
---              intersperse (string col ", ") $
---              map (text' tagColor) $
---              messageTags m
---        )
---
---    TVMessageHeaderField m fieldName ->
---        let k = string mhf $ T.unpack $ CI.original fieldName
---            v = maybe (string mhf_empty "nothing")
---                      (string mhf . T.unpack)
---                      (M.lookup fieldName $ messageHeaders m)
---        in k <|> string mhf ": " <|> v
---
---    TVMessagePart _ p ->
---        string mp "TVMessagePart"
---          <|> translateX 1 (string mp $ show $ partID p)
---          <|> translateX 1 (string mp $ show $ partContentType p)
---
---    TVMessageLine _ _ _ s ->
---        string ml s
---
---    TVSearch s ->
---        string sColor s
---
---    TVSearchResult sr -> do
---        --let ThreadID tid = searchThread sr
---        --string srColor tid
---        -- <|>
---        --translateX 1
---        (string srColor $ padl 11 ' ' $ T.unpack $ searchDateRel sr)
---        <|>
---        string srColor " ("
---        <|>
---        (string srColor $ show $ searchMatched sr)
---        <|>
---        string srColor ")"
---        <|>
---        string srColor "  "
---        -- <|>
---        -- (string srColor $ show $ searchTime sr)
---        <|>
---        (string srColor $ T.unpack $ searchSubject sr)
---        <|>
---        --(string srColor $ T.unpack $ searchThread sr)
---        (translateX 1 $ let ThreadID tid = searchThread sr in string srColor tid)
---        --string srColor tid
---  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
---
---    mhf = if hasFocus then mhf_y else mhf_n
---    mhf_y = withForeColor def $ color 248
---    mhf_n = withForeColor def $ color 244
---
---    mhf_empty = if hasFocus then mhf_empty_y else mhf_empty_n
---    mhf_empty_y = withForeColor def $ color 88
---    mhf_empty_n = withForeColor def $ color 52
---
---    --ph = if hasFocus then ph_y else ph_n
---    --ph_y = withForeColor def $ color 241
---    --ph_n = withForeColor def $ color 235
---
---    mp = if hasFocus then mp_y else mp_n
---    mp_y = withForeColor def $ color 199
---    mp_n = withForeColor def $ color 162
---
---    sColor = if hasFocus then sColor_y else sColor_n
---    sColor_y = withForeColor def $ color 196
---    sColor_n = withForeColor def $ color  88
---
---    srColor = if hasFocus then srColor_y else srColor_n
---    srColor_y = withForeColor def $ color 197
---    srColor_n = withForeColor def $ color  89
---
---    color i = Color240 $ -16 + i
diff --git a/Utils.hs b/Utils.hs
index 2ccf4f7..8d1f624 100644
--- a/Utils.hs
+++ b/Utils.hs
@@ -14,3 +14,10 @@ withTempFile tmpdir template =
 mintercalate :: Monoid b => b -> [b] -> b
 mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t
 mintercalate _ [] = mempty
+
+
+padl :: Int -> a -> [a] -> [a]
+padl n c s =
+    if length s < n
+        then padl n c (c:s)
+        else s
diff --git a/test1.hs b/test1.hs
deleted file mode 100644
index 43f3098..0000000
--- a/test1.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-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
deleted file mode 100644
index 16bbe61..0000000
--- a/test3.hs
+++ /dev/null
@@ -1,323 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE LambdaCase #-}
-
-
-import Data.Default
-import Graphics.Vty
-
---import Data.List
-
-import Control.Applicative
---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.Tree.Zipper as Z
---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 System.Environment
-import Notmuch
-import Notmuch.Message
-import Notmuch.SearchResult
---import Safe
-
-import Control.Exception
-
-import TreeView
-
-import TreeSearch
---import Editor (edit)
-import System.Process
-import System.Environment
-import qualified Data.ByteString.Lazy as LBS
-import System.IO
-import System.Directory
-import Control.Exception (bracket)
-import Control.Exception
-import System.IO
-import Control.DeepSeq (rnf)
-
-
-data State = State
-    { vty :: Vty
-    , cursor :: Z.TreePos Z.Full TreeView
-    , xoffset :: Int
-    , yoffset :: Int
-    , message :: String
-    }
-
-
-toggleTag :: T.Text -> Message -> IO ()
-toggleTag tag 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 =
-    main' "tag:inbox AND NOT tag:killed"
-
-main' :: String -> IO ()
-main' query = do
-    setEnv "HOME" "/home/tv"
-    bracket (mkVty def) finit run
-  where
-
-    finit vty = do
-        shutdown vty
-
-    run vty0 = do
-        --XXX show a single thread
-        --t_ <- getThread "0000000000000862"
-        --let v = fromMessageTree t_
-        --let c = findMessage (MessageID "87egtmvj0n.fsf@write-only.cryp.to") v
-        --rec vty 0 c v
-
-        r_ <- either error id <$> search query
-        rec State
-            { vty = vty0
-            , cursor = Z.fromTree $ fromSearchResults query r_
-            , xoffset = 0
-            , yoffset = 0
-            , message = "Welcome to much; quit with ^C"
-            }
-
-    rec :: State -> IO ()
-    rec q0@State{..} = do
-        let
-            img =
-                --string def (show i) <->
-                --string def (maybe "Nothing" describe (focusPrev v cursor)) <->
-                --string def (maybe "Nothing" describe cursor) <->
-                --string def (maybe "Nothing" describe (focusNext v cursor)) <->
-                --string def (maybe "Nothing" describe (focusPrev v cursor)) <->
-                --string def (describe $ Z.label cursor) <->
-                --string def (maybe "Nothing" describe (focusNext v cursor)) <->
-                treeImage (Just $ Z.label cursor) (Z.toTree cursor)
-                --renderTree q
-            pic = picForImage $
-                    (string def message) <->
-                    translate xoffset yoffset img
-            --v = Z.root cursor
-        update vty pic
-        nextEvent vty >>= \e -> case e of
-            EvKey KEsc [] ->
-                rec q
-
-            EvKey (KChar 'c') [MCtrl] ->
-                error "^C"
-
-            EvKey (KChar 'k') [] ->
-                rec q { cursor = fromMaybe (Z.root cursor) $ findPrev cursor }
-            EvKey (KChar 'j') [] ->
-                rec q { cursor = fromMaybe (Z.root cursor) $ findNext cursor }
-            EvKey KEnter [] ->
-                onEnter cursor
-
-            EvKey (KChar 'H') [] -> rec q { xoffset = xoffset - 3 }
-            EvKey (KChar 'L') [] -> rec q { xoffset = xoffset + 3 }
-            EvKey (KChar 'J') [] -> rec q { yoffset = yoffset - 3 }
-            EvKey (KChar 'K') [] -> rec q { yoffset = yoffset + 3 }
-
-            EvKey (KChar 'r') [] ->
-                case getMessage (Z.label cursor) of
-                    Just m -> do
-                        replyToAll m q >>= rec
-                    Nothing ->
-                        rec q { message = "no message" }
-                --reply ToAll q >>= \case
-                --    Left s -> rec q { message = s }
-                --    Right () -> rec q
-
-            EvResize _w _h ->
-                rec q
-
-            _ -> do
-                rec q { message = "unbound key: " ++ show e }
-      where
-
-        q = q0 { message = "" }
-
-        onEnter c_ = case Z.label c_ of
-            TVMessage m -> do
-                toggleTag "open" m
-
-                let loc = cursor
-                    Just sr = findParent isTVSearchResult loc
-                    --Just sr0 = Z.firstChild sr -- TODO can there be only one (thread per sr)?
-                    TVSearchResult the_sr = Z.label sr
-                    ThreadID tid = searchThread the_sr
-
-                t_ <- return . fromMessageForest =<< getThread tid
-
-                let loc' = Z.modifyTree (\(Node l _) -> Node l t_) sr
-                rec q { cursor = select (==Z.label cursor) loc' }
-
-            TVSearchResult sr -> do
-                --let Just loc = findTree (==c_) $ Z.fromTree v
-                let loc = cursor
-
-                let open = not $ null $ subForest $ Z.tree loc
-                let ThreadID tid = searchThread sr
-
-                t_ <-
-                    if open
-                        then return []
-                        else return . fromMessageForest =<< getThread tid
-
-                let loc' = Z.modifyTree (\(Node l _) -> Node l t_) loc
-                rec q { cursor = select (==Z.label cursor) loc' }
-
-            _ ->
-                -- TODO make some noise
-                rec q
-
-
-select :: (a -> Bool) -> Z.TreePos Z.Full a -> Z.TreePos Z.Full a
-select p loc = fromMaybe (error "cannot select") $ findTree p $ Z.root loc
-
-
-treeImage :: Maybe TreeView -> Tree TreeView -> Image
-treeImage c (Node n ns) =
-    treeViewImage (c == Just n) n <->
-    translateX 2 (vertCat $ map (treeImage c) ns)
-
-
---reply :: ReplyTo -> State -> IO (Either String ())
---reply replyTo _q@State{..} =
---    case getMessage (Z.label cursor) of
---        Just Message{..} -> do
---            x <- notmuchReply replyTo ("id:" <> unMessageID messageId)
---            edit x
---            return $ Right ()
---        Nothing ->
---            return $ Left "no message"
-
---edit :: LBS.ByteString -> IO ()
---edit draft = do
---    editor <- getEnv "EDITOR"
---    logname <- getEnv "LOGNAME"
---    tmpdir <- getTemporaryDirectory
---
---    let template = logname ++ "_much_draft_XXX.email"
---
---    bracket (openTempFile tmpdir template) cleanup $ \(path, h) -> do
---        LBS.hPut h draft
---        hClose h
---        --hFlush h
---        system (editor ++ " " ++ path)
---        return ()
---  where
---    cleanup (path, h) = do
---        removeFile path
---        hClose h
-
-replyToAll Message{..} q = do
-    editor <- getEnv "EDITOR"
-    logname <- getEnv "LOGNAME"
-    tmpdir <- getTemporaryDirectory
-
-    let template = logname ++ "_much_draft_XXX.email"
-
-    bracket (openTempFile tmpdir template) cleanup $ \(path, draftH) -> do
-        (_, _, _, procH) <-
-            withFile "/dev/null" ReadMode $ \devnull ->
-                createProcess
-                    (proc "notmuch" [ "reply" , "id:" <> unMessageID messageId ])
-                        { std_in = UseHandle devnull
-                        , std_out = UseHandle draftH
-                        }
-        hClose draftH
-        waitForProcess procH
-        code <- system (editor ++ " " ++ path)
-        return q { message = show code }
-  where
-    cleanup = removeFile . fst
-
-
-replyToAll2 = do
-    editor <- getEnv "EDITOR"
-    logname <- getEnv "LOGNAME"
-    tmpdir <- getTemporaryDirectory
-
-    let template = logname ++ "_much_draft_XXX.email"
-
-    let msgId = "20141227121335.701B43F@mx2.informatik.uni-stuttgart.de"
-
-    bracket (openTempFile tmpdir template) cleanup $ \(path, draftH) -> do
-        (_, _, _, procH) <-
-            withFile "/dev/null" ReadMode $ \devnull ->
-                createProcess
-                    (proc "notmuch" [ "reply" , "id:" <> msgId ])
-                        { std_in = UseHandle devnull
-                        , std_out = UseHandle draftH
-                        }
-        hClose draftH
-        waitForProcess procH
-        code <- system (editor ++ " " ++ path)
-        print code
-        --return q { message = show code }
-  where
-    cleanup = removeFile . fst
-
-
-
---    (_, 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
diff --git a/test4.hs b/test4.hs
deleted file mode 100644
index d9a2e74..0000000
--- a/test4.hs
+++ /dev/null
@@ -1,352 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-
-import Control.Applicative
-import Control.Exception
-import Data.Maybe
-import Data.Monoid
-import Scanner (scan, runScanner, toChar)
-import System.Directory
-import System.Environment
-import System.Exit
-import System.IO
-import System.Posix.Files
-import System.Posix.Signals
-import System.Process
-import Trammel
-import TreeSearch
-import TreeView
-import TreeViewRaw
-import qualified Notmuch
-import qualified Notmuch.Message as Notmuch
-import qualified Notmuch.SearchResult as Notmuch
-import qualified Data.Tree.Zipper as Z
-import qualified Data.Tree as Tree
-import qualified Data.Text as T
-
-
-data State = State
-    { charge :: IO ()
-    , discharge :: IO ()
-    , cursor :: Z.TreePos Z.Full TreeView
-    , xoffset :: Int
-    , yoffset :: Int
-    , flashMessage :: String
-    , screenWidth :: Int
-    , screenHeight :: Int
-    , headBuffer :: [Trammel String]
-    , treeBuffer :: [Trammel String]
-    }
-
-
-main :: IO ()
-main = do
-    setEnv "HOME" =<< getEnv "OLDHOME"
-
-    q@State{..} <- initState
-    bracket_ charge discharge $ do
-        winchHandler
-        run q
-
-
-initState :: IO State
-initState = do
-
-    let query = "tag:inbox AND NOT tag:killed"
-
-    r_ <- either error id <$> Notmuch.search query
-
-    echo0 <- hGetEcho stdin
-    buffering0 <- hGetBuffering stdin
-    return State
-        { charge = do
-              _ <- installHandler 28 (Catch winchHandler) Nothing
-              hSetEcho stdin False
-              hSetBuffering stdin NoBuffering
-              -- Save Cursor and use Alternate Screen Buffer
-              hPutStr stdout "\ESC[?1049h"
-              -- Hide Cursor
-              hPutStr stdout "\ESC[?25l"
-              hFlush stdout
-        , discharge = do
-              _ <- installHandler 28 Default Nothing
-              hSetEcho stdin echo0
-              hSetBuffering stdin buffering0
-              -- Use Normal Screen Buffer and restore Cursor
-              hPutStr stdout "\ESC[?1049l"
-              hFlush stdout
-        , cursor = Z.fromTree $ fromSearchResults query r_
-        , xoffset = 0
-        , yoffset = 0
-        , flashMessage = "Welcome to much; quit with ^C"
-        , screenWidth = 0
-        , screenHeight = 0
-        , headBuffer = []
-        , treeBuffer = []
-        }
-
-
-run :: State -> IO ()
-run q0 = do
-    let q = render q0
-
-    redraw q
-
-    _ <- hLookAhead stdin -- wait for input
-    ((_, s), _) <- runScanner scan
-
-    case keymap (map toChar s) of
-        Just a ->
-            a q >>= run
-        Nothing ->
-            run q { flashMessage = show $ map toChar s }
-
-
-render :: State -> State
-render q@State{..} =
-    q { treeBuffer = newTreeBuf
-      , headBuffer = newHeadBuf
-      }
-  where
-    newTreeBuf = renderTreeView (Z.label cursor) (Z.toTree cursor)
-    newHeadBuf =
-        [ Plain (show screenWidth) <> "x" <> Plain (show screenHeight)
-          <> " " <> Plain (show $ linearPos cursor - yoffset)
-          <> " " <> Plain (show $ topOverrun q)
-          <> " " <> Plain (show $ botOverrun q)
-          <> " " <> Plain flashMessage
-        ]
-
-
-
-redraw :: State -> IO ()
-redraw _q@State{..} = do
-
-    let image =
-            map (fmap $ fmap $ sub '\t' ' ') $
-            map (trammelTake screenWidth . trammelDrop xoffset) $
-            take screenHeight $
-            headBuffer ++ drop yoffset treeBuffer
-        screen =
-            image ++ take (screenHeight - length image) (repeat "~")
-
-    case map (<>"\ESC[K") screen of
-      (first : rest) ->
-          putStr $ pp $ "\ESC[H" <> first <> mconcat (map ("\n"<>) rest)
-      _ ->
-          return ()
-  where
-    sub x x' c = if c == x then x' else c
-
-
-
-winchHandler :: IO ()
-winchHandler = do
-    -- Report the size of the screen in characters.
-    -- Result is CSI 9 ; height ; width t
-    putStr "\ESC[19t"
-
-
-keymap :: String -> Maybe (State -> IO State)
-
-keymap "r" = Just replyToAll
-keymap "e" = Just viewSource
-keymap "k" = Just $ moveCursorUp 1
-keymap "j" = Just $ moveCursorDown 1
-keymap "K" = Just $ moveTreeDown 1
-keymap "J" = Just $ moveTreeUp 1
-keymap "\ESC[A" = Just $ moveCursorUp 1
-keymap "\ESC[B" = Just $ moveCursorDown 1
-keymap "\ESC[a" = Just $ moveTreeDown 1
-keymap "\ESC[b" = Just $ moveTreeUp 1
-keymap "\ESC[5~" = Just $ \q -> moveTreeDown (screenHeight q `div` 2) q   -- PgUp
-keymap "\ESC[6~" = Just $ \q -> moveTreeUp (screenHeight q `div` 2) q -- PgDn
-keymap "\n" = Just toggleFold
-keymap "\DEL" = Just moveToParent -- backspace
-
-keymap ('\ESC':'[':'9':';':xs) = Just $ \q@State{..} -> do
-    let (h,';':w) = break (==';') (take (length xs - 1) xs) -- ^ drop (assumed) trailing 't'
-    return q { screenWidth = read w, screenHeight = read h }
-keymap _ = Nothing
-
-
-
-topOverrun :: State -> Int
-topOverrun State{..} =
-    max 0 (- (linearPos cursor - yoffset))
-
-
-botOverrun :: State -> Int
-botOverrun State{..} =
-    max 0 (linearPos cursor - yoffset - (screenHeight - (length headBuffer) - 1))
-
-
-
-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'
-
-
-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'
-
-
-toggleFold :: State -> IO State
-toggleFold q@State{..} = case Z.label cursor of
-    TVMessage m -> do
-        toggleTag (T.pack "open") m
-
-        let Just sr = findParent isTVSearchResult cursor
-            TVSearchResult the_sr = Z.label sr
-            Notmuch.ThreadID tid = Notmuch.searchThread the_sr
-
-        t_ <- return . fromMessageForest =<< Notmuch.getThread tid
-
-        let cursor' = Z.modifyTree (\(Tree.Node l _) -> Tree.Node l t_) sr
-        return q { cursor = select (==Z.label cursor) cursor' }
-
-    TVSearchResult sr -> do
-        let open = not $ null $ Tree.subForest $ Z.tree cursor
-        let Notmuch.ThreadID tid = Notmuch.searchThread sr
-
-        t_ <-
-            if open
-                then return []
-                else return . fromMessageForest =<< Notmuch.getThread tid
-
-        let cursor' = Z.modifyTree (\(Tree.Node l _) -> Tree.Node l t_) cursor
-        return q { cursor = select (==Z.label cursor) cursor' }
-
-    _ ->
-        return q { flashMessage = "nothing happened" }
-  where
-    select p loc = fromMaybe (error "cannot select") $ findTree p $ Z.root loc
-
-    toggleTag :: T.Text -> Notmuch.Message -> IO ()
-    toggleTag tag m = do
-        _ <- if tag `elem` Notmuch.messageTags m
-            then
-                Notmuch.unsetTag tagString (Notmuch.unMessageID $ Notmuch.messageId m)
-            else
-                Notmuch.setTag tagString (Notmuch.unMessageID $ Notmuch.messageId m)
-        return ()
-      where
-        tagString = T.unpack tag
-
-
-
-
-replyToAll :: State -> IO State
-replyToAll q@State{..} = case getMessage (Z.label cursor) of
-    Nothing ->
-        return q { flashMessage = "no message" }
-    Just m -> do
-        editor <- getEnv "EDITOR"
-        logname <- getEnv "LOGNAME"
-        tmpdir <- getTemporaryDirectory
-
-
-        let template = logname ++ "_much_draft_.mail"
-
-        let msgId = Notmuch.unMessageID $ Notmuch.messageId m
-
-        withTempFile tmpdir template $ \(path, draftH) -> do
-            (_, _, _, procH) <-
-                withFile "/dev/null" ReadMode $ \nullH ->
-                    createProcess
-                        (proc "notmuch" [ "reply" , "id:" ++ msgId ])
-                            { std_in = UseHandle nullH
-                            , std_out = UseHandle draftH
-                            }
-            hClose draftH
-            waitForProcess procH >>= \case
-                ExitFailure code ->
-                    putStrLn $ "notmuch exit code = " ++ show code
-                ExitSuccess ->
-                    finally (system $ editor ++ " " ++ path) charge >>= \case
-                        ExitFailure code ->
-                            putStrLn $ editor ++ " exit code = " ++ show code
-                        ExitSuccess ->
-                            return ()
-        return q
-
-
-viewSource :: State -> IO State
-viewSource q@State{..} = case getMessage (Z.label cursor) of
-    Nothing ->
-        return q { flashMessage = "no message" }
-    Just m -> do
-        editor <- getEnv "EDITOR"
-        logname <- getEnv "LOGNAME"
-        tmpdir <- getTemporaryDirectory
-
-        let template = logname ++ "_much_raw_.mail"
-
-        let msgId = Notmuch.unMessageID $ Notmuch.messageId m
-
-        withTempFile tmpdir template $ \(path, draftH) -> do
-            setFileMode path 0o400
-            (_, _, _, procH) <-
-                withFile "/dev/null" ReadM