Added a #:derive-property option to define-generics.

The define-generics form can now derive existing struct properties, so that any
instance of the new generics group is also an instance of the struct property.

pkgs/data-lib/data/order.rkt

@@ -22,6 +22,7 @@
                 dict-def-table)
   #:defaults ()
   #:fallbacks ()
+  #:derive-properties ()
   (dict-iterate-least ordered-dict)
   (dict-iterate-greatest ordered-dict)
   (dict-iterate-least/>? ordered-dict key)

pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 
-(require racket/private/generic-methods
+(require racket/generic
          racket/sequence
          (for-syntax racket/base))
 
@@ -8,54 +8,25 @@
 ;; but it turns out streams can do all that already (including state),
 ;; making iterators redundant. Kept around as extra tests.
 
-
+(define-generics iterator
-(define-values (prop:iterator iterator? iterator-accessor)
+  (iterator-first iterator)
-  (make-struct-type-property
+  (iterator-rest iterator)
-   'iterator
+  (iterator-continue? iterator)
-   #f
+  ;; Iterators are automatically sequences, but don't have the full
-   ;; Iterators are automatically sequences, but don't have the full
+  ;; flexibility of sequences: they are their own initial state, and
-   ;; flexibility of sequences: they are their own initial state, and
+  ;; they can only look at their state to decide if iteration is over.
-   ;; they can only look at their state to decide if iteration is over.
+  ;; Given that extra field can be added to the iterator, there is no
-   ;; Given that extra field can be added to the iterator, there is no
+  ;; loss of expressiveness.
-   ;; loss of expressiveness.
+  #:derive-property prop:sequence
-   (list (cons prop:sequence
+  (lambda (t)
-               (lambda (method-table) ; 3-vector
+    (make-do-sequence
-                 (define iterator-first     (vector-ref method-table 0))
+     (lambda ()
-                 (define iterator-rest      (vector-ref method-table 1))
+       (values iterator-first
-                 (define iterator-continue? (vector-ref method-table 2))
+               iterator-rest ; needs to create a new struct
-                 (lambda (t)
+               t
-                   (make-do-sequence
+               iterator-continue?
-                    (lambda ()
+               (lambda (v) #t)
-                      (values iterator-first
+               (lambda (t v) #t))))))
-                              iterator-rest ; needs to create a new struct
-                              t
-                              iterator-continue?
-                              (lambda (v) #t)
-                              (lambda (t v) #t))))))))))
-
-(define (iterator-first i)
-  (unless (iterator? i)
-    (raise-argument-error 'iterator-first "iterator?" i))
-  (define proc (vector-ref (iterator-accessor i) 0))
-  (proc i))
-
-(define (iterator-rest i)
-  (unless (iterator? i)
-    (raise-argument-error 'iterator-rest "iterator?" i))
-  (define proc (vector-ref (iterator-accessor i) 1))
-  (proc i))
-
-(define (iterator-continue? i)
-  (unless (iterator? i)
-    (raise-argument-error 'iterator-continue? "iterator?" i))
-  (define proc (vector-ref (iterator-accessor i) 2))
-  (proc i))
-
-(define-syntax gen:iterator
-  (make-generic-info (quote-syntax prop:iterator)
-                     (list (quote-syntax iterator-first)
-                           (quote-syntax iterator-rest)
-                           (quote-syntax iterator-continue?))))
 
 (struct list-iterator (l)
         #:methods gen:iterator

pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt

@@ -24,6 +24,7 @@
     (foo gen:foo prop:foo foo-methods foo? dummy)
     #:defaults ([number? (define (meth foo #:kw kw) kw)])
     #:fallbacks ()
+    #:derive-properties ()
     (meth foo #:kw kw))
 
   (check-equal? (meth 3 #:kw 5) 5))

racket/collects/racket/generic.rkt

@@ -15,45 +15,54 @@
 
 (begin-for-syntax
 
-  (define (parse stx methods table defaults fallbacks)
+  (define (parse stx [options (hasheq)])
     (syntax-case stx ()
       [(#:defined-table name . args)
        (identifier? #'name)
-       (if table
+       (if (hash-ref options 'table #f)
            (wrong-syntax (stx-car stx)
                          "duplicate #:defined-table specification")
-           (parse #'args methods #'name defaults fallbacks))]
+           (parse #'args (hash-set options 'table #'name)))]
       [(#:defined-table . other)
        (wrong-syntax (stx-car stx) "invalid #:defined-table specification")]
       [(#:defaults ([pred defn ...] ...) . args)
-       (if defaults
+       (if (hash-ref options 'defaults #f)
            (wrong-syntax (stx-car stx) "duplicate #:defaults specification")
-           (parse #'args methods table #'([pred defn ...] ...) fallbacks))]
+           (parse #'args (hash-set options 'defaults #'([pred defn ...] ...))))]
       [(#:defaults . other)
        (wrong-syntax (stx-car stx) "invalid #:defaults specification")]
       [(#:fallbacks [fallback ...] . args)
-       (if fallbacks
+       (if (hash-ref options 'fallbacks #f)
            (wrong-syntax (stx-car stx) "duplicate #:fallbacks specification")
-           (parse #'args methods table defaults #'[fallback ...]))]
+           (parse #'args (hash-set options 'fallbacks #'[fallback ...])))]
       [(#:fallbacks . other)
        (wrong-syntax (stx-car stx) "invalid #:fallbacks specification")]
+      [(#:derive-property prop impl . args)
+       (parse #'args
+              (hash-set options
+                        'derived
+                        (cons (list #'prop #'impl)
+                              (hash-ref options 'derived '()))))]
+      [(#:derive-property . other)
+       (wrong-syntax (stx-car stx) "invalid #:derive-property specification")]
       [(kw . args)
        (keyword? (syntax-e #'kw))
        (wrong-syntax #'kw "invalid keyword argument")]
       [((_ . _) . args)
-       (if methods
+       (if (hash-ref options 'methods #f)
            (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 fallbacks)])))]
+               [_ (parse stx (hash-set options 'methods (reverse methods)))])))]
       [(other . args)
        (wrong-syntax #'other
                      "expected a method identifier with formal arguments")]
-      [() (values (or methods '())
+      [() (values (hash-ref options 'methods '())
-                  (or table (generate-temporary 'table))
+                  (hash-ref options 'table generate-temporary)
-                  (or defaults '())
+                  (hash-ref options 'defaults '())
-                  (or fallbacks '()))]
+                  (hash-ref options 'fallbacks '())
+                  (hash-ref options 'derived '()))]
       [other
        (wrong-syntax #'other
                      "expected a list of arguments with no dotted tail")])))
@@ -64,10 +73,11 @@
      (parameterize ([current-syntax-context stx])
        (unless (identifier? #'name)
          (wrong-syntax #'name "expected an identifier"))
-       (define-values (methods table defaults fallbacks)
+       (define-values (methods table defaults fallbacks derived)
-         (parse #'rest #f #f #f #f))
+         (parse #'rest))
        (define/with-syntax [default ...] defaults)
        (define/with-syntax [fallback ...] fallbacks)
+       (define/with-syntax [derive ...] derived)
        (define/with-syntax [method ...] methods)
        (define/with-syntax [method-name ...] (map stx-car methods))
        (define/with-syntax [method-index ...]
@@ -86,6 +96,7 @@
              (name gen-name prop-name get-name pred-name table-name)
              #:defaults [default ...]
              #:fallbacks [fallback ...]
+             #:derive-properties [derive ...]
              method ...)
            (define-generics-contract name pred-name get-name
              [method-name method-index]

racket/collects/racket/private/dict.rkt

@@ -7,6 +7,7 @@
   (dict gen:dict prop:dict dict-methods dict? dict-def-table)
   #:defaults ()
   #:fallbacks ()
+  #:derive-properties ()
   (dict-ref  dict key [default])
   (dict-set! dict key val)
   (dict-set  dict key val)

racket/collects/racket/private/generic.rkt

@@ -36,6 +36,7 @@
                    supported-name)
         #:defaults ([default-pred default-defn ...] ...)
         #:fallbacks [fallback-defn ...]
+        #:derive-properties ([derived-prop derived-impl] ...)
         [method-name . method-signature]
         ...)
      (parameterize ([current-syntax-context #'original])
@@ -86,7 +87,16 @@
              ...
              x)
            (define-values (property-name prop:pred accessor-name)
-             (make-struct-type-property 'generic-name prop:guard '() #t))
+             (make-struct-type-property
+              'generic-name
+              prop:guard
+              (list
+               (cons derived-prop
+                     (lambda (impl)
+                       (let ([method-name (vector-ref impl 'method-index)] ...)
+                         derived-impl)))
+               ...)
+              #t))
            (define (predicate-name self-name)
              (or (prop:pred self-name) (default-pred-name self-name) ...))
            (define (table-name self-name [who 'table-name])