diff --git a/pkg/king/lib/Arvo/Event.hs b/pkg/king/lib/Arvo/Event.hs index e35b8ab12a..51ffc2417d 100644 --- a/pkg/king/lib/Arvo/Event.hs +++ b/pkg/king/lib/Arvo/Event.hs @@ -5,8 +5,8 @@ import UrbitPrelude hiding (Term) import Arvo.Common (KingId(..), ServId(..)) import Arvo.Common (NounMap, NounSet) import Arvo.Common (Desk, Mime) -import Arvo.Common (HttpEvent, Header(..)) -import Arvo.Common (Ipv4, Ipv6, Port, Turf, AmesDest) +import Arvo.Common (Header(..), HttpEvent) +import Arvo.Common (AmesDest, Ipv4, Ipv6, Port, Turf) import Arvo.Common (ReOrg(..), reorgThroughNoun) import qualified Network.HTTP.Types.Method as H @@ -299,3 +299,26 @@ instance FromNoun Ev where ReOrg "" s t p v -> fmap EvBlip $ parseNoun $ toNoun (s,t,p,v) ReOrg "vane" s t p v -> fmap EvVane $ parseNoun $ toNoun (s,t,p,v) ReOrg _ _ _ _ _ -> fail "First path-elem must be ?($ %vane)" + +-- Short Event Names ----------------------------------------------------------- + +getSpinnerNameForEvent :: Ev -> Maybe String +getSpinnerNameForEvent = \case + EvVane _ -> Nothing + EvBlip b -> case b of + BlipEvAmes _ -> Just "ames" + BlipEvArvo _ -> Just "arvo" + BlipEvBehn _ -> Just "behn" + BlipEvBoat _ -> Just "boat" + BlipEvHttpClient _ -> Just "iris" + BlipEvHttpServer _ -> Just "eyre" + BlipEvNewt _ -> Just "newt" + BlipEvSync _ -> Just "clay" + BlipEvTerm t -> case t of + TermEvBelt _ belt -> case belt of + -- In the case of the user hitting enter, the cause is technically a + -- terminal event, but we don't display any name because the cause is + -- really the user. + Ret () -> Nothing + _ -> Just "term" + _ -> Just "term" diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index 8032316882..2cdb7bb272 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -7,18 +7,18 @@ module Vere.Pier import UrbitPrelude import Arvo -import Vere.Pier.Types import System.Random +import Vere.Pier.Types import System.Directory (createDirectoryIfMissing) import System.Posix.Files (ownerModes, setFileMode) import Vere.Ames (ames) import Vere.Behn (behn) +import Vere.Clay (clay) import Vere.Http.Client (client) import Vere.Http.Server (serv) import Vere.Log (EventLog) -import Vere.Serf (Serf, sStderr, SerfState(..), doJob) -import Vere.Clay (clay) +import Vere.Serf (Serf, SerfState(..), doJob, sStderr) import Vere.Term import qualified System.Entropy as Ent @@ -161,7 +161,8 @@ pier pierPath mPort (serf, log, ss) = do tExe <- startDrivers >>= router (readTQueue executeQ) tDisk <- runPersist log persistQ (writeTQueue executeQ) tCpu <- runCompute serf ss (readTQueue computeQ) (takeTMVar saveM) - (takeTMVar shutdownM) (writeTQueue persistQ) + (takeTMVar shutdownM) (tsShowSpinner terminalSystem) + (tsHideSpinner terminalSystem) (writeTQueue persistQ) tSaveSignal <- saveSignalThread saveM @@ -284,9 +285,12 @@ runCompute :: ∀e. HasLogFunc e -> STM Ev -> STM () -> STM () + -> (Maybe String -> STM ()) + -> STM () -> ((Job, FX) -> STM ()) -> RAcquire e (Async ()) -runCompute serf ss getEvent getSaveSignal getShutdownSignal putResult = +runCompute serf ss getEvent getSaveSignal getShutdownSignal + showSpinner hideSpinner putResult = mkRAcquire (async (go ss)) cancel where go :: SerfState -> RIO e () @@ -302,7 +306,9 @@ runCompute serf ss getEvent getSaveSignal getShutdownSignal putResult = eId <- pure (ssNextEv ss) mug <- pure (ssLastMug ss) + atomically $ showSpinner (getSpinnerNameForEvent ev) (job', ss', fx) <- doJob serf $ DoWork $ Work eId mug wen ev + atomically $ hideSpinner atomically (putResult (job', fx)) go ss' CRSave () -> do diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index 953961a530..998e299464 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -1,10 +1,12 @@ module Vere.Term (initializeLocalTerminal, term, TerminalSystem(..)) where import Arvo hiding (Term) -import UrbitPrelude +import Urbit.Time +import UrbitPrelude hiding (getCurrentTime) import Vere.Pier.Types import Data.Char +import Data.List ((!!)) import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable @@ -27,8 +29,19 @@ import qualified Data.ByteString.UTF8 as UTF8 data VereOutput = VereBlitOutput [Blit] | VerePrintOutput String | VereBlankLine + | VereShowSpinner (Maybe String) + | VereHideSpinner -data LineState = LineState String Int +-- All stateful data in the printing to stdOutput. +data LineState = LineState + { lsLine :: String + , lsCurPos :: Int + , lsSpinTimer :: Maybe (Async ()) + , lsSpinCause :: Maybe String + , lsSpinFirstRender :: Bool + , lsSpinFrame :: Int + , lsPrevEndTime :: Wen + } -- A record used in reading data from stdInput. data ReadData = ReadData @@ -46,16 +59,18 @@ data ReadData = ReadData -- the session is over, and has a general in/out queue in the types of the -- vere/arvo interface. data TerminalSystem e = TerminalSystem - { tsReadQueue :: TQueue Belt - , tsWriteQueue :: TQueue VereOutput - , tsStderr :: Text -> RIO e () + { tsReadQueue :: TQueue Belt + , tsWriteQueue :: TQueue VereOutput + , tsStderr :: Text -> RIO e () + , tsShowSpinner :: Maybe String -> STM () + , tsHideSpinner :: STM () } -- Private data to the TerminalSystem that we keep around for stop(). data Private = Private { pReaderThread :: Async () , pWriterThread :: Async () - , pPreviousConfiguration :: TerminalAttributes + , pPreviousConfiguration :: TerminalAttributes } -- Utils ----------------------------------------------------------------------- @@ -67,6 +82,16 @@ initialHail = EvBlip $ BlipEvTerm $ TermEvHail (UD 1, ()) () -- Version one of this is punting on the ops_u.dem flag: whether we're running -- in daemon mode. +spinners = ['|', '/', '-', '\\'] + +leftBracket = ['«'] +rightBracket = ['»'] + +_spin_cool_us = 500000 +_spin_warm_us = 50000 +_spin_rate_us = 250000 +_spin_idle_us = 500000 + -------------------------------------------------------------------------------- runMaybeTermOutput :: Terminal -> (Terminal -> Maybe TermOutput) -> RIO e () @@ -92,10 +117,9 @@ isTerminalBlit _ = True -- Initializes the generalized input/output parts of the terminal. -- -initializeLocalTerminal :: HasLogFunc e => RAcquire e (TerminalSystem e) -initializeLocalTerminal = do - (a, b) <- mkRAcquire start stop - pure a +initializeLocalTerminal :: forall e. HasLogFunc e + => RAcquire e (TerminalSystem e) +initializeLocalTerminal = fst <$> mkRAcquire start stop where start :: HasLogFunc e => RIO e (TerminalSystem e, Private) start = do @@ -105,7 +129,8 @@ initializeLocalTerminal = do -- TODO: We still need to actually get the size from the terminal somehow. tsWriteQueue <- newTQueueIO - pWriterThread <- asyncBound (writeTerminal t tsWriteQueue) + spinnerMVar <- newEmptyTMVarIO + pWriterThread <- asyncBound (writeTerminal t tsWriteQueue spinnerMVar) pPreviousConfiguration <- io $ getTerminalAttributes stdInput @@ -119,11 +144,15 @@ initializeLocalTerminal = do tsReadQueue <- newTQueueIO pReaderThread <- asyncBound - (readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue)) + (readTerminal tsReadQueue tsWriteQueue (bell tsWriteQueue)) let tsStderr = \txt -> atomically $ writeTQueue tsWriteQueue $ VerePrintOutput $ unpack txt + let tsShowSpinner = \str -> + writeTQueue tsWriteQueue $ VereShowSpinner str + let tsHideSpinner = writeTQueue tsWriteQueue $ VereHideSpinner + pure (TerminalSystem{..}, Private{..}) stop :: HasLogFunc e @@ -161,26 +190,87 @@ initializeLocalTerminal = do vtParmLeft t = getCap t "cub1" vtParmRight t = getCap t "cuf1" + -- An async which will put into an mvar after a delay. Used to spin the + -- spinner in writeTerminal. + spinnerHeartBeat :: Int -> Int -> TMVar () -> RIO e () + spinnerHeartBeat first rest mvar = do + threadDelay first + loop + where + loop = do + atomically $ putTMVar mvar () + threadDelay rest + loop + -- Writes data to the terminal. Both the terminal reading, normal logging, -- and effect handling can all emit bytes which go to the terminal. - writeTerminal :: Terminal -> TQueue VereOutput -> RIO e () - writeTerminal t q = loop (LineState "" 0) + writeTerminal :: Terminal -> TQueue VereOutput -> TMVar () -> RIO e () + writeTerminal t q spinner = do + currentTime <- io $ now + loop (LineState "" 0 Nothing Nothing True 0 currentTime) where - loop s = do - x <- atomically $ readTQueue q + loop ls@LineState{..} = do + x <- atomically $ + Right <$> readTQueue q <|> + Left <$> takeTMVar spinner case x of - VereBlitOutput blits -> do - s <- foldM (writeBlit t) s blits - loop s - VerePrintOutput p -> do + Right (VereBlitOutput blits) -> do + ls <- foldM (writeBlit t) ls blits + loop ls + Right (VerePrintOutput p) -> do io $ runTermOutput t $ termText "\r" runMaybeTermOutput t vtClearToBegin io $ runTermOutput t $ termText p - s <- termRefreshLine t s - loop s - VereBlankLine -> do + ls <- termRefreshLine t ls + loop ls + Right VereBlankLine -> do io $ runTermOutput t $ termText "\r\n" - loop s + loop ls + Right (VereShowSpinner txt) -> do + current <- io $ now + -- Figure out how long to wait to show the spinner. When we don't + -- have a vane name to display, we assume its a user action and + -- trigger immediately. Otherwise, if we receive an event shortly + -- after a previous spin, use a shorter delay to avoid giving the + -- impression of a half-idle system. + let delay = case txt of + Nothing -> 0 + Just _ -> + if (gap current lsPrevEndTime ^. microSecs) < + _spin_idle_us + then _spin_warm_us + else _spin_cool_us + + spinTimer <- async $ spinnerHeartBeat delay _spin_rate_us spinner + loop ls { lsSpinTimer = Just spinTimer, + lsSpinCause = txt, + lsSpinFirstRender = True } + Right VereHideSpinner -> do + maybe (pure ()) cancel lsSpinTimer + -- We do a final flush of the spinner mvar to ensure we don't + -- have a lingering signal which will redisplay the spinner after + -- we call termRefreshLine below. + atomically $ tryTakeTMVar spinner + + -- If we ever actually ran the spinner display callback, we need + -- to force a redisplay of the command prompt. + ls <- if not lsSpinFirstRender + then termRefreshLine t ls + else pure ls + + endTime <- io $ now + loop ls { lsSpinTimer = Nothing, lsPrevEndTime = endTime } + Left () -> do + let spinner = [spinners !! lsSpinFrame] ++ case lsSpinCause of + Nothing -> [] + Just str -> leftBracket ++ str ++ rightBracket + + io $ runTermOutput t $ termText spinner + termSpinnerMoveLeft t (length spinner) + + loop ls { lsSpinFirstRender = False, + lsSpinFrame = (lsSpinFrame + 1) `mod` (length spinners) + } -- Writes an individual blit to the screen writeBlit :: Terminal -> LineState -> Blit -> RIO e LineState @@ -204,41 +294,49 @@ initializeLocalTerminal = do -- Moves the cursor to the requested position termShowCursor :: Terminal -> LineState -> Int -> RIO e LineState - termShowCursor t (LineState line pos) newPos = do - if newPos < pos then do - replicateM_ (pos - newPos) (runMaybeTermOutput t vtParmLeft) - pure (LineState line newPos) - else if newPos > pos then do - replicateM_ (newPos - pos) (runMaybeTermOutput t vtParmRight) - pure (LineState line newPos) + termShowCursor t ls@LineState{..} {-line pos)-} newPos = do + if newPos < lsCurPos then do + replicateM_ (lsCurPos - newPos) (runMaybeTermOutput t vtParmLeft) + pure ls { lsCurPos = newPos } + else if newPos > lsCurPos then do + replicateM_ (newPos - lsCurPos) (runMaybeTermOutput t vtParmRight) + pure ls { lsCurPos = newPos } else - pure (LineState line pos) + pure ls + + + -- Moves the cursor left without any mutation of the LineState. Used only + -- in cursor spinning. + termSpinnerMoveLeft :: Terminal -> Int -> RIO e () + termSpinnerMoveLeft t count = + replicateM_ count (runMaybeTermOutput t vtParmLeft) -- Displays and sets the current line termShowLine :: Terminal -> LineState -> String -> RIO e LineState termShowLine t ls newStr = do - -- TODO: Really think about how term.c munged cus_w. Amidoinitrit? io $ runTermOutput t $ termText newStr - pure (LineState newStr (length newStr)) + pure ls { lsLine = newStr, lsCurPos = (length newStr) } termShowClear :: Terminal -> LineState -> RIO e LineState termShowClear t ls = do io $ runTermOutput t $ termText "\r" runMaybeTermOutput t vtClearToBegin - pure (LineState "" 0) + pure ls { lsLine = "", lsCurPos = 0 } -- New Current Line termShowMore :: Terminal -> LineState -> RIO e LineState termShowMore t ls = do io $ runTermOutput t $ termText "\r\n" - pure (LineState "" 0) + pure ls { lsLine = "", lsCurPos = 0 } - -- Redraw the current LineState, moving cursor to the end. + -- Redraw the current LineState, maintaining the current curpos termRefreshLine :: Terminal -> LineState -> RIO e LineState - termRefreshLine t ls@(LineState line pos) = do - runMaybeTermOutput t vtClearToBegin - newLs <- termShowLine t ls line - termShowCursor t newLs pos + termRefreshLine t ls = do + let line = (lsLine ls) + curPos = (lsCurPos ls) + ls <- termShowClear t ls + ls <- termShowLine t ls line + termShowCursor t ls curPos -- ring my bell bell :: TQueue VereOutput -> RIO e ()