suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

port id-table/c to flat-neg projection

Browse Source
This commit is contained in:
Robby Findler 2015-12-30 13:50:21 -06:00
parent 1c3422d420
commit a97aa8389b
1 changed files with 23 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
racket/collects/syntax/id-table.rkt
View File

@ -56,7 +56,7 @@
(let () (let ()
(define (proj acc location swap) (define (proj acc location swap)
(lambda (ctc blame) (lambda (ctc blame)
((contract-projection (acc ctc)) ((contract-late-neg-projection (acc ctc))
(blame-add-context blame location #:swap? swap)))) (blame-add-context blame location #:swap? swap))))
(values (values
(proj base-id-table/c-dom "the keys of" #f) (proj base-id-table/c-dom "the keys of" #f)
@ -96,51 +96,53 @@
(and (contract-first-order-passes? dom-ctc k) (and (contract-first-order-passes? dom-ctc k)
(contract-first-order-passes? rng-ctc v)))))) (contract-first-order-passes? rng-ctc v))))))
(define (check-id-table/c ctc val blame) (define (check-id-table/c ctc val blame neg-party)
(define immutable (base-id-table/c-immutable ctc)) (define immutable (base-id-table/c-immutable ctc))
(case immutable (case immutable
[(#t) [(#t)
(unless (immutable-idtbl? val) (unless (immutable-idtbl? val)
(raise-blame-error blame val (raise-blame-error blame val #:missing-party neg-party
'(expected "an immutable ~a," given: "~e") 'idtbl val))] '(expected "an immutable ~a," given: "~e") 'idtbl val))]
[(#f) [(#f)
(unless (mutable-idtbl? val) (unless (mutable-idtbl? val)
(raise-blame-error blame val (raise-blame-error blame val #:missing-party neg-party
'(expected "a mutable ~a," given: "~e") 'idtbl val))] '(expected "a mutable ~a," given: "~e") 'idtbl val))]
[(dont-care) [(dont-care)
(unless (idtbl? val) (unless (idtbl? val)
(raise-blame-error blame val (raise-blame-error blame val #:missing-party neg-party
'(expected "a ~a," given: "~e") 'idtbl val))])) '(expected "a ~a," given: "~e") 'idtbl val))]))
(define (fo-projection ctc) (define (late-neg-fo-projection ctc)
(λ (blame) (λ (blame)
(define dom-proj (id-table/c-dom-pos-proj ctc blame)) (define dom-proj (id-table/c-dom-pos-proj ctc blame))
(define rng-proj (id-table/c-rng-pos-proj ctc blame)) (define rng-proj (id-table/c-rng-pos-proj ctc blame))
(λ (val) (λ (val neg-party)
(check-id-table/c ctc val blame) (check-id-table/c ctc val blame neg-party)
(for ([(k v) (in-dict val)]) (for ([(k v) (in-dict val)])
(dom-proj k) (dom-proj k neg-party)
(rng-proj v)) (rng-proj v neg-party))
val))) val)))
(define (ho-projection ctc) (define (late-neg-ho-projection ctc)
(lambda (blame) (lambda (blame)
(define pos-dom-proj (id-table/c-dom-pos-proj ctc blame)) (define pos-dom-proj (id-table/c-dom-pos-proj ctc blame))
(define neg-dom-proj (id-table/c-dom-neg-proj ctc blame)) (define neg-dom-proj (id-table/c-dom-neg-proj ctc blame))
(define pos-rng-proj (id-table/c-rng-pos-proj ctc blame)) (define pos-rng-proj (id-table/c-rng-pos-proj ctc blame))
(define neg-rng-proj (id-table/c-rng-neg-proj ctc blame)) (define neg-rng-proj (id-table/c-rng-neg-proj ctc blame))
(lambda (tbl) (lambda (tbl neg-party)
(check-id-table/c ctc tbl blame) (check-id-table/c ctc tbl blame neg-party)
;;TODO for immutable hash tables optimize this chaperone to a flat ;;TODO for immutable hash tables optimize this chaperone to a flat
;;check if possible ;;check if possible
(if (immutable-idtbl? tbl) (if (immutable-idtbl? tbl)
(chaperone-immutable-id-table tbl pos-dom-proj pos-rng-proj (chaperone-immutable-id-table tbl
(λ (val) (pos-dom-proj val neg-party))
(λ (val) (pos-rng-proj val neg-party))
impersonator-prop:contracted ctc) impersonator-prop:contracted ctc)
(chaperone-mutable-id-table tbl (chaperone-mutable-id-table tbl
neg-dom-proj (λ (val) (neg-dom-proj val neg-party))
pos-dom-proj (λ (val) (pos-dom-proj val neg-party))
neg-rng-proj (λ (val) (neg-rng-proj val neg-party))
pos-rng-proj (λ (val) (pos-rng-proj val neg-party))
impersonator-prop:contracted ctc))))) impersonator-prop:contracted ctc)))))
(struct flat-id-table/c base-id-table/c () (struct flat-id-table/c base-id-table/c ()
@ -149,7 +151,7 @@
(build-flat-contract-property (build-flat-contract-property
#:name id-table/c-name #:name id-table/c-name
#:first-order id-table/c-first-order #:first-order id-table/c-first-order
#:projection fo-projection)) #:late-neg-projection late-neg-fo-projection))
(struct chaperone-id-table/c base-id-table/c () (struct chaperone-id-table/c base-id-table/c ()
#:omit-define-syntaxes #:omit-define-syntaxes
@ -157,7 +159,7 @@
(build-chaperone-contract-property (build-chaperone-contract-property
#:name id-table/c-name #:name id-table/c-name
#:first-order id-table/c-first-order #:first-order id-table/c-first-order
#:projection ho-projection)) #:late-neg-projection late-neg-ho-projection))
;; Note: impersonator contracts not currently supported. ;; Note: impersonator contracts not currently supported.
(struct impersonator-id-table/c base-id-table/c () (struct impersonator-id-table/c base-id-table/c ()
@ -166,7 +168,7 @@
(build-contract-property (build-contract-property
#:name id-table/c-name #:name id-table/c-name
#:first-order id-table/c-first-order #:first-order id-table/c-first-order
#:projection ho-projection)) #:late-neg-projection late-neg-ho-projection))
(define (id-table/c key/c value/c #:immutable [immutable 'dont-care]) (define (id-table/c key/c value/c #:immutable [immutable 'dont-care])
(define key/ctc (coerce-contract idtbl/c-symbol key/c)) (define key/ctc (coerce-contract idtbl/c-symbol key/c))