mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 01:41:37 +03:00
d1a9eaeaa0
After looking at vty for a bit, I decided to just do a straight port of term.c's raw output code. This gets the "~zod:dojo" in the right position, though the other logging output screws things up a bit.
245 lines
7.6 KiB
Haskell
245 lines
7.6 KiB
Haskell
{-# OPTIONS_GHC -Wwarn #-}
|
|
|
|
module Vere.Term (initializeTerminal, term, VereTerminal) where
|
|
|
|
import UrbitPrelude
|
|
import Arvo hiding (Term)
|
|
import Vere.Pier.Types
|
|
|
|
import Foreign.Marshal.Alloc
|
|
import System.Posix.IO
|
|
import System.Posix.Terminal
|
|
|
|
import System.Console.Terminfo.Base
|
|
|
|
import qualified Urbit.Time as Time
|
|
|
|
-- Types -----------------------------------------------------------------------
|
|
|
|
data TermDrv = TermDrv
|
|
{ tdPreviousConfiguration :: TerminalAttributes
|
|
, tdReader :: Async ()
|
|
}
|
|
|
|
-- Output to the attached terminal is either a series of vere blits, or it is an
|
|
-- injected printf line from the interpreter.
|
|
data VereOutput = VereBlitOutput [Blit]
|
|
| VerePrintOutput String
|
|
|
|
|
|
|
|
data VereTerminal = VereTerminal
|
|
{ vtWidth :: Word
|
|
, vtHeight :: Word
|
|
|
|
--
|
|
, vtWriteQueue :: TQueue VereOutput
|
|
, vtWriter :: Async ()
|
|
}
|
|
|
|
data LineState = LineState String Int
|
|
|
|
-- A list of terminal flags that we disable
|
|
disabledFlags = [
|
|
-- lflag
|
|
EnableEcho, EchoLF, ProcessInput, ExtendedFunctions,
|
|
-- iflag
|
|
MapCRtoLF, CheckParity, StripHighBit,
|
|
-- cflag, todo: Terminal library missing CSIZE?
|
|
EnableParity,
|
|
-- oflag
|
|
ProcessOutput
|
|
]
|
|
|
|
-- Utils -----------------------------------------------------------------------
|
|
|
|
-- TODO: We lie about terminal size for now and just pass 80x24 because getting
|
|
-- it is a call to ioctl() which is in IO.
|
|
|
|
initialBlew w h = EvBlip $ BlipEvTerm $ TermEvBlew (UD 1, ()) w h
|
|
|
|
initialHail = EvBlip $ BlipEvTerm $ TermEvHail (UD 1, ()) ()
|
|
|
|
|
|
-- What we need is an equivalent to _term_io_suck_char(). That's a manual, hand
|
|
-- rolled parser to deal with the escape state.
|
|
|
|
-- Version one of this is punting on the ops_u.dem flag: whether we're running
|
|
-- in daemon mode.
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
runMaybeTermOutput :: Terminal -> (Terminal -> Maybe TermOutput) -> IO ()
|
|
runMaybeTermOutput t getter = case (getter t) of
|
|
Nothing -> pure ()
|
|
Just x -> runTermOutput t x
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
initializeTerminal :: Acquire VereTerminal
|
|
initializeTerminal = mkAcquire start stop
|
|
where
|
|
start :: IO VereTerminal
|
|
start = do
|
|
t <- setupTermFromEnv
|
|
let vtWidth = 80
|
|
let vtHeight = 24
|
|
|
|
vtWriteQueue <- newTQueueIO
|
|
vtWriter <- asyncBound (writeTerminal t vtWriteQueue)
|
|
|
|
pure VereTerminal{..}
|
|
|
|
stop :: VereTerminal -> IO ()
|
|
stop (VereTerminal{..}) = cancel vtWriter
|
|
|
|
getCap term cap =
|
|
getCapability term (tiGetOutput1 cap) :: Maybe TermOutput
|
|
|
|
vtClearScreen t = getCap t "clear"
|
|
vtClearToBegin t = getCap t "el"
|
|
vtSoundBell t = getCap t "bel"
|
|
vtParmLeft t = getCap t "cub1"
|
|
vtParmRight t = getCap t "cuf1"
|
|
|
|
-- 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 -> IO ()
|
|
writeTerminal t q = loop (LineState "" 0)
|
|
where
|
|
loop s = do
|
|
x <- atomically $ readTQueue q
|
|
case x of
|
|
VereBlitOutput blits -> do
|
|
newS <- foldM (writeBlit t) s blits
|
|
loop newS
|
|
VerePrintOutput p -> do
|
|
runTermOutput t $ termText "\r"
|
|
runMaybeTermOutput t vtClearToBegin
|
|
runTermOutput t $ termText p
|
|
newS <- termRefreshLine t s
|
|
loop newS
|
|
|
|
-- Writes an individual blit to the screen
|
|
writeBlit :: Terminal -> LineState -> Blit -> IO LineState
|
|
writeBlit t ls = \case
|
|
Bel () -> do
|
|
runMaybeTermOutput t vtSoundBell
|
|
pure ls
|
|
Clr () -> do
|
|
runMaybeTermOutput t vtClearScreen
|
|
termRefreshLine t ls
|
|
(Hop w) -> do
|
|
termShowCursor t ls (fromIntegral w)
|
|
(Lin c) -> do
|
|
ls2 <- termShowClear t ls
|
|
termShowLine t ls2 (pack c)
|
|
(Mor ()) -> do
|
|
termShowMore t ls
|
|
(Sag path noun) -> pure ls
|
|
(Sav path atom) -> pure ls
|
|
(Url url) -> pure ls
|
|
|
|
-- Moves the cursor to the requested position
|
|
termShowCursor :: Terminal -> LineState -> Int -> IO 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)
|
|
else
|
|
pure (LineState line pos)
|
|
|
|
-- Displays and sets the current line
|
|
termShowLine :: Terminal -> LineState -> String -> IO LineState
|
|
termShowLine t ls newStr = do
|
|
-- TODO: Really think about how term.c munged cus_w. Amidoinitrit?
|
|
runTermOutput t $ termText newStr
|
|
pure (LineState newStr (length newStr))
|
|
|
|
termShowClear :: Terminal -> LineState -> IO LineState
|
|
termShowClear t ls = do
|
|
runTermOutput t $ termText "\r"
|
|
runMaybeTermOutput t vtClearToBegin
|
|
pure (LineState "" 0)
|
|
|
|
-- New Current Line
|
|
termShowMore :: Terminal -> LineState -> IO LineState
|
|
termShowMore t ls = do
|
|
runTermOutput t $ termText "\r\n"
|
|
pure (LineState "" 0)
|
|
|
|
-- Redraw the current LineState, moving cursor to the end.
|
|
termRefreshLine :: Terminal -> LineState -> IO LineState
|
|
termRefreshLine t ls@(LineState line pos) = do
|
|
runMaybeTermOutput t vtClearToBegin
|
|
newLs <- termShowLine t ls line
|
|
termShowCursor t newLs pos
|
|
|
|
|
|
term :: VereTerminal -> KingId -> QueueEv -> ([Ev], Acquire (EffCb TermEf))
|
|
term VereTerminal{..} king enqueueEv =
|
|
(initialEvents, runTerm)
|
|
where
|
|
initialEvents = [(initialBlew vtWidth vtHeight), initialHail]
|
|
|
|
runTerm :: Acquire (EffCb TermEf)
|
|
runTerm = do
|
|
tim <- mkAcquire start stop
|
|
pure (handleEffect vtWriteQueue tim)
|
|
|
|
start :: IO TermDrv
|
|
start = do
|
|
putStrLn "term start"
|
|
tdPreviousConfiguration <- getTerminalAttributes stdInput
|
|
|
|
-- Create a new configuration where we put the terminal in raw mode and
|
|
-- disable a bunch of preprocessing.
|
|
let newTermSettings =
|
|
flip withTime 1 .
|
|
flip withMinInput 0 $
|
|
foldl' withoutMode tdPreviousConfiguration disabledFlags
|
|
setTerminalAttributes stdInput newTermSettings Immediately
|
|
|
|
tdReader <- asyncBound readTerminal
|
|
|
|
pure TermDrv{..}
|
|
|
|
stop :: TermDrv -> IO ()
|
|
stop (TermDrv{..}) = do
|
|
-- cancel our threads
|
|
cancel tdReader
|
|
-- take the terminal out of raw mode
|
|
setTerminalAttributes stdInput tdPreviousConfiguration Immediately
|
|
|
|
-- Reads data from stdInput and emit the proper effect
|
|
--
|
|
-- This entire path is a divergence from how term.c does things,
|
|
-- probably. First, the vtime is 0, not 1 in term.c. So (IIUC), we'll
|
|
-- always have a latency of 1/10 of a second.
|
|
--
|
|
-- A better way to do this would be to get some sort of epoll on stdInput,
|
|
-- since that's kinda closer to what libuv does?
|
|
readTerminal :: IO ()
|
|
readTerminal = allocaBytes 1 $ \ buf -> forever $ do
|
|
t <- try (fdReadBuf stdInput buf 1)
|
|
case t of
|
|
Left (e :: IOException) ->
|
|
-- Ignore EAGAINs when doing reads
|
|
pure ()
|
|
Right 0 -> pure ()
|
|
Right _ -> do
|
|
putStrLn "\r[KEY] " -- ++ str)
|
|
wen <- Time.now
|
|
pure ()
|
|
-- atomicallu $ enqueuEv $
|
|
|
|
handleEffect :: TQueue VereOutput -> TermDrv -> TermEf -> IO ()
|
|
handleEffect writeQueue TermDrv{..} = \case
|
|
TermEfBlit _ blits -> atomically $ writeTQueue writeQueue (VereBlitOutput blits)
|
|
TermEfInit _ _ -> pure ()
|
|
TermEfLogo path _ -> pure ()
|
|
TermEfMass _ _ -> pure ()
|