From 2772ffccbae3a2fe070f512e0154c2fd5bb0c0e6 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 30 Jan 2010 21:14:27 +0000 Subject: [PATCH] Restored legacy functions for custom contracts. svn: r17900 --- collects/scheme/contract/base.ss | 5 + collects/scheme/contract/private/base.ss | 55 +++------ collects/scheme/contract/private/helpers.ss | 20 +--- collects/scheme/contract/private/legacy.ss | 126 ++++++++++++++++++++ collects/tests/mzscheme/contract-test.ss | 59 ++++++++- 5 files changed, 204 insertions(+), 61 deletions(-) create mode 100644 collects/scheme/contract/private/legacy.ss diff --git a/collects/scheme/contract/base.ss b/collects/scheme/contract/base.ss index 2608c0bc73..b6e83b931c 100644 --- a/collects/scheme/contract/base.ss +++ b/collects/scheme/contract/base.ss @@ -8,6 +8,7 @@ "private/misc.ss" "private/provide.ss" "private/guts.ss" + "private/legacy.ss" "private/ds.ss" "private/opt.ss") @@ -26,6 +27,10 @@ check-unary-between/c) (all-from-out "private/provide.ss") (all-from-out "private/base.ss") + (except-out (all-from-out "private/legacy.ss") + unpack-blame + unpack-source + unpack-name) (except-out (all-from-out "private/guts.ss") check-flat-contract check-flat-named-contract)) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index b1bf9dcdb8..bfba306647 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -18,7 +18,7 @@ improve method arity mismatch contract violation error messages? unstable/srcloc unstable/location "guts.ss" - "helpers.ss") + "legacy.ss") (define-syntax-parameter current-contract-region (λ (stx) #'(quote-module-path))) @@ -30,19 +30,20 @@ improve method arity mismatch contract violation error messages? (apply-contract c v pos neg name loc))] [(_ c v pos neg) (syntax/loc stx - (apply-contract c v pos neg #f (build-source-location #f)))] - [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) - #| + (apply-contract c + v + (unpack-blame pos) + (unpack-blame neg) + #f + (build-source-location #f)))] + [(_ c v pos neg src) (syntax/loc stx - (let* ([info src-info-e]) - (contract a-contract-e - to-check - pos-blame-e - neg-blame-e - (unpack-source info) - (unpack-name info)))) - |# - (raise-syntax-error 'contract "upgrade to new calling convention" stx)])) + (apply-contract c + v + (unpack-blame pos) + (unpack-blame neg) + (unpack-name src) + (unpack-source src)))])) (define (apply-contract c v pos neg name loc) (let* ([c (coerce-contract 'contract c)] @@ -92,34 +93,6 @@ improve method arity mismatch contract violation error messages? "all arguments: ~e") v-name v x args)]))))) -(define (unpack-source info) - (cond - [(syntax? info) (build-source-location info)] - [(list? info) - (let ([loc (list-ref info 0)]) - (if (syntax? (srcloc-source loc)) - (struct-copy - srcloc loc - [source - (resolved-module-path-name - (module-path-index-resolve - (syntax-source-module - (srcloc-source loc))))]) - loc))] - [else - (error 'contract - "expected a syntax object or list of two elements, got: ~e" - info)])) - -(define (unpack-name info) - (cond - [(syntax? info) (and (identifier? info) (syntax-e info))] - [(list? info) (list-ref info 1)] - [else - (error 'contract - "expected a syntax object or list of two elements, got: ~e" - info)])) - (define-syntax (recursive-contract stx) (syntax-case stx () [(_ arg) diff --git a/collects/scheme/contract/private/helpers.ss b/collects/scheme/contract/private/helpers.ss index a4c23e30dc..a1efe65e3b 100644 --- a/collects/scheme/contract/private/helpers.ss +++ b/collects/scheme/contract/private/helpers.ss @@ -1,7 +1,6 @@ #lang scheme/base -(provide unpack-blame - mangle-id mangle-id-for-maker +(provide mangle-id mangle-id-for-maker build-struct-names lookup-struct-info nums-up-to @@ -128,23 +127,6 @@ (string-append source ":" location) (or location source))))) -;; unpack-blame : any/c -> any/c -;; Constructs an S-expression for use in the blame error messages. -;; A variable reference represents a module or top-level context. -;; Other representations of blame are returned as-is. -(define (unpack-blame blame) - (if (variable-reference? blame) - (let ([rp (variable-reference->resolved-module-path blame)]) - (cond - [(not rp) - 'top-level] - [else - (let ([resolved (resolved-module-path-name rp)]) - (cond - [(symbol? resolved) `(quote ,resolved)] - [else `(file ,(path->string resolved))]))])) - blame)) - (define build-struct-names (lambda (name-stx fields omit-sel? omit-set? srcloc-stx) (let ([name (symbol->string (syntax-e name-stx))] diff --git a/collects/scheme/contract/private/legacy.ss b/collects/scheme/contract/private/legacy.ss new file mode 100644 index 0000000000..95a00f11cf --- /dev/null +++ b/collects/scheme/contract/private/legacy.ss @@ -0,0 +1,126 @@ +#lang scheme/base + +(require "guts.ss" "blame.ss" unstable/srcloc) + +(provide make-proj-contract + raise-contract-error + contract-proc + + proj-prop proj-get proj-pred? + name-prop name-get name-pred? + stronger-prop stronger-get stronger-pred? + first-order-prop first-order-get first-order-pred? + flat-prop flat-get flat-pred? + + unpack-blame unpack-source unpack-name + + ) + +(define (raise-contract-error x src pos name fmt . args) + (apply raise-blame-error + (make-blame (unpack-source src) + (unpack-name src) + name + (unpack-blame pos) + "<>" + #f) + x + fmt + args)) + +(define (make-proj-contract name proj test) + (simple-contract + #:name name + #:first-order test + #:projection + (lambda (blame) + (proj (blame-guilty blame) + (blame-innocent blame) + (list (blame-source blame) (blame-value blame)) + (blame-contract blame) + (not (blame-swapped? blame)))))) + +(define (contract-proc c) + (let* ([proj (contract-projection c)]) + (lambda (pos neg src name original?) + (proj (make-blame (unpack-source src) + (unpack-name src) + name + (unpack-blame (if original? pos neg)) + (unpack-blame (if original? neg pos)) + (not original?)))))) + +(define (legacy-property name) + (define-values [ prop pred get ] + (make-struct-type-property + name + (lambda (impl info) + (error + name + (string-append + "this property is a legacy implementation; " + "use prop:contract or prop:flat-contract instead."))))) + prop) + +(define proj-prop (legacy-property 'proj-prop)) +(define name-prop (legacy-property 'name-prop)) +(define stronger-prop (legacy-property 'stronger-prop)) +(define first-order-prop (legacy-property 'first-order-prop)) +(define flat-prop (legacy-property 'flat-prop)) + +(define proj-pred? contract-struct?) +(define name-pred? contract-struct?) +(define stronger-pred? contract-struct?) +(define first-order-pred? contract-struct?) +(define flat-pred? contract-struct?) + +(define (proj-get c) contract-proc) +(define (name-get c) contract-name) +(define (stronger-get c) contract-stronger?) +(define (first-order-get c) contract-first-order) +(define (flat-get c) flat-contract-predicate) + +;; unpack-blame : any/c -> any/c +;; Constructs an S-expression for use in the blame error messages. +;; A variable reference represents a module or top-level context. +;; Other representations of blame are returned as-is. +(define (unpack-blame blame) + (if (variable-reference? blame) + (let ([rp (variable-reference->resolved-module-path blame)]) + (cond + [(not rp) + 'top-level] + [else + (let ([resolved (resolved-module-path-name rp)]) + (cond + [(symbol? resolved) `(quote ,resolved)] + [else `(file ,(path->string resolved))]))])) + blame)) + +(define (unpack-source info) + (cond + [(syntax? info) (build-source-location info)] + [(list? info) + (let ([loc (list-ref info 0)]) + (if (syntax? (srcloc-source loc)) + (struct-copy + srcloc loc + [source + (resolved-module-path-name + (module-path-index-resolve + (syntax-source-module + (srcloc-source loc))))]) + loc))] + [else + (error 'contract + "expected a syntax object or list of two elements, got: ~e" + info)])) + +(define (unpack-name info) + (cond + [(syntax? info) (and (identifier? info) (syntax-e info))] + [(list? info) (list-ref info 1)] + [else + (error 'contract + "expected a syntax object or list of two elements, got: ~e" + info)])) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 41023d5ed0..ed53e149bd 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -7160,7 +7160,64 @@ so that propagation occurs. 'pos (compose blame-guilty exn:fail:contract:blame-object) (with-handlers ((void values)) (contract not #t 'pos 'neg)))) - + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;; + ;;;; + ;;;; Legacy Contract Constructor tests + ;;;; + ;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; make-proj-contract + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (contract-eval + '(define proj:add1->sub1 + (make-proj-contract + 'proj:add1->sub1 + (lambda (pos neg src name blame) + (lambda (f) + (unless (and (procedure? f) (procedure-arity-includes? f 1)) + (raise-contract-error f src pos name + "expected a unary function, got: ~e" + f)) + (lambda (x) + (unless (and (integer? x) (exact? x)) + (raise-contract-error x src neg name + "expected an integer, got: ~e" + x)) + (let* ([y (f (add1 x))]) + (unless (and (integer? y) (exact? y)) + (raise-contract-error y src pos name + "expected an integer, got: ~e" + y)) + (sub1 y))))) + (lambda (f) + (and (procedure? f) (procedure-arity-includes? f 1)))))) + + (test/spec-passed/result + 'make-proj-contract-1 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) + 3) + + (test/pos-blame + 'make-proj-contract-2 + '(contract proj:add1->sub1 'dummy 'pos 'neg)) + + (test/pos-blame + 'make-proj-contract-3 + '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) + + (test/neg-blame + 'make-proj-contract-4 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy)) + (report-errs) ))