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

add make-struct-type-property/generic and make-generic-struct-type-property (#3627)

Browse Source
This commit is contained in:
Alex Knauth 2021-03-25 19:44:40 -04:00 committed by GitHub
parent ca7404f2e3
commit 5c2949d051
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
4 changed files with 225 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
pkgs/racket-doc/scribblings/reference/generic.scrbl
View File

@ -299,4 +299,56 @@ a @tech{chaperone} of @racket[val-expr] otherwise.
}
@defform[(make-struct-type-property/generic
name-expr
maybe-guard-expr
maybe-supers-expr
maybe-can-impersonate?-expr
property-option
...)
#:grammar
([maybe-guard-expr (code:line) guard-expr]
[maybe-supers-expr (code:line) supers-expr]
[maybe-can-impersonate?-expr (code:line) can-impersonate?-expr]
[property-option (code:line #:property prop-expr val-expr)
(code:line #:methods gen:name-id method-defs)]
[method-defs (definition ...)])
#:contracts
([name-expr symbol?]
[guard-expr (or/c procedure? #f 'can-impersonate)]
[supers-expr (listof (cons/c struct-type-property? (-> any/c any/c)))]
[can-impersonate?-expr any/c]
[prop-expr struct-type-property?]
[val-expr any/c])]{
Creates a new structure type property and returns three
values, just like @racket[make-struct-type-property] would:
@itemize[
@item{a @tech{structure type property descriptor}}
@item{a @tech{property predicate} procedure}
@item{a @tech{property accessor} procedure}
]
Any struct that implements this property will also implement
the properties and @tech{generic interfaces} given in the
@racket[#:property] and @racket[#:methods] declarations.
The property @racket[val-expr]s and @racket[method-def]s are
evaluated eagerly when the property is created, not when
it is attached to a structure type.
}
@defform[(make-generic-struct-type-property
gen:name-id
method-def
...)]{
Creates a new structure type property and returns the
@tech{structure type property descriptor}.
Any struct that implements this property will also implement
the @tech{generic interface} given by @racket[gen:name-id]
with the given @racket[method-def]s. The @racket[method-def]s
are evaluated eagerly when the property is created, not when
it is attached to a structure type.
}
@close-eval[evaluator]

38
pkgs/racket-test/tests/generic/struct-type-property.rkt Normal file
View File

@ -0,0 +1,38 @@
#lang racket/base
(require racket/generic racket/match racket/dict rackunit)
(test-case "silly-dict"
(define prop:silly-dict
(make-generic-struct-type-property
gen:dict
(define (dict-ref self k [default #f])
'i-am-a-dict)))
(struct example ()
#:transparent
#:property prop:silly-dict #f)
(check-equal? (dict-ref (example) 42) 'i-am-a-dict))
(test-case "container-repr"
(define-generics repr (->sexpr repr)
#:defaults
([number? (define (->sexpr n) n)]
[symbol? (define (->sexpr s) `',s)]))
(define-values [prop:container container? container-ref]
(make-struct-type-property/generic
'container
#:methods gen:repr
[(define/generic gen->sexpr ->sexpr)
(define (->sexpr self)
(match ((container-ref self) self)
[(cons constructor contents)
(cons constructor (map gen->sexpr contents))]))]))
(struct foo (a b c)
#:property prop:container
(lambda (self)
(list 'foo (foo-a self) (foo-b self) (foo-c self))))
(check-equal? (->sexpr (foo 1 2 3)) '(foo 1 2 3))
(check-equal? (->sexpr (foo 'a 'b 'c)) '(foo 'a 'b 'c))
(check-equal? (->sexpr (foo 'a 1 (foo 'b 2 'empty)))
'(foo 'a 1 (foo 'b 2 'empty))))

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

@ -3,6 +3,7 @@
racket/contract/combinator
"private/generic.rkt"
"private/generic-methods.rkt"
"private/struct-type-property.rkt"
(for-syntax racket/base racket/syntax syntax/stx))
;; Convenience layer on top of racket/private/generic.
@ -19,7 +20,9 @@
chaperone-generics
impersonate-generics
redirect-generics
generic-instance/c)
generic-instance/c
make-struct-type-property/generic
make-generic-struct-type-property)
(begin-for-syntax

131
racket/collects/racket/private/struct-type-property.rkt Normal file
View File

@ -0,0 +1,131 @@
#lang racket/base
(provide make-struct-type-property/generic
make-generic-struct-type-property)
(require racket/function
"generic-methods.rkt"
(for-syntax racket/base
syntax/stx))
(begin-for-syntax
;; stx-expr? : Stx -> Bool
(define (stx-expr? v)
(not (keyword? (if (syntax? v) (syntax-e v) v))))
;; super-pairs : Stx Stx [Listof Stx] -> [Listof Stx]
(define (option-super-pairs ctx stx acc)
(cond
[(stx-null? stx) (reverse acc)]
[(stx-pair? stx)
(define kw (stx-car stx))
(define kwe (syntax-e kw))
(cond
[(eq? kwe '#:property)
(define r1 (stx-cdr stx))
(unless (stx-pair? r1)
(raise-syntax-error #f
"expected prop-expr and val-expr after #:property"
ctx
r1
(list kw)))
(define p (stx-car r1))
(unless (stx-expr? p)
(raise-syntax-error #f
"expected prop-expr and val-expr after #:property"
ctx
p))
(define r2 (stx-cdr r1))
(unless (stx-pair? r2)
(raise-syntax-error #f
"expected val-expr after #:property prop-expr"
ctx
r2
(list kw)))
(define v (stx-car r2))
(unless (stx-expr? v)
(raise-syntax-error #f
"expected val-expr after #:property prop-expr"
ctx
v))
(option-super-pairs ctx (stx-cdr r2) (cons #`(cons #,p (const #,v)) acc))]
[(eq? kwe '#:methods)
(define r1 (stx-cdr stx))
(unless (stx-pair? r1)
(raise-syntax-error #f
"expected gen:name-id and method-defs after #:methods"
ctx
r1
(list kw)))
(define g (stx-car r1))
(unless (identifier? g)
(raise-syntax-error #f
"expected gen:name-id and method-defs after #:methods"
ctx
g))
(define r2 (stx-cdr r1))
(unless (stx-pair? r2)
(raise-syntax-error #f
"expected method-defs after #:methods gen:name-id"
ctx
r2
(list kw)))
(define m (stx-car r2))
(unless (syntax->list m)
(raise-syntax-error #f
"expected method-defs after #:methods gen:name-id"
ctx
m))
(option-super-pairs ctx (stx-cdr r2)
(cons #`(cons (generic-property #,g)
(const (generic-method-table #,g #,@m)))
acc))]
[else
(raise-syntax-error #f
"expected one of these literals: #:property or #:methods"
ctx
kw)])]
[else
(raise-syntax-error #f "bad syntax" ctx stx)])))
(define-syntax make-struct-type-property/generic
(lambda (stx)
(unless (stx-pair? stx) (raise-syntax-error #f "bad syntax" stx))
(define r1 (stx-cdr stx))
(unless (stx-pair? r1) (raise-syntax-error #f "expected name-expr" stx r1))
(define name (stx-car r1))
(unless (stx-expr? name) (raise-syntax-error #f "expected name-expr" stx name))
(define r2 (stx-cdr r1))
(define-values [guard r3]
(if (and (stx-pair? r2) (stx-expr? (stx-car r2)))
(values (stx-car r2) (stx-cdr r2))
(values #'#f r2)))
(define-values [supers r4]
(if (and (stx-pair? r3) (stx-expr? (stx-car r3)))
(values (stx-car r3) (stx-cdr r3))
(values #''() r3)))
(define-values [can-impersonate? r5]
(if (and (stx-pair? r4) (stx-expr? (stx-car r4)))
(values (stx-car r4) (stx-cdr r4))
(values #'#f r4)))
(syntax-protect
#`(make-struct-type-property #,name
#,guard
(list* #,@(option-super-pairs stx r5 '()) #,supers)
#,can-impersonate?))))
(define-syntax make-generic-struct-type-property
(lambda (stx)
(unless (stx-pair? stx) (raise-syntax-error #f "bad syntax" stx))
(define r1 (stx-cdr stx))
(unless (stx-pair? r1) (raise-syntax-error #f "expected gen:name-id" stx r1))
(define g (stx-car r1))
(unless (identifier? g) (raise-syntax-error #f "expected gen:name-id" stx g))
(define m (stx-cdr r1))
(unless (stx->list m)
(raise-syntax-error #f "expected method-defs after gen:name-id" stx m))
(syntax-protect
#`(let-values [((prop _pred _ref)
(make-struct-type-property/generic '#,g #:methods #,g #,m))]
prop))))