procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add methods for strings to cl-print

Browse source 
* 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.
This commit is contained in:
Gemini Lasswell 2018-06-15 10:26:13 -07:00
parent eba16e5e58
commit 8a7620955b
2 changed files with 152 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

102
lisp/emacs-lisp/cl-print.el
View file

@ -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))

53
test/lisp/emacs-lisp/cl-print-tests.el
View file

@ -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)