Put static contracts in main repo.
original commit: 43ce10b5fed9b145eb60e26de832811781ae5889
This commit is contained in:
Eric Dobson
parent
308680c98f
commit
e83c805771
|
|
@ -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)])
|
||||
Loading…
Reference in New Issue
Block a user