1;;; -*- mode:scheme; coding:utf-8; -*-
2;;;
3;;; srfi/%3a159/internal/pretty.scm - Combinator Formatting (pretty)
4;;;
5;;;   Copyright (c) 2020  Takashi Kato  <ktakashi@ymail.com>
6;;;
7;;;   Redistribution and use in source and binary forms, with or without
8;;;   modification, are permitted provided that the following conditions
9;;;   are met:
10;;;
11;;;   1. Redistributions of source code must retain the above copyright
12;;;      notice, this list of conditions and the following disclaimer.
13;;;
14;;;   2. Redistributions in binary form must reproduce the above copyright
15;;;      notice, this list of conditions and the following disclaimer in the
16;;;      documentation and/or other materials provided with the distribution.
17;;;
18;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29;;;
30
31#!nounbound
32(library (srfi :159 internal pretty)
33    (export pretty pretty-simply)
34    (import (rnrs)
35	    (rnrs mutable-pairs)
36	    (only (rnrs r5rs) quotient)
37	    (srfi :1)
38	    (srfi :69)
39	    (srfi :130)
40	    (srfi :159 internal base)
41	    (srfi :159 internal util))
42
43;;;;;; pretty.scm
44;; pretty.scm -- pretty printing format combinator
45;; Copyright (c) 2006-2018 Alex Shinn.  All rights reserved.
46;; BSD-style license: http://synthcode.com/license.txt
47
48;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49;; utilities
50
51(define (take* ls n)   ; handles dotted lists and n > length
52  (cond ((zero? n) '())
53        ((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1))))
54        (else '())))
55
56(define (drop* ls n)   ; may return the dot
57  (cond ((zero? n) ls)
58        ((pair? ls) (drop* (cdr ls) (- n 1)))
59        (else ls)))
60
61(define (make-space n) (make-string n #\space))
62(define (make-nl-space n) (string-append "\n" (make-string n #\space)))
63
64(define (joined/shares fmt ls shares . o)
65  (let ((sep (displayed (if (pair? o) (car o) " "))))
66    (fn ()
67      (if (null? ls)
68          nothing
69          (let lp ((ls ls))
70            (each
71             (fmt (car ls))
72             (let ((rest (cdr ls)))
73               (cond
74                ((null? rest) nothing)
75                ((pair? rest)
76                 (call-with-shared-ref/cdr rest
77                                           shares
78                                           (fn () (lp rest))
79                                           sep))
80                (else (each sep ". " (fmt rest)))))))))))
81
82(define (string-find/index str pred i)
83  (string-cursor->index
84   str
85   (string-index str pred (string-index->cursor str i))))
86
87(define (try-fitted2 proc fail)
88  (fn (width output)
89    (let-values (((out e) (open-string-output-port)))
90      (call-with-current-continuation
91       (lambda (abort)
92         ;; Modify output to accumulate to an output string port,
93         ;; and escape immediately with failure if we exceed the
94         ;; column width.
95         (define (output* str)
96           (fn (col)
97             (let lp ((i 0) (col col))
98               (let ((nli (string-find/index str #\newline i))
99                     (len (string-length str)))
100                 (if (< nli len)
101                     (if (> (+ (- nli i) col) width)
102                         (abort fail)
103                         (lp (+ nli 1) 0))
104                     (let ((col (+ (- len i) col)))
105                       (cond
106                        ((> col width)
107                         (abort fail))
108                        (else
109                         (output-default str)))))))))
110         (forked
111          (with ((output output*)
112                 (port out))
113            proc)
114          ;; fitted successfully
115          (output (e))))))))
116
117(define (try-fitted proc . fail)
118  (if (null? fail)
119      proc
120      (try-fitted2 proc (apply try-fitted fail))))
121
122(define (fits-in-width width proc)
123  (call-with-current-continuation
124   (lambda (abort)
125     (show
126      #f
127      (fn (output)
128        (define (output* str)
129          (each (output str)
130                (fn (col)
131                  (if (>= col width)
132                      (abort #f)
133                      nothing))))
134        (with ((output output*))
135          proc))))))
136
137(define (fits-in-columns width ls writer)
138  (let ((max-w (quotient width 2)))
139    (let lp ((ls ls) (res '()) (widest 0))
140      (cond
141       ((pair? ls)
142        (let ((str (fits-in-width max-w (writer (car ls)))))
143          (and str
144               (lp (cdr ls)
145                   (cons str res)
146                   (max (string-length str) widest)))))
147       ((null? ls) (cons widest (reverse res)))
148       (else #f)))))
149
150;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
151;; style
152
153(define syntax-abbrevs
154  '((quote . "'") (quasiquote . "`")
155    (unquote . ",") (unquote-splicing . ",@")
156    ))
157
158(define (pp-let ls pp shares)
159  (if (and (pair? (cdr ls)) (symbol? (cadr ls)))
160      (pp-with-indent 2 ls pp shares)
161      (pp-with-indent 1 ls pp shares)))
162
163(define indent-rules
164  `((lambda . 1) (define . 1)
165    (let . ,pp-let) (loop . ,pp-let)
166    (let* . 1) (letrec . 1) (letrec* . 1) (and-let* . 1) (let1 . 2)
167    (let-values . 1) (let*-values . 1) (receive . 2) (parameterize . 1)
168    (let-syntax . 1) (letrec-syntax . 1) (syntax-rules . 1) (syntax-case . 2)
169    (match . 1) (match-let . 1) (match-let* . 1)
170    (if . 3) (when . 1) (unless . 1) (case . 1) (while . 1) (until . 1)
171    (do . 2) (dotimes . 1) (dolist . 1) (test . 1)
172    (condition-case . 1) (guard . 1) (rec . 1)
173    (call-with-current-continuation . 0)
174    ))
175
176(define indent-prefix-rules
177  `(("with-" . -1) ("call-with-" . -1) ("define-" . 1))
178  )
179
180(define indent-suffix-rules
181  `(("-case" . 1))
182  )
183
184(define (pp-indentation form)
185  (let ((indent
186         (cond
187          ((assq (car form) indent-rules) => cdr)
188          ((and (symbol? (car form))
189                (let ((str (symbol->string (car form))))
190                  (or (find (lambda (rx) (string-prefix? (car rx) str))
191                            indent-prefix-rules)
192                      (find (lambda (rx) (string-suffix? (car rx) str))
193                            indent-suffix-rules))))
194           => cdr)
195          (else #f))))
196    (if (and (number? indent) (negative? indent))
197        (max 0 (- (+ (or (length+ form) +inf.0) indent) 1))
198        indent)))
199
200(define (with-reset-shares shares proc)
201  (let ((orig-count (cdr shares)))
202    (fn ()
203      (let ((new-count (cdr shares)))
204        (cond
205         ((> new-count orig-count)
206          (hash-table-walk
207           (car shares)
208           (lambda (k v)
209             (if (and (cdr v) (>= (car v) orig-count))
210                 (set-cdr! v #f))))
211          (set-cdr! shares orig-count)))
212        proc))))
213
214(define (pp-with-indent indent-rule ls pp shares)
215  (fn ((col1 col))
216    (each
217     "("
218     (pp (car ls))
219     (fn ((col2 col) width string-width)
220       (let ((fixed (take* (cdr ls) (or indent-rule 1)))
221             (tail (drop* (cdr ls) (or indent-rule 1)))
222             (default
223               (let ((sep (make-nl-space (+ col1 1))))
224                 (each sep (joined/shares pp (cdr ls) shares sep))))
225             ;; reset in case we don't fit on the first line
226             (reset-shares (with-reset-shares shares nothing)))
227         (call-with-output
228          (trimmed/lazy (- width col2)
229                        (each " "
230                              (joined/shares
231                               (lambda (x) (pp-flat x pp shares)) fixed shares " "))
232                        )
233          (lambda (first-line)
234            (cond
235             ((< (+ col2 (string-width first-line)) width)
236              ;; fixed values on first line
237              (let ((sep (make-nl-space
238                          (if indent-rule (+ col1 2) (+ col2 1)))))
239                (each first-line
240                      (cond
241                       ((not (or (null? tail) (pair? tail)))
242                        (each ". " (pp tail)))
243                       ((> (or (length+ (cdr ls)) +inf.0) (or indent-rule 1))
244                        (each sep (joined/shares pp tail shares sep)))
245                       (else
246                        nothing)))))
247             (indent-rule
248              ;; fixed values lined up, body indented two spaces
249              (try-fitted
250               (each
251                reset-shares
252                " "
253                (joined/shares pp fixed shares (make-nl-space (+ col2 1)))
254                (if (pair? tail)
255                    (let ((sep (make-nl-space (+ col1 2))))
256                      (each sep (joined/shares pp tail shares sep)))
257                    nothing))
258               (each reset-shares default)))
259             (else
260              ;; all on separate lines
261              (each reset-shares default)))))))
262     ")")))
263
264(define (pp-app ls pp shares)
265  (let ((indent-rule (pp-indentation ls)))
266    (if (procedure? indent-rule)
267        (indent-rule ls pp shares)
268        (pp-with-indent indent-rule ls pp shares))))
269
270;; the elements may be shared, just checking the top level list
271;; structure
272(define (proper-non-shared-list? ls shares)
273  (let ((tab (car shares)))
274    (let lp ((ls ls))
275      (or (null? ls)
276          (and (pair? ls)
277               (not (hash-table-ref/default tab ls #f))
278               (lp (cdr ls)))))))
279
280(define (non-app? x)
281  (if (pair? x)
282      (or (not (or (null? (cdr x)) (pair? (cdr x))))
283          (non-app? (car x)))
284      (not (symbol? x))))
285
286(define (pp-data-list ls pp shares)
287  (each
288   "("
289   (fn (col width string-width)
290     (let ((avail (- width col)))
291       (cond
292        ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls)))
293              (fits-in-columns width ls (lambda (x) (pp-flat x pp shares))))
294         => (lambda (ls)
295              ;; at least four elements which can be broken into columns
296              (let* ((prefix (make-nl-space col))
297                     (widest (+ 1 (car ls)))
298                     (columns (quotient width widest))) ; always >= 2
299                (let lp ((ls (cdr ls)) (i 1))
300                  (cond
301                   ((null? ls)
302                    nothing)
303                   ((null? (cdr ls))
304                    (displayed (car ls)))
305                   ((>= i columns)
306                    (each (car ls)
307                          prefix
308                          (fn () (lp (cdr ls) 1))))
309                   (else
310                    (let ((pad (- widest (string-width (car ls)))))
311                      (each (car ls)
312                            (make-space pad)
313                            (lp (cdr ls) (+ i 1))))))))))
314        (else
315         ;; no room, print one per line
316         (joined/shares pp ls shares (make-nl-space col))))))
317   ")"))
318
319(define (pp-flat x pp shares)
320  (cond
321   ((pair? x)
322    (cond
323     ((and (pair? (cdr x)) (null? (cddr x))
324           (assq (car x) syntax-abbrevs))
325      => (lambda (abbrev)
326           (each (cdr abbrev)
327                 (call-with-shared-ref
328                  (cadr x)
329                  shares
330                  (pp-flat (cadr x) pp shares)))))
331     (else
332      (each "("
333            (joined/shares (lambda (x) (pp-flat x pp shares)) x shares " ")
334            ")"))))
335   ((vector? x)
336    (each "#("
337          (joined/shares
338           (lambda (x) (pp-flat x pp shares)) (vector->list x) shares " ")
339          ")"))
340   (else
341    (pp x))))
342
343(define (pp-pair ls pp shares)
344  (cond
345   ;; one element list, no lines to break
346   ((null? (cdr ls))
347    (each "(" (pp (car ls)) ")"))
348   ;; quote or other abbrev
349   ((and (pair? (cdr ls)) (null? (cddr ls))
350         (assq (car ls) syntax-abbrevs))
351    => (lambda (abbrev)
352         (each (cdr abbrev) (pp (cadr ls)))))
353   (else
354    (try-fitted
355     (fn () (pp-flat ls pp shares))
356     (with-reset-shares
357      shares
358      (fn ()
359        (if (and (non-app? ls)
360                 (proper-non-shared-list? ls shares))
361            (pp-data-list ls pp shares)
362            (pp-app ls pp shares))))))))
363
364(define (pp-vector vec pp shares)
365  (each "#" (pp-data-list (vector->list vec) pp shares)))
366
367;; adapted from `write-with-shares'
368(define (pp obj shares)
369  (fn (radix precision)
370    (let ((write-number
371           (cond
372            ((and (not precision)
373                  (assv radix '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))))
374             => (lambda (cell)
375                  (lambda (n)
376                    (if (or (exact? n) (eqv? radix 10))
377                        (each (cdr cell) (number->string n (car cell)))
378                        (with ((radix 10)) (numeric n))))))
379            (else (lambda (n) (with ((radix 10)) (numeric n)))))))
380      (let pp ((obj obj))
381        (call-with-shared-ref
382         obj shares
383         (fn ()
384           (cond
385            ((pair? obj)
386             (pp-pair obj pp shares))
387            ((vector? obj)
388             (pp-vector obj pp shares))
389            ((number? obj)
390             (write-number obj))
391            (else
392             (write-with-shares obj shares)))))))))
393
394(define (pretty obj)
395  (fn ()
396    (call-with-output
397     (each (pp obj (extract-shared-objects obj #t))
398           fl)
399     displayed)))
400
401(define (pretty-simply obj)
402  (fn ()
403    (each (pp obj (extract-shared-objects #f #f))
404          fl)))
405
406
407)
408