bug#62994: [PATCH v4] Add support for colored and styled underlines on tty frames

[mohkale]

From: Mohsin Kaleem <mohkale@kisara.moe>

* src/dispextern.h (face, face_underline_type, syms_of_xfacse,
internal-set-lisp-face-attribute, gui_supports_face_attributes_p):
Add definitions for new underline styles of Double, Dotted and Dashed.
Delete tty_underline_p from the face struct and use just underline going
forward.  Add a flag to check whether styled underlines are available.
* lisp/cus-face.el (custom-face-attributes): Add entries for Double,
Dotted and Dashed so they can be set through `customize'.
* src/termchar.c (tty_display_info): Add an entry for the escape
sequence to set the underline style and color on terminal frames.
* src/term.c (init_tty, tty_capable_p, turn_on_face): Read and save the
underline style escape sequence from the Smulx termcap (alternatively if
the Su flag is set use a default sequence).  Allow checking for support
of styled underlines in the current terminal frame.  Output the necessary
escape sequences to activate a styled underline on turn_on_face; this is
currently only used for the new special underline styles, a default
straight underline will still use the "us" termcap.  Output escape
sequence to set underline color when set in the face and supported by
the tty.  Save a default value for this sequence on init_tty when styled
underlines are supported.
* src/xfaces.c (tty_supports_face_attributes_p, realize_tty_face):
Assert whether styled underlines are supported by the current terminal
on display-supports-face-attributes-p checks.  Populate the correct
underline style and color in the face spec when realizing a face.
---
 etc/NEWS         |  13 ++++
 lisp/cus-face.el |   5 +-
 src/dispextern.h |  10 ++-
 src/term.c       |  54 +++++++++++++--
 src/termchar.h   |   7 ++
 src/xfaces.c     | 167 +++++++++++++++++++++++++++++++++++++++++++----
 6 files changed, 235 insertions(+), 21 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 5ee1509859b..e6192e09f81 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -311,6 +311,19 @@ Previously, it was set to t but this broke remote file 
name detection.
 ** Multi-character key echo now ends with a suggestion to use Help.
 Customize 'echo-keystrokes-help' to nil to prevent that.
 
+---
+** Support for 'styled' and 'colored' underline face attributes on TTY frames
+If your terminals termcap or terminfo database entry has the 'Su' or
+'Smulx' capability defined, Emacs will now emit the prescribed escape
+sequence necessary to render faces with styled underlines on TTY
+frames.
+
+Styled underlines are any underlines containing a non-default
+underline style or a color other than the foreground-color.
+The available underline styles for TTY frames are 'double', 'wave',
+'dotted', and 'dashed'.  These are currently supported by Kitty,
+libvte, and st (through the undercurl patch) among other terminals.
+
 
 * Editing Changes in Emacs 30.1
 
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 47afa841f5e..12551e37785 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -141,7 +141,10 @@ custom-face-attributes
                   (const :format "" :value :style)
                   (choice :tag "Style"
                           (const :tag "Line" line)
-                          (const :tag "Wave" wave))
+                          (const :tag "Double" double)
+                          (const :tag "Wave" wave)
+                          (const :tag "Dotted" dotted)
+                          (const :tag "Dashed" dashed))
                    (const :format "" :value :position)
                    (choice :tag "Position"
                            (const :tag "At Default Position" nil)
diff --git a/src/dispextern.h b/src/dispextern.h
index 5387cb45603..574798fc547 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -1690,9 +1690,13 @@ #define FONT_TOO_HIGH(ft)                                
                \
 
 enum face_underline_type
 {
+       /* Note: Order matches the order of the Smulx terminfo extension. */
   FACE_NO_UNDERLINE = 0,
   FACE_UNDER_LINE,
-  FACE_UNDER_WAVE
+  FACE_DOUBLE_UNDER_LINE,
+  FACE_UNDER_WAVE,
+  FACE_DOTTED_UNDER_LINE,
+  FACE_DASHED_UNDER_LINE,
 };
 
 /* Structure describing a realized face.
@@ -1776,7 +1780,7 @@ #define FONT_TOO_HIGH(ft)                                 
        \
   ENUM_BF (face_box_type) box : 2;
 
   /* Style of underlining. */
-  ENUM_BF (face_underline_type) underline : 2;
+  ENUM_BF (face_underline_type) underline : 3;
 
   /* If `box' above specifies a 3D type, true means use box_color for
      drawing shadows.  */
