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