From 83262a9dfa2100740ee8c9c7a0991140323e8e59 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sun, 13 Oct 2013 19:49:15 +0900
Subject: [PATCH] Adding pretty-printing format combinators.

---
 lib/chibi/show/base.sld   |   4 +-
 lib/chibi/show/pretty.scm | 357 ++++++++++++++++++++++++++++++++++++++
 lib/chibi/show/pretty.sld |   8 +
 lib/chibi/show/write.scm  |  21 +--
 tests/show-tests.scm      |  83 ++++++++-
 5 files changed, 461 insertions(+), 12 deletions(-)
 create mode 100644 lib/chibi/show/pretty.scm
 create mode 100644 lib/chibi/show/pretty.sld

diff --git a/lib/chibi/show/base.sld b/lib/chibi/show/base.sld
index 841b4514..c56d236e 100644
--- a/lib/chibi/show/base.sld
+++ b/lib/chibi/show/base.sld
@@ -3,7 +3,9 @@
   (export
    show fn fn-fork with update! each each-in-list call-with-output
    displayed written written-shared written-simply numeric nothing
-   output-default)
+   ;; internal
+   output-default extract-shared-objects write-to-string write-with-shares
+   call-with-shared-ref call-with-shared-ref/cdr)
   (import (scheme base) (scheme write) (scheme complex) (scheme inexact)
           (srfi 1) (srfi 69) (chibi string) (chibi monad environment))
   (include "base.scm")
diff --git a/lib/chibi/show/pretty.scm b/lib/chibi/show/pretty.scm
new file mode 100644
index 00000000..702d5ed2
--- /dev/null
+++ b/lib/chibi/show/pretty.scm
@@ -0,0 +1,357 @@
+;; 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)))
diff --git a/lib/chibi/show/pretty.sld b/lib/chibi/show/pretty.sld
new file mode 100644
index 00000000..b8b422df
--- /dev/null
+++ b/lib/chibi/show/pretty.sld
@@ -0,0 +1,8 @@
+
+(define-library (chibi show pretty)
+  (export pretty pretty-shared pretty-simply
+          joined/shares
+          )
+  (import (scheme base) (scheme write) (chibi show) (chibi show base)
+          (srfi 1) (srfi 69) (chibi string))
+  (include "pretty.scm"))
diff --git a/lib/chibi/show/write.scm b/lib/chibi/show/write.scm
index 7114a412..72d764e9 100644
--- a/lib/chibi/show/write.scm
+++ b/lib/chibi/show/write.scm
@@ -1,5 +1,5 @@
 ;; write.scm - written formatting, the default displayed for non-string/chars
-;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2006-2013 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -258,7 +258,7 @@
           ((> v 1)
            (hash-table-set! res k (cons count #f))
            (set! count (+ count 1))))))
-      res)))
+      (cons res 0))))
 
 (define (maybe-gen-shared-ref cell shares)
   (cond
@@ -275,15 +275,16 @@
         (each "#" (number->string (car cell)) "#")
         (each (maybe-gen-shared-ref cell shares) proc))))
 
-(define (call-with-shared-ref/cdr obj shares proc)
-  (let ((cell (hash-table-ref/default (car shares) obj #f)))
+(define (call-with-shared-ref/cdr obj shares proc . o)
+  (let ((sep (displayed (if (pair? o) (car o) "")))
+        (cell (hash-table-ref/default (car shares) obj #f)))
     (cond
       ((and (pair? cell) (cdr cell))
-       (each ". #" (number->string (car cell)) "#"))
+       (each sep ". #" (number->string (car cell)) "#"))
       ((pair? cell)
-       (each ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
+       (each sep ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
       (else
-       proc))))
+       (each sep proc)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; written
@@ -352,13 +353,13 @@
 
 (define (written-default obj)
   (fn ()
-    (write-with-shares obj (cons (extract-shared-objects obj #t) 0))))
+    (write-with-shares obj (extract-shared-objects obj #t))))
 
 ;; Writes the object showing the full shared structure.
 
 (define (written-shared obj)
   (fn ()
-    (write-with-shares obj (cons (extract-shared-objects obj #f) 0))))
+    (write-with-shares obj (extract-shared-objects obj #f))))
 
 ;; The only expensive part, in both time and memory, of handling
 ;; shared structures when writing is building the initial table, so
@@ -367,7 +368,7 @@
 
 (define (written-simply obj)
   (fn ()
-    (write-with-shares obj (cons (make-hash-table eq?) 0))))
+    (write-with-shares obj (extract-shared-objects #f #f))))
 
 ;; Local variables:
 ;; eval: (put 'fn 'scheme-indent-function 1)
diff --git a/tests/show-tests.scm b/tests/show-tests.scm
index 6bf000fe..b97ce9cc 100644
--- a/tests/show-tests.scm
+++ b/tests/show-tests.scm
@@ -1,5 +1,6 @@
 
-(import (scheme base) (chibi show) (chibi test))
+(import (scheme base) (scheme read) (chibi test)
+        (chibi show) (chibi show base) (chibi show pretty))
 
 (test-begin "show")
 
@@ -283,4 +284,84 @@
              (written-simply
               (let ((ones (list 1))) (set-cdr! ones ones) ones)))))
 
+;; pretty printing
+
+(define-syntax test-pretty
+  (syntax-rules ()
+    ((test-pretty str)
+     (let ((sexp (read (open-input-string str))))
+       (test str (show #f (pretty sexp)))))))
+
+(test-pretty "(foo bar)\n")
+
+(test-pretty
+"((self . aquanet-paper-1991)
+ (type . paper)
+ (title . \"Aquanet: a hypertext tool to hold your\"))
+")
+
+(test-pretty
+"(abracadabra xylophone
+             bananarama
+             yellowstonepark
+             cryptoanalysis
+             zebramania
+             delightful
+             wubbleflubbery)\n")
+
+(test-pretty
+ "#(0  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)\n")
+
+(test-pretty
+ "(0  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)\n")
+
+(test-pretty
+ "(define (fold kons knil ls)
+  (define (loop ls acc)
+    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc))))
+  (loop ls knil))\n")
+
+(test-pretty
+"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n")
+
+(test-pretty
+"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec)
+  (vector-set! vec i 'supercalifrajalisticexpialidocious))\n")
+
+(test-pretty
+"(do ((my-vector (make-vector 5)) (index 0 (+ index 1)))
+    ((= index 5) my-vector)
+  (vector-set! my-vector index index))\n")
+
+(test-pretty
+ "(define (fold kons knil ls)
+  (let loop ((ls ls) (acc knil))
+    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n")
+
+(test-pretty
+ "(define (file->sexp-list pathname)
+  (call-with-input-file pathname
+    (lambda (port)
+      (let loop ((res '()))
+        (let ((line (read port)))
+          (if (eof-object? line) (reverse res) (loop (cons line res))))))))\n")
+
+(test "(let ((ones '#0=(1 . #0#))) ones)\n"
+    (show #f (pretty (let ((ones (list 1)))
+                       (set-cdr! ones ones)
+                       `(let ((ones ',ones)) ones)))))
+
+'(test
+"(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+      (ones '#0=(1 . #0#)))
+  (append zeros ones))\n"
+    (show #f (pretty
+              (let ((ones (list 1)))
+                (set-cdr! ones ones)
+                `(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
+                       (ones ',ones))
+                   (append zeros ones))))))
+
 (test-end)