From e2e63684de77f0b3525d14a7062230f388c9c917 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 21 Oct 2011 02:32:33 -0600
Subject: [PATCH] data/order: added support for transparent structs, added
 tests

---
 collects/data/order.rkt               | 79 +++++++++++++++++++-----
 collects/data/scribblings/order.scrbl | 86 ++++++++++++++++++++-------
 collects/tests/data/order.rkt         | 66 ++++++++++++++++++++
 3 files changed, 196 insertions(+), 35 deletions(-)
 create mode 100644 collects/tests/data/order.rkt

diff --git a/collects/data/order.rkt b/collects/data/order.rkt
index 46087d7059..58115b65e7 100644
--- a/collects/data/order.rkt
+++ b/collects/data/order.rkt
@@ -2,7 +2,8 @@
 (require racket/dict
          racket/contract/base
          racket/string
-         unstable/prop-contract)
+         unstable/prop-contract
+         ffi/unsafe/atomic)
 
 (define ordering/c
   (or/c '= '< '>))
@@ -154,7 +155,8 @@ Other:
   < pair
   < vector
   < box
-  < prefab
+  < prefab-struct
+  < fully-transparent-struct
 
 ;; FIXME: What else to add? regexps (4 kinds?), syntax, ...
 
@@ -171,16 +173,16 @@ Other:
 (define (gen-cmp x y natural?)
   (define-syntax-rule (recur x* y*)
     (gen-cmp x* y* natural?))
-  #|
-  (cond ...
+  (cond [(eq? x y) '=]
+        #|
         [(T? x) ...]
-        ;; at this point, Type(x) > T
+         ;; at this point, Type(x) > T
         [(T? y)
          ;; Type(x) > T = Type(y), so:
-         '>])
-  Assumes arguments are legal.
-  |#
-  (cond [(real? x)
+         '>]
+        Assumes arguments are legal.
+        |#
+        [(real? x)
          (if (real? y)
              (cond [natural?
                     (cmp* < = x y)]
@@ -252,7 +254,7 @@ Other:
         [(pair? y) '>]
         [(vector? x)
          (if (vector? y)
-             (vector<? x y 0 natural?)
+             (vector-cmp x y 0 natural?)
              '<)]
         [(vector? y) '>]
         [(box? x)
@@ -263,16 +265,29 @@ Other:
         [(prefab-struct-key x)
          (if (prefab-struct-key y)
              (lexico (recur (prefab-struct-key x) (prefab-struct-key y))
-                     (vector<? (struct->vector x) (struct->vector y) 1 natural?))
+                     ;; FIXME: use struct-ref to avoid allocation?
+                     (vector-cmp (struct->vector x) (struct->vector y) 1 natural?))
              '<)]
         [(prefab-struct-key y)
          '>]
+        [(fully-transparent-struct-type x)
+         => (lambda (xtype)
+              (cond [(fully-transparent-struct-type y)
+                     => (lambda (ytype)
+                          ;; could also do another lexico with object-name first
+                          (lexico (object-cmp xtype ytype)
+                                  ;; FIXME: use struct-ref to avoid allocation?
+                                  (vector-cmp (struct->vector x) (struct->vector y)
+                                              1 natural?)))]
+                    [else '<]))]
+        [(fully-transparent-struct-type y)
+         '>]
         [else
          (raise-type-error
           (if natural? 'natural-cmp 'datum-cmp)
           (string-join '("number" "string" "bytes" "keyword" "symbol" "boolean" "character"
                          "null" "pair" "vector" "box"
-                         "or prefab struct")
+                         "prefab struct" "or fully-transparent struct")
                        ", ")
           0 x y)]))
 
@@ -287,18 +302,54 @@ Other:
     ((>) '>)))
 
 (define (symbol<? x y)
+  ;; FIXME: need prim symbol<? to avoid allocation!
   (string<? (symbol->string x) (symbol->string y)))
 
-(define (vector<? x y i natural?)
+(define (vector-cmp x y i natural?)
   (cond [(< i (vector-length x))
          (if (< i (vector-length y))
              (lexico (gen-cmp (vector-ref x i) (vector-ref y i) natural?)
-                     (vector<? x y (add1 i) natural?))
+                     (vector-cmp x y (add1 i) natural?))
              '>)]
         [(< i (vector-length y))
          '<]
         [else '=]))
 
+;; fully-transparent-struct-type : any -> struct-type or #f
+(define (fully-transparent-struct-type x)
+  (parameterize ((current-inspector weak-inspector))
+    (let-values ([(x-type x-skipped?) (struct-info x)])
+      (and (not x-skipped?) x-type))))
+
+;; weak inspector controls no struct types;
+;; so if it can inspect, must be transparent
+(define weak-inspector (make-inspector))
+
+;; Impose an arbitrary (but consistent) ordering on eq?-compared
+;; objects. Use eq? and eq-hash-code for common fast path. Fall back
+;; to table when comparing struct-types *same eq-hash-code* but *not
+;; eq?*. That should be rare.
+(define object-order-table (make-weak-hasheq))
+(define object-order-next 0)
+(define (object-cmp x y)
+  (cond [(eq? x y) '=]
+        [else
+         (lexico
+          (cmp* < = (eq-hash-code x) (eq-hash-code y))
+          (call-as-atomic
+           (lambda ()
+             (let ([xi (hash-ref object-order-table x #f)]
+                   [yi (hash-ref object-order-table y #f)])
+               (cond [(and xi yi)
+                      ;; x not eq? y, so xi != yi
+                      (if (< xi yi) '< '>)]
+                     [xi '<]
+                     [yi '>]
+                     [else ;; neither one is in table; we only need to add one
+                      (hash-set! object-order-table x object-order-next)
+                      (set! object-order-next (add1 object-order-next))
+                      '<])))))]))
+
 (define datum-order
   (order* 'datum-order any/c datum-cmp))
 
diff --git a/collects/data/scribblings/order.scrbl b/collects/data/scribblings/order.scrbl
index 363bc00d11..f33daf945d 100644
--- a/collects/data/scribblings/order.scrbl
+++ b/collects/data/scribblings/order.scrbl
@@ -65,8 +65,10 @@ implementing the @tech{ordered dictionary} interface (via
 }
 
 @deftogether[[
-@defproc[(dict-iterate-least [dict ordered-dict?]) any/c]
-@defproc[(dict-iterate-greatest [dict ordered-dict?]) any/c]]]{
+@defproc[(dict-iterate-least [dict ordered-dict?])
+         (or/c (dict-iter-contract dict) #f)]
+@defproc[(dict-iterate-greatest [dict ordered-dict?])
+         (or/c (dict-iter-contract dict) #f)]]]{
 
 Returns the position of the least (greatest) key in the ordered
 dictionary @racket[dict]. If @racket[dict] is empty, @racket[#f] is
@@ -74,10 +76,14 @@ returned.
 }
 
 @deftogether[[
-@defproc[(dict-iterate-least/>? [dict ordered-dict?] [key any/c]) any/c]
-@defproc[(dict-iterate-least/>=? [dict ordered-dict?] [key any/c]) any/c]
-@defproc[(dict-iterate-greatest/<? [dict ordered-dict?] [key any/c]) any/c]
-@defproc[(dict-iterate-greatest/<=? [dict ordered-dict?] [key any/c]) any/c]
+@defproc[(dict-iterate-least/>? [dict ordered-dict?] [key any/c])
+         (or/c (dict-iter-contract dict) #f)]
+@defproc[(dict-iterate-least/>=? [dict ordered-dict?] [key any/c])
+         (or/c (dict-iter-contract dict) #f)]
+@defproc[(dict-iterate-greatest/<? [dict ordered-dict?] [key any/c])
+         (or/c (dict-iter-contract dict) #f)]
+@defproc[(dict-iterate-greatest/<=? [dict ordered-dict?] [key any/c])
+         (or/c (dict-iter-contract dict) #f)]
 ]]{
 
 Returns the position of the least key greater than @racket[key], the
@@ -167,35 +173,73 @@ excludes @racket[+nan.0] but includes @racket[+inf.0] and
 
 @defthing[datum-order order?]{
 
-An ad hoc order that encompasses many built-in Racket data types. The
+An ad hoc order that encompasses many built-in Racket data types as
+well as prefab structs and fully-transparent structs. The
 @racket[datum-order] comparator orders values of the same data type
 according to the data type's natural order: @racket[string=?],
 @racket[string<?] for strings, for example (but see the warning about
 numbers below). Different data types are ordered arbitrarily but
 contiguously; for example, all strings sort before all vectors, or
-vice versa. Programs should not rely on the ordering of different data
-types.
+vice versa. Prefab and fully-transparent structs are ordered according
+to their most specific struct type, and prefab structs are ordered
+first by their prefab struct keys. The ordering of struct types is
+independent of the struct type hierarchy; a struct type may sort
+before one of its subtypes but after another.
 
-The order is designed so that lists, vectors, and prefab structs are
-ordered lexicographically.
+Programs should not rely on the ordering of different data types,
+since it may change in future versions of Racket to improve comparison
+performance. The ordering of non-prefab struct types may change
+between one execution of a program and the next.
 
-@bold{Warning!} The @racket[datum-order] is not compatible with the
-standard numeric order; all exact numbers are ordered before all
-inexact numbers. This allows @racket[1] to be considered distinct from
+The order is guaranteed, however, to lexicographically sort proper
+lists, vectors, prefab structs, and fully-transparent
+structs. Improper lists sort lexicographically considered as pairs,
+but the ordering of an improper list and its proper prefix, such as
+@racket['(a b . c)] and @racket['(a b)], is not specified.
+
+The @racket[datum-order] comparator does not perform cycle-detection;
+comparisons involving cyclic data may diverge.
+
+@bold{Warning:} @racket[datum-order] is not compatible with the
+standard numeric order; all exact numbers are ordered separately from
+all inexact numbers. Thus @racket[1] is considered distinct from
 @racket[1.0], for example.
 
-The following built-in data types are currently supported: numbers,
-strings, bytes, keywords, symbols, booleans, characters, null, pairs,
-vectors, boxes, and prefab structs.
+The following data types are currently supported: numbers, strings,
+bytes, keywords, symbols, booleans, characters, null, pairs, vectors,
+boxes, prefab structs, and fully-transparent structs.
 
-@examples[#:eval the-eval
+The following example comparisons are specified to return the results
+shown:
+@interaction[#:eval the-eval
 (datum-order 1 2)
-(datum-order 8 5.0)
-(datum-order 3+5i 3+2i)
+(datum-order 8.0 5.0)
+(datum-order 'apple 'candy)
 (datum-order '(a #:b c) '(a #:c d c))
+(datum-order '(5 . 4) '(3 2 1))
+(datum-order '(a b . c) '(a b . z))
 (datum-order "apricot" "apple")
 (datum-order '#(1 2 3) '#(1 2))
 (datum-order '#(1 2 3) '#(1 3))
-(datum-order 'apple (box "candy"))
+(datum-order (box 'car) (box 'candy))
+(datum-order '#s(point a 1) '#s(point b 0))
+(datum-order '#s(A 1 2) '#s(Z 3 4 5))
+(datum-order (make-fish 'alewife) (make-fish 'sockeye))
+]
+
+The following example comparisons are unspecified but consistent within
+all executions of a single version of Racket:
+@racketblock[
+(datum-order 1 2.0)
+(datum-order 3+5i 3+2i)
+(datum-order 'apple "zucchini")
+(datum-order '(a b) '(a b . c))
+(datum-order 0 'zero)
+]
+
+The following example comparison is unspecified but consistent within
+a single execution of a program:
+@racketblock[
+(datum-order (make-fish 'alewife) (make-fowl 'dodo))
 ]
 }
diff --git a/collects/tests/data/order.rkt b/collects/tests/data/order.rkt
new file mode 100644
index 0000000000..61f121501f
--- /dev/null
+++ b/collects/tests/data/order.rkt
@@ -0,0 +1,66 @@
+#lang racket/base
+(require rackunit
+         data/order)
+
+;; for tests
+(struct fish (kind) #:transparent)
+(struct fowl (kind) #:transparent)
+
+;; datum-order tests
+
+(define-syntax-rule (t cmp x y)
+  (test-case (format "~s" '(t cmp x y))
+    (check-equal? (datum-order x y) 'cmp)))
+
+(t = 1 1)
+(t = +inf.0 +inf.0)
+(t = 8.0 8.0)
+(t = +nan.0 +nan.0)
+(t = +nan.0 (- +inf.0 +inf.0))
+(t = 'apple 'apple)
+(t = '(a #:b c) '(a #:b c))
+(t = "apricot" "apricot")
+(t = '#(1 2 3) '#(1 2 3))
+(t = (box 'car) (box 'car))
+(t = (box 'car) '#&car)
+(t = '#s(point a 1) '#s(point a 1))
+(t = (fish 'alewife) (fish 'alewife))
+
+(t < 1 2)
+(t > 8.0 5.0)
+(t < 'apple 'candy)
+(t < '(a #:b c) '(a #:c d c))
+(t > '(5 . 4) '(3 2 1))
+(t < '(a b . c) '(a b . z))
+(t > "apricot" "apple")
+(t > '#(1 2 3) '#(1 2))
+(t < '#(1 2 3) '#(1 3))
+(t > (box 'car) (box 'candy))
+(t < '#s(point a 1) '#s(point b 0))
+(t < '#s(A 1 2) '#s(Z 3 4 5))
+(t < (fish 'alewife) (fish 'sockeye))
+
+(define-syntax-rule (tc x y)
+  (test-case (format "~s" '(tc x y))
+    (let ([xy (datum-order x y)]
+          [xy2 (datum-order x y)]
+          [yx (datum-order y x)]
+          [xy3 (datum-order x y)])
+      ;; check consistency across multiple runs
+      (check-equal? xy xy2)
+      (check-equal? xy xy3)
+      ;; check oppositeness
+      (check member (list xy yx) '((< >) (> <))))))
+
+(tc 1 2.0)
+(tc 3+5i 3+2i)
+(tc 'apple "zucchini")
+(tc '(a b) '(a b . c))
+(tc 0 'zero)
+
+(tc (fish 'alewife) (fowl 'dodo))
+
+(tc (fish 'alewife)
+    (let ()
+      (struct fish (x))
+      (fish 'alewife)))