Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: takikawa/racket
...
head fork: takikawa/racket
Checking mergeability… Don't worry, you can still create the pull request.
  • 2 commits
  • 6 files changed
  • 0 commit comments
  • 1 contributor
Commits on May 10, 2012
@stamourv stamourv Implement coercion for method tables.
For backwards compatiblity, method tables can be generated from old APIs.
e84614b
@stamourv stamourv props c3c2d8c
View
98 collects/generics/generics.rkt
@@ -1,7 +1,8 @@
#lang racket/base
(require racket/local
(for-syntax racket/base
- racket/local))
+ racket/local
+ racket/syntax))
(define-for-syntax (keyword-stx? v)
(keyword? (syntax->datum v)))
@@ -22,13 +23,41 @@
(provide define-generics)
(define-syntax (define-generics stx)
- (syntax-case stx ()
+ (syntax-case stx () ; can't use syntax-parse, since it depends on us
;; defined-table binding is optional, so if it's not provided just
;; hygienically generate some name to bind it to.
[(_ (name prop:name name?) (generic . generics-args) ...)
- #'(define-generics (name prop:name name? defined-table)
+ #'(define-generics (name prop:name name?
+ #:defined-table defined-table
+ #:coerce-method-table #f)
+ (generic . generics-args) ...)]
+ [(_ (name prop:name name? #:defined-table defined-table)
+ (generic . generics-args) ...)
+ #'(define-generics (name prop:name name?
+ #:defined-table defined-table
+ #:coerce-method-table #f)
+ (generic . generics-args) ...)]
+ [(_ (name prop:name name? #:coerce-method-table coerce-method-table)
+ (generic . generics-args) ...)
+ #'(define-generics (name prop:name name?
+ #:defined-table defined-table ; fresh
+ #:coerce-method-table coerce-method-table)
+ (generic . generics-args) ...)]
+ [(_ (name prop:name name?
+ ;; TODO is there a better way to handle optional kw args in s-c?
+ ;; allow out of order kw args
+ #:coerce-method-table coerce-method-table
+ #:defined-table defined-table)
+ (generic . generic-args) ...)
+ #'(define-generics (name prop:name name?
+ #:defined-table defined-table
+ #:coerce-method-table coerce-method-table)
(generic . generics-args) ...)]
- [(_ (name prop:name name? defined-table) (generic . generic-args) ...)
+ [(_ (name prop:name name?
+ #:defined-table defined-table
+ ;; use of coercion functions is explained below
+ #:coerce-method-table coerce-method-table)
+ (generic . generic-args) ...)
(and (identifier? #'name)
(identifier? #'prop:name)
(identifier? #'name?)
@@ -39,7 +68,8 @@
[_ (syntax->list #'(generic ...))])
i)]
[name-str (symbol->string (syntax-e #'name))]
- [generics (syntax->list #'(generic ...))])
+ [generics (syntax->list #'(generic ...))]
+ [need-coercion? (syntax->datum #'coerce-method-table)])
(with-syntax ([name-str name-str]
[how-many-generics (length idxs)]
[(generic-arity-coerce ...) (generate-temporaries #'(generic ...))]
@@ -90,7 +120,14 @@
(identifier? #'id)
#'id]
[()
- #'()])))])
+ #'()])))]
+ [prop:method-table
+ ;; if we need to coerce what's at prop:name into a
+ ;; method table, we need to generate a new struct
+ ;; property for the method table
+ (if need-coercion?
+ (generate-temporary (syntax->datum #'prop:name))
+ #'prop:name)])
#`(begin
(define-syntax name (list #'generic ...))
; XXX optimize no kws or opts
@@ -101,17 +138,17 @@
(lambda (f)
(procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws))))
...
- (define-values (prop:name name? get-generics)
+ (define-values (prop:method-table name? get-generics)
(make-struct-type-property
'name
(lambda (generic-vector si)
(unless (vector? generic-vector)
- (error 'name
+ (error 'name
"bad generics table, expecting a vector, got ~e"
generic-vector))
(unless (= (vector-length generic-vector)
how-many-generics)
- (error 'name
+ (error 'name
"bad generics table, expecting a vector of length ~e, got ~e"
how-many-generics
(vector-length generic-vector)))
@@ -119,6 +156,47 @@
(and mthd-generic
(generic-arity-coerce mthd-generic)))
...))))
+ ;; Use case for method table coercion: retrofitting a generics-
+ ;; based API on top of a struct property that uses its own ad-hoc
+ ;; extension mechanism.
+ ;; If coercion is used, prop:method-table and prop:name are
+ ;; distinct. We define prop:name (e.g. prop:equals+hash-code,
+ ;; the user-facing name) to "push" its method table to
+ ;; prop:method-table, calling the coercion function if necessary.
+ ;; prop:method-table is then used for dispatch and all.
+ ;; That way, existing code can use prop:name using its old
+ ;; extension API, and new code can use the generics-based
+ ;; interface.
+ ;; The coercion function should take whatever lives at prop:name
+ ;; according to its old extension API, and produce a vector of
+ ;; methods in the defined order.
+ #,@(if need-coercion?
+ (list
+ #'(define-values (prop:name unused unused2)
+ (make-struct-type-property
+ 'front-facing-name
+ #f ; no guard, we accept anything;
+ ;; prop:method-table does the checking
+ (list
+ (cons prop:method-table
+ (lambda (maybe-method-table)
+ ;; if we get a valid method table, (methods
+ ;; was used, not the old API provided for
+ ;; prop:name) we just use it. otherwise, we
+ ;; call the coercion function
+ (if (and (vector? maybe-method-table)
+ (= (vector-length
+ maybe-method-table)
+ how-many-generics)
+ (for/and ([g (in-vector
+ maybe-method-table)])
+ (procedure? g)))
+ ;; valid method table
+ maybe-method-table
+ (coerce-method-table
+ maybe-method-table))))))))
+ ;; no need for coercions, methods are stored at prop:name
+ '())
;; Hash table mapping method name symbols to
;; whether the given method is implemented
(define (defined-table this)
@@ -150,7 +228,7 @@
...)))]))
(require racket/stxparam)
-(define-syntax-parameter define/generic
+(define-syntax-parameter define/generic
(lambda (stx)
(raise-syntax-error 'define/generic "only allowed inside methods" stx)))
(provide define/generic)
View
16 collects/generics/scribblings/generics.scrbl
@@ -9,7 +9,9 @@
@defmodule[generics]
-@defform/subs[(define-generics (name prop:name name? [defined-table])
+@defform/subs[(define-generics (name prop:name name?
+ [#:defined-table defined-table]
+ [#:coerce-method-table coerce-method-table])
[method . kw-formals*]
...)
([kw-formals* (arg* ...)
@@ -54,9 +56,19 @@ method is implemented by that instance. The intended use case for this table is
to allow higher-level APIs to adapt their behavior depending on method
availability.
+The optional @racket[coerce-method-table] argument is used when implementing a
+generics-based extension API for a syntax property that already has its own
+extension API, while preserving backwards compatibility. This functionality is
+intended for library writers updating their extension APIs to use generics.
+@racket[coerce-method-table] should be bound to a coercion function that
+accepts valid values for @racket[prop:name] under its old extension API, and
+produces a vector of method implementations ordered as in the generics
+definition. This allows implementations that were defined under the old
+extension API to coexist with those defined using the generics-based API.
+
}
-@defform[(generics name
+@defform[(generics name
[method . kw-formals*]
...)
#:contracts
View
2  collects/meta/props
@@ -875,6 +875,7 @@ path/s is either such a string or a list of them.
"collects/games/show-help.rkt" drdr:command-line (gracket-text "-t" *)
"collects/games/slidey/slidey.rkt" drdr:command-line (gracket-text "-t" *)
"collects/games/spider/spider.rkt" drdr:command-line (gracket-text "-t" *)
+"collects/generics" responsible (asumu stamourv)
"collects/graphics" responsible (mflatt robby)
"collects/graphics/graphics-posn-less-unit.rkt" drdr:command-line (gracket-text "-t" *)
"collects/graphics/graphics-unit.rkt" drdr:command-line (gracket-text "-t" *)
@@ -1493,6 +1494,7 @@ path/s is either such a string or a list of them.
"collects/tests/frtime/time.rkt" drdr:command-line (gracket-text "-t" *)
"collects/tests/future" responsible (jamesswaine mflatt robby)
"collects/tests/future/random-future.rkt" drdr:timeout 480
+"collects/tests/generics" responsible (asumu stamourv)
"collects/tests/gracket" responsible (mflatt)
"collects/tests/gracket/auto.rktl" drdr:command-line #f
"collects/tests/gracket/blits.rkt" drdr:command-line (gracket "-f" *)
View
2  collects/racket/private/dict.rkt
@@ -3,7 +3,7 @@
(require generics
(for-syntax racket/base))
-(define-generics (dict prop:dict dict? dict-def-table)
+(define-generics (dict prop:dict dict? #:defined-table dict-def-table)
(dict-ref dict key [default])
(dict-set! dict key val)
(dict-set dict key val)
View
31 collects/tests/generics/coercion.rkt
@@ -0,0 +1,31 @@
+#lang racket
+
+(require generics)
+
+(define-generics (echoable prop:echo echo? #:coerce-method-table list->vector)
+ (echo echoable))
+
+(struct echo1 (s)
+ #:property prop:echo
+ ;; defined the "new" way
+ (methods echoable (define (echo x) (echo1-s x))))
+
+(struct echo2 (s)
+ #:property prop:echo
+ ;; defined the "old" way
+ (list (lambda (x) (echo2-s x))))
+
+(struct echo3 (s)
+ #:property prop:echo
+ ;; happens to get a valid method table, we're good
+ (vector (lambda (x) (echo3-s x))))
+
+(module+ test
+ (require rackunit)
+
+ (define e1 (echo1 "a"))
+ (check-equal? (echo e1) "a")
+ (define e2 (echo2 "b"))
+ (check-equal? (echo e2) "b")
+ (define e3 (echo3 "c"))
+ (check-equal? (echo e3) "c"))
View
3  collects/tests/generics/tests.rkt
@@ -2,4 +2,5 @@
(require (submod "custom-hash.rkt" test)
(submod "alist.rkt" test)
- (submod "from-docs.rkt" test))
+ (submod "from-docs.rkt" test)
+ (submod "coercion.rkt" test))

No commit comments for this range

Something went wrong with that request. Please try again.