From 5a5da1131413ef402c90da6685c5f5cfa726b14b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 12 Jul 2010 09:51:57 -0500 Subject: [PATCH] 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) --- collects/drracket/private/syncheck/colors.rkt | 147 ++++++----- .../private/syncheck/contract-traversal.rkt | 238 ++++++++++-------- .../drracket/private/syncheck/traversals.rkt | 2 +- collects/racket/contract/private/arrow.rkt | 6 +- 4 files changed, 224 insertions(+), 169 deletions(-) diff --git a/collects/drracket/private/syncheck/colors.rkt b/collects/drracket/private/syncheck/colors.rkt index e39b2bb050..2b03e92319 100644 --- a/collects/drracket/private/syncheck/colors.rkt +++ b/collects/drracket/private/syncheck/colors.rkt @@ -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")) - diff --git a/collects/drracket/private/syncheck/contract-traversal.rkt b/collects/drracket/private/syncheck/contract-traversal.rkt index d435fb6364..3f89740433 100644 --- a/collects/drracket/private/syncheck/contract-traversal.rkt +++ b/collects/drracket/private/syncheck/contract-traversal.rkt @@ -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 '())))) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index d62a5f0019..f8a29df9e0 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -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 diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index b9be4f982f..dc74bd0eaa 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -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 ...))))))))