urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-24 20:47:27 +03:00
Code Issues Packages Projects Releases Wiki Activity

Terminal spinner implementation in King Haskell.

Browse Source 
This gets a terminal spinner to spin after a short delay like in
vere. This also fixes a bug in termRefreshLine which was screwing
up redisplay of the terminal spinner; it hadn't been translated
from C properly.
This commit is contained in:
Elliot Glaysher 2019-09-16 13:34:55 -07:00
parent 721945d1ba
commit c7945689d2
3 changed files with 175 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pkg/king/lib/Arvo/Event.hs
View File

@ -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"

16
pkg/king/lib/Vere/Pier.hs
View File

@ -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

180
pkg/king/lib/Vere/Term.hs
View File

@ -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 ()