From e83c80577100a7f5770b2becb8061e53827a87b9 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 6 Oct 2013 18:08:24 -0700 Subject: [PATCH] Put static contracts in main repo. original commit: 43ce10b5fed9b145eb60e26de832811781ae5889 --- .../static-contracts/combinators.rkt | 17 ++ .../static-contracts/combinators/any.rkt | 33 ++++ .../combinators/case-lambda.rkt | 89 ++++++++++ .../static-contracts/combinators/control.rkt | 58 +++++++ .../static-contracts/combinators/derived.rkt | 14 ++ .../static-contracts/combinators/function.rkt | 146 +++++++++++++++++ .../static-contracts/combinators/object.rkt | 105 ++++++++++++ .../combinators/parametric.rkt | 39 +++++ .../static-contracts/combinators/simple.rkt | 45 +++++ .../static-contracts/combinators/struct.rkt | 45 +++++ .../combinators/structural.rkt | 129 +++++++++++++++ .../static-contracts/constraints.rkt | 151 +++++++++++++++++ .../static-contracts/equations.rkt | 48 ++++++ .../static-contracts/instantiate.rkt | 80 +++++++++ .../typed-racket/static-contracts/kinds.rkt | 37 +++++ .../static-contracts/optimize.rkt | 155 ++++++++++++++++++ .../static-contracts/structures.rkt | 118 +++++++++++++ 17 files changed, 1309 insertions(+) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/constraints.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/equations.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/kinds.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators.rkt new file mode 100644 index 00000000..52e9f0aa --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators.rkt @@ -0,0 +1,17 @@ +#lang racket/base + +(require (for-syntax racket/base racket/runtime-path)) + +(begin-for-syntax + (define-runtime-path combinator-dir "combinators") + (define base-file-names + (filter (lambda (v) (regexp-match? #rx".rkt$" v)) (directory-list combinator-dir))) + (define file-names (map (lambda (v) (string-append "combinators/" (path->string v))) + base-file-names))) + +(define-syntax (gen-provides stx) + #`(begin + (require #,@file-names) + (provide (all-from-out #,@file-names)))) + +(gen-provides) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt new file mode 100644 index 00000000..c6813262 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/any.rkt @@ -0,0 +1,33 @@ +#lang racket/base + +(require "../structures.rkt" "../constraints.rkt" + racket/match + (except-in racket/contract recursive-contract) + (for-template racket/base racket/contract/base) + (for-syntax racket/base racket/syntax syntax/parse)) + +(provide + (contract-out + [any/sc static-contract?]) + any/sc:) + + +;;Printing +(define (any-write-proc v port mode) + (if (equal? mode 0) + (display "any/sc" port) + (display "#" port))) + +(struct any-combinator combinator () + #:methods gen:sc + [(define (sc-map v f) v) + (define (sc->contract v f) #'any/c) + (define (sc->constraints v f) (simple-contract-restrict 'flat))] + #:methods gen:custom-write [(define write-proc any-write-proc)]) + +(define-match-expander any/sc: + (syntax-parser + [(_) #'(? any-combinator?)])) + +(define any/sc (any-combinator null)) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt new file mode 100644 index 00000000..bf77a295 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt @@ -0,0 +1,89 @@ +#lang racket/base + +(require "../structures.rkt" "../constraints.rkt" + racket/list racket/match + unstable/contract + (except-in racket/contract recursive-contract) + (for-template racket/base racket/contract/base) + (for-syntax racket/base syntax/parse)) + +(provide + (contract-out + [case->/sc ((listof arr-combinator?) . -> . static-contract?)] + [arr/sc (-> (listof static-contract?) + (maybe/c static-contract?) + (maybe/c (listof static-contract?)) + static-contract?)]) + case->/sc: + arr/sc:) + + +(define (case->/sc arrs) + (case-combinator arrs)) + +(define (arr/sc args rest range) + (arr-combinator (arr-seq args rest range))) + +(struct case-combinator combinator () + #:transparent + #:property prop:combinator-name "case->/sc" + #:methods gen:sc + [(define (sc-map v f) + (case-combinator (map (λ (a) (f a 'covariant)) (combinator-args v)))) + (define (sc->contract v f) + #`(case-> #,@(map f (combinator-args v)))) + (define (sc->constraints v f) + (merge-restricts* 'chaperone (map f (combinator-args v))))]) +(struct arr-combinator combinator () + #:transparent + #:property prop:combinator-name "arr/sc" + #:methods gen:sc + [(define (sc-map v f) + (arr-combinator (arr-seq-sc-map f (combinator-args v)))) + (define (sc->contract v f) + (match v + [(arr-combinator (arr-seq args rest range)) + (with-syntax ([(arg-stx ...) (map f args)] + [(rest-stx ...) (if rest #`(#:rest #,(f rest)) #'())] + [range-stx (if range #`(values #,@(map f range)) #'any)]) + #'(arg-stx ... rest-stx ... . -> . range-stx))])) + (define (sc->constraints v f) + (merge-restricts* 'chaperone (map f (arr-seq->list (combinator-args v)))))]) + +(define-match-expander case->/sc: + (syntax-parser + [(_ args ...) + #'(case->/combinator (list args ...))])) + +(define-match-expander arr/sc: + (syntax-parser + [(_ args rest range) + #'(arr-combinator (arr-seq args rest range))])) + + +(define (arr-seq-sc-map f seq) + (match seq + [(arr-seq args rest range) + (arr-seq + (map (λ (a) (f a 'contravariant)) args) + (and rest (f rest 'contravariant)) + (and range (map (λ (a) (f a 'covariant)) range)))])) + +(define (arr-seq->list seq) + (match seq + [(arr-seq args rest range) + (append + args + (if rest (list rest) empty) + (or range empty))])) + + +(struct arr-seq (args rest range) + #:transparent + #:property prop:sequence + (match-lambda + [(arr-seq args rest range) + (append + args + (if rest (list rest) empty) + (if range range empty))])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt new file mode 100644 index 00000000..055c7ce8 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt @@ -0,0 +1,58 @@ +#lang racket/base + +(require "../structures.rkt" "../constraints.rkt" + racket/list racket/match + unstable/contract + (except-in racket/contract recursive-contract) + (for-template racket/base racket/contract/base) + (for-syntax racket/base syntax/parse)) + +(provide + (contract-out + [prompt-tag/sc ((listof static-contract?) (maybe/c (listof static-contract?)) . -> . static-contract?)]) + prompt-tag/sc:) + +(struct prompt-tag-combinator combinator () + #:transparent + #:property prop:combinator-name "prompt-tag/sc" + #:methods gen:sc + [(define (sc-map v f) + (prompt-tag-combinator (pt-seq-map f (combinator-args v)))) + (define (sc->contract v f) + (match v + [(prompt-tag-combinator (pt-seq vals call-cc)) + (with-syntax ([(vals-stx ...) (map f vals)] + [(call-cc-stx ...) + (if call-cc + #`(#:call/cc (values #,@(map f call-cc))) + empty)]) + #'(prompt-tag/c vals-stx ... call-cc-stx ...))])) + (define (sc->constraints v f) + (merge-restricts* 'chaperone (map f (pt-seq->list (combinator-args v)))))]) + +(struct pt-seq (vals call-cc)) + +(define (prompt-tag/sc vals call-cc) + (prompt-tag-combinator (pt-seq vals call-cc))) + +(define-match-expander prompt-tag/sc: + (syntax-parser + [(_ vals call-cc) + #'(prompt-tag-combinator (pt-seq vals call-cc))])) + + + +(define (pt-seq-map f seq) + (match seq + [(pt-seq vals call-cc) + (define (f* a) (f a 'invariant)) + (pt-seq + (map f* vals) + (and call-cc (map f* call-cc)))])) + +(define (pt-seq->list seq) + (match seq + [(pt-seq vals call-cc) + (append + vals + (or call-cc empty))])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt new file mode 100644 index 00000000..d632770c --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt @@ -0,0 +1,14 @@ +#lang racket/base +(require "simple.rkt" + (for-template racket/base racket/set racket/promise)) +(provide (all-defined-out)) + +(define identifier?/sc (flat/sc #'identifier?)) +(define list?/sc (flat/sc #'list?)) +(define set?/sc (flat/sc #'set?)) +(define box?/sc (flat/sc #'box?)) +(define vector?/sc (flat/sc #'box?)) +(define syntax?/sc (flat/sc #'syntax?)) +(define promise?/sc (flat/sc #'promise?)) +(define hash?/sc (flat/sc #'hash?)) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt new file mode 100644 index 00000000..8ff946cd --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt @@ -0,0 +1,146 @@ +#lang racket/base + + +(require "../structures.rkt" "../constraints.rkt" + racket/list racket/match + (except-in racket/contract recursive-contract) + (for-template racket/base racket/contract/base) + (for-syntax racket/base racket/syntax syntax/parse)) + +(provide + (contract-out + [function/sc (-> (listof static-contract?) + (listof static-contract?) + (listof (list/c keyword? static-contract?)) + (listof (list/c keyword? static-contract?)) + (or/c #f static-contract?) + (or/c #f (listof static-contract?)) + static-contract?)]) + ->/sc:) + + +(struct function-combinator combinator (indices mand-kws opt-kws) + #:property prop:combinator-name "->/sc" + #:methods gen:equal+hash [(define (equal-proc a b recur) (function-sc-equal? a b recur)) + (define (hash-proc v recur) (function-sc-hash v recur)) + (define (hash2-proc v recur) (function-sc-hash2 v recur))] + #:methods gen:sc + [(define (sc->contract v f) (function-sc->contract v f)) + (define (sc-map v f) (function-sc-map v f)) + (define (sc->constraints v f) (function-sc-constraints v f))]) + +(define (split-function-args ctcs mand-args-end opt-args-end + mand-kw-args-end opt-kw-args-end rest-end range-end) + (values + (drop (take ctcs mand-args-end) 0) + (drop (take ctcs opt-args-end) mand-args-end) + (drop (take ctcs mand-kw-args-end) opt-args-end) + (drop (take ctcs opt-kw-args-end) mand-kw-args-end) + (and (> rest-end opt-kw-args-end) + (first (drop (take ctcs rest-end) opt-kw-args-end))) + (and range-end (drop (take ctcs range-end) rest-end)))) + +(define (function-sc->contract sc recur) + (match-define (function-combinator args indices mand-kws opt-kws) sc) + + (define-values (mand-ctcs opt-ctcs mand-kw-ctcs opt-kw-ctcs rest-ctc range-ctcs) + (apply split-function-args (map recur args) indices)) + + (define mand-kws-stx (append-map list mand-kws mand-kw-ctcs)) + (define opt-kws-stx (append-map list opt-kws opt-kw-ctcs)) + (define rest-ctc-stx + (if rest-ctc + (list '#:rest rest-ctc) + #'())) + + (define range-ctc + (if range-ctcs + #`(values #,@range-ctcs) + #'any)) + + + #`((#,@mand-ctcs #,@mand-kws-stx) + (#,@opt-ctcs #,@opt-kws-stx) + #,@rest-ctc-stx + . ->* . #,range-ctc)) + + +(define (function/sc mand-args opt-args mand-kw-args opt-kw-args rest range) + (define mand-args-end (length mand-args)) + (define opt-args-end (+ mand-args-end (length opt-args))) + (define mand-kw-args-end (+ opt-args-end (length mand-kw-args))) + (define opt-kw-args-end (+ mand-kw-args-end (length opt-kw-args))) + (define rest-end (if rest (add1 opt-kw-args-end) opt-kw-args-end)) + (define range-end (and range (+ rest-end (length range)))) + (define mand-kws (map first mand-kw-args)) + (define opt-kws (map first opt-kw-args)) + (define end-indices + (list mand-args-end opt-args-end mand-kw-args-end opt-kw-args-end rest-end range-end)) + + (function-combinator + (append + mand-args + opt-args + (map second mand-kw-args) + (map second opt-kw-args) + (if rest (list rest) null) + (or range null)) + end-indices + mand-kws + opt-kws)) + +(define-match-expander ->/sc: + (syntax-parser + [(_ mand-args opt-args mand-kw-args opt-kw-args rest range) + #'(and (? function-combinator?) + (app (match-lambda + [(function-combinator args indices mand-kws opt-kws) + (define-values (mand-args* opt-args* mand-kw-args* opt-kw-args* rest* range*) + (apply split-function-args args indices)) + (list + mand-args* opt-args* + (map list mand-kws mand-kw-args*) + (map list opt-kws opt-kw-args*) + rest* + range*)]) + (list mand-args opt-args mand-kw-args opt-kw-args rest range)))])) + +(define (function-sc-map v f) + (match-define (function-combinator args indices mand-kws opt-kws) v) + + (define-values (mand-args opt-args mand-kw-args opt-kw-args rest-arg range-args) + (apply split-function-args args indices)) + + (define new-args + (append + (map (lambda (arg) (f arg 'contravariant)) + (append mand-args opt-args mand-kw-args opt-kw-args (if rest-arg (list rest-arg) null))) + (if range-args + (map (lambda (arg) (f arg 'covariant)) + range-args) + empty))) + + + (function-combinator new-args indices mand-kws opt-kws)) + +(define (function-sc-constraints v f) + (match-define (function-combinator args indices mand-kws opt-kws) v) + (merge-restricts* 'chaperone (map f args))) + +(define (function-sc-equal? a b recur) + (match-define (function-combinator a-args a-indices a-mand-kws a-opt-kws) a) + (match-define (function-combinator b-args b-indices b-mand-kws b-opt-kws) b) + (and + (recur a-indices b-indices) + (recur a-mand-kws b-mand-kws) + (recur a-opt-kws b-opt-kws) + (recur a-args b-args))) + +(define (function-sc-hash v recur) + (match-define (function-combinator v-args v-indices v-mand-kws v-opt-kws) v) + (+ (recur v-indices) (recur v-mand-kws) (recur v-opt-kws) (recur v-args))) + +(define (function-sc-hash2 v recur) + (match-define (function-combinator v-args v-indices v-mand-kws v-opt-kws) v) + (+ (recur v-indices) (recur v-mand-kws) (recur v-opt-kws) (recur v-args))) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt new file mode 100644 index 00000000..922b7885 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt @@ -0,0 +1,105 @@ +#lang racket/base + +(require "../structures.rkt" "../constraints.rkt" + racket/list racket/match + unstable/contract + (except-in racket/contract recursive-contract) + (for-template racket/base racket/class) + (for-syntax racket/base syntax/parse)) + +(provide + (contract-out + [struct member-spec ([modifier symbol?] [id symbol?] [sc static-contract?])] + [object/sc ((listof object-member-spec?) . -> . static-contract?)] + [class/sc ((listof member-spec?) boolean? (listof identifier?) (listof identifier?) . -> . static-contract?)])) + + + +(struct member-spec (modifier id sc) #:transparent) + +(define field-modifiers '(field init init-field inherit-field)) +(define method-modifiers '(method inherit super inner override augment augride)) + +(struct object-combinator combinator () + #:transparent + #:property prop:combinator-name "object/sc" + #:methods gen:sc + [(define (sc-map v f) + (object-combinator (member-seq-sc-map f (combinator-args v)))) + (define (sc->contract v f) + (object/sc->contract v f)) + (define (sc->constraints v f) + (merge-restricts* 'impersonator (map f (member-seq->list (combinator-args v)))))]) + +(struct class-combinator combinator (opaque absent-fields absent-methods) + #:transparent + #:property prop:combinator-name "class/sc" + #:methods gen:sc + [(define (sc-map v f) + (match v + [(class-combinator args opaque absent-fields absent-methods) + (class-combinator (member-seq-sc-map f args) opaque absent-fields absent-methods)])) + (define (sc->contract v f) + (class/sc->contract v f)) + (define (sc->constraints v f) + (merge-restricts* 'impersonator (map f (member-seq->list (combinator-args v)))))]) + + +(define member-seq->list + (match-lambda + [(member-seq vals) + (filter-map member-spec-sc vals)])) + +(struct member-seq (vals) + #:property prop:sequence member-seq->list) + +(define (member-seq-sc-map f seq) + (match seq + [(member-seq vals) + (member-seq + (for/list ([v (in-list vals)]) + (match v + [(member-spec mod id sc) + (member-spec mod id (and sc (f sc 'invariant)))])))])) + +;; TODO make this the correct subset +(define object-member-spec? member-spec?) + +(define (object/sc specs) + (object-combinator (member-seq specs))) +(define (class/sc specs opaque absent-fields absent-methods) + (class-combinator (member-seq specs) opaque absent-fields absent-methods)) + +(define (wrap mod ctc) + (define mod-stx + (case mod + [(method) #f] + [(field) #'field] + [(init) #'init] + [(init-field) #'init-field] + [(inherit) #'inherit] + [(inherit-field) #'inherit-field] + [(super) #'super] + [(inner) #'inner] + [(override) #'override] + [(augment) #'augment] + [(augride) #'augride])) + (if mod-stx #`(#,mod-stx #,ctc) ctc)) + +(define ((member-spec->form f) v) + (match v + [(member-spec modifier id sc) + (with-syntax ([ctc-stx (and sc (f sc) empty)] + [id-stx id]) + (wrap modifier (if sc #`(#,id #,(f sc)) id)))])) + +(define (object/sc->contract v f) + (match v + [(object-combinator (member-seq vals)) + #`(object/c #,@(map (member-spec->form f) vals))])) +(define (class/sc->contract v f) + (match v + [(class-combinator (member-seq vals) opaque absent-fields absent-methods) + #`(class/c #,@(if opaque (list '#:opaque) empty) + #,@(map (member-spec->form f) vals) + (absent #,@absent-methods (field #,@absent-fields)))])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt new file mode 100644 index 00000000..d21e689e --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/parametric.rkt @@ -0,0 +1,39 @@ +#lang racket/base + +(require "../structures.rkt" "../constraints.rkt" + racket/list racket/match + unstable/contract + (except-in racket/contract recursive-contract) + (for-template racket/base racket/contract/parametric) + (for-syntax racket/base syntax/parse)) + +(provide + (contract-out + [parametric->/sc ((listof identifier?) static-contract? . -> . static-contract?)]) + parametric->/sc:) + + +(struct parametric-combinator combinator (vars) + #:transparent + #:property prop:combinator-name "parametric->/sc" + #:methods gen:sc + [(define (sc-map v f) + (match v + [(parametric-combinator (list arg) vars) + (parametric-combinator (list (f arg 'covariant)) vars)])) + (define (sc->contract v f) + (match v + [(parametric-combinator (list arg) vars) + #`(parametric->/c #,vars #,(f arg))])) + (define (sc->constraints v f) + (match v + [(parametric-combinator (list arg) vars) + (merge-restricts* 'impersonator (list (f arg)))]))]) + +(define (parametric->/sc vars body) + (parametric-combinator (list body) vars)) + +(define-match-expander parametric->/sc: + (syntax-parser + [(_ vars body) + #'(parametric-combinator (list body) vars)])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt new file mode 100644 index 00000000..6a733c27 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt @@ -0,0 +1,45 @@ +#lang racket/base + +(require + "../kinds.rkt" + "../structures.rkt" + "../constraints.rkt" + racket/list + racket/match + (except-in racket/contract recursive-contract)) + +(provide + (contract-out + [flat/sc (syntax? . -> . static-contract?)] + [chaperone/sc (syntax? . -> . static-contract?)] + [impersonator/sc (syntax? . -> . static-contract?)] + [flat/sc? predicate/c])) + +(define (simple-contract-write-proc v port mode) + (match-define (simple-contract _ syntax kind) v) + (define-values (open close) + (if (equal? mode 0) + (values "(" ")") + (values "#<" ">"))) + (display open port) + (fprintf port "~a/sc" kind) + (display " " port) + (write (syntax->datum syntax) port) + (display close port)) + + + +(struct simple-contract combinator (syntax kind) + #:methods gen:sc + [(define (sc-map v f) v) + (define (sc->contract v f) (simple-contract-syntax v)) + (define (sc->constraints v f) (simple-contract-restrict (simple-contract-kind v)))] + #:methods gen:custom-write [(define write-proc simple-contract-write-proc)]) + +(define (flat/sc ctc) (simple-contract null ctc 'flat)) +(define (chaperone/sc ctc) (simple-contract null ctc 'chaperone)) +(define (impersonator/sc ctc) (simple-contract null ctc 'impersonator)) + +(define (flat/sc? sc) + (and (simple-contract? sc) + (equal? 'flat (simple-contract-kind sc)))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt new file mode 100644 index 00000000..be683ce0 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt @@ -0,0 +1,45 @@ +#lang racket/base + +(require "../structures.rkt" "../constraints.rkt" + racket/list racket/match + unstable/contract + (except-in racket/contract recursive-contract) + (for-template racket/base racket/contract/base) + (for-syntax racket/base syntax/parse)) + +(provide + (contract-out + [struct/sc (identifier? boolean? (listof static-contract?) . -> . static-contract?)]) + struct/sc:) + + +(struct struct-combinator combinator (name mut?) + #:transparent + #:property prop:combinator-name "struct/sc" + #:methods gen:sc + [(define (sc-map v f) + (match v + [(struct-combinator args name mut?) + (struct-combinator (map (λ (a) (f a (if mut? 'invariant 'covariant))) args) + name mut?)])) + (define (sc->contract v f) + (match v + [(struct-combinator args name _) + #`(struct/c #,name #,@(map f args))])) + (define (sc->constraints v f) + (match v + [(struct-combinator args _ mut?) + (merge-restricts* + (if mut? 'chaperone 'flat) + (map (lambda (a) (if mut? + (add-constraint (f a) 'chaperone) + (f a))) + args))]))]) + +(define (struct/sc name mut? fields) + (struct-combinator fields name mut?)) + +(define-match-expander struct/sc: + (syntax-parser + [(_ name fields) + #'(struct-combinator fields name _)])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt new file mode 100644 index 00000000..26a10e80 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt @@ -0,0 +1,129 @@ +#lang racket/base +(require "../structures.rkt" + "../constraints.rkt" + racket/list racket/match + (for-syntax racket/base racket/syntax syntax/stx syntax/parse) + racket/set + unstable/contract + (for-template racket/base + racket/contract/base + racket/set + unstable/contract) + (except-in racket/contract recursive-contract)) + + +(begin-for-syntax + (define-syntax-class variance-keyword + #:attributes (variance) + [pattern (~and kw (~or #:covariant #:contravariant #:invariant)) + #:with variance (string->symbol (keyword->string (syntax-e (attribute kw))))]) + + (define-syntax-class contract-category-keyword + #:attributes (category category-stx) + [pattern (~and kw (~or #:flat #:chaperone #:impersonator)) + #:attr category (string->symbol (keyword->string (syntax-e (attribute kw)))) + #:with category-stx (attribute category)]) + + ;; TODO: Fix category when syntax parse is fixed + (define-syntax-class argument-description + #:attributes (variance name category category-stx) + [pattern ((~or (~optional c:contract-category-keyword) + (~once :variance-keyword)) ...) + #:attr name (generate-temporary) + #:attr category (or (attribute c.category) 'impersonator) + #:with category-stx (attribute category)]) + + (define-syntax-class static-combinator-form + #:attributes (name struct-name definition combinator2 ->restricts matcher provides map) + [pattern (name:id pos:argument-description ... ) + #:with struct-name (generate-temporary #'name) + #:with matcher-name (format-id #'name "~a:" #'name) + #:with definition + #'(define name (λ (pos.name ...) (struct-name (list pos.name ...)))) + #:with ->restricts + #'(lambda (v recur) + (for/list ([arg (in-list (combinator-args v))] + [kind (in-list (list 'pos.category-stx ...))]) + (add-constraint (recur arg) kind))) + #:attr combinator2 + #'(λ (constructor) (λ (pos.name ...) (constructor (list pos.name ...)))) + #:with matcher + #'(define-match-expander matcher-name + (syntax-parser + [(_ pos.name ...) + #'(struct-name (list pos.name ...))])) + #:with map + #'(lambda (v f) + (struct-name + (for/list ([a (in-list (combinator-args v))] + [kind (in-list (list 'pos.variance ...))]) + (f a kind)))) + #:with ctc + #`(-> #,@(stx-map (lambda (_) #'static-contract?) #'(pos ...)) static-contract?) + #:with provides #'(provide (contract-out [name ctc]) matcher-name)] + [pattern (name:id . rest:argument-description) + #:with struct-name (generate-temporary #'name) + #:with matcher-name (format-id #'name "~a:" #'name) + #:with definition #'(define name (λ args (struct-name args))) + #:attr combinator2 #'(λ (constructor) (λ args (constructor args))) + #:with ->restricts + #'(lambda (v recur) + (for/list ([arg (in-list (combinator-args v))]) + (add-constraint (recur arg) 'rest.category-stx))) + #:with matcher + #'(define-match-expander matcher-name + (syntax-parser + [(_ ctc (... ...)) + #'(struct-name _ (list ctc (... ...)))])) + #:with map + #'(lambda (v f) + (struct-name + (for/list ([a (in-list (combinator-args v))]) + (f a 'rest.variance)))) + #:with ctc + #'(->* () #:rest (listof static-contract?) static-contract?) + #:with provides #'(provide (contract-out [name ctc]) matcher-name)])) + + +(define-syntax (combinator-struct stx) + (syntax-parse stx + [(_ sc:static-combinator-form c:expr kind:contract-category-keyword) + #'(begin + (struct sc.struct-name combinator () + #:transparent + #:methods gen:sc + [(define sc-map sc.map) + (define (sc->contract v recur) + (apply + (sc.combinator2 (lambda (args) #`(c #,@args))) + (map recur (combinator-args v)))) + (define (sc->constraints v recur) + (merge-restricts* 'kind.category-stx (sc.->restricts v recur)))] + #:property prop:combinator-name (symbol->string 'sc.name)) + sc.matcher + sc.definition + sc.provides)])) + + +(define-syntax (combinator-structs stx) + (syntax-parse stx + [(_ (e ...) ...) + #`(begin + (combinator-struct e ...) ...)])) + +(combinator-structs + ((or/sc . (#:covariant)) or/c #:flat) + ((and/sc . (#:covariant)) and/c #:flat) + ((list/sc . (#:covariant)) list/c #:flat) + ((listof/sc (#:covariant)) listof #:flat) + ((cons/sc (#:covariant) (#:covariant)) cons/c #:flat) + ((set/sc (#:covariant #:chaperone)) set/c #:flat) + ((vector/sc . (#:invariant)) vector/c #:chaperone) + ((vectorof/sc (#:invariant)) vectorof #:chaperone) + ((promise/sc (#:covariant)) promise/c #:chaperone) + ((syntax/sc (#:covariant #:flat)) syntax/c #:flat) + ((hash/sc (#:invariant #:flat) (#:invariant)) hash/c #:chaperone) + ((box/sc (#:invariant)) box/c #:chaperone) + ((parameter/sc (#:contravariant) (#:covariant)) parameter/c #:chaperone) + ((sequence/sc . (#:covariant)) sequence/c #:impersonator) + ((continuation-mark-key/sc (#:invariant)) continuation-mark-key/c #:chaperone)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/constraints.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/constraints.rkt new file mode 100644 index 00000000..c889085a --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/constraints.rkt @@ -0,0 +1,151 @@ +#lang racket/base + +(require + racket/match + racket/list + racket/contract + racket/dict + racket/set + syntax/id-table + "kinds.rkt" + "equations.rkt") + +(provide + simple-contract-restrict + variable-contract-restrict + merge-restricts* + merge-restricts + add-constraint + close-loop + (contract-out + [exn:fail:constraint-failure? predicate/c] + [validate-constraints (contract-restrict? . -> . void?)]) + contract-restrict-recursive-values + + contract-restrict? + ) + +(module structs racket/base + (require racket/contract + racket/set + syntax/id-table + "kinds.rkt") + (provide + (contract-out + [struct constraint ([value kind-max?] [max contract-kind?])] + [struct kind-max ([variables free-id-table?] [max contract-kind?])] + [struct contract-restrict ([value kind-max?] + [recursive-values free-id-table?] + [constraints (set/c constraint?)])])) + + (struct constraint (value max) #:transparent) + (struct kind-max (variables max) #:transparent) + (struct contract-restrict (value recursive-values constraints) #:transparent)) +(require 'structs) +(provide (struct-out kind-max)) + +(struct exn:fail:constraint-failure exn:fail ()) + +(define (free-id-set . elems) + (for/fold ([table (make-immutable-free-id-table)]) + ([e (in-list elems)]) + (dict-set table e #t))) + +(define (free-id-set-union tables) + (for*/fold ([table (make-immutable-free-id-table)]) + ([new-table (in-list tables)] + [(k _) (in-dict new-table)]) + (dict-set table k #t))) + +(define (free-id-table-union tables) + (for*/fold ([table (make-immutable-free-id-table)]) + ([new-table (in-list tables)] + [(k v) (in-dict new-table)]) + (dict-set table k v))) + +(define (simple-contract-restrict kind) + (contract-restrict (kind-max (free-id-set) kind) (make-immutable-free-id-table) (set))) +(define (variable-contract-restrict var) + (contract-restrict (kind-max (free-id-set var) 'flat) (make-immutable-free-id-table) (set))) + + +(define (add-constraint cr max) + (if (equal? 'impersonator max) + cr + (match cr + [(contract-restrict v rec constraints) + (contract-restrict v rec (set-add constraints (constraint v max)))]))) + +(define (add-recursive-values cr dict) + (match cr + [(contract-restrict v rec constraints) + (contract-restrict v (free-id-table-union (list rec dict)) constraints)])) + +(define (merge-restricts* min crs) + (apply merge-restricts min crs)) + +(define (merge-restricts min . crs) + (match crs + [(list (contract-restrict vs rec constraints) ...) + (contract-restrict (merge-kind-maxes min vs) + (free-id-table-union rec) + (apply set-union (set) constraints))])) + +(define (merge-kind-maxes min-kind vs) + (match vs + [(list (kind-max variables maxes) ...) + (kind-max (free-id-set-union variables) (apply combine-kinds min-kind maxes))])) + +(define (close-loop names crs body) + (define eqs (make-equation-set)) + (define vars + (for*/hash ((name (in-list names))) + (values name + (add-variable! eqs (simple-contract-restrict 'flat))))) + (define (variable-lookup name) + (variable-ref (hash-ref vars name))) + + + (define (instantiate-cr cr lookup-id) + (match cr + [(contract-restrict (kind-max ids max) rec constraints) + (define-values (bound-ids unbound-ids) + (partition (lambda (id) (member id names)) (dict-keys ids))) + (merge-restricts* 'flat (cons + (contract-restrict + (kind-max (apply free-id-set unbound-ids) max) + rec + constraints) + (map lookup-id bound-ids)))])) + + (for ([name names] [cr crs]) + (add-equation! eqs + (hash-ref vars name) + (lambda () + (instantiate-cr cr variable-lookup)))) + + (define var-values (resolve-equations eqs)) + (define id-values + (for/hash (((name var) vars)) + (values name (hash-ref var-values var)))) + + (define new-rec-values + (for/hash (((name value) id-values)) + (values name (contract-restrict-value value)))) + + (for/fold ([cr (instantiate-cr body (lambda (id) (hash-ref id-values id)))]) + ([rec-values (cons new-rec-values (map contract-restrict-recursive-values + (hash-values id-values)))]) + (add-recursive-values cr rec-values))) + + + +(define (validate-constraints cr) + (match cr + [(contract-restrict (kind-max (app dict-count 0) _) rec constraints) + (for ([const (in-set constraints)]) + (match const + [(constraint (kind-max (app dict-count 0) kind) bound) + (unless (contract-kind<= kind bound) + (raise (exn:fail:constraint-failure "Violated constraint ~a" (current-continuation-marks))))]))])) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/equations.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/equations.rkt new file mode 100644 index 00000000..35cd58ae --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/equations.rkt @@ -0,0 +1,48 @@ +#lang racket + +(provide + make-equation-set + add-variable! + add-equation! + resolve-equations + variable-ref) + + +(struct var ()) + +; equations: (hash/c var? (-> value?)) +; initial-values: (hash/c var? (-> value?)) +(struct equation-set (equations initial-values)) + +(define (make-equation-set) + (equation-set (make-hash) (make-hash))) + +; add-variable!: (equation-set? value? -> var?) +(define (add-variable! eqs initial-value) + (define a-var (var)) + (hash-set! (equation-set-initial-values eqs) a-var initial-value) + a-var) + +; add-equation! (equation-set? var? (-> value?)) +(define (add-equation! eqs var thunk) + (hash-set! (equation-set-equations eqs) var thunk)) + +(define current-variable-values (make-parameter (hash))) + +(define (resolve-equations eqs) + (define values (hash-copy (equation-set-initial-values eqs))) + (parameterize ((current-variable-values values)) + (let loop () + (define change #f) + (for (((v thunk) (equation-set-equations eqs))) + (define new-value (thunk)) + (define old-value (hash-ref values v)) + (unless (equal? new-value old-value) + (set! change #t) + (hash-set! values v new-value))) + (when change + (loop))) + values)) + +(define (variable-ref v) + (hash-ref (current-variable-values) v)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt new file mode 100644 index 00000000..a3212134 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt @@ -0,0 +1,80 @@ +#lang racket/base + +(require + racket/function + racket/match + racket/dict + racket/sequence + (for-template racket/base (prefix-in c: racket/contract)) + "kinds.rkt" + "structures.rkt" + "constraints.rkt" + "equations.rkt") +(require (prefix-in c: racket/contract)) + +(provide + (c:contract-out + [instantiate ((static-contract? (c:-> c:none/c)) (contract-kind?) . c:->* . syntax?)])) + +(module* internals #f + (provide compute-constraints + compute-recursive-kinds + instantiate/inner)) + + +(define (instantiate sc fail [kind 'impersonator]) + (with-handlers [(exn:fail:constraint-failure? (lambda (exn) (fail)))] + (instantiate/inner sc + (compute-recursive-kinds + (contract-restrict-recursive-values (compute-constraints sc kind)))))) + +(define (compute-constraints sc max-kind) + (define (recur sc) + (match sc + [(recursive-contract names values body) + (close-loop names (map recur values) (recur body))] + [(? sc?) + (sc->constraints sc recur)])) + (define constraints (recur sc)) + (validate-constraints (add-constraint constraints max-kind)) + constraints) + + +(define (compute-recursive-kinds recursives) + (define eqs (make-equation-set)) + (define vars + (for/hash ([(name _) (in-dict recursives)]) + (values name (add-variable! eqs 'flat)))) + + (define (lookup id) + (variable-ref (hash-ref vars id))) + + (for ([(name v) (in-dict recursives)]) + (match v + [(kind-max others max) + (add-equation! eqs + (hash-ref vars name) + (lambda () + (apply combine-kinds max (map lookup (dict-keys others)))))])) + (define var-values (resolve-equations eqs)) + (for/hash (((name var) vars)) + (values name (hash-ref var-values var)))) + + +(define (instantiate/inner sc recursive-kinds) + (define (recur sc) + (match sc + [(recursive-contract names values body) + (define raw-names (generate-temporaries names)) + (define raw-bindings + (for/list ([raw-name raw-names] [value values]) + #`[#,raw-name #,(recur value)])) + (define bindings + (for/list ([name names] [raw-name raw-names]) + #`[#,name (c:recursive-contract #,raw-name + #,(kind->keyword + (hash-ref recursive-kinds name)))])) + #`(letrec (#,@bindings #,@raw-bindings) #,(recur body))] + [(? sc? sc) + (sc->contract sc recur)])) + (recur sc)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/kinds.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/kinds.rkt new file mode 100644 index 00000000..7c33821b --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/kinds.rkt @@ -0,0 +1,37 @@ +#lang racket/base + +(require racket/match racket/contract) + +(provide + (contract-out + [contract-kind? predicate/c] + [contract-kind<= (contract-kind? contract-kind? . -> . boolean?)] + [kind->keyword (contract-kind? . -> . keyword?)] + [combine-kinds ((contract-kind?) #:rest (listof contract-kind?) . ->* . contract-kind?)])) + +(define (contract-kind? v) + (case v + ((flat chaperone impersonator) #t) + (else #f))) + + +(define (contract-kind<= v1 v2) + (match* (v1 v2) + [('flat _) #t] + [('chaperone 'flat) #f] + [('chaperone (or 'chaperone 'impersonator)) #t] + [('impersonator (or 'flat 'chaperone)) #f] + [('impersonator 'impersonator) #t])) + +(define combine-kinds + (case-lambda + ((v) v) + ((v1 v2 . vs) + (define combined (if (contract-kind<= v1 v2) v2 v1)) + (apply combine-kinds combined vs)))) + +(define (kind->keyword kind) + (case kind + ((flat) '#:flat) + ((chaperone) '#:chaperone) + ((impersonator) '#:impersonator))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt new file mode 100644 index 00000000..0674acff --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt @@ -0,0 +1,155 @@ +#lang racket/base + +(require "combinators.rkt" + "structures.rkt" + racket/set + racket/list + (except-in racket/contract recursive-contract) + racket/match) + +(provide + (contract-out + [optimize (static-contract? (or/c 'covariant 'contravariant 'invariant ) . -> . static-contract?)])) + + +(define (any/sc-reduce sc) + (match sc + [(listof/sc: (any/sc:)) list?/sc] + [(vectorof/sc: (any/sc:)) vector?/sc] + [(set/sc: (any/sc:)) set?/sc] + [(box/sc: (any/sc:)) box?/sc] + [(syntax/sc: (any/sc:)) syntax?/sc] + [(promise/sc: (any/sc:)) promise?/sc] + [(hash/sc: (any/sc:) (any/sc:)) hash?/sc] + [(any/sc:) sc] + [else sc])) + + +(define (covariant-any/sc-reduce sc) + (match sc + [(->/sc: mand-args opt-args mand-kw-args opt-kw-args rest-arg (list (any/sc:) ...)) + (function/sc mand-args opt-args mand-kw-args opt-kw-args rest-arg #f)] + [(arr/sc: args rest (list (any/sc:) ...)) + (arr/sc args rest #f)] + [else sc])) + +(define (flat-reduce sc) + (match sc + [(? flat/sc?) + any/sc] + [sc sc])) + +(define (invert-variance v) + (case v + [(covariant) 'contravariant] + [(contravariant) 'covariant] + [(invariant) 'invariant])) + +(define (combine-variance var1 var2) + (case var1 + [(covariant) var2] + [(contravariant) (invert-variance var2)] + [(invariant) 'invariant])) + +(define (optimize sc variance) + (define (single-step sc variance) + (define ((maybe/co reduce) sc) + (case variance + [(covariant) (reduce sc)] + [(contravariant invariant) sc] + [else (error 'maybe/co "Bad variance ~a" variance)])) + + ((maybe/co flat-reduce) ((maybe/co covariant-any/sc-reduce) (any/sc-reduce sc)))) + + (define ((recur current-variance) sc variance) + (define new-variance (combine-variance current-variance variance)) + (single-step (sc-map sc (recur new-variance)) new-variance)) + ((recur variance) sc 'covariant)) + + +(module+ test + (require rackunit) + (provide optimizer-tests) + (define-check (check-optimize variance* argument* expected*) + (let ([variance variance*] + [argument argument*] + [expected expected*]) + (with-check-info* + (list (make-check-info 'original argument) + (make-check-expected expected)) + (lambda () + (let ([opt (optimize argument variance)]) + (with-check-info* (list (make-check-actual opt)) + (lambda () + (unless (equal? opt expected) + (fail-check))))))))) + + + (define optimizer-tests + (test-suite "Optimizer Tests" + (check-optimize 'covariant + (listof/sc any/sc) + any/sc) + (check-optimize 'contravariant + (listof/sc any/sc) + list?/sc) + (check-optimize 'covariant + (set/sc any/sc) + any/sc) + (check-optimize 'contravariant + (set/sc any/sc) + set?/sc) + (check-optimize 'covariant + (function/sc (list (listof/sc any/sc)) + (list) + (list) + (list) + #f + (list (listof/sc any/sc))) + (function/sc (list list?/sc) + (list) + (list) + (list) + #f + #f)) + (check-optimize 'contravariant + (function/sc (list (listof/sc any/sc)) + (list) + (list) + (list) + #f + (list (listof/sc any/sc))) + (function/sc (list any/sc) + (list) + (list) + (list) + #f + (list list?/sc))) + (check-optimize 'contravariant + (function/sc (list (listof/sc any/sc)) + (list) + (list) + (list) + #f + (list any/sc)) + (function/sc (list any/sc) + (list) + (list) + (list) + #f + (list any/sc))) + (check-optimize 'covariant + (case->/sc empty) + (case->/sc empty)) + (check-optimize 'contravariant + (case->/sc empty) + (case->/sc empty)) + (check-optimize 'covariant + (parameter/sc list?/sc (flat/sc #'symbol?)) + (parameter/sc list?/sc any/sc)) + (check-optimize 'contravariant + (case->/sc (list (arr/sc (list (listof/sc any/sc)) (listof/sc (set/sc any/sc)) (list (listof/sc any/sc))))) + (case->/sc (list (arr/sc (list any/sc) any/sc (list list?/sc))))) + (check-optimize 'covariant + (case->/sc (list (arr/sc (list (listof/sc any/sc)) (listof/sc (set/sc any/sc)) (list (listof/sc any/sc))))) + (case->/sc (list (arr/sc (list list?/sc) (listof/sc set?/sc) #f))))))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt new file mode 100644 index 00000000..9fa91f22 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt @@ -0,0 +1,118 @@ +#lang racket/base + +(require racket/match racket/list racket/generic + (except-in racket/contract recursive-contract) + "kinds.rkt" "constraints.rkt") + +(provide + (contract-out + (struct recursive-contract ([names (listof identifier?)] + [values (listof static-contract?)] + [body static-contract?])) + (struct recursive-contract-use ([name identifier?])) + (struct combinator ([args sequence?])) + [sc-map (static-contract? (static-contract? variance/c . -> . static-contract?) . -> . static-contract?)] + [sc->contract (static-contract? (static-contract? . -> . syntax?) . -> . syntax?)] + [sc->constraints (static-contract? (static-contract? . -> . contract-restrict?) . -> . contract-restrict?)] + [static-contract? predicate/c] + [sc? predicate/c] + ) + + + prop:combinator-name + gen:sc) + +(define variance/c (or/c 'covariant 'contravariant 'invariant)) + +(define (recursive-contract-write-proc v port mode) + (match-define (recursive-contract names vals body) v) + (define recur + (case mode + [(#t) write] + [(#f) display] + [else (lambda (p port) (print p port mode))])) + (define-values (open close) + (if (equal? mode 0) + (values "(" ")") + (values "#<" ">"))) + (display open port) + (fprintf port "rec/sc") + (display " (" port) + (define (recur-pair name val) + (fprintf port "(~a " (syntax->datum name)) + (recur val port) + (display ")" port)) + (recur-pair (first names) (first vals)) + (for ((name (rest names)) + (val (rest vals))) + (display " " port) + (recur-pair name val)) + (display ") " port) + (recur body port) + (display close port)) + +(define (recursive-contract-use-write-proc v port mode) + (display (syntax->datum (recursive-contract-use-name v)) port)) + +(define (combinator-write-proc v port mode) + (match-define (combinator args) v) + (define name (combinator-name v)) + (define recur + (case mode + [(#t) write] + [(#f) display] + [else (lambda (p port) (print p port mode))])) + (define-values (open close) + (if (equal? mode 0) + (values "(" ")") + (values "#<" ">"))) + (display open port) + (fprintf port name) + (for ((arg args)) + (display " " port) + (recur arg port)) + (display close port)) + +(define-values (prop:combinator-name + has-combinator-name? + combinator-name) + (make-struct-type-property 'combinator-name + (lambda (v _) + (unless (string? v) + (raise-argument-error + 'prop:combinator-name + "string?" + v)) + v))) + +(define-generics sc + [sc-map sc f] + [sc->contract sc f] + [sc->constraints sc f]) + + +(struct static-contract () + #:transparent + #:property prop:custom-print-quotable 'never) + +(struct recursive-contract static-contract (names values body) + #:transparent + #:methods gen:sc + [(define (sc-map v f) + (match v + [(recursive-contract names values body) + (recursive-contract names (map (λ (v) (f v 'covariant)) values) (f body 'covariant))]))] + #:methods gen:custom-write [(define write-proc recursive-contract-write-proc)]) + +(struct recursive-contract-use static-contract (name) + #:transparent + #:methods gen:sc + [(define (sc-map v f) v) + (define (sc->contract v f) (recursive-contract-use-name v)) + (define (sc->constraints v f) (variable-contract-restrict (recursive-contract-use-name v)))] + #:methods gen:custom-write [(define write-proc recursive-contract-use-write-proc)]) + +(struct combinator static-contract (args) + #:transparent + #:property prop:combinator-name "combinator/sc" + #:methods gen:custom-write [(define write-proc combinator-write-proc)])