diff --git a/collects/data/order.rkt b/collects/data/order.rkt index 1847590105..15ad6d68e6 100644 --- a/collects/data/order.rkt +++ b/collects/data/order.rkt @@ -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) diff --git a/collects/racket/generic.rkt b/collects/racket/generic.rkt index 6c676c924f..63188fd562 100644 --- a/collects/racket/generic.rkt +++ b/collects/racket/generic.rkt @@ -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) diff --git a/collects/racket/private/dict.rkt b/collects/racket/private/dict.rkt index 62c103574a..8c1393763d 100644 --- a/collects/racket/private/dict.rkt +++ b/collects/racket/private/dict.rkt @@ -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) diff --git a/collects/racket/private/generic.rkt b/collects/racket/private/generic.rkt index c457ffdfe4..9bde0182e0 100644 --- a/collects/racket/private/generic.rkt +++ b/collects/racket/private/generic.rkt @@ -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)]))))) ...)))])) diff --git a/collects/racket/stream.rkt b/collects/racket/stream.rkt index f5cceb4f10..c98a195473 100644 --- a/collects/racket/stream.rkt +++ b/collects/racket/stream.rkt @@ -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. diff --git a/collects/scribblings/reference/generic.scrbl b/collects/scribblings/reference/generic.scrbl index 7b9ab77121..a3aa87d2eb 100644 --- a/collects/scribblings/reference/generic.scrbl +++ b/collects/scribblings/reference/generic.scrbl @@ -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 diff --git a/collects/tests/generic/defaults.rkt b/collects/tests/generic/defaults.rkt new file mode 100644 index 0000000000..3826a3751f --- /dev/null +++ b/collects/tests/generic/defaults.rkt @@ -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)) diff --git a/collects/tests/generic/iterator.rkt b/collects/tests/generic/iterator.rkt index 04ebd45656..f5d2182329 100644 --- a/collects/tests/generic/iterator.rkt +++ b/collects/tests/generic/iterator.rkt @@ -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) diff --git a/collects/tests/generic/syntax-errors.rkt b/collects/tests/generic/syntax-errors.rkt new file mode 100644 index 0000000000..cacef0ad70 --- /dev/null +++ b/collects/tests/generic/syntax-errors.rkt @@ -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 + ([]))) diff --git a/collects/tests/generic/tests.rkt b/collects/tests/generic/tests.rkt index 984dafc025..cd58377429 100644 --- a/collects/tests/generic/tests.rkt +++ b/collects/tests/generic/tests.rkt @@ -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"