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

[mohkale@kisara.moe]

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.
+
 \f
 * 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
 
 \f
 /***********************************************************************
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