Adding generics
This commit is contained in:
Jay McCarthy
parent
f04addd104
commit
918f2caf34
146
collects/tests/unstable/generics.ss
Normal file
146
collects/tests/unstable/generics.ss
Normal file
|
|
@ -0,0 +1,146 @@
|
|||
#lang scheme
|
||||
(require unstable/generics
|
||||
tests/eli-tester)
|
||||
|
||||
(define (massq idx l)
|
||||
(match l
|
||||
[(mcons (and v (mcons (? (curry equal? idx)) _)) _)
|
||||
v]
|
||||
[(mcons _ rst)
|
||||
(massq idx rst)]
|
||||
[null
|
||||
#f]))
|
||||
|
||||
(test
|
||||
(local
|
||||
[(define-generics (lots prop:lots lots?)
|
||||
(f #:foo foo lots zog [def]))
|
||||
|
||||
(define-struct ex ()
|
||||
#:property prop:lots
|
||||
(define-methods lots
|
||||
(define (f #:foo foo lots zog [def #t])
|
||||
1)))]
|
||||
(test
|
||||
(f #:foo 3 (make-ex) 2) => 1
|
||||
(f (make-ex) #:foo 3 2) => 1
|
||||
(f (make-ex) 2 #:foo 3) => 1))
|
||||
|
||||
(local
|
||||
[(define-generics (lots prop:lots lots?)
|
||||
(f #:foo foo lots zog #:def [def]))
|
||||
|
||||
(define-struct ex ()
|
||||
#:property prop:lots
|
||||
(define-methods lots
|
||||
(define (f #:foo foo lots zog #:def [def #t])
|
||||
1)))]
|
||||
(test
|
||||
(f #:foo 3 (make-ex) 2) => 1
|
||||
(f (make-ex) 4 #:foo 3 #:def 2) => 1
|
||||
(f (make-ex) 3 #:foo 1) => 1))
|
||||
|
||||
(local
|
||||
[(define-generics (lots prop:lots lots?)
|
||||
(f lots idx val))
|
||||
|
||||
(define-struct ex ()
|
||||
#:property prop:lots
|
||||
(define-methods lots
|
||||
(define/generic gen:f f)
|
||||
(define (f lots idx val)
|
||||
(if (zero? idx)
|
||||
val
|
||||
(gen:f lots (sub1 idx) (* 2 val))))))]
|
||||
(test
|
||||
(f (make-ex) 4 1) => (expt 2 4)))
|
||||
|
||||
(local
|
||||
[(generics table
|
||||
(get table idx [default])
|
||||
(weird-get idx table)
|
||||
(put! table idx new))
|
||||
|
||||
(define-struct alist ([l #:mutable])
|
||||
#:property prop:table
|
||||
(define-methods table
|
||||
(define (get table idx [default #f])
|
||||
(cond [(massq idx (alist-l table)) => mcdr]
|
||||
[else default]))
|
||||
(define (weird-get idx table)
|
||||
(get table idx))
|
||||
(define (put! table idx new)
|
||||
(let* ([l (alist-l table)]
|
||||
[prev (massq idx l)])
|
||||
(if prev
|
||||
(set-mcar! prev new)
|
||||
(set-alist-l! table (mcons (mcons idx new) (alist-l table))))))))]
|
||||
|
||||
(test
|
||||
(make-alist empty)
|
||||
|
||||
(get (make-alist empty) 'foo) => #f
|
||||
|
||||
(local [(define t (make-alist empty))]
|
||||
(put! t 'foo 1)
|
||||
(get t 'foo))
|
||||
=>
|
||||
1
|
||||
|
||||
(weird-get 'foo (make-alist empty)) => #f
|
||||
|
||||
(local [(define t (make-alist empty))]
|
||||
(put! t 'foo 1)
|
||||
(weird-get 'foo t))
|
||||
=>
|
||||
1))
|
||||
|
||||
(test
|
||||
(generics table
|
||||
(get idx [default]))
|
||||
=error>
|
||||
"No required by-position generic argument"
|
||||
|
||||
(generics table
|
||||
(get idx [table] [default]))
|
||||
=error>
|
||||
"No required by-position generic argument")
|
||||
|
||||
|
||||
(local [(define-generics (printable prop:printable printable?)
|
||||
(gen-print printable [port])
|
||||
(gen-port-print port printable)
|
||||
(gen-print* printable [port] #:width width #:height [height]))
|
||||
|
||||
(define-struct num (v)
|
||||
#:property prop:printable
|
||||
(define-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
|
||||
(define-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")))))
|
||||
|
||||
(define x (make-num 10))
|
||||
(define y (make-bool #t))]
|
||||
(test
|
||||
(gen-print x)
|
||||
(gen-port-print (current-output-port) x)
|
||||
(gen-print* x #:width 100 #:height 90)
|
||||
|
||||
(gen-print y)
|
||||
(gen-port-print (current-output-port) y)
|
||||
(gen-print* y #:width 100 #:height 90))))
|
||||
182
collects/unstable/generics.ss
Normal file
182
collects/unstable/generics.ss
Normal file
|
|
@ -0,0 +1,182 @@
|
|||
#lang scheme/base
|
||||
(require scheme/local
|
||||
(for-syntax scheme/base
|
||||
scheme/local))
|
||||
|
||||
(define-for-syntax (keyword-stx? v)
|
||||
(keyword? (syntax->datum v)))
|
||||
|
||||
(provide generics)
|
||||
(define-syntax (generics stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name (generic . generic-args) ...)
|
||||
(local [(define name-str (symbol->string (syntax-e #'name)))
|
||||
(define (id . strs)
|
||||
(datum->syntax
|
||||
#'name (string->symbol (apply string-append strs)) #'name))]
|
||||
(with-syntax ([name? (id name-str "?")]
|
||||
[prop:name (id "prop:" name-str)])
|
||||
(syntax/loc stx
|
||||
(define-generics (name prop:name name?)
|
||||
(generic . generic-args) ...))))]))
|
||||
|
||||
(provide define-generics)
|
||||
(define-syntax (define-generics stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name prop:name name?) (generic . generic-args) ...)
|
||||
(and (identifier? #'name)
|
||||
(identifier? #'prop:name)
|
||||
(identifier? #'name?)
|
||||
(let ([generics (syntax->list #'(generic ...))])
|
||||
(and (pair? generics) (andmap identifier? generics))))
|
||||
(let ([idxs (for/list ([i (in-naturals 0)]
|
||||
[_ (syntax->list #'(generic ...))])
|
||||
i)]
|
||||
[name-str (symbol->string (syntax-e #'name))]
|
||||
[generics (syntax->list #'(generic ...))])
|
||||
(with-syntax ([name-str name-str]
|
||||
[how-many-generics (length idxs)]
|
||||
[(generic-arity-coerce ...) (generate-temporaries #'(generic ...))]
|
||||
[(generic-idx ...) idxs]
|
||||
[(generic-this-idx ...)
|
||||
(for/list ([top-ga (syntax->list #'(generic-args ...))])
|
||||
(let loop ([ga top-ga]
|
||||
[i 0])
|
||||
(syntax-case ga ()
|
||||
[(keyword id . ga)
|
||||
(and (keyword-stx? #'keyword)
|
||||
(identifier? #'id))
|
||||
(loop #'ga i)]
|
||||
[(id . ga)
|
||||
(and (identifier? #'id))
|
||||
(if (free-identifier=? #'name #'id)
|
||||
i
|
||||
(loop #'ga (add1 i)))]
|
||||
[(keyword [id] . ga)
|
||||
(and (keyword-stx? #'keyword)
|
||||
(identifier? #'id))
|
||||
(loop #'ga i)]
|
||||
[([id] . ga)
|
||||
(and (identifier? #'id))
|
||||
(loop #'ga i)]
|
||||
[_
|
||||
(identifier? #'id)
|
||||
(raise-syntax-error #f "No required by-position generic argument" top-ga)])))]
|
||||
[(fake-args ...)
|
||||
(for/list ([ga (syntax->list #'(generic-args ...))])
|
||||
(let loop ([ga ga])
|
||||
(syntax-case ga ()
|
||||
[(keyword id . ga)
|
||||
(and (keyword-stx? #'keyword)
|
||||
(identifier? #'id))
|
||||
#`(keyword id . #,(loop #'ga))]
|
||||
[(id . ga)
|
||||
(and (identifier? #'id))
|
||||
#`(id . #,(loop #'ga))]
|
||||
[(keyword [id] . ga)
|
||||
(and (keyword-stx? #'keyword)
|
||||
(identifier? #'id))
|
||||
#`(keyword [id #f] . #,(loop #'ga))]
|
||||
[([id] . ga)
|
||||
(and (identifier? #'id))
|
||||
#`([id #f] . #,(loop #'ga))]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
#'id]
|
||||
[()
|
||||
#'()])))])
|
||||
#'(begin
|
||||
(define-syntax name (list #'generic ...))
|
||||
; XXX optimize no kws or opts
|
||||
(define generic-arity-coerce
|
||||
(let*-values ([(p) (lambda fake-args #f)]
|
||||
[(generic-arity-spec) (procedure-arity p)]
|
||||
[(generic-required-kws generic-allowed-kws) (procedure-keywords p)])
|
||||
(lambda (f)
|
||||
(procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws))))
|
||||
...
|
||||
(define-values (prop:name name? get-generics)
|
||||
(make-struct-type-property
|
||||
'name
|
||||
(lambda (generic-vector si)
|
||||
(unless (vector? generic-vector)
|
||||
(error 'name
|
||||
"bad generics table, expecting a vector, got ~e"
|
||||
generic-vector))
|
||||
(unless (= (vector-length generic-vector)
|
||||
how-many-generics)
|
||||
(error 'name
|
||||
"bad generics table, expecting a vector of length ~e, got ~e"
|
||||
how-many-generics
|
||||
(vector-length generic-vector)))
|
||||
(vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
|
||||
(and mthd-generic
|
||||
(generic-arity-coerce mthd-generic)))
|
||||
...))))
|
||||
(define generic
|
||||
(generic-arity-coerce
|
||||
(make-keyword-procedure
|
||||
(lambda (kws kws-args . given-args)
|
||||
(define this (list-ref given-args generic-this-idx))
|
||||
(if (name? this)
|
||||
(let ([m (vector-ref (get-generics this) generic-idx)])
|
||||
(if m
|
||||
(keyword-apply m kws kws-args given-args)
|
||||
(error 'generic "not implemented for ~e" this)))
|
||||
(raise-type-error 'generic name-str this)))
|
||||
; XXX (non-this ... this . rst)
|
||||
(lambda given-args
|
||||
(define this (list-ref given-args generic-this-idx))
|
||||
(if (name? this)
|
||||
(let ([m (vector-ref (get-generics this) generic-idx)])
|
||||
(if m
|
||||
(apply m given-args)
|
||||
(error 'generic "not implemented for ~e" this)))
|
||||
(raise-type-error 'generic name-str this))))))
|
||||
...)))]))
|
||||
|
||||
(require scheme/stxparam)
|
||||
(define-syntax-parameter define/generic
|
||||
(lambda (stx)
|
||||
(raise-syntax-error 'define/generic "only allowed inside define-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 define-methods)
|
||||
(define-syntax (define-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/loc stx
|
||||
(let ([fake #'generics] ; This is to get the arrow to show up in DrScheme. It is ? arrow, so it isn't that nice.
|
||||
; 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 "~e not a method of ~e"
|
||||
(syntax->datum #'method-name)
|
||||
'generics)
|
||||
stx
|
||||
#'method-name)]))])
|
||||
(local mthds
|
||||
(vector mthd-generic ...)))))))]))
|
||||
138
collects/unstable/scribblings/generics.scrbl
Normal file
138
collects/unstable/scribblings/generics.scrbl
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
#lang scribble/manual
|
||||
@(require "utils.ss" (for-label scheme/base unstable/generics))
|
||||
|
||||
@title{Generics}
|
||||
|
||||
@defmodule[unstable/generics]
|
||||
|
||||
@unstable["Eli Barzilay"
|
||||
@author+email["Jay McCarthy" "jay@plt-scheme.org"]]
|
||||
|
||||
@defform/subs[(define-generics (name prop:name name?)
|
||||
[method . kw-formals*]
|
||||
...)
|
||||
([kw-formals* (arg* ...)
|
||||
(arg* ...+ . rest-id)
|
||||
rest-id]
|
||||
[arg* id
|
||||
[id]
|
||||
(code:line keyword id)
|
||||
(code:line keyword [id])])
|
||||
#:contracts
|
||||
([name identifier?]
|
||||
[prop:name identifier?]
|
||||
[name? identifier?]
|
||||
[method identifier?])]{
|
||||
|
||||
Defines @scheme[name] as a transformer binding for the static information about a new generic group.
|
||||
|
||||
Defines @scheme[prop:name] as a structure
|
||||
type property. Structure types implementing this generic group should have this property where the value is a vector
|
||||
with one element per @scheme[method] where each value is
|
||||
either @scheme[#f] or a procedure with the same arity as specified by @scheme[kw-formals*].
|
||||
(@scheme[kw-formals*] is similar to the @scheme[kw-formals] used by @scheme[lambda], except no expression is given for optional arguments.)
|
||||
The arity of each method is checked by the guard on the structure type property.
|
||||
|
||||
Defines @scheme[name?] as a predicate identifying instances of structure types that implement this generic group.
|
||||
|
||||
Defines each @scheme[method] as a generic procedure that calls the corresponding method on values where @scheme[name?] is true. Each method must have a required by-position argument that is @scheme[free-identifier=?] to @scheme[name]. This argument is used in the generic definition to locate the specialization.
|
||||
|
||||
}
|
||||
|
||||
@defform[(generics name
|
||||
[method . kw-formals*]
|
||||
...)
|
||||
#:contracts
|
||||
([name identifier?]
|
||||
[method identifier?])]{
|
||||
|
||||
Expands to
|
||||
|
||||
@schemeblock[(define-generics (name _prop:name _name?)
|
||||
[method . kw-formals*]
|
||||
...)]
|
||||
|
||||
where @scheme[_prop:name] and @scheme[_name?] are created with the lexical
|
||||
context of @scheme[name].
|
||||
|
||||
}
|
||||
|
||||
@defform[(define-methods name definition ...)
|
||||
#:contracts
|
||||
([name identifier?])]{
|
||||
|
||||
@scheme[name] must be a transformer binding for the static information about a new generic group.
|
||||
|
||||
Expands to a value usable as the property value for the structure type property of the @scheme[name] generic group.
|
||||
|
||||
If the @scheme[definition]s define the methods of @scheme[name], then they are used in the property value.
|
||||
|
||||
If any method of @scheme[name] is not defined, then @scheme[#f] is used to signify that the structure type does not implement the particular method.
|
||||
|
||||
Allows @scheme[define/generic] to appear in @scheme[definition ...].
|
||||
|
||||
}
|
||||
|
||||
@defform[(define/generic local-name method-name)
|
||||
#:contracts
|
||||
([local-name identifier?]
|
||||
[method-name identifier?])]{
|
||||
|
||||
When used inside @scheme[define-methods], binds @scheme[local-name] to the generic for @scheme[method-name]. This is useful for method specializations to use the generic methods on other values.
|
||||
|
||||
Syntactically an error when used outside @scheme[define-methods].
|
||||
|
||||
}
|
||||
|
||||
@; Examples
|
||||
@(require scribble/eval)
|
||||
@(define (new-evaluator)
|
||||
(let* ([e (make-base-eval)])
|
||||
(e '(require (for-syntax scheme/base)
|
||||
unstable/generics))
|
||||
e))
|
||||
|
||||
@(define evaluator (new-evaluator))
|
||||
|
||||
@examples[#:eval evaluator
|
||||
(define-generics (printable prop:printable printable?)
|
||||
(gen-print printable [port])
|
||||
(gen-port-print port printable)
|
||||
(gen-print* printable [port] #:width width #:height [height]))
|
||||
|
||||
(define-struct num (v)
|
||||
#:property prop:printable
|
||||
(define-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
|
||||
(define-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")))))
|
||||
|
||||
(define x (make-num 10))
|
||||
(gen-print x)
|
||||
(gen-port-print (current-output-port) x)
|
||||
(gen-print* x #:width 100 #:height 90)
|
||||
|
||||
(define y (make-bool #t))
|
||||
(gen-print y)
|
||||
(gen-port-print (current-output-port) y)
|
||||
(gen-print* y #:width 100 #:height 90)
|
||||
]
|
||||
|
|
@ -92,6 +92,7 @@ Keep documentation and tests up to date.
|
|||
@include-section["match.scrbl"]
|
||||
@include-section["skip-list.scrbl"]
|
||||
@include-section["interval-map.scrbl"]
|
||||
@include-section["generics.scrbl"]
|
||||
|
||||
@;{--------}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user