Tweak std/misc/repr

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)))))

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)))))

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)" "\"#<procedure #[0-9]+>\"")
+     ("(bar a: 1 b: 2)" "\"#<bar #[0-9]+>\""))))

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 (keyword<? kv1 kv2) (string<? (keyword->string (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<?)))
+
 ;; Print an evaluable representation of an object on the given port with the given options.
 ;; The port defaults to (current-output-port). The options are reserved for future use.
-;; : <- Any (Optional Port) (Optional Table)
+;; : Any (Optional Port) (Optional Table) ->
 (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))))