mirror of
https://github.com/urbit/shrub.git
synced 2024-12-19 00:13:12 +03:00
kh: update Term for new dill interface
Support new Belts/Blits and updated semantics.
This commit is contained in:
fang
parent
1abbe168fe
commit
a90489830d
@ -119,15 +119,22 @@ deriveNoun ''BehnEf
|
||||
data Blit
|
||||
= Bel ()
|
||||
| Clr ()
|
||||
| Hop Word64
|
||||
| Hop HopTarget
|
||||
| Klr Stub
|
||||
| Lin [Char]
|
||||
| Mor ()
|
||||
| Put [Char]
|
||||
| Nel ()
|
||||
| Sag Path Noun
|
||||
| Sav Path Atom
|
||||
| Url Cord
|
||||
| Wyp ()
|
||||
deriving (Eq, Ord)
|
||||
|
||||
--NOTE bottom-left-0-based coordinates
|
||||
data HopTarget
|
||||
= Col Word64
|
||||
| Roc Word64 Word64 -- row, col
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Deco
|
||||
= DecoBl
|
||||
| DecoBr
|
||||
@ -205,18 +212,30 @@ instance FromNoun Tint where
|
||||
"w" -> pure TintW
|
||||
t -> fail ("invalid: " <> unpack t)
|
||||
|
||||
instance FromNoun HopTarget where
|
||||
parseNoun = \case
|
||||
A c -> pure $ Col (fromIntegral c)
|
||||
C (A r) (A c) -> pure $ Roc (fromIntegral r) (fromIntegral c)
|
||||
n -> fail ("invalid hop target: " <> show n)
|
||||
|
||||
instance ToNoun HopTarget where
|
||||
toNoun = \case
|
||||
Col c -> A (fromIntegral c)
|
||||
Roc r c -> C (A (fromIntegral r)) (A (fromIntegral c))
|
||||
|
||||
-- Manual instance to not save the noun/atom in Sag/Sav, because these can be
|
||||
-- megabytes and makes king hang.
|
||||
instance Show Blit where
|
||||
show (Bel ()) = "Bel ()"
|
||||
show (Clr ()) = "Clr ()"
|
||||
show (Hop x) = "Hop " ++ (show x)
|
||||
show (Hop t) = "Hop " ++ (show t)
|
||||
show (Klr s) = "Klr " ++ (show s)
|
||||
show (Lin c) = "Lin " ++ (show c)
|
||||
show (Mor ()) = "Mor ()"
|
||||
show (Put c) = "Put " ++ (show c)
|
||||
show (Nel ()) = "Nel ()"
|
||||
show (Sag path _) = "Sag " ++ (show path)
|
||||
show (Sav path _) = "Sav " ++ (show path)
|
||||
show (Url c) = "Url " ++ (show c)
|
||||
show (Wyp ()) = "Wyp ()"
|
||||
|
||||
{-|
|
||||
%blip -- TODO
|
||||
|
||||
@ -20,6 +20,7 @@ import Urbit.Arvo.Common (ReOrg(..), reorgThroughNoun)
|
||||
|
||||
import qualified Crypto.Sign.Ed25519 as Ed
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Char as C
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Network.HTTP.Types.Method as H
|
||||
|
||||
@ -277,19 +278,56 @@ data LegacyBootEvent
|
||||
| Dawn Dawn
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ArrowKey = D | L | R | U
|
||||
data Bolt
|
||||
= Key Char
|
||||
| Aro ArrowKey
|
||||
| Bac ()
|
||||
| Del ()
|
||||
| Hit Word64 Word64
|
||||
| Ret ()
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Belt
|
||||
= Aro ArrowKey
|
||||
| Bac ()
|
||||
| Ctl Cord
|
||||
| Del ()
|
||||
| Met Cord
|
||||
| Ret ()
|
||||
= Bol Bolt
|
||||
| Mod Modifier Bolt
|
||||
| Txt Tour
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data ArrowKey = D | L | R | U
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Modifier = Ctl | Met | Hyp
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
--NOTE required to get the above declarations into reify's type environment
|
||||
-- see also ghc/ghc#9813
|
||||
$(pure [])
|
||||
|
||||
instance FromNoun Bolt where
|
||||
parseNoun = \case
|
||||
A c -> pure $ Key $ C.chr $ fromIntegral c
|
||||
n -> $(deriveFromNounFunc ''Bolt) n
|
||||
|
||||
instance FromNoun Belt where
|
||||
parseNoun = \case
|
||||
A c -> pure $ Bol $ Key $ C.chr $ fromIntegral c
|
||||
n -> runParser ($(deriveFromNounFunc ''Bolt) n) [] belt bolt
|
||||
where
|
||||
belt p m = $(deriveFromNounFunc ''Belt) n
|
||||
bolt !b = pure $ Bol b
|
||||
|
||||
instance ToNoun Bolt where
|
||||
toNoun = \case
|
||||
Key c -> A $ fromIntegral $ C.ord c
|
||||
n -> $(deriveToNounFunc ''Bolt) n
|
||||
|
||||
instance ToNoun Belt where
|
||||
toNoun = \case
|
||||
Bol b -> case b of
|
||||
Key c -> A $ fromIntegral $ C.ord c
|
||||
b -> $(deriveToNounFunc ''Bolt) b
|
||||
n -> $(deriveToNounFunc ''Belt) n
|
||||
|
||||
data TermEv
|
||||
= TermEvBelt (UD, ()) Belt
|
||||
| TermEvBlew (UD, ()) Word Word
|
||||
@ -300,7 +338,7 @@ data TermEv
|
||||
|
||||
deriveNoun ''LegacyBootEvent
|
||||
deriveNoun ''ArrowKey
|
||||
deriveNoun ''Belt
|
||||
deriveNoun ''Modifier
|
||||
deriveNoun ''TermEv
|
||||
|
||||
|
||||
@ -353,6 +391,7 @@ instance FromNoun Ev where
|
||||
terminal event, but we don't display any name because the cause is
|
||||
really the user.
|
||||
-}
|
||||
--REVIEW doesn't that hold for _any_ terminal event?
|
||||
getSpinnerNameForEvent :: Ev -> Maybe Text
|
||||
getSpinnerNameForEvent = \case
|
||||
EvBlip b -> case b of
|
||||
@ -367,8 +406,8 @@ getSpinnerNameForEvent = \case
|
||||
BlipEvTerm t | isRet t -> Nothing
|
||||
BlipEvTerm t -> Just "term"
|
||||
where
|
||||
isRet (TermEvBelt _ (Ret ())) = True
|
||||
isRet _ = False
|
||||
isRet (TermEvBelt _ (Bol (Ret ()))) = True
|
||||
isRet _ = False
|
||||
|
||||
summarizeEvent :: Ev -> Text
|
||||
summarizeEvent ev =
|
||||
|
||||
@ -46,7 +46,7 @@ import qualified Urbit.Vere.Term.Render as T
|
||||
-- | All stateful data in the printing to stdOutput.
|
||||
data LineState = LineState
|
||||
{ lsLine :: Text
|
||||
, lsCurPos :: Int
|
||||
, lsCurPos :: CurPos
|
||||
, lsSpinTimer :: Maybe (Async ())
|
||||
, lsSpinCause :: Maybe Text
|
||||
, lsSpinFirstRender :: Bool
|
||||
@ -54,6 +54,11 @@ data LineState = LineState
|
||||
, lsPrevEndTime :: Wen
|
||||
}
|
||||
|
||||
data CurPos = CurPos
|
||||
{ row :: Int
|
||||
, col :: Int
|
||||
}
|
||||
|
||||
-- | A record used in reading data from stdInput.
|
||||
data ReadData = ReadData
|
||||
{ rdBuf :: Ptr Word8
|
||||
@ -269,7 +274,7 @@ localClient doneSignal = fst <$> mkRAcquire start stop
|
||||
writeTerminal :: TQueue [Term.Ev] -> TMVar () -> TVar TermSize -> RIO e ()
|
||||
writeTerminal q spinner termSizeVar = do
|
||||
currentTime <- io $ now
|
||||
loop (LineState "" 0 Nothing Nothing True 0 currentTime)
|
||||
loop (LineState "" (CurPos 0 0) Nothing Nothing True 0 currentTime)
|
||||
where
|
||||
writeBlank :: LineState -> RIO e LineState
|
||||
writeBlank ls = putStr "\r\n" $> ls
|
||||
@ -340,7 +345,7 @@ localClient doneSignal = fst <$> mkRAcquire start stop
|
||||
|
||||
execEv :: LineState -> Term.Ev -> RIO e LineState
|
||||
execEv ls = \case
|
||||
Term.Blits bs -> foldM writeBlit ls bs
|
||||
Term.Blits bs -> foldM (writeBlit termSizeVar) ls bs
|
||||
Term.Trace p -> writeTrace ls (unCord p)
|
||||
Term.Slog s -> writeSlog ls s
|
||||
Term.Blank -> writeBlank ls
|
||||
@ -370,20 +375,22 @@ localClient doneSignal = fst <$> mkRAcquire start stop
|
||||
]
|
||||
|
||||
-- Writes an individual blit to the screen
|
||||
writeBlit :: LineState -> Blit -> RIO e LineState
|
||||
writeBlit ls = \case
|
||||
writeBlit :: TVar TermSize -> LineState -> Blit -> RIO e LineState
|
||||
writeBlit ts ls = \case
|
||||
Bel () -> T.soundBell $> ls
|
||||
Clr () -> do T.clearScreen
|
||||
termRefreshLine ls
|
||||
Hop w -> termShowCursor ls (fromIntegral w)
|
||||
Klr s -> do ls2 <- termShowClear ls
|
||||
termShowStub ls2 s
|
||||
Lin c -> do ls2 <- termShowClear ls
|
||||
termShowLine ls2 (pack c)
|
||||
Mor () -> termShowMore ls
|
||||
T.cursorRestore
|
||||
pure ls
|
||||
Hop t -> case t of
|
||||
Col c -> termShowCursor ls ts 0 (fromIntegral c)
|
||||
Roc r c -> termShowCursor ls ts (fromIntegral r) (fromIntegral c)
|
||||
Klr s -> termShowStub ls s
|
||||
Put c -> termShowLine ls (pack c)
|
||||
Nel () -> termShowNewline ls
|
||||
Sag path noun -> pure ls
|
||||
Sav path atom -> pure ls
|
||||
Url url -> pure ls
|
||||
Wyp () -> termShowClear ls
|
||||
|
||||
termRenderDeco :: Deco -> Char
|
||||
termRenderDeco = \case
|
||||
@ -428,48 +435,56 @@ localClient doneSignal = fst <$> mkRAcquire start stop
|
||||
|
||||
styled = mconcat [escape, styles, "m", tape, escape, "0m"]
|
||||
|
||||
-- Displays and sets styled text as the current line
|
||||
-- Displays styled text at the cursor
|
||||
termShowStub :: LineState -> Stub -> RIO e LineState
|
||||
termShowStub ls (Stub s) = do
|
||||
let visualLength = sum $ fmap (length . snd) s
|
||||
termShowStub ls@LineState{lsCurPos} (Stub s) = do
|
||||
let outText = pack $ mconcat $ fmap (uncurry termRenderStubSegment) s
|
||||
putStr outText
|
||||
pure ls { lsLine = outText, lsCurPos = visualLength }
|
||||
T.cursorRestore
|
||||
case row lsCurPos of
|
||||
0 -> --TODO offset by col
|
||||
pure ls { lsLine = outText }
|
||||
_ -> pure ls
|
||||
|
||||
-- Moves the cursor to the requested position
|
||||
termShowCursor :: LineState -> Int -> RIO e LineState
|
||||
termShowCursor ls@LineState{..} {-line pos)-} newPos = do
|
||||
if newPos < lsCurPos then do
|
||||
T.cursorLeft (lsCurPos - newPos)
|
||||
pure ls { lsCurPos = newPos }
|
||||
else if newPos > lsCurPos then do
|
||||
T.cursorRight (newPos - lsCurPos)
|
||||
pure ls { lsCurPos = newPos }
|
||||
else
|
||||
pure ls
|
||||
termShowCursor :: LineState -> TVar TermSize -> Int -> Int -> RIO e LineState
|
||||
termShowCursor ls ts row col = do
|
||||
TermSize _ h <- readTVarIO ts
|
||||
T.cursorMove (max 0 (fromIntegral h - row - 1)) col
|
||||
T.cursorSave
|
||||
pure ls { lsCurPos = CurPos row col }
|
||||
|
||||
-- Moves the cursor left without any mutation of the LineState. Used only
|
||||
-- in cursor spinning.
|
||||
_termSpinnerMoveLeft :: Int -> RIO e ()
|
||||
_termSpinnerMoveLeft = T.cursorLeft
|
||||
_termSpinnerMoveLeft = liftIO . ANSI.cursorBackward
|
||||
|
||||
-- Displays and sets the current line
|
||||
termShowLine :: LineState -> Text -> RIO e LineState
|
||||
termShowLine ls newStr = do
|
||||
termShowLine ls@LineState{lsCurPos} newStr = do
|
||||
putStr newStr
|
||||
pure ls { lsLine = newStr, lsCurPos = (length newStr) }
|
||||
T.cursorRestore
|
||||
case row lsCurPos of
|
||||
0 -> --TODO offset by col
|
||||
pure ls { lsLine = newStr }
|
||||
_ -> pure ls
|
||||
|
||||
termShowClear :: LineState -> RIO e LineState
|
||||
termShowClear ls = do
|
||||
termShowClear ls@LineState{lsCurPos} = do
|
||||
putStr "\r"
|
||||
T.clearLine
|
||||
pure ls { lsLine = "", lsCurPos = 0 }
|
||||
T.cursorRestore
|
||||
case row lsCurPos of
|
||||
0 -> pure ls { lsLine = "" }
|
||||
_ -> pure ls
|
||||
|
||||
-- New Current Line
|
||||
termShowMore :: LineState -> RIO e LineState
|
||||
termShowMore ls = do
|
||||
termShowNewline :: LineState -> RIO e LineState
|
||||
termShowNewline ls@LineState{lsCurPos} = do
|
||||
putStr "\r\n"
|
||||
pure ls { lsLine = "", lsCurPos = 0 }
|
||||
case row lsCurPos of
|
||||
0 -> pure ls { lsLine = "", lsCurPos = lsCurPos { col = 0 } }
|
||||
r -> pure ls { lsCurPos = CurPos (r-1) 0 }
|
||||
|
||||
-- Redraw the current LineState, maintaining the current curpos
|
||||
termRefreshLine :: LineState -> RIO e LineState
|
||||
@ -513,20 +528,17 @@ localClient doneSignal = fst <$> mkRAcquire start stop
|
||||
if rdEscape then
|
||||
if rdBracket then do
|
||||
case c of
|
||||
'A' -> sendBelt $ Aro U
|
||||
'B' -> sendBelt $ Aro D
|
||||
'C' -> sendBelt $ Aro R
|
||||
'D' -> sendBelt $ Aro L
|
||||
'A' -> sendBelt $ Bol $ Aro U
|
||||
'B' -> sendBelt $ Bol $ Aro D
|
||||
'C' -> sendBelt $ Bol $ Aro R
|
||||
'D' -> sendBelt $ Bol $ Aro L
|
||||
_ -> bell
|
||||
loop rd { rdEscape = False, rdBracket = False}
|
||||
else if isAsciiLower c then do
|
||||
sendBelt $ Met $ Cord $ pack [c]
|
||||
loop rd { rdEscape = False }
|
||||
else if c == '.' then do
|
||||
sendBelt $ Met $ Cord "dot"
|
||||
sendBelt $ Mod Met $ Key c
|
||||
loop rd { rdEscape = False }
|
||||
else if w == 8 || w == 127 then do
|
||||
sendBelt $ Met $ Cord "bac"
|
||||
sendBelt $ Mod Met $ Bac ()
|
||||
loop rd { rdEscape = False }
|
||||
else if c == '[' || c == '0' then do
|
||||
loop rd { rdBracket = True }
|
||||
@ -543,31 +555,31 @@ localClient doneSignal = fst <$> mkRAcquire start stop
|
||||
error "empty utf8 accumulation buffer"
|
||||
Just (c, bytes) | bytes /= rdUTF8width ->
|
||||
error "utf8 character size mismatch?!"
|
||||
Just (c, bytes) -> sendBelt $ Txt $ Tour $ [c]
|
||||
Just (c, bytes) -> sendBelt $ Bol $ Key c
|
||||
loop rd { rdUTF8 = mempty, rdUTF8width = 0 }
|
||||
else if w >= 32 && w < 127 then do
|
||||
sendBelt $ Txt $ Tour $ [c]
|
||||
sendBelt $ Bol $ Key c
|
||||
loop rd
|
||||
else if w == 0 then do
|
||||
bell
|
||||
loop rd
|
||||
else if w == 8 || w == 127 then do
|
||||
sendBelt $ Bac ()
|
||||
sendBelt $ Bol $ Bac ()
|
||||
loop rd
|
||||
else if w == 13 then do
|
||||
sendBelt $ Ret ()
|
||||
sendBelt $ Bol $ Ret ()
|
||||
loop rd
|
||||
else if w == 3 then do
|
||||
-- ETX (^C)
|
||||
logInfo $ "Ctrl-c interrupt"
|
||||
atomically $ do
|
||||
writeTQueue wq [Term.Trace "interrupt\r\n"]
|
||||
writeTQueue rq $ Ctl $ Cord "c"
|
||||
writeTQueue rq $ Mod Ctl $ Key 'c'
|
||||
loop rd
|
||||
else if w <= 26 then do
|
||||
case pack [BS.w2c (w + 97 - 1)] of
|
||||
"d" -> atomically doneSignal
|
||||
c -> do sendBelt $ Ctl $ Cord c
|
||||
case BS.w2c (w + 97 - 1) of
|
||||
'd' -> atomically doneSignal
|
||||
c -> do sendBelt $ Mod Ctl $ Key c
|
||||
loop rd
|
||||
else if w == 27 then do
|
||||
loop rd { rdEscape = True }
|
||||
@ -644,7 +656,7 @@ term env (tsize, Client{..}) plan stat serfSIGINT = runTerm
|
||||
atomically take >>= \case
|
||||
Nothing -> pure ()
|
||||
Just (ClientTakeBelt b) -> do
|
||||
when (b == Ctl (Cord "c")) $ do
|
||||
when (b == Mod Ctl (Key 'c')) $ do
|
||||
io serfSIGINT
|
||||
let beltEv = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b
|
||||
let beltFailed _ = pure ()
|
||||
|
||||
@ -39,11 +39,11 @@ data Ev
|
||||
= EvLine Text
|
||||
| EvSlog (Atom, Tank)
|
||||
| EvSpin SpinnerState
|
||||
| EvMove Word
|
||||
| EvMove (Word, Word)
|
||||
| EvBell
|
||||
| EvDraw
|
||||
| EvEdit Text
|
||||
| EvMore
|
||||
| EvNewl
|
||||
deriving (Show)
|
||||
|
||||
data Ef
|
||||
@ -62,7 +62,7 @@ data History
|
||||
data St = St
|
||||
{ sHistory :: !(Seq History)
|
||||
, sLine :: !Text
|
||||
, sCurPos :: !Word
|
||||
, sCurPos :: !(Word, Word)
|
||||
, sSpinner :: !SpinnerState
|
||||
}
|
||||
deriving (Show)
|
||||
@ -70,10 +70,10 @@ data St = St
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
init :: St
|
||||
init = St mempty "" 0 Nothing
|
||||
init = St mempty "" (0, 0) Nothing
|
||||
|
||||
{-|
|
||||
When we process `EvMore`, we need to append a newline to the end of
|
||||
When we process `EvNewl`, we need to append a newline to the end of
|
||||
the current line. During normal play, the ENTER key inserts the
|
||||
newline for us, so we need to recreate that newline when we rebuild
|
||||
the state for a new terminal connection.
|
||||
@ -83,15 +83,17 @@ step st@St{..} = \case
|
||||
EvLine t -> st & recordText t
|
||||
EvSlog s -> st & recordSlog s
|
||||
EvSpin s -> st { sSpinner = s }
|
||||
EvMove w -> st { sCurPos = min w (word $ length sLine) }
|
||||
EvEdit t -> st { sLine = t, sCurPos = word (length t) }
|
||||
EvMore -> st { sLine = "", sCurPos = 0 } & recordText (sLine <> "\n")
|
||||
EvMove p -> st { sCurPos = p }
|
||||
EvEdit t -> if fst sCurPos == 0 then st { sLine = t }
|
||||
else st
|
||||
EvNewl -> if fst sCurPos == 0 then
|
||||
st { sLine = "", sCurPos = (0, 0) }
|
||||
& recordText (sLine <> "\n")
|
||||
else
|
||||
st { sCurPos = (((fst sCurPos) - 1), 0) }
|
||||
EvBell -> st
|
||||
EvDraw -> st
|
||||
where
|
||||
word :: Integral i => i -> Word
|
||||
word = fromIntegral
|
||||
|
||||
recordText :: Text -> St -> St
|
||||
recordText !t st@St{..} = st {
|
||||
sHistory = trim (sHistory |> (HistoryText t))
|
||||
@ -111,8 +113,8 @@ drawState :: St -> [Ev]
|
||||
drawState St{..} = hist <> out <> cur <> spin
|
||||
where
|
||||
hist = drawHistory <$> toList sHistory
|
||||
out = if null sLine then [] else [EvEdit sLine]
|
||||
cur = if 0 == sCurPos then [] else [EvMove $ fromIntegral $ sCurPos]
|
||||
out = if null sLine then [] else [EvEdit sLine]
|
||||
cur = if 0 == fst sCurPos then [] else [EvMove sCurPos]
|
||||
spin = maybe [] (singleton . EvSpin . Just) sSpinner
|
||||
|
||||
drawHistory (HistoryText t) = EvLine t
|
||||
@ -123,12 +125,13 @@ drawState St{..} = hist <> out <> cur <> spin
|
||||
|
||||
fromBlit :: Arvo.Blit -> Maybe Ev
|
||||
fromBlit = \case
|
||||
Arvo.Hop w -> Just $ EvMove $ fromIntegral w
|
||||
Arvo.Bel () -> Just EvBell
|
||||
Arvo.Clr () -> Just EvDraw
|
||||
Arvo.Lin s -> Just $ EvEdit (pack s)
|
||||
Arvo.Mor () -> Just EvMore
|
||||
_ -> Nothing
|
||||
Arvo.Hop (Arvo.Col c) -> Just $ EvMove (0, fromIntegral c)
|
||||
Arvo.Hop (Arvo.Roc r c) -> Just $ EvMove (fromIntegral r, fromIntegral c)
|
||||
Arvo.Bel () -> Just EvBell
|
||||
Arvo.Clr () -> Just EvDraw
|
||||
Arvo.Put s -> Just $ EvEdit (pack s)
|
||||
Arvo.Nel () -> Just EvNewl
|
||||
_ -> Nothing
|
||||
|
||||
toCause :: Maybe Cord -> SpinnerCause
|
||||
toCause Nothing = User
|
||||
@ -148,12 +151,12 @@ fromTermEv = \case
|
||||
|
||||
toTermEv :: Ev -> Term.Ev
|
||||
toTermEv = \case
|
||||
EvLine "" -> Term.Blank
|
||||
EvLine t -> Term.Trace (Cord t)
|
||||
EvSlog s -> Term.Slog s
|
||||
EvSpin s -> Term.Spinr (fromCause <$> s)
|
||||
EvMove w -> Term.Blits [Arvo.Hop $ fromIntegral w]
|
||||
EvBell -> Term.Blits [Arvo.Bel ()]
|
||||
EvDraw -> Term.Blits [Arvo.Clr ()]
|
||||
EvEdit t -> Term.Blits [Arvo.Lin $ unpack t]
|
||||
EvMore -> Term.Blits [Arvo.Mor ()]
|
||||
EvLine "" -> Term.Blank
|
||||
EvLine t -> Term.Trace (Cord t)
|
||||
EvSlog s -> Term.Slog s
|
||||
EvSpin s -> Term.Spinr (fromCause <$> s)
|
||||
EvMove (r, c) -> Term.Blits [Arvo.Hop $ Arvo.Roc (fromIntegral r) (fromIntegral c)]
|
||||
EvBell -> Term.Blits [Arvo.Bel ()]
|
||||
EvDraw -> Term.Blits [Arvo.Clr ()]
|
||||
EvEdit t -> Term.Blits [Arvo.Put $ unpack t]
|
||||
EvNewl -> Term.Blits [Arvo.Nel ()]
|
||||
|
||||
@ -4,9 +4,13 @@
|
||||
module Urbit.Vere.Term.Render
|
||||
( clearScreen
|
||||
, clearLine
|
||||
, cursorRight
|
||||
, cursorLeft
|
||||
, soundBell
|
||||
, cursorMove
|
||||
, cursorSave
|
||||
, cursorRestore
|
||||
, putCSI
|
||||
, hijack
|
||||
, lojack
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
@ -25,8 +29,31 @@ clearLine = liftIO $ ANSI.clearLine
|
||||
soundBell :: MonadIO m => m ()
|
||||
soundBell = liftIO $ putStr "\a"
|
||||
|
||||
cursorLeft :: MonadIO m => Int -> m ()
|
||||
cursorLeft = liftIO . ANSI.cursorBackward
|
||||
--NOTE top-left-0-based coordinates
|
||||
cursorMove :: MonadIO m => Int -> Int -> m ()
|
||||
cursorMove r c = liftIO $ ANSI.setCursorPosition r c
|
||||
|
||||
cursorRight :: MonadIO m => Int -> m ()
|
||||
cursorRight = liftIO . ANSI.cursorForward
|
||||
cursorSave :: MonadIO m => m ()
|
||||
cursorSave = liftIO $ ANSI.saveCursor
|
||||
|
||||
cursorRestore :: MonadIO m => m ()
|
||||
cursorRestore = liftIO $ ANSI.restoreCursor
|
||||
|
||||
putCSI :: MonadIO m => Char -> [Int] -> m ()
|
||||
putCSI c a = liftIO do
|
||||
putStr "\x1b["
|
||||
putStr $ pack $ mconcat $ intersperse ";" (fmap show a)
|
||||
putStr $ pack [c]
|
||||
|
||||
hijack :: MonadIO m => Int -> m ()
|
||||
hijack h = liftIO do
|
||||
putCSI 'r' [1, h-1] -- set scroll region to exclude bottom line
|
||||
putCSI 'S' [1] -- scroll up one line
|
||||
cursorMove (h-2) 0 -- move cursor to empty space --TODO off-by-one?
|
||||
|
||||
lojack :: MonadIO m => m ()
|
||||
lojack = liftIO do
|
||||
putCSI 'r' [] -- reset scroll region
|
||||
cursorRestore -- restory cursor position
|
||||
|
||||
--TODO consider ANSI.setSGR
|
||||
|
||||
Loading…
Reference in New Issue
Block a user