From cfc8f43e8dbb5fad0b39356b347960600770ced7 Mon Sep 17 00:00:00 2001 From: dwdv Date: Sat, 26 Oct 2019 17:30:51 +0200 Subject: [PATCH] srfi-159: add missing pretty printing procedures like the rest of srfi-159, this is coming straight from the chibi reference implementation furthermore, restrict export of pretty-shared and written-shared since they are part of srfi-166 --- src/std/build-deps | 10 + src/std/build-spec.ss | 1 + src/std/srfi/159.ss | 17 +- src/std/srfi/159/pretty.scm | 368 ++++++++++++++++++++++++++++++++++++ src/std/srfi/159/pretty.ss | 14 ++ 5 files changed, 404 insertions(+), 6 deletions(-) create mode 100644 src/std/srfi/159/pretty.scm create mode 100644 src/std/srfi/159/pretty.ss diff --git a/src/std/build-deps b/src/std/build-deps index d90e77bb3..f0c090d8e 100644 --- a/src/std/build-deps +++ b/src/std/build-deps @@ -397,12 +397,22 @@ (std/srfi/159/color (gxc: "srfi/159/color" (extra-inputs: ("srfi/159/color.scm"))) (gerbil/core std/srfi/13 std/srfi/159/base)) + (std/srfi/159/pretty + (gxc: "srfi/159/pretty" (extra-inputs: ("srfi/159/pretty.scm"))) + (gerbil/core + std/srfi/1 + std/srfi/125 + std/srfi/130 + std/srfi/159/base + std/srfi/159/show + std/srfi/159/string)) (std/srfi/159 "srfi/159" (gerbil/core std/srfi/159/base std/srfi/159/color std/srfi/159/columnar + std/srfi/159/pretty std/srfi/159/show std/srfi/159/unicode)) (std/srfi/160/macros diff --git a/src/std/build-spec.ss b/src/std/build-spec.ss index 9aed6ecb9..c6b9fcec8 100644 --- a/src/std/build-spec.ss +++ b/src/std/build-spec.ss @@ -98,6 +98,7 @@ "srfi/159/columnar" (gxc: "srfi/159/unicode" (extra-inputs: ("srfi/159/unicode.scm"))) (gxc: "srfi/159/color" (extra-inputs: ("srfi/159/color.scm"))) + (gxc: "srfi/159/pretty" (extra-inputs: ("srfi/159/pretty.scm"))) "srfi/159" "srfi/160/cvector" "srfi/160/base" diff --git a/src/std/srfi/159.ss b/src/std/srfi/159.ss index a3b53e329..54dc29cf8 100644 --- a/src/std/srfi/159.ss +++ b/src/std/srfi/159.ss @@ -6,9 +6,14 @@ ./159/show ./159/columnar ./159/unicode - ./159/color) -(export (import: ./159/base - ./159/show - ./159/columnar - ./159/unicode - ./159/color)) + ./159/color + ./159/pretty) +(export + (except-out (import: ./159/base + ./159/show + ./159/columnar + ./159/unicode + ./159/color + ./159/pretty) + written-shared + pretty-shared)) diff --git a/src/std/srfi/159/pretty.scm b/src/std/srfi/159/pretty.scm new file mode 100644 index 000000000..98a455561 --- /dev/null +++ b/src/std/srfi/159/pretty.scm @@ -0,0 +1,368 @@ +;; pretty.scm -- pretty printing format combinator +;; Copyright (c) 2006-2018 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 (string-find/index str pred i) + (string-cursor->index + str + (string-find str pred (string-index->cursor str i)))) + +(define (try-fitted2 proc fail) + (fn (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/index str #\newline i)) + (len (string-length 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-default str))))))))) + (forked + (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 (- (+ (or (length+ form) +inf.0) 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 + (trimmed/lazy (- width col2) + (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))) + ((> (or (length+ (cdr ls)) +inf.0) (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 "(" (pp (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 () + (call-with-output + (each (pp obj (extract-shared-objects obj #t)) + fl) + displayed))) + +(define (pretty-shared obj) + (fn () + (call-with-output + (each (pp obj (extract-shared-objects obj #f)) + fl) + displayed))) + +(define (pretty-simply obj) + (fn () + (each (pp obj (extract-shared-objects #f #f)) + fl))) diff --git a/src/std/srfi/159/pretty.ss b/src/std/srfi/159/pretty.ss new file mode 100644 index 000000000..c2c811800 --- /dev/null +++ b/src/std/srfi/159/pretty.ss @@ -0,0 +1,14 @@ +;;; -*- Gerbil -*- +;;; © vyzo +;;; SRFI-159: pretty printing format combinator + +(import ../1 + ../125 + ../130 + ./base + ./show + ./string) +(export + pretty pretty-shared pretty-simply + joined/shares try-fitted) +(include "pretty.scm")