[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 8a76209 02/19: Add methods for strings to cl-print
From: |
Gemini Lasswell |
Subject: |
[Emacs-diffs] master 8a76209 02/19: Add methods for strings to cl-print |
Date: |
Fri, 3 Aug 2018 13:32:53 -0400 (EDT) |
branch: master
commit 8a7620955b4d859caecd9a5dc9f2a986baf994fd
Author: Gemini Lasswell <address@hidden>
Commit: Gemini Lasswell <address@hidden>
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.
---
lisp/emacs-lisp/cl-print.el | 102 ++++++++++++++++++++++++++++++++-
test/lisp/emacs-lisp/cl-print-tests.el | 53 ++++++++++++++++-
2 files changed, 152 insertions(+), 3 deletions(-)
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index e638e58..337efa4 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 2b5eb34..7594d24 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)
- [Emacs-diffs] master updated (e65ec81 -> da0054c), Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master 9aa9d79 07/19: Add links in backtraces to functions written in C (bug#25393), Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master 5b50fa5 04/19: Always make buttons from function names in backtraces, Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master 2ede75c 10/19: Change keybinding for backtrace-collapse from '=' to '-', Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master 8a76209 02/19: Add methods for strings to cl-print,
Gemini Lasswell <=
- [Emacs-diffs] master d6b364e 05/19: Lazily print backtrace frame local variables, Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master eba16e5 01/19: Support ellipsis expansion in cl-print, Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master af5f377 08/19: Add link in backtraces to position in buffer being evaluated (bug#14081), Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master 95b2ab3 18/19: Fix some documentation formatting nits, Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master 58be6cb 17/19: Fix typo in edebug-backtrace-hide-instrumentation's docstring., Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master ca98377 14/19: Add new commands to Edebug backtraces, Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master bb9de87 06/19: Add prefix argument to backtrace-toggle-print-circle, Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master 9879151 12/19: * lisp/emacs-lisp/debug.el (debugger-mode-map): Use easy-menu-define., Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master 1459ad2 13/19: Add a menu for backtrace-mode, Gemini Lasswell, 2018/08/03
- [Emacs-diffs] master 3cd6a68 16/19: Give two backtrace-mode commands better names, Gemini Lasswell, 2018/08/03