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

added a few more contracts to those that get colored by check syntax

Browse Source 
(and fixed a bug in the helper macros that support the coloring)
This commit is contained in:
Robby Findler 2010-08-17 11:41:21 -05:00
parent 672355f823
commit 2cb5de9581
2 changed files with 85 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/drracket/private/syncheck/contract-traversal.rkt
View File

@ -26,7 +26,7 @@
(add-to-map stx 'racket/contract:function-contract arrow-map)
(syntax-case stx ()
[(a . b) (loop #'a) (loop #'b)]
[else (void)]))
[_ (void)]))
;; fill in the coloring-plans table for boundary contracts
(for ([(start-k start-val) (in-hash boundary-start-map)])
@ -128,6 +128,14 @@
(for ((rhs (in-list (module-identifier-mapping-get binding-inits binder))))
(ploop rhs polarity))))
(call-give-up))))]
[const
(let ([val (syntax-e #'const)])
(or (boolean? val)
(number? val)
(string? val)
(char? val)
(regexp? val)))
(base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
[(#%plain-lambda (id) expr ...)
(identifier? #'id)
(base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
@ -165,7 +173,7 @@
[(set! a b)
(call-give-up)]
[(quote stuff)
(call-give-up)]
(base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
[(quote-syntax stuff)
(call-give-up)]
[(with-continuation-mark a b c)
@ -175,7 +183,12 @@
[(#%top . id)
(call-give-up)]
[(#%variable-reference ignored ...)
(call-give-up)])]))))
(call-give-up)]
[_
(begin
#;(error 'contract-traversal.rkt "unknown thing: ~s\n" stx)
(call-give-up))
])]))))
;; add-to-map : syntax any hash[any -> (listof stx)]
;; looks at stx's property prop and updates map,

135
collects/racket/contract/private/guts.rkt
View File

@ -143,6 +143,72 @@
[(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)]
[else #f]))
(define-syntax (define/final-prop stx)
(syntax-case stx ()
[(_ header bodies ...)
(with-syntax ([ctc (if (identifier? #'header)
#'header
(car (syntax-e #'header)))])
(with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))])
#'(begin
(define ctc/proc
(let ()
(define header bodies ...)
ctc))
(define-syntax (ctc stx)
(syntax-case stx ()
[x
(identifier? #'x)
(syntax-property
#'ctc/proc
'racket/contract:contract
(vector (gensym 'ctc)
(list stx)
'()))]
[(_ margs (... ...))
(with-syntax ([app (datum->syntax stx '#%app)])
(syntax-property
#'(app ctc/proc margs (... ...))
'racket/contract:contract
(vector (gensym 'ctc)
(list (car (syntax-e stx)))
'())))])))))]))
(define-syntax (define/subexpression-pos-prop stx)
(syntax-case stx ()
[(_ header bodies ...)
(with-syntax ([ctc (if (identifier? #'header)
#'header
(car (syntax-e #'header)))])
(with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))])
#'(begin
(define ctc/proc
(let ()
(define header bodies ...)
ctc))
(define-syntax (ctc stx)
(syntax-case stx ()
[x
(identifier? #'x)
(syntax-property
#'ctc/proc
'racket/contract:contract
(vector (gensym 'ctc)
(list stx)
'()))]
[(_ margs (... ...))
(let ([this-one (gensym 'ctc)])
(with-syntax ([(margs (... ...))
(map (λ (x) (syntax-property x 'racket/contract:positive-position this-one))
(syntax->list #'(margs (... ...))))]
[app (datum->syntax stx '#%app)])
(syntax-property
#'(app ctc/proc margs (... ...))
'racket/contract:contract
(vector this-one
(list (car (syntax-e stx)))
'()))))])))))]))
;
;
;
@ -239,7 +305,7 @@
this-ctcs
that-ctcs)))))))
(define (and/c . raw-fs)
(define/subexpression-pos-prop (and/c . raw-fs)
(let ([contracts (coerce-contracts 'and/c raw-fs)])
(cond
[(null? contracts) any/c]
@ -273,7 +339,7 @@
#:name (λ (ctc) 'any/c)
#:first-order get-any?))
(define any/c (make-any/c))
(define/final-prop any/c (make-any/c))
(define (none-curried-proj ctc)
(λ (blame)
@ -294,7 +360,7 @@
#:name (λ (ctc) (none/c-name ctc))
#:first-order (λ (ctc) (λ (val) #f))))
(define none/c (make-none/c 'none/c))
(define/final-prop none/c (make-none/c 'none/c))
@ -379,66 +445,3 @@
(define (build-flat-contract name pred) (make-predicate-contract name pred))
(define-syntax (define/final-prop stx)
(syntax-case stx ()
[(_ header bodies ...)
(with-syntax ([ctc (if (identifier? #'header)
#'header
(car (syntax-e #'header)))])
(with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))])
#'(begin
(define ctc/proc
(let ()
(define header bodies ...)
ctc))
(define-syntax (ctc stx)
(syntax-case stx ()
[x
(identifier? #'x)
(syntax-property
#'x
'racket/contract:contract
(vector (gensym 'ctc)
(list stx)
'()))]
[(_ margs (... ...))
(syntax-property
#'(ctc/proc margs (... ...))
'racket/contract:contract
(vector (gensym 'ctc)
(list (car (syntax-e stx)))
'()))])))))]))
(define-syntax (define/subexpression-pos-prop stx)
(syntax-case stx ()
[(_ header bodies ...)
(with-syntax ([ctc (if (identifier? #'header)
#'header
(car (syntax-e #'header)))])
(with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))])
#'(begin
(define ctc/proc
(let ()
(define header bodies ...)
ctc))
(define-syntax (ctc stx)
(syntax-case stx ()
[x
(identifier? #'x)
(syntax-property
#'ctc/proc
'racket/contract:contract
(vector (gensym 'ctc)
(list stx)
'()))]
[(_ margs (... ...))
(let ([this-one (gensym 'ctc)])
(with-syntax ([(margs (... ...))
(map (λ (x) (syntax-property x 'racket/contract:positive-position this-one))
(syntax->list #'(margs (... ...))))])
(syntax-property
#'(ctc/proc margs (... ...))
'racket/contract:contract
(vector this-one
(list (car (syntax-e stx)))
'()))))])))))]))