>From e4b1a2ef3b4b11466e81d639a09ff671318e0968 Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Sat, 11 Mar 2017 00:09:36 -0500 Subject: [PATCH v2] New pretty printer (Bug#25122) * lisp/emacs-lisp/pp.el (pp-state): New struct. (pp--scan): New function, measures length of sublists (actually "logical blocks" to allow for more customizable grouping than just by lists). Calls pp--print when scanned tokens are too wide to fit on a single line. (pp--print): New function, prints tokens horizontally or vertically depending on whether the sublist can fit within the line. (pp-prin1): New function, entry point for pp--scan and pp-print. (pp-print-object): New generic function. (pp-print-object) : New method, prettyprinter for lists. --- lisp/emacs-lisp/pp.el | 156 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 156 insertions(+) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 7ef46a48bd..8c2ed24ffd 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -24,6 +24,9 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) +(require 'ring) + (defvar font-lock-verbose) (defgroup pp nil @@ -121,6 +124,159 @@ pp-display-expression (setq buffer-read-only nil) (set (make-local-variable 'font-lock-verbose) nil))))) +(eval-when-compile + ;; FIXME: should we try to restore original settings? (how?) + (cl-proclaim '(optimize (speed 3) (safety 0)))) + +(cl-defstruct (pp-state (:constructor + make-pp-state + (stream + tempbuffer + right-margin + &aux + (left-margin 0) + (indent '(0)) + (scan-depth 0) + (print-depth 0) + (print-width 0) + (scan-width 0) + (block-mode (list nil)) + (fifo (make-ring 30))))) + stream + tempbuffer + right-margin ; how far we may go. + left-margin ; how far printer has gone + print-width ; total width of tokens printed so far. + indent ; left-margin, stack per depth. + scan-width ; total width of tokens scanned so far. + scan-depth + print-depth + block-widths + block-mode ; `:vertical', `:horizontal', nil (undecided); stack per depth. + fifo + ) + +(defun pp--print (state) + (cl-symbol-macrolet ((stream (pp-state-stream state)) + (depth (pp-state-print-depth state)) + (scan-depth (pp-state-scan-depth state)) + (fifo (pp-state-fifo state)) + (left-margin (pp-state-left-margin state)) + (width (pp-state-print-width state)) + (indent (pp-state-indent state)) + (right-margin (pp-state-right-margin state)) + (block-mode (pp-state-block-mode state))) + (catch 'rescan + (while (not (ring-empty-p fifo)) + (pcase (ring-remove fifo) + ((and `(,len . :open-block) token) + (if (<= len 0) + ;; Not ready to print this yet! + (progn (ring-insert-at-beginning fifo token) + (throw 'rescan nil)) + (cl-incf depth) + (push left-margin indent) + (push (if (> (+ left-margin len) right-margin) + :vertical :horizontal) + block-mode))) + (:close-block (cl-decf depth) (pop indent) (pop block-mode)) + (:blank + (pcase (car block-mode) + (:vertical + (terpri stream) + (princ (make-string (car indent) ?\s) stream) + (setf left-margin (car indent))) + ((or :horizontal 'nil) + (write-char ?\s stream) + (cl-incf left-margin)) + (_ (error "oops"))) + (cl-incf width)) + (:eof nil) + ((and (pred characterp) char) + (write-char char stream) + (cl-incf left-margin (char-width char)) + (cl-incf width (char-width char))) + (string + (princ string stream) + (cl-incf left-margin (string-width string)) + (cl-incf width (string-width string)))))))) + +(defun pp--scan (token state) + (cl-symbol-macrolet ((stream (pp-state-stream state)) + (depth (pp-state-scan-depth state)) + (print-depth (pp-state-print-depth state)) + (fifo (pp-state-fifo state)) + (width (pp-state-scan-width state)) + (right-margin (pp-state-right-margin state)) + (block-widths (pp-state-block-widths state))) + (cl-flet ((scanlen (len) (cl-incf width len))) + (cl-assert (> (ring-size fifo) (ring-length fifo))) + (ring-insert fifo token) + (pcase token + (:open-block + (cl-incf depth) + (let ((block-token (cons (- width) (ring-remove fifo 0)))) + (push block-token block-widths) + (ring-insert fifo block-token))) + (:close-block + (cl-incf (caar block-widths) width) + (when (> (caar block-widths) right-margin) + (pp--print state)) + (cl-decf depth) + (pop block-widths)) + (:blank (scanlen 1)) + (:eof (pp--print state)) + ((pred characterp) (scanlen (char-width token))) + (_ (scanlen (string-width token))))) + (when block-widths + (when (> (+ (caar block-widths) width) right-margin) + (dolist (block-width block-widths) + (setf (car block-width) (+ right-margin 1)))) + (when (> (caar block-widths) right-margin) + (pp--print state))))) + +(defvar cl-print-readably) ; cl-print.el + +(defun pp-prin1 (object &optional stream right-margin) + (unless right-margin + (setq right-margin fill-column)) + (with-temp-buffer + (let ((cl-print-readably nil) + (state (make-pp-state (or stream standard-output) (current-buffer) + right-margin))) + (pp--scan :open-block state) + (prog1 (pp-print-object object state) + (pp--scan :close-block state) + (pp--scan :eof state))))) + + +(cl-defgeneric pp-print-object (object state) + ;; Fallback to standard `cl-print-object'. + (pp--scan (with-current-buffer (pp-state-tempbuffer state) + (cl-prin1 object (current-buffer)) + (prog1 (buffer-string) + (erase-buffer))) + state) + object) + +(cl-defmethod pp-print-object ((list cons) state) + (pcase list + (`(,head . ,tail) + (pp--scan "(" state) + (pp--scan :open-block state) + (pp-print-object head state) + (while (consp tail) + (pp--scan :blank state) + (pp-print-object (pop tail) state)) + (when tail + (pp--scan :blank state) + (pp--scan ?\. state) + (pp--scan :blank state) + (pp-print-object tail state)) + (pp--scan :close-block state) + (pp--scan ")" state))) + list) + ;;;###autoload (defun pp-eval-expression (expression) "Evaluate EXPRESSION and pretty-print its value. -- 2.11.1