home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / PP.SCM < prev    next >
Text File  |  1992-06-17  |  12KB  |  426 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ;;;; A pretty-printer
  4.  
  5. ; This is NOT in the spirit of the rest of the Scheme48 system -- it's
  6. ; too hairy.  It also has some unexploited internal generality.  It
  7. ; really ought to be rewritten.  In addition, it seems to be buggy!
  8. ; (It sometimes prints unnecessarily wide lines.)  What a drag.
  9. ; But sometimes it's better than no pretty printer at all.
  10.  
  11. ;   :enable
  12. ;   :load misc/pp.scm
  13. ;   :disable
  14.  
  15. ; From: ramsdell@linus.mitre.org
  16. ; Date:  Wed, 12 Sep 1990 05:14:49 PDT
  17. ;
  18. ; As you noted in your comments, pp.scm is not a straight forward
  19. ; program.  You could add some comments that would greatly ease the task
  20. ; of figuring out what his going on.  In particular, you should describe
  21. ; the signature of various objects---most importantly the signature of a
  22. ; formatter.  You might also add some description as to what protocol
  23. ; they are to follow.
  24.  
  25. ; Other things to implement some day:
  26. ;  - LET, LET*, LETREC binding lists should be printed vertically if longer
  27. ;    than about 30 characters
  28. ;  - COND clauses should all be printed vertically if the COND is vertical
  29. ;  - Add an option to lowercase or uppercase symbols and named characters.
  30. ;  - Parameters controlling behavior of printer should be passed around
  31. ;  - Do something about choosing between #f and ()
  32. ;  - Insert line breaks intelligently following head of symbol-headed list,
  33. ;    when necessary
  34. ;  - Some equivalents of *print-level*, *print-length*, *print-circle*.
  35.  
  36. ; Possible strategies:
  37. ;   (foo x y z)     Horizontal = infinity sticky 
  38. ;   (foo x y        One sticky + one + body (e.g. named LET)
  39. ;     z
  40. ;     w)
  41. ;   (foo x          One + body
  42. ;     y
  43. ;     z)
  44. ;   (foo x          Two + body
  45. ;        y
  46. ;     z)
  47. ;   (foo x          Big ell = infinity + body (combination)
  48. ;     y
  49. ;     z)
  50. ;   (foo            Little ell, zero + body (combination)
  51. ;     x
  52. ;     y)
  53. ;   (foo            Vertical
  54. ;    x
  55. ;    y)
  56. ;
  57. ; Available height/width tradeoffs:
  58. ;   Combination:
  59. ;     Horizontal, big ell, or little ell.
  60. ;   Special form:
  61. ;     Horizontal, or M sticky + N + body.
  62. ;   Random (e.g. vector, improper list, non-symbol-headed list):
  63. ;     Horizontal, or vertical.  (Never zero plus body.)
  64.  
  65. (define (p x)                           ;test routine
  66.   (newline)
  67.   (pretty-print x (current-output-port) 0)
  68.   (newline))
  69.  
  70. (define *line-width* 80)
  71.  
  72. (define *single-line-special-form-limit* 30)
  73.  
  74. ; Stream primitives
  75.  
  76. (define head car)
  77. (define (tail s) (force (cdr s)))
  78.  
  79. (define (map-stream proc stream)
  80.   (cons (proc (head stream))
  81.     (delay (map-stream proc (tail stream)))))
  82.  
  83. (define (stream-ref stream n)
  84.   (if (= n 0)
  85.       (head stream)
  86.       (stream-ref (tail stream) (- n 1))))
  87.  
  88. ; Printer
  89.  
  90. (define (pretty-print obj port pos)
  91.   (let ((node (pp-prescan obj 0)))
  92. ;    (if (> (column-of (node-dimensions node)) *line-width*)
  93. ;        ;; Eventually add a pass to change format of selected combinations
  94. ;        ;; from big-ell to little-ell.
  95. ;        (begin (display ";** too wide - ")
  96. ;               (write (node-dimensions node))
  97. ;               (newline)))
  98.     (print-node node port pos)))
  99.  
  100. (define make-node list)
  101.  
  102. (define (node-dimensions node)
  103.   ((car node)))
  104.  
  105. (define (node-pass-2 node pos)
  106.   ((cadr node) pos))
  107.  
  108. (define (print-node node port pos)
  109.   ((caddr node) port pos))
  110.  
  111. (define (pp-prescan obj hang)
  112.   (cond ((symbol? obj)
  113.          (make-leaf (string-length (symbol->string obj))
  114.                     obj hang))
  115.         ((number? obj)
  116.          (make-leaf (string-length (number->string obj '(heur)))
  117.                     obj hang))
  118.         ((boolean? obj)
  119.          (make-leaf 2 obj hang))
  120.         ((string? obj)
  121.          ;;++ Should count number of backslashes and quotes
  122.          (make-leaf (+ (string-length obj) 2) obj hang))
  123.         ((char? obj)
  124.          (make-leaf (case obj
  125.                       ((#\space) 7)
  126.                       ((#\newline) 9)
  127.                       (else 3))
  128.                     obj hang))
  129.         ((pair? obj)
  130.          (pp-prescan-pair obj hang))
  131.         ((vector? obj)
  132.          (pp-prescan-vector obj hang))
  133. ;    ((record? obj)
  134. ;     (pp-prescan-record obj hang))
  135.         (else
  136.          (make-leaf 25 obj hang)))) ;Random number
  137.  
  138. (define (make-leaf width obj hang)
  139.   (let ((width (+ width hang)))
  140.     (make-node (lambda () width)
  141.            (lambda (pos)
  142.          (+ pos width))
  143.            (lambda (port pos)
  144.          (write obj port)
  145.          (do ((i 0 (+ i 1)))
  146.              ((>= i hang) (+ pos width))
  147.            (write-char #\) port))))))
  148.  
  149. (define (make-prefix-node string node)
  150.   (let ((len (string-length string)))
  151.     (make-node (lambda ()
  152.          (+ (node-dimensions node) len))
  153.            (lambda (pos)
  154.          (node-pass-2 node (+ pos len)))
  155.            (lambda (port pos)
  156.          (display string port)
  157.          (print-node node port (+ pos len))))))
  158.  
  159. (define (pp-prescan-vector obj hang)
  160.   (if (= (vector-length obj) 0)
  161.       (make-leaf 3 obj hang)
  162.       (make-prefix-node "#" (pp-prescan-list (vector->list obj) #t hang))))
  163.  
  164. ; Improve later.
  165.  
  166. (define (pp-prescan-record obj hang)
  167.   (let ((l (disclose-record obj)))
  168.     (make-prefix-node (string-append "#." (car l))
  169.               (pp-prescan-list (cdr l) #t hang))))
  170.  
  171. (define (pp-prescan-pair obj hang)
  172.   (cond ((read-macro-inverse obj)
  173.          =>
  174.          (lambda (inverse)
  175.        (make-prefix-node inverse (pp-prescan (cadr obj) hang))))
  176.         (else
  177.          (pp-prescan-list obj #f hang))))
  178.  
  179. (define (pp-prescan-list obj random? hang)
  180.   (let loop ((l obj) (z '()))
  181.     (if (pair? (cdr l))
  182.     (loop (cdr l)
  183.           (cons (pp-prescan (car l) 0) z))
  184.     (make-list-node
  185.       (reverse
  186.         (if (null? (cdr l))
  187.         (cons (pp-prescan (car l) (+ hang 1)) z)
  188.         (cons (make-prefix-node ". " (pp-prescan (cdr l) (+ hang 1)))
  189.               (cons (pp-prescan (car l) 0) z))))
  190.       obj
  191.       (or random? (not (null? (cdr l))))))))
  192.  
  193. ; Is it sufficient to tell parent node:
  194. ;  At a cost of X line breaks, I can make myself narrower by Y columns. ?
  195. ; Then how do we decide whether we narrow ourselves or some of our children?
  196.  
  197. (define (make-list-node node-list obj random?)
  198.   (let* ((random? (or random?
  199.               ;; Heuristic for things like do, cond, let, ...
  200.               (not (symbol? (car obj)))
  201.               (eq? (car obj) 'else)))
  202.      (probe (if (not random?)
  203.             (assq (car obj) *indentations*)
  204.             #f))
  205.      (format horizontal-format)
  206.      (dimensions (compute-dimensions node-list format))
  207.      (go-non-horizontal
  208.       (lambda (col)
  209.         (set! format
  210.           (cond (random? vertical-format)
  211.             ((not probe) big-ell-format)
  212.             (else ((cadr probe) obj))))
  213.         (let* ((start-col (+ col 1))
  214.            (col (node-pass-2 (car node-list) start-col))
  215.            (final-col
  216.                (format (cdr node-list) 
  217.                    (lambda (node col target-col)
  218.                  (node-pass-2 node target-col))
  219.                    start-col
  220.                    (+ col 1)
  221.                    col)))
  222.           (set! dimensions (compute-dimensions node-list format))
  223.           final-col))))
  224.     (if (> dimensions
  225.        (if probe
  226.            *single-line-special-form-limit*
  227.            *line-width*))
  228.     (go-non-horizontal 0))
  229.     (make-node (lambda () dimensions)
  230.            (lambda (col) ;Pass 2: if necessary, go non-horizontal
  231.          (let ((defacto (+ col (column-of dimensions))))
  232.            (if (> defacto *line-width*)
  233.                (go-non-horizontal col)
  234.                defacto)))
  235.            (lambda (port pos)
  236.          (write-char #\( port)
  237.          (let* ((pos (+ pos 1))
  238.             (start-col (column-of pos))
  239.             (pos (print-node (car node-list) port pos)))
  240.            (format (cdr node-list) 
  241.                (lambda (node pos target-col)
  242.                  (let ((pos (go-to-column target-col
  243.                               port pos)))
  244.                    (print-node node port pos)))
  245.                start-col
  246.                (+ (column-of pos) 1)
  247.                pos))))))
  248.  
  249. (define (compute-dimensions node-list format)
  250.   (let* ((start-col 1)            ;open paren
  251.      (pos (+ (make-position start-col 0)
  252.          (node-dimensions (car node-list)))))
  253.     (format (cdr node-list)
  254.         (lambda (node pos target-col)
  255.           (let* ((dims (node-dimensions node))
  256.              (lines (+ (line-of pos) (line-of dims)))
  257.              (width (+ target-col (column-of dims))))
  258.         (if (>= (column-of pos) target-col)
  259.             ;; Line break required
  260.             (make-position
  261.              (max (column-of pos) width)
  262.              (+ lines 1))
  263.             (make-position width lines))))
  264.         start-col
  265.         (+ (column-of pos) 1)    ;first-col
  266.         pos)))
  267.  
  268. ; Three positions are significant
  269. ;   (foo baz ...)
  270. ;    ^   ^  ^
  271. ;    |   |  +--- (column-of pos)
  272. ;    |   +------ first-col
  273. ;    +---------- start-col
  274.  
  275. ; Separators
  276.  
  277. (define on-same-line
  278.   (lambda (start-col first-col pos)
  279.     start-col first-col ;ignored
  280.     (+ (column-of pos) 1)))
  281.  
  282. (define indent-under-first
  283.   (lambda (start-col first-col pos)
  284.     start-col ;ignored
  285.     first-col))
  286.  
  287. (define indent-for-body
  288.   (lambda (start-col first-col pos)
  289.     first-col ;ignored
  290.     (+ start-col 1)))
  291.  
  292. (define indent-under-head
  293.   (lambda (start-col first-col pos)
  294.     first-col ;ignored
  295.     start-col))
  296.  
  297. ; Format constructors
  298.  
  299. (define (once separator format)
  300.   (lambda (tail proc start-col first-col pos)
  301.     (if (null? tail)
  302.     pos
  303.     (let ((target-col (separator start-col first-col pos)))
  304.       (format (cdr tail)
  305.           proc
  306.           start-col
  307.           first-col
  308.           (proc (car tail) pos target-col))))))
  309.  
  310. (define (indefinitely separator)
  311.   (letrec ((self (once separator    ;eta
  312.                (lambda (tail proc start-col first-col pos)
  313.              (self tail proc start-col first-col pos)))))
  314.     self))
  315.  
  316. (define (repeatedly separator count format)
  317.   (do ((i 0 (+ i 1))
  318.        (format format
  319.            (once separator format)))
  320.       ((>= i count) format)))
  321.  
  322. ; Particular formats
  323.  
  324. (define vertical-format
  325.   (indefinitely indent-under-head))
  326.  
  327. (define horizontal-format
  328.   (indefinitely on-same-line))
  329.  
  330. (define big-ell-format
  331.   (indefinitely indent-under-first))
  332.  
  333. (define little-ell-format
  334.   (indefinitely indent-for-body))
  335.  
  336. (define format-for-named-let
  337.   (repeatedly on-same-line 2 (indefinitely indent-for-body)))
  338.  
  339. (define hook-formats
  340.   (letrec ((stream (cons little-ell-format
  341.              (delay (map-stream (lambda (format)
  342.                           (once indent-under-first format))
  343.                         stream)))))
  344.     stream))
  345.  
  346. ; Hooks for special forms.
  347. ; A hook maps an expression to a format.
  348.  
  349. (define (compute-let-indentation exp)
  350.   (if (and (not (null? (cdr exp)))
  351.        (symbol? (cadr exp)))
  352.       format-for-named-let
  353.       (stream-ref hook-formats 1)))
  354.  
  355. (define hook
  356.   (let ((hooks (map-stream (lambda (format)
  357.                  (lambda (exp) exp ;ignored
  358.                    format))
  359.                hook-formats)))
  360.     (lambda (n)
  361.       (stream-ref hooks n))))
  362.  
  363. (define *indentations*
  364.   `((lambda        ,(hook 1))
  365.     (define       ,(hook 1))
  366.     (define-syntax ,(hook 1))
  367.     (do           ,(hook 2))
  368.     (let       ,compute-let-indentation)
  369.     (let*       ,(hook 1))
  370.     (letrec       ,(hook 1))
  371.     (case       ,(hook 1))
  372.     ;; Kludge to force vertical printing (do AND and OR as well?)
  373.     (if           ,(lambda (exp) big-ell-format))
  374.     (cond       ,(lambda (exp) big-ell-format))
  375.     (call-with-current-continuation ,(hook 0))
  376.     (call-with-input-file  ,(hook 1))
  377.     (call-with-output-file ,(hook 1))
  378.     (with-input-from-file  ,(hook 1))
  379.     (with-output-to-file   ,(hook 1))))
  380.  
  381. ; Other auxiliaries
  382.  
  383. (define (go-to-column target-col port pos) ;=> pos
  384.   ;; Writes at least one space or newline
  385.   (let* ((column (column-of pos))
  386.      (line (if (>= column target-col)
  387.            (+ (line-of pos) 1)
  388.            (line-of pos))))
  389.     (do ((column (if (>= column target-col)
  390.              (begin (newline port) 0)
  391.              column)
  392.          (+ column 1)))
  393.     ((>= column target-col)
  394.      (make-position column line))
  395.       (write-char #\space port))))
  396.  
  397. (define (make-position column line)
  398.   (+ column (* line 1000)))
  399.  
  400. (define (column-of pos)
  401.   (remainder pos 1000))
  402.  
  403. (define (line-of pos)
  404.   (quotient pos 1000))
  405.  
  406. (define (read-macro-inverse x)
  407.   (cond ((and (pair? x)
  408.               (pair? (cdr x))
  409.               (null? (cddr x)))
  410.          (case (car x)
  411.            ((quote)            "'")
  412.            ((quasiquote)       "`")
  413.            ((unquote)          ",")
  414.            ((unquote-splicing) ",@")
  415.            (else #f)))
  416.         (else #f)))
  417.  
  418. ; For the command processor:
  419.  
  420. ;(define (pprint thing)
  421. ;  (let ((port (fluid $output-port)))
  422. ;    (pretty-print thing port 0)
  423. ;    (newline port)))
  424. ;
  425. ;(define-command 'pp "<exp>" "pretty-print" '(value) pprint)
  426.