1#lang racket/base
2
3(require (for-syntax racket/base "arr-util.rkt")
4         syntax/location
5         "guts.rkt"
6         "blame.rkt"
7         "prop.rkt"
8         "rand.rkt"
9         "generate.rkt"
10         "generate-base.rkt")
11
12(provide (rename-out [wrap-hash/c hash/c])
13         hash/dc)
14
15(define-syntax (wrap-hash/c stx)
16  (syntax-case stx ()
17    [x
18     (identifier? #'x)
19     (syntax-property
20      (syntax/loc stx hash/c)
21      'racket/contract:contract
22      (vector (gensym 'ctc) (list stx) null))]
23    [(h/c arg ...)
24     (let ([args (syntax->list #'(arg ...))]
25           [this-one (gensym 'ctc)])
26       (define (convert-args args)
27         (let loop ([args args]
28                    [new-args null]
29                    [neg-ctc? #t])
30           (cond
31             [(null? args) (reverse new-args)]
32             [(keyword? (syntax-e (car args)))
33              (if (null? (cdr args))
34                  (reverse (cons (car args) new-args))
35                  (loop (cddr args)
36                        (list* (cadr args) (car args) new-args)
37                        neg-ctc?))]
38             [neg-ctc?
39              (loop (cdr args)
40                    (cons (syntax-property
41                           (car args)
42                           'racket/contract:negative-position
43                           this-one)
44                          new-args)
45                    #f)]
46             [else
47              (append (reverse new-args)
48                      (cons (syntax-property
49                             (car args)
50                             'racket/contract:positive-position
51                             this-one)
52                            (cdr args)))])))
53       (with-syntax ([(new-arg ...) (convert-args args)]
54                     [app (datum->syntax stx '#%app)])
55         (syntax-property
56          (syntax/loc stx
57            (app hash/c new-arg ...))
58          'racket/contract:contract
59          (vector this-one (list #'h/c) null))))]))
60
61(define (hash/c dom rng #:immutable [immutable 'dont-care] #:flat? [flat? #f])
62  (unless (member immutable '(#t #f dont-care))
63    (raise-argument-error 'hash/c
64                          "(or/c #t #f 'dont-care) for the #:immutable argument"
65                          immutable))
66  (define dom-ctc (if flat?
67                      (coerce-flat-contract 'hash/c dom)
68                      (coerce-chaperone-contract 'hash/c dom)))
69  (define rng-ctc (if flat?
70                      (coerce-flat-contract 'hash/c rng)
71                      (coerce-contract 'hash/c rng)))
72  (cond
73    [(or flat?
74         (and (eq? immutable #t)
75              (flat-contract? dom-ctc)
76              (flat-contract? rng-ctc)))
77     (make-flat-hash/c dom-ctc rng-ctc immutable)]
78    [(chaperone-contract? rng-ctc)
79     (make-chaperone-hash/c dom-ctc rng-ctc immutable)]
80    [else
81     (make-impersonator-hash/c dom-ctc rng-ctc immutable)]))
82
83
84;; ... --> boolean
85;;  returns #t when it called raise-blame-error, #f otherwise
86(define (check-hash/c dom-ctc immutable flat? val blame neg-party)
87  (cond
88    [(hash? val)
89     (cond
90       [(and (not flat?)
91             (not (flat-contract? dom-ctc))
92             (not (hash-equal? val)))
93        (raise-blame-error
94         blame val #:missing-party neg-party
95         '(expected "equal?-based hash table due to higher-order domain contract" given: "~e")
96         val)
97        #t]
98       [else
99        (case immutable
100          [(#t)
101           (cond
102             [(immutable? val)
103              #f]
104             [else
105              (raise-blame-error
106               blame val #:missing-party neg-party
107               '(expected "an immutable hash" given: "~e") val)
108              #t])]
109          [(#f)
110           (cond
111             [(immutable? val)
112              (raise-blame-error
113               blame val #:missing-party neg-party
114               '(expected "a mutable hash" given: "~e") val)
115              #t]
116             [else #f])]
117          [(dont-care) #f])])]
118    [else
119     (raise-blame-error blame val #:missing-party neg-party
120                        '(expected "a hash" given: "~e") val)
121     #t]))
122
123(define (hash/c-first-order ctc)
124  (define dom-ctc (base-hash/c-dom ctc))
125  (define rng-ctc (base-hash/c-rng ctc))
126  (define immutable (base-hash/c-immutable ctc))
127  (define flat? (flat-hash/c? ctc))
128  (λ (val)
129    (and (hash? val)
130         (or flat?
131             (flat-contract? dom-ctc)
132             (hash-equal? val))
133         (case immutable
134           [(#t) (immutable? val)]
135           [(#f) (not (immutable? val))]
136           [else #t])
137         (for/and ([(k v) (in-hash val)])
138           (and (contract-first-order-passes? dom-ctc k)
139                (contract-first-order-passes? rng-ctc v))))))
140
141(define (hash/c-name ctc)
142  (apply
143   build-compound-type-name
144   'hash/c (base-hash/c-dom ctc) (base-hash/c-rng ctc)
145   (append
146    (if (and (flat-hash/c? ctc)
147             (not (eq? (base-hash/c-immutable ctc) #t)))
148        (list '#:flat? #t)
149        null)
150    (case (base-hash/c-immutable ctc)
151      [(dont-care) null]
152      [(#t)
153       (list '#:immutable #t)]
154      [(#f)
155       (list '#:immutable #f)]))))
156
157(define-struct base-hash/c (dom rng immutable))
158
159(define (hash/c-stronger this that)
160  (define this-dom (base-hash/c-dom this))
161  (define this-rng (base-hash/c-rng this))
162  (define this-immutable (base-hash/c-immutable this))
163  (cond
164    [(base-hash/c? that)
165     (define that-dom (base-hash/c-dom that))
166     (define that-rng (base-hash/c-rng that))
167     (define that-immutable (base-hash/c-immutable that))
168     (cond
169       [(and (equal? this-immutable #t)
170             (equal? that-immutable #t))
171        (and (contract-struct-stronger? this-dom that-dom)
172             (contract-struct-stronger? this-rng that-rng))]
173       [(or (equal? that-immutable 'dont-care)
174            (equal? this-immutable that-immutable))
175        (and (contract-struct-equivalent? this-dom that-dom)
176             (contract-struct-equivalent? this-rng that-rng))]
177       [else #f])]
178    [else #f]))
179
180(define (hash/c-equivalent this that)
181  (cond
182    [(base-hash/c? that)
183     (define this-dom (base-hash/c-dom this))
184     (define this-rng (base-hash/c-rng this))
185     (define this-immutable (base-hash/c-immutable this))
186     (define that-dom (base-hash/c-dom that))
187     (define that-rng (base-hash/c-rng that))
188     (define that-immutable (base-hash/c-immutable that))
189     (and (equal? this-immutable that-immutable)
190          (contract-struct-equivalent? this-dom that-dom)
191          (contract-struct-equivalent? this-rng that-rng))]
192    [else #f]))
193
194;; Will periodically generate empty hashes and hashes with multiple elements
195(define (hash/c-generate ctc)
196  (define this-dom (base-hash/c-dom ctc))
197  (define this-rng (base-hash/c-rng ctc))
198  (define this-immutable (base-hash/c-immutable ctc))
199  (λ (fuel)
200    (define rnd (random fuel)) ;; used to return empty hashes from time to time
201    (define gen-key (contract-random-generate/choose this-dom fuel))
202    (define gen-val (contract-random-generate/choose this-rng fuel))
203    (λ ()
204      (cond [(or (zero? rnd) (not gen-key) (not gen-val))
205             (if this-immutable
206                 (hash)
207                 (make-hash))]
208            [else
209             (let ([pair-list
210                    (let loop ([so-far (list (cons (gen-key) (gen-val)))])
211                      (rand-choice
212                       [1/5 so-far]
213                       [else
214                        (loop
215                         (cons (cons (gen-key) (gen-val)) so-far))]))])
216               (if this-immutable
217                   (make-immutable-hash pair-list)
218                   (make-hash pair-list)))]))))
219
220(define (hash/c-exercise ctc)
221  (define env (contract-random-generate-get-current-environment))
222  (define dom (base-hash/c-dom ctc))
223  (define rng (base-hash/c-rng ctc))
224  (λ (fuel)
225    ;; passing (list dom rng) to multi-exercise will produce
226    ;; a function that exercises values of form (list/c dom rng)
227    ;; and a list of newly available contracts.
228    (define-values (exercise-list-dom-rng available-ctcs)
229      ((multi-exercise (list dom rng)) fuel))
230    (values
231     (λ (h)
232       ;; iterate over key-value pairs, exercise and stash
233       (for ([(k v) (in-hash h)])
234         (exercise-list-dom-rng (list k v))
235         (contract-random-generate-stash env dom k)
236         (contract-random-generate-stash env dom v)))
237     (cons dom (cons rng available-ctcs)))))
238
239(define-struct (flat-hash/c base-hash/c) ()
240  #:omit-define-syntaxes
241  #:property prop:custom-write custom-write-property-proc
242  #:property prop:flat-contract
243  (build-flat-contract-property
244   #:trusted trust-me
245   #:name hash/c-name
246   #:first-order hash/c-first-order
247   #:generate hash/c-generate
248   #:exercise hash/c-exercise
249   #:stronger hash/c-stronger
250   #:equivalent hash/c-equivalent
251   #:late-neg-projection
252   (λ (ctc)
253     (define dom-ctc (base-hash/c-dom ctc))
254     (define immutable (base-hash/c-immutable ctc))
255     (define flat? (flat-hash/c? ctc))
256     (λ (blame)
257       (define dom-proj ((get/build-late-neg-projection (base-hash/c-dom ctc))
258                         (blame-add-key-context blame #f)))
259       (define rng-proj ((get/build-late-neg-projection (base-hash/c-rng ctc))
260                         (blame-add-value-context blame #f)))
261       (λ (val neg-party)
262         (cond
263           [(check-hash/c dom-ctc immutable flat? val blame neg-party)
264            val]
265           [else
266            (for ([(k v) (in-hash val)])
267              (dom-proj k neg-party)
268              (rng-proj v neg-party))
269            val]))))))
270
271(define (ho-projection chaperone-or-impersonate-hash)
272  (λ (ctc)
273    (define immutable (base-hash/c-immutable ctc))
274    (define dom-ctc (base-hash/c-dom ctc))
275    (define flat? (flat-hash/c? ctc))
276    (define dom-proc (get/build-late-neg-projection dom-ctc))
277    (define rng-proc (get/build-late-neg-projection (base-hash/c-rng ctc)))
278    (λ (blame)
279      (define-values (dom-filled? maybe-pos-dom-proj maybe-neg-dom-proj)
280        (contract-pos/neg-doubling (dom-proc (blame-add-key-context blame #f))
281                                   (dom-proc (blame-add-key-context blame #t))))
282      (define-values (rng-filled? maybe-pos-rng-proj maybe-neg-rng-proj)
283        (contract-pos/neg-doubling (rng-proc (blame-add-value-context blame #f))
284                                   (rng-proc (blame-add-value-context blame #t))))
285      (cond
286        [(and dom-filled? rng-filled?)
287         (λ (val neg-party)
288           (cond
289             [(check-hash/c dom-ctc immutable flat? val blame neg-party)
290              val]
291             [else
292              (handle-the-hash val neg-party
293                               maybe-pos-dom-proj maybe-neg-dom-proj
294                               (λ (v) maybe-pos-rng-proj) (λ (v) maybe-neg-rng-proj)
295                               chaperone-or-impersonate-hash ctc blame)]))]
296        [else
297         (define tc (make-thread-cell #f))
298         (λ (val neg-party)
299           (define-values (pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)
300             (cond
301               [(thread-cell-ref tc)
302                =>
303                (λ (v) (values (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4)))]
304               [else
305                (define pos-dom-proj (maybe-pos-dom-proj))
306                (define neg-dom-proj (maybe-neg-dom-proj))
307                (define pos-rng-proj (maybe-pos-rng-proj))
308                (define neg-rng-proj (maybe-neg-rng-proj))
309                (thread-cell-set! tc (vector pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj))
310                (values pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)]))
311           (cond
312             [(check-hash/c dom-ctc immutable flat? val blame neg-party)
313              val]
314             [else
315              (handle-the-hash val neg-party
316                               pos-dom-proj neg-dom-proj
317                               (λ (v) pos-rng-proj) (λ (v) neg-rng-proj)
318                               chaperone-or-impersonate-hash ctc blame)]))]))))
319
320(define (blame-add-key-context blame swap?) (blame-add-context blame "the keys of" #:swap? swap?))
321(define (blame-add-value-context blame swap?) (blame-add-context blame "the values of" #:swap? swap?))
322
323(define (handle-the-hash val neg-party
324                         pos-dom-proj neg-dom-proj mk-pos-rng-proj mk-neg-rng-proj
325                         chaperone-or-impersonate-hash ctc blame)
326  (define blame+neg-party (cons blame neg-party))
327  (if (immutable? val)
328      (for/fold ([h val]) ([(k v) (in-hash val)])
329        (hash-set h
330                  (pos-dom-proj k neg-party)
331                  ((mk-pos-rng-proj k) v neg-party)))
332      (chaperone-or-impersonate-hash
333       val
334       (λ (h k)
335         (values (with-contract-continuation-mark
336                   blame+neg-party
337                   (neg-dom-proj k neg-party))
338                 (λ (h k v)
339                   (with-contract-continuation-mark
340                     blame+neg-party
341                     ((mk-pos-rng-proj k) v neg-party)))))
342       (λ (h k v)
343         (with-contract-continuation-mark
344           blame+neg-party
345           (values (neg-dom-proj k neg-party)
346                   ((mk-neg-rng-proj k) v neg-party))))
347       (λ (h k)
348         (with-contract-continuation-mark
349           blame+neg-party
350           (neg-dom-proj k neg-party)))
351       (λ (h k)
352         (with-contract-continuation-mark
353           blame+neg-party
354           (pos-dom-proj k neg-party)))
355       impersonator-prop:contracted ctc
356       impersonator-prop:blame blame)))
357
358(define-struct (chaperone-hash/c base-hash/c) ()
359  #:omit-define-syntaxes
360  #:property prop:custom-write custom-write-property-proc
361  #:property prop:chaperone-contract
362  (build-chaperone-contract-property
363   #:trusted trust-me
364   #:name hash/c-name
365   #:first-order hash/c-first-order
366   #:generate hash/c-generate
367   #:exercise hash/c-exercise
368   #:stronger hash/c-stronger
369   #:equivalent hash/c-equivalent
370   #:late-neg-projection (ho-projection chaperone-hash)))
371
372(define-struct (impersonator-hash/c base-hash/c) ()
373  #:omit-define-syntaxes
374  #:property prop:custom-write custom-write-property-proc
375  #:property prop:contract
376  (build-contract-property
377   #:trusted trust-me
378   #:name hash/c-name
379   #:first-order hash/c-first-order
380   #:stronger hash/c-stronger
381   #:equivalent hash/c-equivalent
382   #:late-neg-projection (ho-projection impersonate-hash)))
383
384
385(define (hash/dc-name a-hash-dc)
386  (define info (base-hash/dc-name-info a-hash-dc))
387  (define immutable (base-hash/dc-immutable a-hash-dc))
388  `(hash/dc [,(vector-ref info 0) ,(contract-name (base-hash/dc-dom a-hash-dc))]
389            [,(vector-ref info 1) (,(vector-ref info 0)) ,(vector-ref info 2)]
390            ,@(if (equal? immutable 'dont-care)
391                  '()
392                  `(#:immutable ,immutable))
393            ,@(cond
394                [(flat-hash/dc? a-hash-dc)
395                 '(#:kind 'flat)]
396                [(chaperone-hash/dc? a-hash-dc)
397                 '()]
398                [else '(#:kind 'impersonator)])))
399
400(define (hash/dc-first-order a-hash-dc)
401  (define dom (base-hash/dc-dom a-hash-dc))
402  (define rng-f (base-hash/dc-dep-rng a-hash-dc))
403  (λ (val)
404    (and (hash? val)
405         (for/and ([(k v) (in-hash val)])
406           (and (contract-first-order-passes? dom k)
407                (contract-first-order-passes? (rng-f k) v))))))
408
409(define (hash/dc-stronger this that) #f)
410(define (hash/dc-equivalent this that) #f)
411
412(define ((hash/dc-late-neg-projection chaperone-or-impersonate-hash) ctc)
413  (define dom-ctc (base-hash/dc-dom ctc))
414  (define immutable (base-hash/dc-immutable ctc))
415  (define flat? (flat-hash/dc? ctc))
416  (define dom-proc (get/build-late-neg-projection dom-ctc))
417  (define dep-rng-proc (base-hash/dc-dep-rng ctc))
418  (λ (blame)
419    (define pos-dom-proj (dom-proc (blame-add-key-context blame #f)))
420    (define neg-dom-proj (dom-proc (blame-add-key-context blame #t)))
421    (define indy-dom-proj (dom-proc
422                           (blame-replace-negative (blame-add-key-context blame #f)
423                                                   (base-hash/dc-here ctc))))
424    (define pos-value-blame (blame-add-value-context blame #f))
425    (define neg-value-blame (blame-add-value-context blame #t))
426    (cond
427      [chaperone-or-impersonate-hash
428       (λ (val neg-party)
429         (cond
430           [(check-hash/c dom-ctc immutable flat? val blame neg-party) val]
431           [else
432            (define ((mk-rng-proj x-value-blame) key)
433              ((get/build-late-neg-projection (dep-rng-proc (indy-dom-proj key neg-party)))
434               x-value-blame))
435            (handle-the-hash val neg-party
436                             pos-dom-proj neg-dom-proj
437                             (mk-rng-proj pos-value-blame) (mk-rng-proj neg-value-blame)
438                             chaperone-or-impersonate-hash ctc blame)]))]
439      [else
440       (λ (val neg-party)
441         (check-hash/c dom-ctc immutable flat? val blame neg-party)
442         (define ((mk-rng-proj x-value-blame) key)
443           ((get/build-late-neg-projection (dep-rng-proc (indy-dom-proj key neg-party)))
444            x-value-blame))
445         (define mk-pos-rng-proj (mk-rng-proj pos-value-blame))
446         (define mk-neg-rng-proj (mk-rng-proj neg-value-blame))
447         (with-contract-continuation-mark (cons blame neg-party)
448           (for ([(k v) (in-hash val)])
449             (pos-dom-proj k neg-party)
450             ((mk-pos-rng-proj k) v neg-party)))
451         val)])))
452
453(struct base-hash/dc (dom dep-rng here name-info immutable))
454(struct flat-hash/dc base-hash/dc ()
455  #:property prop:custom-write custom-write-property-proc
456  #:property prop:flat-contract
457  (build-flat-contract-property
458   #:trusted trust-me
459   #:name hash/dc-name
460   #:first-order hash/dc-first-order
461   #:equivalent hash/dc-equivalent
462   #:stronger hash/dc-stronger
463   #:late-neg-projection (hash/dc-late-neg-projection #f)))
464
465(struct chaperone-hash/dc base-hash/dc ()
466  #:property prop:custom-write custom-write-property-proc
467  #:property prop:chaperone-contract
468  (build-chaperone-contract-property
469   #:trusted trust-me
470   #:name hash/dc-name
471   #:first-order hash/dc-first-order
472   #:stronger hash/dc-stronger
473   #:equivalent hash/dc-equivalent
474   #:late-neg-projection (hash/dc-late-neg-projection chaperone-hash)))
475(struct impersonator-hash/dc base-hash/dc ()
476  #:property prop:custom-write custom-write-property-proc
477  #:property prop:contract
478  (build-contract-property
479   #:trusted trust-me
480   #:name hash/dc-name
481   #:first-order hash/dc-first-order
482   #:stronger hash/dc-stronger
483   #:equivalent hash/dc-equivalent
484   #:late-neg-projection (hash/dc-late-neg-projection impersonate-hash)))
485
486(define (build-hash/dc dom dep-rng here name-info immutable kind)
487  (unless (member kind '(flat chaperone impersonator))
488    (error 'hash/dc
489           "expected (or/c 'flat 'chaperone 'impersonator) for the #:kind argument, got ~s"
490           kind))
491  (cond
492    [(equal? kind 'flat)
493     (flat-hash/dc (coerce-flat-contract 'hash/dc dom)
494                   (λ (v) (coerce-flat-contract 'hash/dc (dep-rng v)))
495                   here name-info immutable)]
496    [(equal? kind 'chaperone)
497     (chaperone-hash/dc (coerce-chaperone-contract 'hash/dc dom)
498                        (λ (v) (coerce-chaperone-contract 'hash/dc (dep-rng v)))
499                        here name-info immutable)]
500    [else
501     (chaperone-hash/dc (coerce-contract 'hash/dc dom)
502                        (λ (v) (coerce-contract 'hash/dc (dep-rng v)))
503                        here name-info immutable)]))
504
505(define-syntax (hash/dc stx)
506  (syntax-case stx ()
507    [(_ [dom-id dom-ctc-expr] [rng-id (dom-id2) rng-ctc-expr] . more)
508     (begin
509       (unless (free-identifier=? #'dom-id2 #'dom-id)
510         (raise-syntax-error
511          'hash/dc
512          "expected the same identifier for the domain and the dependency"
513          stx
514          #'dom-id
515          (list #'dom-id2)))
516       (define immutable-expression #f)
517       (define kind-expression #f)
518       (let loop ([kwd-stx #'more])
519         (syntax-case kwd-stx ()
520           [() (void)]
521           [(#:immutable immutable . more)
522            (begin
523              (when immutable-expression
524                (raise-syntax-error 'hash/dc "multiple #:immutable arguments"
525                                    stx
526                                    immutable-expression
527                                    (list #'immutable)))
528              (set! immutable-expression #'immutable)
529              (loop #'more))]
530           [(#:kind kind . more)
531            (begin
532              (when kind-expression
533                (raise-syntax-error 'hash/dc "multiple #:kind arguments"
534                                    stx
535                                    kind-expression
536                                    (list #'kind)))
537              (set! kind-expression #'kind)
538              (loop #'more))]
539           [(x . y)
540            (raise-syntax-error 'hash/dc
541                                "expected either the keyword #:kind or #:immutable"
542                                stx
543                                #'x)]))
544       #`(build-hash/dc dom-ctc-expr
545                        (λ (dom-id2) rng-ctc-expr)
546                        (quote-module-name)
547                        '#(dom-id rng-id #,(compute-quoted-src-expression #'rng-ctc-expr))
548                        #,(or immutable-expression #''dont-care)
549                        #,(or kind-expression #''chaperone)))]))
550