Terminal spinner implementation in King Haskell.

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.

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 (Header(..), HttpEvent)
-import Arvo.Common (Ipv4, Ipv6, Port, Turf, AmesDest)
+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"

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.Serf          (Serf, SerfState(..), doJob, sStderr)
-import Vere.Clay          (clay)
 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

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
+  { tsReadQueue   :: TQueue Belt
-  , tsWriteQueue :: TQueue VereOutput
+  , tsWriteQueue  :: TQueue VereOutput
-  , tsStderr     :: Text -> RIO e ()
+  , 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 :: forall e. HasLogFunc e
-initializeLocalTerminal = do
+                        => RAcquire e (TerminalSystem e)
-    (a, b) <- mkRAcquire start stop
+initializeLocalTerminal = fst <$> mkRAcquire start stop
-    pure a
   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 :: Terminal -> TQueue VereOutput -> TMVar () -> RIO e ()
-    writeTerminal t q = loop (LineState "" 0)
+    writeTerminal t q spinner = do
+        currentTime <- io $ now
+        loop (LineState "" 0 Nothing Nothing True 0 currentTime)
       where
-        loop s = do
+        loop ls@LineState{..} = do
-          x <- atomically $ readTQueue q
+          x <- atomically $
+                 Right <$> readTQueue q <|>
+                 Left <$> takeTMVar spinner
           case x of
-            VereBlitOutput blits -> do
+            Right (VereBlitOutput blits) -> do
-              s <- foldM (writeBlit t) s blits
+              ls <- foldM (writeBlit t) ls blits
-              loop s
+              loop ls
-            VerePrintOutput p -> do
+            Right (VerePrintOutput p) -> do
               io $ runTermOutput t $ termText "\r"
               runMaybeTermOutput t vtClearToBegin
               io $ runTermOutput t $ termText p
-              s <- termRefreshLine t s
+              ls <- termRefreshLine t ls
-              loop s
+              loop ls
-            VereBlankLine -> do
+            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
+    termShowCursor t ls@LineState{..} {-line pos)-} newPos = do
-      if newPos < pos then do
+      if newPos < lsCurPos then do
-        replicateM_ (pos - newPos) (runMaybeTermOutput t vtParmLeft)
+        replicateM_ (lsCurPos - newPos) (runMaybeTermOutput t vtParmLeft)
-        pure (LineState line newPos)
+        pure ls { lsCurPos =  newPos }
-      else if newPos > pos then do
+      else if newPos > lsCurPos then do
-        replicateM_ (newPos - pos) (runMaybeTermOutput t vtParmRight)
+        replicateM_ (newPos - lsCurPos) (runMaybeTermOutput t vtParmRight)
-        pure (LineState line newPos)
+        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
+    termRefreshLine t ls = do
-      runMaybeTermOutput t vtClearToBegin
+      let line = (lsLine ls)
-      newLs <- termShowLine t ls line
+          curPos = (lsCurPos ls)
-      termShowCursor t newLs pos
+      ls <- termShowClear t ls
+      ls <- termShowLine t ls line
+      termShowCursor t ls curPos
 
     -- ring my bell
     bell :: TQueue VereOutput -> RIO e ()