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

Add static contracts for instanceof

Browse Source
This commit is contained in:
Asumu Takikawa 2014-02-25 15:53:19 -05:00
parent a8cc430d0f
commit 4bc4a74d00
2 changed files with 30 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -376,6 +376,8 @@
(recursive-sc-use (if (from-typed? typed-side) typed-n* untyped-n*)))])] (recursive-sc-use (if (from-typed? typed-side) typed-n* untyped-n*)))])]
[(Instance: (? Mu? t)) [(Instance: (? Mu? t))
(t->sc (make-Instance (resolve-once t)))] (t->sc (make-Instance (resolve-once t)))]
[(Instance: (? Name? t))
(instanceof/sc (t->sc t))]
[(Instance: (Class: _ _ fields methods _ _)) [(Instance: (Class: _ _ fields methods _ _))
(match-define (list (list field-names field-types) ...) fields) (match-define (list (list field-names field-types) ...) fields)
(match-define (list (list public-names public-types) ...) methods) (match-define (list (list public-names public-types) ...) methods)

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

@ -14,7 +14,8 @@
(contract-out (contract-out
[struct member-spec ([modifier symbol?] [id symbol?] [sc static-contract?])] [struct member-spec ([modifier symbol?] [id symbol?] [sc static-contract?])]
[object/sc ((listof object-member-spec?) . -> . 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? (listof identifier?) (listof identifier?) . -> . static-contract?)]
[instanceof/sc (static-contract? . -> . static-contract?)]))
@ -55,6 +56,26 @@
(define (sc->constraints v f) (define (sc->constraints v f)
(merge-restricts* 'impersonator (map f (member-seq->list (combinator-args v)))))]) (merge-restricts* 'impersonator (map f (member-seq->list (combinator-args v)))))])
(struct instanceof-combinator combinator ()
#:transparent
#:property prop:combinator-name "instanceof/sc"
#:methods gen:sc
[(define (sc-map v f)
(match v
[(instanceof-combinator (list class))
(instanceof-combinator (list (f class 'covariant)))]))
(define (sc-traverse v f)
(match v
[(instanceof-combinator (list class))
(f class 'covariant)
(void)]))
(define (sc->contract v f)
(instance/sc->contract v f))
(define (sc->constraints v f)
(match v
[(instanceof-combinator (list class))
(f class)]))])
(define member-seq->list (define member-seq->list
(match-lambda (match-lambda
@ -81,6 +102,8 @@
(object-combinator (member-seq specs))) (object-combinator (member-seq specs)))
(define (class/sc specs opaque absent-fields absent-methods) (define (class/sc specs opaque absent-fields absent-methods)
(class-combinator (member-seq specs) opaque absent-fields absent-methods)) (class-combinator (member-seq specs) opaque absent-fields absent-methods))
(define (instanceof/sc class)
(instanceof-combinator (list class)))
(define (wrap mod ctc) (define (wrap mod ctc)
(define mod-stx (define mod-stx
@ -115,3 +138,7 @@
#`(class/c #,@(if opaque (list '#:opaque) empty) #`(class/c #,@(if opaque (list '#:opaque) empty)
#,@(map (member-spec->form f) vals) #,@(map (member-spec->form f) vals)
(absent #,@absent-methods (field #,@absent-fields)))])) (absent #,@absent-methods (field #,@absent-fields)))]))
(define (instance/sc->contract v f)
(match v
[(instanceof-combinator (list class))
#`(instanceof/c #,(f class))]))