collects/racket/set.rkt

147 (define (set-contract-check cmp kind b neg-party x)
149     (raise-blame-error b #:missing-party neg-party x "expected a set"))
153        (raise-blame-error b #:missing-party neg-party x "expected an equal?-based set"))]
156        (raise-blame-error b #:missing-party neg-party x "expected an eqv?-based set"))]
159        (raise-blame-error b #:missing-party neg-party x "expected an eq?-based set"))])
163        (raise-blame-error b #:missing-party neg-party x "expected a mutable or weak set"))]
166        (raise-blame-error b #:missing-party neg-party x "expected a mutable set"))]
169        (raise-blame-error b #:missing-party neg-party x "expected a weak set"))]
172        (raise-blame-error b #:missing-party neg-party x "expected an immutable set"))]))
174 (define (set-contract-late-neg-projection chaperone-ctc?)
178        (generic-set-late-neg-projection ctc chaperone-ctc?)]
180        (hash-set-late-neg-projection ctc chaperone-ctc?)])))
186 (define (hash-set-late-neg-projection ctc chaperone-ctc?)
191   (define late-neg-ele-proj (contract-late-neg-projection elem/c))
192   (define late-neg-equal-key-proj (contract-late-neg-projection equal-key/c))
195     (define ele-neg-blame (blame-add-element-context blame #t))
196     (define late-neg-pos-proj (late-neg-ele-proj (blame-add-element-context blame #f)))
197     (define late-neg-neg-proj (late-neg-ele-proj ele-neg-blame))
198     (define late-neg-equal-key-pos-proj (late-neg-equal-key-proj ele-neg-blame))
201        (λ (val neg-party)
202          (set-contract-check cmp kind blame neg-party val)
203          (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party))
204          (define blame+neg-party (cons blame neg-party))
213                            blame+neg-party
214                            (late-neg-pos-proj ele neg-party)))
217                            blame+neg-party
218                            (late-neg-equal-key-pos-proj ele neg-party)))
220              impersonator-prop:blame (cons blame neg-party))]
226                            blame+neg-party
227                            (late-neg-neg-proj ele neg-party)))
230                            blame+neg-party
231                            (late-neg-pos-proj ele neg-party)))
234                            blame+neg-party
235                            (late-neg-equal-key-pos-proj ele neg-party)))
237              impersonator-prop:blame (cons blame neg-party))]))]
239        (λ (val neg-party)
240          (define blame+neg-party (cons blame neg-party))
241          (set-contract-check cmp kind blame neg-party val)
248                            blame+neg-party
249                            (late-neg-pos-proj e neg-party))))
252              impersonator-prop:blame (cons blame neg-party))]
256               (set-add! val (late-neg-pos-proj ele neg-party)))
261                            blame+neg-party
262                            (late-neg-neg-proj ele neg-party)))
265                            blame+neg-party
266                            (late-neg-pos-proj ele neg-party)))
269                            blame+neg-party
270                            (late-neg-equal-key-pos-proj ele neg-party)))
272              impersonator-prop:blame (cons blame neg-party))]))])))
274 (define (generic-set-late-neg-projection ctc chaperone-ctc?)
284       ((contract-late-neg-projection c) b2))
290                (λ (x neg-party)
292                                     gen:set x [id (λ (x) (proj-id x neg-party))] ...))))]))
297                     #:late-neg-projection
298                     (λ (blame) (λ (val neg-party) (do-redirect val neg-party))))
302                     #:late-neg-projection
303                     (λ (blame) (λ (val neg-party) (do-redirect val neg-party))))))
344       ((contract-late-neg-projection elem/c) (blame-add-element-context blame #f)))
345     (lambda (x neg-party)
346       (set-contract-check cmp kind blame neg-party x)
350            (proj e neg-party))]
352          (do-redirect x neg-party)]))))
370 (define (flat-set-contract-late-neg-projection ctc)
374   (define mk-elem/c-proj (contract-late-neg-projection elem/c))
377     (lambda (x neg-party)
378       (set-contract-check cmp kind b neg-party x)
380         (proj e neg-party))
392     #:late-neg-projection flat-set-contract-late-neg-projection))
400     #:late-neg-projection (set-contract-late-neg-projection #t)))
408     #:late-neg-projection (set-contract-late-neg-projection #f)))