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

Keyword arguments to define-generics can be in any order, before/after methods.

Browse Source
This commit is contained in:
Carl Eastlund 2013-07-08 00:55:41 -04:00
parent 21f4377305
commit c5760b5ed1
1 changed files with 56 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
racket/lib/collects/racket/generic.rkt
View File

@ -3,7 +3,7 @@
racket/contract/combinator racket/contract/combinator
(rename-in "private/generic.rkt" (rename-in "private/generic.rkt"
[define-generics define-generics/pre]) [define-generics define-generics/pre])
(for-syntax racket/base racket/local racket/syntax)) (for-syntax racket/base racket/local racket/syntax syntax/stx))
;; Convenience layer on top of racket/private/generic. ;; Convenience layer on top of racket/private/generic.
;; To avoid circular dependencies, racket/private/generic cannot use ;; To avoid circular dependencies, racket/private/generic cannot use
@ -14,40 +14,64 @@
(provide define-generics define/generic) (provide define-generics define/generic)
(begin-for-syntax
(define (parse stx methods table defaults)
(syntax-case stx ()
[(#:defined-table name . args)
(identifier? #'name)
(if table
(wrong-syntax (stx-car stx)
"duplicate #:defined-table specification")
(parse #'args methods #'name defaults))]
[(#:defined-table . other)
(wrong-syntax (stx-car stx) "invalid #:defined-table specification")]
[(#:defaults ([pred defn ...] ...) . args)
(if defaults
(wrong-syntax (stx-car stx) "duplicate #:defaults specification")
(parse #'args methods table #'([pred defn ...] ...)))]
[(#:defaults . other)
(wrong-syntax (stx-car stx) "invalid #:defaults specification")]
[(kw . args)
(keyword? (syntax-e #'kw))
(wrong-syntax #'kw "invalid keyword argument")]
[((_ . _) . args)
(if methods
(wrong-syntax (stx-car stx) "duplicate methods list specification")
(let loop ([methods (list (stx-car stx))] [stx #'args])
(syntax-case stx ()
[((_ . _) . args) (loop (cons (stx-car stx) methods) #'args)]
[_ (parse stx (reverse methods) table defaults)])))]
[(other . args)
(wrong-syntax #'other
"expected a method identifier with formal arguments")]
[() (values (or methods '())
(or table (generate-temporary 'table))
(or defaults '()))]
[other
(wrong-syntax #'other
"expected a list of arguments with no dotted tail")])))
(define-syntax (define-generics stx) ; allows out-of-order / optional kw args (define-syntax (define-generics stx) ; allows out-of-order / optional kw args
(syntax-case stx () ; can't use syntax-parse, since it depends on us (syntax-case stx ()
[(_ name (generic . generics-args) ... #:defaults defaults) [(_ name . rest)
#'(define-generics name (parameterize ([current-syntax-context stx])
#:defined-table defined-table (unless (identifier? #'name)
(generic . generics-args) ... (wrong-syntax #'name "expected an identifier"))
#:defaults defaults)] (define-values (methods table defaults)
[(_ name #:defined-table defined-table (generic . generics-args) ...) (parse #'rest #f #f #f))
#'(define-generics name (define/with-syntax [default ...] defaults)
#:defined-table defined-table (define/with-syntax [method ...] methods)
(generic . generics-args) ... (define/with-syntax pred-name (format-id #'name "~a?" #'name))
#:defaults ())] (define/with-syntax gen-name (format-id #'name "gen:~a" #'name))
[(_ name (generic . generics-args) ...) (define/with-syntax prop-name (generate-temporary #'name))
#'(define-generics name (define/with-syntax table-name table)
#:defined-table defined-table #'(define-generics/pre (name gen-name prop-name pred-name
(generic . generics-args) ... #:defined-table table-name
#:defaults ())] #:defaults [default ...]
[(_ name
#:defined-table defined-table
(generic . generics-args) ...
#:defaults defaults)
(local [(define name-str (symbol->string (syntax-e #'name)))
(define (id . strs)
(datum->syntax
#'name (string->symbol (apply string-append strs)) #'name))]
(with-syntax ([name? (id name-str "?")]
[gen:name (id "gen:" name-str)])
#'(define-generics/pre (name gen:name prop:name name?
#:defined-table defined-table
#:defaults defaults
;; the following are not public
#:prop-defined-already? #f #:prop-defined-already? #f
#:define-contract define-generics-contract) #:define-contract define-generics-contract)
(generic . generics-args) ...)))])) method ...))]))
;; generate a contract combinator for instances of a generic interface ;; generate a contract combinator for instances of a generic interface
(define-syntax (define-generics-contract stx) (define-syntax (define-generics-contract stx)