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["match.scrbl"]
|
||||||
@include-section["skip-list.scrbl"]
|
@include-section["skip-list.scrbl"]
|
||||||
@include-section["interval-map.scrbl"]
|
@include-section["interval-map.scrbl"]
|
||||||
|
@include-section["generics.scrbl"]
|
||||||
|
|
||||||
@;{--------}
|
@;{--------}
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user