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