test4: initial emergency commit

2 files changed, 484 insertions, 0 deletions

diff --git a/TreeViewRaw.hs b/TreeViewRaw.hs
new file mode 100644
index 0000000..babd42d
--- /dev/null
+++ b/TreeViewRaw.hs
@@ -0,0 +1,204 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TreeViewRaw where
+
+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
+
+-- Maybe TreeView -> Tree TreeView -> Image
+--hPutTreeView h cur tv =
+--                treeImage (Just $ Z.label cursor) (Z.toTree cursor)
+
+renderTreeView :: TreeView -> Tree TreeView -> [String]
+renderTreeView cur _loc@(Node label children) =
+    [ colorize $ renderTreeView1 hasFocus label ] ++
+    concatMap (map ("  "++) . renderTreeView cur) children
+  where
+    hasFocus = cur == label
+    colorize s =
+        if hasFocus
+            then pp $ SGR [31] s
+            else pp s
+
+
+renderTreeView1 :: Bool -> TreeView -> Trammel String
+renderTreeView1 hasFocus = \case
+
+    TVSearch s ->
+        Plain s
+
+    TVSearchResult sr -> Plain $
+        (padl 11 ' ' $ T.unpack $ Notmuch.searchDateRel sr)
+        ++ "("
+        ++ (show $ Notmuch.searchMatched sr)
+        ++ ")  "
+        ++ (T.unpack $ Notmuch.searchSubject sr)
+        -- ++ " "
+        -- ++ (let Notmuch.ThreadID tid = Notmuch.searchThread sr in tid)
+
+    TVMessage m -> Plain $
+        (Notmuch.unMessageID $ Notmuch.messageId m)
+        ++ " "
+        ++ T.unpack (T.intercalate (T.pack ",") $ Notmuch.messageTags m)
+
+    TVMessageHeaderField m fieldName -> Plain $
+        let k = T.unpack $ CI.original fieldName
+            v = maybe "nothing"
+                      T.unpack
+                      (M.lookup fieldName $ Notmuch.messageHeaders m)
+        in k ++ ": " ++ v
+
+    TVMessagePart _ p -> Plain $
+        "part#"
+        ++ (show $ Notmuch.partID p)
+        ++ " "
+        ++ (T.unpack $ CI.original $ Notmuch.partContentType p)
+
+    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/test4.hs b/test4.hs
new file mode 100644
index 0000000..893d120
--- /dev/null
+++ b/test4.hs
@@ -0,0 +1,280 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Data.Maybe
+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 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
+    }
+
+
+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"
+              -- Move the cursor to the home position
+              hPutStr stdout "\ESC[H"
+              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
+        }
+
+
+run :: State -> IO ()
+run q = do
+
+    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 }
+
+
+redraw :: State -> IO ()
+redraw _q@State{..} = do
+
+    --putStrLn $ describe (Z.label cursor)
+    --putStr "\ESC[?2J"
+    putStr "\ESC[H"
+    --mapM_ putStr $ take screenHeight $ repeat "\ESC[2K\n"
+    --putStr "\ESC[H"
+
+    -- consumes 1 screenHeight
+    putStr $ "\ESC[2K" ++ flashMessage ++ " " ++ show (screenWidth, screenHeight)
+
+    mapM_ (putStr . ("\n\ESC[2K"++)) $
+        map (take screenWidth . drop xoffset) $
+        take (screenHeight - 1) $
+        drop yoffset $
+        renderTreeView (Z.label cursor) (Z.toTree cursor)
+
+
+
+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
+keymap "j" = Just moveCursorDown
+keymap "K" = Just moveTreeDown
+keymap "J" = Just moveTreeUp
+keymap "\ESC[A" = Just moveCursorUp
+keymap "\ESC[B" = Just moveCursorDown
+keymap "\ESC[a" = Just moveTreeDown
+keymap "\ESC[b" = Just moveTreeUp
+keymap "\n" = Just toggleFold
+
+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
+
+
+moveCursorDown q@State{..} =
+    return q { cursor = fromMaybe (Z.root cursor) $ findNext cursor }
+
+moveCursorUp q@State{..} =
+    return q { cursor = fromMaybe (Z.root cursor) $ findPrev cursor }
+
+moveTreeUp q@State{..} =
+    return q { yoffset = max 0 (yoffset + 1) }
+
+moveTreeDown q@State{..} =
+    return q { yoffset = max 0 (yoffset - 1) }
+
+
+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 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 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" ReadMode $ \nullH ->
+                    createProcess
+                        (proc "notmuch" [ "show", "--format=raw", "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
+
+
+
+
+
+
+
+withTempFile :: FilePath -> String -> ((FilePath, Handle) -> IO a) -> IO a
+withTempFile tmpdir template f = do
+    bracket (openTempFile tmpdir template) (removeFile . fst) f