data/order: added support for transparent structs, added tests
This commit is contained in:
parent
e362888d6d
commit
e2e63684de
|
@ -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))
|
||||
|
||||
|
|
|
@ -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))
|
||||
]
|
||||
}
|
||||
|
|
66
collects/tests/data/order.rkt
Normal file
66
collects/tests/data/order.rkt
Normal 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)))
|
Loading…
Reference in New Issue
Block a user