diff options
Diffstat (limited to 'src/Much/Core.hs')
| -rw-r--r-- | src/Much/Core.hs | 216 |
1 files changed, 216 insertions, 0 deletions
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 |