@@ -1808,7 +1812,6 @@ #define FONT_TOO_HIGH(ft)                                 
        \
      string meaning the default color of the TTY.  */
   bool_bf tty_bold_p : 1;
   bool_bf tty_italic_p : 1;
-  bool_bf tty_underline_p : 1;
   bool_bf tty_reverse_p : 1;
   bool_bf tty_strike_through_p : 1;
 
@@ -3421,6 +3424,7 @@ #define TTY_CAP_BOLD              0x04
 #define TTY_CAP_DIM            0x08
 #define TTY_CAP_ITALIC         0x10
 #define TTY_CAP_STRIKE_THROUGH 0x20
+#define TTY_CAP_UNDERLINE_STYLED       0x32 & TTY_CAP_UNDERLINE
 
 
 /***********************************************************************
diff --git a/src/term.c b/src/term.c
index 3fa244be824..d5a5442cb19 100644
--- a/src/term.c
+++ b/src/term.c
@@ -2014,8 +2014,19 @@ turn_on_face (struct frame *f, int face_id)
        OUTPUT1 (tty, tty->TS_enter_dim_mode);
     }
 
-  if (face->tty_underline_p && MAY_USE_WITH_COLORS_P (tty, NC_UNDERLINE))
-    OUTPUT1_IF (tty, tty->TS_enter_underline_mode);
+  if (face->underline && MAY_USE_WITH_COLORS_P (tty, NC_UNDERLINE))
+       {
+       if (face->underline == FACE_UNDER_LINE
+               || !tty->TF_set_underline_style)
+               OUTPUT1_IF (tty, tty->TS_enter_underline_mode);
+       else if (tty->TF_set_underline_style)
+         {
+               char *p;
+               p = tparam(tty->TF_set_underline_style, NULL, 0, 
face->underline, 0, 0, 0);
+               OUTPUT (tty, p);
+               xfree (p);
+         }
+       }
 
   if (face->tty_strike_through_p
       && MAY_USE_WITH_COLORS_P (tty, NC_STRIKE_THROUGH))
@@ -2041,6 +2052,14 @@ turn_on_face (struct frame *f, int face_id)
          OUTPUT (tty, p);
          xfree (p);
        }
+
+         ts = tty->TF_set_underline_color;
+         if (ts && face->underline_color)
+       {
+         p = tparam (ts, NULL, 0, face->underline_color, 0, 0, 0);
+         OUTPUT (tty, p);
+         xfree (p);
+       }
     }
 }
 
@@ -2061,7 +2080,7 @@ turn_off_face (struct frame *f, int face_id)
       if (face->tty_bold_p
          || face->tty_italic_p
          || face->tty_reverse_p
-         || face->tty_underline_p
+         || face->underline
          || face->tty_strike_through_p)
        {
          OUTPUT1_IF (tty, tty->TS_exit_attribute_mode);
@@ -2073,7 +2092,7 @@ turn_off_face (struct frame *f, int face_id)
     {
       /* If we don't have "me" we can only have those appearances
         that have exit sequences defined.  */
-      if (face->tty_underline_p)
+      if (face->underline)
        OUTPUT_IF (tty, tty->TS_exit_underline_mode);
     }
 
@@ -2104,6 +2123,9 @@ #define TTY_CAPABLE_P_TRY(tty, cap, TS, NC_bit)           
                \
   TTY_CAPABLE_P_TRY (tty,
                     TTY_CAP_UNDERLINE,   tty->TS_enter_underline_mode,
                     NC_UNDERLINE);
