From 9dd6ae54bbdd71909d15fd2098757eabee8fa2a0 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau Date: Thu, 28 Sep 2023 05:41:00 +0000 Subject: [PATCH] Tweak std/misc/repr --- src/std/misc/alist.ss | 2 +- src/std/misc/plist.ss | 2 +- src/std/misc/repr-test.ss | 54 ++++++++++++++++++++++++++++++++++ src/std/misc/repr.ss | 62 +++++++++++++++++++++++++++++---------- 4 files changed, 102 insertions(+), 18 deletions(-) create mode 100644 src/std/misc/repr-test.ss diff --git a/src/std/misc/alist.ss b/src/std/misc/alist.ss index c6ee4d0b5f..5b92cad186 100644 --- a/src/std/misc/alist.ss +++ b/src/std/misc/alist.ss @@ -27,7 +27,7 @@ (def (plist->alist plist) (let loop ((p plist)) (match p - ([k v . rest] (cons (cons k v) (loop rest))) + ([k v . rest] (acons k v (loop rest))) ([] []) (else (raise-bad-argument plist->alist "proper plist" plist))))) diff --git a/src/std/misc/plist.ss b/src/std/misc/plist.ss index 1d7f16c990..edaffc1058 100644 --- a/src/std/misc/plist.ss +++ b/src/std/misc/plist.ss @@ -26,7 +26,7 @@ (def (alist->plist alist) (let loop ((p alist)) (match p - ([[k . v] . rest] (append [k v] (loop rest))) + ([[k . v] . rest] (cons* k v (loop rest))) ([] []) (else (raise-bad-argument alist->plist "proper alist" alist))))) diff --git a/src/std/misc/repr-test.ss b/src/std/misc/repr-test.ss new file mode 100644 index 0000000000..227f0a0a70 --- /dev/null +++ b/src/std/misc/repr-test.ss @@ -0,0 +1,54 @@ +(export repr-test) + +(import + :gerbil/expander + :gerbil/gambit + :std/format + :std/iter + :std/misc/repr + :std/pregexp + :std/sugar + :std/test) + +(defclass foo (a b) transparent: #t) +(defclass bar (a b)) +(defclass baz (a b)) +(defmethod {:pr baz} + (lambda (object (port (current-output-port)) (options (current-representation-options))) + (fprintf port "#~d #;(baz a: ~r b: ~r)" + (object->serial-number object) (@ object a) (@ object b)))) + +(def repr-test + (test-suite "test suite for std/misc/repr" + (import-module ':std/sugar #t #t) + (defsyntax (stx-read stx) + (syntax-case stx () + ((s r) (datum->syntax #'s (call-with-input-string (syntax->datum #'r) read))))) + (defrule (representable-checks r ...) + (begin + (test-case r + (check-equal? (repr (stx-read r)) r)) ...)) + (representable-checks + "0" + "(vector -42 3.14 +inf.0 #f #t \"simple\" #\\$ #!void keyword: #!eof)" + "identity" ;; function with a global name + "['symbol []]" ;; symbol, empty list + "[1 2 [3 . 4] [5 #u8(114 101 112 114) ...]]" + "(vector #f #!void #!eof)" + ;;"(hash (a 1) (b 2) (,(vector 'x 'y) 'xyzzy))" + "(hash-eq (a 1) (b 2))" + "(hash-eqv (1 'a) (2 'b))" + "(foo a: 1 b: 2)" + "(values 1 2 3)" + "(values)") + (defrule (unrepresentable-checks (oo rr) ...) + (begin + (test-case oo + (check-equal? + (let (o (stx-read oo)) + (match (pregexp-match (string-append "^#([0-9]+) #;" rr) (repr o)) + ([_ sn . _] (equal? (serial-number->object (string->number sn)) o)) + (else (repr o)))) #t)) ...)) + (unrepresentable-checks + ("(lambda (lambda) lambda)" "\"#\"") + ("(bar a: 1 b: 2)" "\"#\"")))) diff --git a/src/std/misc/repr.ss b/src/std/misc/repr.ss index aae8ac1540..e1ae653a2e 100644 --- a/src/std/misc/repr.ss +++ b/src/std/misc/repr.ss @@ -1,10 +1,12 @@ ;; -*- Gerbil -*- ;;; © fare ;;;; Sourceable Representation of Gerbil entities +;;;; (equal? (eval (call-with-input-string (repr o) read)) o) (export default-representation-options current-representation-options - display-separated print-representation print-unrepresentable-object representable + display-separated print-representation representable + print-unrepresentable-object unrepresentable-object-string? pr prn repr) (import @@ -14,7 +16,7 @@ ;; Definition of for-each! copied from :std/misc/list, ;; Unlike for-each, also works on improper lists, ended by non-pairs other than '() -;; : <- (list X) (<- X) +;; : (list X) (X ->) -> (def (for-each! list fun) (match list ([elem . more] (fun elem) (for-each! more fun)) @@ -36,7 +38,7 @@ ;; Display a list of items, with prefix and suffix, separated by given separator. ;; Print the prefix, suffix and separator strings on the given port. ;; Call the display-element function on each element. -;; : <- (List Any) port: Port prefix: String separator: String suffix: String display-element: (<- Any) +;; : (List Any) port: Port prefix: String separator: String suffix: String display-element: (Any ->) -> (def (display-separated list (port (current-output-port)) @@ -55,9 +57,17 @@ (display-element elem port))) (display suffix port)) +(def (sort-plist p) + (def (plist->alist p) + (match p ([k v . rest] (cons (cons k v) (plist->alist rest))) ([] []))) + (def (keywordstring (car kv1)) (keyword->string (car kv2)))) + (def (alist->plist a) + (match a ([[k . v] . rest] (cons* k v (alist->plist rest))) ([] []))) + (alist->plist (sort (plist->alist p) keyword (def (print-representation x (port (current-output-port)) (options (current-representation-options))) ;; Our universal utilities: print (recurse), repr, display, write @@ -72,8 +82,11 @@ ((simple? x) (w x)) - ((or (symbol? x) (null? x)) ;; requires slightly more care: write it after a quote. - (d "") (w x)) + ((symbol? x) ;; requires slightly more care: write it after a quote. + (d "'") (w x)) + + ((null? x) + (d "[]")) ((pair? x) ;; pair: print as [ ... ]. (display-separated x port prefix: "[" display-element: p) @@ -131,34 +144,51 @@ (let (t (object-type x)) (and (type-descriptor? t) (assgetq transparent: (type-descriptor-plist t))))) (display-separated - (cdr (if (struct-type? (object-type x)) (struct->list x) (class->list x))) port + (if (struct-type? (object-type x)) + (cdr (struct->list x)) + (sort-plist (cdr (class->list x)))) port prefix: (string-append "(" (symbol->string (type-name (object-type x)))) separate-prefix?: #t suffix: ")" display-element: p)) ((##values? x) - (let ((vs (call-with-values (lambda () x) list))) - (display-separated vs prefix: "(values" separate-prefix?: #t suffix: ")" display-element: p))) + (display-separated (values->list x) port + prefix: "(values" separate-prefix?: #t display-element: p suffix: ")")) (else (print-unrepresentable-object x port options)))) ;; Given an object without a known evaluable representation, a port and options, -;; print a general-purpose escape, using the #42 syntax and putting in a string -;; a hint as to what the value is, as obtained from the write function. -;; : <- Any Port Table +;; print a general-purpose escape, using the #42 syntax followed by the +;; string from object->string (as in the write function) in a #; comment. +;; : Any (Optional Port) (Optional Table) -> (def (print-unrepresentable-object object (port (current-output-port)) (options (current-representation-options))) (def (d x) (display x port)) (def (w x) (write x port)) - (d "") (d (object->serial-number object)) (d " #;") (w (object->string object))) + (def s (object->string object)) + (if (unrepresentable-object-string? s) + (d s) + (begin (d "#") (d (object->serial-number object)) (d " #;") (w s)))) + +(def (unrepresentable-object-string? s) + ;; we can't depend on std/pregexp or std/text/char-set for dependency reasons, + ;; so no (pregexp-match "^#[0-9]+ #;" s) or char-ascii-numeric? + (def (is? i p) (and (> (string-length s) i) (p (string-ref s i)))) + (def (is=? i c) (is? i (cut eqv? c <>))) + (def (is-num? i) (is? i (lambda (c) (char<=? #\0 c #\9)))) + (and (is=? 0 #\#) (is-num? 1) + (let loop ((i 2)) + (if (is-num? i) + (loop (1+ i)) + (and (is=? i #\space) (is=? (1+ i) #\#) (is=? (+ i 2) #\;)))))) ;; Class for representable objects with a :pr method. (defclass representable ()) ;; Given an object, a port and options, print a representation of the object. -;; : <- Any (Optional Port) (Optional Table) +;; : Any (Optional Port) (Optional Table) (defmethod {:pr representable} print-unrepresentable-object) ;; Short hand for the print-representation function @@ -167,12 +197,12 @@ (defalias pr print-representation) ;; Print a representation, then print a newline -;; : <- Any (Optional Port) (Optional Table) +;; : Any (Optional Port) (Optional Table) -> (def (prn x (p (current-output-port)) (o (current-representation-options))) (pr x p o) (newline p)) ;; Return a representation of the object, as a string, with given options. -;; : <- Any (Optional Table) +;; : Any (Optional Table) -> (def (repr x (options (current-representation-options))) (call-with-output-string [] (lambda (port) (print-representation x port options))))