Source

xemacs-devel / pretty-print.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
;;; pretty-print.el --- Emacs Lisp pretty printer and macro expander

;; Copyright (C) 1992,1993 Guido Bosch <Guido.Bosch@loria.fr>

;; Author: Guido Bosch
;; Maintainer: None
;; Keywords: lisp, internal

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with:  Not in FSF.

;;; Commentary:

;; Please send bugs and comments to the author.
;;
;; <DISCLAIMER>
;; This program is still under development.  Neither the author nor
;; CRIN-INRIA accepts responsibility to anyone for the consequences of
;; using it or for whether it serves any particular purpose or works
;; at all.
;; 
;; The package has been developed under Lucid Emacs 19, but also runs
;; on Emacs 18, if it is compiled with the version 19 byte compiler
;; (function `compiled-function-p' lacking).
;;

;; Installation and Usage
;; ----------------------
;;
;; This package provides an Emacs Lisp sexpression pretty printer and
;; macroexpander.  To install it, put the following line in your .emacs,
;; default.el or site-init.el/site-run.el (for Lucid Emacs): 
;; (require 'pp)
;; 
;; The package can also be made autoloadable, with the following entry 
;; points: 
;; (autoload 'pp-function "pp" nil t)
;; (autoload 'pp-variable "pp" nil t)
;; (autoload 'pp-plist     "pp" nil t)
;; (autoload 'macroexpand-sexp "pp" nil t)
;; (autoload 'macroexpand-all-sexp "pp" nil t)
;; (autoload 'prettyexpand-sexp "pp" nil t)
;; (autoload 'prettyexpand-all-sexp "pp" nil t)
;;
;;(define-key emacs-lisp-mode-map '(control meta m) 'macroexpand-sexp)
;;(define-key emacs-lisp-mode-map '(control meta M) 'macroexpand-all-sexp)
;;(define-key emacs-lisp-mode-map '(control symbol m) 'prettyexpand-sexp)
;;(define-key emacs-lisp-mode-map '(control symbol M) 'prettyexpand-all-sexp)
;;
;;(define-key lisp-interaction-mode-map '(control meta m) 'macroexpand-sexp)
;;(define-key lisp-interaction-mode-map '(control meta M) 'macroexpand-all-sexp)
;;(define-key lisp-interaction-mode-map '(control symbol m) 'prettyexpand-sexp)
;;(define-key lisp-interaction-mode-map '(control symbol M) 'prettyexpand-all-sexp)
;;

;; Pretty printing of the different cells of a symbol is done with the
;; commands:
;;
;; 		M-x pp-function
;; 		M-x pp-variable
;;		M-x pp-plist
;;
;; They print a symbol's function definition, variable value and
;; property list, respectively.  These commands pop up a separate
;; window in which the pretty printed lisp object is displayed.
;; Completion for function and variable symbols is provided. If a
;; function is byte compiled, `pp-function' proposes to call the Emacs
;; Lisp disassembler (this feature only works for Emacs 19, as it
;; needs the `compiled-function-p' predicate).
;;
;; To use the macro expander, put the cursor at the beginning of the
;; form to be expanded, then type
;;
;; 	        C-M-m 		(macroexpand-sexp)
;; or		C-M-Sh-M  	(macroexpand-all-sexp)
;; 
;; Both commands will pop up a temporary window containing the
;; macroexpanded code. The only difference is that the second command
;; expands recursively all containing macro calls, while the first one
;; does it only for the uppermost sexpression.  
;; 	With a prefix argument, the macro expansion isn't displayed in a
;; separate buffer but replaces the original code in the current
;; buffer. Be aware: Comments will be lost.
;; 	You can get back the original sexpression using the `undo'
;; 	command on `C-x u'.
;;
;; There is also a prettyfied version of the macroexpander:
;;
;;		C-Sym-m		(prettyexpand-sexp)
;; or		C-Sym-M		(prettyexpand-all-sexp)
;; 
;; The only difference with the corresponding macroexpand commands is 
;; that calls to macros specified in the variable
;; `pp-shadow-expansion-list' are not expanded, in order to make the
;; code look nicer. This is only useful for Lucid Emacs or code that
;; uses Dave Gillespies cl package, as it inhibits expansion of the
;; following macros: block, eval-when, defun*, defmacro*, function*,
;; setf.

; Change History
; 
; $Log$
; Revision 1.2  1998/02/10 16:23:33  steveb
; pretty-print fixes
;
; Revision 1.4  1993/03/25  14:09:52  bosch
; Commands `prettyexpand-sexp' and `prettyexpand-all-sexp' and
; corresponding key bindings added.  Commands pp-{function, variable}
; rewritten. `pp-plist' added. Function `pp-internal-loop' (for Dave
; Gillespies CL loop macro) added.
;
; Revision 1.3  1993/03/03  12:24:13  bosch
; Macroexpander rewritten. Function `pp-macroexpand-all' added (snarfed
; from Dave Gillespies cl-extra.el). Pretty printing for top level
; defining forms added (`pp-internal-def'). Key bindings for
; `emacs-lisp-mode-map' and `lisp-interaction-mode-map' added.  Built-in
; variable `print-gensym' set for printinng uninterned symbols. Started
; adding support for cl-dg (defun*, defmacro*, ...).  Minor bug fixes.
;
; Revision 1.2  1993/02/25  17:35:02  bosch
; Comments about Emacs 18 compatibility added.
;
; Revision 1.1  1993/02/25  16:55:01  bosch
; Initial revision
;
;
;;; Code:

;; TO DO LIST
;; ----------
;; Provide full Emacs 18 compatibility.

;; Popper support
(defvar pp-buffer-name "*Pretty Print*")
(defvar pp-macroexpand-buffer-name "*Macro Expansion*")
(if (featurep 'popper)
    (or (eq popper-pop-buffers 't)
	(setq popper-pop-buffers 
	      (cons pp-buffer-name 
		    (cons pp-macroexpand-buffer-name 
			  popper-pop-buffers)))))

;; User level functions
;;;###autoload
(defun pp-function (symbol)
  "Pretty print the function definition of SYMBOL in a separate buffer"
  (interactive 
   (list (pp-read-symbol 'fboundp "Pretty print function definition of: ")))
  (if (compiled-function-p (symbol-function symbol))
      (if (y-or-n-p 
	   (format "Function %s is byte compiled. Disassemble? " symbol))
	  (disassemble (symbol-function symbol))
	(pp-symbol-cell symbol 'symbol-function))
    (pp-symbol-cell symbol 'symbol-function)))

;;;###autoload
(defun pp-variable (symbol)
  "Pretty print the variable value of SYMBOL in a separate buffer"
  (interactive
   (list (pp-read-symbol 'boundp "Pretty print variable value of: ")))
  (pp-symbol-cell symbol 'symbol-value))

;;;###autoload
(defun pp-plist (symbol)
  "Pretty print the property list of SYMBOL in a separate buffer"
  (interactive
   (list (pp-read-symbol 'symbol-plist "Pretty print property list of: ")))
  (pp-symbol-cell symbol 'symbol-plist))

(defun pp-read-symbol (predicate prompt)
  "Read a symbol for which  PREDICATE is true, promptiong with PROMPT."
  (let (symbol)
    (while (or (not symbol) (not (funcall predicate symbol)))
      (setq symbol 
	    (intern-soft 
	     (completing-read
	      prompt
	      obarray
	      predicate
	      t
	      (and symbol (symbol-name symbol))))))
    symbol))

(defun pp-symbol-cell (symbol accessor)  
  "Pretty print the contents of the cell of SYMBOL that can be reached
with the function ACCESSOR."
  (with-output-to-temp-buffer pp-buffer-name
    (set-buffer pp-buffer-name)
    (emacs-lisp-mode)
    (erase-buffer)
    (pp-internal 
     (funcall accessor symbol) 
     (format "%s's %s is:\n" symbol accessor))
    (terpri)))


  
;; Macro expansion (user level)

;;;###autoload
(defun macroexpand-sexp (&optional replace)
  "Macro expand the sexpression following point. Pretty print expansion in a
temporary buffer. With prefix argument, replace the original
sexpression by its expansion in the current buffer."
  (interactive "P")
  (pp-macroexpand-internal 'macroexpand replace t))

;;;###autoload
(defun macroexpand-all-sexp (&optional replace)
  "Macro expand recursively the sexpression following point. Pretty print
expansion in a temporary buffer. With prefix argument, replace the
original sexpression by its expansion in the current buffer."
  (interactive "P")
  (pp-macroexpand-internal 'pp-macroexpand-all replace t))

;;;###autoload
(defun prettyexpand-sexp (&optional replace)
  "Macro expand the sexpression following point. Pretty print expansion
in a temporary buffer. With prefix argument, replace the original
sexpression by its expansion in the current buffer.  
	However, calls to macros specified in the variable
`pp-shadow-expansion-list' are not expanded, in order to make the code
look nicer."

  (interactive "P")
  (pp-macroexpand-internal 'macroexpand replace))

;;;###autoload
(defun prettyexpand-all-sexp (&optional replace)
  "Macro expand recursively the sexpression following point. Pretty print
expansion in a temporary buffer. With prefix argument, replace the
original sexpression by its expansion in the current buffer.
	However, calls to macros specified in the variable
`pp-shadow-expansion-list' are not expanded, in order to make the code
look nicer."
  (interactive "P")
  (pp-macroexpand-internal 'pp-macroexpand-all replace))

;; XEmacs: don't do this at load time.
;;(define-key emacs-lisp-mode-map '(control meta m) 'macroexpand-sexp)
;;(define-key emacs-lisp-mode-map '(control meta M) 'macroexpand-all-sexp)
;;(define-key emacs-lisp-mode-map '(control symbol m) 'prettyexpand-sexp)
;;(define-key emacs-lisp-mode-map '(control symbol M) 'prettyexpand-all-sexp)

;;(define-key lisp-interaction-mode-map '(control meta m) 'macroexpand-sexp)
;;(define-key lisp-interaction-mode-map '(control meta M) 'macroexpand-all-sexp)
;;(define-key lisp-interaction-mode-map '(control symbol m) 'prettyexpand-sexp)
;;(define-key lisp-interaction-mode-map '(control symbol M) 'prettyexpand-all-sexp)


;; Macro expansion (internals)

(defvar pp-shadow-expansion-list
  (mapcar 'list '(block eval-when defun* defmacro* function* setf))
  "The value of this variable is given as the optional environment
argument of the macroexpand functions. Forms specified in this list are
not expanded.")

(defun pp-macroexpand-internal 
  (macroexpand-function replace &optional dont-shadow)
  "Macro expand the sexp that starts at point, using
MACROEXPAND-FUNCTION.  If REPLACE is non-nil, replace the original
text by its expansion, otherwise pretty print the expansion in a
temporary buffer. With optional argument DONT-SHADOW non-nil, do not
use the `pp-shadow-expansion-list' to inhibit expansion of some
forms."

  (interactive)
  (let ((expansion
	 (funcall 
	  macroexpand-function
	  (let ((stab (syntax-table)))
	    (unwind-protect
		(save-excursion
		  (set-syntax-table emacs-lisp-mode-syntax-table)
		  ;; (forward-sexp 1)
		  (read (current-buffer)))
	      (set-syntax-table stab)))
	  (if dont-shadow 
	      nil
	    pp-shadow-expansion-list))))
    (save-excursion
      (if replace 
	  (let ((start (point))
		(end (progn (forward-sexp 1) (point))))
	    (delete-region start end)
	    (pp-internal expansion))
	(with-output-to-temp-buffer pp-macroexpand-buffer-name
	  (set-buffer pp-macroexpand-buffer-name)
	  (erase-buffer)
	  (emacs-lisp-mode)
	  (pp-internal expansion))))))

;; Internal pretty print functions

;;;###autoload
(defun pp-internal (form &optional title)
  "Pretty print FORM in in the current buffer.
Optional string TITLE is inserted before the pretty print."
  (let (start)
    (if title (princ title))
    (setq start (point))
    ;; print-escape-newlines must be t, otherwise we cannot use
    ;; (current-column) to detect good line breaks
    (let ((print-escape-newlines t)
	  (print-gensym t)
	  )
      (prin1 form (current-buffer))
      (goto-char start)
      (pp-internal-sexp))))

(defun pp-internal-sexp ()
  "Pretty print the following sexp. 
Point must be on or before the first character."

  (skip-chars-forward " \n\t")
  (let* ((char (following-char))
	 (ch-class (char-syntax char))
	 (start (point)))

    (cond
     ;; open paren
     ((eq char ?\()
      (down-list 1)
      (if (memq  (char-syntax (following-char)) '(?_ ?w))
	  (let ((symbol (read (current-buffer))))
	    (cond ((and (symbolp symbol)
			(fboundp symbol))
		   (goto-char start)
		   (pp-internal-function symbol))
		  ((memq symbol '(lambda macro))
		   (pp-internal-lambda))
		  (t
		   (goto-char start)
		   (pp-internal-list))))
	(up-list -1)
	(pp-internal-list)))
     
     ;;symbols & strings
     ((memq  ch-class '(?_		; symbol
			?w		; word
			?\"		; string
			?\\		; escape
			?\'		; quote (for uninterned symbols)
			)) (forward-sexp 1))
	
     ;; vector
     ((eq char ?\[) (pp-internal-list))
     
     ;; error otherwise
     (t (error "pp-internal-sexp: character class not treated yet: `%c'" 
	       ch-class)))))

(defun pp-internal-function (func)
  "Pretty print a functuion call.
Point must be on the open paren. the function symbol may be passed as an 
optional argument."
  (let ((start (point))
	(too-large (>= (save-excursion
			 (forward-sexp 1)
			 (current-column))
		       fill-column))
	(indent-info (get func lisp-indent-function)))
    (down-list 1)
    ;; skip over function name
    (forward-sexp 1)
    (cond
     ((memq func '(let let*)) (pp-internal-let))

     ((eq func 'cond) (pp-internal-cond))

     ((memq func '(if while with-output-to-temp-buffer catch block))
      (pp-internal-sexp)
      (pp-internal-body 't))

     ((eq func 'quote) (pp-internal-quote))

     ((memq func '(progn 
		    prog1 prog2
		    save-window-excursion 
		    save-excursion 
		    save-restriction))
      (pp-internal-body 't))

     ((memq func '(defun defmacro defsubst defun* defmacro*))
      (pp-internal-def))
     
     ((eq func 'loop) (pp-internal-loop))

     ('t (pp-internal-body too-large)))))

(defun pp-internal-def ()
  (forward-sexp 1)			; skip name
  (if (looking-at " nil")		; replace nil by () 
      (replace-match " ()")
    (forward-sexp 1))
  (if (looking-at " \"")
      ;; comment string. Replace all escaped linefeeds by real ones
      (let ((limit (save-excursion (forward-sexp 1) (point-marker))))
	(newline-and-indent)
	(while (re-search-forward "\\\\n" limit t)
	  (replace-match "\n" nil nil))
	(goto-char limit)))
  (pp-internal-body 't))

(defun pp-internal-list ()
  "Pretty print a list  or a vector.
Point must be on the open paren."
  (let ((too-large (>= (save-excursion
			(forward-sexp 1)
			(current-column))
		      fill-column)))
    (down-list 1)
    (pp-internal-sexp)
    (pp-internal-body too-large)))

(defun pp-internal-body (&optional force-indent)
  "Prety print a body of sexp. Stop after reaching a `)'.  If argument
FORCE-INDENT is non-nil, break line after each sexpression of the
body."
  (skip-chars-forward " \n\t")
  (let (ch-class)
    ;; while not closing paren
    (while (/= (setq ch-class (char-syntax (following-char))) ?\)) 
      (if  force-indent (newline-and-indent))
      (pp-internal-sexp))
    (up-list 1)))

(defun pp-internal-loop ()
  "Prety print a loop body. Stop after reaching a `)'. 
Line breaks are done before the following keywords: "
  (forward-sexp 1)
  (skip-chars-forward " \n\t")
  (let (ch-class)
    ;; while not closing paren
    (while (/= (setq ch-class (char-syntax (following-char))) ?\))
      (if (not (looking-at "for\\|repeat\\|with\\|while\\|until\\|always\\|never\\|thereis\\|collect\\|append\\|nconc\\|sum\\|count\\|maximize\\|minimize\\|if\\|when\\|else\\|unless\\|do\\W\\|initially\\|finally\\|return\\|named"))
	  (pp-internal-sexp)
	(newline-and-indent)
	(forward-sexp 1))
      (skip-chars-forward " \n\t"))
    (up-list 1)))

(defun pp-internal-body-list ()
  (let ((too-large (>= (save-excursion
			(forward-sexp 1)
			(current-column))
		      fill-column))
	ch-class)
    (down-list 1)
    (pp-internal-sexp)
    (while (/= (setq ch-class (char-syntax (following-char))) ?\)) 
      (if  too-large (newline-and-indent))
      (pp-internal-sexp))
    (up-list 1)))
    
(defun pp-internal-lambda ()
  (forward-sexp 1) ; arguments
  (pp-internal-body 't))

(defun pp-internal-let ()
  "Pretty print a let-like  form.
Cursor is behind function symbol."
  (down-list 1)
  (while (not (= (following-char) ?\)))
    (if (= (following-char) ?\()
	(pp-internal-body-list)
      (forward-sexp 1))
    (if (not (= (following-char) ?\)))
        (newline-and-indent)))
  (up-list 1)
  (pp-internal-body 't))

(defun pp-internal-cond ()
  "Pretty print a cond-like  form.
Cursor is behind function symbol."
  (skip-chars-forward " \n\t")
  (while (not (= (following-char) ?\)))
    (pp-internal-body-list)
    (if (not (= (following-char) ?\)))
	(newline-and-indent)))
  (up-list 1))

      
(defun pp-internal-quote ()
  "Pretty print a quoted list.
Cursor is behind the symbol quote."
  (skip-chars-forward " \n\t")
  (let ((end (point)))
    (backward-sexp 1)
    (delete-region (point) end)
    (up-list -1)
    (setq end (point))
    (forward-sexp 1)
    (delete-char -1)
    (goto-char end)
    (delete-char 1)
    (insert "'")
    (if (= (char-syntax (following-char)) ?\()
	;; don't print it as sexp, because it could be (let ... ) or
	;; (cond ... ) or whatever. 
	(pp-internal-list)
      (pp-internal-sexp))))


;; Stolen form Dave Gillespies cl-extra.el
(defun pp-macroexpand-all (form &optional env)
  "Expand all macro calls through a Lisp FORM.
This also does some trivial optimizations to make the form prettier."
  (setq form (macroexpand form env))
  (cond 
   ((not (consp form)) form)
   ((memq (car form) '(let let*))
    (if (null (nth 1 form))
	(pp-macroexpand-all (cons 'progn (cdr (cdr form))) env)
      (cons (car form) 
	    (cons (pp-macroexpand-lets (nth 1 form) env)
		  (pp-macroexpand-body (cdr (cdr form)) env)))))
   ((eq (car form) 'cond)
    (cons (car form)
	  (mapcar (function (lambda (x) (pp-macroexpand-body x env)))
		  (cdr form))))
   ((eq (car form) 'condition-case)
    (cons (car form)
	  (cons (nth 1 form)
		(cons (pp-macroexpand-all (nth 2 form) env)
		      (pp-macroexpand-lets 
		       (cdr (cdr (cdr form))) env)))))
   ((memq (car form) '(quote function))
    (if (eq (car-safe (nth 1 form)) 'lambda)
	(list (car form) 
	      (cons 'lambda
		    (cons (car (cdr (car (cdr form))))
			  (pp-macroexpand-body 
			   (cdr (cdr (car (cdr form)))) env))))
      form))
   ((memq (car form) '(defun defmacro))
    (cons (car form)
	  (cons (nth 1 form)
		(pp-macroexpand-body (cdr (cdr form)) env))))
   ((and (eq (car form) 'progn) (not (cdr (cdr form))))
    (pp-macroexpand-all (nth 1 form) env))
   (t 
    (cons (car form) (pp-macroexpand-body (cdr form) env)))))

(defun pp-macroexpand-body (body &optional env)
  (mapcar (function (lambda (x) (pp-macroexpand-all x env))) body))

(defun pp-macroexpand-lets (list &optional env)
  (mapcar (function
	   (lambda (x)
	     (if (consp x) (cons (car x) (pp-macroexpand-body (cdr x) env))
	       x))) list))

(run-hooks 'pp-load-hook)
(provide 'pp)

;;; pretty-print.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.