+  TTY_CAPABLE_P_TRY (tty,
+                        TTY_CAP_UNDERLINE_STYLED,        
tty->TF_set_underline_style,
+                        NC_UNDERLINE);
   TTY_CAPABLE_P_TRY (tty,
                     TTY_CAP_BOLD,        tty->TS_enter_bold_mode, NC_BOLD);
   TTY_CAPABLE_P_TRY (tty,
@@ -4360,6 +4382,30 @@ init_tty (const char *name, const char *terminal_type, 
bool must_succeed)
   tty->TF_underscore = tgetflag ("ul");
   tty->TF_teleray = tgetflag ("xt");
 
+  /* Styled underlines.         Support for this is provided either by the
+        escape sequence in Smulx or the Su flag.  The latter results in a
+        common default escape sequence and is not recommended.  */
+#ifdef TERMINFO
+       tty->TF_set_underline_style = tigetstr("Smulx");
+       if (tty->TF_set_underline_style == (char *) (intptr_t) -1)
+               tty->TF_set_underline_style = NULL;
+#else
+       tty->TF_set_underline_style = tgetstr("Smulx", address);
+#endif
+       if (!tty->TF_set_underline_style && tgetflag("Su"))
+               /* Default to the kitty escape sequence.  See
+                  https://sw.kovidgoyal.net/kitty/underlines/ */
+               tty->TF_set_underline_style = "\x1b[4:%p1%dm";
+
+       if (tty->TF_set_underline_style)
+               /* This escape sequence for setting the underline color is
+                  consistent with the one described in kitty (see above) and
+                  adapted from the one used by neovim.  This sequence has
+                  been altered from the neovim sequence at
+                  
https://github.com/neovim/neovim/blob/42f492ac99058bd1cd56c3c7871e7e464b2a5e24/src/nvim/tui/tui.c#L1932
+                  to require only a single parameter, the color index.  */
+               tty->TF_set_underline_color = 
"\x1b[58:2::%p1%{65536}%/%d:%p1%{256}%/%{255}%&%d:%p1%{255}%&%dm";
+
 #else /* DOS_NT */
 #ifdef WINDOWSNT
   {
diff --git a/src/termchar.h b/src/termchar.h
index 2d845107e11..de9009d32f1 100644
--- a/src/termchar.h
+++ b/src/termchar.h
@@ -171,6 +171,13 @@ #define EMACS_TERMCHAR_H
                                    non-blank position.  Must clear before 
writing _.  */
   int TF_teleray;               /* termcap xt flag: many weird consequences.
                                    For t1061. */
+  const char *TF_set_underline_style; /* termcap Smulx entry: Switches the 
underline
+                                                                               
 style based on the parameter.  Param should
+                                                                               
 be one of: 0 (none), 1 (straight), 2 (double),
+                                                                               
 3 (wave), 4 (dotted), or 5 (dashed).  */
+  const char *TF_set_underline_color; /* Enabled when TF_set_underline_style 
is set:
+                                                                               
 Sets the color of the underline.  Accepts a
+                                                                               
 single parameter, the color index.      */
 
   int RPov;                     /* # chars to start a TS_repeat */
 
diff --git a/src/xfaces.c b/src/xfaces.c
index a558e7328c0..75fae11dca3 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -3311,7 +3311,11 @@ DEFUN ("internal-set-lisp-face-attribute", 
Finternal_set_lisp_face_attribute,
                 }
 
               else if (EQ (key, QCstyle)
-                       && !(EQ (val, Qline) || EQ (val, Qwave)))
+                                          && !(EQ (val, Qline)
+                                                       || EQ (val, Qdouble)
+                                                       || EQ (val, Qwave)
+                                                       || EQ (val, Qdotted)
+                                                       || EQ (val, Qdashed)))
                 {
                   valid_p = false;
                   break;
@@ -5266,6 +5270,7 @@ gui_supports_face_attributes_p (struct frame *f,
                                 Lisp_Object attrs[LFACE_VECTOR_SIZE],
                                 struct face *def_face)
 {
+  Lisp_Object val;
   Lisp_Object *def_attrs = def_face->lface;
   Lisp_Object lattrs[LFACE_VECTOR_SIZE];
 
@@ -5360,6 +5365,20 @@ gui_supports_face_attributes_p (struct frame *f,
       return false;
     }
 
+  /* Check supported underline styles. */
+  val = attrs[LFACE_UNDERLINE_INDEX];
+  if (!UNSPECIFIEDP (val))
+       {
+       if (EQ (CAR_SAFE (val), QCstyle))
+         {
+               if (!(EQ (CAR_SAFE (CDR_SAFE (val)), Qline)
+                         || EQ (CAR_SAFE (CDR_SAFE (val)), Qwave)))
+                 {
+                       return false; /* Unsupported underline style */
+                 }
+         }
+       }
+
   /* Everything checks out, this face is supported.  */
   return true;
 }
@@ -5452,15 +5471,26 @@ tty_supports_face_attributes_p (struct frame *f,
   val = attrs[LFACE_UNDERLINE_INDEX];
   if (!UNSPECIFIEDP (val))
     {
-      if (STRINGP (val))
-       return false;           /* ttys can't use colored underlines */
-      else if (EQ (CAR_SAFE (val), QCstyle) && EQ (CAR_SAFE (CDR_SAFE (val)), 
Qwave))
-       return false;           /* ttys can't use wave underlines */
-      else if (face_attr_equal_p (val, def_attrs[LFACE_UNDERLINE_INDEX]))
-       return false;           /* same as default */
-      else
-       test_caps |= TTY_CAP_UNDERLINE;
-    }
+       if (STRINGP (val))
+               test_caps |= TTY_CAP_UNDERLINE_STYLED;
+       else if (EQ (CAR_SAFE (val), QCstyle))
+         {
+       if (!(EQ (CAR_SAFE (CDR_SAFE (val)), Qline)
+                 || EQ (CAR_SAFE (CDR_SAFE (val)), Qdouble)
+                 || EQ (CAR_SAFE (CDR_SAFE (val)), Qwave)
+                 || EQ (CAR_SAFE (CDR_SAFE (val)), Qdotted)
+                 || EQ (CAR_SAFE (CDR_SAFE (val)), Qdashed)))
+         {
+               return false; /* Face uses an unsupported underline style.      
*/
+         }
+
+       test_caps |= TTY_CAP_UNDERLINE_STYLED;
+         }
+       else if (face_attr_equal_p (val, def_attrs[LFACE_UNDERLINE_INDEX]))
+               return false;  /* same as default */
+       else
+               test_caps |= TTY_CAP_UNDERLINE;
+  }
 
   /* inverse video */
   val = attrs[LFACE_INVERSE_INDEX];
@@ -6381,6 +6411,8 @@ realize_gui_face (struct face_cache *cache, Lisp_Object 
attrs[LFACE_VECTOR_SIZE]
                 face->underline = FACE_UNDER_LINE;
               else if (EQ (value, Qwave))
                 face->underline = FACE_UNDER_WAVE;
+             else
+               face->underline = FACE_UNDER_LINE;
             }
          else if (EQ (keyword, QCposition))
            {
@@ -6434,7 +6466,53 @@ realize_gui_face (struct face_cache *cache, Lisp_Object 
attrs[LFACE_VECTOR_SIZE]
 /* Map a specified color of face FACE on frame F to a tty color index.
    IDX is either LFACE_FOREGROUND_INDEX or LFACE_BACKGROUND_INDEX, and
    specifies which color to map.  Set *DEFAULTED to true if mapping to the
-   default foreground/background colors.  */
+   default foreground/background colors. TODO(me): Update docstring. */
+
+static void
+my_map_tty_color (struct frame *f, struct face *face, Lisp_Object color,
+                 enum lface_attribute_index idx)
+{
+       Lisp_Object frame, def;
+       unsigned long default_pixel = FACE_TTY_DEFAULT_FG_COLOR;
+       unsigned long pixel = default_pixel;
+
+       eassert (idx == LFACE_FOREGROUND_INDEX
+                || idx == LFACE_BACKGROUND_INDEX
+                || idx == LFACE_UNDERLINE_INDEX);
+
+       XSETFRAME (frame, f);
+
+       if (STRINGP (color)
+           && SCHARS (color)
+           && CONSP (Vtty_defined_color_alist)
+           && (def = assoc_no_quit (color, call1 (Qtty_color_alist, frame)),
+               CONSP (def)))
+       {
+               /* Associations in tty-defined-color-alist are of the form
+                  (NAME INDEX R G B).  We need the INDEX part.  */
+               pixel = XFIXNUM (XCAR (XCDR (def)));
+       }
+
+       if (pixel == default_pixel && STRINGP (color))
+       {
+               pixel = load_color (f, face, color, idx);
+       }
+
+       switch (idx)
+       {
+               case LFACE_UNDERLINE_INDEX:
+                       face->underline_color = pixel;
+                       break;
+               case LFACE_FOREGROUND_INDEX:
+                       face->foreground = pixel;
+                       break;
+               case LFACE_BACKGROUND_INDEX:
+                       face->background = pixel;
+                       break;
+               default:
+                       emacs_abort ();
+       }
+}
 
 static void
 map_tty_color (struct frame *f, struct face *face,
@@ -6515,6 +6593,7 @@ realize_tty_face (struct face_cache *cache,
 {
   struct face *face;
   int weight, slant;
+  Lisp_Object underline;
   bool face_colors_defaulted = false;
   struct frame *f = cache->f;
 
@@ -6534,13 +6613,72 @@ realize_tty_face (struct face_cache *cache,
     face->tty_bold_p = true;
   if (slant != 100)
     face->tty_italic_p = true;
-  if (!NILP (attrs[LFACE_UNDERLINE_INDEX]))
-    face->tty_underline_p = true;
   if (!NILP (attrs[LFACE_INVERSE_INDEX]))
     face->tty_reverse_p = true;
   if (!NILP (attrs[LFACE_STRIKE_THROUGH_INDEX]))
     face->tty_strike_through_p = true;
 
+  /* Text underline.  */
+  underline = attrs[LFACE_UNDERLINE_INDEX];
+  if (NILP (underline))
+    {
+       face->underline = FACE_NO_UNDERLINE;
+       face->underline_color = 0;
+    }
+  else if (EQ (underline, Qt))
+    {
+       face->underline = FACE_UNDER_LINE;
+       face->underline_color = 0;
+    }
+  else if (STRINGP (underline))
+    {
+       face->underline = FACE_UNDER_LINE;
+       my_map_tty_color (f, face, underline, LFACE_UNDERLINE_INDEX);
+    }
+  else if (CONSP (underline))
+    {
+       /* `(:color COLOR :style STYLE)'.
+          STYLE being one of `line', `double', `wave', `dotted' or `dashed'.  
*/
+       face->underline = FACE_UNDER_LINE;
+       face->underline_color = 0;
+
+       while (CONSP (underline))
+         {
+               Lisp_Object keyword, value;
+
+               keyword = XCAR (underline);
+               underline = XCDR (underline);
+
+               if (!CONSP (underline))
+                       break;
+               value = XCAR (underline);
+               underline = XCDR (underline);
+
+               if (EQ (keyword, QCcolor))
+                 {
+                       if (EQ (value, Qforeground_color))
+                               face->underline_color = 0;
+                       else if (STRINGP (value))
+                               my_map_tty_color (f, face, value, 
LFACE_UNDERLINE_INDEX);
+                 }
+               else if (EQ (keyword, QCstyle))
+                 {
+                       if (EQ (value, Qline))
+                               face->underline = FACE_UNDER_LINE;
+                       else if (EQ (value, Qdouble))
+                               face->underline = FACE_DOUBLE_UNDER_LINE;
+                       else if (EQ (value, Qwave))
+                               face->underline = FACE_UNDER_WAVE;
+                       else if (EQ (value, Qdotted))
+                               face->underline = FACE_DOTTED_UNDER_LINE;
+                       else if (EQ (value, Qdashed))
+                               face->underline = FACE_DASHED_UNDER_LINE;
+                       else
+                               face->underline = FACE_UNDER_LINE;
+                 }
+         }
+    }
+
   /* Map color names to color indices.  */
   map_tty_color (f, face, LFACE_FOREGROUND_INDEX, &face_colors_defaulted);
   map_tty_color (f, face, LFACE_BACKGROUND_INDEX, &face_colors_defaulted);
@@ -7229,6 +7367,9 @@ syms_of_xfaces (void)
   DEFSYM (QCposition, ":position");
   DEFSYM (Qline, "line");
   DEFSYM (Qwave, "wave");
+  DEFSYM (Qdouble, "double");
+  DEFSYM (Qdotted, "dotted");
+  DEFSYM (Qdashed, "dashed");
   DEFSYM (Qreleased_button, "released-button");
   DEFSYM (Qpressed_button, "pressed-button");
   DEFSYM (Qflat_button, "flat-button");
-- 
2.43.0