cgit.sxemacs.org Git - packages/blob - xemacs-packages/cedet-common/pprint.el

   1 ;;; pprint.el --- A flexible Elisp pretty-printer
   2
   3 ;; Copyright (C) 2002, 2003, 2004 David Ponce
   4
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 06 Mar 2002
   8 ;; Keywords: lisp
   9 ;; X-RCS: $Id: pprint.el,v 1.1 2007-11-26 15:06:42 michaels Exp $
  10
  11 ;; This file is not part of GNU Emacs.
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; see the file COPYING.  If not, write to
  25 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29 ;;
  30 ;; pprint library provides a simple and flexible pretty-printer for
  31 ;; Elisp code.
  32 ;;
  33 ;; The core function `pprint-to-string' uses `prin1' to write into a
  34 ;; temporary buffer a "flat" representation of a given expression.
  35 ;; Then it walks over that linear form and inserts line breaks and
  36 ;; indentations to produce a pretty-printed representation of the
  37 ;; expression.
  38 ;;
  39 ;; The implementation uses a lot of inline functions to improve
  40 ;; performance.  And, when byte-compiled, pprint is reasonably fast.
  41 ;;
  42 ;; pprint can handle specific expressions using adapted "printers".  A
  43 ;; "printer" is a function that will be called to process a form that
  44 ;; match a regular expression.  A number of "standard printers" are
  45 ;; predefined to pretty print common Elisp statements like `defun',
  46 ;; `defvar', `lambda', `let', `progn', `cond', `if', etc..
  47 ;;
  48 ;; More "printers" should be provided in future versions ;-)
  49 ;;
  50
  51 ;;; History:
  52 ;;
  53
  54 ;;; Code:
  55 \f
  56 ;;;;
  57 ;;;; Printers management
  58 ;;;;
  59
  60 (defvar pprint-standard-printers nil
  61   "The standard printers.")
  62
  63 (defvar pprint-printers nil
  64   "The current printers.
  65 This is an alist which maps printers (functions) to
  66 matchers (regexps).")
  67
  68 (defsubst pprint-clear-printers ()
  69   "Clear the current defined printers."
  70   (setq pprint-printers nil))
  71
  72 (defun pprint-push-printer (printer matcher)
  73   "Push a new PRINTER on top of defined printers.
  74 MATCHER is a regexp matching expressions passed to PRINTER."
  75   (add-to-list 'pprint-printers (cons printer matcher)))
  76 (put 'pprint-push-printer 'lisp-indent-function 1)
  77
  78 (defmacro pprint-with-printers (table &rest body)
  79   "Set up a copy of the TABLE of printers and evaluate BODY.
  80 The current table of printers is saved, BODY is evaluated, and the
  81 saved table is restored, even in case of an abnormal exit.  Value is
  82 what BODY returns."
  83   (let ((old-table (make-symbol "old-table")))
  84     `(let ((,old-table pprint-printers))
  85        (unwind-protect
  86            (progn
  87              (setq pprint-printers (copy-sequence ,table))
  88              ,@body)
  89          (setq pprint-printers ,old-table)))))
  90 (put 'pprint-with-printers 'lisp-indent-function 1)
  91 \f
  92 ;;;;
  93 ;;;; Core functions
  94 ;;;;
  95
  96 (defvar pprint-min-width 20
  97   "Minimum width required to prettify an expression.
  98 If current width is greater than this value, the pretty printer does
  99 nothing.")
 100
 101 (defvar pprint-width)
 102 (defvar pprint-no-break)
 103
 104 (defmacro pprint-no-break-p (&rest motions)
 105   "Return non-nil if executing MOTIONS don't break line."
 106   `(save-excursion
 107      (let ((p (point)))
 108        ,@motions
 109        (and (<= (current-column) pprint-width)
 110             (= (progn (beginning-of-line) (point))
 111                (progn (goto-char p) (beginning-of-line) (point)))))))
 112
 113 (defsubst pprint-maybe-newline-and-indent ()
 114   "Insert a newline, then indent.
 115 Does nothing if point is before a close parenthesis character or
 116 already at the beginning of a line."
 117   (or (looking-at "\\s)")
 118       (save-excursion (skip-syntax-backward "-") (bolp))
 119       (newline-and-indent)))
 120
 121 (defsubst pprint-search-printer (table)
 122   "Search in TABLE for a printer to process expression at point.
 123 Return the first one that match expression at point or nil if not
 124 found."
 125   (while (and table (not (looking-at (cdar table))))
 126     (setq table (cdr table)))
 127   (caar table))
 128
 129 (defsubst pprint-dispatch-printer ()
 130   "Dispatch a printer to print current expression.
 131 Return non-nil if a printer was found."
 132   (let ((printer (pprint-search-printer pprint-printers)))
 133     (when printer
 134       (funcall printer)
 135       t)))
 136
 137 (defsubst pprint-sexp-try (room)
 138   "Try to pretty print current expression.
 139 Return nil if the width needed to pretty print current expression goes
 140 beyond specified ROOM."
 141   (save-restriction
 142     (narrow-to-region (point) (progn (forward-sexp) (point)))
 143     (let* ((old-sexp (buffer-string))
 144            (pprint-width room)
 145            (nobreak t))
 146       (goto-char (point-min))
 147       (pprint-sexp)
 148       (goto-char (point-min))
 149       (end-of-line)
 150       (while (and (setq nobreak (<= (current-column) room))
 151                   (not (eobp)))
 152         (end-of-line 2))
 153       (delete-region (point-min) (point-max))
 154       (insert old-sexp)
 155       nobreak)))
 156
 157 (defsubst pprint-close-list ()
 158   "Built-in printer to process close parenthesis characters."
 159   (up-list 1))
 160
 161 (defsubst pprint-nil-as-list ()
 162   "If next s-expression is the nil symbol print it as ().
 163 Return non-nil if nil has been found and printed."
 164   (skip-syntax-forward "-'")
 165   (when (looking-at "\\<nil\\>")
 166     (delete-region (point) (save-excursion (forward-sexp) (point)))
 167     (insert "()")
 168     t))
 169
 170 (defsubst pprint-list ()
 171   "Built-in list printer."
 172   (down-list 1)
 173   (pprint-sexp t) ;; never break after an open paren
 174   (let* ((room (- pprint-width (current-column)))
 175          (nobreak (>= room pprint-min-width)))
 176     (save-excursion
 177       (while (and nobreak (not (looking-at "\\s)")))
 178         (setq nobreak (pprint-sexp-try room))))
 179     (or nobreak (pprint-maybe-newline-and-indent))
 180     (while (not (looking-at "\\s)"))
 181       (pprint-sexp nobreak)
 182       (setq nobreak nil)))
 183   (pprint-close-list))
 184
 185 (defsubst pprint-sequence ()
 186   "Built-in printer of a sequence of expressions.
 187 Insert a line break before each expression."
 188   (while (not (looking-at "\\s)"))
 189     (pprint-maybe-newline-and-indent)
 190     (pprint-sexp)))
 191
 192 (defun pprint-sexp (&optional pprint-no-break)
 193   "Pretty print S-expression at point.
 194 If optional argument PPRINT-NO-BREAK is non-nil the pretty-printed
 195 representation will not start on a new line."
 196   (if (or (> pprint-min-width pprint-width)
 197           (pprint-no-break-p (forward-sexp)))
 198       (forward-sexp)
 199     (or pprint-no-break (pprint-maybe-newline-and-indent))
 200     (let ((old-mark (copy-marker (mark-marker))))
 201       (set-marker
 202        (mark-marker) (save-excursion (forward-sexp) (point)))
 203       (while (< (point) (marker-position (mark-marker)))
 204         (skip-syntax-forward "-'")
 205         (cond
 206          ((pprint-no-break-p (forward-sexp))
 207           (forward-sexp))
 208          ((pprint-dispatch-printer))
 209          ((looking-at "\\s(")
 210           (pprint-list))
 211          ((looking-at "\\s)")
 212           (pprint-close-list))
 213          (t
 214           (forward-sexp)))
 215         )
 216       (set-marker (mark-marker) (marker-position old-mark))
 217       (set-marker old-mark nil))))
 218 \f
 219 ;;;;
 220 ;;;; Standard printers
 221 ;;;;
 222
 223 (defun pprint-lambda ()
 224   "Standard printer for `lambda' like forms."
 225   (down-list 1)
 226   (forward-sexp)
 227   ;; Print empty args as () instead of nil
 228   (or (pprint-nil-as-list)
 229       (pprint-sexp t))
 230   (pprint-sequence)
 231   (pprint-close-list))
 232
 233 (defun pprint-defun ()
 234   "Standard printer for `defun' like forms."
 235   (pprint-maybe-newline-and-indent)
 236   (down-list 1)
 237   (forward-sexp)
 238   (forward-sexp)
 239   ;; Print empty args as () instead of nil
 240   (or (pprint-nil-as-list)
 241       (pprint-sexp t))
 242   (pprint-sequence)
 243   (pprint-close-list))
 244
 245 (defun pprint-defvar ()
 246   "Standard printer for `defvar' like forms."
 247   (pprint-maybe-newline-and-indent)
 248   (down-list 1)
 249   (forward-sexp)
 250   (unless (looking-at "\\s)")
 251     (pprint-sexp)
 252     (unless (looking-at "\\s)")
 253       (pprint-sexp)
 254       (pprint-sequence)))
 255   (pprint-close-list))
 256
 257 (defun pprint-let ()
 258   "Standard printer for `let' like forms."
 259   (down-list 1)
 260   (forward-sexp)
 261   (skip-syntax-forward "-'")
 262   (if (looking-at "\\s(")
 263       (progn
 264         (down-list 1)
 265         (skip-syntax-forward "-'")
 266         (unless (looking-at "\\s)")
 267           (pprint-sexp t)
 268           (pprint-sequence))
 269         (pprint-close-list))
 270     ;; Print empty let binding as () instead of nil
 271     (or (pprint-nil-as-list)
 272         (pprint-sexp t)))
 273   (pprint-maybe-newline-and-indent)
 274   (pprint-sequence)
 275   (pprint-close-list))
 276
 277 (defun pprint-if ()
 278   "Standard printer for `if' like forms."
 279   (down-list 1)
 280   (forward-sexp)
 281   (pprint-sexp t)
 282   (pprint-maybe-newline-and-indent)
 283   (pprint-sexp)
 284   (pprint-sequence)
 285   (pprint-close-list))
 286
 287 (defun pprint-while ()
 288   "Standard printer for `while' like forms."
 289   (down-list 1)
 290   (forward-sexp)
 291   (pprint-sexp t)
 292   (pprint-sequence)
 293   (pprint-close-list))
 294
 295 (defun pprint-progn ()
 296   "Standard printer for `progn' like forms."
 297   (down-list 1)
 298   (forward-sexp)
 299   (pprint-sequence)
 300   (pprint-close-list))
 301
 302 (defun pprint-setq ()
 303   "Standard printer for `setq' like forms."
 304   (down-list 1)
 305   (forward-sexp)
 306   (forward-sexp) ;; 1rst VAR
 307   (pprint-sexp t) ;; 1rst VAL
 308   (while (not (looking-at "\\s)"))
 309     (pprint-maybe-newline-and-indent)
 310     (forward-sexp) ;; VAR
 311     (pprint-sexp t)) ;; VAL
 312   (pprint-close-list))
 313
 314 (defun pprint-cond ()
 315   "Standard printer for `cond' like forms."
 316   (down-list 1)
 317   (forward-sexp)
 318   (while (not (looking-at "\\s)"))
 319     (pprint-maybe-newline-and-indent)
 320     (down-list 1)
 321     (pprint-sexp t)
 322     (pprint-sequence)
 323     (pprint-close-list))
 324   (pprint-close-list))
 325
 326 (defun pprint-with ()
 327   "Standard printer for `with-' like forms."
 328   (let* ((withfun (intern-soft (match-string 1)))
 329          (nobreak (or (get withfun 'lisp-indent-function) 0)))
 330     (down-list 1)
 331     (forward-sexp)
 332     (while (> nobreak 0)
 333       (pprint-sexp t)
 334       (setq nobreak (1- nobreak)))
 335     (pprint-sequence)
 336     (pprint-close-list)))
 337
 338 (defun pprint-setup-standard-printers ()
 339   "Setup standard printers."
 340   (pprint-clear-printers)
 341   ;; Printers are searched in sequence from last to first pushed one.
 342   ;; So it could be important to push the most generic printers first!
 343   (pprint-push-printer 'pprint-with
 344     (format "(%s\\>" "\\(with[-]\\(\\sw\\|\\s_\\)+\\)"
 345             ))
 346   (pprint-push-printer 'pprint-defun
 347     (format "(%s\\>"
 348             (regexp-opt
 349              '(
 350                "defun" "defmacro" "defsubst"
 351                ) t)))
 352   (pprint-push-printer 'pprint-lambda
 353     (format "(%s\\>"
 354             (regexp-opt
 355              '(
 356                "lambda"
 357                ) t)))
 358   (pprint-push-printer 'pprint-defvar
 359     (format "(%s\\>"
 360             (regexp-opt
 361              '(
 362                "defvar" "defconst"
 363                ) t)))
 364   (pprint-push-printer 'pprint-let
 365     (format "(%s\\>"
 366             (regexp-opt
 367              '(
 368                "let" "let*"
 369                ) t)))
 370   (pprint-push-printer 'pprint-if
 371     (format "(%s\\>"
 372             (regexp-opt
 373              '(
 374                "if"
 375                ) t)))
 376   (pprint-push-printer 'pprint-while
 377     (format "(%s\\>"
 378             (regexp-opt
 379              '(
 380                "while" "when" "unless"
 381                "condition-case" "catch"
 382                "dotimes"
 383                ) t)))
 384   (pprint-push-printer 'pprint-cond
 385     (format "(%s\\>"
 386             (regexp-opt
 387              '(
 388                "cond"
 389                ) t)))
 390   (pprint-push-printer 'pprint-progn
 391     (format "(%s\\>"
 392             (regexp-opt
 393              '(
 394                "prog1" "progn"
 395                "save-excursion" "save-restriction"
 396                "unwind-protect"
 397                ) t)))
 398   (pprint-push-printer 'pprint-setq
 399     (format "(%s\\>"
 400             (regexp-opt
 401              '(
 402                "setq"
 403                ) t)))
 404   (setq pprint-standard-printers pprint-printers))
 405
 406 (pprint-setup-standard-printers)
 407 \f
 408 ;;;;
 409 ;;;; User's functions & commands
 410 ;;;;
 411
 412 ;;;###autoload
 413 (defun pprint-to-string (object &optional width)
 414   "Return a string containing the pretty-printed representation of OBJECT.
 415 OBJECT can be any Lisp object.  Quoting characters are used as needed
 416 to make output that `read' can handle, whenever this is possible.  The
 417 pretty printer try as much as possible to limit the length of lines to
 418 given WIDTH.  WIDTH value defaults to `fill-column'."
 419   (with-temp-buffer
 420     (lisp-mode-variables nil)
 421     (set-syntax-table emacs-lisp-mode-syntax-table)
 422     (let ((print-escape-newlines nil)
 423           (print-quoted t))
 424       (prin1 object (current-buffer)))
 425     (goto-char (point-min))
 426     ;; Escape "(" at beginning of line.  Can only occur in strings.
 427     (when (looking-at "\\s(")
 428       (down-list 1)
 429       (while (re-search-forward "^\\s(" nil t)
 430         (goto-char (match-beginning 0))
 431         (insert "\\")))
 432     (goto-char (point-min))
 433     (let* ((pprint-width (or width fill-column))
 434            (zmacs-regions nil) ;; XEmacs
 435            (inhibit-modification-hooks t)) ;; Emacs
 436       (pprint-sexp))
 437     (buffer-string)))
 438
 439 ;;;###autoload
 440 (defun pprint (object &optional stream width)
 441   "Output the pretty-printed representation of OBJECT, any Lisp object.
 442 Quoting characters are printed as needed to make output that `read'
 443 can handle, whenever this is possible.  Output stream is STREAM, or
 444 value of `standard-output' (which see).  The pretty printer try as
 445 much as possible to limit the length of lines to given WIDTH.  WIDTH
 446 value defaults to `fill-column'."
 447   (princ (pprint-to-string object width)
 448          (or stream standard-output)))
 449
 450 ;;;###autoload
 451 (defun pprint-function (function-name)
 452   "See a pretty-printed representation of FUNCTION-NAME."
 453   (interactive "aPretty print function: ")
 454   (let ((code (symbol-function function-name)))
 455     (if (byte-code-function-p code)
 456         (error "Can't pretty-print a byte compiled function"))
 457     (with-current-buffer
 458         (get-buffer-create (format "*pprint-function %s*"
 459                                    function-name))
 460       (erase-buffer)
 461       (emacs-lisp-mode)
 462       (pprint code (current-buffer))
 463       (goto-char (point-min))
 464       (pop-to-buffer (current-buffer)))))
 465
 466 (provide 'pprint)
 467
 468 ;;; pprint.el ends here