diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 2b771b86b5..902719f243 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -1,17 +1,13 @@ (module contract mzscheme (require "private/contract.ss" "private/contract-arrow.ss" - "private/contract-util.ss" + "private/contract-guts.ss" "private/contract-ds.ss") (provide (all-from "private/contract-ds.ss") (all-from "private/contract-arrow.ss") - (all-from-except "private/contract-util.ss" - raise-contract-error - contract-proc - make-contract - contract-proc + (all-from-except "private/contract-guts.ss" build-compound-type-name) - (all-from-except "private/contract.ss"))) + (all-from "private/contract.ss"))) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index d853d62c68..0785353d47 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -1,7 +1,7 @@ (module contract-arrow mzscheme (require (lib "etc.ss") (lib "list.ss") - "contract-util.ss" + "contract-guts.ss" "class-internal.ss") (require-for-syntax (lib "list.ss") diff --git a/collects/mzlib/private/contract-ds.ss b/collects/mzlib/private/contract-ds.ss index 1170f20c71..ce7e9fd22b 100644 --- a/collects/mzlib/private/contract-ds.ss +++ b/collects/mzlib/private/contract-ds.ss @@ -1,6 +1,6 @@ (module contract-ds mzscheme - (require "contract-util.ss") + (require "contract-guts.ss") (require-for-syntax "contract-ds-helpers.ss" "contract-helpers.scm") diff --git a/collects/mzlib/private/contract-util.ss b/collects/mzlib/private/contract-guts.ss similarity index 94% rename from collects/mzlib/private/contract-util.ss rename to collects/mzlib/private/contract-guts.ss index e6f73404b5..777c7adfb1 100644 --- a/collects/mzlib/private/contract-util.ss +++ b/collects/mzlib/private/contract-guts.ss @@ -1,4 +1,4 @@ -(module contract-util mzscheme +(module contract-guts mzscheme (require "contract-helpers.scm" (lib "pretty.ss") (lib "list.ss")) @@ -81,7 +81,7 @@ (define bangers (make-struct-field-mutator set count 'field)) ...))))]))) - (define-values (proj-prop proj-pred? proj-get) + (define-values (proj-prop proj-pred? raw-proj-get) (make-struct-type-property 'contract-projection)) (define-values (name-prop name-pred? name-get) (make-struct-type-property 'contract-name)) @@ -90,6 +90,26 @@ (define-values (flat-prop flat-pred? flat-get) (make-struct-type-property 'contract-flat)) + (define-values (pos-proj-prop pos-proj-pred? pos-proj-get) + (make-struct-type-property 'contract-positive-projection)) + (define-values (neg-proj-prop neg-proj-pred? neg-proj-get) + (make-struct-type-property 'contract-negative-projection)) + + (define (proj-get ctc) + (cond + [(proj-pred? ctc) + (raw-proj-get ctc)] + [(and (neg-proj-pred? ctc) + (pos-proj-pred? ctc)) + (let ([pos-abs (pos-proj-get ctc)] + [neg-abs (pos-proj-get ctc)]) + (λ (pos neg src-info str) + (let ([p-proj (pos-abs pos src-info str)] + [n-proj (neg-abs neg src-info str)]) + (lambda (v) + (n-proj (p-proj v))))))] + [else (error 'proj-get "unknown ~e" ctc)])) + ;; contract-stronger? : contract contract -> boolean ;; indicates if one contract is stronger (ie, likes fewer values) than another ;; this is not a total order. diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index 617009b211..247b01e4f8 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -23,7 +23,7 @@ add struct contracts for immutable structs? (lib "list.ss") (lib "pretty.ss") "contract-arrow.ss" - "contract-util.ss") + "contract-guts.ss") (require "contract-helpers.scm") (require-for-syntax (prefix a: "contract-helpers.scm")) diff --git a/collects/plai/private/datatype-core.ss b/collects/plai/private/datatype-core.ss index ace7e723b5..66b4d8ce85 100644 --- a/collects/plai/private/datatype-core.ss +++ b/collects/plai/private/datatype-core.ss @@ -7,9 +7,7 @@ (module datatype-core mzscheme (require (lib "pconvert-prop.ss") - (lib "contract.ss" "mzlib" "private") - (lib "contract-util.ss" "mzlib" "private") - (lib "contract-arrow.ss" "mzlib" "private")) + (lib "contract.ss")) (require-for-syntax "core-utils.ss") (provide define-datatype-core