From dd3112985e6fd54d99499fdd1705d05be365fe89 Mon Sep 17 00:00:00 2001 From: Fang Date: Tue, 15 Sep 2020 16:40:28 +0200 Subject: [PATCH] kh: support rendering +stub as ansi escape codes Adds support to term.hs for a %klr blit, containing a +stub describing styled text. Dill will start making use of this in a separate commit, for release cutting reasons. --- pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs | 75 ++++++++++++++++++++++ pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs | 52 +++++++++++++++ 2 files changed, 127 insertions(+) diff --git a/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs b/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs index 606539907a..d77b25051c 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs @@ -112,6 +112,7 @@ data Blit = Bel () | Clr () | Hop Word64 + | Klr Stub | Lin [Char] | Mor () | Sag Path Noun @@ -119,12 +120,84 @@ data Blit | Url Cord deriving (Eq, Ord) +data Deco + = DecoBl + | DecoBr + | DecoUn + | DecoNull + deriving (Eq, Ord, Show) + +data Tint + = TintR + | TintG + | TintB + | TintC + | TintM + | TintY + | TintK + | TintW + | TintNull + deriving (Eq, Ord, Show) + +data Stye = Stye + { deco :: (HoonSet Deco) + , back :: Tint + , fore :: Tint + } + deriving (Eq, Ord, Show) + +newtype Stub = Stub [(Stye, [Char])] + deriving (Eq, Ord, Show) + +instance ToNoun Deco where + toNoun = \case + DecoBl -> toNoun $ Cord "bl" + DecoBr -> toNoun $ Cord "br" + DecoUn -> toNoun $ Cord "un" + DecoNull -> Atom 0 + +instance FromNoun Deco where + parseNoun = named "Deco" . \case + Atom 0 -> pure DecoNull + n -> parseNoun @Cord n <&> unCord >>= \case + "bl" -> pure DecoBl + "br" -> pure DecoBr + "un" -> pure DecoUn + t -> fail ("invalid: " <> unpack t) + +instance ToNoun Tint where + toNoun = \case + TintR -> toNoun $ Cord "r" + TintG -> toNoun $ Cord "g" + TintB -> toNoun $ Cord "b" + TintC -> toNoun $ Cord "c" + TintM -> toNoun $ Cord "m" + TintY -> toNoun $ Cord "y" + TintK -> toNoun $ Cord "k" + TintW -> toNoun $ Cord "w" + TintNull -> Atom 0 + +instance FromNoun Tint where + parseNoun = named "Tint" . \case + Atom 0 -> pure TintNull + n -> parseNoun @Cord n <&> unCord >>= \case + "r" -> pure TintR + "g" -> pure TintG + "b" -> pure TintB + "c" -> pure TintC + "m" -> pure TintM + "y" -> pure TintY + "k" -> pure TintK + "w" -> pure TintW + t -> fail ("invalid: " <> unpack t) + -- 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 (Klr s) = "Klr " ++ (show s) show (Lin c) = "Lin " ++ (show c) show (Mor ()) = "Mor ()" show (Sag path _) = "Sag " ++ (show path) @@ -144,6 +217,8 @@ data TermEf | TermEfMass Path Noun -- Irrelevant deriving (Eq, Ord, Show) +deriveNoun ''Stye +deriveNoun ''Stub deriveNoun ''Blit deriveNoun ''TermEf diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs index eea980a7fc..e4b5bf0cd4 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs @@ -30,6 +30,7 @@ import Urbit.King.API (readPortsFile) import Urbit.TermSize (TermSize(TermSize)) import Urbit.Vere.Term.API (Client(Client)) +import qualified Data.Set as S import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.UTF8 as BS import qualified System.Console.ANSI as ANSI @@ -342,6 +343,8 @@ localClient doneSignal = fst <$> mkRAcquire start stop 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 @@ -349,6 +352,55 @@ localClient doneSignal = fst <$> mkRAcquire start stop Sav path atom -> pure ls Url url -> pure ls + termRenderDeco :: Deco -> Char + termRenderDeco = \case + DecoBr -> '1' + DecoUn -> '4' + DecoBl -> '5' + DecoNull -> '0' + + termRenderTint :: Tint -> Char + termRenderTint = \case + TintK -> '0' + TintR -> '1' + TintG -> '2' + TintY -> '3' + TintB -> '4' + TintM -> '5' + TintC -> '6' + TintW -> '7' + TintNull -> '9' + + -- Wraps the appropriate escape sequence around a piece of styled text + termRenderStubSegment :: Stye -> [Char] -> [Char] + termRenderStubSegment Stye {..} tape = + case (S.null decoset, back, fore) of + (True, TintNull, TintNull) -> tape + _ -> styled + where + decoset = setFromHoonSet deco + escape = [chr 27, '['] + + styles = intercalate ";" $ filter (not . null) + [ intersperse ';' $ fmap termRenderDeco $ toList decoset + , case back of + TintNull -> [] + tint -> ['4', termRenderTint tint] + , case fore of + TintNull -> [] + tint -> ['3', termRenderTint tint] + ] + + styled = mconcat [escape, styles, "m", tape, escape, "0m"] + + -- Displays and sets styled text as the current line + termShowStub :: LineState -> Stub -> RIO e LineState + termShowStub ls (Stub s) = do + let visualLength = sum $ fmap (length . snd) s + let outText = pack $ mconcat $ fmap (uncurry termRenderStubSegment) s + putStr outText + pure ls { lsLine = outText, lsCurPos = visualLength } + -- Moves the cursor to the requested position termShowCursor :: LineState -> Int -> RIO e LineState termShowCursor ls@LineState{..} {-line pos)-} newPos = do