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

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

Browse Source 
Struct properties are hidden from users.
This commit is contained in:
Vincent St-Amour 2012-05-22 15:39:39 -04:00
parent 3bfaa2b00b
commit f11861f60a
14 changed files with 221 additions and 193 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/data/skip-list.rkt
View File

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

30
collects/data/splay-tree.rkt
View File

@ -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/<=?)])

2
collects/racket/generics.rkt
View File

@ -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/generic)
(define-syntax (generics stx)
(syntax-case stx ()

64
collects/racket/private/define-struct.rkt
View File

@ -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,59 @@
(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 ([(generic ...)
specs]
[(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)
'#,gen)
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) 1))
(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)

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

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

55
collects/racket/private/generics.rkt
View File

@ -2,12 +2,13 @@
(require racket/local
(for-syntax racket/base
racket/local
racket/syntax))
racket/syntax)
(only-in "define-struct.rkt" define/generic))
(define-for-syntax (keyword-stx? v)
(keyword? (syntax->datum v)))
(provide define-generics)
(provide define-generics define/generic)
(define-syntax (define-generics stx)
(syntax-case stx () ; can't use syntax-parse, since it depends on us
;; keyword arguments must _all_ be provided _in_order_. For the
@ -100,7 +101,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 +208,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))))]))

27
collects/tests/generics/alist.rkt
View File

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

4
collects/tests/generics/coercion.rkt
View File

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

19
collects/tests/generics/custom-hash.rkt
View File

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

42
collects/tests/generics/from-docs.rkt
View File

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

22
collects/tests/generics/iterator.rkt
View File

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

32
collects/tests/generics/stream.rkt
View File

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

31
collects/tests/generics/struct-form.rkt Normal file
View File

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

3
collects/tests/generics/tests.rkt
View File

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