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

Adding cstruct, which is like the struct signature form but with contracts.

Browse Source 
svn: r13647
This commit is contained in:
Stevie Strickland 2009-02-16 02:51:12 +00:00
parent eba3b5d54d
commit 340035bef7
5 changed files with 248 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/mzlib/scribblings/unit.scrbl
View File

@ -7,13 +7,18 @@
(begin
(require (for-label scheme/unit))
(define id (scheme struct))))
(bind scheme-struct))
(bind scheme-struct)
(define-syntax-rule (bindc id)
(begin
(require (for-label scheme/unit))
(define id (scheme cstruct))))
(bindc scheme-cstruct))
@mzlib[#:mode title unit]
The @schememodname[mzlib/unit] library mostly re-provides
@schememodname[scheme/unit], except for @scheme-struct from
@schememodname[scheme/unit].
@schememodname[scheme/unit], except for @scheme-struct and
@scheme-cstruct from @schememodname[scheme/unit].
@defform/subs[(struct id (field-id ...) omit-decl ...)
([omit-decl -type
@ -23,3 +28,12 @@ The @schememodname[mzlib/unit] library mostly re-provides
A signature form like @scheme-struct from @schememodname[scheme/unit],
but with a different syntax for the options that limit exports.}
@defform/subs[(cstruct id ([field-id contract-expr] ...) omit-decl ...)
([omit-decl -type
-selectors
-setters
-constructor])]{
A signature form like @scheme-cstruct from @schememodname[scheme/unit],
but with a different syntax for the options that limit exports.}

87
collects/mzlib/unit.ss
View File

@ -1,5 +1,6 @@
(module unit mzscheme
(require-for-syntax mzlib/list
scheme/pretty
stxclass
syntax/boundmap
syntax/context
@ -19,7 +20,7 @@
"private/unit-runtime.ss"
"private/unit-utils.ss")
(provide define-signature-form struct open
(provide define-signature-form struct cstruct open
define-signature provide-signature-elements
only except rename import export prefix link tag init-depend extends contracted
unit?
@ -124,6 +125,90 @@
(raise-stx-err "missing fields"))
((_)
(raise-stx-err "missing name and fields")))))
(define-signature-form (cstruct stx)
(parameterize ((error-syntax stx))
(syntax-case stx ()
((_ name ([field ctc] ...) . omissions)
(let ([omit-selectors #f]
[omit-setters #f]
[omit-constructor #f]
[omit-type #f])
(define (remove-ctor&type-info l)
(define new-type
(if omit-type
#f
(cadr l)))
(define new-ctor
(if omit-constructor
#f
(caddr l)))
(cons (car l)
(cons new-type
(cons new-ctor
(cdddr l)))))
(define (add-contracts l)
(let* ([pred (caddr l)]
[ctor-ctc #`(-> ctc ... #,pred)]
[pred-ctc #`(-> any/c boolean?)]
[field-ctcs (apply append
(map (λ (c)
(append (if omit-selectors
null
(list #`(-> #,pred #,c)))
(if omit-setters
null
(list #`(-> #,pred #,c void?)))))
(syntax->list #'(ctc ...))))])
(list* (car l)
(list (cadr l) ctor-ctc)
(list pred pred-ctc)
(map list (cdddr l) field-ctcs))))
(check-id #'name)
(for-each check-id (syntax->list #'(field ...)))
(for-each
(lambda (omission)
(cond
((and (identifier? omission)
(module-identifier=? omission #'-selectors))
(set! omit-selectors #t))
((and (identifier? omission)
(module-identifier=? omission #'-setters))
(set! omit-setters #t))
((and (identifier? omission)
(module-identifier=? omission #'-constructor))
(set! omit-constructor #t))
((and (identifier? omission)
(module-identifier=? omission #'-type))
(set! omit-type #t))
(else
(raise-stx-err
"expected \"-selectors\" or \"-setters\" or \"-constructor\" or \"-type\""
omission))))
(checked-syntax->list #'omissions))
(cons
#`(define-syntaxes (name)
#,(remove-ctor&type-info
(build-struct-expand-info
#'name (syntax->list #'(field ...))
omit-selectors omit-setters
#f '(#f) '(#f))))
(let* ([res (add-contracts
(build-struct-names #'name (syntax->list #'(field ...))
omit-selectors omit-setters #f))]
[cpairs (cons 'contracted (if omit-constructor (cddr res) (cdr res)))])
(if omit-type
(list cpairs)
(list (car res) cpairs))))))
((_ name (x . y) . omissions)
;; Will fail
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx)))))
((_ name fields . omissions)
(raise-stx-err "expected syntax matching (identifier ...)" #'fields))
((_ name)
(raise-stx-err "missing fields"))
((_)
(raise-stx-err "missing name and fields")))))
;; build-val+macro-defs : sig -> (list syntax-object^3)

123
collects/scheme/unit.ss
View File

@ -1,20 +1,19 @@
(module unit scheme/base
(require mzlib/unit
scheme/contract
(for-syntax scheme/base
syntax/struct))
(provide (except-out (all-from-out mzlib/unit)
struct)
(rename-out [struct* struct]))
struct cstruct)
(rename-out [struct* struct]
[cstruct* cstruct]))
;; Replacement `struct' signature form:
(define-signature-form (struct* stx)
(syntax-case stx ()
((_ name (field ...) opt ...)
(let ([omit-selectors #f]
[omit-setters #f]
[omit-constructor #f]
[omit-type #f])
(begin
(unless (identifier? #'name)
(raise-syntax-error #f
"expected an identifier to name the structure type"
@ -98,6 +97,118 @@
(raise-syntax-error #f
"bad syntax; missing fields"
stx))
((_)
(raise-syntax-error #f
"missing name and fields"
stx))))
;; Replacement cstruct form
(define-signature-form (cstruct* stx)
(syntax-case stx ()
((_ name ([field ctc] ...) opt ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f
"expected an identifier to name the structure type"
stx
#'name))
(for-each (lambda (field)
(unless (identifier? field)
(syntax-case field ()
[(id #:mutable)
(identifier? #'id)
'ok]
[_
(raise-syntax-error #f
"bad field specification"
stx
field)])))
(syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt?)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
stx
opt)]))))])
(define (add-contracts l)
(let* ([pred (caddr l)]
[ctor-ctc #`(-> ctc ... #,pred)]
[pred-ctc #'(-> any/c boolean?)]
[field-ctcs
(apply append
(map (λ (f c)
(cons #`(-> #,pred #,c)
(if (and (not mutable?)
(not (pair? (syntax-e f))))
null
#`(-> #,pred #,c void?))))
(syntax->list #'(field ...))
(syntax->list #'(ctc ...))))])
(list* (car l)
(list (cadr l) ctor-ctc)
(list pred pred-ctc)
(map list (cdddr l) field-ctcs))))
(cons
#`(define-syntaxes (name)
#,(build-struct-expand-info
#'name (syntax->list #'(field ...))
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?))
(let* ([names (add-contracts
(build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?)))]
[cpairs (cons 'contracted
(if no-ctr? (cddr names) (cdr names)))])
(list (car names) cpairs))))))
((_ name fields opt ...)
(raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields"
stx
#'fields))
((_ name)
(raise-syntax-error #f
"bad syntax; missing fields"
stx))
((_)
(raise-syntax-error #f
"missing name and fields"

14
collects/scribblings/reference/units.scrbl
View File

@ -614,6 +614,20 @@ would be bound by @scheme[(define-struct id (field ...) option ...)],
where the extra option @scheme[#:omit-constructor] omits the
@schemeidfont{make-}@scheme[id] identifier.}
@defform/subs[
(cstruct id ([field contract-expr] ...) option ...)
([field id
[id #:mutable]]
[option #:mutable
#:omit-constructor
#:omit-define-syntaxes
#:omit-define-values])]{
For use with @scheme[define-signature]. The @scheme[cstruct] form works
similarly to @scheme[struct], but the constructor, predicate, field
accessors, and field mutators are contracted appropriately.}
@; ------------------------------------------------------------------------
@section{Unit Utilities}

14
collects/tests/units/test-unit-contracts.ss
View File

@ -793,3 +793,17 @@
;; the stronger contract?
(test-runtime-error exn:fail:contract? "top-level broke the contract on x"
(f #t)))
(let ()
(define-signature student^
((cstruct student ([name string?] [id number?]))))
(define-unit student@
(import)
(export student^)
(define-struct student (name id)))
(define-values/invoke-unit/infer student@)
(make-student "foo" 3)
(test-runtime-error exn:fail:contract? "top-level broke contract on make-student"
(make-student 4 3))
(test-runtime-error exn:fail:contract? "top-level broke contract on student-id"
(student-id 'a)))