tv config: use Core

1 files changed, 83 insertions, 255 deletions

diff --git a/config/tv.hs b/config/tv.hs
index f3012b9..b2ff124 100644
--- a/config/tv.hs
+++ b/config/tv.hs
@@ -2,278 +2,86 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
-module Main (main, mainWithArgs) where
+module Main (main) where
 
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy.Char8 as LBS8
-import           Data.CaseInsensitive   (CI)
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import qualified Data.Tree as Tree
-import qualified Data.Tree.Zipper as Z
-import qualified Network.Mail.Mime as M
-import qualified Notmuch
-import qualified Notmuch.Message as Notmuch
-import qualified Notmuch.SearchResult as Notmuch
-import qualified System.Console.Terminal.Size as Term
-import Blessings.String (Blessings(Plain,SGR),pp)
-import qualified Blessings.Internal as Blessings
 import Action
+import Blessings.String
 import Control.Concurrent
+import Control.DeepSeq (rnf)
 import Control.Exception
 import Control.Monad
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except
+import Core
 import Data.Aeson (eitherDecode')
+import Data.CaseInsensitive (CI)
 import Data.Foldable (foldrM)
 import Data.List (intercalate)
 import Data.Maybe
 import Data.Time
-import Event
 import ParseMail (readMail)
-import RenderTreeView (renderTreeView)
-import Scanner (scan,Scan(..))
-import Screen
 import Safe
+import Scanner
 import State
 import System.Directory
-import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption)
 import System.Environment
 import System.Exit
 import System.IO
-import System.Posix.Signals
 import System.Process
 import TagUtils
 import Text.Hyphenation
 import Text.LineBreak
 import TreeSearch
 import TreeView
-import TreeZipperUtils (modifyFirstParentLabelWhere)
 import Utils
-
-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
-
-
-initState :: String -> IO State
-initState query = do
-    r_ <- either error id <$> Notmuch.search
-                                [ "--offset=0"
-                                , "--limit=100"
-                                , query
-                                ]
-
-    return State
-        { cursor = Z.fromTree $ fromSearchResults query r_
-        , 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 = []
-        }
-
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy.Char8 as LBS8
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Data.Tree as Tree
+import qualified Data.Tree.Zipper as Z
+import qualified Network.Mail.Mime as M
+import qualified Notmuch
+import qualified Notmuch.Message as Notmuch
+import qualified Notmuch.SearchResult as Notmuch
 
 main :: IO ()
 main =
-    getArgs >>= mainWithArgs
-
-
-mainWithArgs :: [String] -> IO ()
-mainWithArgs args = do
-    usage' <- parseUsageOrExit usage
-    args' <- parseArgsOrExit usage' args
-    let query = getArgWithDefault args' defaultSearch (shortOption 'q')
-    withScreen s0 (\_-> initState 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)
-      ]
-    defaultSearch = "tag:inbox AND NOT tag:killed"
-
-    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)
-
-withoutHandlers :: (State -> IO State) -> State -> IO State
-withoutHandlers f q@State{..} =
-    bracket_ (uninstallHandlers signalHandlers)
-             (installHandlers signalHandlers)
-             (f q)
-
-
-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 s q
-    EScan info@ScanMouse{..} ->
-        Right <$> mousemap 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
+    mainWithState emptyState
+      { keymap = myKeymap
+      , mousemap = myMousemap
       }
