Add methods for strings to cl-print

* lisp/emacs-lisp/cl-print.el (cl-print-object) <string>: New method.
(cl-print-object-contents) <string>: New method.
(cl-print--find-sharing): Look in string property lists.

* test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-3): Test
printing of long strings.
(cl-print-tests-4): Test printing of strings nested in other objects.
(cl-print-tests-strings, cl-print-tests-ellipsis-string): New
tests.

2 files changed, 152 insertions, 3 deletions

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index befbca0e97d..186ff8a7091 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -285,6 +285,95 @@ into a button whose action shows the function's disassembly.")
       (princ " " stream)
       (cl-print-insert-ellipsis object limit stream))))
 
+(cl-defmethod cl-print-object ((object string) stream)
+  (unless stream (setq stream standard-output))
+  (let* ((has-properties (or (text-properties-at 0 object)
+                             (next-property-change 0 object)))
+         (len (length object))
+         (limit (if (natnump print-length) (min print-length len) len)))
+    (if (and has-properties
+             cl-print--depth
+             (natnump print-level)
+             (> cl-print--depth print-level))
+        (cl-print-insert-ellipsis object 0 stream)
+      ;; Print all or part of the string
+      (when has-properties
+        (princ "#(" stream))
+      (if (= limit len)
+          (prin1 (if has-properties (substring-no-properties object) object)
+                 stream)
+        (let ((part (concat (substring-no-properties object 0 limit) "...")))
+          (prin1 part stream)
+          (when (bufferp stream)
+            (with-current-buffer stream
+              (cl-print-propertize-ellipsis object limit
+                                            (- (point) 4)
+                                            (- (point) 1) stream)))))
+      ;; Print the property list.
+      (when has-properties
+        (let* ((interval-limit (and (natnump print-length)
+                                    (max 1 (/ print-length 3))))
+               (interval-count 0)
+               (start-pos (if (text-properties-at 0 object)
+                              0 (next-property-change 0 object)))
+               (end-pos (next-property-change start-pos object len)))
+          (while (and (or (null interval-limit)
+                          (< interval-count interval-limit))
+                      (< start-pos len))
+            (let ((props (text-properties-at start-pos object)))
+              (when props
+                (princ " " stream) (princ start-pos stream)
+                (princ " " stream) (princ end-pos stream)
+                (princ " " stream) (cl-print-object props stream)
+                (cl-incf interval-count))
+              (setq start-pos end-pos
+                    end-pos (next-property-change start-pos object len))))
+          (when (< start-pos len)
+            (princ " " stream)
+            (cl-print-insert-ellipsis object (list start-pos) stream)))
+        (princ ")" stream)))))
+
+(cl-defmethod cl-print-object-contents ((object string) start stream)
+  ;; If START is an integer, it is an index into the string, and the
+  ;; ellipsis that needs to be expanded is part of the string.  If
+  ;; START is a cons, its car is an index into the string, and the
+  ;; ellipsis that needs to be expanded is in the property list.
+  (let* ((len (length object)))
+    (if (atom start)
+        ;; Print part of the string.
+        (let* ((limit (if (natnump print-length)
+                          (min (+ start print-length) len) len))
+               (substr (substring-no-properties object start limit))
+               (printed (prin1-to-string substr))
+               (trimmed (substring printed 1 (1- (length printed)))))
+          (princ trimmed)
+          (when (< limit len)
+            (cl-print-insert-ellipsis object limit stream)))
+
+      ;; Print part of the property list.
+      (let* ((first t)
+             (interval-limit (and (natnump print-length)
+                                  (max 1 (/ print-length 3))))
+             (interval-count 0)
+             (start-pos (car start))
+             (end-pos (next-property-change start-pos object len)))
+        (while (and (or (null interval-limit)
+                        (< interval-count interval-limit))
+                    (< start-pos len))
+          (let ((props (text-properties-at start-pos object)))
+            (when props
+              (if first
+                  (setq first nil)
+                (princ " " stream))
+              (princ start-pos stream)
+              (princ " " stream) (princ end-pos stream)
+              (princ " " stream) (cl-print-object props stream)
+              (cl-incf interval-count))
+            (setq start-pos end-pos
+                  end-pos (next-property-change start-pos object len))))
+        (when (< start-pos len)
+          (princ " " stream)
+          (cl-print-insert-ellipsis object (list start-pos) stream))))))
 
 ;;; Circularity and sharing.
 
