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

Implement coercion for method tables.

Browse Source 
For backwards compatiblity, method tables can be generated from old APIs.
This commit is contained in:
Vincent St-Amour 2012-05-10 13:25:18 -04:00 committed by Asumu Takikawa
parent a68242e4eb
commit e7e66ce41c
5 changed files with 136 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
collects/generics/generics.rkt
View File

@ -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) (generic . generic-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 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)

16
collects/generics/scribblings/generics.scrbl
View File

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

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

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

31
collects/tests/generics/coercion.rkt Normal file
View File

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

3
collects/tests/generics/tests.rkt
View File

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