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

Greatly reduce size of class static contracts.

Browse Source 
This helps generate contracts for GUI classes using less
time and memory.

original commit: dc578cdbc0496fe5bdfd2238981e8e3ac206756b
This commit is contained in:
Asumu Takikawa 2014-10-09 22:53:43 -04:00
parent 573f6506b3
commit 905058e07c
4 changed files with 62 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -365,25 +365,17 @@
#:unless (memq name pubment-names))
(values name type)))
(class/sc (append
(map (λ (n sc) (member-spec 'method n sc))
public-names (map t->sc/method public-types))
(map (λ (n sc) (member-spec 'inherit n sc))
public-names (map t->sc/method public-types))
(map (λ (n sc) (member-spec 'override n sc))
override-names (map t->sc/method override-types))
(map (λ (n sc) (member-spec 'super n sc))
override-names (map t->sc/method override-types))
(map (λ (n sc) (member-spec 'inner n sc))
augment-names (map t->sc/method augment-types))
(map (λ (n sc) (member-spec 'augment n sc))
(map (λ (n sc) (member-spec 'pubment n sc))
pubment-names (map t->sc/method pubment-types))
(map (λ (n sc) (member-spec 'augment n sc))
augment-names (map t->sc/method augment-types))
(map (λ (n sc) (member-spec 'init n sc))
init-names (map t->sc/neg init-types))
(map (λ (n sc) (member-spec 'field n sc))
field-names (map t->sc/both field-types))
(map (λ (n sc) (member-spec 'inherit-field n sc))
field-names (map t->sc/both field-types)))
#f empty empty)]
#f)]
[(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred?)
(cond
[(dict-ref recursive-values nm #f)]

78
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt
View File

@ -7,6 +7,7 @@
racket/list racket/match
unstable/contract
racket/contract
racket/syntax
(for-template racket/base racket/class)
(for-syntax racket/base syntax/parse))
@ -14,7 +15,7 @@
(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?)]
[class/sc ((listof member-spec?) boolean? . -> . static-contract?)]
[instanceof/sc (static-contract? . -> . static-contract?)]))
@ -38,17 +39,17 @@
(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)
(struct class-combinator combinator (opaque)
#: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)]))
[(class-combinator args opaque)
(class-combinator (member-seq-sc-map f args) opaque)]))
(define (sc-traverse v f)
(match v
[(class-combinator args opaque absent-fields absent-methods)
[(class-combinator args opaque)
(member-seq-sc-map f args)
(void)]))
(define (sc->contract v f)
@ -100,33 +101,30 @@
(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 (class/sc specs opaque)
(class-combinator (member-seq specs) opaque))
(define (instanceof/sc class)
(instanceof-combinator (list class)))
(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 id/ctc
(if sc #`(#,id #,(f sc)) id))
(match modifier
['method id/ctc]
['augment #`(augment #,id/ctc)]
['init #`(init #,id/ctc)]
['field #`(field #,id/ctc)]))]))
(define (spec->id/ctc f modifier vals)
(for/lists (_1 _2)
([spec vals]
#:when (eq? modifier (member-spec-modifier spec)))
(values (member-spec-id spec)
(f (member-spec-sc spec)))))
(define (object/sc->contract v f)
(match v
@ -134,10 +132,34 @@
#`(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)))]))
[(class-combinator (member-seq vals) opaque)
(define-values (override-names override-ctcs)
(spec->id/ctc f 'override vals))
(define-values (pubment-names pubment-ctcs)
(spec->id/ctc f 'pubment vals))
(define/with-syntax (override-temp ...)
(generate-temporaries override-ctcs))
(define/with-syntax (pubment-temp ...)
(generate-temporaries pubment-ctcs))
(define/with-syntax (override-name ...) override-names)
(define/with-syntax (pubment-name ...) pubment-names)
(define/with-syntax (override-ctc ...) override-ctcs)
(define/with-syntax (pubment-ctc ...) pubment-ctcs)
(define vals-rest
(filter (λ (spec)
(not (memq (member-spec-modifier spec)
'(override pubment))))
vals))
#`(let ([override-temp override-ctc] ...
[pubment-temp pubment-ctc] ...)
(class/c #,@(if opaque (list '#:opaque) empty)
#,@(map (member-spec->form f) vals-rest)
[override-name override-temp] ...
(override [override-name override-temp] ...)
(super [override-name override-temp] ...)
(inherit [override-name override-temp] ...)
[pubment-name pubment-temp] ...
(inherit [pubment-name pubment-temp] ...)))]))
(define (instance/sc->contract v f)
(match v
[(instanceof-combinator (list class))

11
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt
View File

@ -189,21 +189,20 @@
(t-sc (Un (-lst Univ) -Number) (or/sc number/sc (listof/sc any-wrap/sc)))
;; classes
(t-sc (-class) (class/sc null #f null null))
(t-sc (-class) (class/sc null #f))
(t-sc (-class #:init ([x -Number #f] [y -Number #f]))
(class/sc (list (member-spec 'init 'x number/sc)
(member-spec 'init 'y number/sc))
#f null null))
#f))
(t-sc (-class #:init ([x -Number #f] [y -Number #t]))
(class/sc (list (member-spec 'init 'x number/sc)
(member-spec 'init 'y number/sc))
#f null null))
#f))
(t-sc (-class #:init ([x -Number #f]) #:init-field ([y -Integer #f]))
(class/sc (list (member-spec 'init 'x number/sc)
(member-spec 'init 'y integer/sc)
(member-spec 'field 'y integer/sc)
(member-spec 'inherit-field 'y integer/sc))
#f null null))
(member-spec 'field 'y integer/sc))
#f))
;; typed/untyped interaction tests
(t-int (-poly (a) (-> a a))

6
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt
View File

@ -279,9 +279,9 @@
#:neg (object/sc (list (member-spec 'field 'x list?/sc))))
(check-optimize
(class/sc (list (member-spec 'field 'x (listof/sc any/sc))) #f empty empty)
#:pos (class/sc (list (member-spec 'field 'x list?/sc)) #f empty empty)
#:neg (class/sc (list (member-spec 'field 'x list?/sc)) #f empty empty))
(class/sc (list (member-spec 'field 'x (listof/sc any/sc))) #f)
#:pos (class/sc (list (member-spec 'field 'x list?/sc)) #f)
#:neg (class/sc (list (member-spec 'field 'x list?/sc)) #f))
(check-optimize
(recursive-sc (list foo-id bar-id)