From 8e92e6e11d2b3b0bfb5ac9d68f347219493e6380 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Wed, 23 Sep 2020 17:44:40 +0200 Subject: split into library + executables --- Core.hs | 216 ---------------------------------------------------------------- 1 file changed, 216 deletions(-) delete mode 100644 Core.hs (limited to 'Core.hs') diff --git a/Core.hs b/Core.hs deleted file mode 100644 index 5971769..0000000 --- a/Core.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Core where - -import Action -import Blessings.String (Blessings(Plain,SGR),pp) -import Control.Concurrent -import Control.Monad -import Data.Time -import Event -import RenderTreeView (renderTreeView) -import Scanner (scan,Scan(..)) -import Screen -import State -import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption) -import System.Environment -import System.IO -import System.Posix.Signals -import TreeSearch -import TreeView -import 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 "") []) - , 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 ]" - , "" - , "Options:" - , " -q , --query=" - , " 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 -- cgit v1.2.3