suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Forge gen:equal+hash and gen:custom-write to provide them from racket/base.

Browse Source
This commit is contained in:
Vincent St-Amour 2012-05-23 17:54:58 -04:00
parent c21813cebf
commit 11dc825126
10 changed files with 64 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/data/gvector.rkt
View File

@ -4,8 +4,7 @@
unstable/wrapc)
racket/contract/base
racket/dict
racket/vector
racket/struct)
racket/vector)
(define (make-gvector #:capacity [capacity 10])
(gvector (make-vector capacity #f) 0))

2
collects/racket/main.rkt
View File

@ -27,7 +27,6 @@
racket/promise
racket/bool
racket/stream
racket/struct
racket/sequence
racket/local
racket/system
@ -60,7 +59,6 @@
racket/promise
racket/bool
racket/stream
racket/struct
racket/sequence
racket/local
racket/system)

2
collects/racket/private/base.rkt
View File

@ -11,6 +11,7 @@
"struct.rkt"
"cert.rkt"
"submodule.rkt"
"generic-interfaces.rkt"
(for-syntax "stxcase-scheme.rkt"))
(#%provide (all-from-except "pre-base.rkt"
@ -36,6 +37,7 @@
(all-from "namespace.rkt")
(all-from "cert.rkt")
(all-from "submodule.rkt")
(all-from "generic-interfaces.rkt")
(for-syntax syntax-rules syntax-id-rules ... _)
(rename -open-input-file open-input-file)
(rename -open-output-file open-output-file)

1
collects/racket/private/dict.rkt
View File

@ -1,7 +1,6 @@
#lang racket/base
(require racket/private/generics ; to avoid circular dependencies
racket/struct
(for-syntax racket/base))
(define-generics (dict gen:dict prop:dict dict? #:defined-table dict-def-table

56
collects/racket/private/generic-interfaces.rkt Normal file
View File

@ -0,0 +1,56 @@
(module generic-interfaces "pre-base.rkt"
;; Defines (forgeries of) generic interfaces that correspond to struct
;; properties that come from racket/base.
;; Since racket/base can't depend on racket/generics, we can't use
;; `define-generics' to build these generic interfaces. Thus we must
;; forge them.
(#%require (for-syntax '#%kernel))
(#%provide gen:equal+hash gen:custom-write)
(define-values (prop:gen:equal+hash equal+hash? gen:equal+hash-acc)
(make-struct-type-property
'prop:gen:equal+hash
(lambda (v si)
(if (and (vector? v)
(= 3 (vector-length v))
(procedure? (vector-ref v 0))
(procedure-arity-includes? (vector-ref v 0) 3)
(procedure? (vector-ref v 1))
(procedure-arity-includes? (vector-ref v 1) 2)
(procedure? (vector-ref v 2))
(procedure-arity-includes? (vector-ref v 2) 2))
v
(raise-type-error 'guard-for-prop:gen:equal+hash
"vector of three procedures (arities 3, 2, 2)"
v)))
(list (cons prop:equal+hash vector->list))))
(define-syntax gen:equal+hash
(list (quote-syntax prop:gen:equal+hash)
(quote-syntax equal-proc)
(quote-syntax hash-proc)
(quote-syntax hash2-proc)))
(define-values (prop:gen:custom-write gen:custom-write? gen:custom-write-acc)
(make-struct-type-property
'prop:gen:custom-write
(lambda (v si)
(if (and (vector? v)
(= 1 (vector-length v))
(procedure? (vector-ref v 0))
(procedure-arity-includes? (vector-ref v 0) 3))
v
(raise-type-error 'guard-for-prop:gen:custom-write
"vector of one procedure (arity 3)"
v)))
(list (cons prop:custom-write (lambda (v) (vector-ref v 0))))))
(define-syntax gen:custom-write
(list (quote-syntax prop:gen:custom-write)
(quote-syntax write-proc)))
)

56
collects/racket/struct.rkt
View File

@ -1,56 +0,0 @@
#lang racket/base
;; Provides generic interfaces that correspond to struct properties
;; that live in racket/base
(require racket/private/generics)
(provide gen:equal+hash)
(define-values (prop:gen:equal+hash equal+hash? gen:equal+hash-acc)
(make-struct-type-property
'prop:gen:equal+hash
(lambda (v si)
(unless (and (vector? v)
(= 3 (vector-length v))
(procedure? (vector-ref v 0))
(procedure-arity-includes? (vector-ref v 0) 3)
(procedure? (vector-ref v 1))
(procedure-arity-includes? (vector-ref v 1) 2)
(procedure? (vector-ref v 2))
(procedure-arity-includes? (vector-ref v 2) 2))
(raise-type-error 'guard-for-prop:gen:equal+hash
"vector of three procedures (arities 3, 2, 2)"
v))
v)
(list (cons prop:equal+hash vector->list))))
(define-generics (equal+hash gen:equal+hash prop:gen:equal+hash equal+hash?
#:defined-table equal+hash-def-table
#:prop-defined-already? gen:equal+hash-acc)
(equal-proc equal+hash rhs equal?/recur)
(hash-proc equal+hash equal-hash-code/recur)
(hash2-proc equal+hash equal-secondary-hash-code/recur))
(provide gen:custom-write)
(define-values (prop:gen:custom-write gen:custom-write? gen:custom-write-acc)
(make-struct-type-property
'prop:gen:custom-write
(lambda (v si)
(unless (and (vector? v)
(= 1 (vector-length v))
(procedure? (vector-ref v 0))
(procedure-arity-includes? (vector-ref v 0) 3))
(raise-type-error 'guard-for-prop:gen:custom-write
"vector of one procedure (arity 3)"
v))
v)
(list (cons prop:custom-write (lambda (v) (vector-ref v 0))))))
(define-generics (custom-write gen:custom-write prop:gen:custom-write
gen:custom-write?
#:defined-table custom-write-def-table
#:prop-defined-already? gen:custom-write-acc)
(write-proc custom-write port mode))

9
collects/scribblings/reference/booleans.scrbl
View File

@ -4,9 +4,6 @@
@(define bool-eval (make-base-eval))
@(bool-eval '(require racket/bool))
@(define struct-eval (make-base-eval))
@(struct-eval '(require racket/struct))
@title[#:tag "booleans"]{Booleans and Equality}
True and false @deftech{booleans} are represented by the values
@ -135,10 +132,6 @@ type. @racket[gen:equal+hash] should be used instead. Accepts a list of
three procedures that correspond to the methods of @racket[gen:equal+hash].
}
@section{Extensible Equality and Hashing}
@note-lib[racket/struct]
@defthing[gen:equal+hash any/c]{
A @tech{generic interface} (see @secref["struct-generics"]) that
supplies an equality predicate and hashing functions for a structure
@ -208,7 +201,7 @@ property, then the @racket[prop:impersonator-of] property takes precedence over
@racket[gen:equal+hash] if the property value's procedure returns a
non-@racket[#f] value when applied to the structure.
@examples[ #:eval struct-eval
@examples[
(define (farm=? farm1 farm2 recursive-equal?)
(and (= (farm-apples farm1)
(farm-apples farm2))

2
collects/tests/generics/custom-hash.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require racket/generics racket/struct
(require racket/generics
(only-in racket/dict
gen:dict prop:dict
dict?

4
collects/tests/generics/custom-write.rkt
View File

@ -1,6 +1,6 @@
#lang racket
#lang racket/base
(require racket/struct)
(require racket/port)
(struct loud (v)
#:methods gen:custom-write

4
collects/tests/generics/equal+hash.rkt
View File

@ -1,6 +1,4 @@
#lang racket
(require racket/struct)
#lang racket/base
;; vectors as method tables
(struct kons (kar kdr)