chibi-scheme/lib/chibi/show/pretty.scm

;; pretty.scm -- pretty printing format combinator
;; Copyright (c) 2006-2013 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utilities

(define (take* ls n)   ; handles dotted lists and n > length
  (cond ((zero? n) '())
        ((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1))))
        (else '())))

(define (drop* ls n)   ; may return the dot
  (cond ((zero? n) ls)
        ((pair? ls) (drop* (cdr ls) (- n 1)))
        (else ls)))

(define (make-space n) (make-string n #\space))
(define (make-nl-space n) (string-append "\n" (make-string n #\space)))

(define (joined/shares fmt ls shares . o)
  (let ((sep (displayed (if (pair? o) (car o) " "))))
    (fn ()
      (if (null? ls)
          nothing
          (let lp ((ls ls))
            (each
             (fmt (car ls))
             (let ((rest (cdr ls)))
               (cond
                ((null? rest) nothing)
                ((pair? rest)
                 (call-with-shared-ref/cdr rest
                                           shares
                                           (fn () (lp rest))
                                           sep))
                (else (each sep ". " (fmt rest)))))))))))

(define (try-fitted2 proc fail)
  (fn (width string-width output)
    (let ((out (open-output-string)))
      (call-with-current-continuation
       (lambda (abort)
         ;; Modify output to accumulate to an output string port,
         ;; and escape immediately with failure if we exceed the
         ;; column width.
         (define (output* str)
           (fn (col)
             (let lp ((i 0) (col col))
               (let ((nli (string-find str #\newline i))
                     (len (string-width str)))
                 (if (< nli len)
                     (if (> (+ (- nli i) col) width)
                         (abort fail)
                         (lp (+ nli 1) 0))
                     (let ((col (+ (- len i) col)))
                       (cond
                        ((> col width)
                         (abort fail))
                        (else
                         (output str)))))))))
         (fn-fork
          (with ((output output*)
                 (port out))
            proc)
          ;; fitted successfully
          (output (get-output-string out))))))))

(define (try-fitted proc . fail)
  (if (null? fail)
      proc
      (try-fitted2 proc (apply try-fitted fail))))

(define (fits-in-width width proc)
  (call-with-current-continuation
   (lambda (abort)
     (show
      #f
      (fn (output)
        (define (output* str)
          (each (output str)
                (fn (col)
                  (if (>= col width)
                      (abort #f)
                      nothing))))
        (with ((output output*))
          proc))))))

(define (fits-in-columns width ls writer)
  (let ((max-w (quotient width 2)))
    (let lp ((ls ls) (res '()) (widest 0))
      (cond
       ((pair? ls)
        (let ((str (fits-in-width max-w (writer (car ls)))))
          (and str
               (lp (cdr ls)
                   (cons str res)
                   (max (string-length str) widest)))))
       ((null? ls) (cons widest (reverse res)))
       (else #f)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; style

(define syntax-abbrevs
  '((quote . "'") (quasiquote . "`")
    (unquote . ",") (unquote-splicing . ",@")
    ))

(define (pp-let ls pp shares)
  (if (and (pair? (cdr ls)) (symbol? (cadr ls)))
      (pp-with-indent 2 ls pp shares)
      (pp-with-indent 1 ls pp shares)))

(define indent-rules
  `((lambda . 1) (define . 1)
    (let . ,pp-let) (loop . ,pp-let)
    (let* . 1) (letrec . 1) (letrec* . 1) (and-let* . 1) (let1 . 2)
    (let-values . 1) (let*-values . 1) (receive . 2) (parameterize . 1)
    (let-syntax . 1) (letrec-syntax . 1) (syntax-rules . 1) (syntax-case . 2)
    (match . 1) (match-let . 1) (match-let* . 1)
    (if . 3) (when . 1) (unless . 1) (case . 1) (while . 1) (until . 1)
    (do . 2) (dotimes . 1) (dolist . 1) (test . 1)
    (condition-case . 1) (guard . 1) (rec . 1)
    (call-with-current-continuation . 0)
    ))

(define indent-prefix-rules
  `(("with-" . -1) ("call-with-" . -1) ("define-" . 1))
  )

(define indent-suffix-rules
  `(("-case" . 1))
  )

(define (pp-indentation form)
  (let ((indent
         (cond
          ((assq (car form) indent-rules) => cdr)
          ((and (symbol? (car form))
                (let ((str (symbol->string (car form))))
                  (or (find (lambda (rx) (string-prefix? (car rx) str))
                            indent-prefix-rules)
                      (find (lambda (rx) (string-suffix? (car rx) str))
                            indent-suffix-rules))))
           => cdr)
          (else #f))))
    (if (and (number? indent) (negative? indent))
        (max 0 (- (+ (length+ form) indent) 1))
        indent)))

(define (with-reset-shares shares proc)
  (let ((orig-count (cdr shares)))
    (fn ()
      (let ((new-count (cdr shares)))
        (cond
         ((> new-count orig-count)
          (hash-table-walk
           (car shares)
           (lambda (k v)
             (if (and (cdr v) (>= (car v) orig-count))
                 (set-cdr! v #f))))
          (set-cdr! shares orig-count)))
        proc))))

(define (pp-with-indent indent-rule ls pp shares)
  (fn ((col1 col))
    (each
     "("
     (pp (car ls))
     (fn ((col2 col) width string-width)
       (let ((fixed (take* (cdr ls) (or indent-rule 1)))
             (tail (drop* (cdr ls) (or indent-rule 1)))
             (default
               (let ((sep (make-nl-space (+ col1 1))))
                 (each sep (joined/shares pp (cdr ls) shares sep) ")")))
             ;; reset in case we don't fit on the first line
             (reset-shares (with-reset-shares shares nothing)))
         (call-with-output
          (each " "
                (joined/shares
                 (lambda (x) (pp-flat x pp shares)) fixed shares " "))
          (lambda (first-line)
            (cond
             ((< (+ col2 (string-width first-line)) width)
              ;; fixed values on first line
              (let ((sep (make-nl-space
                          (if indent-rule (+ col1 2) (+ col2 1)))))
                (each first-line
                      (cond
                       ((not (or (null? tail) (pair? tail)))
                        (each ". " (pp tail pp shares)))
                       ((> (length+ (cdr ls)) (or indent-rule 1))
                        (each sep (joined/shares pp tail shares sep)))
                       (else
                        nothing)))))
             (indent-rule
              ;; fixed values lined up, body indented two spaces
              (try-fitted
               (each
                reset-shares
                " "
                (joined/shares pp fixed shares (make-nl-space (+ col2 1)))
                (if (pair? tail)
                    (let ((sep (make-nl-space (+ col1 2))))
                      (each sep (joined/shares pp tail shares sep)))
                    nothing))
               (each reset-shares default)))
             (else
              ;; all on separate lines
              (each reset-shares default)))))))
     ")")))

(define (pp-app ls pp shares)
  (let ((indent-rule (pp-indentation ls)))
    (if (procedure? indent-rule)
        (indent-rule ls pp shares)
        (pp-with-indent indent-rule ls pp shares))))

;; the elements may be shared, just checking the top level list
;; structure
(define (proper-non-shared-list? ls shares)
  (let ((tab (car shares)))
    (let lp ((ls ls))
      (or (null? ls)
          (and (pair? ls)
               (not (hash-table-ref/default tab ls #f))
               (lp (cdr ls)))))))

(define (non-app? x)
  (if (pair? x)
      (or (not (or (null? (cdr x)) (pair? (cdr x))))
          (non-app? (car x)))
      (not (symbol? x))))

(define (pp-data-list ls pp shares)
  (each
   "("
   (fn (col width string-width)
     (let ((avail (- width col)))
       (cond
        ;; ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls)))
        ;;       (fits-in-columns width ls (lambda (x) (pp-flat x pp shares))))
        ;;  => (lambda (ls)
        ;;       ;; at least four elements which can be broken into columns
        ;;       (let* ((prefix (make-nl-space col))
        ;;              (widest (+ 1 (car ls)))
        ;;              (columns (quotient width widest))) ; always >= 2
        ;;         (let lp ((ls (cdr ls)) (i 1))
        ;;           (cond
        ;;            ((null? ls)
        ;;             nothing)
        ;;            ((null? (cdr ls))
        ;;             (displayed (car ls)))
        ;;            ((>= i columns)
        ;;             (each (car ls)
        ;;                   prefix
        ;;                   (fn () (lp (cdr ls) 1))))
        ;;            (else
        ;;             (let ((pad (- widest (string-width (car ls)))))
        ;;               (each (car ls)
        ;;                     (make-space pad)
        ;;                     (lp (cdr ls) (+ i 1))))))))))
        (else
         ;; no room, print one per line
         (joined/shares pp ls shares (make-nl-space col))))))
   ")"))

(define (pp-flat x pp shares)
  (cond
   ((pair? x)
    (cond
     ((and (pair? (cdr x)) (null? (cddr x))
           (assq (car x) syntax-abbrevs))
      => (lambda (abbrev)
           (each (cdr abbrev)
                 (call-with-shared-ref
                  (cadr x)
                  shares
                  (pp-flat (cadr x) pp shares)))))
     (else
      (each "("
            (joined/shares (lambda (x) (pp-flat x pp shares)) x shares " ")
            ")"))))
   ((vector? x)
    (each "#("
          (joined/shares
           (lambda (x) (pp-flat x pp shares)) (vector->list x) shares " ")
          ")"))
   (else
    (pp x))))

(define (pp-pair ls pp shares)
  (cond
   ;; one element list, no lines to break
   ((null? (cdr ls))
    (each "(" (pretty (car ls)) ")"))
   ;; quote or other abbrev
   ((and (pair? (cdr ls)) (null? (cddr ls))
         (assq (car ls) syntax-abbrevs))
    => (lambda (abbrev)
         (each (cdr abbrev) (pp (cadr ls)))))
   (else
    (try-fitted
     (fn () (pp-flat ls pp shares))
     (with-reset-shares
      shares
      (fn ()
        (if (and (non-app? ls)
                 (proper-non-shared-list? ls shares))
            (pp-data-list ls pp shares)
            (pp-app ls pp shares))))))))

(define (pp-vector vec pp shares)
  (each "#" (pp-data-list (vector->list vec) pp shares)))

;; adapted from `write-with-shares'
(define (pp obj shares)
  (fn (radix precision)
    (let ((write-number
           (cond
            ((and (not precision)
                  (assv radix '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))))
             => (lambda (cell)
                  (lambda (n)
                    (if (or (exact? n) (eqv? radix 10))
                        (each (cdr cell) (number->string n (car cell)))
                        (with ((radix 10)) (numeric n))))))
            (else (lambda (n) (with ((radix 10)) (numeric n)))))))
      (let pp ((obj obj))
        (call-with-shared-ref
         obj shares
         (fn ()
           (cond
            ((pair? obj)
             (pp-pair obj pp shares))
            ((vector? obj)
             (pp-vector obj pp shares))
            ((number? obj)
             (write-number obj))
            (else
             (write-with-shares obj shares)))))))))

(define (pretty obj)
  (fn ()
    (each (pp obj (extract-shared-objects obj #t))
          fl)))

(define (pretty-shared obj)
  (fn ()
    (each (pp obj (extract-shared-objects obj #f))
          fl)))

(define (pretty-simply obj)
  (fn ()
    (each (pp obj (extract-shared-objects #f #f))
          fl)))