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

Add names to flat static contracts.

Browse Source 
original commit: 751835c7dac73d6edb45ce9349bc329593250ded
This commit is contained in:
Eric Dobson 2014-01-07 23:54:32 -08:00
parent c933380f40
commit db19acbc71
2 changed files with 15 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -200,7 +200,7 @@
(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)))]
(flat/sc #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt)) sym)]
[(Refinement: par p?)
(and/sc (t->sc par) (flat/sc p?))]
[(Union: elems)
@ -313,7 +313,7 @@
[(Syntax: t)
(syntax/sc (t->sc t))]
[(Value: v)
(flat/sc #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v))))]
(flat/sc #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v))) v)]
[(Param: in out)
(parameter/sc (t->sc in) (t->sc out))]
[(Hashtable: k v)
@ -429,7 +429,7 @@
[_ (int-err "not a function" f)]))
(define-syntax-rule (numeric/sc name body)
(flat/sc #'(flat-named-contract 'name body)))
(flat/sc #'(flat-named-contract 'name body) 'name))
(module predicates racket/base
(provide nonnegative? nonpositive?)
(define nonnegative? (lambda (x) (>= x 0)))

26
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt
View File

@ -13,13 +13,12 @@
(provide
(contract-out
[flat/sc (syntax? . -> . static-contract?)]
[chaperone/sc (syntax? . -> . static-contract?)]
[impersonator/sc (syntax? . -> . static-contract?)]
[flat/sc? predicate/c]))
[flat/sc ((syntax?) ((or/c #f any/c)) . ->* . static-contract?)]
[chaperone/sc ((syntax?) ((or/c #f any/c)) . ->* . static-contract?)]
[impersonator/sc ((syntax?) ((or/c #f any/c)) . ->* . static-contract?)]))
(define (simple-contract-write-proc v port mode)
(match-define (simple-contract syntax kind) v)
(match-define (simple-contract syntax kind name) v)
(define-values (open close)
(if (equal? mode 0)
(values "(" ")")
@ -27,12 +26,12 @@
(display open port)
(fprintf port "~a/sc" kind)
(display " " port)
(write (syntax->datum syntax) port)
(write (or name (syntax->datum syntax)) port)
(display close port))
(struct simple-contract static-contract (syntax kind)
(struct simple-contract static-contract (syntax kind name)
#:methods gen:sc
[(define (sc-map v f) v)
(define (sc-traverse v f) (void))
@ -42,10 +41,9 @@
[(define (terminal-sc-kind v) (simple-contract-kind v))]
#:methods gen:custom-write [(define write-proc simple-contract-write-proc)])
(define (flat/sc ctc) (simple-contract ctc 'flat))
(define (chaperone/sc ctc) (simple-contract ctc 'chaperone))
(define (impersonator/sc ctc) (simple-contract ctc 'impersonator))
(define (flat/sc? sc)
(and (simple-contract? sc)
(equal? 'flat (simple-contract-kind sc))))
(define (flat/sc ctc [name #f])
(simple-contract ctc 'flat name))
(define (chaperone/sc ctc [name #f])
(simple-contract ctc 'chaperone name))
(define (impersonator/sc ctc [name #f])
(simple-contract ctc 'impersonator name))