Skip to content
Browse files

Have method definitions be its own keyword in the struct form.

Struct properties are hidden from users.
  • Loading branch information...
1 parent 7c3c815 commit 75964e4e4397f44eabb906e2e63da5d6500e73a5 @stamourv stamourv committed May 22, 2012
View
45 collects/data/skip-list.rkt
@@ -356,14 +356,13 @@ Levels are indexed starting at 1, as in the paper.
(list dict-methods
(vector-immutable any/c any/c skip-list-iter?
#f #f #f))
- #:property prop:ordered-dict
- (methods gen:ordered-dict
- (define dict-iterate-least skip-list-iterate-least)
- (define dict-iterate-greatest skip-list-iterate-greatest)
- (define dict-iterate-least/>? skip-list-iterate-least/>?)
- (define dict-iterate-least/>=? skip-list-iterate-least/>=?)
- (define dict-iterate-greatest/<? skip-list-iterate-greatest/<?)
- (define dict-iterate-greatest/<=? skip-list-iterate-greatest/<=?)))
+ #:methods gen:ordered-dict
+ [(define dict-iterate-least skip-list-iterate-least)
+ (define dict-iterate-greatest skip-list-iterate-greatest)
+ (define dict-iterate-least/>? skip-list-iterate-least/>?)
+ (define dict-iterate-least/>=? skip-list-iterate-least/>=?)
+ (define dict-iterate-greatest/<? skip-list-iterate-greatest/<?)
+ (define dict-iterate-greatest/<=? skip-list-iterate-greatest/<=?)])
(struct skip-list* skip-list (key-c value-c)
#:property prop:dict/contract
@@ -372,14 +371,13 @@ Levels are indexed starting at 1, as in the paper.
(lambda (s) (skip-list*-key-c s))
(lambda (s) (skip-list*-value-c s))
#f))
- #:property prop:ordered-dict
- (methods gen:ordered-dict
- (define dict-iterate-least skip-list-iterate-least)
- (define dict-iterate-greatest skip-list-iterate-greatest)
- (define dict-iterate-least/>? skip-list-iterate-least/>?)
- (define dict-iterate-least/>=? skip-list-iterate-least/>=?)
- (define dict-iterate-greatest/<? skip-list-iterate-greatest/<?)
- (define dict-iterate-greatest/<=? skip-list-iterate-greatest/<=?)))
+ #:methods gen:ordered-dict
+ [(define dict-iterate-least skip-list-iterate-least)
+ (define dict-iterate-greatest skip-list-iterate-greatest)
+ (define dict-iterate-least/>? skip-list-iterate-least/>?)
+ (define dict-iterate-least/>=? skip-list-iterate-least/>=?)
+ (define dict-iterate-greatest/<? skip-list-iterate-greatest/<?)
+ (define dict-iterate-greatest/<=? skip-list-iterate-greatest/<=?)])
(struct adjustable-skip-list skip-list ()
#:property prop:dict/contract
@@ -394,14 +392,13 @@ Levels are indexed starting at 1, as in the paper.
(lambda (s) (adjustable-skip-list*-key-c s))
(lambda (s) (adjustable-skip-list*-value-c s))
#f))
- #:property prop:ordered-dict
- (methods gen:ordered-dict
- (define dict-iterate-least skip-list-iterate-least)
- (define dict-iterate-greatest skip-list-iterate-greatest)
- (define dict-iterate-least/>? skip-list-iterate-least/>?)
- (define dict-iterate-least/>=? skip-list-iterate-least/>=?)
- (define dict-iterate-greatest/<? skip-list-iterate-greatest/<?)
- (define dict-iterate-greatest/<=? skip-list-iterate-greatest/<=?)))
+ #:methods gen:ordered-dict
+ [(define dict-iterate-least skip-list-iterate-least)
+ (define dict-iterate-greatest skip-list-iterate-greatest)
+ (define dict-iterate-least/>? skip-list-iterate-least/>?)
+ (define dict-iterate-least/>=? skip-list-iterate-least/>=?)
+ (define dict-iterate-greatest/<? skip-list-iterate-greatest/<?)
+ (define dict-iterate-greatest/<=? skip-list-iterate-greatest/<=?)])
(define (make-skip-list [ord datum-order]
#:key-contract [key-contract any/c]
View
30 collects/data/splay-tree.rkt
@@ -522,14 +522,13 @@ Options
any/c
splay-tree-iter?
#f #f #f))
- #:property prop:ordered-dict
- (methods gen:ordered-dict
- (define dict-iterate-least n:splay-tree-iterate-least)
- (define dict-iterate-greatest n:splay-tree-iterate-greatest)
- (define dict-iterate-least/>? n:splay-tree-iterate-least/>?)
- (define dict-iterate-least/>=? n:splay-tree-iterate-least/>=?)
- (define dict-iterate-greatest/<? n:splay-tree-iterate-greatest/<?)
- (define dict-iterate-greatest/<=? n:splay-tree-iterate-greatest/<=?)))
+ #:methods gen:ordered-dict
+ [(define dict-iterate-least n:splay-tree-iterate-least)
+ (define dict-iterate-greatest n:splay-tree-iterate-greatest)
+ (define dict-iterate-least/>? n:splay-tree-iterate-least/>?)
+ (define dict-iterate-least/>=? n:splay-tree-iterate-least/>=?)
+ (define dict-iterate-greatest/<? n:splay-tree-iterate-greatest/<?)
+ (define dict-iterate-greatest/<=? n:splay-tree-iterate-greatest/<=?)])
(struct node-splay-tree* node-splay-tree (key-c value-c)
#:property prop:dict/contract
@@ -540,14 +539,13 @@ Options
(lambda (s) (node-splay-tree*-key-c s))
(lambda (s) (node-splay-tree*-value-c s))
#f))
- #:property prop:ordered-dict
- (methods gen:ordered-dict
- (define dict-iterate-least n:splay-tree-iterate-least)
- (define dict-iterate-greatest n:splay-tree-iterate-greatest)
- (define dict-iterate-least/>? n:splay-tree-iterate-least/>?)
- (define dict-iterate-least/>=? n:splay-tree-iterate-least/>=?)
- (define dict-iterate-greatest/<? n:splay-tree-iterate-greatest/<?)
- (define dict-iterate-greatest/<=? n:splay-tree-iterate-greatest/<=?)))
+ #:methods gen:ordered-dict
+ [(define dict-iterate-least n:splay-tree-iterate-least)
+ (define dict-iterate-greatest n:splay-tree-iterate-greatest)
+ (define dict-iterate-least/>? n:splay-tree-iterate-least/>?)
+ (define dict-iterate-least/>=? n:splay-tree-iterate-least/>=?)
+ (define dict-iterate-greatest/<? n:splay-tree-iterate-greatest/<?)
+ (define dict-iterate-greatest/<=? n:splay-tree-iterate-greatest/<=?)])
View
2 collects/racket/generics.rkt
@@ -10,7 +10,7 @@
;; Files that use racket/private/generics _must_ pass _all_ keyword
;; arguments to define-generics _in_order_.
-(provide generics define-generics define/generic methods)
+(provide generics define-generics)
(define-syntax (generics stx)
(syntax-case stx ()
View
63 collects/racket/private/define-struct.rkt
@@ -12,9 +12,10 @@
define-struct/derived
struct-field-index
struct-copy
- (for-syntax
- (rename checked-struct-info-rec? checked-struct-info?)))
-
+ define/generic
+ (for-syntax
+ (rename checked-struct-info-rec? checked-struct-info?)))
+
(define-values-for-syntax
(struct:struct-auto-info
make-struct-auto-info
@@ -104,6 +105,10 @@
(raise-type-error name "symbol" what))
what)
+ (define-syntax-parameter define/generic
+ (lambda (stx)
+ (raise-syntax-error 'define/generic "only allowed inside methods" stx)))
+
(define-syntax (define-struct* stx)
(syntax-case stx ()
[(_ . rest)
@@ -268,6 +273,58 @@
(cons (cons (cadr p) (caddr p))
(lookup config '#:props)))
nongen?)]
+ [(eq? '#:methods (syntax-e (car p)))
+ ;; #:methods gen:foo [(define (meth1 x ...) e ...) ...]
+ ;; `gen:foo' is bound to (prop:foo generic ...)
+ (define (build-method-table gen specs mthds) ; mthds is syntax
+ (with-syntax ([generics gen]
+ [(mthd-generic ...)
+ (map (λ (g) (datum->syntax mthds (syntax->datum g)))
+ specs)])
+ (quasisyntax/loc gen
+ (let ([mthd-generic #f]
+ ...)
+ (syntax-parameterize
+ ([define/generic
+ (lambda (stx)
+ (syntax-case stx (mthd-generic ...)
+ [(_ new-name mthd-generic)
+ (syntax/loc stx
+ (define new-name generic))]
+ ...
+ [(_ new-name method-name)
+ (raise-syntax-error 'define/generic
+ (format "~.s not a method of ~.s"
+ (syntax->datum #'method-name)
+ 'generics)
+ stx
+ #'method-name)]))])
+ (let ()
+ #,@mthds
+ (vector mthd-generic ...)))))))
+ (define gen:foo (cadr p))
+ (define (bad-generics)
+ (raise-syntax-error #f
+ "not a name for a generics group"
+ gen:foo gen:foo))
+ (unless (identifier? gen:foo) (bad-generics))
+ (define gen:foo-val (syntax-local-value gen:foo))
+ (unless (and (list? gen:foo-val)
+ (> (length gen:foo-val) 2))
+ (bad-generics))
+ (define prop:foo (car gen:foo-val))
+ (define meth-specs (cdr gen:foo-val))
+ (unless (and (identifier? prop:foo)
+ (list? meth-specs)
+ (andmap identifier? meth-specs))
+ (bad-generics))
+ (define meths (caddr p))
+ (loop (cons #'#:property
+ (cons prop:foo
+ (cons (build-method-table gen:foo meth-specs meths)
+ (cdddr p)))) ; post #:generics args
+ config
+ nongen?)]
[(eq? '#:inspector (syntax-e (car p)))
(check-exprs 1 p #f)
(when (lookup config '#:inspector)
View
38 collects/racket/private/dict.rkt
@@ -427,16 +427,15 @@
(hash-iterate-value (custom-hash-table d) i))
(struct custom-hash (table make-box)
- #:property prop:dict
- (methods gen:dict
- (define dict-ref custom-hash-ref)
- (define dict-set! custom-hash-set!)
- (define dict-remove! custom-hash-remove!)
- (define dict-count custom-hash-count)
- (define dict-iterate-first custom-hash-iterate-first)
- (define dict-iterate-next custom-hash-iterate-next)
- (define dict-iterate-key custom-hash-iterate-key)
- (define dict-iterate-value custom-hash-iterate-value))
+ #:methods gen:dict
+ [(define dict-ref custom-hash-ref)
+ (define dict-set! custom-hash-set!)
+ (define dict-remove! custom-hash-remove!)
+ (define dict-count custom-hash-count)
+ (define dict-iterate-first custom-hash-iterate-first)
+ (define dict-iterate-next custom-hash-iterate-next)
+ (define dict-iterate-key custom-hash-iterate-key)
+ (define dict-iterate-value custom-hash-iterate-value)]
#:property prop:equal+hash
(list (lambda (a b recur)
(and (recur (custom-hash-make-box a)
@@ -447,16 +446,15 @@
(lambda (a recur) (recur (custom-hash-table a)))))
(struct immutable-custom-hash custom-hash ()
- #:property prop:dict
- (methods gen:dict
- (define dict-ref custom-hash-ref)
- (define dict-set custom-hash-set)
- (define dict-remove custom-hash-remove)
- (define dict-count custom-hash-count)
- (define dict-iterate-first custom-hash-iterate-first)
- (define dict-iterate-next custom-hash-iterate-next)
- (define dict-iterate-key custom-hash-iterate-key)
- (define dict-iterate-value custom-hash-iterate-value)))
+ #:methods gen:dict
+ [(define dict-ref custom-hash-ref)
+ (define dict-set custom-hash-set)
+ (define dict-remove custom-hash-remove)
+ (define dict-count custom-hash-count)
+ (define dict-iterate-first custom-hash-iterate-first)
+ (define dict-iterate-next custom-hash-iterate-next)
+ (define dict-iterate-key custom-hash-iterate-key)
+ (define dict-iterate-value custom-hash-iterate-value)])
(define-values (create-custom-hash
create-immutable-custom-hash
View
50 collects/racket/private/generics.rkt
@@ -100,7 +100,7 @@
#'defined-already?
(generate-temporary 'get-generics))])
#`(begin
- (define-syntax name (list #'generic ...))
+ (define-syntax name (list #'prop:name #'generic ...))
; XXX optimize no kws or opts
(define generic-arity-coerce
(let*-values ([(p) (lambda fake-args #f)]
@@ -207,51 +207,3 @@
(error 'generic "not implemented for ~e" this)))
(raise-type-error 'generic name-str this))))))
...)))]))
-
-(require racket/stxparam)
-(define-syntax-parameter define/generic
- (lambda (stx)
- (raise-syntax-error 'define/generic "only allowed inside methods" stx)))
-(provide define/generic)
-
-;; utility for specification of methods for a group of generic functions
-;; (could make this do all the checks instead of a guard for the property)
-(provide methods)
-(define-syntax (methods stx)
- (syntax-case stx (=>)
- [(_ generics . mthds)
- (identifier? #'generics)
- (let ([specs (syntax-local-value #'generics (lambda () #f))])
- (unless (and (list? specs) (andmap identifier? specs))
- (raise-syntax-error
- #f "not a name for a generics group" stx #'generics))
- (with-syntax ([(generic ...)
- specs]
- [(mthd-generic ...)
- (map (λ (g) (datum->syntax #'mthds (syntax->datum g)))
- specs)])
- (syntax-property
- (syntax/loc stx
- (let (; XXX this could be a signal to the guard to error early,
- ; but is seems okay to allow missing methods
- [mthd-generic #f]
- ...)
- (syntax-parameterize
- ([define/generic
- (lambda (stx)
- (syntax-case stx (mthd-generic ...)
- [(_ new-name mthd-generic)
- (syntax/loc stx
- (define new-name generic))]
- ...
- [(_ new-name method-name)
- (raise-syntax-error 'define/generic
- (format "~.s not a method of ~.s"
- (syntax->datum #'method-name)
- 'generics)
- stx
- #'method-name)]))])
- (local mthds
- (vector mthd-generic ...)))))
- 'disappeared-use
- (list #'generics))))]))
View
27 collects/tests/generics/alist.rkt
@@ -3,20 +3,19 @@
(require racket/generics racket/dict racket/list)
(define-struct alist (v)
- #:property prop:dict
- (methods gen:dict
- (define (dict-ref dict key
- [default (lambda () (error "key not found" key))])
- (cond [(assoc key (alist-v dict)) => cdr]
- [else (if (procedure? default) (default) default)]))
- (define (dict-set dict key val)
- (alist (cons (cons key val) (alist-v dict))))
- (define (dict-remove dict key)
- (define al (alist-v dict))
- (remove* (assoc key al) al))
- (define (dict-count dict #:default [x #f])
- (or x
- (length (remove-duplicates (alist-v dict) #:key car))))))
+ #:methods gen:dict
+ [(define (dict-ref dict key
+ [default (lambda () (error "key not found" key))])
+ (cond [(assoc key (alist-v dict)) => cdr]
+ [else (if (procedure? default) (default) default)]))
+ (define (dict-set dict key val)
+ (alist (cons (cons key val) (alist-v dict))))
+ (define (dict-remove dict key)
+ (define al (alist-v dict))
+ (remove* (assoc key al) al))
+ (define (dict-count dict #:default [x #f])
+ (or x
+ (length (remove-duplicates (alist-v dict) #:key car))))])
(module+ test
View
4 collects/tests/generics/coercion.rkt
@@ -9,9 +9,9 @@
(echo echoable))
(struct echo1 (s)
- #:property prop:echo
+ #:methods echoable
;; defined the "new" way
- (methods echoable (define (echo x) (echo1-s x))))
+ ((define (echo x) (echo1-s x))))
(struct echo2 (s)
#:property prop:echo
View
19 collects/tests/generics/custom-hash.rkt
@@ -41,16 +41,15 @@
(struct custom-hash (table make-box)
- #:property prop:dict
- (methods gen:dict
- (define dict-ref custom-hash-ref)
- (define dict-set! custom-hash-set!)
- (define (dict-set dict key val)
- (error "no functional update"))
- (define dict-remove! custom-hash-remove!)
- (define (dict-remove dict key)
- (error "no functional update"))
- (define dict-count custom-hash-count))
+ #:methods gen:dict
+ [(define dict-ref custom-hash-ref)
+ (define dict-set! custom-hash-set!)
+ (define (dict-set dict key val)
+ (error "no functional update"))
+ (define dict-remove! custom-hash-remove!)
+ (define (dict-remove dict key)
+ (error "no functional update"))
+ (define dict-count custom-hash-count)]
#:property prop:equal+hash
(list (lambda (a b recur)
(and (recur (custom-hash-make-box a)
View
42 collects/tests/generics/from-docs.rkt
@@ -8,30 +8,28 @@
(gen-print* printable [port] #:width width #:height [height]))
(define-struct num (v)
- #:property prop:printable
- (methods printable
- (define/generic super-print gen-print)
- (define (gen-print n [port (current-output-port)])
- (fprintf port "Num: ~a" (num-v n)))
- (define (gen-port-print port n)
- (super-print n port))
- (define (gen-print* n [port (current-output-port)]
- #:width w #:height [h 0])
- (fprintf port "Num (~ax~a): ~a" w h (num-v n)))))
+ #:methods printable
+ [(define/generic super-print gen-print)
+ (define (gen-print n [port (current-output-port)])
+ (fprintf port "Num: ~a" (num-v n)))
+ (define (gen-port-print port n)
+ (super-print n port))
+ (define (gen-print* n [port (current-output-port)]
+ #:width w #:height [h 0])
+ (fprintf port "Num (~ax~a): ~a" w h (num-v n)))])
(define-struct bool (v)
- #:property prop:printable
- (methods printable
- (define/generic super-print gen-print)
- (define (gen-print b [port (current-output-port)])
- (fprintf port "Bool: ~a"
- (if (bool-v b) "Yes" "No")))
- (define (gen-port-print port b)
- (super-print b port))
- (define (gen-print* b [port (current-output-port)]
- #:width w #:height [h 0])
- (fprintf port "Bool (~ax~a): ~a" w h
- (if (bool-v b) "Yes" "No")))))
+ #:methods printable
+ [(define/generic super-print gen-print)
+ (define (gen-print b [port (current-output-port)])
+ (fprintf port "Bool: ~a"
+ (if (bool-v b) "Yes" "No")))
+ (define (gen-port-print port b)
+ (super-print b port))
+ (define (gen-print* b [port (current-output-port)]
+ #:width w #:height [h 0])
+ (fprintf port "Bool (~ax~a): ~a" w h
+ (if (bool-v b) "Yes" "No")))])
(module+ test
(require rackunit)
View
22 collects/tests/generics/iterator.rkt
@@ -40,22 +40,20 @@
(iterator-continue? iterator))
(struct list-iterator (l)
- #:property prop:iterator
- (methods iterator
- (define (iterator-first x) (car (list-iterator-l x)))
+ #:methods iterator
+ [(define (iterator-first x) (car (list-iterator-l x)))
(define (iterator-rest x) (list-iterator (cdr (list-iterator-l x))))
- (define (iterator-continue? x) (not (null? (list-iterator-l x))))))
+ (define (iterator-continue? x) (not (null? (list-iterator-l x))))])
(struct vector-iterator (i v)
- #:property prop:iterator
- (methods iterator
- (define (iterator-first x) (vector-ref (vector-iterator-v x)
- (vector-iterator-i x)))
- (define (iterator-rest x) (vector-iterator (add1 (vector-iterator-i x))
- (vector-iterator-v x)))
- (define (iterator-continue? x) (not (>= (vector-iterator-i x)
+ #:methods iterator
+ [(define (iterator-first x) (vector-ref (vector-iterator-v x)
+ (vector-iterator-i x)))
+ (define (iterator-rest x) (vector-iterator (add1 (vector-iterator-i x))
+ (vector-iterator-v x)))
+ (define (iterator-continue? x) (not (>= (vector-iterator-i x)
(vector-length
- (vector-iterator-v x)))))))
+ (vector-iterator-v x)))))])
(module+ test
(require rackunit)
View
32 collects/tests/generics/stream.rkt
@@ -3,25 +3,23 @@
(require racket/generics racket/stream)
(define-struct list-stream (v)
- #:property prop:stream
- (methods gen:stream
- (define (stream-empty? generic-stream)
- (empty? (list-stream-v generic-stream)))
- (define (stream-first generic-stream)
- (first (list-stream-v generic-stream)))
- (define (stream-rest generic-stream)
- (rest (list-stream-v generic-stream)))))
+ #:methods gen:stream
+ [(define (stream-empty? generic-stream)
+ (empty? (list-stream-v generic-stream)))
+ (define (stream-first generic-stream)
+ (first (list-stream-v generic-stream)))
+ (define (stream-rest generic-stream)
+ (rest (list-stream-v generic-stream)))])
(struct vector-stream (i v)
- #:property prop:stream
- (methods gen:stream
- (define (stream-first x) (vector-ref (vector-stream-v x)
- (vector-stream-i x)))
- (define (stream-rest x) (vector-stream (add1 (vector-stream-i x))
- (vector-stream-v x)))
- (define (stream-empty? x) (>= (vector-stream-i x)
- (vector-length
- (vector-stream-v x))))))
+ #:methods gen:stream
+ [(define (stream-first x) (vector-ref (vector-stream-v x)
+ (vector-stream-i x)))
+ (define (stream-rest x) (vector-stream (add1 (vector-stream-i x))
+ (vector-stream-v x)))
+ (define (stream-empty? x) (>= (vector-stream-i x)
+ (vector-length
+ (vector-stream-v x))))])
View
31 collects/tests/generics/struct-form.rkt
@@ -0,0 +1,31 @@
+#lang racket
+
+(require racket/dict racket/list)
+
+(define-struct alist (v)
+ #:methods gen:dict
+ [(define (dict-ref dict key
+ [default (lambda () (error "key not found" key))])
+ (cond [(assoc key (alist-v dict)) => cdr]
+ [else (if (procedure? default) (default) default)]))
+ (define (dict-set dict key val)
+ (alist (cons (cons key val) (alist-v dict))))
+ (define (dict-remove dict key)
+ (define al (alist-v dict))
+ (remove* (assoc key al) al))
+ (define (dict-count dict #:default [x #f])
+ (or x
+ (length (remove-duplicates (alist-v dict) #:key car))))])
+
+
+(module+ test
+ (require rackunit)
+
+ (define d1 '((1 . a) (2 . b)))
+
+ (check-true (dict? d1))
+ (check-eq? (dict-ref d1 1) 'a)
+ (check-equal? (dict-count (dict-remove d1 2)) 1)
+ (check-false (dict-mutable? d1))
+ (check-true (dict-can-remove-keys? d1))
+ (check-true (dict-can-functional-set? d1)))
View
3 collects/tests/generics/tests.rkt
@@ -5,4 +5,5 @@
(submod "from-docs.rkt" test)
(submod "coercion.rkt" test)
(submod "stream.rkt" test)
- (submod "iterator.rkt" test))
+ (submod "iterator.rkt" test)
+ (submod "struct-form.rkt" test))

0 comments on commit 75964e4

Please sign in to comment.
Something went wrong with that request. Please try again.