@@ -346,8 +435,17 @@ into a button whose action shows the function's disassembly.")
                  (push cdr stack)
                  (push car stack))
                 ((pred stringp)
-                 ;; We presumably won't print its text-properties.
-                 nil)
+                 (let* ((len (length object))
+                        (start (if (text-properties-at 0 object)
+                                   0 (next-property-change 0 object)))
+                        (end (and start
+                                  (next-property-change start object len))))
+                   (while (and start (< start len))
+                     (let ((props (text-properties-at start object)))
+                       (when props
+                         (push props stack))
+                       (setq start end
+                             end (next-property-change start object len))))))
                 ((or (pred arrayp) (pred byte-code-function-p))
                  ;; FIXME: Inefficient for char-tables!
                  (dotimes (i (length object))
diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el
index 2b5eb3402bf..7594d2466b5 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -56,11 +56,13 @@
   (let ((long-list (make-list 5 'a))
         (long-vec (make-vector 5 'b))
         (long-struct (cl-print-tests-con))
+        (long-string (make-string 5 ?a))
         (print-length 4))
     (should (equal "(a a a a ...)" (cl-prin1-to-string long-list)))
     (should (equal "[b b b b ...]" (cl-prin1-to-string long-vec)))
     (should (equal "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"
-                   (cl-prin1-to-string long-struct)))))
+                   (cl-prin1-to-string long-struct)))
+    (should (equal "\"aaaa...\"" (cl-prin1-to-string long-string)))))
 
 (ert-deftest cl-print-tests-4 ()
   "CL printing observes `print-level'."
@@ -68,11 +70,16 @@
          (buried-vector '(a (b (c (d [e])))))
          (deep-struct (cl-print-tests-con))
          (buried-struct `(a (b (c (d ,deep-struct)))))
+         (buried-string '(a (b (c (d #("hello" 0 5 (cl-print-test t)))))))
+         (buried-simple-string '(a (b (c (d "hello")))))
          (print-level 4))
     (setf (cl-print-tests-struct-a deep-struct) deep-list)
     (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string deep-list)))
     (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-vector)))
     (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-struct)))
+    (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-string)))
+    (should (equal "(a (b (c (d \"hello\"))))"
+                   (cl-prin1-to-string buried-simple-string)))
     (should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)"
                    (cl-prin1-to-string deep-struct)))))
 
@@ -86,6 +93,35 @@
       (should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))"
                      (cl-prin1-to-string quoted-stuff))))))
 
+(ert-deftest cl-print-tests-strings ()
+  "CL printing prints strings and propertized strings."
+  (let* ((str1 "abcdefghij")
+         (str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t)))
+         (str3 #("abcdefghij" 0 10 (test t)))
+         (obj '(a b))
+         ;; Since the byte compiler reuses string literals,
+         ;; and the put-text-property call is destructive, use
+         ;; copy-sequence to make a new string.
+         (str4 (copy-sequence "abcdefghij")))
+    (put-text-property 0 5 'test obj str4)
+    (put-text-property 7 10 'test obj str4)
+
+    (should (equal "\"abcdefghij\"" (cl-prin1-to-string str1)))
+    (should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))"
+                   (cl-prin1-to-string str2)))
+    (should (equal "#(\"abcdefghij\" 0 10 (test t))"
+                   (cl-prin1-to-string str3)))
+    (let ((print-circle nil))
+      (should
+       (equal
+        "#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))"
+        (cl-prin1-to-string str4))))
+    (let ((print-circle t))
+      (should
+       (equal
+        "#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))"
+        (cl-prin1-to-string str4))))))
+
 (ert-deftest cl-print-tests-ellipsis-cons ()
   "Ellipsis expansion works in conses."
   (let ((print-length 4)
@@ -113,6 +149,21 @@
     (cl-print-tests-check-ellipsis-expansion
      [a [b [c [d [e]]]]] "[a [b [c ...]]]" "[d [e]]")))
 
+(ert-deftest cl-print-tests-ellipsis-string ()
+  "Ellipsis expansion works in strings."
+  (let ((print-length 4)
+        (print-level 3))
+    (cl-print-tests-check-ellipsis-expansion
+     "abcdefg" "\"abcd...\"" "efg")
+    (cl-print-tests-check-ellipsis-expansion
+     "abcdefghijk" "\"abcd...\"" "efgh...")
+    (cl-print-tests-check-ellipsis-expansion
+     '(1 (2 (3 #("abcde" 0 5 (test t)))))
+     "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))")
+    (cl-print-tests-check-ellipsis-expansion
+     #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t))
+     "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ...")))
+
 (ert-deftest cl-print-tests-ellipsis-struct ()
   "Ellipsis expansion works in structures."
   (let ((print-length 4)