1#lang racket/base 2 3(require racket/contract/base 4 racket/contract/combinator 5 "private/set.rkt" 6 "private/set-types.rkt" 7 racket/generic 8 racket/private/for 9 (for-syntax racket/base)) 10 11(provide gen:set generic-set? set-implements? 12 13 set-empty? set-member? set-count 14 set=? subset? proper-subset? 15 set-map set-for-each 16 set-copy set-copy-clear 17 set->list set->stream set-first set-rest 18 set-add set-remove set-clear 19 set-union set-intersect set-subtract set-symmetric-difference 20 set-add! set-remove! set-clear! 21 set-union! set-intersect! set-subtract! set-symmetric-difference! 22 23 in-set 24 in-immutable-set 25 in-mutable-set 26 in-weak-set 27 set-implements/c 28 29 set seteq seteqv 30 weak-set weak-seteq weak-seteqv 31 mutable-set mutable-seteq mutable-seteqv 32 list->set list->seteq list->seteqv 33 list->weak-set list->weak-seteq list->weak-seteqv 34 list->mutable-set list->mutable-seteq list->mutable-seteqv 35 set-eq? set-eqv? set-equal? 36 set-weak? set-mutable? set? 37 for/set for/seteq for/seteqv 38 for*/set for*/seteq for*/seteqv 39 for/weak-set for/weak-seteq for/weak-seteqv 40 for*/weak-set for*/weak-seteq for*/weak-seteqv 41 for/mutable-set for/mutable-seteq for/mutable-seteqv 42 for*/mutable-set for*/mutable-seteq for*/mutable-seteqv 43 44 define-custom-set-types 45 make-custom-set-types 46 make-custom-set 47 make-weak-custom-set 48 make-mutable-custom-set 49 50 chaperone-hash-set 51 impersonate-hash-set 52 53 set/c) 54 55(define/subexpression-pos-prop/name 56 real-set/c-name (set/c _elem/c 57 #:equal-key/c [_equal-key/c any/c] 58 #:cmp [cmp 'dont-care] 59 #:kind [kind 'immutable] 60 #:lazy? [_lazy? (lazy-default kind _elem/c)]) 61 (define elem/c (coerce-contract 'set/c _elem/c)) 62 (define equal-key/c (coerce-contract 'set/c _equal-key/c)) 63 (define lazy? (and _lazy? #t)) 64 (define cmp/c 65 (case cmp 66 [(dont-care) any/c] 67 [(equal) set-equal?] 68 [(eqv) set-eqv?] 69 [(eq) set-eq?] 70 [else (raise-arguments-error 'set/c 71 "invalid #:cmp argument" 72 "#:cmp argument" cmp)])) 73 (define kind/c 74 (case kind 75 [(dont-care) any/c] 76 [(mutable-or-weak) (or/c set-weak? set-mutable?)] 77 [(mutable) set-mutable?] 78 [(weak) set-weak?] 79 [(immutable) set?] 80 [else (raise-arguments-error 'set/c 81 "invalid #:kind argument" 82 "#:kind argument" kind)])) 83 (case cmp 84 [(eqv eq) 85 (unless (flat-contract? elem/c) 86 (raise-arguments-error 87 'set/c 88 "element contract must be a flat contract for eqv? and eq?-based sets" 89 "element contract" elem/c 90 "#:cmp option" cmp))] 91 [else 92 (unless (chaperone-contract? elem/c) 93 (raise-argument-error 'set/c "chaperone-contract?" elem/c))]) 94 (cond 95 [(and (eq? kind 'immutable) 96 (not lazy?) 97 (flat-contract? elem/c) 98 (flat-contract? equal-key/c)) 99 (flat-set-contract elem/c equal-key/c cmp kind lazy?)] 100 [(chaperone-contract? elem/c) 101 (chaperone-set-contract elem/c equal-key/c cmp kind lazy?)] 102 [else 103 (impersonator-set-contract elem/c equal-key/c cmp kind lazy?)])) 104 105(struct set-contract [elem/c equal-key/c cmp kind lazy?] 106 #:property prop:custom-write contract-custom-write-property-proc) 107 108(define (lazy-default kind elem/c) 109 (not (and (equal? kind 'immutable) 110 (flat-contract? elem/c)))) 111 112(define (set-contract-name ctc) 113 (define elem/c (set-contract-elem/c ctc)) 114 (define cmp (set-contract-cmp ctc)) 115 (define kind (set-contract-kind ctc)) 116 `(set/c ,(contract-name elem/c) 117 ,@(if (eq? cmp 'dont-care) 118 `[] 119 `[#:cmp (quote ,cmp)]) 120 ,@(if (eq? kind 'immutable) 121 `[] 122 `[#:kind (quote ,kind)]) 123 ,@(if (equal? (set-contract-lazy? ctc) 124 (lazy-default kind elem/c)) 125 '() 126 `(#:lazy? ,(set-contract-lazy? ctc))))) 127 128(define (set-contract-first-order ctc) 129 (define cmp (set-contract-cmp ctc)) 130 (define kind (set-contract-kind ctc)) 131 (define cmp? 132 (case cmp 133 [(dont-care) (lambda (x) #t)] 134 [(equal) set-equal?] 135 [(eqv) set-eqv?] 136 [(eq) set-eq?])) 137 (define kind? 138 (case kind 139 [(dont-care) (lambda (x) #t)] 140 [(mutable-or-weak) (lambda (x) (or (set-mutable? x) (set-weak? x)))] 141 [(mutable) set-mutable?] 142 [(weak) set-weak?] 143 [(immutable) set?])) 144 (lambda (x) 145 (and (generic-set? x) (cmp? x) (kind? x)))) 146 147(define (set-contract-check cmp kind b neg-party x) 148 (unless (generic-set? x) 149 (raise-blame-error b #:missing-party neg-party x "expected a set")) 150 (case cmp 151 [(equal) 152 (unless (set-equal? x) 153 (raise-blame-error b #:missing-party neg-party x "expected an equal?-based set"))] 154 [(eqv) 155 (unless (set-eqv? x) 156 (raise-blame-error b #:missing-party neg-party x "expected an eqv?-based set"))] 157 [(eq) 158 (unless (set-eq? x) 159 (raise-blame-error b #:missing-party neg-party x "expected an eq?-based set"))]) 160 (case kind 161 [(mutable-or-weak) 162 (unless (or (set-mutable? x) (set-weak? x)) 163 (raise-blame-error b #:missing-party neg-party x "expected a mutable or weak set"))] 164 [(mutable) 165 (unless (set-mutable? x) 166 (raise-blame-error b #:missing-party neg-party x "expected a mutable set"))] 167 [(weak) 168 (unless (set-weak? x) 169 (raise-blame-error b #:missing-party neg-party x "expected a weak set"))] 170 [(immutable) 171 (unless (set? x) 172 (raise-blame-error b #:missing-party neg-party x "expected an immutable set"))])) 173 174(define (set-contract-late-neg-projection chaperone-ctc?) 175 (lambda (ctc) 176 (cond 177 [(allows-generic-sets? ctc) 178 (generic-set-late-neg-projection ctc chaperone-ctc?)] 179 [else 180 (hash-set-late-neg-projection ctc chaperone-ctc?)]))) 181 182(define (allows-generic-sets? ctc) 183 (and (equal? 'dont-care (set-contract-kind ctc)) 184 (equal? 'dont-care (set-contract-cmp ctc)))) 185 186(define (hash-set-late-neg-projection ctc chaperone-ctc?) 187 (define elem/c (set-contract-elem/c ctc)) 188 (define equal-key/c (set-contract-equal-key/c ctc)) 189 (define cmp (set-contract-cmp ctc)) 190 (define kind (set-contract-kind 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)) 193 (define lazy? (set-contract-lazy? ctc)) 194 (λ (blame) 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)) 199 (cond 200 [lazy? 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)) 205 (cond 206 [(set? val) 207 (chaperone-hash-set 208 val 209 (λ (val ele) ele) 210 (λ (val ele) ele) 211 (λ (val ele) ele) 212 (λ (val ele) (with-contract-continuation-mark 213 blame+neg-party 214 (late-neg-pos-proj ele neg-party))) 215 (λ (val) (void)) 216 (λ (val ele) (with-contract-continuation-mark 217 blame+neg-party 218 (late-neg-equal-key-pos-proj ele neg-party))) 219 impersonator-prop:contracted ctc 220 impersonator-prop:blame (cons blame neg-party))] 221 [else 222 (chaperone-hash-set 223 val 224 (λ (val ele) ele) 225 (λ (val ele) (with-contract-continuation-mark 226 blame+neg-party 227 (late-neg-neg-proj ele neg-party))) 228 (λ (val ele) ele) 229 (λ (val ele) (with-contract-continuation-mark 230 blame+neg-party 231 (late-neg-pos-proj ele neg-party))) 232 (λ (val) (void)) 233 (λ (val ele) (with-contract-continuation-mark 234 blame+neg-party 235 (late-neg-equal-key-pos-proj ele neg-party))) 236 impersonator-prop:contracted ctc 237 impersonator-prop:blame (cons blame neg-party))]))] 238 [else 239 (λ (val neg-party) 240 (define blame+neg-party (cons blame neg-party)) 241 (set-contract-check cmp kind blame neg-party val) 242 (cond 243 [(set? val) 244 (chaperone-hash-set 245 (for/fold ([s (set-clear val)]) 246 ([e (in-set val)]) 247 (set-add s (with-contract-continuation-mark 248 blame+neg-party 249 (late-neg-pos-proj e neg-party)))) 250 #f #f #f 251 impersonator-prop:contracted ctc 252 impersonator-prop:blame (cons blame neg-party))] 253 [else 254 (for ([ele (in-list (set->list val))]) 255 (set-remove! val ele) 256 (set-add! val (late-neg-pos-proj ele neg-party))) 257 (chaperone-hash-set 258 val 259 (λ (val ele) ele) 260 (λ (val ele) (with-contract-continuation-mark 261 blame+neg-party 262 (late-neg-neg-proj ele neg-party))) 263 (λ (val ele) ele) 264 (λ (val ele) (with-contract-continuation-mark 265 blame+neg-party 266 (late-neg-pos-proj ele neg-party))) 267 (λ (val) (void)) 268 (λ (val ele) (with-contract-continuation-mark 269 blame+neg-party 270 (late-neg-equal-key-pos-proj ele neg-party))) 271 impersonator-prop:contracted ctc 272 impersonator-prop:blame (cons blame neg-party))]))]))) 273 274(define (generic-set-late-neg-projection ctc chaperone-ctc?) 275 (define elem/c (set-contract-elem/c ctc)) 276 (define cmp (set-contract-cmp ctc)) 277 (define kind (set-contract-kind ctc)) 278 (define lazy? (set-contract-lazy? ctc)) 279 (lambda (blame) 280 (define (method sym c) 281 (define name (contract-name c)) 282 (define str (format "method ~a with contract ~.s" sym name)) 283 (define b2 (blame-add-context blame str)) 284 ((contract-late-neg-projection c) b2)) 285 (define-syntax (redirect stx) 286 (syntax-case stx () 287 [(_ [id expr] ...) 288 (with-syntax ([(proj-id ...) (generate-temporaries #'(id ...))]) 289 #'(let ([proj-id (method 'id expr)] ...) 290 (λ (x neg-party) 291 (redirect-generics chaperone-ctc? 292 gen:set x [id (λ (x) (proj-id x neg-party))] ...))))])) 293 (define me (if chaperone-contract? 294 (make-chaperone-contract 295 #:name (set-contract-name ctc) 296 #:stronger set-contract-stronger 297 #:late-neg-projection 298 (λ (blame) (λ (val neg-party) (do-redirect val neg-party)))) 299 (make-contract 300 #:name (set-contract-name ctc) 301 #:stronger set-contract-stronger 302 #:late-neg-projection 303 (λ (blame) (λ (val neg-party) (do-redirect val neg-party)))))) 304 (define do-redirect 305 (redirect 306 [set-member? (-> generic-set? elem/c boolean?)] 307 [set-empty? (or/c (-> generic-set? boolean?) #f)] 308 [set-count (or/c (-> generic-set? exact-nonnegative-integer?) #f)] 309 [set=? (or/c (-> generic-set? me boolean?) #f)] 310 [subset? (or/c (-> generic-set? me boolean?) #f)] 311 [proper-subset? (or/c (-> generic-set? me boolean?) #f)] 312 [set-map (or/c (-> generic-set? (-> elem/c any/c) list?) #f)] 313 [set-for-each (or/c (-> generic-set? (-> elem/c any) void?) #f)] 314 [set-copy (or/c (-> generic-set? generic-set?) #f)] 315 [in-set (or/c (-> generic-set? sequence?) #f)] 316 [set->list (or/c (-> generic-set? (listof elem/c)) #f)] 317 [set->stream (or/c (-> generic-set? stream?) #f)] 318 [set-first (or/c (-> generic-set? elem/c) #f)] 319 [set-rest (or/c (-> generic-set? me) #f)] 320 [set-add (or/c (-> generic-set? elem/c me) #f)] 321 [set-remove (or/c (-> generic-set? elem/c me) #f)] 322 [set-clear (or/c (-> generic-set? me) #f)] 323 [set-copy-clear (or/c (-> generic-set? generic-set?) #f)] 324 [set-union 325 (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] 326 [set-intersect 327 (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] 328 [set-subtract 329 (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] 330 [set-symmetric-difference 331 (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] 332 [set-add! (or/c (-> generic-set? elem/c void?) #f)] 333 [set-remove! (or/c (-> generic-set? elem/c void?) #f)] 334 [set-clear! (or/c (-> generic-set? void?) #f)] 335 [set-union! 336 (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] 337 [set-intersect! 338 (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] 339 [set-subtract! 340 (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] 341 [set-symmetric-difference! 342 (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)])) 343 (define proj 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) 347 (cond 348 [(list? x) 349 (for/list ([e (in-list x)]) 350 (proj e neg-party))] 351 [else 352 (do-redirect x neg-party)])))) 353 354 355(define (blame-add-element-context blame swap?) 356 (blame-add-context blame "an element of" #:swap? swap?)) 357 358(define (flat-set-contract-first-order ctc) 359 (define set-passes? (set-contract-first-order ctc)) 360 (define elem-passes? (contract-first-order (set-contract-elem/c ctc))) 361 (lambda (x) 362 (and (set-passes? x) 363 (for/and ([e (in-set x)]) 364 (elem-passes? e))))) 365 366;; since the equal-key/c must be a flat contract 367;; in order for the entire set/c to be a flat contract, 368;; then we know that it doesn't have any negative blame 369;; and thus can never fail; so this projection ignores it. 370(define (flat-set-contract-late-neg-projection ctc) 371 (define elem/c (set-contract-elem/c ctc)) 372 (define cmp (set-contract-cmp ctc)) 373 (define kind (set-contract-kind ctc)) 374 (define mk-elem/c-proj (contract-late-neg-projection elem/c)) 375 (lambda (b) 376 (define proj (mk-elem/c-proj (blame-add-context b "an element of"))) 377 (lambda (x neg-party) 378 (set-contract-check cmp kind b neg-party x) 379 (for ([e (in-set x)]) 380 (proj e neg-party)) 381 x))) 382 383(define (set-contract-stronger this that) 384 #f) 385 386(struct flat-set-contract set-contract [] 387 #:property prop:flat-contract 388 (build-flat-contract-property 389 #:name set-contract-name 390 #:stronger set-contract-stronger 391 #:first-order flat-set-contract-first-order 392 #:late-neg-projection flat-set-contract-late-neg-projection)) 393 394(struct chaperone-set-contract set-contract [] 395 #:property prop:chaperone-contract 396 (build-chaperone-contract-property 397 #:name set-contract-name 398 #:stronger set-contract-stronger 399 #:first-order set-contract-first-order 400 #:late-neg-projection (set-contract-late-neg-projection #t))) 401 402(struct impersonator-set-contract set-contract [] 403 #:property prop:contract 404 (build-contract-property 405 #:name set-contract-name 406 #:stronger set-contract-stronger 407 #:first-order set-contract-first-order 408 #:late-neg-projection (set-contract-late-neg-projection #f))) 409