added in unioning and a bit more coloring; checking in to prepare for some changes to the original check syntax (to support contract obligations better)
This commit is contained in:
Robby Findler
parent
b72a59d55c
commit
5a5da11314
|
|
@ -7,75 +7,86 @@
|
|||
|
||||
(define cs-my-obligation-color "my obligations")
|
||||
(define cs-their-obligation-color "my assumptions")
|
||||
(define cs-both-obligation-color "both obligations")
|
||||
(define cs-unk-obligation-color "unknown obligations")
|
||||
|
||||
(define lexically-bound-variable-style-pref 'drracket:check-syntax:lexically-bound)
|
||||
(define imported-variable-style-pref 'drracket:check-syntax:imported)
|
||||
(define set!d-variable-style-pref 'drracket:check-syntax:set!d)
|
||||
|
||||
(define lexically-bound-variable-style-pref 'drracket:check-syntax:lexically-bound)
|
||||
(define imported-variable-style-pref 'drracket:check-syntax:imported)
|
||||
(define set!d-variable-style-pref 'drracket:check-syntax:set!d)
|
||||
|
||||
(define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref))
|
||||
(define imported-variable-style-name (symbol->string imported-variable-style-pref))
|
||||
(define set!d-variable-style-name (symbol->string set!d-variable-style-pref))
|
||||
(define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref))
|
||||
(define imported-variable-style-name (symbol->string imported-variable-style-pref))
|
||||
(define set!d-variable-style-name (symbol->string set!d-variable-style-pref))
|
||||
|
||||
(define my-obligation-style-pref 'drracket:check-syntax:my-obligation-style-pref)
|
||||
(define their-obligation-style-pref 'drracket:check-syntax:their-obligation-style-pref)
|
||||
(define unk-obligation-style-pref 'drracket:check-syntax:unk-obligation-style-pref)
|
||||
(define both-obligation-style-pref 'drracket:check-syntax:both-obligation-style-pref)
|
||||
|
||||
(define my-obligation-style-name (symbol->string my-obligation-style-pref))
|
||||
(define their-obligation-style-name (symbol->string their-obligation-style-pref))
|
||||
(define unk-obligation-style-name (symbol->string unk-obligation-style-pref))
|
||||
(define both-obligation-style-name (symbol->string both-obligation-style-pref))
|
||||
|
||||
(define error-style-name (scheme:short-sym->style-name 'error))
|
||||
;(define constant-style-name (scheme:short-sym->style-name 'constant))
|
||||
|
||||
(define (syncheck-add-to-preferences-panel parent)
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
lexically-bound-variable-style-pref
|
||||
lexically-bound-variable-style-name
|
||||
(string-constant cs-lexical-variable))
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
imported-variable-style-pref
|
||||
imported-variable-style-name
|
||||
(string-constant cs-imported-variable))
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
set!d-variable-style-pref
|
||||
set!d-variable-style-name
|
||||
(string-constant cs-set!d-variable))
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
my-obligation-style-pref
|
||||
my-obligation-style-name
|
||||
cs-my-obligation-color)
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
their-obligation-style-pref
|
||||
their-obligation-style-name
|
||||
cs-their-obligation-color)
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
unk-obligation-style-pref
|
||||
unk-obligation-style-name
|
||||
cs-unk-obligation-color)
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
both-obligation-style-pref
|
||||
both-obligation-style-name
|
||||
cs-both-obligation-color))
|
||||
|
||||
(color-prefs:register-color-preference lexically-bound-variable-style-pref
|
||||
lexically-bound-variable-style-name
|
||||
(make-object color% 81 112 203)
|
||||
(make-object color% 50 163 255))
|
||||
(color-prefs:register-color-preference set!d-variable-style-pref
|
||||
set!d-variable-style-name
|
||||
(send the-color-database find-color "firebrick")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:register-color-preference imported-variable-style-pref
|
||||
imported-variable-style-name
|
||||
(make-object color% 68 0 203)
|
||||
(make-object color% 166 0 255))
|
||||
(color-prefs:register-color-preference my-obligation-style-pref
|
||||
my-obligation-style-name
|
||||
(send the-color-database find-color "firebrick")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:register-color-preference their-obligation-style-pref
|
||||
their-obligation-style-name
|
||||
(make-object color% 0 116 0)
|
||||
(send the-color-database find-color "limegreen"))
|
||||
(color-prefs:register-color-preference unk-obligation-style-pref
|
||||
unk-obligation-style-name
|
||||
(send the-color-database find-color "black")
|
||||
(send the-color-database find-color "white"))
|
||||
(color-prefs:register-color-preference both-obligation-style-pref
|
||||
both-obligation-style-name
|
||||
(make-object color% 139 142 28)
|
||||
(send the-color-database find-color "khaki"))
|
||||
|
||||
(define my-obligation-style-pref 'drracket:check-syntax:my-obligation-style-pref)
|
||||
(define their-obligation-style-pref 'drracket:check-syntax:their-obligation-style-pref)
|
||||
(define unk-obligation-style-pref 'drracket:check-syntax:unk-obligation-style-pref)
|
||||
(define my-obligation-style-name (symbol->string my-obligation-style-pref))
|
||||
(define their-obligation-style-name (symbol->string their-obligation-style-pref))
|
||||
(define unk-obligation-style-name (symbol->string unk-obligation-style-pref))
|
||||
|
||||
(define error-style-name (scheme:short-sym->style-name 'error))
|
||||
;(define constant-style-name (scheme:short-sym->style-name 'constant))
|
||||
|
||||
(define (syncheck-add-to-preferences-panel parent)
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
lexically-bound-variable-style-pref
|
||||
lexically-bound-variable-style-name
|
||||
(string-constant cs-lexical-variable))
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
imported-variable-style-pref
|
||||
imported-variable-style-name
|
||||
(string-constant cs-imported-variable))
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
set!d-variable-style-pref
|
||||
set!d-variable-style-name
|
||||
(string-constant cs-set!d-variable))
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
my-obligation-style-pref
|
||||
my-obligation-style-name
|
||||
cs-my-obligation-color)
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
their-obligation-style-pref
|
||||
their-obligation-style-name
|
||||
cs-their-obligation-color)
|
||||
(color-prefs:build-color-selection-panel parent
|
||||
unk-obligation-style-pref
|
||||
unk-obligation-style-name
|
||||
cs-unk-obligation-color))
|
||||
|
||||
(color-prefs:register-color-preference lexically-bound-variable-style-pref
|
||||
lexically-bound-variable-style-name
|
||||
(make-object color% 81 112 203)
|
||||
(make-object color% 50 163 255))
|
||||
(color-prefs:register-color-preference set!d-variable-style-pref
|
||||
set!d-variable-style-name
|
||||
(send the-color-database find-color "firebrick")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:register-color-preference imported-variable-style-pref
|
||||
imported-variable-style-name
|
||||
(make-object color% 68 0 203)
|
||||
(make-object color% 166 0 255))
|
||||
(color-prefs:register-color-preference my-obligation-style-pref
|
||||
my-obligation-style-name
|
||||
(send the-color-database find-color "firebrick")
|
||||
(send the-color-database find-color "pink"))
|
||||
(color-prefs:register-color-preference their-obligation-style-pref
|
||||
their-obligation-style-name
|
||||
(make-object color% 0 116 0)
|
||||
(send the-color-database find-color "limegreen"))
|
||||
(color-prefs:register-color-preference unk-obligation-style-pref
|
||||
unk-obligation-style-name
|
||||
(make-object color% 139 142 28)
|
||||
(send the-color-database find-color "khaki"))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,15 +2,19 @@
|
|||
(require "intf.rkt"
|
||||
"annotate.rkt"
|
||||
"colors.rkt"
|
||||
syntax/boundmap
|
||||
syntax/kerncase)
|
||||
(provide annotate-contracts)
|
||||
|
||||
(define (annotate-contracts stx)
|
||||
(define (annotate-contracts stx low-binders varrefs)
|
||||
(define start-map (make-hash))
|
||||
(define arrow-map (make-hash))
|
||||
(define domain-map (make-hash))
|
||||
(define range-map (make-hash))
|
||||
|
||||
;; coloring-plans : hash[stx -o-> (listof color)]
|
||||
(define coloring-plans (make-hash))
|
||||
|
||||
(let loop ([stx stx])
|
||||
(add-to-map stx 'racket/contract:contract-on-boundary start-map)
|
||||
(add-to-map stx 'racket/contract:domain-of domain-map)
|
||||
|
|
@ -20,66 +24,112 @@
|
|||
[(a . b) (loop #'a) (loop #'b)]
|
||||
[else (void)]))
|
||||
|
||||
;; fill in the coloring-plans table
|
||||
(for ([(start-k start-val) (in-hash start-map)])
|
||||
(for ([start-stx (in-list start-val)])
|
||||
(do-contract-traversal start-stx arrow-map domain-map range-map #t))))
|
||||
(do-contract-traversal start-stx
|
||||
coloring-plans low-binders
|
||||
arrow-map domain-map range-map
|
||||
#t)))
|
||||
|
||||
;; enact the coloring plans
|
||||
(for ([(stx colors) (in-hash coloring-plans)])
|
||||
(cond
|
||||
[(and (member my-obligation-style-name colors)
|
||||
(member their-obligation-style-name colors))
|
||||
(color stx both-obligation-style-name 'contract-mode)]
|
||||
[(member my-obligation-style-name colors)
|
||||
(color stx my-obligation-style-name 'contract-mode)]
|
||||
[(member their-obligation-style-name colors)
|
||||
(color stx their-obligation-style-name 'contract-mode)]
|
||||
[(member unk-obligation-style-name colors)
|
||||
(color stx unk-obligation-style-name 'contract-mode)])))
|
||||
|
||||
(define (do-contract-traversal start-stx coloring-plans low-binders arrow-map domain-map range-map polarity)
|
||||
(let ploop ([stx start-stx]
|
||||
[polarity polarity])
|
||||
|
||||
(let ([main-prop (syntax-property stx 'racket/contract:contract)])
|
||||
(cond
|
||||
[main-prop
|
||||
;; we've found a contract, now go color it and
|
||||
;; continue with the sub-contract expressions (as indicated via the properties)
|
||||
(let sloop ([prop main-prop])
|
||||
(cond
|
||||
[(pair? prop) (sloop (car prop)) (sloop (cdr prop))]
|
||||
[(vector? prop)
|
||||
(let ([id (vector-ref prop 0)]
|
||||
[to-color (vector-ref prop 1)])
|
||||
(base-color to-color polarity coloring-plans)
|
||||
(for ((stx (in-list (hash-ref domain-map id '()))))
|
||||
(do-contract-traversal stx coloring-plans low-binders arrow-map domain-map range-map (not polarity)))
|
||||
(for ((stx (in-list (hash-ref range-map id '()))))
|
||||
(do-contract-traversal stx coloring-plans low-binders arrow-map domain-map range-map polarity)))]))]
|
||||
|
||||
[else
|
||||
;; we didn't find a contract, but we might find one in a subexpression
|
||||
;; so we need to go look for it (possibly giving up)
|
||||
(kernel-syntax-case stx #f
|
||||
[(#%expression expr)
|
||||
(ploop #'expr polarity)]
|
||||
[(module id name-id (#%plain-module-begin mod-level-form ...))
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(begin tl-form ... last-one)
|
||||
(ploop #'last-one polarity)]
|
||||
[(#%provide pvd ...)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(define-values (id ...) expr)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(define-syntaxes (id ...) expr)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(define-values-for-syntax (id ...) expr)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(#%require rspec ...)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(if (known-predicate? #'id)
|
||||
(base-color #'id polarity coloring-plans)
|
||||
(begin
|
||||
;(printf "mapped to ~s\n" (module-identifier-mapping-get low-binders #'id))
|
||||
(give-up start-stx coloring-plans)))]
|
||||
[(#%plain-lambda formals expr ...)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(case-lambda [formals expr] ...)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(if a b c)
|
||||
;; these calls are questionable.
|
||||
;; if we ultimately end up giving up in both
|
||||
;; branches, maybe we should actually be coloring the entire thing
|
||||
;; in the blank color, but we'll only color the then and else branches
|
||||
;; in that color with this code.
|
||||
;; on the other hand, recurring like this will mean that the two
|
||||
;; branches are considered separately and thus calling give-up
|
||||
;; on one side will not pollute the other side.
|
||||
(do-contract-traversal #'b coloring-plans low-binders arrow-map domain-map range-map polarity)
|
||||
(do-contract-traversal #'c coloring-plans low-binders arrow-map domain-map range-map polarity)]
|
||||
;; [(begin expr ...) (void)]
|
||||
[(begin0 fst rst ...)
|
||||
(ploop #'fst polarity)]
|
||||
[(let-values bindings body ... last-one)
|
||||
(ploop #'last-one polarity)]
|
||||
[(letrec-values bindings body ... last-one)
|
||||
(ploop #'last-one polarity)]
|
||||
[(set! a b)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(quote stuff)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(quote-syntax stuff)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(with-continuation-mark a b c)
|
||||
(ploop #'c polarity)]
|
||||
[(#%plain-app f args ...)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(#%top . id)
|
||||
(give-up start-stx coloring-plans)]
|
||||
[(#%variable-reference ignored ...)
|
||||
(give-up start-stx coloring-plans)])]))))
|
||||
|
||||
(define (do-contract-traversal start-stx arrow-map domain-map range-map polarity)
|
||||
(let loop ([stx start-stx])
|
||||
(base-color stx polarity)
|
||||
(kernel-syntax-case stx #f
|
||||
[(#%expression expr)
|
||||
(loop #'expr)]
|
||||
[(module id name-id (#%plain-module-begin mod-level-form ...))
|
||||
(for-each loop (syntax->list #'(mod-level-form ...)))]
|
||||
[(begin tl-form ... last-one)
|
||||
(loop #'last-one)]
|
||||
[(#%provide pvd ...)
|
||||
(void)]
|
||||
[(define-values (id ...) expr)
|
||||
(void)]
|
||||
[(define-syntaxes (id ...) expr)
|
||||
(void)]
|
||||
[(define-values-for-syntax (id ...) expr)
|
||||
(void)]
|
||||
[(#%require rspec ...)
|
||||
(void)]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(void)]
|
||||
[(#%plain-lambda formals expr ...)
|
||||
(void)]
|
||||
[(case-lambda [formals expr] ...)
|
||||
(void)]
|
||||
[(if a b c)
|
||||
(loop #'b)
|
||||
(loop #'c)]
|
||||
;; [(begin expr ...) (void)]
|
||||
[(begin0 fst rst ...)
|
||||
(loop #'fst)]
|
||||
[(let-values bindings body ... last-one)
|
||||
(loop #'last-one)]
|
||||
[(letrec-values bindings body ... last-one)
|
||||
(loop #'last-one)]
|
||||
[(set! a b)
|
||||
(void)]
|
||||
[(quote stuff)
|
||||
(void)]
|
||||
[(quote-syntax stuff)
|
||||
(void)]
|
||||
[(with-continuation-mark a b c)
|
||||
(loop #'c)]
|
||||
[(#%plain-app f args ...)
|
||||
(void)]
|
||||
[(#%top . id)
|
||||
(void)]
|
||||
[(#%variable-reference id)
|
||||
(void)]
|
||||
[(#%variable-reference)
|
||||
(void)])))
|
||||
|
||||
|
||||
|
||||
;; add-to-map : syntax any hash[any -> (listof stx)]
|
||||
;; looks at stx's property prop and updates map,
|
||||
;; using the value of the property as the key
|
||||
|
|
@ -92,41 +142,6 @@
|
|||
(loop (car val))
|
||||
(loop (cdr val))])))
|
||||
|
||||
#|
|
||||
(define (annotate-contracts stx)
|
||||
(let loop ([stx stx])
|
||||
(let sloop ([prop (syntax-property stx 'provide/contract-original-contract)])
|
||||
(cond
|
||||
[(vector? prop)
|
||||
(color-obligations (vector-ref prop 1))]
|
||||
[(pair? prop) (sloop (car prop))
|
||||
(sloop (cdr prop))]))
|
||||
(syntax-case stx ()
|
||||
[(a . b) (loop #'a) (loop #'b)]
|
||||
[else (void)])))
|
||||
|
||||
(define (color-obligations stx)
|
||||
(let loop ([stx stx]
|
||||
[polarity #t])
|
||||
(syntax-case stx (->)
|
||||
[(-> a ... rng)
|
||||
(begin
|
||||
(base-color (car (syntax-e stx)) polarity)
|
||||
(for-each (λ (x) (loop x (not polarity))) (syntax->list #'(a ...)))
|
||||
(syntax-case #'rng (values any)
|
||||
[(values b ...)
|
||||
(for-each (λ (x) (loop x polarity)) (syntax->list #'(b ...)))]
|
||||
[any
|
||||
(void)]
|
||||
[rng
|
||||
(loop #'rng polarity)]))]
|
||||
[id
|
||||
(and (identifier? #'id)
|
||||
(known-predicate? #'id))
|
||||
(base-color stx polarity)]
|
||||
[else
|
||||
(color stx unk-obligation-style-name 'contract-mode)])))
|
||||
|#
|
||||
;; returns #t if the result is known to be a predicate that shoudl correspond to a
|
||||
;; complete obligation for the contract. If it is some unknown variable, this variable
|
||||
;; may refer to some other contract with nested obligations, so we have to return #f here.
|
||||
|
|
@ -139,8 +154,35 @@
|
|||
(let-values ([(base rel) (module-path-index-split src)])
|
||||
(member base '('#%kernel racket racket/base scheme scheme/base)))))))
|
||||
|
||||
(define (base-color stx polarity)
|
||||
(printf "base-color ~s\n" stx)
|
||||
(color stx
|
||||
(if polarity my-obligation-style-name their-obligation-style-name)
|
||||
'contract-mode))
|
||||
(define (give-up stx coloring-plans)
|
||||
(let loop ([stx stx])
|
||||
(when (syntax-original? stx)
|
||||
(blank-color stx coloring-plans))
|
||||
|
||||
(let oloop ([origin (syntax-property stx 'origin)])
|
||||
(cond
|
||||
[(pair? origin) (oloop (car origin)) (oloop (cdr origin))]
|
||||
[(syntax? origin)
|
||||
(when (syntax-original? origin)
|
||||
(blank-color origin coloring-plans))]))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(a . b) (loop #'a) (loop #'b)]
|
||||
[_ (void)])))
|
||||
|
||||
|
||||
|
||||
(define (base-color stx polarity coloring-plans)
|
||||
(make-a-coloring-plan stx
|
||||
(if polarity my-obligation-style-name their-obligation-style-name)
|
||||
coloring-plans))
|
||||
|
||||
(define (blank-color stx coloring-plans)
|
||||
(make-a-coloring-plan stx unk-obligation-style-name coloring-plans))
|
||||
|
||||
(define (make-a-coloring-plan stx plan coloring-plans)
|
||||
(hash-set! coloring-plans
|
||||
stx
|
||||
(cons
|
||||
plan
|
||||
(hash-ref coloring-plans stx '()))))
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@
|
|||
require-for-syntaxes
|
||||
require-for-templates
|
||||
require-for-labels)
|
||||
(annotate-contracts sexp))]
|
||||
(annotate-contracts sexp low-binders varrefs))]
|
||||
[else
|
||||
(annotate-basic sexp
|
||||
user-namespace user-directory jump-to-id
|
||||
|
|
|
|||
|
|
@ -382,8 +382,10 @@ v4 todo:
|
|||
(list kwd-ctcs ...) '(kwds ...) '() '()
|
||||
(list rng-ctcs ...) use-any?
|
||||
outer-lambda))
|
||||
'racket/contract:function-contract
|
||||
this->)
|
||||
'racket/contract:contract
|
||||
(vector this->
|
||||
;; the -> in the original input to this guy
|
||||
(car (syntax-e stx))))
|
||||
inner-args/body
|
||||
(syntax (dom-names ... rng-names ...))))))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user