From 340035bef7544d1bb868c98e5fb28a18a4214222 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 16 Feb 2009 02:51:12 +0000 Subject: [PATCH] Adding cstruct, which is like the struct signature form but with contracts. svn: r13647 --- collects/mzlib/scribblings/unit.scrbl | 20 +++- collects/mzlib/unit.ss | 87 +++++++++++++- collects/scheme/unit.ss | 123 +++++++++++++++++++- collects/scribblings/reference/units.scrbl | 14 +++ collects/tests/units/test-unit-contracts.ss | 14 +++ 5 files changed, 248 insertions(+), 10 deletions(-) diff --git a/collects/mzlib/scribblings/unit.scrbl b/collects/mzlib/scribblings/unit.scrbl index 26839c01f3..34e059c53d 100644 --- a/collects/mzlib/scribblings/unit.scrbl +++ b/collects/mzlib/scribblings/unit.scrbl @@ -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.} diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 95f2bced3a..ba3e245e44 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -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) diff --git a/collects/scheme/unit.ss b/collects/scheme/unit.ss index 8e56ce4ebf..525ff1750b 100644 --- a/collects/scheme/unit.ss +++ b/collects/scheme/unit.ss @@ -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" diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index 5ff110a198..a03e6da916 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -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} diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss index 70c866aab3..fd86391969 100644 --- a/collects/tests/units/test-unit-contracts.ss +++ b/collects/tests/units/test-unit-contracts.ss @@ -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))) \ No newline at end of file