data/order: added support for transparent structs, added tests

This commit is contained in:
Ryan Culpepper 2011-10-21 02:32:33 -06:00
parent e362888d6d
commit e2e63684de
3 changed files with 196 additions and 35 deletions

View File

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

View File

@ -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))
]
}

View File

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