Put static contracts in main repo.
This commit is contained in:
Eric Dobson
parent
8f461f9f88
commit
43ce10b5fe
|
|
@ -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)
|
||||
|
|
@ -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 "#<any/sc>" 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))
|
||||
|
||||
|
|
@ -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))]))
|
||||
|
|
@ -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))]))
|
||||
|
|
@ -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?))
|
||||
|
||||
|
|
@ -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)))
|
||||
|
||||
|
|
@ -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)))]))
|
||||
|
|
@ -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)]))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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 _)]))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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))))]))]))
|
||||
|
||||
|
|
@ -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))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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)))))))
|
||||
|
|
@ -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)])
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require tests/typed-racket/unit-tests/test-utils
|
||||
(for-syntax scheme/base)
|
||||
(for-template scheme/base)
|
||||
(types abbrev numeric-tower union)
|
||||
rackunit
|
||||
"types.rkt" "instantiate.rkt")
|
||||
|
||||
(define-syntax-rule (t e)
|
||||
(test-not-exn (format "~a" e) (lambda () (type->contract e (lambda _ (error "type could not be converted to contract"))))))
|
||||
|
||||
(define-namespace-anchor anchor)
|
||||
(define ns (namespace-anchor->empty-namespace anchor))
|
||||
|
||||
(define-syntax-rule (t/sc e)
|
||||
(test-case (format "~a" e)
|
||||
(define sc
|
||||
(type->static-contract e (lambda _ (error "type could not be converted to static-contract"))))
|
||||
(with-check-info (['static-contract sc])
|
||||
(define ctc (instantiate sc (lambda _ (error "static-contract could not be converted to a contract"))))
|
||||
(with-check-info (['contract (syntax->datum ctc)])
|
||||
(eval-syntax ctc ns)))))
|
||||
|
||||
(define-syntax-rule (t/fail e)
|
||||
(test-not-exn (format "~a" e) (lambda ()
|
||||
(let/ec exit
|
||||
(type->static-contract e (lambda _ (exit #t)))
|
||||
(error "type could be converted to contract")))))
|
||||
|
||||
(define-syntax-rule (t/fail-import e)
|
||||
(test-not-exn (format "~a" e) (lambda ()
|
||||
(let/ec exit
|
||||
(type->static-contract e (lambda _ (exit #t)) #:typed-side #f)
|
||||
(error "type could be converted to contract")))))
|
||||
|
||||
|
||||
(define contract-tests
|
||||
(test-suite "Contract Tests"
|
||||
(t/sc (-Number . -> . -Number))
|
||||
(t/sc (cl->* (-> -Symbol)
|
||||
(-Symbol . -> . -Symbol)))
|
||||
(t/sc (cl->* (-> -Symbol)
|
||||
(-Symbol -Symbol . -> . -Symbol)))
|
||||
(t/sc (cl->* (-Symbol . -> . -Symbol)
|
||||
(-Symbol -Symbol . -> . -Symbol)))
|
||||
(t/sc (-Promise -Number))
|
||||
(t/sc (-lst -Symbol))
|
||||
(t/sc -Boolean)
|
||||
(t/sc Univ)
|
||||
(t/sc (-set Univ))
|
||||
(t/sc (-poly (a) (-lst a)))
|
||||
(t/fail ((-poly (a) (-vec a)) . -> . -Symbol))
|
||||
(t/fail-import (-poly (a) (-lst a)))
|
||||
(t/sc (-mu a (-lst a)))
|
||||
(t/sc (-mu a (-box a)))
|
||||
(t/sc (-mu sexp (Un (-val '()) -Symbol (-pair sexp sexp) (-vec sexp) (-box sexp))))
|
||||
(t/sc (-mu a (-> a a)))
|
||||
(t/sc (-seq -Symbol))
|
||||
))
|
||||
|
||||
|
||||
(require (submod "optimize.rkt" test))
|
||||
(define all-tests
|
||||
(test-suite "All Tests"
|
||||
contract-tests
|
||||
optimizer-tests))
|
||||
|
||||
(require rackunit/text-ui)
|
||||
(void (run-tests all-tests))
|
||||
|
||||
|
|
@ -0,0 +1,391 @@
|
|||
#lang racket
|
||||
|
||||
(require
|
||||
"combinators.rkt"
|
||||
typed-racket/utils/utils
|
||||
syntax/parse
|
||||
(rep type-rep filter-rep object-rep)
|
||||
(typecheck internal-forms)
|
||||
(utils tc-utils require-contract any-wrap)
|
||||
(env type-name-env)
|
||||
(types resolve utils)
|
||||
(prefix-in t: (types abbrev numeric-tower))
|
||||
(private parse-type)
|
||||
racket/match unstable/match syntax/struct syntax/stx racket/syntax racket/list
|
||||
(only-in racket/contract -> ->* case-> cons/c flat-rec-contract contract-out any/c)
|
||||
(for-template racket/base racket/contract racket/set (utils any-wrap)
|
||||
(prefix-in t: (types numeric-predicates))
|
||||
(only-in unstable/contract sequence/c)))
|
||||
|
||||
(require "structures.rkt" "combinators.rkt")
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[type->static-contract
|
||||
(parametric->/c (a) ((Type/c (-> a)) (#:typed-side boolean?) . ->* . (or/c a static-contract?)))]))
|
||||
|
||||
(define any-wrap/sc (chaperone/sc #'any-wrap/c))
|
||||
|
||||
(define (no-duplicates l)
|
||||
(= (length l) (length (remove-duplicates l))))
|
||||
|
||||
(define (from-typed? side)
|
||||
(case side
|
||||
[(typed both) #t]
|
||||
[(untyped) #f]))
|
||||
|
||||
(define (from-untyped? side)
|
||||
(case side
|
||||
[(untyped both) #t]
|
||||
[(typed) #f]))
|
||||
|
||||
(define (flip-side side)
|
||||
(case side
|
||||
[(typed) 'untyped]
|
||||
[(untyped) 'typed]
|
||||
[(both) 'both]))
|
||||
|
||||
(struct triple (untyped typed both))
|
||||
(define (triple-lookup trip side)
|
||||
(case side
|
||||
((untyped) (triple-untyped trip))
|
||||
((typed) (triple-typed trip))
|
||||
((both) (triple-both trip))))
|
||||
(define (same sc)
|
||||
(triple sc sc sc))
|
||||
|
||||
|
||||
(define (type->static-contract type init-fail #:typed-side [typed-side #t])
|
||||
(let/ec return
|
||||
(define (fail) (return (init-fail)))
|
||||
(let loop ([type type] [typed-side (if typed-side 'typed 'untyped)] [recursive-values (hash)])
|
||||
(define (t->sc t #:recursive-values (recursive-values recursive-values))
|
||||
(loop t typed-side recursive-values))
|
||||
(define (t->sc/neg t #:recursive-values (recursive-values recursive-values))
|
||||
(loop t (flip-side typed-side) recursive-values))
|
||||
(define (t->sc/both t #:recursive-values (recursive-values recursive-values))
|
||||
(loop t 'both recursive-values))
|
||||
(define (t->sc/method t) (t->sc/function t fail typed-side recursive-values loop #t))
|
||||
(define (t->sc/fun t) (t->sc/function t fail typed-side recursive-values loop #f))
|
||||
(match type
|
||||
[(or (App: _ _ _) (Name: _)) (t->sc (resolve-once type))]
|
||||
[(Univ:) (if (from-typed? typed-side) any-wrap/sc any/sc)]
|
||||
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
|
||||
(listof/sc (t->sc elem-ty))]
|
||||
[t (=> fail) (or (numeric-type->static-contract t) (fail))]
|
||||
[(Base: sym cnt _ _)
|
||||
(flat/sc #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt)))]
|
||||
[(Refinement: par p?)
|
||||
(and/sc (t->sc par) (flat/sc p?))]
|
||||
[(Union: elems)
|
||||
(apply or/sc (map t->sc elems))]
|
||||
[(and t (Function: _)) (t->sc/fun t)]
|
||||
[(Set: t) (set/sc (t->sc t))]
|
||||
[(Sequence: ts) (apply sequence/sc (map t->sc ts))]
|
||||
[(Vector: t) (vectorof/sc (t->sc/both t))]
|
||||
[(HeterogeneousVector: ts) (apply vector/sc (map t->sc/both ts))]
|
||||
[(Box: t) (box/sc (t->sc/both t))]
|
||||
[(Pair: t1 t2)
|
||||
(cons/sc (t->sc t1) (t->sc t2))]
|
||||
[(Promise: t)
|
||||
(promise/sc (t->sc t))]
|
||||
[(Opaque: p?)
|
||||
(flat/sc #`(flat-named-contract (quote #,(syntax-e p?)) #,p?))]
|
||||
[(Continuation-Mark-Keyof: t)
|
||||
(continuation-mark-key/sc (t->sc t))]
|
||||
;; TODO: this is not quite right for case->
|
||||
[(Prompt-Tagof: s (Function: (list (arr: (list ts ...) _ _ _ _))))
|
||||
(prompt-tag/sc (map t->sc ts) (t->sc s))]
|
||||
;; TODO
|
||||
[(F: v)
|
||||
(triple-lookup
|
||||
(hash-ref recursive-values v
|
||||
(λ () (error 'type->static-contract
|
||||
"Recursive value lookup failed. ~a ~a" recursive-values v)))
|
||||
typed-side)]
|
||||
[(Poly: vs b)
|
||||
(if (not (from-untyped? typed-side))
|
||||
;; in positive position, no checking needed for the variables
|
||||
(let ((recursive-values (for/fold ([rv recursive-values]) ([v vs])
|
||||
(hash-set rv v (same any/sc)))))
|
||||
(t->sc b #:recursive-values recursive-values))
|
||||
;; in negative position, use parameteric contracts.
|
||||
(match-let ([(Poly-names: vs-nm b) type])
|
||||
(define function-type?
|
||||
(let loop ([ty b])
|
||||
(match (resolve ty)
|
||||
[(Function: _) #t]
|
||||
[(Union: elems) (andmap loop elems)]
|
||||
[(Poly: _ body) (loop body)]
|
||||
[(PolyDots: _ body) (loop body)]
|
||||
[_ #f])))
|
||||
(unless function-type?
|
||||
(fail))
|
||||
(let ((temporaries (generate-temporaries vs-nm)))
|
||||
(define rv (for/fold ((rv recursive-values)) ((temp temporaries)
|
||||
(v-nm vs-nm))
|
||||
(hash-set rv v-nm (same (impersonator/sc temp)))))
|
||||
(parametric->/sc temporaries
|
||||
(t->sc b #:recursive-values rv)))))]
|
||||
[(Mu: n b)
|
||||
(match-define (and n*s (list untyped-n* typed-n* both-n*)) (generate-temporaries (list n n n)))
|
||||
(define rv
|
||||
(hash-set recursive-values n
|
||||
(triple (recursive-contract-use untyped-n*)
|
||||
(recursive-contract-use typed-n*)
|
||||
(recursive-contract-use both-n*))))
|
||||
(case typed-side
|
||||
[(both) (recursive-contract
|
||||
(list both-n*)
|
||||
(list (loop b 'both rv))
|
||||
(recursive-contract-use both-n*))]
|
||||
[(typed untyped)
|
||||
;; TODO not fail in cases that don't get used
|
||||
(define untyped (loop b 'untyped rv))
|
||||
(define typed (loop b 'typed rv))
|
||||
(define both (loop b 'both rv))
|
||||
|
||||
(recursive-contract
|
||||
n*s
|
||||
(list untyped typed both)
|
||||
(recursive-contract-use (if (from-typed? typed-side) typed-n* untyped-n*)))])]
|
||||
[(Instance: (? Mu? t))
|
||||
(t->sc (make-Instance (resolve-once t)))]
|
||||
[(Instance: (Class: _ _ (list (list names functions) ...)))
|
||||
(object/sc (map (λ (n sc) (member-spec 'method n sc)) names (map t->sc/method functions)))]
|
||||
;; init args not currently handled by class/c
|
||||
[(Class: _ (list (list by-name-inits by-name-init-tys _) ...) (list (list names functions) ...))
|
||||
(class/sc (append
|
||||
(map (λ (n sc) (member-spec 'method n sc))
|
||||
names (map t->sc/method functions))
|
||||
(map (λ (n sc) (member-spec 'init n sc))
|
||||
by-name-inits (map t->sc/neg by-name-init-tys)))
|
||||
#f empty empty)]
|
||||
[(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred?)
|
||||
(cond
|
||||
[(dict-ref recursive-values nm #f)]
|
||||
[proc (fail)]
|
||||
[poly?
|
||||
(define nm* (generate-temporary #'n*))
|
||||
(define fields
|
||||
(for/list ([fty flds] [mut? mut?])
|
||||
(t->sc fty #:recursive-values (hash-set
|
||||
recursive-values
|
||||
nm (recursive-contract-use nm*)))))
|
||||
(recursive-contract (list nm*) (list (struct/sc nm (ormap values mut?) fields))
|
||||
(recursive-contract-use nm*))]
|
||||
[else (flat/sc #`(flat-named-contract '#,(syntax-e pred?) #,pred?))])]
|
||||
[(Syntax: (Base: 'Symbol _ _ _)) identifier?/sc]
|
||||
[(Syntax: t)
|
||||
(syntax/sc (t->sc t))]
|
||||
[(Value: v)
|
||||
(flat/sc #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v))))]
|
||||
[(Param: in out)
|
||||
(parameter/sc (t->sc in) (t->sc out))]
|
||||
[(Hashtable: k v)
|
||||
(hash/sc (t->sc k) (t->sc v))]
|
||||
[else
|
||||
(fail)]))))
|
||||
|
||||
(define (t->sc/function f fail typed-side recursive-values loop method?)
|
||||
(define (t->sc t #:recursive-values (recursive-values recursive-values))
|
||||
(loop t typed-side recursive-values))
|
||||
(define (t->sc/neg t #:recursive-values (recursive-values recursive-values))
|
||||
(loop t (flip-side typed-side) recursive-values))
|
||||
(match f
|
||||
[(Function: (list (top-arr:))) (case->/sc empty)]
|
||||
[(Function: arrs)
|
||||
;; Try to generate a single `->*' contract if possible.
|
||||
;; This allows contracts to be generated for functions with both optional and keyword args.
|
||||
;; (and don't otherwise require full `case->')
|
||||
(define conv (match-lambda [(Keyword: kw kty _) (list kw (t->sc/neg kty))]))
|
||||
(define (partition-kws kws) (partition (match-lambda [(Keyword: _ _ mand?) mand?]) kws))
|
||||
(define (process-dom dom*) (if method? (cons any/sc dom*) dom*))
|
||||
(cond
|
||||
;; To generate a single `->*', everything must be the same for all arrs, except for positional
|
||||
;; arguments which can increase by at most one each time.
|
||||
;; Note: optional arguments can only increase by 1 each time, to avoid problems with
|
||||
;; functions that take, e.g., either 2 or 6 arguments. These functions shouldn't match,
|
||||
;; since this code would generate contracts that accept any number of arguments between
|
||||
;; 2 and 6, which is wrong.
|
||||
;; TODO sufficient condition, but may not be necessary
|
||||
[(and
|
||||
(> (length arrs) 1)
|
||||
;; Keyword args, range and rest specs all the same.
|
||||
(let* ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws)
|
||||
(list rng rest-spec kws)])
|
||||
arrs)]
|
||||
[first-x (first xs)])
|
||||
(for/and ([x (in-list (rest xs))])
|
||||
(equal? x first-x)))
|
||||
;; Positionals are monotonically increasing by at most one.
|
||||
(let-values ([(_ ok?)
|
||||
(for/fold ([positionals (arr-dom (first arrs))]
|
||||
[ok-so-far? #t])
|
||||
([arr (in-list (rest arrs))])
|
||||
(match arr
|
||||
[(arr: dom _ _ _ _)
|
||||
(define ldom (length dom))
|
||||
(define lpositionals (length positionals))
|
||||
(values dom
|
||||
(and ok-so-far?
|
||||
(or (= ldom lpositionals)
|
||||
(= ldom (add1 lpositionals)))
|
||||
(equal? positionals (take dom lpositionals))))]))])
|
||||
ok?))
|
||||
(match* ((first arrs) (last arrs))
|
||||
[((arr: first-dom (Values: (list (Result: rngs (FilterSet: (Top:) (Top:)) (Empty:)) ...)) rst #f kws)
|
||||
(arr: last-dom _ _ _ _)) ; all but dom is the same for all
|
||||
(define mand-args (map t->sc/neg first-dom))
|
||||
(define opt-args (map t->sc/neg (drop last-dom (length first-dom))))
|
||||
(define-values (mand-kws opt-kws)
|
||||
(let*-values ([(mand-kws opt-kws) (partition-kws kws)])
|
||||
(values (map conv mand-kws)
|
||||
(map conv opt-kws))))
|
||||
(define range (map t->sc rngs))
|
||||
(define rest (and rst (listof/sc (t->sc/neg rst))))
|
||||
(function/sc (process-dom mand-args) opt-args mand-kws opt-kws rest range)])]
|
||||
[else
|
||||
(define ((f [case-> #f]) a)
|
||||
(define (convert-arr arr)
|
||||
(match arr
|
||||
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f kws)
|
||||
(let-values ([(mand-kws opt-kws) (partition-kws kws)])
|
||||
;; Garr, I hate case->!
|
||||
(when (and (not (empty? kws)) case->)
|
||||
(fail))
|
||||
(if case->
|
||||
(arr/sc (map t->sc/neg dom) (and rst (t->sc/neg rst)) (map t->sc rngs))
|
||||
(function/sc
|
||||
(process-dom (map t->sc/neg dom))
|
||||
null
|
||||
(map conv mand-kws)
|
||||
(map conv opt-kws)
|
||||
(and rst (listof/sc (t->sc/neg rst)))
|
||||
(map t->sc rngs))))]))
|
||||
(match a
|
||||
;; functions with no filters or objects
|
||||
[(arr: dom (Values: (list (Result: rngs (FilterSet: (Top:) (Top:)) (Empty:)) ...)) rst #f kws)
|
||||
(convert-arr a)]
|
||||
;; functions with filters or objects
|
||||
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f kws)
|
||||
(if (from-untyped? typed-side)
|
||||
(fail)
|
||||
(convert-arr a))]
|
||||
[_ (fail)]))
|
||||
(unless (no-duplicates (for/list ([t arrs])
|
||||
(match t
|
||||
[(arr: dom _ _ _ _) (length dom)]
|
||||
;; is there something more sensible here?
|
||||
[(top-arr:) (int-err "got top-arr")])))
|
||||
(fail))
|
||||
(if (= (length arrs) 1)
|
||||
((f #f) (first arrs))
|
||||
(case->/sc (map (f #t) arrs)))])]
|
||||
[_ (int-err "not a function" f)]))
|
||||
|
||||
(define-syntax-rule (numeric/sc name body)
|
||||
(flat/sc #'(flat-named-contract 'name body)))
|
||||
(module predicates racket/base
|
||||
(provide nonnegative? nonpositive?)
|
||||
(define nonnegative? (lambda (x) (>= x 0)))
|
||||
(define nonpositive? (lambda (x) (<= x 0))))
|
||||
(require (for-template 'predicates))
|
||||
|
||||
(define positive-byte/sc (numeric/sc Positive-Byte (and/c byte? positive?)))
|
||||
(define byte/sc (numeric/sc Byte byte?))
|
||||
(define positive-index/sc (numeric/sc Positive-Index (and/c t:index? positive?)))
|
||||
(define index/sc (numeric/sc Index t:index?))
|
||||
(define positive-fixnum/sc (numeric/sc Positive-Fixnum (and/c fixnum? positive?)))
|
||||
(define nonnegative-fixnum/sc (numeric/sc Nonnegative-Fixnum (and/c fixnum? nonnegative?)))
|
||||
(define nonpositive-fixnum/sc (numeric/sc Nonpositive-Fixnum (and/c fixnum? nonpositive?)))
|
||||
(define fixnum/sc (numeric/sc Fixnum fixnum?))
|
||||
(define positive-integer/sc (numeric/sc Positive-Integer (and/c exact-integer? positive?)))
|
||||
(define natural/sc (numeric/sc Natural exact-nonnegative-integer?))
|
||||
(define negative-integer/sc (numeric/sc Negative-Integer (and/c exact-integer? negative?)))
|
||||
(define nonpositive-integer/sc (numeric/sc Nonpositive-Integer (and/c exact-integer? nonpostive?)))
|
||||
(define integer/sc (numeric/sc Integer exact-integer?))
|
||||
(define positive-rational/sc (numeric/sc Positive-Rational (and/c t:exact-rational? positive?)))
|
||||
(define nonnegative-rational/sc (numeric/sc Nonnegative-Rational (and/c t:exact-rational? nonnegative?)))
|
||||
(define negative-rational/sc (numeric/sc Negative-Rational (and/c t:exact-rational? negative?)))
|
||||
(define nonpositive-rational/sc (numeric/sc Nonpositive-Rational (and/c t:exact-rational? nonpositive?)))
|
||||
(define rational/sc (numeric/sc Rational t:exact-rational?))
|
||||
(define flonum-zero/sc (numeric/sc Float-Zero (and/c flonum? zero?)))
|
||||
(define nonnegative-flonum/sc (numeric/sc Nonnegative-Float (and/c flonum? nonnegative?)))
|
||||
(define nonpositive-flonum/sc (numeric/sc Nonpositive-Float (and/c flonum? nonpositive?)))
|
||||
(define flonum/sc (numeric/sc Float flonum?))
|
||||
(define single-flonum-zero/sc (numeric/sc Single-Flonum-Zero (and/c single-flonum? zero?)))
|
||||
(define inexact-real-zero/sc (numeric/sc Inexact-Real-Zero (and/c inexact-real? zero?)))
|
||||
(define positive-inexact-real/sc (numeric/sc Positive-Inexact-Real (and/c inexact-real? positive?)))
|
||||
(define nonnegative-single-flonum/sc (numeric/sc Nonnegative-Single-Flonum (and/c single-flonum? nonnegative?)))
|
||||
(define nonnegative-inexact-real/sc (numeric/sc Nonnegative-Inexact-Real (and/c inexact-real? nonpositive?)))
|
||||
(define negative-inexact-real/sc (numeric/sc Negative-Inexact-Real (and/c inexact-real? negative?)))
|
||||
(define nonpositive-single-flonum/sc (numeric/sc Nonpositive-Single-Flonum (and/c single-flonum? nonnegative?)))
|
||||
(define nonpositive-inexact-real/sc (numeric/sc Nonpositive-Inexact-Real (and/c inexact-real? nonpositive?)))
|
||||
(define single-flonum/sc (numeric/sc Single-Flonum single-flonum?))
|
||||
(define inexact-real/sc (numeric/sc Inexact-Real inexact-real?))
|
||||
(define real-zero/sc (numeric/sc Real-Zero (and/c real? zero?)))
|
||||
(define positive-real/sc (numeric/sc Positive-Real (and/c real? positive?)))
|
||||
(define nonnegative-real/sc (numeric/sc Nonnegative-Real (and/c real? nonnegative?)))
|
||||
(define negative-real/sc (numeric/sc Negative-Real (and/c real? negative?)))
|
||||
(define nonpositive-real/sc (numeric/sc Nonpositive-Real (and/c real? nonpositive?)))
|
||||
(define real/sc (numeric/sc Real real?))
|
||||
(define exact-number/sc (numeric/sc Exact-Number (and/c number? exact?)))
|
||||
(define inexact-complex/sc
|
||||
(numeric/sc Inexact-Complex
|
||||
(and/c number?
|
||||
(lambda (x)
|
||||
(and (inexact-real? (imag-part x))
|
||||
(inexact-real? (real-part x)))))))
|
||||
(define number/sc (numeric/sc Number number?))
|
||||
|
||||
|
||||
(define (numeric-type->static-contract type)
|
||||
(match type
|
||||
;; numeric special cases
|
||||
;; since often-used types like Integer are big unions, this would
|
||||
;; generate large contracts.
|
||||
[(== t:-PosByte type-equal?) positive-byte/sc]
|
||||
[(== t:-Byte type-equal?) byte/sc]
|
||||
[(== t:-PosIndex type-equal?) positive-index/sc]
|
||||
[(== t:-Index type-equal?) index/sc]
|
||||
[(== t:-PosFixnum type-equal?) positive-fixnum/sc]
|
||||
[(== t:-NonNegFixnum type-equal?) nonnegative-fixnum/sc]
|
||||
;; -NegFixnum is a base type
|
||||
[(== t:-NonPosFixnum type-equal?) nonpositive-fixnum/sc]
|
||||
[(== t:-Fixnum type-equal?) fixnum/sc]
|
||||
[(== t:-PosInt type-equal?) positive-integer/sc]
|
||||
[(== t:-Nat type-equal?) natural/sc]
|
||||
[(== t:-NegInt type-equal?) negative-integer/sc]
|
||||
[(== t:-NonPosInt type-equal?) nonpositive-integer/sc]
|
||||
[(== t:-Int type-equal?) integer/sc]
|
||||
[(== t:-PosRat type-equal?) positive-rational/sc]
|
||||
[(== t:-NonNegRat type-equal?) nonnegative-rational/sc]
|
||||
[(== t:-NegRat type-equal?) negative-rational/sc]
|
||||
[(== t:-NonPosRat type-equal?) nonpositive-rational/sc]
|
||||
[(== t:-Rat type-equal?) rational/sc]
|
||||
[(== t:-FlonumZero type-equal?) flonum-zero/sc]
|
||||
[(== t:-NonNegFlonum type-equal?) nonnegative-flonum/sc]
|
||||
[(== t:-NonPosFlonum type-equal?) nonpositive-flonum/sc]
|
||||
[(== t:-Flonum type-equal?) flonum/sc]
|
||||
[(== t:-SingleFlonumZero type-equal?) single-flonum-zero/sc]
|
||||
[(== t:-InexactRealZero type-equal?) inexact-real-zero/sc]
|
||||
[(== t:-PosInexactReal type-equal?) positive-inexact-real/sc]
|
||||
[(== t:-NonNegSingleFlonum type-equal?) nonnegative-single-flonum/sc]
|
||||
[(== t:-NonNegInexactReal type-equal?) nonnegative-inexact-real/sc]
|
||||
[(== t:-NegInexactReal type-equal?) negative-inexact-real/sc]
|
||||
[(== t:-NonPosSingleFlonum type-equal?) nonpositive-single-flonum/sc]
|
||||
[(== t:-NonPosInexactReal type-equal?) nonpositive-inexact-real/sc]
|
||||
[(== t:-SingleFlonum type-equal?) single-flonum/sc]
|
||||
[(== t:-InexactReal type-equal?) inexact-real/sc]
|
||||
[(== t:-RealZero type-equal?) real-zero/sc]
|
||||
[(== t:-PosReal type-equal?) positive-real/sc]
|
||||
[(== t:-NonNegReal type-equal?) nonnegative-real/sc]
|
||||
[(== t:-NegReal type-equal?) negative-real/sc]
|
||||
[(== t:-NonPosReal type-equal?) nonpositive-real/sc]
|
||||
[(== t:-Real type-equal?) real/sc]
|
||||
[(== t:-ExactNumber type-equal?) exact-number/sc]
|
||||
[(== t:-InexactComplex type-equal?) inexact-complex/sc]
|
||||
[(== t:-Number type-equal?) number/sc]
|
||||
[else #f]))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user