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

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

Browse Source 
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.
This commit is contained in:
Carl Eastlund 2013-07-16 00:54:12 -04:00
parent a5d724dda4
commit f7f15e1113
6 changed files with 60 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkgs/data-lib/data/order.rkt
View File

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

69
pkgs/racket-pkgs/racket-test/tests/generic/iterator.rkt
View File

@ -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-values (prop:iterator iterator? iterator-accessor)
(make-struct-type-property
'iterator
#f
;; Iterators are automatically sequences, but don't have the full
;; flexibility of sequences: they are their own initial state, and
;; 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
;; loss of expressiveness.
(list (cons prop:sequence
(lambda (method-table) ; 3-vector
(define iterator-first (vector-ref method-table 0))
(define iterator-rest (vector-ref method-table 1))
(define iterator-continue? (vector-ref method-table 2))
(lambda (t)
(make-do-sequence
(lambda ()
(values iterator-first
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?))))
(define-generics iterator
(iterator-first iterator)
(iterator-rest iterator)
(iterator-continue? iterator)
;; Iterators are automatically sequences, but don't have the full
;; flexibility of sequences: they are their own initial state, and
;; 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
;; loss of expressiveness.
#:derive-property prop:sequence
(lambda (t)
(make-do-sequence
(lambda ()
(values iterator-first
iterator-rest ; needs to create a new struct
t
iterator-continue?
(lambda (v) #t)
(lambda (t v) #t))))))
(struct list-iterator (l)
#:methods gen:iterator

1
pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt
View File

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

41
racket/collects/racket/generic.rkt
View File

@ -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 '())
(or table (generate-temporary 'table))
(or defaults '())
(or fallbacks '()))]
[() (values (hash-ref options 'methods '())
(hash-ref options 'table generate-temporary)
(hash-ref options 'defaults '())
(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)
(parse #'rest #f #f #f #f))
(define-values (methods table defaults fallbacks derived)
(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]

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

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

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

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