diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index 65d42d73cb..b94766e151 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -21,13 +21,14 @@ import Vere.Serf (Serf, SerfState(..), doJob, sStderr) import RIO.Directory -import qualified System.Entropy as Ent -import qualified Urbit.Time as Time -import qualified Vere.Log as Log -import qualified Vere.Serf as Serf -import qualified Vere.Term as Term -import qualified Vere.Term.API as Term -import qualified Vere.Term.Demux as Term +import qualified System.Console.Terminal.Size as TSize +import qualified System.Entropy as Ent +import qualified Urbit.Time as Time +import qualified Vere.Log as Log +import qualified Vere.Serf as Serf +import qualified Vere.Term as Term +import qualified Vere.Term.API as Term +import qualified Vere.Term.Demux as Term -------------------------------------------------------------------------------- @@ -150,7 +151,7 @@ pier pierPath mPort (serf, log, ss) = do inst <- io (KingId . UV . fromIntegral <$> randomIO @Word16) - local <- Term.localClient + (sz, local) <- Term.localClient muxed <- atomically $ do res <- Term.mkDemux @@ -165,7 +166,7 @@ pier pierPath mPort (serf, log, ss) = do drivers pierPath inst ship mPort (writeTQueue computeQ) shutdownEvent - muxed + (sz, muxed) io $ atomically $ for_ bootEvents (writeTQueue computeQ) @@ -219,7 +220,7 @@ data Drivers e = Drivers drivers :: HasLogFunc e => FilePath -> KingId -> Ship -> Maybe Port -> (Ev -> STM ()) -> STM() - -> Term.Client + -> (TSize.Window Word, Term.Client) -> ([Ev], RAcquire e (Drivers e)) drivers pierPath inst who mPort plan shutdownSTM termSys = (initialEvents, runDrivers) diff --git a/pkg/king/lib/Vere/Term.hs b/pkg/king/lib/Vere/Term.hs index 1e35a4906b..9cb4e1fa63 100644 --- a/pkg/king/lib/Vere/Term.hs +++ b/pkg/king/lib/Vere/Term.hs @@ -1,6 +1,7 @@ module Vere.Term ( module Term , localClient + , termServer , term ) where @@ -22,10 +23,15 @@ import Vere.Term.API (Client(Client)) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.UTF8 as BS +import qualified System.Console.Terminal.Size as TSize import qualified System.Console.Terminfo.Base as T +import qualified Vere.NounServ as Serv import qualified Vere.Term.API as Term + + + -- Types ----------------------------------------------------------------------- -- All stateful data in the printing to stdOutput. @@ -104,13 +110,31 @@ isTerminalBlit _ = True -------------------------------------------------------------------------------- +termServer :: ∀e. HasLogFunc e + => RAcquire e (TChan Client, Port) +termServer = mkRAcquire start stop + where + stop = const (pure ()) + start = do + serv <- Serv.wsServer @Belt @Term.Ev + chan <- newTChanIO + pure (chan, 0) + +{- +data Server i o a = Server + { sAccept :: STM (Maybe (Conn i o)) + , sAsync :: Async () + , sData :: a + } +-} + {- Initializes the generalized input/output parts of the terminal. -} -localClient :: ∀e. HasLogFunc e => RAcquire e Client +localClient :: ∀e. HasLogFunc e => RAcquire e (TSize.Window Word, Client) localClient = fst <$> mkRAcquire start stop where - start :: HasLogFunc e => RIO e (Client, Private) + start :: HasLogFunc e => RIO e ((TSize.Window Word, Client), Private) start = do -- Initialize the writing side of the terminal -- @@ -139,11 +163,13 @@ localClient = fst <$> mkRAcquire start stop , give = writeTQueue tsWriteQueue } - pure (client, Private{..}) + tsize <- io $ TSize.size <&> fromMaybe (TSize.Window 80 24) + + pure ((tsize, client), Private{..}) stop :: HasLogFunc e - => (Client, Private) -> RIO e () - stop (Client{..}, Private{..}) = do + => ((TSize.Window Word, Client), Private) -> RIO e () + stop ((_, Client{..}), Private{..}) = do -- Note that we don't `cancel pReaderThread` here. This is a deliberate -- decision because fdRead calls into a native function which the runtime -- can't kill. If we were to cancel here, the internal `waitCatch` would @@ -257,9 +283,9 @@ localClient = fst <$> mkRAcquire start stop execEv :: LineState -> Term.Ev -> RIO e LineState execEv ls = \case Term.Blits bs -> foldM (writeBlit t) ls bs - Term.Trace p -> writeTrace ls p + Term.Trace p -> writeTrace ls (unCord p) Term.Blank -> writeBlank ls - Term.Spinr (Just txt) -> doSpin ls txt + Term.Spinr (Just txt) -> doSpin ls (unCord <$> txt) Term.Spinr Nothing -> unspin ls spin :: LineState -> RIO e LineState @@ -451,12 +477,18 @@ localClient = fst <$> mkRAcquire start stop -------------------------------------------------------------------------------- term :: forall e. HasLogFunc e - => Client -> (STM ()) -> FilePath -> KingId -> QueueEv + => (TSize.Window Word, Client) + -> (STM ()) + -> FilePath + -> KingId + -> QueueEv -> ([Ev], RAcquire e (EffCb e TermEf)) -term Client{..} shutdownSTM pierPath king enqueueEv = +term (tsize, Client{..}) shutdownSTM pierPath king enqueueEv = (initialEvents, runTerm) where - initialEvents = [(initialBlew 80 24), initialHail] + TSize.Window wi hi = tsize + + initialEvents = [(initialBlew hi wi), initialHail] runTerm :: RAcquire e (EffCb e TermEf) runTerm = do diff --git a/pkg/king/lib/Vere/Term/API.hs b/pkg/king/lib/Vere/Term/API.hs index 9f4fd3fc7f..20998aa4ba 100644 --- a/pkg/king/lib/Vere/Term/API.hs +++ b/pkg/king/lib/Vere/Term/API.hs @@ -16,23 +16,26 @@ import Arvo (Blit, Belt) %spinr -- Start or stop the spinner -} data Ev = Blits [Blit] - | Trace Text + | Trace Cord | Blank - | Spinr (Maybe (Maybe Text)) + | Spinr (Maybe (Maybe Cord)) + deriving (Show) data Client = Client { take :: STM Belt , give :: Ev -> STM () } +deriveNoun ''Ev + -- Utilities ------------------------------------------------------------------- trace :: Client -> Text -> STM () -trace ts = give ts . Trace +trace ts = give ts . Trace . Cord spin :: Client -> Maybe Text -> STM () -spin ts = give ts . Spinr . Just +spin ts = give ts . Spinr . Just . fmap Cord stopSpin :: Client -> STM () stopSpin ts = give ts (Spinr Nothing) diff --git a/pkg/king/package.yaml b/pkg/king/package.yaml index 2783a0f98e..d20954366e 100644 --- a/pkg/king/package.yaml +++ b/pkg/king/package.yaml @@ -37,6 +37,7 @@ dependencies: - classy-prelude - conduit - containers + - data-default - data-fix - directory - entropy @@ -81,6 +82,7 @@ dependencies: - tasty-th - template-haskell - terminal-progress-bar + - terminal-size - terminfo - text - these @@ -98,7 +100,6 @@ dependencies: - warp - warp-tls - websockets - - data-default default-extensions: - ApplicativeDo