Implementation of #:defaults keyword for define-generics

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)

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
+     #'(define-generics name
-         (generic . generics-args) ...)]
+         #:defined-table defined-table
-    [(_ name #:defined-table defined-table
+         (generic . generics-args) ...
-        (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)

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)

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))))
+            (and (list? generics)
-     (let* ([idxs (for/list ([i (in-naturals 0)]
+                 (andmap identifier? generics))))
-                             [_ (syntax->list #'(generic ...))])
+     (let* ([generics (syntax->list #'(generic ...))]
-                    i)]
             [name-str (symbol->string (syntax-e #'name?))]
-            [generics (syntax->list #'(generic ...))]
+            [idxs (for/list ([i (in-naturals 0)]
-            [prop-defined-already? (syntax-e #'defined-already?)])
+                             [_ 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)
+                     #'(begin
-                         (make-struct-type-property
+                         (define-values (prop:name -name? get-generics)
-                          'name
+                           (make-struct-type-property
-                          (lambda (generic-vector si)
+                            'name
-                            (unless (vector? generic-vector)
+                            (lambda (generic-vector si)
-                              (error 'name
+                              (unless (vector? generic-vector)
-                                     "bad generics table, expecting a vector, got ~e"
+                                (error 'name
-                                     generic-vector))
+                                       "bad generics table, expecting a vector, got ~e"
-                            (unless (= (vector-length generic-vector)
+                                       generic-vector))
-                                       how-many-generics)
+                              (unless (= (vector-length generic-vector)
-                              (error 'name
+                                         how-many-generics)
-                                     "bad generics table, expecting a vector of length ~e, got ~e"
+                                (error 'name
-                                     how-many-generics
+                                       "bad generics table, expecting a vector of length ~e, got ~e"
-                                     (vector-length generic-vector)))
+                                       how-many-generics
-                            (vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
+                                       (vector-length generic-vector)))
-                                      (and mthd-generic
+                              (vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
-                                           (generic-arity-coerce mthd-generic)))
+                                        (and mthd-generic
-                                    ...))
+                                             (generic-arity-coerce mthd-generic)))
-                          null #t))))
+                                      ...))
+                            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)
+                   (cond
-                       (let ([m (vector-ref (get-generics this) generic-idx)])
+                    ;; default cases
-                         (if m
+                    [(pred? this) (apply cond-impl given-args)]
-                             (apply m given-args)
+                    ...
-                             (error 'generic "not implemented for ~e" this)))
+                    ;; Fallthrough
-                       (raise-argument-error 'generic name-str this))))))
+                    [(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)])))))
              ...)))]))
 

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.

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

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

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)

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
+   ([])))

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"