-  where
-    newTreeBuf = renderTreeView now cursor (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 ++ take (screenHeight - length buffer) (repeat "~")
-
-
-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
-
-
-
-
-keymap :: String -> State -> IO State
-
-keymap "A" = attachFilesToDraft
-keymap "a" = toggleTagAtCursor "inbox"
-keymap "s" = toggleTagAtCursor "unread"
-keymap "&" = toggleTagAtCursor "killed"
-keymap "*" = toggleTagAtCursor "star"
-keymap "r" = replyToAll
-keymap "e" = withoutHandlers viewSource
-keymap "t" = withoutHandlers editTagsAtCursor
-keymap "k" = moveCursorUp 1
-keymap "j" = moveCursorDown 1
-keymap "K" = moveTreeDown 1
-keymap "J" = moveTreeUp 1
-keymap "\ESC[A" = moveCursorUp 1
-keymap "\ESC[B" = moveCursorDown 1
-keymap "\ESC[a" = moveTreeDown 1
-keymap "\ESC[b" = moveTreeUp 1
-keymap "\ESC[c" = moveTreeLeft 1  -- S-Right
-keymap "\ESC[d" = moveTreeRight 1 -- S-Left
-keymap "\ESC[5~" = \q -> moveTreeDown (screenHeight q `div` 2) q  -- PgUp
-keymap "\ESC[6~" = \q -> moveTreeUp (screenHeight q `div` 2) q    -- PgDn
-keymap "\n" = toggleFold
-keymap "\ESC[Z" = moveCursorUpToPrevUnread -- S-Tab
-keymap "\t" = moveCursorDownToNextUnread
-keymap "\DEL" = moveToParent  -- backspace
+
+myKeymap :: String -> State -> IO State
+
+myKeymap "A" = attachFilesToDraft
+myKeymap "a" = toggleTagAtCursor "inbox"
+myKeymap "s" = toggleTagAtCursor "unread"
+myKeymap "&" = toggleTagAtCursor "killed"
+myKeymap "*" = toggleTagAtCursor "star"
+myKeymap "r" = replyToAll
+myKeymap "e" = withoutHandlers viewSource
+myKeymap "t" = withoutHandlers editTagsAtCursor
+myKeymap "k" = moveCursorUp 1
+myKeymap "j" = moveCursorDown 1
+myKeymap "K" = moveTreeDown 1
+myKeymap "J" = moveTreeUp 1
+myKeymap "\ESC[A" = moveCursorUp 1
+myKeymap "\ESC[B" = moveCursorDown 1
+myKeymap "\ESC[a" = moveTreeDown 1
+myKeymap "\ESC[b" = moveTreeUp 1
+myKeymap "\ESC[c" = moveTreeLeft 1  -- S-Right
+myKeymap "\ESC[d" = moveTreeRight 1 -- S-Left
+myKeymap "\ESC[5~" = \q -> moveTreeDown (screenHeight q `div` 2) q  -- PgUp
+myKeymap "\ESC[6~" = \q -> moveTreeUp (screenHeight q `div` 2) q    -- PgDn
+myKeymap "\n" = toggleFold
+myKeymap "\ESC[Z" = moveCursorUpToPrevUnread -- S-Tab
+myKeymap "\t" = moveCursorDownToNextUnread
+myKeymap "\DEL" = moveToParent  -- backspace
 
 -- TODO wrap/unwrap to separate module
-keymap "=" = \q@State{..} ->
+myKeymap "=" = \q@State{..} ->
     let cursor' = case Z.label cursor of
             TVMessageLine a b c s ->
                 wrap (TVMessageLine a b c) cursor s
@@ -304,14 +112,14 @@ keymap "=" = \q@State{..} ->
         hyp = Just german_1996
         bf = BreakFormat 80 8 shy hyp
 
-keymap "\ESCq" = editSearchTerm
+myKeymap "\ESCq" = editSearchTerm
 
 -- <F1>
-keymap "\ESC[11~" = \q@State{..} ->
+myKeymap "\ESC[11~" = \q@State{..} ->
     return q { flashMessage = Plain $ show $ treeViewId $ Z.label cursor }
 
 -- <F2>
-keymap "\ESC[12~" = \q@State{..} ->
+myKeymap "\ESC[12~" = \q@State{..} ->
     return q { flashMessage =
                   Plain $
                   show $
@@ -321,22 +129,42 @@ keymap "\ESC[12~" = \q@State{..} ->
               }
 
 -- TODO Stuff Vim sends after exit (also there is more...)
-keymap "\ESC[2;2R" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
-keymap "\ESC[>85;95;0c" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
+myKeymap "\ESC[2;2R" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
+myKeymap "\ESC[>85;95;0c" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
 
-keymap s = \q ->
-    return q { flashMessage = Plain $ show s }
+myKeymap s = displayKey s
 
 
-mousemap :: Scan -> State -> IO State
+myMousemap :: Scan -> State -> IO State
+myMousemap ScanMouse{mouseButton=1,mouseY=y} = defaultMouse1Click y
+myMousemap ScanMouse{mouseButton=3,mouseY=y} = \q -> defaultMouse1Click y q >>= toggleFold
+myMousemap ScanMouse{mouseButton=4} = moveTreeDown 3
+myMousemap ScanMouse{mouseButton=5} = moveTreeUp 3
+myMousemap ScanMouse{mouseButton=0} = return
+myMousemap info = displayMouse info
 
-mousemap ScanMouse{mouseButton=1,mouseY=y} = defaultMouse1Click y
-mousemap ScanMouse{mouseButton=3,mouseY=y} = \q -> defaultMouse1Click y q >>= toggleFold
-mousemap ScanMouse{mouseButton=4} = moveTreeDown 3
-mousemap ScanMouse{mouseButton=5} = moveTreeUp 3
-mousemap ScanMouse{mouseButton=0} = return
-mousemap info = \q ->
-    return q { flashMessage = SGR [38,5,202] $ Plain $ show info }
+
+withoutHandlers :: (State -> IO State) -> State -> IO State
+withoutHandlers f q@State{..} =
+    bracket_ (uninstallHandlers signalHandlers)
+             (installHandlers signalHandlers)
+             (f q)
+
+
+-- | 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
 
 
 attachFilesToDraft :: State -> IO State