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

Implementation of #:defaults keyword for define-generics

Browse Source
This commit is contained in:
Claire Alvis 2012-10-14 12:00:40 -04:00 committed by Asumu Takikawa
parent 7618a6a737
commit 2f426943f0
10 changed files with 198 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/data/order.rkt
View File

@ -16,6 +16,7 @@
;; generated hidden property.
(define-generics (ordered-dict gen:ordered-dict prop:ordered-dict ordered-dict?
#:defined-table dict-def-table
#:defaults ()
;; private version needs all kw args, in order
#:prop-defined-already? #f
#:define-contract #f)

23
collects/racket/generic.rkt
View File

@ -16,11 +16,25 @@
(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
[(_ name (generic . generics-args) ... #:defaults defaults)
#'(define-generics name
#:defined-table defined-table
(generic . generics-args) ...
#:defaults defaults)]
[(_ name #:defined-table defined-table (generic . generics-args) ...)
#'(define-generics name
#:defined-table defined-table
(generic . generics-args) ...
#:defaults ())]
[(_ name (generic . generics-args) ...)
#'(define-generics name #:defined-table defined-table
(generic . generics-args) ...)]
[(_ name #:defined-table defined-table
(generic . generics-args) ...)
#'(define-generics name
#:defined-table defined-table
(generic . generics-args) ...
#:defaults ())]
[(_ name
#:defined-table defined-table
(generic . generics-args) ...
#:defaults defaults)
(local [(define name-str (symbol->string (syntax-e #'name)))
(define (id . strs)
(datum->syntax
@ -29,6 +43,7 @@
[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
#:define-contract define-generics-contract)

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

@ -3,7 +3,9 @@
(require racket/private/generic ; to avoid circular dependencies
(for-syntax racket/base))
(define-generics (dict gen:dict prop:dict dict? #:defined-table dict-def-table
(define-generics (dict gen:dict prop:dict dict?
#:defined-table dict-def-table
#:defaults ()
;; private version needs all kw args, in order
#:prop-defined-already? #f
#:define-contract #f)

105
collects/racket/private/generic.rkt
View File

@ -2,7 +2,8 @@
(require racket/local
(for-syntax racket/base
racket/local
racket/syntax)
racket/syntax
syntax/stx)
(only-in "define-struct.rkt" define/generic))
(define-for-syntax (keyword-stx? v)
@ -20,6 +21,10 @@
;; the method header's self argument.
[(_ (header name prop:name name?
#:defined-table defined-table
#:defaults
([pred? impl ...]
;; TODO fallthrough?
...)
;; are we being passed an existing struct property? If so,
;; this kw arg is bound to the struct property accessor, and
;; we don't define the struct property
@ -36,13 +41,32 @@
(identifier? #'name?)
(identifier? #'defined-table)
(let ([generics (syntax->list #'(generic ...))])
(and (list? generics) (andmap identifier? generics))))
(let* ([idxs (for/list ([i (in-naturals 0)]
[_ (syntax->list #'(generic ...))])
i)]
(and (list? generics)
(andmap identifier? generics))))
(let* ([generics (syntax->list #'(generic ...))]
[name-str (symbol->string (syntax-e #'name?))]
[generics (syntax->list #'(generic ...))]
[prop-defined-already? (syntax-e #'defined-already?)])
[idxs (for/list ([i (in-naturals 0)]
[_ generics])
i)]
[prop-defined-already? (syntax-e #'defined-already?)]
;; syntax introducers for each default implementation set
;; these connect the default method definitions to the
;; appropriate dispatch reference in the generic function body
[pred-introducers (map (λ (_) (make-syntax-introducer))
(syntax->list #'(pred? ...)))]
;; mark each set of default methods for a default set and
;; then flatten all of the default definitions
[method-impl-list
(apply append
(map syntax->list
(for/list ([introducer pred-introducers]
[meths (syntax->list #'((impl ...) ...))])
(introducer meths))))]
;; mark each generic function name for a default set
[marked-generics
(for/list ([generic generics])
(for/list ([introducer pred-introducers])
(introducer generic)))])
(with-syntax ([name-str name-str]
[how-many-generics (length idxs)]
[(generic-arity-coerce ...) (generate-temporaries #'(generic ...))]
@ -100,7 +124,10 @@
[get-generics
(if prop-defined-already?
#'defined-already?
(generate-temporary 'get-generics))])
(generate-temporary 'get-generics))]
;; for each generic method, builds a cond clause to do the
;; predicate dispatch found in method-impl-list
[((cond-impl ...) ...) marked-generics])
#`(begin
(define-syntax name (list #'prop:name #'generic ...))
; XXX optimize no kws or opts
@ -114,25 +141,30 @@
#,@(if prop-defined-already?
'() ; we don't need to define it
(list
#'(define-values (prop:name name? get-generics)
(make-struct-type-property
'name
(lambda (generic-vector si)
(unless (vector? generic-vector)
(error 'name
"bad generics table, expecting a vector, got ~e"
generic-vector))
(unless (= (vector-length generic-vector)
how-many-generics)
(error 'name
"bad generics table, expecting a vector of length ~e, got ~e"
how-many-generics
(vector-length generic-vector)))
(vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
(and mthd-generic
(generic-arity-coerce mthd-generic)))
...))
null #t))))
#'(begin
(define-values (prop:name -name? get-generics)
(make-struct-type-property
'name
(lambda (generic-vector si)
(unless (vector? generic-vector)
(error 'name
"bad generics table, expecting a vector, got ~e"
generic-vector))
(unless (= (vector-length generic-vector)
how-many-generics)
(error 'name
"bad generics table, expecting a vector of length ~e, got ~e"
how-many-generics
(vector-length generic-vector)))
(vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
(and mthd-generic
(generic-arity-coerce mthd-generic)))
...))
null #t))
;; overrides the interface predicate so that any of the default
;; types also answer #t
(define (name? x)
(or (-name? x) (pred? x) ...)))))
;; Hash table mapping method name symbols to
;; whether the given method is implemented
(define (defined-table this)
@ -147,6 +179,8 @@
(generic generic-idx) ...))
;; don't define a contract when given #f
'())
;; Define default implementations
#,@method-impl-list
;; Define generic functions
(define generic
(generic-arity-coerce
@ -162,11 +196,16 @@
; XXX (non-this ... this . rst)
(lambda given-args
(define this (list-ref given-args generic-this-idx))
(if (name? this)
(let ([m (vector-ref (get-generics this) generic-idx)])
(if m
(apply m given-args)
(error 'generic "not implemented for ~e" this)))
(raise-argument-error 'generic name-str this))))))
(cond
;; default cases
[(pred? this) (apply cond-impl given-args)]
...
;; Fallthrough
[(name? this)
(let ([m (vector-ref (get-generics this) generic-idx)])
(if m
(apply m given-args)
(error 'generic "not implemented for ~e" this)))]
[else (raise-argument-error 'generic name-str this)])))))
...)))]))

1
collects/racket/stream.rkt
View File

@ -41,6 +41,7 @@
(define-generics (-stream gen:stream prop:stream stream?
#:defined-table defined-table
#:defaults ()
#:prop-defined-already? stream-get-generics
#:define-contract #f)
;; These three are never used for the reasons explained above.

18
collects/scribblings/reference/generic.scrbl
View File

@ -9,6 +9,7 @@
@defmodule[racket/generic]
A @deftech{generic interface} allows per-type methods to be
associated with generic functions. Generic functions are defined
using a @racket[define-generics] form. Method implementations for
@ -17,14 +18,19 @@ a structure type are defined using the @racket[#:methods] keyword
@defform/subs[(define-generics id [#:defined-table defined-table-id]
[method-id . kw-formals*]
...)
...
maybe-defaults)
([kw-formals* (arg* ...)
(arg* ...+ . rest-id)
rest-id]
[arg* arg-id
[arg-id]
(code:line keyword arg-id)
(code:line keyword [arg-id])])]{
(code:line keyword [arg-id])]
[maybe-defaults (code:line)
(code:line #:defaults ([pred?
method-impl ...]
...))])]{
Defines
@ -59,7 +65,13 @@ immutable @tech{hash table} that maps symbols corresponding to method
names to booleans representing whether or not that method is
implemented by the instance. This table is intended for use by
higher-level APIs to adapt their behavior depending on method
availability.}
availability.
When @racket[maybe-defaults] is provided, each generic function
uses @racket[pred?]s to dispatch to the given default implementations,
@racket[method-impl]s, before dispatching to the generic method table.
The syntax of the @racket[method-impl]s is the same as the methods
provided for the @racket[#:methods] keyword for @racket[struct].}
The @racket[id]@racketidfont{/c} combinator is intended to be used to
contract the range of a constructor procedure for a struct type that

43
collects/tests/generic/defaults.rkt Normal file
View File

@ -0,0 +1,43 @@
#lang racket
(require racket/generic
(prefix-in s: racket/stream))
(define-generics stream
(stream-first stream)
(stream-rest stream)
(stream-empty? stream)
#:defaults
([list?
(define my-car car)
(define stream-first my-car)
(define stream-rest cdr)
(define stream-empty? null?)]
[s:stream?
(define stream-first s:stream-first)
(define stream-rest s:stream-rest)
(define stream-empty? s:stream-empty?)]))
(module+ test
(require rackunit)
(define l1 '(1 2))
(check-true (stream? l1))
(check-false (stream-empty? l1))
(check-equal? (stream-first l1) 1)
(define l2 (stream-rest l1))
(check-true (stream? l2))
(check-false (stream-empty? l2))
(check-equal? (stream-first l2) 2)
(define l3 (stream-rest l2))
(check-true (stream? l3))
(check-true (stream-empty? l3))
(define l4 (s:stream 1 2 3))
(check-true (stream? l4))
(check-false (stream-empty? l4))
(check-equal? (stream-first l4) 1)
(check-equal? (stream-first (stream-rest l4)) 2))

1
collects/tests/generic/iterator.rkt
View File

@ -33,6 +33,7 @@
(define-generics (iterator gen:iterator prop:iterator iterator?
#:defined-table dummy
#:defaults ()
#:prop-defined-already? iterator-accessor
#:define-contract #f)
(iterator-first iterator)

41
collects/tests/generic/syntax-errors.rkt Normal file
View File

@ -0,0 +1,41 @@
#lang racket
(require racket/generic rackunit)
(define-namespace-anchor generic-env)
(define-syntax-rule (check-syntax exp ...)
(begin
(check-exn
exn:fail:syntax?
(lambda () (eval '(module foo racket/base
(require racket/generic)
exp)
(namespace-anchor->namespace generic-env))))
...))
(check-syntax
(define-generics stream
(stream-first stream)
(stream-rest stream)
(stream-empty? stream)
#:defaults
foo)
(define-generics stream
(stream-first stream)
(stream-rest stream)
(stream-empty? stream)
#:defaults
([list?
(define stream-first car)
(define stream-rest cdr)
(define stream-rest 5)
(define stream-empty? null?)]))
(define-generics stream
(stream-first stream)
(stream-rest stream)
(stream-empty? stream)
#:defaults
([])))

2
collects/tests/generic/tests.rkt
View File

@ -8,6 +8,8 @@
(submod "struct-form.rkt" test)
(submod "equal+hash.rkt" test)
(submod "custom-write.rkt" test)
(submod "defaults.rkt" test)
"syntax-errors.rkt"
"base-interfaces.rkt"
"contract.rkt"
"from-unstable.rkt"