From 05185dcdde6607430ca03631390963f3b3e54380 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Sep 2014 20:19:29 -0500 Subject: [PATCH] improve stronger for flat-named-contract by making the equal, eq, and regexp contracts all have an extra field to hold the name. This mostly has the advantage that flat-named-contract has to turn a flat contract into it's predicate a bit less often --- .../scribblings/reference/contracts.scrbl | 19 +++-- .../tests/racket/contract/stronger.rkt | 12 ++++ .../collects/racket/contract/private/guts.rkt | 70 ++++++++++++------- .../collects/racket/contract/private/misc.rkt | 19 +++-- 4 files changed, 74 insertions(+), 46 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl index 66a9a30d98..97026c3618 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -116,21 +116,18 @@ implement contracts~@cite{Strickland12}. @section[#:tag "data-structure-contracts"]{Data-structure Contracts} @declare-exporting-ctc[racket/contract/base] -@defproc[(flat-named-contract [type-name any/c] - [predicate flat-contract?] +@defproc[(flat-named-contract [name any/c] + [flat-contract flat-contract?] [generator (or/c #f (-> contract (-> int? any))) #f]) flat-contract?]{ +Produces a contract like @racket[flat-contract], but with the name @racket[name]. -On predicates, behaves like @racket[flat-contract], but the first argument must be the -(quoted) name of a contract used for error reporting. For example, -@racketblock[(flat-named-contract - 'odd-integer - (lambda (x) (and (integer? x) (odd? x))))] -turns the predicate into a contract with the name @tt{odd-integer}. - -On flat contracts, the new flat contract is the same as the old except for -the name. +@racketblock[(define/contract i + (flat-named-contract + 'odd-integer + (lambda (x) (and (integer? x) (odd? x)))) + 2)] The generator argument adds a generator for the flat-named-contract. See @racket[contract-generate] for more information. diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt index 235ef6f65c..d3c396d9d5 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -150,6 +150,18 @@ (ctest #t contract-stronger? 'x symbol?) (ctest #f contract-stronger? symbol? 'x) + (ctest #t contract-stronger? + (flat-named-contract 'name1 #f) + (flat-named-contract 'name2 #f)) + (ctest #t contract-stronger? + (flat-named-contract 'name1 (flat-named-contract 'name2 #f)) + (flat-named-contract 'name3 (flat-named-contract 'name4 #f))) + (ctest #t contract-stronger? (flat-named-contract 'name1 1) (flat-named-contract 'name2 1)) + (ctest #t contract-stronger? (flat-named-contract 'name1 "x") (flat-named-contract 'name2 "x")) + (ctest #t contract-stronger? + (flat-named-contract 'name2 (regexp "x")) + (flat-named-contract 'name2 (regexp "x"))) + (contract-eval `(let ([c (class/c (m (-> any/c integer?)))]) (,test #t contract-stronger? (instanceof/c c) (instanceof/c c)))) diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index c5484714d4..0fa1e9f08d 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -205,19 +205,44 @@ ;; coerce-contract/f : any -> (or/c #f contract?) ;; returns #f if the argument could not be coerced to a contract -(define (coerce-contract/f x) +(define-values (name-default name-default?) + (let () + (struct name-default ()) + (values (name-default) name-default?))) +(define (coerce-contract/f x [name name-default]) + (define (coerce-simple-value x) + (cond + [(contract-struct? x) #f] ;; this has to come first, since some of these are procedure?. + [(and (procedure? x) (procedure-arity-includes? x 1)) + (make-predicate-contract (if (name-default? name) + (or (object-name x) '???) + name) + x + #f + (memq x the-known-good-contracts))] + [(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) + (make-eq-contract x + (if (name-default? name) + (if (or (null? x) + (symbol? x)) + `',x + x) + name))] + [(or (bytes? x) (string? x)) + (make-equal-contract x (if (name-default? name) x name))] + [(number? x) + (make-=-contract x (if (name-default? name) x name))] + [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x (if (name-default? name) x name))] + [else #f])) (cond - [(contract-struct? x) x] - [(and (procedure? x) (procedure-arity-includes? x 1)) - (make-predicate-contract (or (object-name x) '???) - x - #f - (memq x the-known-good-contracts))] - [(null? x) (make-eq-contract x)] - [(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) (make-eq-contract x)] - [(or (bytes? x) (string? x)) (make-equal-contract x)] - [(number? x) (make-=-contract x)] - [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)] + [(coerce-simple-value x) => values] + [(name-default? name) (and (contract-struct? x) x)] + [(predicate-contract? x) + (struct-copy predicate-contract x [name name])] + [(eq-contract? x) (make-eq-contract (eq-contract-val x) name)] + [(equal-contract? x) (make-eq-contract (equal-contract-val x) name)] + [(=-contract? x) (make-=-contract (=-contract-val x) name)] + [(regexp/c? x) (make-regexp/c (regexp/c-reg x) name)] [else #f])) (define the-known-good-contracts @@ -341,17 +366,12 @@ ; ; -(define-struct eq-contract (val) +(define-struct eq-contract (val name) #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property #:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x))) - #:name - (λ (ctc) - (if (or (null? (eq-contract-val ctc)) - (symbol? (eq-contract-val ctc))) - `',(eq-contract-val ctc) - (eq-contract-val ctc))) + #:name (λ (ctc) (eq-contract-name ctc)) #:generate (λ (ctc) (define v (eq-contract-val ctc)) @@ -366,12 +386,12 @@ ((predicate-contract-pred that) this-val)))) #:list-contract? (λ (c) (null? (eq-contract-val c))))) -(define-struct equal-contract (val) +(define-struct equal-contract (val name) #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property #:first-order (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x))) - #:name (λ (ctc) (equal-contract-val ctc)) + #:name (λ (ctc) (equal-contract-name ctc)) #:stronger (λ (this that) (define this-val (equal-contract-val this)) @@ -385,12 +405,12 @@ (define v (equal-contract-val ctc)) (λ (fuel) (λ () v))))) -(define-struct =-contract (val) +(define-struct =-contract (val name) #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property #:first-order (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x)))) - #:name (λ (ctc) (=-contract-val ctc)) + #:name (λ (ctc) (=-contract-name ctc)) #:stronger (λ (this that) (define this-val (=-contract-val this)) @@ -404,7 +424,7 @@ (define v (=-contract-val ctc)) (λ (fuel) (λ () v))))) -(define-struct regexp/c (reg) +(define-struct regexp/c (reg name) #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property @@ -417,7 +437,7 @@ #:name (λ (ctc) (regexp/c-reg ctc)) #:stronger (λ (this that) - (and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that)))))) + (and (regexp/c? that) (equal? (regexp/c-reg this) (regexp/c-reg that)))))) ;; sane? : boolean -- indicates if we know that the predicate is well behaved diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 3b7ca1ba9b..2bda342831 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -1514,19 +1514,18 @@ (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) -(define (flat-named-contract name predicate [generate #f]) +(define (flat-named-contract name pre-contract [generate #f]) (cond - [(and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (make-predicate-contract name predicate generate #f)] - [(flat-contract? predicate) - (make-predicate-contract name (flat-contract-predicate predicate) generate #f)] + [(and (not generate) + (coerce-contract/f pre-contract name)) + => + values] + [(flat-contract? pre-contract) + (make-predicate-contract name (flat-contract-predicate pre-contract) generate #f)] [else (raise-argument-error 'flat-named-contract - (format "~s" `(or/c flat-contract? - (and/c procedure? - (λ (x) (procedure-arity-include? x 1))))) - predicate)])) + "flat-contract?" + pre-contract)])) (define printable/c (flat-named-contract