Merge pull request #3487 from urbit/m/term-escape-kh

kh: support rendering +stub as ansi escape codes

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
 

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