From be7fe82ea82c8b33d03da489e3bd295592ecb92a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 15 May 2018 15:20:09 -0500 Subject: [PATCH] adjust implementation of recursive contract to cope with the fact that blame object equality now works right and adding context to a blame object doesn't produce an equal? blame object also it appears that blame-add-unknown-context is not actually being called so lets just get rid of that functionality (but preserve reasonable backwards compatibility in case someone is actually calling that function or supplying #f to blame-add-context) And the interning of blame objects was not intended to be in 0b3f4b627e, so get rid of it here closes racket/typed-racket#722 --- .../scribblings/reference/contracts.scrbl | 14 +-- .../racket/contract/recursive-contract.rkt | 9 ++ .../collects/racket/contract/private/base.rkt | 75 +++++++---- .../racket/contract/private/blame.rkt | 116 ++++++++---------- .../collects/racket/contract/private/prop.rkt | 6 - 5 files changed, 117 insertions(+), 103 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 8dc1c68b0c..5f828073f1 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -2526,13 +2526,13 @@ The @racket[swap?] argument has the effect of calling @racket[blame-swap] while adding the layer of context, but without creating an extra @|blame-object|. -The context information recorded in blame structs keeps track of -combinators that do not add information, and add the string @racket["..."] -for them, so programmers at least see that there was some context -they are missing in the error messages. Accordingly, since there are -combinators that should not add any context (e.g., @racket[recursive-contract]), -passing @racket[#f] as the context string argument avoids adding the -@racket["..."] string. + +Passing @racket[#f] as the context string argument is no longer relevant. +For backwards compatibility, @racket[blame-add-context] returns @racket[b] +when @racket[context] is @racket[#f]. + +@history[#:changed "6.90.0.29" @elem{The @racket[context] argument being + @racket[#f] is no longer relevant.}] } @defproc[(blame-context [blame blame?]) (listof string?)]{ diff --git a/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt b/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt index 92d658824d..7b71cd2a63 100644 --- a/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt +++ b/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt @@ -85,6 +85,15 @@ '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat #:extra-delay)))]) (contract ctc (cons 1 (cons 2 'not-a-number)) 'pos 'neg))) + (test/spec-passed/result + 'recursive-contract14 + '(let () + (define c (recursive-contract (or/c integer? (cons/c c integer?)))) + (void (contract (-> c any/c) void 'p 'n)) + ((contract (-> c any/c) values 'p 'n) '(1 . 2))) + '(1 . 2)) + + (test/spec-passed/result 'memoize-applied-blame '(let () diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt index 964dbb898e..dacaf009bb 100644 --- a/racket/collects/racket/contract/private/base.rkt +++ b/racket/collects/racket/contract/private/base.rkt @@ -170,6 +170,7 @@ #`(#,maker '#,stx (λ () #,arg) '#,(syntax-local-infer-name stx) + 'recursive-contract-val->lnp-not-yet-initialized #,(if list-contract? #'#t #'#f) #,@(if (equal? (syntax-e type) '#:flat) (list (if extra-delay? #'#t #'#f)) @@ -207,6 +208,7 @@ (unless (list-contract? forced-ctc) (raise-argument-error 'recursive-contract "list-contract?" forced-ctc))) (set-recursive-contract-ctc! ctc forced-ctc) + (set-recursive-contract-blame->val-np->val! ctc (make-blame->val-np->val ctc)) (when (and (pair? old-name) (pair? (cdr old-name))) ;; this guard will be #f when we are forcing this contract ;; in a nested which (which can make the `cddr` below fail) @@ -217,33 +219,48 @@ forced-ctc] [else current])) +(define (make-blame->val-np->val ctc) + (define list-check? (recursive-contract-list-contract? ctc)) + (define blame-accepting-func-cell (make-thread-cell #f)) + (define (do-list-check val neg-party blame-known) + (when list-check? + (unless (list? val) + (raise-blame-error blame-known #:missing-party neg-party + val + '(expected: "list?" given: "~e") + val)))) + (λ (blame) + (cond + [(thread-cell-ref blame-accepting-func-cell) + => + (λ (blame-accepting-func) (blame-accepting-func blame))] + [else + (define r-ctc (force-recursive-contract ctc)) + (define f (get/build-late-neg-projection r-ctc)) + (define val-neg-party-acceptor (make-thread-cell #f)) + (λ (val neg-party) + (cond + [(thread-cell-ref val-neg-party-acceptor) + => + (λ (f) (f val neg-party))] + [else + (thread-cell-set! blame-accepting-func-cell + (λ (blame) + (λ (val neg-party) + ((thread-cell-ref val-neg-party-acceptor) val neg-party)))) + (do-list-check val neg-party blame) + (define f-of-blame 'f-of-blame-not-yet-set) + (thread-cell-set! val-neg-party-acceptor + (λ (val neg-party) + (do-list-check val neg-party blame) + (f-of-blame val neg-party))) + (set! f-of-blame (f blame)) + (f-of-blame val neg-party)]))]))) + (define (recursive-contract-late-neg-projection ctc) - (cond - [(recursive-contract-list-contract? ctc) - (λ (blame) - (define r-ctc (force-recursive-contract ctc)) - (define f (get/build-late-neg-projection r-ctc)) - (define blame-known (blame-add-context blame #f)) - (define f-blame-known (make-thread-cell #f)) - (λ (val neg-party) - (unless (list? val) - (raise-blame-error blame-known #:missing-party neg-party - val - '(expected: "list?" given: "~e") - val)) - (unless (thread-cell-ref f-blame-known) - (thread-cell-set! f-blame-known (f blame-known))) - ((thread-cell-ref f-blame-known) val neg-party)))] - [else - (λ (blame) - (define r-ctc (force-recursive-contract ctc)) - (define f (get/build-late-neg-projection r-ctc)) - (define blame-known (blame-add-context blame #f)) - (define f-blame-known (make-thread-cell #f)) - (λ (val neg-party) - (unless (thread-cell-ref f-blame-known) - (thread-cell-set! f-blame-known (f blame-known))) - ((thread-cell-ref f-blame-known) val neg-party)))])) + (λ (blame) + (force-recursive-contract ctc) + ((recursive-contract-blame->val-np->val ctc) blame))) (define (flat-recursive-contract-late-neg-projection ctc) (cond @@ -287,7 +304,11 @@ (force-recursive-contract ctc) (contract-random-generate/choose (recursive-contract-ctc ctc) (- fuel 1))]))) -(struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] list-contract?) +(struct recursive-contract ([name #:mutable] + thunk + [ctc #:mutable] + [blame->val-np->val #:mutable] + list-contract?) #:property prop:recursive-contract (λ (this) (force-recursive-contract this) (recursive-contract-ctc this))) diff --git a/racket/collects/racket/contract/private/blame.rkt b/racket/collects/racket/contract/private/blame.rkt index fdc340d448..67df9eb1ad 100644 --- a/racket/collects/racket/contract/private/blame.rkt +++ b/racket/collects/racket/contract/private/blame.rkt @@ -39,32 +39,37 @@ (define (combine-them x y) (bitwise-xor x (* 3 y))) -(define (blame-hash b hash/recur) +(define (blame-hash/combine b hash/recur combine-them) (combine-them (hash/recur (blame-no-swap? b)) (combine-them (hash/recur (blame-context-frame b)) (hash/recur (blame-and-more b))))) +(define (blame-hash b hash/recur) + (blame-hash/combine b hash/recur (λ (x y) (bitwise-xor x (* 3 y))))) +(define (blame-secondary-hash b hash/recur) + (blame-hash/combine b hash/recur (λ (x y) (bitwise-xor (* 5 x) y)))) + ;; missing-party? field is #t when the missing party ;; is still missing and it is #f when the missing party ;; has been filled in (or if it was filled in from the start) (define-struct all-the-info [positive negative - source value build-name top-known? important missing-party? context-limit extra-fields] + source value build-name important missing-party? context-limit extra-fields] #:transparent) ;; and-more : (or/c blame-no-swap? blame-swap? all-the-info?) ;; context : string? (define-struct blame (context-frame and-more) #:property prop:equal+hash - (list blame=? blame-hash blame-hash)) + (list blame=? blame-hash blame-secondary-hash)) (define-struct (blame-no-swap blame) () #:property prop:equal+hash - (list blame=? blame-hash blame-hash)) + (list blame=? blame-hash blame-secondary-hash)) (define-struct (blame-yes-swap blame) () #:property prop:equal+hash - (list blame=? blame-hash blame-hash)) + (list blame=? blame-hash blame-secondary-hash)) (define (blame->all-the-info b) (let loop ([b b]) @@ -73,7 +78,6 @@ [else b]))) (define (blame-source b) (all-the-info-source (blame->all-the-info b))) (define (blame-value b) (all-the-info-value (blame->all-the-info b))) -(define (blame-top-known? b) (all-the-info-top-known? (blame->all-the-info b))) (define (blame-important b) (all-the-info-important (blame->all-the-info b))) (define (blame-missing-party? b) (all-the-info-missing-party? (blame->all-the-info b))) (define (blame-contract b) ((all-the-info-build-name (blame->all-the-info b)))) @@ -146,7 +150,6 @@ source value build/memo-name - #t #f (not negative) context-limit @@ -155,11 +158,10 @@ ;; so be careful in other parts of the code to ignore ;; it, as appropriate. (if original? - (blame-no-swap/intern #f all-the-info) - (blame-yes-swap/intern #f all-the-info)))]) + (blame-no-swap #f all-the-info) + (blame-yes-swap #f all-the-info)))]) make-blame)) -(define seen '()) (define (blame-add-context b s #:important [name #f] #:swap? [swap? #f]) (unless (blame? b) (raise-argument-error 'blame-add-context @@ -172,20 +174,15 @@ (format "~s" '(or/c string? #f)) 1 b s)) - (do-blame-add-context b s name swap?)) + (cond + [(string? s) + (do-blame-add-context b s name swap?)] + [else b])) -(define (blame-add-unknown-context b) - (do-blame-add-context b #f #f #f)) - -(define (make-blame-yes/no-swap/intern blame-yes/no-swap) - (define ht (make-hash)) - (define (blame-yes/no-swap/intern s b) - (define b-table (hash-ref! ht s make-hash)) - (hash-ref! b-table b (λ () (blame-yes/no-swap s b)))) - blame-yes/no-swap/intern) - -(define blame-no-swap/intern (make-blame-yes/no-swap/intern blame-no-swap)) -(define blame-yes-swap/intern (make-blame-yes/no-swap/intern blame-yes-swap)) +;; this has become a no op. it seems to never have been +;; documented. probably exported because of the Great +;; Extra Export ScrewUp that happened years back +(define (blame-add-unknown-context b) b) (define (do-blame-add-context b s name swap?) (define context-limit (blame-context-limit b)) @@ -194,52 +191,45 @@ ;; if we are not tracking context, ;; we are not updating the name ;; at the top of the messages either - ; (not name) - (blame-top-known? b)) + ;(not name) + ) (cond - [(and s (not (zero? context-limit))) + [(not (zero? context-limit)) ;; if the limit is zero, we skip this case, ;; which has the effect of always keeping only ;; the dummy context frame (define-values (limited-b dropped-swap?) (drop-to-limit b context-limit)) (if (equal? dropped-swap? swap?) - (blame-no-swap/intern s limited-b) - (blame-yes-swap/intern s limited-b))] + (blame-no-swap s limited-b) + (blame-yes-swap s limited-b))] [swap? (if (blame-yes-swap? b) - (blame-no-swap/intern (blame-context-frame b) (blame-and-more b)) - (blame-yes-swap/intern (blame-context-frame b) (blame-and-more b)))] + (blame-no-swap (blame-context-frame b) (blame-and-more b)) + (blame-yes-swap (blame-context-frame b) (blame-and-more b)))] [else b])] [else - (define blame-yes/no-swap (if swap? blame-yes-swap/intern blame-no-swap/intern)) + (define blame-yes/no-swap (if swap? blame-yes-swap blame-no-swap)) (define inside-part - (let/ec k - (let loop ([inner-b b]) - (cond - [(blame-yes-swap? inner-b) - (blame-yes-swap/intern (blame-context-frame inner-b) (loop (blame-and-more inner-b)))] - [(blame-no-swap? inner-b) - (blame-no-swap/intern (blame-context-frame inner-b) (loop (blame-and-more inner-b)))] - [else - (define top-known? (all-the-info-top-known? inner-b)) - (cond - [(or (equal? top-known? (string? s)) - name) - (define new-original? (if swap? (not (blame-original? b)) (blame-original? b))) - ;; in this case, we need to make a new blame record - (struct-copy - all-the-info inner-b - [important (if name - (important name new-original?) - (all-the-info-important inner-b))] - [top-known? (string? s)])] - [else - ;; we can skip all that pending work - ;; of making a copy in this case - (k b)])])))) + (cond + [name + (let loop ([inner-b b]) + (cond + [(blame-yes-swap? inner-b) + (blame-yes-swap (blame-context-frame inner-b) (loop (blame-and-more inner-b)))] + [(blame-no-swap? inner-b) + (blame-no-swap (blame-context-frame inner-b) (loop (blame-and-more inner-b)))] + [else + (define new-original? (if swap? (not (blame-original? b)) (blame-original? b))) + ;; in this case, we need to make a new blame record + (struct-copy + all-the-info inner-b + [important (if name + (important name new-original?) + (all-the-info-important inner-b))])]))] + [else b])) (if swap? - (blame-yes-swap/intern s inside-part) - (blame-no-swap/intern s inside-part))])) + (blame-yes-swap s inside-part) + (blame-no-swap s inside-part))])) (define (drop-to-limit b context-limit) (define short-enough? @@ -269,10 +259,10 @@ (set! swapped? swap?) b]))] [(blame-no-swap? b) - (blame-no-swap/intern (blame-context-frame b) + (blame-no-swap (blame-context-frame b) (loop (blame-and-more b) (- n 1)))] [(blame-yes-swap? b) - (blame-yes-swap/intern (blame-context-frame b) + (blame-yes-swap (blame-context-frame b) (loop (blame-and-more b) (- n 1)))]))) (values limited-b swapped?)])) @@ -281,9 +271,9 @@ (define (blame-swap b) (cond [(blame-yes-swap? b) - (blame-no-swap/intern (blame-context-frame b) (blame-and-more b))] + (blame-no-swap (blame-context-frame b) (blame-and-more b))] [(blame-no-swap? b) - (blame-yes-swap/intern (blame-context-frame b) (blame-and-more b))])) + (blame-yes-swap (blame-context-frame b) (blame-and-more b))])) (define (blame-replace-negative b new-neg) (update-the-info @@ -331,9 +321,9 @@ [swap? #f]) (cond [(blame-yes-swap? b) - (blame-yes-swap/intern (blame-context-frame b) (loop (blame-and-more b) (not swap?)))] + (blame-yes-swap (blame-context-frame b) (loop (blame-and-more b) (not swap?)))] [(blame-no-swap? b) - (blame-no-swap/intern (blame-context-frame b) (loop (blame-and-more b) swap?))] + (blame-no-swap (blame-context-frame b) (loop (blame-and-more b) swap?))] [else (f b swap?)]))) (define (ensure-blame-known who blame) diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt index 7bed4f33ec..ee2537810e 100644 --- a/racket/collects/racket/contract/private/prop.rkt +++ b/racket/collects/racket/contract/private/prop.rkt @@ -364,12 +364,6 @@ 'anonymous-flat-contract 'build-flat-contract-property #t #t) 'build-flat-contract-property)) -(define (blame-context-projection-wrapper proj) - (λ (ctc) - (define c-proj (proj ctc)) - (λ (blame) - (c-proj (blame-add-unknown-context blame))))) - (define build-chaperone-contract-property (procedure-rename (build-property (compose make-chaperone-contract-property make-contract-property)