From e13c4b690d8c257de1e08252b1bb0199cb6a1f63 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 14 Feb 2009 16:03:25 +0000 Subject: [PATCH 01/13] new branch initial commit svn: r13578 --- collects/typed-scheme/private/base-env.ss | 7 +- collects/typed-scheme/private/parse-type.ss | 20 +- .../typed-scheme/private/remove-intersect.ss | 2 +- collects/typed-scheme/private/resolve-type.ss | 2 +- collects/typed-scheme/private/subtype.ss | 6 +- collects/typed-scheme/private/type-abbrev.ss | 235 ++++++++++++++++++ .../private/type-effect-convenience.ss | 224 +---------------- collects/typed-scheme/private/type-utils.ss | 7 +- collects/typed-scheme/private/union.ss | 5 +- collects/typed-scheme/rep/type-rep.ss | 7 +- .../typed-scheme/typecheck/tc-app-unit.ss | 9 +- 11 files changed, 287 insertions(+), 237 deletions(-) create mode 100644 collects/typed-scheme/private/type-abbrev.ss diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 4034d2ed70..e6ce1de78f 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -517,8 +517,8 @@ [expand (-> (-Syntax Univ) (-Syntax Univ))] [expand-once (-> (-Syntax Univ) (-Syntax Univ))] -[syntax-source (-poly (a) (-> (-Syntax a) Univ))] -[syntax-position (-poly (a) (-> (-Syntax a) (-opt N)))] +[syntax-source (-> (-Syntax Univ) Univ)] +[syntax-position (-> (-Syntax Univ) (-opt N))] [datum->syntax (cl->* (-> (-opt (-Syntax Univ)) Sym (-Syntax Sym)) (-> (-opt (-Syntax Univ)) Univ (-Syntax Univ)))] @@ -538,6 +538,9 @@ [maybe-print-message (-String . -> . -Void)] +;; scheme/list +[last-pair (-poly (a) ((-mu x (Un a (-val '()) (-pair a x))) . -> . (Un (-pair a a) (-pair a (-val '())))))] + ;; scheme/tcp [tcp-listener? (make-pred-ty -TCP-Listener)] [tcp-abandon-port (-Port . -> . -Void)] diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index a454714ca9..a3283d07c4 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -77,6 +77,7 @@ (define-syntax-class fun-ty #:literals (t:-> :) + #:transparent #:description "function type" ;; FIXME - shouldn't have to use syntax->datum (pattern (dom*:type t:-> rng:type : pred:type) @@ -118,31 +119,43 @@ #:with t (-values (syntax->datum #'(ts.t ...))))) (define-syntax-class type-name + #:description "type name" (pattern i:id #:when (lookup-type-name #'i (lambda () #f)) #:with t #'(make-Name #'i) #:when (add-type-name-reference #'i))) (define-syntax-class type-alias + #:description "type alias" (pattern i:id #:with t (lookup-type-alias #'i parse-type* (lambda () #f)) #:when #'t #:when (add-type-name-reference #'i))) +(define-syntax-class all-ddd-formals + #:description "\na sequence of identifiers with a ... after the last identifier\n" + (pattern (v:id ... v-last:id _:ddd))) + +(define-syntax-class all-formals + #:description "\na sequence of identifiers\n" + (pattern (v:id ...))) + (define-syntax-class all-type + #:transparent #:literals (t:All) - (pattern (t:All (v:id ... v-last:id _:ddd) b) + (pattern (t:All :all-ddd-formals b) #:with b.t (parse/get #'b t (type/tvars (cons #'v-last.datum (syntax->datum #'(v ...))) (cons (make-Dotted (make-F #'v-last.datum)) (map make-F (syntax->datum #'(v ...)))))) #:when (add-type-name-reference #'All) #:with t (make-PolyDots (syntax->datum #'(v ... v-last)) #'b.t)) - (pattern (t:All (v:id ...) b) + (pattern (t:All :all-formals b) #:with b.t (parse/get #'b t (type/tvars (syntax->datum #'(v ...)) (map make-F (syntax->datum #'(v ...))))) #:when (add-type-name-reference #'All) #:with t (make-Poly (syntax->datum #'(v ...)) #'b.t))) (define-syntax-class type-app + #:attributes (t) (pattern (i arg:type args:type ...) #:declare i type #:when (identifier? #'i) @@ -165,6 +178,7 @@ Err])))) (define-syntax-class not-kw-id + #:attributes (datum) (pattern i:id #:when (not (for/or ([e (syntax->list #'(quote t:pred t:Tuple case-lambda t:U t:Rec t:Opaque t:Parameter t:Class t:Instance @@ -174,6 +188,8 @@ #:with datum #'i.datum)) (define-syntax-class type + #:transparent + #:attributes (t) #:literals (quote t:pred t:Tuple case-lambda t:U t:Rec t:Opaque t:Parameter t:Class t:Instance) (pattern ty #:declare ty (3d Type?) diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/private/remove-intersect.ss index d2be5958a0..ca2b264c01 100644 --- a/collects/typed-scheme/private/remove-intersect.ss +++ b/collects/typed-scheme/private/remove-intersect.ss @@ -3,7 +3,7 @@ (require (except-in "../utils/utils.ss" extend)) (require (rep type-rep) (private union subtype resolve-type type-effect-convenience type-utils) - mzlib/plt-match mzlib/trace) + scheme/match mzlib/trace) (provide (rename-out [*remove remove]) overlap) diff --git a/collects/typed-scheme/private/resolve-type.ss b/collects/typed-scheme/private/resolve-type.ss index 6526a42819..28ec18a488 100644 --- a/collects/typed-scheme/private/resolve-type.ss +++ b/collects/typed-scheme/private/resolve-type.ss @@ -3,7 +3,7 @@ (require (rep type-rep) (env type-name-env) (utils tc-utils) "type-utils.ss" - mzlib/plt-match + scheme/match mzlib/trace) (provide resolve-name resolve-app needs-resolving? resolve-once) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index d0d6629bc7..4832711c8e 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -6,9 +6,10 @@ "type-utils.ss" "type-comparison.ss" "resolve-type.ss" + "type-abbrev.ss" (env type-name-env) (only-in (infer infer-dummy) unify) - mzlib/plt-match + scheme/match mzlib/trace) @@ -302,3 +303,6 @@ ;(subtype (-> Univ B) (-> Univ Univ)) ;(subtype (make-poly '(a) (make-tvar 'a)) (make-lst N)) + +;;problem: +;; (subtype (make-Mu 'x (make-Syntax (make-Union (list (make-Base 'Number #'number?) (make-F 'x))))) (make-Syntax (make-Univ))) \ No newline at end of file diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss new file mode 100644 index 0000000000..3a33b0f34d --- /dev/null +++ b/collects/typed-scheme/private/type-abbrev.ss @@ -0,0 +1,235 @@ +#lang scheme + +(require "../utils/utils.ss") + +(require (rep type-rep effect-rep) + (utils tc-utils) + scheme/list + scheme/match + "type-effect-printer.ss" + scheme/promise + (for-syntax scheme/base stxclass) + (for-template scheme/base scheme/contract scheme/tcp)) + +(provide (all-defined-out)) + +(define top-func (make-Function (list (make-top-arr)))) + +(define (-vet id) (make-Var-True-Effect id)) +(define (-vef id) (make-Var-False-Effect id)) + +(define -rem make-Remove-Effect) +(define -rest make-Restrict-Effect) + +(define (var->type-eff eff) + (match eff + [(Var-True-Effect: v) (make-Remove-Effect (make-Value #f) v)] + [(Var-False-Effect: v) (make-Restrict-Effect (make-Value #f) v)] + [_ eff])) + +(define ((add-var v) eff) + (match eff + [(Latent-Var-True-Effect:) (-vet v)] + [(Latent-Var-False-Effect:) (-vef v)] + [(Latent-Restrict-Effect: t) (make-Restrict-Effect t v)] + [(Latent-Remove-Effect: t) (make-Remove-Effect t v)] + [(True-Effect:) eff] + [(False-Effect:) eff] + [_ (int-err "can't add var ~a to effect ~a" v eff)])) + +(define-syntax (-> stx) + (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + [(_ dom ... rng : eff1 eff2) + #'(->* (list dom ...) rng : eff1 eff2)] + [(_ dom ... rng : eff1 eff2) + #'(->* (list dom ...) rng : eff1 eff2)] + [(_ dom ... rng) + #'(->* (list dom ...) rng)])) + +(define-syntax ->* + (syntax-rules (:) + [(_ dom rng) + (make-Function (list (make-arr* dom rng)))] + [(_ dom rst rng) + (make-Function (list (make-arr* dom rng rst)))] + [(_ dom rng : eff1 eff2) + (make-Function (list (make-arr* dom rng #f eff1 eff2)))] + [(_ dom rst rng : eff1 eff2) + (make-Function (list (make-arr* dom rng rst eff1 eff2)))])) +(define-syntax ->... + (syntax-rules (:) + [(_ dom rng) + (->* dom rng)] + [(_ dom (dty dbound) rng) + (make-Function (list (make-arr* dom rng #f (cons dty 'dbound) (list) (list))))] + [(_ dom rng : eff1 eff2) + (->* dom rng : eff1 eff2)] + [(_ dom (dty dbound) rng : eff1 eff2) + (make-Function (list (make-arr* dom rng #f (cons dty 'dbound) eff1 eff2)))])) +(define-syntax cl-> + (syntax-rules (:) + [(_ [(dom ...) rng] ...) + (make-Function (list (make-arr* (list dom ...) rng) ...))] + [(_ [(dom ...) rng : eff1 eff2] ...) + (make-Function (list (make-arr* (list dom ...) rng #f eff1 eff2) ...))] + [(_ [(dom ...) rng rst : eff1 eff2] ...) + (make-Function (list (make-arr* (list dom ...) rng rst eff1 eff2) ...))])) +(define (cl->* . args) + (define (funty-arities f) + (match f + [(Function: as) as])) + (make-Function (apply append (map funty-arities args)))) + +(define-syntax (->key stx) + (syntax-parse stx + [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng) + #'(make-Function + (list + (make-arr* (list ty ...) + rng + #f + #f + (list (make-Keyword 'k kty opt) ...) + null + null)))])) + +(define make-arr* + (case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))] + [(dom rng rest) (make-arr dom rng rest #f null (list) (list))] + [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)] + [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)] + [(dom rng rest drest kws eff1 eff2) + (make-arr dom rng rest drest (sort #:key Keyword-kw kws keyworduninterned-symbol "Promise")]) + (lambda (t) + (make-Struct s #f (list t) #f #f #'promise? values)))) + +(define N (make-Base 'Number #'number?)) +(define -Integer (make-Base 'Integer #'exact-integer?)) +(define B (make-Base 'Boolean #'boolean?)) +(define Sym (make-Base 'Symbol #'symbol?)) +(define -Void (make-Base 'Void #'void?)) +(define -Bytes (make-Base 'Bytes #'bytes?)) +(define -Regexp (make-Base 'Regexp #'(and/c regexp? (not/c pregexp?) (not/c byte-regexp?)))) +(define -PRegexp (make-Base 'PRegexp #'(and/c pregexp? (not/c byte-pregexp?)))) +(define -Byte-Regexp (make-Base 'Byte-Regexp #'(and/c byte-regexp? (not/c byte-pregexp?)))) +(define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp?)) +(define -String (make-Base 'String #'string?)) +(define -Keyword (make-Base 'Keyword #'keyword?)) +(define -Char (make-Base 'Char #'char?)) +(define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag?)) +(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set?)) +(define -Path (make-Base 'Path #'path?)) +(define -Namespace (make-Base 'Namespace #'namespace?)) +(define -Output-Port (make-Base 'Output-Port #'output-port?)) +(define -Input-Port (make-Base 'Input-Port #'input-port?)) +(define -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener?)) + +(define -Syntax make-Syntax) +(define -HT make-Hashtable) +(define -Promise make-promise-ty) + +(define Univ (make-Univ)) +(define Err (make-Error)) + +(define -Nat -Integer) + +(define-syntax -v + (syntax-rules () + [(_ x) (make-F 'x)])) + +(define-syntax -poly + (syntax-rules () + [(_ (vars ...) ty) + (let ([vars (-v vars)] ...) + (make-Poly (list 'vars ...) ty))])) + +(define-syntax -polydots + (syntax-rules () + [(_ (vars ... dotted) ty) + (let ([dotted (-v dotted)] + [vars (-v vars)] ...) + (make-PolyDots (list 'vars ... 'dotted) ty))])) + +(define-syntax -mu + (syntax-rules () + [(_ var ty) + (let ([var (-v var)]) + (make-Mu 'var ty))])) + + +(define -values make-Values) + +(define-syntax *Un + (syntax-rules () + [(_ . args) (make-Union (list . args))])) + + +(define -pair make-Pair) + +(define -struct make-Struct) +(define -val make-Value) + +(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec)))) +(define -Listof (-poly (list-elem) (make-Listof list-elem))) + +(define -lst make-Listof) +(define -Sexp (-mu x (*Un Sym N B -String (-val null) (-pair x x)))) +(define -Port (*Un -Input-Port -Output-Port)) + +(define (-lst* #:tail [tail (-val null)] . args) + (if (null? args) + tail + (-pair (car args) (apply -lst* #:tail tail (cdr args))))) + + +#;(define NE (-mu x (Un N (make-Listof x)))) +(define -NE (-mu x (*Un N (-pair x (-pair Sym (-pair x (-val null))))))) + +(define -Param make-Param) + +(define make-pred-ty + (case-lambda + [(in out t) + (->* in out : (list (make-Latent-Restrict-Effect t)) (list (make-Latent-Remove-Effect t)))] + [(t) (make-pred-ty (list Univ) B t)])) + +(define -Pathlike (*Un -Path -String)) +(define -Pathlike* (*Un (-val 'up) (-val 'same) -Path -String)) +(define -Pattern (*Un -String -Bytes -Regexp -Byte-Regexp -PRegexp -Byte-PRegexp)) +(define -Byte N) + +(define (-Tuple l) + (foldr -pair (-val '()) l)) + +(define (untuple t) + (match t + [(Value: '()) null] + [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))] + [else #f])] + [_ #f])) + +(define -box make-Box) +(define -vec make-Vector) + +(define Any-Syntax ;(-Syntax Univ) + (-mu x + (-Syntax (*Un + (-mu y (*Un (-pair x (*Un x y)) (-val '()))) + (make-Vector x) + (make-Box x) + N + B + -Keyword + -String + Sym)))) + +(define Ident (-Syntax Sym)) + +;; DO NOT USE if t contains #f +(define (-opt t) (*Un (-val #f) t)) \ No newline at end of file diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 69c91f5196..e8a8849f61 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -10,241 +10,23 @@ "union.ss" "subtype.ss" "type-utils.ss" + "type-abbrev.ss" scheme/promise (for-syntax stxclass) (for-syntax scheme/base) (for-template scheme/base scheme/contract scheme/tcp)) -(provide (all-defined-out) +(provide (all-defined-out) + (all-from-out "type-abbrev.ss") ;; these should all eventually go away make-Name make-ValuesDots make-Function make-Latent-Restrict-Effect make-Latent-Remove-Effect) (define (one-of/c . args) (apply Un (map -val args))) -(define top-func (make-Function (list (make-top-arr)))) - -(define (-vet id) (make-Var-True-Effect id)) -(define (-vef id) (make-Var-False-Effect id)) - -(define -rem make-Remove-Effect) -(define -rest make-Restrict-Effect) - -(define (var->type-eff eff) - (match eff - [(Var-True-Effect: v) (make-Remove-Effect (make-Value #f) v)] - [(Var-False-Effect: v) (make-Restrict-Effect (make-Value #f) v)] - [_ eff])) - -(define ((add-var v) eff) - (match eff - [(Latent-Var-True-Effect:) (-vet v)] - [(Latent-Var-False-Effect:) (-vef v)] - [(Latent-Restrict-Effect: t) (make-Restrict-Effect t v)] - [(Latent-Remove-Effect: t) (make-Remove-Effect t v)] - [(True-Effect:) eff] - [(False-Effect:) eff] - [_ (int-err "can't add var ~a to effect ~a" v eff)])) - -(define-syntax (-> stx) - (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) - [(_ dom ... rng : eff1 eff2) - #'(->* (list dom ...) rng : eff1 eff2)] - [(_ dom ... rng : eff1 eff2) - #'(->* (list dom ...) rng : eff1 eff2)] - [(_ dom ... rng) - #'(->* (list dom ...) rng)])) - -(define-syntax ->* - (syntax-rules (:) - [(_ dom rng) - (make-Function (list (make-arr* dom rng)))] - [(_ dom rst rng) - (make-Function (list (make-arr* dom rng rst)))] - [(_ dom rng : eff1 eff2) - (make-Function (list (make-arr* dom rng #f eff1 eff2)))] - [(_ dom rst rng : eff1 eff2) - (make-Function (list (make-arr* dom rng rst eff1 eff2)))])) -(define-syntax ->... - (syntax-rules (:) - [(_ dom rng) - (->* dom rng)] - [(_ dom (dty dbound) rng) - (make-Function (list (make-arr* dom rng #f (cons dty 'dbound) (list) (list))))] - [(_ dom rng : eff1 eff2) - (->* dom rng : eff1 eff2)] - [(_ dom (dty dbound) rng : eff1 eff2) - (make-Function (list (make-arr* dom rng #f (cons dty 'dbound) eff1 eff2)))])) -(define-syntax cl-> - (syntax-rules (:) - [(_ [(dom ...) rng] ...) - (make-Function (list (make-arr* (list dom ...) rng) ...))] - [(_ [(dom ...) rng : eff1 eff2] ...) - (make-Function (list (make-arr* (list dom ...) rng #f eff1 eff2) ...))] - [(_ [(dom ...) rng rst : eff1 eff2] ...) - (make-Function (list (make-arr* (list dom ...) rng rst eff1 eff2) ...))])) -(define (cl->* . args) - (define (funty-arities f) - (match f - [(Function: as) as])) - (make-Function (apply append (map funty-arities args)))) - -(define-syntax (->key stx) - (syntax-parse stx - [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng) - #'(make-Function - (list - (make-arr* (list ty ...) - rng - #f - #f - (list (make-Keyword 'k kty opt) ...) - null - null)))])) - -(define make-arr* - (case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))] - [(dom rng rest) (make-arr dom rng rest #f null (list) (list))] - [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)] - [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)] - [(dom rng rest drest kws eff1 eff2) - (make-arr dom rng rest drest (sort #:key Keyword-kw kws keyworduninterned-symbol "Promise")]) - (lambda (t) - (make-Struct s #f (list t) #f #f #'promise? values)))) - -(define N (make-Base 'Number #'number?)) -(define -Integer (make-Base 'Integer #'exact-integer?)) -(define B (make-Base 'Boolean #'boolean?)) -(define Sym (make-Base 'Symbol #'symbol?)) -(define -Void (make-Base 'Void #'void?)) -(define -Bytes (make-Base 'Bytes #'bytes?)) -(define -Regexp (make-Base 'Regexp #'(and/c regexp? (not/c pregexp?) (not/c byte-regexp?)))) -(define -PRegexp (make-Base 'PRegexp #'(and/c pregexp? (not/c byte-pregexp?)))) -(define -Byte-Regexp (make-Base 'Byte-Regexp #'(and/c byte-regexp? (not/c byte-pregexp?)))) -(define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp?)) -(define -String (make-Base 'String #'string?)) -(define -Keyword (make-Base 'Keyword #'keyword?)) -(define -Char (make-Base 'Char #'char?)) -(define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag?)) -(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set?)) -(define -Path (make-Base 'Path #'path?)) -(define -Namespace (make-Base 'Namespace #'namespace?)) -(define -Output-Port (make-Base 'Output-Port #'output-port?)) -(define -Input-Port (make-Base 'Input-Port #'input-port?)) -(define -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener?)) - -(define -Syntax make-Syntax) -(define -HT make-Hashtable) -(define -Promise make-promise-ty) - -(define Univ (make-Univ)) -(define Err (make-Error)) - -(define -Nat -Integer) - -(define-syntax -v - (syntax-rules () - [(_ x) (make-F 'x)])) - -(define-syntax -poly - (syntax-rules () - [(_ (vars ...) ty) - (let ([vars (-v vars)] ...) - (make-Poly (list 'vars ...) ty))])) - -(define-syntax -polydots - (syntax-rules () - [(_ (vars ... dotted) ty) - (let ([dotted (-v dotted)] - [vars (-v vars)] ...) - (make-PolyDots (list 'vars ... 'dotted) ty))])) - -(define-syntax -mu - (syntax-rules () - [(_ var ty) - (let ([var (-v var)]) - (make-Mu 'var ty))])) - - -(define -values make-Values) - -(define-syntax *Un - (syntax-rules () - [(_ . args) (make-Union (list . args))])) - - -(define -pair make-Pair) - -(define -struct make-Struct) -(define -val make-Value) - -(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec)))) -(define -Listof (-poly (list-elem) (make-Listof list-elem))) - -(define -lst make-Listof) -(define -Sexp (-mu x (*Un Sym N B -String (-val null) (-pair x x)))) -(define -Port (*Un -Input-Port -Output-Port)) - -(define (-lst* #:tail [tail (-val null)] . args) - (if (null? args) - tail - (-pair (car args) (apply -lst* #:tail tail (cdr args))))) - - -#;(define NE (-mu x (Un N (make-Listof x)))) -(define -NE (-mu x (*Un N (-pair x (-pair Sym (-pair x (-val null))))))) - (define (Un/eff . args) (apply Un (map tc-result-t args))) -(define -Param make-Param) - -(define make-pred-ty - (case-lambda - [(in out t) - (->* in out : (list (make-Latent-Restrict-Effect t)) (list (make-Latent-Remove-Effect t)))] - [(t) (make-pred-ty (list Univ) B t)])) - -(define -Pathlike (*Un -Path -String)) -(define -Pathlike* (*Un (-val 'up) (-val 'same) -Path -String)) -(define -Pattern (*Un -String -Bytes -Regexp -Byte-Regexp -PRegexp -Byte-PRegexp)) -(define -Byte N) - -(define (-Tuple l) - (foldr -pair (-val '()) l)) - -(define (untuple t) - (match t - [(Value: '()) null] - [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))] - [else #f])] - [_ #f])) - -(define -box make-Box) -(define -vec make-Vector) - -(define Any-Syntax - (-mu x - (-Syntax (*Un - (-lst x) - (-mu y (*Un x (-pair x y))) - (make-Vector x) - (make-Box x) - N - B - -String - Sym)))) - -(define Ident (-Syntax Sym)) - -;; DO NOT USE if t contains #f -(define (-opt t) (*Un (-val #f) t)) (define-syntax (make-env stx) (syntax-case stx () diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss index f813a19ef6..567cdd56fa 100644 --- a/collects/typed-scheme/private/type-utils.ss +++ b/collects/typed-scheme/private/type-utils.ss @@ -5,7 +5,7 @@ (require (rep type-rep effect-rep rep-utils) (utils tc-utils) (only-in (rep free-variance) combine-frees) - mzlib/plt-match + scheme/match scheme/list mzlib/trace (for-syntax scheme/base)) @@ -33,10 +33,11 @@ ;; substitute : Type Name Type -> Type -(define (substitute image name target) +(define (substitute image name target #:Un [Un (get-union-maker)]) (define (sb t) (substitute image name t)) (if (hash-ref (free-vars* target) name #f) (type-case sb target + [#:Union tys (Un (map sb tys))] [#:F name* (if (eq? name* name) image target)] [#:arr dom rng rest drest kws thn-eff els-eff (begin @@ -141,7 +142,7 @@ ;; must be applied to a Mu (define (unfold t) (match t - [(Mu: name b) (substitute t name b)] + [(Mu: name b) (substitute t name b #:Un make-Union)] [_ (int-err "unfold: requires Mu type, got ~a" t)])) (define (instantiate-poly t types) diff --git a/collects/typed-scheme/private/union.ss b/collects/typed-scheme/private/union.ss index d2235d658f..e8830edcc4 100644 --- a/collects/typed-scheme/private/union.ss +++ b/collects/typed-scheme/private/union.ss @@ -4,7 +4,9 @@ (require (rep type-rep rep-utils) (utils tc-utils) + "type-utils.ss" "subtype.ss" + "type-abbrev.ss" "type-effect-printer.ss" "type-comparison.ss" scheme/match mzlib/trace) @@ -32,6 +34,7 @@ (define Un (case-lambda [() empty-union] + [(t) t] [args ;; a is a Type (not a union type) ;; b is a List[Type] @@ -50,7 +53,7 @@ (if (andmap Values? types) (make-Values (apply map Un (map Values-types types))) (int-err "Un: should not take the union of multiple values with some other type: ~a" types))] - [else (make-union* #;(remove-subtypes types) (foldr union2 null (remove-subtypes types)))]))])) + [else (make-union* #;(remove-subtypes types) (foldr union2 (list (car types)) (remove-subtypes (cdr types))))]))])) #;(defintern (Un-intern args) (lambda (_ args) (apply Un args)) args) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index b5b54bf5ea..bd286cf8d5 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -158,7 +158,7 @@ ;; elems : Listof[Type] (dt Union (elems) [#:frees (combine-frees (map free-vars* elems)) (combine-frees (map free-idxs* elems))] - [#:fold-rhs ((unbox union-maker) (map type-rec-id elems))]) + [#:fold-rhs ((get-union-maker) (map type-rec-id elems))]) (dt Univ () [#:frees #f] [#:fold-rhs #:base]) @@ -217,11 +217,12 @@ ;; Ugly hack - should use units -(define union-maker (box #f)) +(define union-maker (box (lambda args (int-err "Union not yet available")))) (define (set-union-maker! v) (set-box! union-maker v)) +(define (get-union-maker) (unbox union-maker)) -(provide set-union-maker!) +(provide set-union-maker! get-union-maker) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 3c75308f3d..36de510bee 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -544,13 +544,17 @@ (define (find-annotation stx name) (define (find s) (find-annotation s name)) (define (match? b) + (printf "match? 1 : ~a~n" (syntax->datum b)) (syntax-parse b #:literals (#%plain-app reverse) [c:lv-clause + #:when (printf "match? 2 : ~a~n" (syntax->datum #'c.e)) #:with (#%plain-app reverse n:id) #'c.e - #:when (free-identifier=? name #'n) + #:with (v) #'(c.v ...) + #:when (free-identifier=? name #'v) (type-annotation #'v)] [_ #f])) + (printf "in find-ann~n") (syntax-parse stx #:literals (let-values) [(let-values cls:lv-clauses body) @@ -760,7 +764,8 @@ [((val acc ...) ((if (#%plain-app null? val*) thn els)) (actual actuals ...)) - (and (free-identifier=? #'val #'val*) + (and (printf "in match special case~n") + (free-identifier=? #'val #'val*) (ormap (lambda (a) (find-annotation #'(if (#%plain-app null? val*) thn els) a)) (syntax->list #'(acc ...)))) (let* ([ts1 (generalize (tc-expr/t #'actual))] From b5ccbb45bdf9b64f5ea6231bbd4ed627e60664ed Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 14 Feb 2009 16:03:42 +0000 Subject: [PATCH 02/13] branch svn: r13579 --- collects/drscheme/private/mred-typed.ss | 103 + collects/drscheme/private/prefs-contract.ss | 16 - collects/drscheme/syncheck/annotate.ss | 634 ++++ collects/drscheme/syncheck/color.ss | 84 + collects/drscheme/syncheck/extra-stxcase.ss | 44 + collects/drscheme/syncheck/extra-typed.ss | 453 +++ collects/drscheme/syncheck/extra.ss | 21 + collects/drscheme/syncheck/id-sets.ss | 41 + collects/drscheme/syncheck/make-traversal.ss | 86 + collects/drscheme/syncheck/syncheck.ss | 2755 ++++++++++++++++++ collects/drscheme/syncheck/utils.ss | 8 + 11 files changed, 4229 insertions(+), 16 deletions(-) create mode 100644 collects/drscheme/private/mred-typed.ss delete mode 100644 collects/drscheme/private/prefs-contract.ss create mode 100644 collects/drscheme/syncheck/annotate.ss create mode 100644 collects/drscheme/syncheck/color.ss create mode 100644 collects/drscheme/syncheck/extra-stxcase.ss create mode 100644 collects/drscheme/syncheck/extra-typed.ss create mode 100644 collects/drscheme/syncheck/extra.ss create mode 100644 collects/drscheme/syncheck/id-sets.ss create mode 100644 collects/drscheme/syncheck/make-traversal.ss create mode 100644 collects/drscheme/syncheck/syncheck.ss create mode 100644 collects/drscheme/syncheck/utils.ss diff --git a/collects/drscheme/private/mred-typed.ss b/collects/drscheme/private/mred-typed.ss new file mode 100644 index 0000000000..e906dbc81a --- /dev/null +++ b/collects/drscheme/private/mred-typed.ss @@ -0,0 +1,103 @@ +#lang planet plt typed-scheme.plt 3 1 + +;(require mred/mred) +(provide (all-defined-out)) + +(define-type-alias Bitmap% (Class (Number Number Boolean) + () + ([get-width (-> Number)] + [get-height (-> Number)]))) +(define-type-alias Font-List% (Class () () ([find-or-create-font (Any .. -> (Instance Font%))]))) +(define-type-alias Font% (Class () () ([get-face (-> (Option String))] + [get-point-size (-> Number)]))) +(define-type-alias Dialog% (Class () + ([parent Any] [width Number] [label String]) + ([show (Any -> Void)]))) +(define-type-alias Text-Field% (Class () + ([parent Any] [callback Any] [label String]) + ([get-value (-> String)] + [focus (-> String)]))) +(define-type-alias Horizontal-Panel% (Class () + ([parent Any] + [stretchable-height Any #t] + [alignment (List Symbol Symbol) #t]) + ())) +(define-type-alias Choice% (Class () + ([parent Any] [label String] [choices List] [callback Any]) + ([get-string-selection (-> (Option String))] + [set-string-selection (String -> Void)]))) +(define-type-alias Message% (Class () + ([parent Any] [label String]) + ([set-label ((U String (Instance Bitmap%)) -> Void)]))) +(define-type-alias Horizontal-Pane% (Class () + ([parent Any]) + ())) +(define-type-alias Editor-Canvas% (Class () + ([parent Any] [editor Any]) + ([set-line-count (Number -> Void)]))) +(define-type-alias Bitmap-DC% (Class ((Instance Bitmap%)) + () + ([get-text-extent (String (Instance Font%) -> (values Number Number Number Number))] + [get-pixel (Number Number (Instance Color%) -> Boolean)] + [set-bitmap ((Option (Instance Bitmap%)) -> Void)] + [clear (-> Void)] + [set-font ((Instance Font%) -> Void)] + [draw-text (String Number Number -> Void)]))) +(define-type-alias Color% (Class () () ([red (-> Number)]))) +(define-type-alias Style-List% (Class () + () + ([find-named-style + (String -> (Instance (Class () + () + ([get-font (-> (Instance Font%))]))))]))) + +(define-type-alias Scheme:Text% (Class () + () + ([begin-edit-sequence (-> Void)] + [end-edit-sequence (-> Void)] + [lock (Boolean -> Void)] + [last-position (-> Number)] + [last-paragraph (-> Number)] + [delete (Number Number -> Void)] + [auto-wrap (Any -> Void)] + [paragraph-end-position (Number -> Number)] + [paragraph-start-position (Number -> Number)] + [get-start-position (-> Number)] + [get-end-position (-> Number)] + [insert (String Number Number -> Void)]))) + +(require/typed mred/mred + [the-font-list (Instance Font-List%)] + [dialog% Dialog%] + [text-field% Text-Field%] + [horizontal-panel% Horizontal-Panel%] + [choice% Choice%] + [get-face-list (-> (Listof String))] + [message% Message%] + [horizontal-pane% Horizontal-Pane%] + [editor-canvas% Editor-Canvas%] + [bitmap-dc% Bitmap-DC%] + [bitmap% Bitmap%] + [color% Color%]) + +(require/typed framework/framework + [preferences:set-default (Symbol Any Any -> Void)] + [preferences:set (Symbol Any -> Void)] + [editor:get-standard-style-list + (-> (Instance Style-List%))] + [scheme:text% Scheme:Text%] + [gui-utils:ok/cancel-buttons (Any (Any Any -> Any) (Any Any -> Any) -> (values Any Any))]) + +(require/typed "prefs-contract.ss" + [preferences:get-drscheme:large-letters-font (-> (Pair Symbol Number))]) + +(require (only-in "prefs-contract.ss" preferences:get)) +(provide preferences:get preferences:get-drscheme:large-letters-font) + +(define-type-alias Bitmap-Message% (Class () + ([parent Any]) + ([set-bm ((Instance Bitmap%) -> Void)]))) + + +(require/typed "bitmap-message.ss" + [bitmap-message% Bitmap-Message%]) \ No newline at end of file diff --git a/collects/drscheme/private/prefs-contract.ss b/collects/drscheme/private/prefs-contract.ss deleted file mode 100644 index dd62fb14d3..0000000000 --- a/collects/drscheme/private/prefs-contract.ss +++ /dev/null @@ -1,16 +0,0 @@ -#lang scheme/base - -(require (for-syntax scheme/base) - framework/framework) - -(provide (rename-out [-preferences:get preferences:get]) - preferences:get-drscheme:large-letters-font) - -(define (preferences:get-drscheme:large-letters-font) - (preferences:get 'drscheme:large-letters-font)) - -(define-syntax (-preferences:get stx) - (syntax-case stx (quote) - [(_ (quote sym)) - (with-syntax ([nm (datum->syntax stx (string->symbol (string-append "preferences:get" "-" (symbol->string (syntax-e #'sym)))))]) - (syntax/loc stx (nm)))])) diff --git a/collects/drscheme/syncheck/annotate.ss b/collects/drscheme/syncheck/annotate.ss new file mode 100644 index 0000000000..087aba6e3b --- /dev/null +++ b/collects/drscheme/syncheck/annotate.ss @@ -0,0 +1,634 @@ +#lang scheme/base + +(provide (all-defined-out)) + +(require string-constants/string-constant + scheme/unit + scheme/contract + scheme/class + drscheme/tool + mzlib/list + syntax/toplevel + syntax/boundmap + mrlib/bitmap-label + (prefix-in drscheme:arrow: drscheme/arrow) + (prefix-in fw: framework/framework) + mred/mred + setup/xref + scribble/xref + scribble/manual-struct + net/url + net/uri-codec + browser/external + (for-syntax scheme/base) + "extra-stxcase.ss" + "id-sets.ss" + "extra-typed.ss" + "utils.ss") + + + ; + ; + ; + ; ; + ; ; + ; ; ; ; + ; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;; + ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; + ; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;; + ; ; + ; ; + ; ; + + + + ;; annotate-basic : syntax + ;; namespace + ;; string[directory] + ;; syntax[id] + ;; id-set (six of them) + ;; hash-table[require-spec -> syntax] (three of them) + ;; -> void + (define (annotate-basic sexp user-namespace user-directory jump-to-id + low-binders high-binders + low-varrefs high-varrefs + low-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + (let ([tail-ht (make-hash-table)] + [maybe-jump + (λ (vars) + (when jump-to-id + (for-each (λ (id) + (let ([binding (identifier-binding id)]) + (when (pair? binding) + (let ([nominal-source-id (list-ref binding 3)]) + (when (eq? nominal-source-id jump-to-id) + (jump-to id)))))) + (syntax->list vars))))]) + + (let level-loop ([sexp sexp] + [high-level? #f]) + (let* ([loop (λ (sexp) (level-loop sexp high-level?))] + [varrefs (if high-level? high-varrefs low-varrefs)] + [binders (if high-level? high-binders low-binders)] + [tops (if high-level? high-tops low-tops)] + [collect-general-info + (λ (stx) + (add-origins stx varrefs) + (add-disappeared-bindings stx binders varrefs) + (add-disappeared-uses stx varrefs))]) + (collect-general-info sexp) + (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! + quote quote-syntax with-continuation-mark + #%plain-app #%top #%plain-module-begin + define-values define-syntaxes define-values-for-syntax module + #%require #%provide #%expression) + (if high-level? free-transformer-identifier=? free-identifier=?) + [(#%plain-lambda args bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (add-binders (syntax args) binders) + (for-each loop (syntax->list (syntax (bodies ...)))))] + [(case-lambda [argss bodiess ...]...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each (λ (bodies/stx) (annotate-tail-position/last sexp + (syntax->list bodies/stx) + tail-ht)) + (syntax->list (syntax ((bodiess ...) ...)))) + (for-each + (λ (args bodies) + (add-binders args binders) + (for-each loop (syntax->list bodies))) + (syntax->list (syntax (argss ...))) + (syntax->list (syntax ((bodiess ...) ...)))))] + [(if test then else) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax then) tail-ht) + (annotate-tail-position sexp (syntax else) tail-ht) + (loop (syntax test)) + (loop (syntax else)) + (loop (syntax then)))] + [(begin bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ;; treat a single body expression specially, since this has + ;; different tail behavior. + [(begin0 body) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax body) tail-ht) + (loop (syntax body)))] + + [(begin0 bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + [(let-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(letrec-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(set! var e) + (begin + (annotate-raw-keyword sexp varrefs) + + ;; tops are used here because a binding free use of a set!'d variable + ;; is treated just the same as (#%top . x). + (when (syntax-original? (syntax var)) + (if (identifier-binding (syntax var)) + (add-id varrefs (syntax var)) + (add-id tops (syntax var)))) + + (loop (syntax e)))] + [(quote datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs)] + [(quote-syntax datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs) + (let loop ([stx #'datum]) + (cond [(identifier? stx) + (when (syntax-original? stx) + (add-id templrefs stx))] + [(syntax? stx) + (loop (syntax-e stx))] + [(pair? stx) + (loop (car stx)) + (loop (cdr stx))] + [(vector? stx) + (for-each loop (vector->list stx))] + [(box? stx) + (loop (unbox stx))] + [else (void)]))] + [(with-continuation-mark a b c) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax c) tail-ht) + (loop (syntax a)) + (loop (syntax b)) + (loop (syntax c)))] + [(#%plain-app pieces ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (pieces ...)))))] + [(#%top . var) + (begin + (annotate-raw-keyword sexp varrefs) + (when (syntax-original? (syntax var)) + (add-id tops (syntax var))))] + [(define-values vars b) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax vars) binders) + (maybe-jump (syntax vars)) + (loop (syntax b)))] + [(define-syntaxes names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(define-values-for-syntax names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) high-binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(module m-name lang (#%plain-module-begin bodies ...)) + (begin + (annotate-raw-keyword sexp varrefs) + ((annotate-require-open user-namespace user-directory) (syntax lang)) + + ;; temporarily removed until Matthew fixes whatever. + #; + (hash-table-put! requires + (syntax->datum (syntax lang)) + (cons (syntax lang) + (hash-table-get requires + (syntax->datum (syntax lang)) + (λ () '())))) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ; top level or module top level only: + [(#%require require-specs ...) + (let ([at-phase + (lambda (stx requires) + (syntax-case stx () + [(_ require-specs ...) + (let ([new-specs (map trim-require-prefix + (syntax->list (syntax (require-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (annotate-require-open user-namespace user-directory) new-specs) + (for-each (add-require-spec requires) + new-specs + (syntax->list (syntax (require-specs ...)))))]))]) + (for-each (lambda (spec) + (syntax-case* spec (for-syntax for-template for-label) (lambda (a b) + (eq? (syntax-e a) (syntax-e b))) + [(for-syntax specs ...) + (at-phase spec require-for-syntaxes)] + [(for-template specs ...) + (at-phase spec require-for-templates)] + [(for-label specs ...) + (at-phase spec require-for-labels)] + [else + (at-phase (list #f spec) requires)])) + (syntax->list #'(require-specs ...))))] + + ; module top level only: + [(#%provide provide-specs ...) + (let ([provided-varss (map extract-provided-vars + (syntax->list (syntax (provide-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (λ (provided-vars) + (for-each + (λ (provided-var) + (when (syntax-original? provided-var) + (add-id varrefs provided-var))) + provided-vars)) + provided-varss))] + + [(#%expression arg) + (begin + (annotate-raw-keyword sexp varrefs) + (loop #'arg))] + [id + (identifier? (syntax id)) + (when (syntax-original? sexp) + (add-id varrefs sexp))] + [_ + (begin + #; + (printf "unknown stx: ~e datum: ~e source: ~e\n" + sexp + (and (syntax? sexp) + (syntax->datum sexp)) + (and (syntax? sexp) + (syntax-source sexp))) + (void))]))) + (add-tail-ht-links tail-ht))) + + ;; jump-to : syntax -> void + (define (jump-to stx) + (let ([src (find-source-editor stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (when (and (is-a? src text%) + pos + span) + (send src set-position (- pos 1) (+ pos span -1))))) + + + ;; annotate-require-open : namespace string -> (stx -> void) + ;; relies on current-module-name-resolver, which in turn depends on + ;; current-directory and current-namespace + (define (annotate-require-open user-namespace user-directory) + (λ (require-spec) + (when (syntax-original? require-spec) + (let ([source (find-source-editor require-spec)]) + (when (and (is-a? source text%) + (syntax-position require-spec) + (syntax-span require-spec)) + (let ([defs-text (get-defs-text)]) + (when defs-text + (let* ([start (- (syntax-position require-spec) 1)] + [end (+ start (syntax-span require-spec))] + [file (get-require-filename (syntax->datum require-spec) + user-namespace + user-directory)]) + (when file + (send defs-text syncheck:add-menu + source + start end + #f + (make-require-open-menu file))))))))))) + + ;; hash-table[syntax -o> (listof syntax)] -> void + (define (add-tail-ht-links tail-ht) + (hash-table-for-each + tail-ht + (λ (stx-from stx-tos) + (for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to)) + stx-tos)))) + + ;; add-tail-ht-link : syntax syntax -> void + (define (add-tail-ht-link from-stx to-stx) + (let* ([to-src (find-source-editor to-stx)] + [from-src (find-source-editor from-stx)] + [defs-text (get-defs-text)]) + (when (and to-src from-src defs-text) + (let ([from-pos (syntax-position from-stx)] + [to-pos (syntax-position to-stx)]) + (when (and from-pos to-pos) + (send defs-text syncheck:add-tail-arrow + from-src (- from-pos 1) + to-src (- to-pos 1))))))) + + ;; find-source : definitions-text source -> editor or false + (define (find-source-editor stx) + (let ([defs-text (get-defs-text)]) + (and defs-text + (let txt-loop ([text defs-text]) + (cond + [(and (is-a? text fw:text:basic<%>) + (send text port-name-matches? (syntax-source stx))) + text] + [else + (let snip-loop ([snip (send text find-first-snip)]) + (cond + [(not snip) + #f] + [(and (is-a? snip editor-snip%) + (send snip get-editor)) + (or (txt-loop (send snip get-editor)) + (snip-loop (send snip next)))] + [else + (snip-loop (send snip next))]))]))))) + + ;; get-defs-text : -> text or false + (define (get-defs-text) + (let ([drs-frame (currently-processing-drscheme-frame)]) + (and drs-frame + (send drs-frame get-definitions-text)))) + + + + + ;; record-renamable-var : rename-ht syntax -> void + (define (record-renamable-var rename-ht stx) + (let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))]) + (hash-table-put! rename-ht + key + (cons stx (hash-table-get rename-ht key (λ () '())))))) + + + ;; connect-identifier : syntax + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; (listof id-set) + ;; namespace + ;; directory + ;; boolean + ;; -> void + ;; adds arrows and rename menus for binders/bindings + (define (connect-identifier var rename-ht all-binders unused requires get-binding user-namespace user-directory actual?) + (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) + (when (and actual? (get-ids all-binders var)) + (record-renamable-var rename-ht var))) + + ;; connect-identifier/arrow : syntax + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; boolean + ;; -> void + ;; adds the arrows that correspond to binders/bindings + (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) + (let ([binders (get-ids all-binders var)]) + (when binders + (for-each (λ (x) + (when (syntax-original? x) + (connect-syntaxes x var actual?))) + binders)) + + (when (and unused requires) + (let ([req-path/pr (get-module-req-path (get-binding var))]) + (when req-path/pr + (let* ([req-path (car req-path/pr)] + [id (cdr req-path/pr)] + [req-stxes (hash-table-get requires req-path (λ () #f))]) + (when req-stxes + (hash-table-remove! unused req-path) + (for-each (λ (req-stx) + (when (id/require-match? (syntax->datum var) + id + (syntax->datum req-stx)) + (when id + (add-jump-to-definition + var + id + (get-require-filename req-path user-namespace user-directory))) + (add-mouse-over var (fw:gui-utils:format-literal-label (string-constant cs-mouse-over-import) + (syntax-e var) + req-path)) + (connect-syntaxes req-stx var actual?))) + req-stxes)))))))) + + (define (id/require-match? var id req-stx) + (cond + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix)) + (let ([prefix (list-ref req-stx 1)]) + (equal? (format "~a~a" prefix id) + (symbol->string var)))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix-all-except)) + (let ([prefix (list-ref req-stx 1)]) + (and (not (memq id (cdddr req-stx))) + (equal? (format "~a~a" prefix id) + (symbol->string var))))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'rename)) + (eq? (list-ref req-stx 2) + var)] + [else (eq? var id)])) + + + ;; color/connect-top : namespace directory id-set syntax -> void + (define (color/connect-top rename-ht user-namespace user-directory binders var) + (let ([top-bound? + (or (get-ids binders var) + (parameterize ([current-namespace user-namespace]) + (let/ec k + (namespace-variable-value (syntax-e var) #t (λ () (k #f))) + #t)))]) + (if top-bound? + (color var lexically-bound-variable-style-name) + (color var error-style-name)) + (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t))) + + + ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void + (define (color-unused requires unused) + (hash-table-for-each + unused + (λ (k v) + (for-each (λ (stx) (color stx error-style-name)) + (hash-table-get requires k))))) + + + + + ; + ; + ; + ; ; + ; ; + ; + ; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; + ; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;; + ; ; + ; ; ; + ; ;;; + + + ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void + (define (make-rename-menu stxs id-sets) + (let ([defs-frame (currently-processing-drscheme-frame)]) + (when defs-frame + (let* ([defs-text (send defs-frame get-definitions-text)] + [source (syntax-source (car stxs))]) ;; all stxs in the list must have the same source + (when (and (send defs-text port-name-matches? source) + (send defs-text port-name-matches? source)) + (let* ([name-to-offer (format "~a" (syntax->datum (car stxs)))] + [start (- (syntax-position (car stxs)) 1)] + [fin (+ start (syntax-span (car stxs)))]) + (send defs-text syncheck:add-menu + defs-text + start + fin + (syntax-e (car stxs)) + (λ (menu) + (instantiate menu-item% () + (parent menu) + (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) + (callback + (λ (x y) + (let ([frame-parent (find-menu-parent menu)]) + (rename-callback name-to-offer + defs-text + stxs + id-sets + frame-parent))))))))))))) + + ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) + (define (find-menu-parent menu) + (let loop ([menu menu]) + (cond + [(is-a? menu menu-bar%) (send menu get-frame)] + [(is-a? menu popup-menu%) + (let ([target (send menu get-popup-target)]) + (cond + [(is-a? target editor<%>) + (let ([canvas (send target get-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [(is-a? target window<%>) + (send target get-top-level-window)] + [else #f]))] + [(is-a? menu menu-item<%>) (loop (send menu get-parent))] + [else #f]))) + + ;; rename-callback : string + ;; (and/c syncheck-text<%> definitions-text<%>) + ;; (listof syntax[original]) + ;; (listof id-set) + ;; (union #f (is-a?/c top-level-window<%>)) + ;; -> void + ;; callback for the rename popup menu item + (define (rename-callback name-to-offer defs-text stxs id-sets parent) + (let ([new-str + (fw:keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (string-constant cs-rename-id) + (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) + parent + name-to-offer)))]) + (when new-str + (let ([new-sym (format "~s" (string->symbol new-str))]) + (let* ([to-be-renamed + (remove-duplicates + (sort + (apply + append + (map (λ (id-set) + (apply + append + (map (λ (stx) (or (get-ids id-set stx) '())) stxs))) + id-sets)) + (λ (x y) + ((syntax-position x) . >= . (syntax-position y)))))] + [do-renaming? + (or (not (name-duplication? to-be-renamed id-sets new-sym)) + (equal? + (message-box/custom + (string-constant check-syntax) + (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) + new-sym) + (string-constant cs-rename-anyway) + (string-constant cancel) + #f + parent + '(stop default=2)) + 1))]) + (when do-renaming? + (unless (null? to-be-renamed) + (send defs-text begin-edit-sequence) + (for-each (λ (stx) + (let ([source (syntax-source stx)]) + (when (send defs-text port-name-matches? source) + (let* ([start (- (syntax-position stx) 1)] + [end (+ start (syntax-span stx))]) + (send defs-text delete start end #f) + (send defs-text insert new-sym start start #f))))) + to-be-renamed) + (send defs-text invalidate-bitmap-cache) + (send defs-text end-edit-sequence)))))))) + + ;; get-require-filename : sexp namespace string[directory] -> filename + ;; finds the filename corresponding to the require in stx + (define (get-require-filename datum user-namespace user-directory) + (let ([mp + (parameterize ([current-namespace user-namespace] + [current-directory user-directory] + [current-load-relative-directory user-directory]) + (with-handlers ([exn:fail? (λ (x) #f)]) + ((current-module-name-resolver) datum #f #f)))]) + (and (resolved-module-path? mp) + (resolved-module-path-name mp)))) + + + ;; make-require-open-menu : path -> menu -> void + (define (make-require-open-menu file) + (λ (menu) + (let-values ([(base name dir?) (split-path file)]) + (instantiate menu-item% () + (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) + (parent menu) + (callback (λ (x y) (fw:handler:edit-file file)))) + (void)))) \ No newline at end of file diff --git a/collects/drscheme/syncheck/color.ss b/collects/drscheme/syncheck/color.ss new file mode 100644 index 0000000000..a1c6ef45a9 --- /dev/null +++ b/collects/drscheme/syncheck/color.ss @@ -0,0 +1,84 @@ +#lang scheme/base + +(require string-constants/string-constant + scheme/unit + scheme/contract + scheme/class + drscheme/tool + mzlib/list + syntax/toplevel + syntax/boundmap + mrlib/bitmap-label + (prefix-in drscheme:arrow: drscheme/arrow) + (prefix-in fw: framework/framework) + mred/mred + setup/xref + scribble/xref + scribble/manual-struct + net/url + net/uri-codec + browser/external + (for-syntax scheme/base) + "extra-stxcase.ss" + "id-sets.ss" + "extra-typed.ss") +;; color : syntax[original] str -> void +;; colors the syntax with style-name's style +(define (color stx style-name) + (let ([source (find-source-editor stx)]) + (when (is-a? source text%) + (let ([pos (- (syntax-position stx) 1)] + [span (syntax-span stx)]) + (color-range source pos (+ pos span) style-name))))) + +;; color-range : text start finish style-name +;; colors a range in the text based on `style-name' +(define (color-range source start finish style-name) + (let ([style (send (send source get-style-list) + find-named-style + style-name)]) + (add-to-cleanup-texts source) + (send source change-style style start finish #f))) + + ;; find-source : definitions-text source -> editor or false + (define (find-source-editor stx) + (let ([defs-text (get-defs-text)]) + (and defs-text + (let txt-loop ([text defs-text]) + (cond + [(and (is-a? text fw:text:basic<%>) + (send text port-name-matches? (syntax-source stx))) + text] + [else + (let snip-loop ([snip (send text find-first-snip)]) + (cond + [(not snip) + #f] + [(and (is-a? snip editor-snip%) + (send snip get-editor)) + (or (txt-loop (send snip get-editor)) + (snip-loop (send snip next)))] + [else + (snip-loop (send snip next))]))]))))) + +;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void + (define (add-to-cleanup-texts ed) + (let ([ed (find-outermost-editor ed)]) + (when (is-a? ed drscheme:unit:definitions-text<%>) + (let ([tab (send ed get-tab)]) + (send tab syncheck:add-to-cleanup-texts ed))))) + + ;; get-defs-text : -> text or false + (define (get-defs-text) + (let ([drs-frame (currently-processing-drscheme-frame)]) + (and drs-frame + (send drs-frame get-definitions-text)))) + + (define (find-outermost-editor ed) + (let loop ([ed ed]) + (let ([admin (send ed get-admin)]) + (if (is-a? admin editor-snip-editor-admin<%>) + (let* ([enclosing-snip (send admin get-snip)] + [enclosing-snip-admin (send enclosing-snip get-admin)]) + (loop (send enclosing-snip-admin get-editor))) + ed)))) \ No newline at end of file diff --git a/collects/drscheme/syncheck/extra-stxcase.ss b/collects/drscheme/syncheck/extra-stxcase.ss new file mode 100644 index 0000000000..d5ac6927cc --- /dev/null +++ b/collects/drscheme/syncheck/extra-stxcase.ss @@ -0,0 +1,44 @@ +#lang scheme/base + +(require (only-in "extra-typed.ss" symbolic-compare?)) + +(provide (all-defined-out)) + +;; FIXME: handle for-template and for-label +;; extract-provided-vars : syntax -> (listof syntax[identifier]) +(define (extract-provided-vars stx) + (syntax-case* stx (rename struct all-from all-from-except all-defined-except) symbolic-compare? + [identifier + (identifier? (syntax identifier)) + (list (syntax identifier))] + + [(rename local-identifier export-identifier) + (list (syntax local-identifier))] + + ;; why do I even see this?!? + [(struct struct-identifier (field-identifier ...)) + null] + + [(all-from module-name) null] + [(all-from-except module-name identifier ...) + null] + [(all-defined-except identifier ...) + (syntax->list #'(identifier ...))] + [_ + null])) + + +;; trim-require-prefix : syntax -> syntax +(define (trim-require-prefix require-spec) + (syntax-case* require-spec (only prefix all-except prefix-all-except rename) symbolic-compare? + [(only module-name identifer ...) + (syntax module-name)] + [(prefix identifier module-name) + (syntax module-name)] + [(all-except module-name identifer ...) + (syntax module-name)] + [(prefix-all-except module-name identifer ...) + (syntax module-name)] + [(rename module-name local-identifer exported-identifer) + (syntax module-name)] + [_ require-spec])) \ No newline at end of file diff --git a/collects/drscheme/syncheck/extra-typed.ss b/collects/drscheme/syncheck/extra-typed.ss new file mode 100644 index 0000000000..06f129af52 --- /dev/null +++ b/collects/drscheme/syncheck/extra-typed.ss @@ -0,0 +1,453 @@ +#lang typed-scheme + +(require (except-in scheme/list remove-duplicates) + "id-sets.ss") + +(define-type-alias (MaybeList a) (Rec x (U a '() (Pair a x)))) + +(provide (all-defined-out)) + +;; remove-duplicates : (listof syntax[original]) -> (listof syntax[original]) +;; removes duplicates, based on the source locations of the identifiers +;; assumes the list is ordered by source location +(: remove-duplicates ((Listof Syntax) -> (Listof Syntax))) +(define (remove-duplicates ids) + (cond + [(null? ids) null] + [else (let: loop : (Listof Syntax) + ([fst : Syntax (car ids)] + [rst : (Listof Syntax) (cdr ids)]) + (cond + [(null? rst) (list fst)] + [else (if (and (eq? (syntax-source fst) + (syntax-source (car rst))) + ;; CHANGE - used eqv? instead of =, since these might be #f + (eqv? (syntax-position fst) + (syntax-position (car rst)))) + (loop fst (cdr rst)) + (cons fst (loop (car rst) (cdr rst))))]))])) + + +;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean +;; returns #t if the name chosen would be the same as another name in this scope. +(: name-duplication? ((Listof Identifier) (Listof Id-Set) String -> Any)) +(define (name-duplication? to-be-renamed id-sets new-str) + (let ([new-ids (map (λ: ([id : Identifier]) (datum->syntax id (string->symbol new-str))) + to-be-renamed)]) + (ormap (λ: ([id-set : Id-Set]) + (ormap (λ: ([new-id : Identifier]) (get-ids id-set new-id)) + new-ids)) + id-sets))) + + +;; annotate-raw-keyword : syntax id-map -> void +;; annotates keywords when they were never expanded. eg. +;; if someone just types `(λ (x) x)' it has no 'origin +;; field, but there still are keywords. +(: annotate-raw-keyword (Syntax Id-Set -> Any)) +(define (annotate-raw-keyword stx id-map) + (let ([lst (syntax-e stx)]) + (when (pair? lst) + (let ([f-stx (car lst)]) + (when (and (syntax-original? f-stx) + (identifier? f-stx)) + (add-id id-map f-stx)))))) + + +;; add-binders : syntax id-set -> void +;; transforms an argument list into a bunch of symbols/symbols +;; and puts them into the id-set +;; effect: colors the identifiers +(: add-binders (Syntax Id-Set -> Void)) +(define (add-binders stx id-set) + (let: loop : Void ([stx : (MaybeList Syntax) stx]) + (let ([e (if (syntax? stx) (syntax-e stx) stx)]) + (cond + [(cons? e) + (let ([fst (car e)] + [rst (cdr e)]) + (if (identifier? fst) ;; CHANGE - was (syntax? fst) + (begin + (when (syntax-original? fst) + (add-id id-set fst)) + (loop rst)) + (loop rst)))] + [(null? e) (void)] + [(identifier? stx) ;; CHANGE -- used to be else + (when (syntax-original? stx) + (add-id id-set stx))])))) + +(define-type-alias TailHT (HashTable Syntax (Listof Syntax))) + +;; annotate-tail-position/last : (listof syntax) -> void +(: annotate-tail-position/last (Syntax (Listof Syntax) TailHT -> Void)) +(define (annotate-tail-position/last orig-stx stxs tail-ht) + (unless (null? stxs) + (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht))) + +;; annotate-tail-position : syntax -> void +;; colors the parens (if any) around the argument +;; to indicate this is a tail call. +(: annotate-tail-position (Syntax Syntax TailHT -> Void)) +(define (annotate-tail-position orig-stx tail-stx tail-ht) + (hash-set! + tail-ht + orig-stx + (cons + tail-stx + (hash-ref + tail-ht + orig-stx + (λ () null))))) + +;; add-disappeared-uses : syntax id-set -> void +(: add-disappeared-uses (Syntax Id-Set -> Void)) +(define (add-disappeared-uses stx id-set) + (let ([prop (syntax-property stx 'disappeared-use)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-id id-set prop)]))))) + +;; add-require-spec : hash-table[sexp[require-spec] -o> (listof syntax)] +;; -> require-spec +;; syntax +;; -> void +(: add-require-spec ((HashTable Any (Listof Syntax)) -> (Syntax Syntax -> Void))) +(define (add-require-spec require-ht) + (λ (raw-spec syntax) + (when (syntax-original? syntax) + (let ([key (syntax->datum raw-spec)]) + (hash-set! require-ht + key + (cons syntax + (hash-ref require-ht + key + (λ () '())))))))) + +;; possible-suffixes : (listof string) +;; these are the suffixes that are checked for the reverse +;; module-path mapping. +(: possible-suffixes (Listof String)) +(define possible-suffixes '(".ss" ".scm" "")) + +;; add-origins : sexp id-set -> void +(: add-origins (Syntax Id-Set -> Void)) +(define (add-origins sexp id-set) + (let ([origin (syntax-property sexp 'origin)]) + (when (syntax? origin) ;; CHANGE - was (when origin ...) + (let loop ([ct origin]) + (cond + [(pair? ct) + (loop (car ct)) + (loop (cdr ct))] + [(identifier? ct) ;; CHANGE - was (syntax? ct) + (when (syntax-original? ct) + (add-id id-set ct))] + [else (void)]))))) + + +;; add-disappeared-bindings : syntax id-set -> void +(: add-disappeared-bindings (Syntax Id-Set Id-Set -> Void)) +(define (add-disappeared-bindings stx binders disappaeared-uses) + (let ([prop (syntax-property stx 'disappeared-binding)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-origins prop disappaeared-uses) + (add-id binders prop)]))))) + +;; module-name-sym->filename : symbol -> (union #f string) +(: module-name-sym->filename (Symbol -> (Option Path))) +(define (module-name-sym->filename sym) + (let ([str (symbol->string sym)]) + (and ((string-length str) . > . 1) + (char=? (string-ref str 0) #\,) + (let ([fn (substring str 1 (string-length str))]) + (ormap (λ: ([x : String]) + (let ([test (string->path (string-append fn x))]) + (and (file-exists? test) + test))) + possible-suffixes))))) + +(: symbolic-compare? (Syntax Syntax -> Boolean)) +(define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y))) + +;; type req/tag = (make-req/tag syntax sexp boolean) +(define-typed-struct req/tag ([req-stx : Syntax] [req-sexp : Any] [used? : Boolean])) + +;; add-var : hash-table -> syntax -> void +;; adds the variable to the hash table. +(: add-var ((HashTable Any (Listof Any)) -> (Syntax -> Void))) +(define (add-var ht) + (λ (var) + (let* ([key (syntax-e var)] + [prev (hash-ref ht #{key :: Any} (λ () #{null :: (Listof Any)}))]) + (hash-set! ht #{key :: Any} #{(cons var prev) :: (Listof Any)})))) + + + +#| +;; annotate-basic : syntax +;; namespace +;; string[directory] +;; syntax[id] +;; id-set (six of them) +;; hash-table[require-spec -> syntax] (three of them) +;; -> void +(: annotate-basic (Syntax + Any String Syntax + Id-Set Id-Set Id-Set Id-Set Id-Set Id-Set + Any + (HashTable Syntax Syntax) (HashTable Syntax Syntax) (HashTable Syntax Syntax) (HashTable Syntax Syntax) + -> Void)) +(define (annotate-basic sexp user-namespace user-directory jump-to-id + low-binders high-binders + low-varrefs high-varrefs + low-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + (let ([tail-ht (make-hash-table)] + [maybe-jump + (λ: ([vars : Syntax]) + (when jump-to-id + (for-each (λ: ([id : Identifier]) + (let ([binding (identifier-binding id)]) + (when (pair? binding) + (let ([nominal-source-id (list-ref binding 3)]) + (when (eq? nominal-source-id jump-to-id) + (jump-to id)))))) + (syntax->list vars))))]) + + (let level-loop ([sexp sexp] + [high-level? #f]) + (let* ([loop (λ (sexp) (level-loop sexp high-level?))] + [varrefs (if high-level? high-varrefs low-varrefs)] + [binders (if high-level? high-binders low-binders)] + [tops (if high-level? high-tops low-tops)] + [collect-general-info + (λ (stx) + (add-origins stx varrefs) + (add-disappeared-bindings stx binders varrefs) + (add-disappeared-uses stx varrefs))]) + (collect-general-info sexp) + (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! + quote quote-syntax with-continuation-mark + #%plain-app #%top #%plain-module-begin + define-values define-syntaxes define-values-for-syntax module + #%require #%provide #%expression) + (if high-level? free-transformer-identifier=? free-identifier=?) + [(#%plain-lambda args bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (add-binders (syntax args) binders) + (for-each loop (syntax->list (syntax (bodies ...)))))] + [(case-lambda [argss bodiess ...]...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each (λ (bodies/stx) (annotate-tail-position/last sexp + (syntax->list bodies/stx) + tail-ht)) + (syntax->list (syntax ((bodiess ...) ...)))) + (for-each + (λ (args bodies) + (add-binders args binders) + (for-each loop (syntax->list bodies))) + (syntax->list (syntax (argss ...))) + (syntax->list (syntax ((bodiess ...) ...)))))] + [(if test then else) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax then) tail-ht) + (annotate-tail-position sexp (syntax else) tail-ht) + (loop (syntax test)) + (loop (syntax else)) + (loop (syntax then)))] + [(begin bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ;; treat a single body expression specially, since this has + ;; different tail behavior. + [(begin0 body) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax body) tail-ht) + (loop (syntax body)))] + + [(begin0 bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + [(let-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(letrec-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(set! var e) + (begin + (annotate-raw-keyword sexp varrefs) + + ;; tops are used here because a binding free use of a set!'d variable + ;; is treated just the same as (#%top . x). + (when (syntax-original? (syntax var)) + (if (identifier-binding (syntax var)) + (add-id varrefs (syntax var)) + (add-id tops (syntax var)))) + + (loop (syntax e)))] + [(quote datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs)] + [(quote-syntax datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs) + (let loop ([stx #'datum]) + (cond [(identifier? stx) + (when (syntax-original? stx) + (add-id templrefs stx))] + [(syntax? stx) + (loop (syntax-e stx))] + [(pair? stx) + (loop (car stx)) + (loop (cdr stx))] + [(vector? stx) + (for-each loop (vector->list stx))] + [(box? stx) + (loop (unbox stx))] + [else (void)]))] + [(with-continuation-mark a b c) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax c) tail-ht) + (loop (syntax a)) + (loop (syntax b)) + (loop (syntax c)))] + [(#%plain-app pieces ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (pieces ...)))))] + [(#%top . var) + (begin + (annotate-raw-keyword sexp varrefs) + (when (syntax-original? (syntax var)) + (add-id tops (syntax var))))] + [(define-values vars b) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax vars) binders) + (maybe-jump (syntax vars)) + (loop (syntax b)))] + [(define-syntaxes names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(define-values-for-syntax names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) high-binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(module m-name lang (#%plain-module-begin bodies ...)) + (begin + (annotate-raw-keyword sexp varrefs) + ((annotate-require-open user-namespace user-directory) (syntax lang)) + + ;; temporarily removed until Matthew fixes whatever. + #; + (hash-table-put! requires + (syntax->datum (syntax lang)) + (cons (syntax lang) + (hash-table-get requires + (syntax->datum (syntax lang)) + (λ () '())))) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ; top level or module top level only: + [(#%require require-specs ...) + (let ([at-phase + (lambda (stx requires) + (syntax-case stx () + [(_ require-specs ...) + (let ([new-specs (map trim-require-prefix + (syntax->list (syntax (require-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (annotate-require-open user-namespace user-directory) new-specs) + (for-each (add-require-spec requires) + new-specs + (syntax->list (syntax (require-specs ...)))))]))]) + (for-each (lambda (spec) + (syntax-case* spec (for-syntax for-template for-label) (lambda (a b) + (eq? (syntax-e a) (syntax-e b))) + [(for-syntax specs ...) + (at-phase spec require-for-syntaxes)] + [(for-template specs ...) + (at-phase spec require-for-templates)] + [(for-label specs ...) + (at-phase spec require-for-labels)] + [else + (at-phase (list #f spec) requires)])) + (syntax->list #'(require-specs ...))))] + + ; module top level only: + [(#%provide provide-specs ...) + (let ([provided-varss (map extract-provided-vars + (syntax->list (syntax (provide-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (λ (provided-vars) + (for-each + (λ (provided-var) + (when (syntax-original? provided-var) + (add-id varrefs provided-var))) + provided-vars)) + provided-varss))] + + [(#%expression arg) + (begin + (annotate-raw-keyword sexp varrefs) + (loop #'arg))] + [id + (identifier? (syntax id)) + (when (syntax-original? sexp) + (add-id varrefs sexp))] + [_ + (begin + #; + (printf "unknown stx: ~e datum: ~e source: ~e\n" + sexp + (and (syntax? sexp) + (syntax->datum sexp)) + (and (syntax? sexp) + (syntax-source sexp))) + (void))]))) + (add-tail-ht-links tail-ht))) +|# \ No newline at end of file diff --git a/collects/drscheme/syncheck/extra.ss b/collects/drscheme/syncheck/extra.ss new file mode 100644 index 0000000000..b541dbb395 --- /dev/null +++ b/collects/drscheme/syncheck/extra.ss @@ -0,0 +1,21 @@ +#lang scheme/base + + + + + + + + + + + + + + + + + + + + diff --git a/collects/drscheme/syncheck/id-sets.ss b/collects/drscheme/syncheck/id-sets.ss new file mode 100644 index 0000000000..fc2c720b25 --- /dev/null +++ b/collects/drscheme/syncheck/id-sets.ss @@ -0,0 +1,41 @@ +#lang typed-scheme + +(provide (rename-out [make-module-identifier-mapping make-id-set] + [module-identifier-mapping? id-set?]) + add-id get-idss get-ids for-each-ids + Id-Set) + +(require/opaque-type Id-Set module-identifier-mapping? syntax/boundmap) + +;; FIXME - need polymorphic imports +(require/typed [module-identifier-mapping-get module-identifier-mapping-get/f] + (Id-Set Identifier (-> #f) -> (U (Listof Identifier) #f)) + syntax/boundmap) + +(require/typed syntax/boundmap + [make-module-identifier-mapping (-> Id-Set)] + [module-identifier-mapping-get + (Id-Set Identifier (-> '()) -> (Listof Identifier))] + [module-identifier-mapping-put! (Id-Set Identifier (Listof Identifier) -> Void)] + [module-identifier-mapping-for-each (Id-Set (Identifier (Listof Identifier) -> Void) -> Void)] + [module-identifier-mapping-map + (Id-Set (Identifier (Listof Identifier) -> (Listof Identifier)) -> (Listof (Listof Identifier)))]) + + +(: add-id (Id-Set Identifier -> Void)) +(define (add-id mapping id) + (let* ([old (module-identifier-mapping-get mapping id (λ () '()))] + [new (cons id old)]) + (module-identifier-mapping-put! mapping id new))) + +(: get-idss (Id-Set -> (Listof (Listof Identifier)))) +(define (get-idss mapping) + (module-identifier-mapping-map mapping (λ: ([x : Identifier] [y : (Listof Identifier)]) y))) + +(: get-ids (Id-Set Identifier -> (U (Listof Identifier) #f))) +(define (get-ids mapping var) + (module-identifier-mapping-get/f mapping var (λ () #f))) + +(: for-each-ids (Id-Set ((Listof Identifier) -> Void) -> Void)) +(define (for-each-ids mapping f) + (module-identifier-mapping-for-each mapping (λ: ([x : Identifier] [y : (Listof Identifier)]) (f y)))) diff --git a/collects/drscheme/syncheck/make-traversal.ss b/collects/drscheme/syncheck/make-traversal.ss new file mode 100644 index 0000000000..efe7dd3dff --- /dev/null +++ b/collects/drscheme/syncheck/make-traversal.ss @@ -0,0 +1,86 @@ +#lang scheme/base + +(require "id-sets.ss" + "annotate.ss") + +;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void) +;; (namespace string[directory] -> void)) +;; returns a pair of functions that close over some state that +;; represents the top-level of a single program. The first value +;; is called once for each top-level expression and the second +;; value is called once, after all expansion is complete. +(define (make-traversal) + (let* ([tl-low-binders (make-id-set)] + [tl-high-binders (make-id-set)] + [tl-low-varrefs (make-id-set)] + [tl-high-varrefs (make-id-set)] + [tl-low-tops (make-id-set)] + [tl-high-tops (make-id-set)] + [tl-templrefs (make-id-set)] + [tl-requires (make-hash-table 'equal)] + [tl-require-for-syntaxes (make-hash-table 'equal)] + [tl-require-for-templates (make-hash-table 'equal)] + [tl-require-for-labels (make-hash-table 'equal)] + [expanded-expression + (λ (user-namespace user-directory sexp jump-to-id) + (parameterize ([current-load-relative-directory user-directory]) + (let ([is-module? (syntax-case sexp (module) + [(module . rest) #t] + [else #f])]) + (cond + [is-module? + (let ([low-binders (make-id-set)] + [high-binders (make-id-set)] + [varrefs (make-id-set)] + [high-varrefs (make-id-set)] + [low-tops (make-id-set)] + [high-tops (make-id-set)] + [templrefs (make-id-set)] + [requires (make-hash-table 'equal)] + [require-for-syntaxes (make-hash-table 'equal)] + [require-for-templates (make-hash-table 'equal)] + [require-for-labels (make-hash-table 'equal)]) + (annotate-basic sexp user-namespace user-directory jump-to-id + low-binders high-binders varrefs high-varrefs low-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + (annotate-variables user-namespace + user-directory + low-binders + high-binders + varrefs + high-varrefs + low-tops + high-tops + templrefs + requires + require-for-syntaxes + require-for-templates + require-for-labels))] + [else + (annotate-basic sexp user-namespace user-directory jump-to-id + tl-low-binders tl-high-binders + tl-low-varrefs tl-high-varrefs + tl-low-tops tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)]))))] + [expansion-completed + (λ (user-namespace user-directory) + (parameterize ([current-load-relative-directory user-directory]) + (annotate-variables user-namespace + user-directory + tl-low-binders + tl-high-binders + tl-low-varrefs + tl-high-varrefs + tl-low-tops + tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)))]) + (values expanded-expression expansion-completed))) \ No newline at end of file diff --git a/collects/drscheme/syncheck/syncheck.ss b/collects/drscheme/syncheck/syncheck.ss new file mode 100644 index 0000000000..0e5055440d --- /dev/null +++ b/collects/drscheme/syncheck/syncheck.ss @@ -0,0 +1,2755 @@ +#lang scheme/base +#| + +Check Syntax separates two classes of identifiers, +those bound in this file and those bound by require, +and uses identifier-binding and identifier-transformer-binding +to distinguish them. + +Variables come from 'origin, 'disappeared-use, and 'disappeared-binding +syntax properties, as well as from variable references and binding (letrec-values, +let-values, define-values) in the fully expanded text. + +Variables inside #%top (not inside a module) are treated specially. +If the namespace has a binding for them, they are colored bound color. +If the namespace does not, they are colored the unbound color. + +|# + + +(require string-constants + scheme/unit + scheme/contract + scheme/class + drscheme/tool + mzlib/list + syntax/toplevel + syntax/boundmap + mrlib/switchable-button + (prefix-in drscheme:arrow: drscheme/arrow) + (prefix-in fw: framework/framework) + mred + framework + setup/xref + scribble/xref + scribble/manual-struct + net/url + net/uri-codec + browser/external + (for-syntax scheme/base)) +(provide tool@) + +(define o (current-output-port)) + +(define status-init (string-constant cs-status-init)) +(define status-coloring-program (string-constant cs-status-coloring-program)) +(define status-eval-compile-time (string-constant cs-status-eval-compile-time)) +(define status-expanding-expression (string-constant cs-status-expanding-expression)) +(define status-loading-docs-index (string-constant cs-status-loading-docs-index)) + +(define jump-to-next-bound-occurrence (string-constant cs-jump-to-next-bound-occurrence)) +(define jump-to-binding (string-constant cs-jump-to-binding)) +(define jump-to-definition (string-constant cs-jump-to-definition)) + +(define-local-member-name + syncheck:init-arrows + syncheck:clear-arrows + syncheck:add-menu + syncheck:add-arrow + syncheck:add-tail-arrow + syncheck:add-mouse-over-status + syncheck:add-jump-to-definition + syncheck:sort-bindings-table + syncheck:jump-to-next-bound-occurrence + syncheck:jump-to-binding-occurrence + syncheck:jump-to-definition + + syncheck:clear-highlighting + syncheck:button-callback + syncheck:add-to-cleanup-texts + ;syncheck:error-report-visible? ;; test suite uses this one. + ;syncheck:get-bindings-table ;; test suite uses this one. + syncheck:clear-error-message + + hide-error-report + get-error-report-text + get-error-report-visible? + + turn-off-error-report + turn-on-error-report + + update-button-visibility/settings) + +(define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + ;; use this to communicate the frame being + ;; syntax checked w/out having to add new + ;; parameters to all of the functions + (define currently-processing-definitions-text (make-parameter #f)) + + (define (phase1) + (drscheme:unit:add-to-program-editor-mixin clearing-text-mixin)) + (define (phase2) (void)) + + (define (printf . args) (apply fprintf o args)) + + + (define xref 'not-yet-loaded-xref) + (define (get-xref) + (cond + [(equal? xref 'failed-to-load) #f] + [else + (when (symbol? xref) + (error 'get-xref "xref has not yet been loaded")) + xref])) + (define (force-xref th) + (cond + [(equal? xref 'failed-to-load) + (void)] + [(symbol? xref) + (th) + (with-handlers ((exn? (λ (exn) (set! xref 'failed-to-load)))) + (set! xref (load-collections-xref)))] + [else + (void)])) + + + + ;;; ;;; ;;; ;;;;; + ; ; ; ; ; + ; ; ; ; ; + ; ; ; ; + ; ;; ; ; ; + ; ; ; ; ; + ; ; ;; ;; ; + ;;; ;;; ;;;;; + + + ;; used for quicker debugging of the preference panel + '(define test-preference-panel + (λ (name f) + (let ([frame (make-object frame% name)]) + (f frame) + (send frame show #t)))) + + (define-struct graphic (pos* locs->thunks draw-fn click-fn)) + + (define-struct arrow (start-x start-y end-x end-y) #:mutable) + (define-struct (var-arrow arrow) + (start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual? level)) ;; level is one of 'lexical, 'top-level, 'import + (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos)) + + ;; color : string + ;; text: text:basic<%> + ;; start, fin: number + ;; used to represent regions to highlight when passing the mouse over the syncheck window + (define-struct colored-region (color text start fin)) + + ;; id : symbol -- the nominal-source-id from identifier-binding + ;; filename : path + (define-struct def-link (id filename) #:inspector (make-inspector)) + + (define tacked-var-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)) + (define var-pen (send the-pen-list find-or-create-pen "BLUE" 1 'solid)) + + (define templ-color (send the-color-database find-color "purple")) + (define templ-pen (send the-pen-list find-or-create-pen templ-color 1 'solid)) + (define tacked-templ-brush (send the-brush-list find-or-create-brush templ-color 'solid)) + + (define tail-pen (send the-pen-list find-or-create-pen "orchid" 1 'solid)) + (define tacked-tail-brush (send the-brush-list find-or-create-brush "orchid" 'solid)) + (define untacked-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) + + (define syncheck-text<%> + (interface () + syncheck:init-arrows + syncheck:clear-arrows + syncheck:add-menu + syncheck:add-arrow + syncheck:add-tail-arrow + syncheck:add-mouse-over-status + syncheck:add-jump-to-definition + syncheck:sort-bindings-table + syncheck:get-bindings-table + syncheck:jump-to-next-bound-occurrence + syncheck:jump-to-binding-occurrence + syncheck:jump-to-definition)) + + ;; clearing-text-mixin : (mixin text%) + ;; overrides methods that make sure the arrows go away appropriately. + ;; adds a begin/end-edit-sequence to the insertion and deletion + ;; to ensure that the on-change method isn't called until after + ;; the arrows are cleared. + (define clearing-text-mixin + (mixin ((class->interface text%)) () + + (inherit begin-edit-sequence end-edit-sequence) + (define/augment (on-delete start len) + (begin-edit-sequence) + (inner (void) on-delete start len)) + (define/augment (after-delete start len) + (inner (void) after-delete start len) + (clean-up) + (end-edit-sequence)) + + (define/augment (on-insert start len) + (begin-edit-sequence) + (inner (void) on-insert start len)) + (define/augment (after-insert start len) + (inner (void) after-insert start len) + (clean-up) + (end-edit-sequence)) + + (define/private (clean-up) + (let ([st (find-syncheck-text this)]) + (when (and st + (is-a? st drscheme:unit:definitions-text<%>)) + (let ([tab (send st get-tab)]) + (send tab syncheck:clear-error-message) + (send tab syncheck:clear-highlighting))))) + + (super-new))) + + (define make-syncheck-text% + (λ (super%) + (let* ([cursor-arrow (make-object cursor% 'arrow)]) + (class* super% (syncheck-text<%>) + (inherit set-cursor get-admin invalidate-bitmap-cache set-position + get-pos/text position-location + get-canvas last-position dc-location-to-editor-location + find-position begin-edit-sequence end-edit-sequence + highlight-range unhighlight-range + paragraph-end-position first-line-currently-drawn-specially?) + + + + ;; arrow-vectors : + ;; (union + ;; #f + ;; (hash-table + ;; (text% + ;; . -o> . + ;; (vector (listof (union (cons (union #f sym) (menu -> void)) + ;; def-link + ;; tail-link + ;; arrow + ;; string)))))) + (define arrow-vectors #f) + + + ;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))] + ;; this is a private field + (define bindings-table (make-hash)) + + ;; add-to-bindings-table : text number number text number number -> boolean + ;; results indicates if the binding was added to the table. It is added, unless + ;; 1) it is already there, or + ;; 2) it is a link to itself + (define/private (add-to-bindings-table start-text start-left start-right + end-text end-left end-right) + (cond + [(and (object=? start-text end-text) + (= start-left end-left) + (= start-right end-right)) + #f] + [else + (let* ([key (list start-text start-left start-right)] + [priors (hash-ref bindings-table key (λ () '()))] + [new (list end-text end-left end-right)]) + (cond + [(member new priors) + #f] + [else + (hash-set! bindings-table key (cons new priors)) + #t]))])) + + ;; for use in the automatic test suite + (define/public (syncheck:get-bindings-table) bindings-table) + + (define/public (syncheck:sort-bindings-table) + + ;; compare-bindings : (list text number number) (list text number number) -> boolean + (define (compare-bindings l1 l2) + (let ([start-text (list-ref l1 0)] + [start-left (list-ref l1 1)] + [end-text (list-ref l2 0)] + [end-left (list-ref l2 1)]) + (let-values ([(sx sy) (find-dc-location start-text start-left)] + [(ex ey) (find-dc-location end-text end-left)]) + (cond + [(= sy ey) (< sx ex)] + [else (< sy ey)])))) + + ;; find-dc-location : text number -> (values number number) + (define (find-dc-location text pos) + (let ([bx (box 0)] + [by (box 0)]) + (send text position-location pos bx by) + (send text editor-location-to-dc-location (unbox bx) (unbox by)))) + + (hash-for-each + bindings-table + (λ (k v) + (hash-set! bindings-table k (sort v compare-bindings))))) + + (define tacked-hash-table (make-hasheq)) + (define cursor-location #f) + (define cursor-text #f) + (define cursor-eles #f) + + ;; find-char-box : text number number -> (values number number number number) + ;; returns the bounding box (left, top, right, bottom) for the text range. + ;; only works right if the text is on a single line. + (define/private (find-char-box text left-pos right-pos) + (let ([xlb (box 0)] + [ylb (box 0)] + [xrb (box 0)] + [yrb (box 0)]) + (send text position-location left-pos xlb ylb #t) + (send text position-location right-pos xrb yrb #f) + (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] + [(xl yl) (dc-location-to-editor-location xl-off yl-off)] + [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] + [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) + (values + xl + yl + xr + yr)))) + + (define/private (update-arrow-poss arrow) + (cond + [(var-arrow? arrow) (update-var-arrow-poss arrow)] + [(tail-arrow? arrow) (update-tail-arrow-poss arrow)])) + + (define/private (update-var-arrow-poss arrow) + (let-values ([(start-x start-y) (find-poss + (var-arrow-start-text arrow) + (var-arrow-start-pos-left arrow) + (var-arrow-start-pos-right arrow))] + [(end-x end-y) (find-poss + (var-arrow-end-text arrow) + (var-arrow-end-pos-left arrow) + (var-arrow-end-pos-right arrow))]) + (set-arrow-start-x! arrow start-x) + (set-arrow-start-y! arrow start-y) + (set-arrow-end-x! arrow end-x) + (set-arrow-end-y! arrow end-y))) + + + (define/private (update-tail-arrow-poss arrow) + ;; If the item is an embedded editor snip, redirect + ;; the arrow to point at the left edge rather than the + ;; midpoint. + (define (find-poss/embedded text pos) + (let* ([snip (send text find-snip pos 'after)]) + (cond + [(and snip + (is-a? snip editor-snip%) + (= pos (send text get-snip-position snip))) + (find-poss text pos pos)] + [else + (find-poss text pos (+ pos 1))]))) + (let-values ([(start-x start-y) (find-poss/embedded + (tail-arrow-from-text arrow) + (tail-arrow-from-pos arrow))] + [(end-x end-y) (find-poss/embedded + (tail-arrow-to-text arrow) + (tail-arrow-to-pos arrow))]) + (set-arrow-start-x! arrow start-x) + (set-arrow-start-y! arrow start-y) + (set-arrow-end-x! arrow end-x) + (set-arrow-end-y! arrow end-y))) + + (define/private (find-poss text left-pos right-pos) + (let ([xlb (box 0)] + [ylb (box 0)] + [xrb (box 0)] + [yrb (box 0)]) + (send text position-location left-pos xlb ylb #t) + (send text position-location right-pos xrb yrb #f) + (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] + [(xl yl) (dc-location-to-editor-location xl-off yl-off)] + [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] + [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) + (values (/ (+ xl xr) 2) + (/ (+ yl yr) 2))))) + + ;; syncheck:init-arrows : -> void + (define/public (syncheck:init-arrows) + (set! tacked-hash-table (make-hasheq)) + (set! arrow-vectors (make-hasheq)) + (set! bindings-table (make-hash)) + (let ([f (get-top-level-window)]) + (when f + (send f open-status-line 'drscheme:check-syntax:mouse-over)))) + + ;; syncheck:clear-arrows : -> void + (define/public (syncheck:clear-arrows) + (when (or arrow-vectors cursor-location cursor-text) + (let ([any-tacked? #f]) + (when tacked-hash-table + (let/ec k + (hash-for-each + tacked-hash-table + (λ (key val) + (set! any-tacked? #t) + (k (void)))))) + (set! tacked-hash-table #f) + (set! arrow-vectors #f) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (when any-tacked? + (invalidate-bitmap-cache)) + (update-docs-background #f) + (let ([f (get-top-level-window)]) + (when f + (send f close-status-line 'drscheme:check-syntax:mouse-over)))))) + (define/public (syncheck:add-menu text start-pos end-pos key make-menu) + (when (and (<= 0 start-pos end-pos (last-position))) + (add-to-range/key text start-pos end-pos make-menu key #t))) + + (define/public (syncheck:add-background-color text color start fin key) + (when (is-a? text text:basic<%>) + (add-to-range/key text start fin (make-colored-region color text start fin) key #f))) + + ;; syncheck:add-arrow : symbol text number number text number number boolean -> void + ;; pre: start-editor, end-editor are embedded in `this' (or are `this') + (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual? level) + (let* ([arrow (make-var-arrow #f #f #f #f + start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual? level)]) + (when (add-to-bindings-table + start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right) + (add-to-range/key start-text start-pos-left start-pos-right arrow #f #f) + (add-to-range/key end-text end-pos-left end-pos-right arrow #f #f)))) + + ;; syncheck:add-tail-arrow : text number text number -> void + (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) + (let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)]) + (add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f) + (add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f))) + + ;; syncheck:add-jump-to-definition : text start end id filename -> void + (define/public (syncheck:add-jump-to-definition text start end id filename) + (add-to-range/key text start end (make-def-link id filename) #f #f)) + + ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void + (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) + (add-to-range/key text pos-left pos-right str #f #f)) + + ;; add-to-range/key : text number number any any boolean -> void + ;; adds `key' to the range `start' - `end' in the editor + ;; If use-key? is #t, it adds `to-add' with the key, and does not + ;; replace a value with that key already there. + ;; If use-key? is #f, it adds `to-add' without a key. + ;; pre: arrow-vectors is not #f + (define/private (add-to-range/key text start end to-add key use-key?) + (let ([arrow-vector (hash-ref + arrow-vectors + text + (λ () + (let ([new-vec + (make-vector + (add1 (send text last-position)) + null)]) + (hash-set! + arrow-vectors + text + new-vec) + new-vec)))]) + (let loop ([p start]) + (when (and (<= p end) + (< p (vector-length arrow-vector))) + ;; the last test in the above and is because some syntax objects + ;; appear to be from the original source, but can have bogus information. + + (let ([r (vector-ref arrow-vector p)]) + (cond + [use-key? + (unless (ormap (λ (x) + (and (pair? x) + (car x) + (eq? (car x) key))) + r) + (vector-set! arrow-vector p (cons (cons key to-add) r)))] + [else + (vector-set! arrow-vector p (cons to-add r))])) + (loop (add1 p)))))) + + (inherit get-top-level-window) + + (define/augment (on-change) + (inner (void) on-change) + (when arrow-vectors + (flush-arrow-coordinates-cache) + (let ([any-tacked? #f]) + (when tacked-hash-table + (let/ec k + (hash-for-each + tacked-hash-table + (λ (key val) + (set! any-tacked? #t) + (k (void)))))) + (when any-tacked? + (invalidate-bitmap-cache))))) + + ;; flush-arrow-coordinates-cache : -> void + ;; pre-condition: arrow-vector is not #f. + (define/private (flush-arrow-coordinates-cache) + (hash-for-each + arrow-vectors + (λ (text arrow-vector) + (let loop ([n (vector-length arrow-vector)]) + (unless (zero? n) + (let ([eles (vector-ref arrow-vector (- n 1))]) + (for-each (λ (ele) + (cond + [(arrow? ele) + (set-arrow-start-x! ele #f) + (set-arrow-start-y! ele #f) + (set-arrow-end-x! ele #f) + (set-arrow-end-y! ele #f)])) + eles)) + (loop (- n 1))))))) + + (define/override (on-paint before dc left top right bottom dx dy draw-caret) + (when (and arrow-vectors (not before)) + (let ([draw-arrow2 + (λ (arrow) + (unless (arrow-start-x arrow) + (update-arrow-poss arrow)) + (let ([start-x (arrow-start-x arrow)] + [start-y (arrow-start-y arrow)] + [end-x (arrow-end-x arrow)] + [end-y (arrow-end-y arrow)]) + (unless (and (= start-x end-x) + (= start-y end-y)) + (drscheme:arrow:draw-arrow dc start-x start-y end-x end-y dx dy) + (when (and (var-arrow? arrow) (not (var-arrow-actual? arrow))) + (let-values ([(fw fh _d _v) (send dc get-text-extent "x")]) + (send dc draw-text "?" + (+ end-x dx fw) + (+ end-y dy (- fh))))))))] + [old-brush (send dc get-brush)] + [old-pen (send dc get-pen)] + [old-font (send dc get-font)] + [old-text-foreground (send dc get-text-foreground)] + [old-text-mode (send dc get-text-mode)]) + (send dc set-font + (send the-font-list find-or-create-font + (send old-font get-point-size) + 'default + 'normal + 'bold)) + (send dc set-text-foreground templ-color) + (hash-for-each tacked-hash-table + (λ (arrow v) + (when v + (cond + [(var-arrow? arrow) + (if (var-arrow-actual? arrow) + (begin (send dc set-pen var-pen) + (send dc set-brush tacked-var-brush)) + (begin (send dc set-pen templ-pen) + (send dc set-brush tacked-templ-brush)))] + [(tail-arrow? arrow) + (send dc set-pen tail-pen) + (send dc set-brush tacked-tail-brush)]) + (draw-arrow2 arrow)))) + (when (and cursor-location + cursor-text) + (let* ([arrow-vector (hash-ref arrow-vectors cursor-text (λ () #f))]) + (when arrow-vector + (let ([eles (vector-ref arrow-vector cursor-location)]) + (for-each (λ (ele) + (cond + [(var-arrow? ele) + (if (var-arrow-actual? ele) + (begin (send dc set-pen var-pen) + (send dc set-brush untacked-brush)) + (begin (send dc set-pen templ-pen) + (send dc set-brush untacked-brush))) + (draw-arrow2 ele)] + [(tail-arrow? ele) + (send dc set-pen tail-pen) + (send dc set-brush untacked-brush) + (for-each-tail-arrows draw-arrow2 ele)])) + eles))))) + (send dc set-brush old-brush) + (send dc set-pen old-pen) + (send dc set-font old-font) + (send dc set-text-foreground old-text-foreground) + (send dc set-text-mode old-text-mode))) + + ;; do the drawing before calling super so that the arrows don't + ;; cross the "#lang ..." line, if it is present. + (super on-paint before dc left top right bottom dx dy draw-caret)) + + ;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void + (define/private (for-each-tail-arrows f tail-arrow) + ;; call-f-ht ensures that `f' is only called once per arrow + (define call-f-ht (make-hasheq)) + + (define (for-each-tail-arrows/to/from tail-arrow-pos tail-arrow-text + tail-arrow-other-pos tail-arrow-other-text) + + ;; traversal-ht ensures that we don't loop in the arrow traversal. + (let ([traversal-ht (make-hasheq)]) + (let loop ([tail-arrow tail-arrow]) + (unless (hash-ref traversal-ht tail-arrow (λ () #f)) + (hash-set! traversal-ht tail-arrow #t) + (unless (hash-ref call-f-ht tail-arrow (λ () #f)) + (hash-set! call-f-ht tail-arrow #t) + (f tail-arrow)) + (let* ([next-pos (tail-arrow-pos tail-arrow)] + [next-text (tail-arrow-text tail-arrow)] + [arrow-vector (hash-ref arrow-vectors next-text (λ () #f))]) + (when arrow-vector + (let ([eles (vector-ref arrow-vector next-pos)]) + (for-each (λ (ele) + (cond + [(tail-arrow? ele) + (let ([other-pos (tail-arrow-other-pos ele)] + [other-text (tail-arrow-other-text ele)]) + (when (and (= other-pos next-pos) + (eq? other-text next-text)) + (loop ele)))])) + eles)))))))) + + (for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text + tail-arrow-from-pos tail-arrow-from-text) + (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text + tail-arrow-to-pos tail-arrow-to-text)) + + (define/override (on-event event) + (if arrow-vectors + (cond + [(send event leaving?) + (update-docs-background #f) + (when (and cursor-location cursor-text) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #f))) + (invalidate-bitmap-cache)) + (super on-event event)] + [(or (send event moving?) + (send event entering?)) + (let-values ([(pos text) (get-pos/text event)]) + (cond + [(and pos (is-a? text text%)) + (unless (and (equal? pos cursor-location) + (eq? cursor-text text)) + (set! cursor-location pos) + (set! cursor-text text) + + (let* ([arrow-vector (hash-ref arrow-vectors cursor-text (λ () #f))] + [eles (and arrow-vector (vector-ref arrow-vector cursor-location))]) + + (unless (equal? cursor-eles eles) + (set! cursor-eles eles) + (update-docs-background eles) + (when eles + (update-status-line eles) + (for-each (λ (ele) + (cond + [(arrow? ele) + (update-arrow-poss ele)])) + eles) + (invalidate-bitmap-cache)))))] + [else + (update-docs-background #f) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #f))) + (when (or cursor-location cursor-text) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (invalidate-bitmap-cache))])) + (super on-event event)] + [(send event button-down? 'right) + (let-values ([(pos text) (get-pos/text event)]) + (if (and pos (is-a? text text%)) + (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (vector-ref arrow-vector pos)] + [start-selection (send text get-start-position)] + [end-selection (send text get-end-position)]) + (cond + [(and (null? vec-ents) (= start-selection end-selection)) + (super on-event event)] + [else + (let* ([menu (make-object popup-menu% #f)] + [arrows (filter arrow? vec-ents)] + [def-links (filter def-link? vec-ents)] + [var-arrows (filter var-arrow? arrows)] + [add-menus (map cdr (filter pair? vec-ents))]) + (unless (null? arrows) + (make-object menu-item% + (string-constant cs-tack/untack-arrow) + menu + (λ (item evt) (tack/untack-callback arrows)))) + (unless (null? def-links) + (let ([def-link (car def-links)]) + (make-object menu-item% + jump-to-definition + menu + (λ (item evt) + (jump-to-definition-callback def-link))))) + (unless (null? var-arrows) + (make-object menu-item% + jump-to-next-bound-occurrence + menu + (λ (item evt) (jump-to-next-callback pos text arrows))) + (make-object menu-item% + jump-to-binding + menu + (λ (item evt) (jump-to-binding-callback arrows)))) + (unless (= start-selection end-selection) + (let ([arrows-menu + (make-object menu% + "Arrows crossing selection" + menu)] + [callback + (lambda (accept) + (tack-crossing-arrows-callback + arrow-vector + start-selection + end-selection + text + accept))]) + (make-object menu-item% + "Tack arrows" + arrows-menu + (lambda (item evt) + (callback + '(lexical top-level imported)))) + (make-object menu-item% + "Tack non-import arrows" + arrows-menu + (lambda (item evt) + (callback + '(lexical top-level)))) + (make-object menu-item% + "Untack arrows" + arrows-menu + (lambda (item evt) + (untack-crossing-arrows + arrow-vector + start-selection + end-selection))))) + (for-each (λ (f) (f menu)) add-menus) + (send (get-canvas) popup-menu menu + (+ 1 (inexact->exact (floor (send event get-x)))) + (+ 1 (inexact->exact (floor (send event get-y))))))])))) + (super on-event event)))] + [else (super on-event event)]) + (super on-event event))) + + (define/private (update-status-line eles) + (let ([has-txt? #f]) + (for-each (λ (ele) + (cond + [(string? ele) + (set! has-txt? #t) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line + 'drscheme:check-syntax:mouse-over + ele)))])) + eles) + (unless has-txt? + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #f)))))) + + (define current-colored-region #f) + ;; update-docs-background : (or/c false/c (listof any)) -> void + (define/private (update-docs-background eles) + (let ([new-region (and eles (ormap (λ (x) (and (colored-region? x) x)) eles))]) + (unless (eq? current-colored-region new-region) + (when current-colored-region + (send (colored-region-text current-colored-region) unhighlight-range + (colored-region-start current-colored-region) + (colored-region-fin current-colored-region) + (send the-color-database find-color (colored-region-color current-colored-region)))) + (when new-region + (send (colored-region-text new-region) highlight-range + (colored-region-start new-region) + (colored-region-fin new-region) + (send the-color-database find-color (colored-region-color new-region)))) + (set! current-colored-region new-region)))) + + ;; tack/untack-callback : (listof arrow) -> void + ;; callback for the tack/untack menu item + (define/private (tack/untack-callback arrows) + (let ([arrow-tacked? + (λ (arrow) + (hash-ref + tacked-hash-table + arrow + (λ () #f)))] + [untack-arrows? #f]) + (for-each + (λ (arrow) + (cond + [(var-arrow? arrow) + (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))] + [(tail-arrow? arrow) + (for-each-tail-arrows + (λ (arrow) (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))) + arrow)])) + arrows) + (for-each + (λ (arrow) + (cond + [(var-arrow? arrow) + (hash-set! tacked-hash-table arrow (not untack-arrows?))] + [(tail-arrow? arrow) + (for-each-tail-arrows + (λ (arrow) + (hash-set! tacked-hash-table arrow (not untack-arrows?))) + arrow)])) + arrows)) + (invalidate-bitmap-cache)) + + (define/private (tack-crossing-arrows-callback arrow-vector start end text kinds) + (define (xor a b) + (or (and a (not b)) (and (not a) b))) + (define (within t p) + (and (eq? t text) + (<= start p end))) + (for ([position (in-range start end)]) + (define things (vector-ref arrow-vector position)) + (for ([va things] #:when (var-arrow? va)) + (define va-start (var-arrow-start-pos-left va)) + (define va-start-text (var-arrow-start-text va)) + (define va-end (var-arrow-end-pos-left va)) + (define va-end-text (var-arrow-end-text va)) + (when (xor (within va-start-text va-start) + (within va-end-text va-end)) + (when (memq (var-arrow-level va) kinds) + (hash-set! tacked-hash-table va #t))))) + (invalidate-bitmap-cache)) + + (define/private (untack-crossing-arrows arrow-vector start end) + (for ([position (in-range start end)]) + (for ([va (vector-ref arrow-vector position)] #:when (var-arrow? va)) + (hash-set! tacked-hash-table va #f)))) + + ;; syncheck:jump-to-binding-occurrence : text -> void + ;; jumps to the next occurrence, based on the insertion point + (define/public (syncheck:jump-to-next-bound-occurrence text) + (jump-to-binding/bound-helper + text + (λ (pos text vec-ents) + (jump-to-next-callback pos text vec-ents)))) + + ;; syncheck:jump-to-binding-occurrence : text -> void + (define/public (syncheck:jump-to-binding-occurrence text) + (jump-to-binding/bound-helper + text + (λ (pos text vec-ents) + (jump-to-binding-callback vec-ents)))) + + (define/private (jump-to-binding/bound-helper text do-jump) + (let ([pos (send text get-start-position)]) + (when arrow-vectors + (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (filter var-arrow? (vector-ref arrow-vector pos))]) + (unless (null? vec-ents) + (do-jump pos text vec-ents)))))))) + + ;; jump-to-next-callback : (listof arrow) -> void + ;; callback for the jump popup menu item + (define/private (jump-to-next-callback pos txt input-arrows) + (unless (null? input-arrows) + (let* ([arrow-key (car input-arrows)] + [orig-arrows (hash-ref bindings-table + (list (var-arrow-start-text arrow-key) + (var-arrow-start-pos-left arrow-key) + (var-arrow-start-pos-right arrow-key)) + (λ () '()))]) + (cond + [(null? orig-arrows) (void)] + [(null? (cdr orig-arrows)) (jump-to (car orig-arrows))] + [else + (let loop ([arrows orig-arrows]) + (cond + [(null? arrows) (jump-to (car orig-arrows))] + [else (let ([arrow (car arrows)]) + (cond + [(and (object=? txt (list-ref arrow 0)) + (<= (list-ref arrow 1) pos (list-ref arrow 2))) + (jump-to (if (null? (cdr arrows)) + (car orig-arrows) + (cadr arrows)))] + [else (loop (cdr arrows))]))]))])))) + + ;; jump-to : (list text number number) -> void + (define/private (jump-to to-arrow) + (let ([end-text (list-ref to-arrow 0)] + [end-pos-left (list-ref to-arrow 1)] + [end-pos-right (list-ref to-arrow 2)]) + (send end-text set-position end-pos-left end-pos-right) + (send end-text set-caret-owner #f 'global))) + + ;; jump-to-binding-callback : (listof arrow) -> void + ;; callback for the jump popup menu item + (define/private (jump-to-binding-callback arrows) + (unless (null? arrows) + (let* ([arrow (car arrows)] + [start-text (var-arrow-start-text arrow)] + [start-pos-left (var-arrow-start-pos-left arrow)] + [start-pos-right (var-arrow-start-pos-right arrow)]) + (send start-text set-position start-pos-left start-pos-right) + (send start-text set-caret-owner #f 'global)))) + + ;; syncheck:jump-to-definition : text -> void + (define/public (syncheck:jump-to-definition text) + (let ([pos (send text get-start-position)]) + (when arrow-vectors + (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (filter def-link? (vector-ref arrow-vector pos))]) + (unless (null? vec-ents) + (jump-to-definition-callback (car vec-ents))))))))) + + (define/private (jump-to-definition-callback def-link) + (let* ([filename (def-link-filename def-link)] + [id-from-def (def-link-id def-link)] + [frame (fw:handler:edit-file filename)]) + (when (is-a? frame syncheck-frame<%>) + (send frame syncheck:button-callback id-from-def)))) + + (define/augment (after-set-next-settings settings) + (let ([frame (get-top-level-window)]) + (when frame + (send frame update-button-visibility/settings settings))) + (inner (void) after-set-next-settings settings)) + + (super-new))))) + + (define syncheck-bitmap (make-object bitmap% (build-path (collection-path "icons") "syncheck.png") 'png/mask)) + + (define syncheck-frame<%> + (interface () + syncheck:button-callback + syncheck:error-report-visible?)) + + (define tab-mixin + + (mixin (drscheme:unit:tab<%>) () + (inherit is-current-tab? get-defs get-frame) + + (define report-error-text (new (fw:text:ports-mixin fw:scheme:text%))) + (define error-report-visible? #f) + (send report-error-text auto-wrap #t) + (send report-error-text set-autowrap-bitmap #f) + (send report-error-text lock #t) + + (define/public (get-error-report-text) report-error-text) + (define/public (get-error-report-visible?) error-report-visible?) + (define/public (turn-on-error-report) (set! error-report-visible? #t)) + (define/public (turn-off-error-report) (set! error-report-visible? #f)) + (define/augment (clear-annotations) + (inner (void) clear-annotations) + (syncheck:clear-error-message) + (syncheck:clear-highlighting)) + + (define/public (syncheck:clear-error-message) + (set! error-report-visible? #f) + (send report-error-text clear-output-ports) + (send report-error-text lock #f) + (send report-error-text delete/io 0 (send report-error-text last-position)) + (send report-error-text lock #t) + (when (is-current-tab?) + (send (get-frame) hide-error-report))) + + (define cleanup-texts '()) + (define/public (syncheck:clear-highlighting) + (let* ([definitions (get-defs)] + [locked? (send definitions is-locked?)]) + (send definitions begin-edit-sequence #f) + (send definitions lock #f) + (send definitions syncheck:clear-arrows) + (for-each (λ (text) + (send text thaw-colorer)) + cleanup-texts) + (set! cleanup-texts '()) + (send definitions lock locked?) + (send definitions end-edit-sequence))) + + (define/augment (can-close?) + (and (send report-error-text can-close?) + (inner #t can-close?))) + + (define/augment (on-close) + (send report-error-text on-close) + (send (get-defs) syncheck:clear-arrows) + (inner (void) on-close)) + + ;; syncheck:add-to-cleanup-texts : (is-a?/c text%) -> void + (define/public (syncheck:add-to-cleanup-texts txt) + (unless (memq txt cleanup-texts) + (send txt freeze-colorer) + (set! cleanup-texts (cons txt cleanup-texts)))) + + (super-new))) + + (define unit-frame-mixin + (mixin (drscheme:unit:frame<%>) (syncheck-frame<%>) + + (inherit get-button-panel + get-definitions-canvas + get-definitions-text + get-interactions-text + get-current-tab) + + (define/augment (on-tab-change old-tab new-tab) + (inner (void) on-tab-change old-tab new-tab) + (if (send new-tab get-error-report-visible?) + (show-error-report) + (hide-error-report)) + (send report-error-canvas set-editor (send new-tab get-error-report-text)) + (update-button-visibility/tab new-tab)) + + (define/private (update-button-visibility/tab tab) + (update-button-visibility/settings (send (send tab get-defs) get-next-settings))) + (define/public (update-button-visibility/settings settings) + (let* ([lang (drscheme:language-configuration:language-settings-language settings)] + [visible? (send lang capability-value 'drscheme:check-syntax-button)]) + (send check-syntax-button-parent-panel change-children + (λ (l) + (if visible? + (list check-syntax-button) + '()))))) + + (define/augment (enable-evaluation) + (send check-syntax-button enable #t) + (inner (void) enable-evaluation)) + + (define/augment (disable-evaluation) + (send check-syntax-button enable #f) + (inner (void) disable-evaluation)) + + (define report-error-parent-panel 'uninitialized-report-error-parent-panel) + (define report-error-panel 'uninitialized-report-error-panel) + (define report-error-canvas 'uninitialized-report-error-editor-canvas) + (define/override (get-definitions/interactions-panel-parent) + (set! report-error-parent-panel + (make-object vertical-panel% + (super get-definitions/interactions-panel-parent))) + (set! report-error-panel (instantiate horizontal-panel% () + (parent report-error-parent-panel) + (stretchable-height #f) + (alignment '(center center)) + (style '(border)))) + (send report-error-parent-panel change-children (λ (l) null)) + (let ([message-panel (instantiate vertical-panel% () + (parent report-error-panel) + (stretchable-width #f) + (stretchable-height #f) + (alignment '(left center)))]) + (make-object message% (string-constant check-syntax) message-panel) + (make-object message% (string-constant cs-error-message) message-panel)) + (set! report-error-canvas (new editor-canvas% + (parent report-error-panel) + (editor (send (get-current-tab) get-error-report-text)) + (line-count 3) + (style '(no-hscroll)))) + (instantiate button% () + (label (string-constant hide)) + (parent report-error-panel) + (callback (λ (x y) (hide-error-report))) + (stretchable-height #t)) + (make-object vertical-panel% report-error-parent-panel)) + + (define/public-final (syncheck:error-report-visible?) + (and (is-a? report-error-parent-panel area-container<%>) + (member report-error-panel (send report-error-parent-panel get-children)))) + + (define/public (hide-error-report) + (when (syncheck:error-report-visible?) + (send (get-current-tab) turn-off-error-report) + (send report-error-parent-panel change-children + (λ (l) (remq report-error-panel l))))) + + (define/private (show-error-report) + (unless (syncheck:error-report-visible?) + (send report-error-parent-panel change-children + (λ (l) (cons report-error-panel l))))) + + (define rest-panel 'uninitialized-root) + (define super-root 'uninitialized-super-root) + (define/override (make-root-area-container % parent) + (let* ([s-root (super make-root-area-container + vertical-panel% + parent)] + [r-root (make-object % s-root)]) + (set! super-root s-root) + (set! rest-panel r-root) + r-root)) + + (inherit open-status-line close-status-line update-status-line ensure-rep-hidden) + ;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void) + ;; this is the only function that has any code running on the user's thread + (define/public syncheck:button-callback + (case-lambda + [() (syncheck:button-callback #f)] + [(jump-to-id) + (when (send check-syntax-button is-enabled?) + (open-status-line 'drscheme:check-syntax) + (update-status-line 'drscheme:check-syntax status-init) + (ensure-rep-hidden) + (let-values ([(expanded-expression expansion-completed) (make-traversal)]) + (let* ([definitions-text (get-definitions-text)] + [interactions-text (get-interactions-text)] + [drs-eventspace (current-eventspace)] + [the-tab (get-current-tab)]) + (let-values ([(old-break-thread old-custodian) (send the-tab get-breakables)]) + (let* ([user-namespace #f] + [user-directory #f] + [user-custodian #f] + [normal-termination? #f] + + [show-error-report/tab + (λ () ; =drs= + (send the-tab turn-on-error-report) + (send (send the-tab get-error-report-text) scroll-to-position 0) + (when (eq? (get-current-tab) the-tab) + (show-error-report)))] + [cleanup + (λ () ; =drs= + (send the-tab set-breakables old-break-thread old-custodian) + (send the-tab enable-evaluation) + (send definitions-text end-edit-sequence) + (close-status-line 'drscheme:check-syntax) + + ;; do this with some lag ... not great, but should be okay. + (thread + (λ () + (flush-output (send (send the-tab get-error-report-text) get-err-port)) + (queue-callback + (λ () + (unless (= 0 (send (send the-tab get-error-report-text) last-position)) + (show-error-report/tab)))))))] + [kill-termination + (λ () + (unless normal-termination? + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (send the-tab syncheck:clear-highlighting) + (cleanup) + (custodian-shutdown-all user-custodian))))))] + [error-display-semaphore (make-semaphore 0)] + [uncaught-exception-raised + (λ () ;; =user= + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ;; =drs= + (yield error-display-semaphore) ;; let error display go first + (send the-tab syncheck:clear-highlighting) + (cleanup) + (custodian-shutdown-all user-custodian)))))] + [error-port (send (send the-tab get-error-report-text) get-err-port)] + [init-proc + (λ () ; =user= + (send the-tab set-breakables (current-thread) (current-custodian)) + (set-directory definitions-text) + (current-error-port error-port) + (error-display-handler + (λ (msg exn) ;; =user= + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ;; =drs= + + ;; a call like this one also happens in + ;; drscheme:debug:error-display-handler/stacktrace + ;; but that call won't happen here, because + ;; the rep is not in the current-rep parameter + (send interactions-text highlight-errors/exn exn) + + (show-error-report/tab)))) + + (drscheme:debug:error-display-handler/stacktrace + msg + exn + '()) + + (semaphore-post error-display-semaphore))) + + (error-print-source-location #f) ; need to build code to render error first + (uncaught-exception-handler + (let ([oh (uncaught-exception-handler)]) + (λ (exn) + (uncaught-exception-raised) + (oh exn)))) + (update-status-line 'drscheme:check-syntax status-expanding-expression) + (set! user-custodian (current-custodian)) + (set! user-directory (current-directory)) ;; set by set-directory above + (set! user-namespace (current-namespace)))]) + (send the-tab disable-evaluation) ;; this locks the editor, so must be outside. + (send definitions-text begin-edit-sequence #f) + (with-lock/edit-sequence + definitions-text + (λ () + (send the-tab clear-annotations) + (send the-tab reset-offer-kill) + (send (send the-tab get-defs) syncheck:init-arrows) + + (drscheme:eval:expand-program + (drscheme:language:make-text/pos definitions-text 0 (send definitions-text last-position)) + (send definitions-text get-next-settings) + #t + init-proc + kill-termination + (λ (sexp loop) ; =user= + (cond + [(eof-object? sexp) + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ; =drs= + (with-lock/edit-sequence + definitions-text + (λ () + (parameterize ([currently-processing-definitions-text definitions-text]) + (expansion-completed user-namespace user-directory) + (send definitions-text syncheck:sort-bindings-table)))) + (cleanup) + (custodian-shutdown-all user-custodian))))] + [else + (update-status-line 'drscheme:check-syntax status-eval-compile-time) + (eval-compile-time-part-of-top-level sexp) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ; =drs= + (with-lock/edit-sequence + definitions-text + (λ () + (open-status-line 'drscheme:check-syntax) + (force-xref (λ () (update-status-line 'drscheme:check-syntax status-loading-docs-index))) + (update-status-line 'drscheme:check-syntax status-coloring-program) + (parameterize ([currently-processing-definitions-text definitions-text]) + (expanded-expression user-namespace user-directory sexp jump-to-id)) + (close-status-line 'drscheme:check-syntax)))))) + (update-status-line 'drscheme:check-syntax status-expanding-expression) + (loop)]))))))))))])) + + ;; set-directory : text -> void + ;; sets the current-directory and current-load-relative-directory + ;; based on the file saved in the definitions-text + (define/private (set-directory definitions-text) + (let* ([tmp-b (box #f)] + [fn (send definitions-text get-filename tmp-b)]) + (unless (unbox tmp-b) + (when fn + (let-values ([(base name dir?) (split-path fn)]) + (current-directory base) + (current-load-relative-directory base)))))) + + ;; with-lock/edit-sequence : text (-> void) -> void + ;; sets and restores some state of the definitions text + ;; so that edits to the definitions text work out. + (define/private (with-lock/edit-sequence definitions-text thnk) + (let* ([locked? (send definitions-text is-locked?)]) + (send definitions-text begin-edit-sequence) + (send definitions-text lock #f) + (thnk) + (send definitions-text end-edit-sequence) + (send definitions-text lock locked?))) + + (super-new) + + (define check-syntax-button-parent-panel + (new horizontal-panel% + [parent (get-button-panel)] + [stretchable-width #f] + [stretchable-height #f])) + (define check-syntax-button + (new switchable-button% + (label (string-constant check-syntax)) + (bitmap syncheck-bitmap) + (parent check-syntax-button-parent-panel) + (callback (λ (button) (syncheck:button-callback))))) + (inherit register-toolbar-button) + (register-toolbar-button check-syntax-button) + (define/public (syncheck:get-button) check-syntax-button) + (send (get-button-panel) change-children + (λ (l) + (cons check-syntax-button-parent-panel + (remove check-syntax-button-parent-panel l)))) + (update-button-visibility/tab (get-current-tab)))) + + (define report-error-style (make-object style-delta% 'change-style 'italic)) + (send report-error-style set-delta-foreground "red") + + (define (add-check-syntax-key-bindings keymap) + (send keymap add-function + "check syntax" + (λ (obj evt) + (when (is-a? obj editor<%>) + (let ([canvas (send obj get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame syncheck-frame<%>) + (send frame syncheck:button-callback)))))))) + + (let ([jump-callback + (λ (send-msg) + (λ (obj evt) + (when (is-a? obj text%) + (let ([canvas (send obj get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame syncheck-frame<%>) + (let ([defs (send frame get-definitions-text)]) + (when (is-a? defs syncheck-text<%>) + (send-msg defs obj))))))))))]) + (send keymap add-function + "jump to binding occurrence" + (jump-callback (λ (defs obj) (send defs syncheck:jump-to-binding-occurrence obj)))) + (send keymap add-function + "jump to next bound occurrence" + (jump-callback (λ (defs obj) (send defs syncheck:jump-to-next-bound-occurrence obj)))) + (send keymap add-function + "jump to definition (in other file)" + (jump-callback (λ (defs obj) (send defs syncheck:jump-to-definition obj))))) + + (send keymap map-function "f6" "check syntax") + (send keymap map-function "c:c;c:c" "check syntax") + (send keymap map-function "c:x;b" "jump to binding occurrence") + (send keymap map-function "c:x;n" "jump to next bound occurrence") + (send keymap map-function "c:x;d" "jump to definition (in other file)")) + + (define lexically-bound-variable-style-pref 'drscheme:check-syntax:lexically-bound) + (define imported-variable-style-pref 'drscheme:check-syntax:imported) + + (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 error-style-name (fw:scheme:short-sym->style-name 'error)) + ;(define constant-style-name (fw:scheme:short-sym->style-name 'constant)) + + (define (syncheck-add-to-preferences-panel parent) + (fw:color-prefs:build-color-selection-panel parent + lexically-bound-variable-style-pref + lexically-bound-variable-style-name + (string-constant cs-lexical-variable)) + (fw:color-prefs:build-color-selection-panel parent + imported-variable-style-pref + imported-variable-style-name + (string-constant cs-imported-variable))) + + (fw: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)) + (fw: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)) + + + + + + ; + ; + ; + ; ; + ; ; + ; ; ; ; + ; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;; + ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; + ; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;; + ; ; + ; ; + ; ; + + + + ;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void) + ;; (namespace string[directory] -> void)) + ;; returns a pair of functions that close over some state that + ;; represents the top-level of a single program. The first value + ;; is called once for each top-level expression and the second + ;; value is called once, after all expansion is complete. + (define (make-traversal) + (let* ([tl-low-binders (make-id-set)] + [tl-high-binders (make-id-set)] + [tl-low-varrefs (make-id-set)] + [tl-high-varrefs (make-id-set)] + [tl-low-tops (make-id-set)] + [tl-high-tops (make-id-set)] + [tl-templrefs (make-id-set)] + [tl-requires (make-hash)] + [tl-require-for-syntaxes (make-hash)] + [tl-require-for-templates (make-hash)] + [tl-require-for-labels (make-hash)] + [expanded-expression + (λ (user-namespace user-directory sexp jump-to-id) + (parameterize ([current-load-relative-directory user-directory]) + (let ([is-module? (syntax-case sexp (module) + [(module . rest) #t] + [else #f])]) + (cond + [is-module? + (let ([low-binders (make-id-set)] + [high-binders (make-id-set)] + [varrefs (make-id-set)] + [high-varrefs (make-id-set)] + [low-tops (make-id-set)] + [high-tops (make-id-set)] + [templrefs (make-id-set)] + [requires (make-hash)] + [require-for-syntaxes (make-hash)] + [require-for-templates (make-hash)] + [require-for-labels (make-hash)]) + (annotate-basic sexp + user-namespace user-directory jump-to-id + low-binders high-binders varrefs high-varrefs low-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + (annotate-variables user-namespace + user-directory + low-binders + high-binders + varrefs + high-varrefs + low-tops + high-tops + templrefs + requires + require-for-syntaxes + require-for-templates + require-for-labels))] + [else + (annotate-basic sexp + user-namespace user-directory jump-to-id + tl-low-binders tl-high-binders + tl-low-varrefs tl-high-varrefs + tl-low-tops tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)]))))] + [expansion-completed + (λ (user-namespace user-directory) + (parameterize ([current-load-relative-directory user-directory]) + (annotate-variables user-namespace + user-directory + tl-low-binders + tl-high-binders + tl-low-varrefs + tl-high-varrefs + tl-low-tops + tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)))]) + (values expanded-expression expansion-completed))) + + + ;; type req/tag = (make-req/tag syntax sexp boolean) + (define-struct req/tag (req-stx req-sexp used?)) + + ;; annotate-basic : syntax + ;; namespace + ;; string[directory] + ;; syntax[id] + ;; id-set (six of them) + ;; hash-table[require-spec -> syntax] (three of them) + ;; -> void + (define (annotate-basic sexp + user-namespace user-directory jump-to-id + low-binders high-binders + low-varrefs high-varrefs + low-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + + (let ([tail-ht (make-hasheq)] + [maybe-jump + (λ (vars) + (when jump-to-id + (for-each (λ (id) + (let ([binding (identifier-binding id)]) + (when (pair? binding) + (let ([nominal-source-id (list-ref binding 3)]) + (when (eq? nominal-source-id jump-to-id) + (jump-to id)))))) + (syntax->list vars))))]) + + (let level-loop ([sexp sexp] + [high-level? #f]) + + (let* ([loop (λ (sexp) (level-loop sexp high-level?))] + [varrefs (if high-level? high-varrefs low-varrefs)] + [binders (if high-level? high-binders low-binders)] + [tops (if high-level? high-tops low-tops)] + [collect-general-info + (λ (stx) + (add-origins stx varrefs) + (add-disappeared-bindings stx binders varrefs) + (add-disappeared-uses stx varrefs))]) + (collect-general-info sexp) + (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! + quote quote-syntax with-continuation-mark + #%plain-app #%top #%plain-module-begin + define-values define-syntaxes define-values-for-syntax module + #%require #%provide #%expression) + (if high-level? free-transformer-identifier=? free-identifier=?) + [(#%plain-lambda args bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (add-binders (syntax args) binders) + (for-each loop (syntax->list (syntax (bodies ...)))))] + [(case-lambda [argss bodiess ...]...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each (λ (bodies/stx) (annotate-tail-position/last sexp + (syntax->list bodies/stx) + tail-ht)) + (syntax->list (syntax ((bodiess ...) ...)))) + (for-each + (λ (args bodies) + (add-binders args binders) + (for-each loop (syntax->list bodies))) + (syntax->list (syntax (argss ...))) + (syntax->list (syntax ((bodiess ...) ...)))))] + [(if test then else) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax then) tail-ht) + (annotate-tail-position sexp (syntax else) tail-ht) + (loop (syntax test)) + (loop (syntax else)) + (loop (syntax then)))] + [(begin bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ;; treat a single body expression specially, since this has + ;; different tail behavior. + [(begin0 body) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax body) tail-ht) + (loop (syntax body)))] + + [(begin0 bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + [(let-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(letrec-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(set! var e) + (begin + (annotate-raw-keyword sexp varrefs) + + ;; tops are used here because a binding free use of a set!'d variable + ;; is treated just the same as (#%top . x). + (when (syntax-original? (syntax var)) + (if (identifier-binding (syntax var)) + (add-id varrefs (syntax var)) + (add-id tops (syntax var)))) + + (loop (syntax e)))] + [(quote datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs)] + [(quote-syntax datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs) + (let loop ([stx #'datum]) + (cond [(identifier? stx) + (when (syntax-original? stx) + (add-id templrefs stx))] + [(syntax? stx) + (loop (syntax-e stx))] + [(pair? stx) + (loop (car stx)) + (loop (cdr stx))] + [(vector? stx) + (for-each loop (vector->list stx))] + [(box? stx) + (loop (unbox stx))] + [else (void)]))] + [(with-continuation-mark a b c) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax c) tail-ht) + (loop (syntax a)) + (loop (syntax b)) + (loop (syntax c)))] + [(#%plain-app pieces ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (pieces ...)))))] + [(#%top . var) + (begin + (annotate-raw-keyword sexp varrefs) + (when (syntax-original? (syntax var)) + (add-id tops (syntax var))))] + [(define-values vars b) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax vars) binders) + (maybe-jump (syntax vars)) + (loop (syntax b)))] + [(define-syntaxes names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(define-values-for-syntax names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) high-binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(module m-name lang (#%plain-module-begin bodies ...)) + (begin + (annotate-raw-keyword sexp varrefs) + ((annotate-require-open user-namespace user-directory) (syntax lang)) + + (hash-cons! requires (syntax->datum (syntax lang)) (syntax lang)) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ; top level or module top level only: + [(#%require require-specs ...) + (let ([at-phase + (lambda (stx requires) + (syntax-case stx () + [(_ require-specs ...) + (with-syntax ([((require-specs ...) ...) + (map (lambda (spec) + (syntax-case spec (just-meta) + [(just-meta m spec ...) + #'(spec ...)] + [else (list spec)])) + (syntax->list #'(require-specs ...)))]) + (let ([new-specs (map trim-require-prefix + (syntax->list (syntax (require-specs ... ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (annotate-require-open user-namespace + user-directory) + new-specs) + (for-each (add-require-spec requires) + new-specs + (syntax->list (syntax (require-specs ... ...))))))]))]) + (for-each (lambda (spec) + (let loop ([spec spec]) + (syntax-case* spec (for-syntax for-template for-label for-meta just-meta) + (lambda (a b) + (eq? (syntax-e a) (syntax-e b))) + [(just-meta phase specs ...) + (for-each loop (syntax->list #'(specs ...)))] + [(for-syntax specs ...) + (at-phase spec require-for-syntaxes)] + [(for-meta 1 specs ...) + (at-phase #'(for-syntax specs ...) require-for-syntaxes)] + [(for-template specs ...) + (at-phase spec require-for-templates)] + [(for-meta -1 specs ...) + (at-phase #'(for-template specs ...) require-for-templates)] + [(for-label specs ...) + (at-phase spec require-for-labels)] + [(for-meta #f specs ...) + (at-phase #'(for-label specs ...) require-for-labels)] + [(for-meta 0 specs ...) + (at-phase #'(for-run specs ...) requires)] + [(for-meta . _) (void)] + [else + (at-phase (list #f spec) requires)]))) + (syntax->list #'(require-specs ...))))] + + ; module top level only: + [(#%provide provide-specs ...) + (let ([provided-varss (map extract-provided-vars + (syntax->list (syntax (provide-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (λ (provided-vars) + (for-each + (λ (provided-var) + (when (syntax-original? provided-var) + (add-id varrefs provided-var))) + provided-vars)) + provided-varss))] + + [(#%expression arg) + (begin + (annotate-raw-keyword sexp varrefs) + (loop #'arg))] + [id + (identifier? (syntax id)) + (when (syntax-original? sexp) + (add-id varrefs sexp))] + [_ + (begin + #; + (printf "unknown stx: ~e datum: ~e source: ~e\n" + sexp + (and (syntax? sexp) + (syntax->datum sexp)) + (and (syntax? sexp) + (syntax-source sexp))) + (void))]))) + (add-tail-ht-links tail-ht))) + + (define (hash-cons! ht k v) + (hash-set! ht k (cons v (hash-ref ht k '())))) + + ;; add-disappeared-bindings : syntax id-set -> void + (define (add-disappeared-bindings stx binders disappaeared-uses) + (let ([prop (syntax-property stx 'disappeared-binding)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-origins prop disappaeared-uses) + (add-id binders prop)]))))) + + ;; add-disappeared-uses : syntax id-set -> void + (define (add-disappeared-uses stx id-set) + (let ([prop (syntax-property stx 'disappeared-use)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-id id-set prop)]))))) + + ;; add-require-spec : hash-table[sexp[require-spec] -o> (listof syntax)] + ;; -> sexp[require-spec] + ;; syntax + ;; -> void + (define (add-require-spec require-ht) + (λ (raw-spec syntax) + (when (syntax-original? syntax) + (let ([key (syntax->datum raw-spec)]) + (hash-set! require-ht + key + (cons syntax + (hash-ref require-ht + key + (λ () '())))))))) + + ;; annotate-variables : namespace directory string id-set[four of them] (listof syntax) (listof syntax) -> void + ;; colors in and draws arrows for variables, according to their classifications + ;; in the various id-sets + (define (annotate-variables user-namespace + user-directory + low-binders + high-binders + low-varrefs + high-varrefs + low-tops + high-tops + templrefs + requires + require-for-syntaxes + require-for-templates + require-for-labels) + + (let ([rename-ht + ;; hash-table[(list source number number) -> (listof syntax)] + (make-hash)] + [unused-requires (make-hash)] + [unused-require-for-syntaxes (make-hash)] + [unused-require-for-templates (make-hash)] + [unused-require-for-labels (make-hash)] + ;; there is no define-for-template form, thus no for-template binders + [template-binders (make-id-set)] + [label-binders (make-id-set)] + [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)]) + + (hash-for-each requires + (λ (k v) (hash-set! unused-requires k #t))) + (hash-for-each require-for-syntaxes + (λ (k v) (hash-set! unused-require-for-syntaxes k #t))) + (hash-for-each require-for-templates + (lambda (k v) (hash-set! unused-require-for-templates k #t))) + (hash-for-each require-for-labels + (lambda (k v) (hash-set! unused-require-for-labels k #t))) + + (for-each (λ (vars) + (for-each (λ (var) + (when (syntax-original? var) + (color-variable var identifier-binding) + (document-variable var identifier-binding) + (record-renamable-var rename-ht var))) + vars)) + (append (get-idss high-binders) + (get-idss low-binders))) + + (for-each (λ (vars) (for-each + (λ (var) + (color-variable var identifier-binding) + (document-variable var identifier-binding) + (connect-identifier var + rename-ht + low-binders + unused-requires + requires + identifier-binding + user-namespace + user-directory + #t)) + vars)) + (get-idss low-varrefs)) + + (for-each (λ (vars) (for-each + (λ (var) + (color-variable var identifier-transformer-binding) + (document-variable var identifier-transformer-binding) + (connect-identifier var + rename-ht + high-binders + unused-require-for-syntaxes + require-for-syntaxes + identifier-transformer-binding + user-namespace + user-directory + #t)) + vars)) + (get-idss high-varrefs)) + + (for-each (lambda (vars) (for-each + (lambda (var) + ;; no color variable + (connect-identifier var + rename-ht + low-binders + unused-requires + requires + identifier-binding + user-namespace + user-directory + #f) + (connect-identifier var + rename-ht + high-binders + unused-require-for-syntaxes + require-for-syntaxes + identifier-transformer-binding + user-namespace + user-directory + #f) + (connect-identifier var + rename-ht + template-binders ;; dummy; always empty + unused-require-for-templates + require-for-templates + identifier-template-binding + user-namespace + user-directory + #f) + (connect-identifier var + rename-ht + label-binders ;; dummy; always empty + unused-require-for-labels + require-for-labels + identifier-label-binding + user-namespace + user-directory + #f)) + vars)) + (get-idss templrefs)) + + (for-each + (λ (vars) + (for-each + (λ (var) + (color/connect-top rename-ht user-namespace user-directory low-binders var)) + vars)) + (get-idss low-tops)) + + (for-each + (λ (vars) + (for-each + (λ (var) + (color/connect-top rename-ht user-namespace user-directory high-binders var)) + vars)) + (get-idss high-tops)) + + (color-unused require-for-labels unused-require-for-labels) + (color-unused require-for-templates unused-require-for-templates) + (color-unused require-for-syntaxes unused-require-for-syntaxes) + (color-unused requires unused-requires) + (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets))))) + + ;; record-renamable-var : rename-ht syntax -> void + (define (record-renamable-var rename-ht stx) + (let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))]) + (hash-set! rename-ht + key + (cons stx (hash-ref rename-ht key '()))))) + + ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void + (define (color-unused requires unused) + (hash-for-each + unused + (λ (k v) + (for-each (λ (stx) (color stx error-style-name)) + (hash-ref requires k))))) + + ;; connect-identifier : syntax + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; (listof id-set) + ;; namespace + ;; directory + ;; boolean + ;; -> void + ;; adds arrows and rename menus for binders/bindings + (define (connect-identifier var rename-ht all-binders + unused requires get-binding user-namespace user-directory actual?) + (connect-identifier/arrow var all-binders + unused requires get-binding user-namespace user-directory actual?) + (when (and actual? (get-ids all-binders var)) + (record-renamable-var rename-ht var))) + + ;; id-level : identifier-binding-function identifier -> symbol + (define (id-level get-binding id) + (define (self-module? mpi) + (let-values ([(a b) (module-path-index-split mpi)]) + (and (not a) (not b)))) + (let ([binding (get-binding id)]) + (cond [(list? binding) + (if (self-module? (car binding)) + 'top-level + 'imported)] + [(eq? binding 'lexical) 'lexical] + [else 'top-level]))) + + ;; connect-identifier/arrow : syntax + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; boolean + ;; -> void + ;; adds the arrows that correspond to binders/bindings + (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) + (let ([binders (get-ids all-binders var)]) + (when binders + (for-each (λ (x) + (when (syntax-original? x) + (connect-syntaxes x var actual? (id-level get-binding x)))) + binders)) + + (when (and unused requires) + (let ([req-path/pr (get-module-req-path (get-binding var))]) + (when req-path/pr + (let* ([req-path (car req-path/pr)] + [id (cdr req-path/pr)] + [req-stxes (hash-ref requires req-path (λ () #f))]) + (when req-stxes + (hash-remove! unused req-path) + (for-each (λ (req-stx) + (when (id/require-match? (syntax->datum var) + id + (syntax->datum req-stx)) + (when id + (add-jump-to-definition + var + id + (get-require-filename req-path user-namespace user-directory))) + (add-mouse-over var + (fw:gui-utils:format-literal-label + (string-constant cs-mouse-over-import) + (syntax-e var) + req-path)) + (connect-syntaxes req-stx var actual? + (id-level get-binding var)))) + req-stxes)))))))) + + (define (id/require-match? var id req-stx) + (cond + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix)) + (let ([prefix (list-ref req-stx 1)]) + (equal? (format "~a~a" prefix id) + (symbol->string var)))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix-all-except)) + (let ([prefix (list-ref req-stx 1)]) + (and (not (memq id (cdddr req-stx))) + (equal? (format "~a~a" prefix id) + (symbol->string var))))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'rename)) + (eq? (list-ref req-stx 2) + var)] + [else (eq? var id)])) + + + ;; get-module-req-path : binding -> (union #f (cons require-sexp sym)) + ;; argument is the result of identifier-binding or identifier-transformer-binding + (define (get-module-req-path binding) + (and (pair? binding) + (let ([mod-path (list-ref binding 2)]) + (cond + [(module-path-index? mod-path) + (let-values ([(base offset) (module-path-index-split mod-path)]) + (cons base (list-ref binding 3)))] + [(symbol? mod-path) + (cons mod-path (list-ref binding 3))])))) + + ;; color/connect-top : namespace directory id-set syntax -> void + (define (color/connect-top rename-ht user-namespace user-directory binders var) + (let ([top-bound? + (or (get-ids binders var) + (parameterize ([current-namespace user-namespace]) + (let/ec k + (namespace-variable-value (syntax-e var) #t (λ () (k #f))) + #t)))]) + (if top-bound? + (color var lexically-bound-variable-style-name) + (color var error-style-name)) + (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t))) + + ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void + (define (color-variable var get-binding) + (let* ([b (get-binding var)] + [lexical? + (or (not b) + (eq? b 'lexical) + (and (pair? b) + (let ([path (caddr b)]) + (and (module-path-index? path) + (let-values ([(a b) (module-path-index-split path)]) + (and (not a) + (not b)))))))]) + (cond + [lexical? (color var lexically-bound-variable-style-name)] + [(pair? b) (color var imported-variable-style-name)]))) + + ;; add-var : hash-table -> syntax -> void + ;; adds the variable to the hash table. + (define (add-var ht) + (λ (var) + (let* ([key (syntax-e var)] + [prev (hash-ref ht key (λ () null))]) + (hash-set! ht key (cons var prev))))) + + ;; connect-syntaxes : syntax[original] syntax[original] boolean symbol -> void + ;; adds an arrow from `from' to `to', unless they have the same source loc. + (define (connect-syntaxes from to actual? level) + (let ([from-source (find-source-editor from)] + [to-source (find-source-editor to)] + [defs-text (get-defs-text)]) + (when (and from-source to-source defs-text) + (let ([pos-from (syntax-position from)] + [span-from (syntax-span from)] + [pos-to (syntax-position to)] + [span-to (syntax-span to)]) + (when (and pos-from span-from pos-to span-to) + (let* ([from-pos-left (- (syntax-position from) 1)] + [from-pos-right (+ from-pos-left (syntax-span from))] + [to-pos-left (- (syntax-position to) 1)] + [to-pos-right (+ to-pos-left (syntax-span to))]) + (unless (= from-pos-left to-pos-left) + (send defs-text syncheck:add-arrow + from-source from-pos-left from-pos-right + to-source to-pos-left to-pos-right + actual? level)))))))) + + ;; add-mouse-over : syntax[original] string -> void + ;; registers the range in the editor so that a mouse over + ;; this area shows up in the status line. + (define (add-mouse-over stx str) + (let* ([source (find-source-editor stx)] + [defs-text (get-defs-text)]) + (when (and defs-text + source + (syntax-position stx) + (syntax-span stx)) + (let* ([pos-left (- (syntax-position stx) 1)] + [pos-right (+ pos-left (syntax-span stx))]) + (send defs-text syncheck:add-mouse-over-status + source pos-left pos-right str))))) + + ;; add-jump-to-definition : syntax symbol path -> void + ;; registers the range in the editor so that the + ;; popup menu in this area allows the programmer to jump + ;; to the definition of the id. + (define (add-jump-to-definition stx id filename) + (let ([source (find-source-editor stx)] + [defs-text (get-defs-text)]) + (when (and source + defs-text + (syntax-position stx) + (syntax-span stx)) + (let* ([pos-left (- (syntax-position stx) 1)] + [pos-right (+ pos-left (syntax-span stx))]) + (send defs-text syncheck:add-jump-to-definition + source + pos-left + pos-right + id + filename))))) + + ;; find-syncheck-text : text% -> (union #f (is-a?/c syncheck-text<%>)) + (define (find-syncheck-text text) + (let loop ([text text]) + (cond + [(is-a? text syncheck-text<%>) text] + [else + (let ([admin (send text get-admin)]) + (and (is-a? admin editor-snip-editor-admin<%>) + (let* ([enclosing-editor-snip (send admin get-snip)] + [editor-snip-admin (send enclosing-editor-snip get-admin)] + [enclosing-editor (send editor-snip-admin get-editor)]) + (loop enclosing-editor))))]))) + + ;; annotate-tail-position/last : (listof syntax) -> void + (define (annotate-tail-position/last orig-stx stxs tail-ht) + (unless (null? stxs) + (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht))) + + ;; annotate-tail-position : syntax -> void + ;; colors the parens (if any) around the argument + ;; to indicate this is a tail call. + (define (annotate-tail-position orig-stx tail-stx tail-ht) + (hash-set! + tail-ht + orig-stx + (cons + tail-stx + (hash-ref + tail-ht + orig-stx + (λ () null))))) + + ;; annotate-require-open : namespace string -> (stx -> void) + ;; relies on current-module-name-resolver, which in turn depends on + ;; current-directory and current-namespace + (define (annotate-require-open user-namespace user-directory) + (λ (require-spec) + (when (syntax-original? require-spec) + (let ([source (find-source-editor require-spec)]) + (when (and (is-a? source text%) + (syntax-position require-spec) + (syntax-span require-spec)) + (let ([defs-text (get-defs-text)]) + (when defs-text + (let* ([start (- (syntax-position require-spec) 1)] + [end (+ start (syntax-span require-spec))] + [file (get-require-filename (syntax->datum require-spec) + user-namespace + user-directory)]) + (when file + (send defs-text syncheck:add-menu + source + start end + #f + (make-require-open-menu file))))))))))) + + ;; get-require-filename : sexp namespace string[directory] -> filename + ;; finds the filename corresponding to the require in stx + (define (get-require-filename datum user-namespace user-directory) + (let ([mp + (parameterize ([current-namespace user-namespace] + [current-directory user-directory] + [current-load-relative-directory user-directory]) + (with-handlers ([exn:fail? (λ (x) #f)]) + ((current-module-name-resolver) datum #f #f)))]) + (and (resolved-module-path? mp) + (resolved-module-path-name mp)))) + + ;; make-require-open-menu : path -> menu -> void + (define (make-require-open-menu file) + (λ (menu) + (let-values ([(base name dir?) (split-path file)]) + (instantiate menu-item% () + (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) + (parent menu) + (callback (λ (x y) (fw:handler:edit-file file)))) + (void)))) + + ;; possible-suffixes : (listof string) + ;; these are the suffixes that are checked for the reverse + ;; module-path mapping. + (define possible-suffixes '(".ss" ".scm" "")) + + ;; module-name-sym->filename : symbol -> (union #f string) + (define (module-name-sym->filename sym) + (let ([str (symbol->string sym)]) + (and ((string-length str) . > . 1) + (char=? (string-ref str 0) #\,) + (let ([fn (substring str 1 (string-length str))]) + (ormap (λ (x) + (let ([test (string->path (string-append fn x))]) + (and (file-exists? test) + test))) + possible-suffixes))))) + + ;; add-origins : sexp id-set -> void + (define (add-origins sexp id-set) + (let ([origin (syntax-property sexp 'origin)]) + (when origin + (let loop ([ct origin]) + (cond + [(pair? ct) + (loop (car ct)) + (loop (cdr ct))] + [(syntax? ct) + (when (syntax-original? ct) + (add-id id-set ct))] + [else (void)]))))) + + ;; FIXME: handle for-template and for-label + ;; extract-provided-vars : syntax -> (listof syntax[identifier]) + (define (extract-provided-vars stx) + (syntax-case* stx (rename struct all-from all-from-except all-defined-except) symbolic-compare? + [identifier + (identifier? (syntax identifier)) + (list (syntax identifier))] + + [(rename local-identifier export-identifier) + (list (syntax local-identifier))] + + ;; why do I even see this?!? + [(struct struct-identifier (field-identifier ...)) + null] + + [(all-from module-name) null] + [(all-from-except module-name identifier ...) + null] + [(all-defined-except identifier ...) + (syntax->list #'(identifier ...))] + [_ + null])) + + + ;; trim-require-prefix : syntax -> syntax + (define (trim-require-prefix require-spec) + (syntax-case* require-spec (only prefix all-except prefix-all-except rename just-meta) symbolic-compare? + [(only module-name identifer ...) + (syntax module-name)] + [(prefix identifier module-name) + (syntax module-name)] + [(all-except module-name identifer ...) + (syntax module-name)] + [(prefix-all-except module-name identifer ...) + (syntax module-name)] + [(rename module-name local-identifer exported-identifer) + (syntax module-name)] + [_ require-spec])) + + (define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y))) + + ;; add-binders : syntax id-set -> void + ;; transforms an argument list into a bunch of symbols/symbols + ;; and puts them into the id-set + ;; effect: colors the identifiers + (define (add-binders stx id-set) + (let loop ([stx stx]) + (let ([e (if (syntax? stx) (syntax-e stx) stx)]) + (cond + [(cons? e) + (let ([fst (car e)] + [rst (cdr e)]) + (if (syntax? fst) + (begin + (when (syntax-original? fst) + (add-id id-set fst)) + (loop rst)) + (loop rst)))] + [(null? e) (void)] + [else + (when (syntax-original? stx) + (add-id id-set stx))])))) + + ;; annotate-raw-keyword : syntax id-map -> void + ;; annotates keywords when they were never expanded. eg. + ;; if someone just types `(λ (x) x)' it has no 'origin + ;; field, but there still are keywords. + (define (annotate-raw-keyword stx id-map) + (let ([lst (syntax-e stx)]) + (when (pair? lst) + (let ([f-stx (car lst)]) + (when (and (syntax-original? f-stx) + (identifier? f-stx)) + (add-id id-map f-stx)))))) + + ;; color-internal-structure : syntax str -> void + (define (color-internal-structure stx style-name) + (let ([ht (make-hasheq)]) + ;; ht : stx -o> true + ;; indicates if we've seen this syntax object before + + (let loop ([stx stx] + [datum (syntax->datum stx)]) + (unless (hash-ref ht datum (λ () #f)) + (hash-set! ht datum #t) + (cond + [(pair? stx) + (loop (car stx) (car datum)) + (loop (cdr stx) (cdr datum))] + [(syntax? stx) + (when (syntax-original? stx) + (color stx style-name)) + (let ([stx-e (syntax-e stx)]) + (cond + [(cons? stx-e) + (loop (car stx-e) (car datum)) + (loop (cdr stx-e) (cdr datum))] + [(null? stx-e) + (void)] + [(vector? stx-e) + (for-each loop + (vector->list stx-e) + (vector->list datum))] + [(box? stx-e) + (loop (unbox stx-e) (unbox datum))] + [else (void)]))]))))) + + ;; jump-to : syntax -> void + (define (jump-to stx) + (let ([src (find-source-editor stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (when (and (is-a? src text%) + pos + span) + (send src set-position (- pos 1) (+ pos span -1))))) + + ;; color : syntax[original] str -> void + ;; colors the syntax with style-name's style + (define (color stx style-name) + (let ([source (find-source-editor stx)]) + (when (and (is-a? source text%) + (syntax-position stx) + (syntax-span stx)) + (let ([pos (- (syntax-position stx) 1)] + [span (syntax-span stx)]) + (color-range source pos (+ pos span) style-name))))) + + ;; color-range : text start finish style-name + ;; colors a range in the text based on `style-name' + (define (color-range source start finish style-name) + (let ([style (send (send source get-style-list) + find-named-style + style-name)]) + (add-to-cleanup-texts source) + (send source change-style style start finish #f))) + + ;; hash-table[syntax -o> (listof syntax)] -> void + (define (add-tail-ht-links tail-ht) + (begin + (collapse-tail-links tail-ht) + (hash-for-each + tail-ht + (λ (stx-from stx-tos) + (for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to)) + stx-tos))))) + + ;; hash-table[syntax -o> (listof syntax)] -> void + ;; take something like a transitive closure, except + ;; only when there are non-original links in between + + (define (collapse-tail-links tail-ht) + (let loop () + (let ([found-one? #f]) + (hash-for-each + tail-ht + (λ (stx-from stx-tos) + (for-each + (λ (stx-to) + (let ([stx-to-tos (hash-ref tail-ht stx-to '())]) + (for-each + (λ (stx-to-to) + (unless (and (add-tail-link? stx-from stx-to) + (add-tail-link? stx-to stx-to-to)) + (unless (memq stx-to-to (hash-ref tail-ht stx-from '())) + (set! found-one? #t) + (hash-cons! tail-ht stx-from stx-to-to)))) + stx-to-tos))) + stx-tos))) + + ;; this takes O(n^3) in general, so we just do + ;; one iteration. This doesn't work for case + ;; expressions but it seems to for most others. + ;; turning this on makes this function go from about + ;; 55 msec to about 2400 msec on my laptop, + ;; (a 43x slowdown) when checking the syntax of this file. + + #; + (when found-one? + (loop))))) + + ;; add-tail-ht-link : syntax syntax -> void + (define (add-tail-ht-link from-stx to-stx) + (let* ([to-src (find-source-editor to-stx)] + [from-src (find-source-editor from-stx)] + [defs-text (get-defs-text)]) + (when (and to-src from-src defs-text) + (let ([from-pos (syntax-position from-stx)] + [to-pos (syntax-position to-stx)]) + (when (and from-pos to-pos) + (send defs-text syncheck:add-tail-arrow + from-src (- from-pos 1) + to-src (- to-pos 1))))))) + + ;; add-tail-link? : syntax syntax -> boolean + (define (add-tail-link? from-stx to-stx) + (let* ([to-src (find-source-editor to-stx)] + [from-src (find-source-editor from-stx)] + [defs-text (get-defs-text)]) + (and to-src from-src defs-text + (let ([from-pos (syntax-position from-stx)] + [to-pos (syntax-position to-stx)]) + (and from-pos to-pos))))) + + ;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void + (define (add-to-cleanup-texts ed) + (let ([ed (find-outermost-editor ed)]) + (when (is-a? ed drscheme:unit:definitions-text<%>) + (let ([tab (send ed get-tab)]) + (send tab syncheck:add-to-cleanup-texts ed))))) + + (define (find-outermost-editor ed) + (let loop ([ed ed]) + (let ([admin (send ed get-admin)]) + (if (is-a? admin editor-snip-editor-admin<%>) + (let* ([enclosing-snip (send admin get-snip)] + [enclosing-snip-admin (send enclosing-snip get-admin)]) + (loop (send enclosing-snip-admin get-editor))) + ed)))) + + ;; find-source-editor : stx -> editor or false + (define (find-source-editor stx) + (let ([defs-text (get-defs-text)]) + (and defs-text + (find-source-editor/defs stx defs-text)))) + + ;; find-source-editor : stx text -> editor or false + (define (find-source-editor/defs stx defs-text) + (cond + [(not (syntax-source stx)) #f] + [(and (symbol? (syntax-source stx)) + (text:lookup-port-name (syntax-source stx))) + => values] + [else + (let txt-loop ([text defs-text]) + (cond + [(and (is-a? text fw:text:basic<%>) + (send text port-name-matches? (syntax-source stx))) + text] + [else + (let snip-loop ([snip (send text find-first-snip)]) + (cond + [(not snip) + #f] + [(and (is-a? snip editor-snip%) + (send snip get-editor)) + (or (txt-loop (send snip get-editor)) + (snip-loop (send snip next)))] + [else + (snip-loop (send snip next))]))]))])) + ;; get-defs-text : -> text or false + (define (get-defs-text) + (currently-processing-definitions-text)) + + +; +; +; ; +; ; ; +; ; ; ; +; ;; ; ;;; ;;;; ; ; ; ;; ;; ;;; ; ;; ;;;;; ;;;; ;;;;; ;;; ;;; ; ;; +; ; ;; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;;;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; +; ;; ; ;;; ;;;; ;; ; ; ; ; ;;;; ; ; ;;; ;; ; ;;; ; ;;; ; ; +; +; +; + + + ;; document-variable : stx identifier-binding -> void + (define (document-variable stx get-binding) + (when (syntax-original? stx) + (let ([defs-text (currently-processing-definitions-text)]) + (when defs-text + (let ([binding-info (get-binding stx)]) + (when (and (pair? binding-info) + (syntax-position stx) + (syntax-span stx)) + (let* ([start (- (syntax-position stx) 1)] + [fin (+ start (syntax-span stx))] + [source-editor (find-source-editor stx)] + [xref (get-xref)]) + (when (and xref source-editor) + (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)]) + (when definition-tag + (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) + (when path + (let ([index-entry (xref-tag->index-entry xref definition-tag)]) + (when index-entry + (send defs-text syncheck:add-background-color source-editor "navajowhite" start fin (syntax-e stx)) + (send defs-text syncheck:add-menu + source-editor + start + fin + (syntax-e stx) + (λ (menu) + (instantiate menu-item% () + (parent menu) + (label (fw:gui-utils:format-literal-label (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry)))) + (callback + (λ (x y) + (let* ([url (path->url path)] + [url2 (if tag + (make-url (url-scheme url) + (url-user url) + (url-host url) + (url-port url) + (url-path-absolute? url) + (url-path url) + (url-query url) + tag) + url)]) + (send-url (url->string url2)))))))))))))))))))))) + + + + ; + ; + ; + ; ; + ; ; + ; + ; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; + ; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;; + ; ; + ; ; ; + ; ;;; + + + ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void + (define (make-rename-menu stxs id-sets) + (let ([defs-text (currently-processing-definitions-text)]) + (when defs-text + (let* ([source (syntax-source (car stxs))] ;; all stxs in the list must have the same source + [source-editor (find-source-editor (car stxs))]) + (when (is-a? source-editor text%) + (let* ([start (- (syntax-position (car stxs)) 1)] + [fin (+ start (syntax-span (car stxs)))]) + (send defs-text syncheck:add-menu + source-editor + start + fin + (syntax-e (car stxs)) + (λ (menu) + (let ([name-to-offer (format "~a" (syntax->datum (car stxs)))]) + (instantiate menu-item% () + (parent menu) + (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) + (callback + (λ (x y) + (let ([frame-parent (find-menu-parent menu)]) + (rename-callback name-to-offer + defs-text + stxs + id-sets + frame-parent)))))))))))))) + + ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) + (define (find-menu-parent menu) + (let loop ([menu menu]) + (cond + [(is-a? menu menu-bar%) (send menu get-frame)] + [(is-a? menu popup-menu%) + (let ([target (send menu get-popup-target)]) + (cond + [(is-a? target editor<%>) + (let ([canvas (send target get-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [(is-a? target window<%>) + (send target get-top-level-window)] + [else #f]))] + [(is-a? menu menu-item<%>) (loop (send menu get-parent))] + [else #f]))) + + ;; rename-callback : string + ;; (and/c syncheck-text<%> definitions-text<%>) + ;; (listof syntax[original]) + ;; (listof id-set) + ;; (union #f (is-a?/c top-level-window<%>)) + ;; -> void + ;; callback for the rename popup menu item + (define (rename-callback name-to-offer defs-text stxs id-sets parent) + (let ([new-str + (fw:keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (string-constant cs-rename-id) + (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) + parent + name-to-offer)))]) + (when new-str + (let* ([new-sym (format "~s" (string->symbol new-str))] + [to-be-renamed + (remove-duplicates + (sort + (apply + append + (map (λ (id-set) + (apply + append + (map (λ (stx) (or (get-ids id-set stx) '())) stxs))) + id-sets)) + (λ (x y) + ((syntax-position x) . >= . (syntax-position y)))))] + [do-renaming? + (or (not (name-duplication? to-be-renamed id-sets new-sym)) + (equal? + (message-box/custom + (string-constant check-syntax) + (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) + new-sym) + (string-constant cs-rename-anyway) + (string-constant cancel) + #f + parent + '(stop default=2)) + 1))]) + (when do-renaming? + (unless (null? to-be-renamed) + (let ([txts (list defs-text)]) + (send defs-text begin-edit-sequence) + (for-each (λ (stx) + (let ([source-editor (find-source-editor/defs stx defs-text)]) + (when (is-a? source-editor text%) + (unless (memq source-editor txts) + (send source-editor begin-edit-sequence) + (set! txts (cons source-editor txts))) + (let* ([start (- (syntax-position stx) 1)] + [end (+ start (syntax-span stx))]) + (send source-editor delete start end #f) + (send source-editor insert new-sym start start #f))))) + to-be-renamed) + (send defs-text invalidate-bitmap-cache) + (for-each + (λ (txt) (send txt end-edit-sequence)) + txts)))))))) + + ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean + ;; returns #t if the name chosen would be the same as another name in this scope. + (define (name-duplication? to-be-renamed id-sets new-str) + (let ([new-ids (map (λ (id) (datum->syntax id (string->symbol new-str))) + to-be-renamed)]) + (ormap (λ (id-set) + (ormap (λ (new-id) (get-ids id-set new-id)) + new-ids)) + id-sets))) + + ;; remove-duplicates : (listof syntax[original]) -> (listof syntax[original]) + ;; removes duplicates, based on the source locations of the identifiers + (define (remove-duplicates ids) + (cond + [(null? ids) null] + [else (let loop ([fst (car ids)] + [rst (cdr ids)]) + (cond + [(null? rst) (list fst)] + [else (if (and (eq? (syntax-source fst) + (syntax-source (car rst))) + (= (syntax-position fst) + (syntax-position (car rst)))) + (loop fst (cdr rst)) + (cons fst (loop (car rst) (cdr rst))))]))])) + + + ; + ; + ; + ; ; ; ; ; + ; ; ; ; + ; ; ; ; ; + ; ; ; ; ; ; ; ; ;;; ; ; ; ;; + ; ; ; ; ; ; ;; ; ; ; ; ;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;;;;;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ;; ; + ; ; ; ; ; ;;;; ;; ; ; ;; + ; ; + ; ; + ; ; + + + (add-check-syntax-key-bindings (drscheme:rep:get-drs-bindings-keymap)) + (fw:color-prefs:add-to-preferences-panel (string-constant check-syntax) + syncheck-add-to-preferences-panel) + (drscheme:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t) + (drscheme:get/extend:extend-definitions-text make-syncheck-text%) + (drscheme:get/extend:extend-unit-frame unit-frame-mixin #f) + (drscheme:get/extend:extend-tab tab-mixin))) diff --git a/collects/drscheme/syncheck/utils.ss b/collects/drscheme/syncheck/utils.ss new file mode 100644 index 0000000000..04f956ec59 --- /dev/null +++ b/collects/drscheme/syncheck/utils.ss @@ -0,0 +1,8 @@ +#lang scheme/base + +(provide (all-defined-out)) + +;; use this to communicate the frame being +;; syntax checked w/out having to add new +;; parameters to all of the functions +(define currently-processing-drscheme-frame (make-parameter #f)) \ No newline at end of file From e198478055f13631ec9ab6154edcf71c6c3f7ef3 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 14 Feb 2009 20:27:37 +0000 Subject: [PATCH 03/13] type keys now work, mostly svn: r13580 --- collects/typed-scheme/env/init-envs.ss | 4 +- collects/typed-scheme/private/subtype.ss | 264 +++++++++--------- .../private/type-effect-printer.ss | 2 +- collects/typed-scheme/private/type-utils.ss | 2 +- collects/typed-scheme/private/union.ss | 2 +- collects/typed-scheme/rep/rep-utils.ss | 54 ++-- collects/typed-scheme/rep/type-rep.ss | 67 +++-- collects/typed-scheme/utils/utils.ss | 15 +- 8 files changed, 226 insertions(+), 184 deletions(-) diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/env/init-envs.ss index e087666bfa..0b64510527 100644 --- a/collects/typed-scheme/env/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -32,9 +32,9 @@ [(Mu-name: n b) `(make-Mu ,(sub n) ,(sub b))] [(Poly-names: ns b) `(make-Poly (list ,@(map sub ns)) ,(sub b))] [(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))] - [(? Type? (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq vals))) + [(? Type? (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq vals))) `(,(gen-constructor tag) ,@(map sub vals))] - [(? Effect? (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq vals))) + [(? Effect? (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq vals))) `(,(gen-constructor tag) ,@(map sub vals))] [_ (basic v)])) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 4832711c8e..513c453533 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (except-in (rep type-rep effect-rep) sub-eff) +(require (except-in (rep type-rep effect-rep rep-utils) sub-eff) (utils tc-utils) "type-utils.ss" "type-comparison.ss" @@ -156,139 +156,139 @@ (define (subtype* A s t) (parameterize ([match-equality-test type-equal?] [current-seen A]) - (if (seen? s t) - A - (let* ([A0 (remember s t A)]) - (parameterize ([current-seen A0]) - #;(match t - [(Name: n) (when (eq? 'heap (syntax-e n)) - (trace subtype*))] - [_ #f]) + (let ([ks (Type-key s)] [kt (Type-key t)]) + (cond + [(or (seen? s t) (type-equal? s t)) A] + [(and (symbol? ks) (symbol? kt) (not (eq? ks kt))) (fail! s t)] + [(and (symbol? ks) (pair? kt) (not (memq ks kt))) (fail! s t)] + [(and (pair? ks) (pair? kt) + (for/and ([i (in-list ks)]) (not (memq i kt)))) + (fail! s t)] + [else + (let* ([A0 (remember s t A)]) + (parameterize ([current-seen A0]) (match (list s t) - ;; subtyping is reflexive - [(list t t) A0] - ;; univ is top - [(list _ (Univ:)) A0] - ;; error is top and bot - [(list _ (Error:)) A0] - [(list (Error:) _) A0] - ;; (Un) is bot - [(list _ (Union: (list))) (fail! s t)] - [(list (Union: (list)) _) A0] - ;; value types - [(list (Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))] - ;; integers are numbers too - [(list (Base: 'Integer _) (Base: 'Number _)) A0] - ;; values are subtypes of their "type" - [(list (Value: (? integer? n)) (Base: 'Integer _)) A0] - [(list (Value: (? number? n)) (Base: 'Number _)) A0] - [(list (Value: (? boolean? n)) (Base: 'Boolean _)) A0] - [(list (Value: (? symbol? n)) (Base: 'Symbol _)) A0] - [(list (Value: (? string? n)) (Base: 'String _)) A0] - ;; tvars are equal if they are the same variable - [(list (F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))] - ;; case-lambda - [(list (Function: arr1) (Function: arr2)) - (when (null? arr1) (fail! s t)) - (let loop-arities ([A* A0] - [arr2 arr2]) - (cond - [(null? arr2) A*] - [(supertype-of-one/arr A* (car arr2) arr1) => (lambda (A) (loop-arities A (cdr arr2)))] - [else (fail! s t)]))] - ;; recur structurally on pairs - [(list (Pair: a d) (Pair: a* d*)) - (let ([A1 (subtype* A0 a a*)]) - (and A1 (subtype* A1 d d*)))] - ;; quantification over two types preserves subtyping - [(list (Poly: ns b1) (Poly: ms b2)) - (=> unmatch) - (unless (= (length ns) (length ms)) - (unmatch)) - ;(printf "Poly: ~n~a ~n~a~n" b1 (subst-all (map list ms (map make-F ns)) b2)) - (subtype* A0 b1 (subst-all (map list ms (map make-F ns)) b2))] - ;; use unification to see if we can use the polytype here - [(list (Poly: vs b) s) - (=> unmatch) - (if (unify vs (list b) (list s)) A0 (unmatch))] - [(list s (Poly: vs b)) - (=> unmatch) - (if (null? (fv b)) (subtype* A0 s b) (unmatch))] - ;; names are compared for equality: - [(list (Name: n) (Name: n*)) - (=> unmatch) - (if (free-identifier=? n n*) - A0 - (unmatch))] - ;; just unfold the recursive types - [(list _ (? Mu?)) (subtype* A0 s (unfold t))] - [(list (? Mu?) _) (subtype* A0 (unfold s) t)] - ;; for unions, we check the cross-product - [(list (Union: es) t) (and (andmap (lambda (elem) (subtype* A0 elem t)) es) A0)] - [(list s (Union: es)) (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0)] - ;; subtyping on immutable structs is covariant - [(list (Struct: nm _ flds #f _ _ _) (Struct: nm _ flds* #f _ _ _)) - (subtypes* A0 flds flds*)] - [(list (Struct: nm _ flds proc _ _ _) (Struct: nm _ flds* proc* _ _ _)) - (subtypes* A0 (cons proc flds) (cons proc* flds*))] - ;; subtyping on structs follows the declared hierarchy - [(list (Struct: nm (? Type? parent) flds proc _ _ _) other) - ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other) - (subtype* A0 parent other)] - ;; applications and names are structs too - [(list (App: (Name: n) args stx) other) - (let ([t (lookup-type-name n)]) - (unless (Type? t) - (fail! s t)) - #;(printf "subtype: app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other - (instantiate-poly t args)) - (unless (Poly? t) - (tc-error/stx stx "cannot apply non-polymorphic type ~a" t)) - (match t [(Poly-unsafe: n _) - (unless (= n (length args)) - (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a" - n (length args)))]) - (let ([v (subtype* A0 (instantiate-poly t args) other)]) - #;(printf "val: ~a~n" v) - v))] - [(list other (App: (Name: n) args stx)) - (let ([t (lookup-type-name n)]) - (unless (Type? t) - (fail! s t)) - #;(printf "subtype: 2 app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other - (instantiate-poly t args)) - (unless (Poly? t) - (tc-error/stx stx "cannot apply non-polymorphic type ~a" t)) - (match t [(Poly-unsafe: n _) - (unless (= n (length args)) - (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a" - n (length args)))]) - ;(printf "about to call subtype with: ~a ~a ~n" other (instantiate-poly t args)) - (let ([v (subtype* A0 other (instantiate-poly t args))]) - #;(printf "2 val: ~a~n" v) - v))] - [(list (Name: n) other) - (let ([t (lookup-type-name n)]) - ;(printf "subtype: name: ~a ~a ~a~n" (syntax-e n) t other) - (if (Type? t) - (subtype* A0 t other) - (fail! s t)))] - ;; Promises are covariant - [(list (Struct: 'Promise _ (list t) _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _)) (subtype* A0 t t*)] - ;; subtyping on values is pointwise - [(list (Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] - ;; single values shouldn't actually happen, but they're just like the type - [(list t (Values: (list t*))) (int-err "BUG - singleton values type~a" (make-Values (list t*)))] - [(list (Values: (list t)) t*) (int-err "BUG - singleton values type~a" (make-Values (list t)))] - ;; subtyping on other stuff - [(list (Syntax: t) (Syntax: t*)) - (subtype* A0 t t*)] - [(list (Instance: t) (Instance: t*)) - (subtype* A0 t t*)] - ;; otherwise, not a subtype - [_ (fail! s t) #;(printf "failed")])))))) + [(list _ (Univ:)) A0] + ;; error is top and bot + [(list _ (Error:)) A0] + [(list (Error:) _) A0] + ;; (Un) is bot + [(list _ (Union: (list))) (fail! s t)] + [(list (Union: (list)) _) A0] + ;; value types + [(list (Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))] + ;; integers are numbers too + [(list (Base: 'Integer _) (Base: 'Number _)) A0] + ;; values are subtypes of their "type" + [(list (Value: (? integer? n)) (Base: 'Integer _)) A0] + [(list (Value: (? number? n)) (Base: 'Number _)) A0] + [(list (Value: (? boolean? n)) (Base: 'Boolean _)) A0] + [(list (Value: (? symbol? n)) (Base: 'Symbol _)) A0] + [(list (Value: (? string? n)) (Base: 'String _)) A0] + ;; tvars are equal if they are the same variable + [(list (F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))] + ;; case-lambda + [(list (Function: arr1) (Function: arr2)) + (when (null? arr1) (fail! s t)) + (let loop-arities ([A* A0] + [arr2 arr2]) + (cond + [(null? arr2) A*] + [(supertype-of-one/arr A* (car arr2) arr1) => (lambda (A) (loop-arities A (cdr arr2)))] + [else (fail! s t)]))] + ;; recur structurally on pairs + [(list (Pair: a d) (Pair: a* d*)) + (let ([A1 (subtype* A0 a a*)]) + (and A1 (subtype* A1 d d*)))] + ;; quantification over two types preserves subtyping + [(list (Poly: ns b1) (Poly: ms b2)) + (=> unmatch) + (unless (= (length ns) (length ms)) + (unmatch)) + ;(printf "Poly: ~n~a ~n~a~n" b1 (subst-all (map list ms (map make-F ns)) b2)) + (subtype* A0 b1 (subst-all (map list ms (map make-F ns)) b2))] + ;; use unification to see if we can use the polytype here + [(list (Poly: vs b) s) + (=> unmatch) + (if (unify vs (list b) (list s)) A0 (unmatch))] + [(list s (Poly: vs b)) + (=> unmatch) + (if (null? (fv b)) (subtype* A0 s b) (unmatch))] + ;; names are compared for equality: + [(list (Name: n) (Name: n*)) + (=> unmatch) + (if (free-identifier=? n n*) + A0 + (unmatch))] + ;; just unfold the recursive types + [(list _ (? Mu?)) (subtype* A0 s (unfold t))] + [(list (? Mu?) _) (subtype* A0 (unfold s) t)] + ;; for unions, we check the cross-product + [(list (Union: es) t) (and (andmap (lambda (elem) (subtype* A0 elem t)) es) A0)] + [(list s (Union: es)) (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0)] + ;; subtyping on immutable structs is covariant + [(list (Struct: nm _ flds #f _ _ _) (Struct: nm _ flds* #f _ _ _)) + (subtypes* A0 flds flds*)] + [(list (Struct: nm _ flds proc _ _ _) (Struct: nm _ flds* proc* _ _ _)) + (subtypes* A0 (cons proc flds) (cons proc* flds*))] + ;; subtyping on structs follows the declared hierarchy + [(list (Struct: nm (? Type? parent) flds proc _ _ _) other) + ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other) + (subtype* A0 parent other)] + ;; applications and names are structs too + [(list (App: (Name: n) args stx) other) + (let ([t (lookup-type-name n)]) + (unless (Type? t) + (fail! s t)) + #;(printf "subtype: app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other + (instantiate-poly t args)) + (unless (Poly? t) + (tc-error/stx stx "cannot apply non-polymorphic type ~a" t)) + (match t [(Poly-unsafe: n _) + (unless (= n (length args)) + (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a" + n (length args)))]) + (let ([v (subtype* A0 (instantiate-poly t args) other)]) + #;(printf "val: ~a~n" v) + v))] + [(list other (App: (Name: n) args stx)) + (let ([t (lookup-type-name n)]) + (unless (Type? t) + (fail! s t)) + #;(printf "subtype: 2 app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other + (instantiate-poly t args)) + (unless (Poly? t) + (tc-error/stx stx "cannot apply non-polymorphic type ~a" t)) + (match t [(Poly-unsafe: n _) + (unless (= n (length args)) + (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a" + n (length args)))]) + ;(printf "about to call subtype with: ~a ~a ~n" other (instantiate-poly t args)) + (let ([v (subtype* A0 other (instantiate-poly t args))]) + #;(printf "2 val: ~a~n" v) + v))] + [(list (Name: n) other) + (let ([t (lookup-type-name n)]) + ;(printf "subtype: name: ~a ~a ~a~n" (syntax-e n) t other) + (if (Type? t) + (subtype* A0 t other) + (fail! s t)))] + ;; Promises are covariant + [(list (Struct: 'Promise _ (list t) _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _)) (subtype* A0 t t*)] + ;; subtyping on values is pointwise + [(list (Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] + ;; single values shouldn't actually happen, but they're just like the type + [(list t (Values: (list t*))) (int-err "BUG - singleton values type~a" (make-Values (list t*)))] + [(list (Values: (list t)) t*) (int-err "BUG - singleton values type~a" (make-Values (list t)))] + ;; subtyping on other stuff + [(list (Syntax: t) (Syntax: t*)) + (subtype* A0 t t*)] + [(list (Instance: t) (Instance: t*)) + (subtype* A0 t t*)] + ;; otherwise, not a subtype + [_ (fail! s t) #;(printf "failed")])))])))) -(define (type-compare? a b) + (define (type-compare? a b) (and (subtype a b) (subtype b a))) (provide subtype type-compare? subtypes/varargs subtypes) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index b5852df8d3..5a5a5d03ea 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -9,7 +9,7 @@ ;; FIXME - currently broken (define print-poly-types? #f) ;; do we use simple type aliases in printing -(define print-aliases #t) +(define print-aliases #f) ;; does t have a type name associated with it currently? ;; has-name : Type -> Maybe[Symbol] diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss index 567cdd56fa..f24f725856 100644 --- a/collects/typed-scheme/private/type-utils.ss +++ b/collects/typed-scheme/private/type-utils.ss @@ -37,7 +37,7 @@ (define (sb t) (substitute image name t)) (if (hash-ref (free-vars* target) name #f) (type-case sb target - [#:Union tys (Un (map sb tys))] + ;[#:Union tys (Un (map sb tys))] [#:F name* (if (eq? name* name) image target)] [#:arr dom rng rest drest kws thn-eff els-eff (begin diff --git a/collects/typed-scheme/private/union.ss b/collects/typed-scheme/private/union.ss index e8830edcc4..756ac4b827 100644 --- a/collects/typed-scheme/private/union.ss +++ b/collects/typed-scheme/private/union.ss @@ -53,7 +53,7 @@ (if (andmap Values? types) (make-Values (apply map Un (map Values-types types))) (int-err "Un: should not take the union of multiple values with some other type: ~a" types))] - [else (make-union* #;(remove-subtypes types) (foldr union2 (list (car types)) (remove-subtypes (cdr types))))]))])) + [else (make-union* #;(remove-subtypes types) (foldr union2 (list) (remove-subtypes types)))]))])) #;(defintern (Un-intern args) (lambda (_ args) (apply Un args)) args) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 14e39c96a9..679b2e339c 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -13,7 +13,7 @@ syntax/stx (utils utils))) -(provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq) +(provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq Type-key) @@ -25,9 +25,9 @@ ;; all types are Type? -(define-struct/printer Type (seq) (lambda (a b c) ((unbox print-type*) a b c))) +(define-struct/printer Type (seq key) (lambda (a b c) ((unbox print-type*) a b c))) -(define-struct/printer Effect (seq) (lambda (a b c) ((unbox print-effect*) a b c))) +(define-struct/printer Effect (seq key) (lambda (a b c) ((unbox print-effect*) a b c))) @@ -44,31 +44,34 @@ (define-syntaxes (dt de) (let () (define (parse-opts opts stx) - (let loop ([provide? #t] [intern? #f] [frees #t] [fold-rhs #f] [opts opts]) + (let loop ([provide? #t] [intern? #f] [frees #t] [fold-rhs #f] [key '(#f)] [opts opts]) (cond - [(null? opts) (values provide? intern? frees fold-rhs)] + [(null? opts) (values provide? intern? frees fold-rhs key)] [(eq? '#:no-provide (syntax-e (stx-car opts))) - (loop #f intern? frees fold-rhs (cdr opts))] + (loop #f intern? frees fold-rhs key (cdr opts))] [(eq? '#:no-frees (syntax-e (stx-car opts))) - (loop #f intern? #f fold-rhs (cdr opts))] + (loop #f intern? #f fold-rhs key (cdr opts))] [(not (and (stx-pair? opts) (stx-pair? (stx-car opts)))) (raise-syntax-error #f "bad options" stx)] [(eq? '#:intern (syntax-e (stx-car (car opts)))) - (loop provide? (stx-car (stx-cdr (car opts))) frees fold-rhs (cdr opts))] + (loop provide? (stx-car (stx-cdr (car opts))) frees fold-rhs key (cdr opts))] [(eq? '#:frees (syntax-e (stx-car (car opts)))) - (loop provide? intern? (stx-cdr (car opts)) fold-rhs (cdr opts))] + (loop provide? intern? (stx-cdr (car opts)) fold-rhs key (cdr opts))] [(eq? '#:fold-rhs (syntax-e (stx-car (car opts)))) - (loop provide? intern? frees (stx-cdr (car opts)) (cdr opts))] + (loop provide? intern? frees (stx-cdr (car opts)) key (cdr opts))] + [(eq? '#:key (syntax-e (stx-car (car opts)))) + (loop provide? intern? frees fold-rhs (stx-cdr (car opts)) (cdr opts))] [else (raise-syntax-error #f "bad options" stx)]))) (define (mk par ht-stx) (lambda (stx) (syntax-case stx () [(dform nm flds . opts) - (let*-values ([(provide? intern? frees fold-rhs) (parse-opts (syntax->list #'opts) #'opts)] + (let*-values ([(provide? intern? frees fold-rhs key-expr) (parse-opts (syntax->list #'opts) #'opts)] [(kw) (string->keyword (symbol->string (syntax-e #'nm)))]) (with-syntax* ([ex (id #'nm #'nm ":")] [kw-stx kw] + [(key-expr) key-expr] [parent par] [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds) #f #t #'nm)] [(flds* ...) #'flds] @@ -82,7 +85,12 @@ #'(lambda (tr er) #'fr))] [fold-rhs (raise-syntax-error fold-rhs "something went wrong")] - [else #'(lambda (type-rec-id effect-rec-id) #`(*maker (#,type-rec-id flds*) ...))])] + [else #'(lambda (type-rec-id effect-rec-id) + #; + (printf "about to call ~a with ~a args~n" + '*maker + (length '(flds* ...))) + #`(*maker (#,type-rec-id flds*) ...))])] [provides (if provide? #`(begin (provide ex pred acc ...) @@ -90,19 +98,18 @@ #'(begin))] [intern (cond [(syntax? intern?) - #`(defintern (**maker . flds) maker #,intern?)] + #`(defintern (**maker key . flds) maker #,intern?)] [(null? (syntax-e #'flds)) - #'(defintern (**maker . flds) maker #f)] - [(stx-null? (stx-cdr #'flds)) #'(defintern (**maker . flds) maker . flds)] - [else #'(defintern (**maker . flds) maker (list . flds))])] + #'(defintern (**maker key . flds) maker #f)] + [(stx-null? (stx-cdr #'flds)) #'(defintern (**maker key . flds) maker . flds)] + [else #'(defintern (**maker key . flds) maker (list . flds))])] [frees (cond [(not frees) #'(begin)] ;; we know that this has no free vars [(and (pair? frees) (syntax? (car frees)) (not (syntax-e (car frees)))) (syntax/loc stx (define (*maker . flds) - (define v (**maker . flds)) - #;(printf "~a entered in #f case~n" '*maker) + (define v (**maker key-expr . flds)) (unless-in-table var-table v (hash-set! var-table v empty-hash-table) @@ -113,16 +120,14 @@ [(and (pair? frees) (pair? (cdr frees))) (quasisyntax/loc stx - (define (*maker . flds) - (define v (**maker . flds)) - #;(printf "~a entered in expr case ~n~a~n~a ~n" '*maker '#,(car frees) '#,(cadr frees)) + (define (*maker . flds) + (define v (**maker key-expr . flds)) #, (quasisyntax/loc (car frees) (unless-in-table var-table v (hash-set! var-table v #,(car frees)) (hash-set! index-table v #,(cadr frees)))) - #;(printf "~a exited in expr case~n" '*maker) v))] [else (let @@ -134,8 +139,7 @@ [(e ...) #`(combine-frees (list (#,f e) ...))]))]) (quasisyntax/loc stx (define (*maker . flds) - (define v (**maker . flds)) - #;(printf "~a entered in default case~n" '*maker) + (define v (**maker key-expr . flds)) (unless-in-table var-table v (define fvs #,(combiner #'free-vars* #'flds)) @@ -150,7 +154,7 @@ (... (syntax-case s () [(__ . fs) - (with-syntax ([flds** (syntax/loc s (_ . fs))]) + (with-syntax ([flds** (syntax/loc s (_ _ . fs))]) (quasisyntax/loc s (struct nm flds**)))])))) (begin-for-syntax (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx))) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index bd286cf8d5..ea2d2017bb 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -13,7 +13,7 @@ ;; Type is defined in rep-utils.ss ;; t must be a Type -(dt Scope (t)) +(dt Scope (t) [#:key (Type-key t)]) ;; this is ONLY used when a type error ocurrs (dt Error () [#:frees #f] [#:fold-rhs #:base]) @@ -41,39 +41,52 @@ stx)]) ;; left and right are Types -(dt Pair (left right)) +(dt Pair (left right) [#:key 'pair]) ;; elem is a Type -(dt Vector (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))]) +(dt Vector (elem) + [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] + [#:key 'vector]) ;; elem is a Type -(dt Box (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))]) +(dt Box (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] + [#:key 'box]) ;; name is a Symbol (not a Name) -(dt Base (name contract) [#:frees #f] [#:fold-rhs #:base] [#:intern name]) +(dt Base (name contract) [#:frees #f] [#:fold-rhs #:base] [#:intern name] + [#:key (case name + [(Number Integer) 'number] + [(Boolean) 'boolean] + [(String) 'string] + [(Symbol) 'symbol] + [(Keyword) 'keyword] + [else #f])]) ;; body is a Scope (dt Mu (body) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))] - [#:fold-rhs (*Mu (*Scope (type-rec-id (Scope-t body))))]) + [#:fold-rhs (*Mu (*Scope (type-rec-id (Scope-t body))))] + [#:key (Type-key body)]) ;; n is how many variables are bound here ;; body is a Scope (dt Poly (n body) #:no-provide [#:frees (free-vars* body) (without-below n (free-idxs* body))] [#:fold-rhs (let ([body* (remove-scopes n body)]) - (*Poly n (add-scopes n (type-rec-id body*))))]) + (*Poly n (add-scopes n (type-rec-id body*))))] + [#:key (Type-key body)]) ;; n is how many variables are bound here ;; there are n-1 'normal' vars and 1 ... var ;; body is a Scope (dt PolyDots (n body) #:no-provide + [#:key (Type-key body)] [#:frees (free-vars* body) (without-below n (free-idxs* body))] [#:fold-rhs (let ([body* (remove-scopes n body)]) (*PolyDots n (add-scopes n (type-rec-id body*))))]) ;; pred : identifier ;; cert : syntax certifier -(dt Opaque (pred cert) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base]) +(dt Opaque (pred cert) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred]) ;; name : symbol ;; parent : Struct @@ -92,7 +105,8 @@ (and proc (type-rec-id proc)) poly? pred-id - cert)]) + cert)] + [#:key (gensym)]) ;; kw : keyword? ;; ty : Type @@ -100,7 +114,8 @@ (dt Keyword (kw ty required?) [#:frees (free-vars* ty) (free-idxs* ty)] - [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)]) + [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)] + [#:key 'keyword]) ;; dom : Listof[Type] ;; rng : Type @@ -112,6 +127,7 @@ ;; els-eff : Effect ;; arr is NOT a Type (dt arr (dom rng rest drest kws thn-eff els-eff) + [#:key 'procedure] [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) (map Keyword-ty kws) dom))) @@ -153,13 +169,22 @@ [#:fold-rhs (*Function (map type-rec-id arities))]) ;; v : Scheme Value -(dt Value (v) [#:frees #f] [#:fold-rhs #:base]) +(dt Value (v) [#:frees #f] [#:fold-rhs #:base] [#:key (cond [(number? v) 'number] + [(boolean? v) 'boolean] + [(null? v) 'null] + [else #f])]) ;; elems : Listof[Type] (dt Union (elems) [#:frees (combine-frees (map free-vars* elems)) (combine-frees (map free-idxs* elems))] - [#:fold-rhs ((get-union-maker) (map type-rec-id elems))]) - + [#:fold-rhs ((get-union-maker) (map type-rec-id elems))] + [#:key (let loop ([res null] [ts elems]) + (if (null? ts) res + (let ([k (Type-key (car ts))]) + (cond [(pair? k) (loop (append k res) (cdr ts))] + [k (loop (cons k res) (cdr ts))] + [else #f]))))]) + (dt Univ () [#:frees #f] [#:fold-rhs #:base]) ;; types : Listof[Type] @@ -167,23 +192,25 @@ #:no-provide [#:frees (combine-frees (map free-vars* types)) (combine-frees (map free-idxs* types))] - [#:fold-rhs (*Values (map type-rec-id types))]) + [#:fold-rhs (*Values (map type-rec-id types))] + [#:key 'values]) (dt ValuesDots (types dty dbound) [#:frees (combine-frees (map free-vars* (cons dty types))) (combine-frees (map free-idxs* (cons dty types)))] - [#:fold-rhs (*ValuesDots (map type-rec-id types) (type-rec-id dty) dbound)]) + [#:fold-rhs (*ValuesDots (map type-rec-id types) (type-rec-id dty) dbound)] + [#:key 'values]) ;; in : Type ;; out : Type -(dt Param (in out)) +(dt Param (in out) [#:key 'parameter]) ;; key : Type ;; value : Type -(dt Hashtable (key value)) +(dt Hashtable (key value) [#:key 'hash]) ;; t : Type -(dt Syntax (t)) +(dt Syntax (t) [#:key 'syntax]) ;; pos-flds : (Listof Type) ;; name-flds : (Listof (Tuple Symbol Type Boolean)) @@ -197,7 +224,7 @@ (map free-idxs* (append pos-flds (map cadr name-flds) (map cadr methods))))] - + [#:key 'class] [#:fold-rhs (match (list pos-flds name-flds methods) [(list pos-tys @@ -211,7 +238,7 @@ (map list mname (map type-rec-id mty)))])]) ;; cls : Class -(dt Instance (cls)) +(dt Instance (cls) [#:key 'instance]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index f08a44ff90..8cb1559cc4 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -166,16 +166,27 @@ [(_ val) #'(? (lambda (x) (equal? val x)))]))) -(define-for-syntax printing? #t) +(define-for-syntax printing? #f) (define print-type* (box (lambda _ (error "print-type* not yet defined")))) (define print-effect* (box (lambda _ (error "print-effect* not yet defined")))) +(require scheme/pretty mzlib/pconvert) + (define-syntax (define-struct/printer stx) (syntax-case stx () [(form name (flds ...) printer) #`(define-struct/properties name (flds ...) - #,(if printing? #'([prop:custom-write printer]) #'()) + #,(if printing? + #'([prop:custom-write printer]) + #'([prop:custom-write (lambda (s port mode) + (parameterize ([current-output-port port] + [show-sharing #f] + [booleans-as-true/false #f] + [constructor-style-printing #t]) + (newline) + (pretty-print (print-convert s)) + (newline)))])) #f)])) (define (id kw . args) From 7830091d42fc7204957a9947d52ad7999d4abd6b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 14 Feb 2009 20:48:26 +0000 Subject: [PATCH 04/13] re-enable printing svn: r13581 --- collects/typed-scheme/private/base-env.ss | 4 +++- collects/typed-scheme/private/type-effect-printer.ss | 2 +- collects/typed-scheme/private/union.ss | 2 +- collects/typed-scheme/utils/utils.ss | 2 +- 4 files changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index e6ce1de78f..c8e9b69a41 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -539,7 +539,9 @@ [maybe-print-message (-String . -> . -Void)] ;; scheme/list -[last-pair (-poly (a) ((-mu x (Un a (-val '()) (-pair a x))) . -> . (Un (-pair a a) (-pair a (-val '())))))] +[last-pair (-poly (a) ((-mu x (Un a (-val '()) (-pair a x))) + . -> . + (Un (-pair a a) (-pair a (-val '())))))] ;; scheme/tcp [tcp-listener? (make-pred-ty -TCP-Listener)] diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index 5a5a5d03ea..b5852df8d3 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -9,7 +9,7 @@ ;; FIXME - currently broken (define print-poly-types? #f) ;; do we use simple type aliases in printing -(define print-aliases #f) +(define print-aliases #t) ;; does t have a type name associated with it currently? ;; has-name : Type -> Maybe[Symbol] diff --git a/collects/typed-scheme/private/union.ss b/collects/typed-scheme/private/union.ss index 756ac4b827..816dbe7eb9 100644 --- a/collects/typed-scheme/private/union.ss +++ b/collects/typed-scheme/private/union.ss @@ -53,7 +53,7 @@ (if (andmap Values? types) (make-Values (apply map Un (map Values-types types))) (int-err "Un: should not take the union of multiple values with some other type: ~a" types))] - [else (make-union* #;(remove-subtypes types) (foldr union2 (list) (remove-subtypes types)))]))])) + [else (make-union* #;(remove-subtypes types) (foldr union2 '() (remove-subtypes types)))]))])) #;(defintern (Un-intern args) (lambda (_ args) (apply Un args)) args) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 8cb1559cc4..485bc20b7f 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -166,7 +166,7 @@ [(_ val) #'(? (lambda (x) (equal? val x)))]))) -(define-for-syntax printing? #f) +(define-for-syntax printing? #t) (define print-type* (box (lambda _ (error "print-type* not yet defined")))) (define print-effect* (box (lambda _ (error "print-effect* not yet defined")))) From f5c60e9282ed08fc53f7612fa6dd295949e424c8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 14 Feb 2009 20:48:40 +0000 Subject: [PATCH 05/13] now fully typechecks svn: r13582 --- collects/drscheme/syncheck/extra-typed.ss | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/collects/drscheme/syncheck/extra-typed.ss b/collects/drscheme/syncheck/extra-typed.ss index 06f129af52..4e79dc7b21 100644 --- a/collects/drscheme/syncheck/extra-typed.ss +++ b/collects/drscheme/syncheck/extra-typed.ss @@ -1,5 +1,5 @@ #lang typed-scheme - + (require (except-in scheme/list remove-duplicates) "id-sets.ss") @@ -17,7 +17,7 @@ [else (let: loop : (Listof Syntax) ([fst : Syntax (car ids)] [rst : (Listof Syntax) (cdr ids)]) - (cond + (error 'foo) #;(cond [(null? rst) (list fst)] [else (if (and (eq? (syntax-source fst) (syntax-source (car rst))) @@ -83,7 +83,7 @@ (: annotate-tail-position/last (Syntax (Listof Syntax) TailHT -> Void)) (define (annotate-tail-position/last orig-stx stxs tail-ht) (unless (null? stxs) - (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht))) + (annotate-tail-position orig-stx (car (#{last-pair @ Syntax} stxs)) tail-ht))) ;; annotate-tail-position : syntax -> void ;; colors the parens (if any) around the argument @@ -193,8 +193,6 @@ [prev (hash-ref ht #{key :: Any} (λ () #{null :: (Listof Any)}))]) (hash-set! ht #{key :: Any} #{(cons var prev) :: (Listof Any)})))) - - #| ;; annotate-basic : syntax ;; namespace @@ -450,4 +448,4 @@ (syntax-source sexp))) (void))]))) (add-tail-ht-links tail-ht))) -|# \ No newline at end of file +|# From 345abb820bf34bf7a9e1763a964b23143c07219f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 04:01:30 +0000 Subject: [PATCH 06/13] Use stxclass for defintern. Use stxclass for dt and de, and refactor/simplify. Don't use the real union for unfolding mu types. Add some descriptions to syntax classes for type parsing. svn: r13597 --- collects/typed-scheme/private/parse-type.ss | 5 +- collects/typed-scheme/private/type-utils.ss | 4 +- collects/typed-scheme/rep/interning.ss | 32 ++-- collects/typed-scheme/rep/rep-utils.ss | 202 ++++++++------------ 4 files changed, 106 insertions(+), 137 deletions(-) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index a3283d07c4..526d91843e 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -28,10 +28,12 @@ (define (stx-cadr stx) (stx-car (stx-cdr stx))) (define-syntax-class star + #:description "*" (pattern star:id #:when (eq? '* #'star.datum))) (define-syntax-class ddd + #:description "..." (pattern ddd:id #:when (eq? '... #'ddd.datum))) @@ -140,7 +142,8 @@ #:description "\na sequence of identifiers\n" (pattern (v:id ...))) -(define-syntax-class all-type +(define-syntax-class all-type + #:description "All type" #:transparent #:literals (t:All) (pattern (t:All :all-ddd-formals b) diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss index f24f725856..0617aa0f86 100644 --- a/collects/typed-scheme/private/type-utils.ss +++ b/collects/typed-scheme/private/type-utils.ss @@ -37,7 +37,7 @@ (define (sb t) (substitute image name t)) (if (hash-ref (free-vars* target) name #f) (type-case sb target - ;[#:Union tys (Un (map sb tys))] + [#:Union tys (Un (map sb tys))] [#:F name* (if (eq? name* name) image target)] [#:arr dom rng rest drest kws thn-eff els-eff (begin @@ -142,7 +142,7 @@ ;; must be applied to a Mu (define (unfold t) (match t - [(Mu: name b) (substitute t name b #:Un make-Union)] + [(Mu: name b) (substitute t name b #:Un (lambda (tys) (make-Union (sort tys < #:key Type-seq))))] [_ (int-err "unfold: requires Mu type, got ~a" t)])) (define (instantiate-poly t types) diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index d9eb6ff41d..2430ee4af9 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -1,25 +1,25 @@ #lang scheme/base -(require syntax/boundmap) +(require syntax/boundmap (for-syntax scheme/base stxclass)) (provide defintern hash-id) -(define-syntax defintern - (syntax-rules () - [(_ name+args make-name key) - (defintern name+args (lambda () (make-hash #;'weak)) make-name key)] - [(_ (*name arg ...) make-ht make-name key-expr) - (define *name - (let ([table (make-ht)]) - (lambda (arg ...) - #;(all-count!) - (let ([key key-expr]) - (hash-ref table key - (lambda () - (let ([new (make-name (count!) arg ...)]) - (hash-set! table key new) - new)))))))])) +(define-syntax (defintern stx) + (syntax-parse stx + [(_ name+args make-name key ([#:extra-arg e:expr]) ...*) + #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)] + [(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*) + #'(define *name + (let ([table (make-ht)]) + (lambda (arg ...) + #;(all-count!) + (let ([key key-expr]) + (hash-ref table key + (lambda () + (let ([new (make-name (count!) e ... arg ...)]) + (hash-set! table key new) + new)))))))])) (define (make-count!) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 679b2e339c..2d2ecc7d98 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -8,10 +8,11 @@ "interning.ss" mzlib/etc (for-syntax + stxclass scheme/base syntax/struct syntax/stx - (utils utils))) + (rename-in (utils utils) [id mk-id]))) (provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq Type-key) @@ -43,123 +44,88 @@ (define-syntaxes (dt de) (let () - (define (parse-opts opts stx) - (let loop ([provide? #t] [intern? #f] [frees #t] [fold-rhs #f] [key '(#f)] [opts opts]) - (cond - [(null? opts) (values provide? intern? frees fold-rhs key)] - [(eq? '#:no-provide (syntax-e (stx-car opts))) - (loop #f intern? frees fold-rhs key (cdr opts))] - [(eq? '#:no-frees (syntax-e (stx-car opts))) - (loop #f intern? #f fold-rhs key (cdr opts))] - [(not (and (stx-pair? opts) (stx-pair? (stx-car opts)))) - (raise-syntax-error #f "bad options" stx)] - [(eq? '#:intern (syntax-e (stx-car (car opts)))) - (loop provide? (stx-car (stx-cdr (car opts))) frees fold-rhs key (cdr opts))] - [(eq? '#:frees (syntax-e (stx-car (car opts)))) - (loop provide? intern? (stx-cdr (car opts)) fold-rhs key (cdr opts))] - [(eq? '#:fold-rhs (syntax-e (stx-car (car opts)))) - (loop provide? intern? frees (stx-cdr (car opts)) key (cdr opts))] - [(eq? '#:key (syntax-e (stx-car (car opts)))) - (loop provide? intern? frees fold-rhs (stx-cdr (car opts)) (cdr opts))] - [else (raise-syntax-error #f "bad options" stx)]))) + (define-syntax-class no-provide-kw + (pattern #:no-provide)) + (define-syntax-class idlist + (pattern (i:id ...))) + (define (combiner f flds) + (syntax-parse flds + [() #'empty-hash-table] + [(e) #`(#,f e)] + [(e ...) #`(combine-frees (list (#,f e) ...))])) + (define-syntax-class frees-pat + #:transparent + #:attributes (f1 f2) + (pattern (f1:expr f2:expr)) + (pattern (#f) + #:with f1 #'empty-hash-table + #:with f2 #'empty-hash-table)) + (define-syntax-class fold-pat + #:transparent + #:attributes (e) + (pattern #:base + #:with e fold-target) + (pattern ex:expr + #:with e #'#'ex)) (define (mk par ht-stx) (lambda (stx) - (syntax-case stx () - [(dform nm flds . opts) - (let*-values ([(provide? intern? frees fold-rhs key-expr) (parse-opts (syntax->list #'opts) #'opts)] - [(kw) (string->keyword (symbol->string (syntax-e #'nm)))]) - (with-syntax* - ([ex (id #'nm #'nm ":")] - [kw-stx kw] - [(key-expr) key-expr] - [parent par] - [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds) #f #t #'nm)] - [(flds* ...) #'flds] - [*maker (id #'nm "*" #'nm)] - [**maker (id #'nm "**" #'nm)] - [ht-stx ht-stx] - [bfs-fold-rhs (cond [(and fold-rhs (eq? (syntax-e (stx-car fold-rhs)) '#:base)) - #`(lambda (tr er) #,fold-target)] - [(and fold-rhs (stx-pair? fold-rhs)) - (with-syntax ([fr (stx-car fold-rhs)]) - #'(lambda (tr er) - #'fr))] - [fold-rhs (raise-syntax-error fold-rhs "something went wrong")] - [else #'(lambda (type-rec-id effect-rec-id) - #; - (printf "about to call ~a with ~a args~n" - '*maker - (length '(flds* ...))) - #`(*maker (#,type-rec-id flds*) ...))])] - [provides (if provide? - #`(begin - (provide ex pred acc ...) - (provide (rename-out [*maker maker]))) - #'(begin))] - [intern (cond - [(syntax? intern?) - #`(defintern (**maker key . flds) maker #,intern?)] - [(null? (syntax-e #'flds)) - #'(defintern (**maker key . flds) maker #f)] - [(stx-null? (stx-cdr #'flds)) #'(defintern (**maker key . flds) maker . flds)] - [else #'(defintern (**maker key . flds) maker (list . flds))])] - [frees (cond - [(not frees) #'(begin)] - ;; we know that this has no free vars - [(and (pair? frees) (syntax? (car frees)) (not (syntax-e (car frees)))) - (syntax/loc stx - (define (*maker . flds) - (define v (**maker key-expr . flds)) - (unless-in-table - var-table v - (hash-set! var-table v empty-hash-table) - (hash-set! index-table v empty-hash-table)) - v))] - ;; we provided an expression each for calculating the free vars and free idxs - ;; this should really be 2 expressions, one for each kind - [(and (pair? frees) (pair? (cdr frees))) - (quasisyntax/loc - stx - (define (*maker . flds) - (define v (**maker key-expr . flds)) - #, - (quasisyntax/loc (car frees) - (unless-in-table - var-table v - (hash-set! var-table v #,(car frees)) - (hash-set! index-table v #,(cadr frees)))) - v))] - [else - (let - ([combiner - (lambda (f flds) - (syntax-case flds () - [() #'empty-hash-table] - [(e) #`(#,f e)] - [(e ...) #`(combine-frees (list (#,f e) ...))]))]) - (quasisyntax/loc stx - (define (*maker . flds) - (define v (**maker key-expr . flds)) - (unless-in-table - var-table v - (define fvs #,(combiner #'free-vars* #'flds)) - (define fis #,(combiner #'free-idxs* #'flds)) - (hash-set! var-table v fvs) - (hash-set! index-table v fis)) - v)))])]) - #`(begin - (define-struct (nm parent) flds #:inspector #f) - (define-match-expander ex - (lambda (s) - (... - (syntax-case s () - [(__ . fs) - (with-syntax ([flds** (syntax/loc s (_ _ . fs))]) - (quasisyntax/loc s (struct nm flds**)))])))) - (begin-for-syntax - (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx))) - intern - provides - frees)))]))) - (values (mk #'Type #'type-name-ht) (mk #'Effect #'effect-name-ht)))) + (syntax-parse stx + [(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt + [[#:intern intern?:expr]] #:opt + [[#:frees . frees:frees-pat]] #:opt + [[#:fold-rhs fold-rhs:fold-pat]] #:opt + [no-provide?:no-provide-kw] #:opt) ...*) + (with-syntax* + ([ex (mk-id #'nm #'nm ":")] + [kw-stx (string->keyword (symbol->string #'nm.datum))] + [parent par] + [(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds) #f #t #'nm)] + [*maker (mk-id #'nm "*" #'nm)] + [**maker (mk-id #'nm "**" #'nm)] + [ht-stx ht-stx] + [bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)] + [else #'(lambda (type-rec-id effect-rec-id) + #`(*maker (#,type-rec-id flds.i) ...))])] + [provides (if #'no-provide? + #'(begin) + #`(begin + (provide ex pred acc ...) + (provide (rename-out [*maker maker]))))] + [intern + (let ([mk (lambda (int) #`(defintern (**maker . flds) maker #,int #:extra-arg key-expr))]) + (syntax-parse #'flds + [_ #:when #'intern? + (mk #'intern?)] + [() (mk #'#f)] + [(f) (mk #'f)] + [_ (mk #'(list . flds))]))] + [frees + (with-syntax ([(f1 f2) (if #'frees + #'(frees.f1 frees.f2) + (list (combiner #'free-vars* #'flds) + (combiner #'free-idxs* #'flds)))]) + (quasisyntax/loc stx + (define (*maker . flds) + (define v (**maker . flds)) + (unless-in-table + var-table v + (define fvs f1) + (define fis f2) + (hash-set! var-table v fvs) + (hash-set! index-table v fis)) + v)))]) + #`(begin + (define-struct (nm parent) flds #:inspector #f) + (define-match-expander ex + (lambda (s) + (syntax-parse s + [(_ . fs) + #:with pat (syntax/loc s (_ _ . fs)) + (syntax/loc s (struct nm pat))]))) + (begin-for-syntax + (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx))) + intern + provides + frees))]))) + (values (mk #'Type #'type-name-ht) (mk #'Effect #'effect-name-ht)))) From 738b8311afd40047e22fcf0181e34cef541e7ece Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 17:45:53 +0000 Subject: [PATCH 07/13] sync to trunk svn: r13609 --- collects/2htdp/private/universe.ss | 104 +- collects/2htdp/universe.ss | 12 +- .../games/chat-noir/chat-noir-literate.ss | 53 +- collects/games/chat-noir/literate-lang.ss | 50 +- collects/lang/private/beginner-funs.ss | 112 +- collects/mzlib/private/unit-compiletime.ss | 17 +- .../mzlib/private/unit-contract-syntax.ss | 57 +- collects/mzlib/private/unit-contract.ss | 127 +- collects/mzlib/unit.ss | 138 +- collects/repos-time-stamp/stamp.ss | 2 +- collects/scheme/private/contract.ss | 45 +- collects/scribblings/guide/info.ss | 2 +- collects/scribblings/guide/unit.scrbl | 92 +- collects/scribblings/main/config.ss | 2 +- .../scribblings/main/getting-started.scrbl | 44 + collects/scribblings/main/info.ss | 1 + collects/scribblings/main/private/manuals.ss | 24 +- collects/scribblings/more/info.ss | 2 +- collects/scribblings/quick/quick.scrbl | 13 +- collects/scribblings/reference/exns.scrbl | 29 +- collects/scribblings/reference/hashes.scrbl | 92 +- collects/scribblings/reference/units.scrbl | 18 +- .../2htdp/scribblings/universe.scrbl | 81 +- .../teachpack/htdp/scribblings/world.scrbl | 30 +- collects/tests/units/test-unit-contracts.ss | 79 +- collects/tex2page/tex2page.tex | 1238 +++++++++++++++++ collects/web-server/info.ss | 2 +- .../scribblings/tutorial/continue.scrbl | 6 +- doc/release-notes/teachpack/HISTORY.txt | 5 + src/mzscheme/gc2/newgc.c | 14 +- src/mzscheme/gc2/sighand.c | 8 + src/mzscheme/src/error.c | 5 +- 32 files changed, 2072 insertions(+), 432 deletions(-) create mode 100644 collects/scribblings/main/getting-started.scrbl create mode 100644 collects/tex2page/tex2page.tex diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss index 7fc5426de7..f1dd4b08bd 100644 --- a/collects/2htdp/private/universe.ss +++ b/collects/2htdp/private/universe.ss @@ -57,21 +57,21 @@ (define (pname a ...) (define (handler e) (stop! e)) (with-handlers ([exn? handler]) - (define r (check-state-x-mail 'name (name worlds universe a ...))) + (define r (check-state-x-mail 'name (name iworlds universe a ...))) (define u (bundle-state r)) - (set! worlds (bundle-low r)) + (set! iworlds (bundle-low r)) (set! universe u) - (unless (boolean? to-string) (send gui add (to-string worlds u))) + (unless (boolean? to-string) (send gui add (to-string iworlds u))) (broadcast (bundle-mails r)))))) - (def/cback private (pmsg world received) on-msg) + (def/cback private (pmsg iworld received) on-msg) - (def/cback private (pdisconnect world) on-disconnect) + (def/cback private (pdisconnect iworld) on-disconnect) - (def/cback private (pnew world) ppnew) + (def/cback private (pnew iworld) ppnew) (define/private (ppnew low uni p) - (world-send p 'okay) + (iworld-send p 'okay) (on-new low uni p)) (def/cback public (ptock) tick) @@ -90,7 +90,7 @@ ;; ----------------------------------------------------------------------- ;; start and stop server, start and stop the universe - (field [worlds '()] ;; [Listof World] + (field [iworlds '()] ;; [Listof World] [gui (new gui% [stop-server (lambda () (stop! universe))] [stop-and-restart (lambda () (restart))])] @@ -103,50 +103,50 @@ (parameterize ([current-custodian the-custodian]) (define (loop) (apply sync - (handle-evt (tcp-accept-evt tcp-listener) add-world) - (map world-wait-for-msg worlds))) - (define (add-world in-out) + (handle-evt (tcp-accept-evt tcp-listener) add-iworld) + (map iworld-wait-for-msg iworlds))) + (define (add-iworld in-out) (with-handlers ((tcp-eof? (lambda _ (loop)))) (define in (first in-out)) (define next (tcp-receive in)) (match next [(cons 'REGISTER info) - (let* ([w (create-world in (second in-out) info)]) - ; (set! worlds (cons w worlds)) + (let* ([w (create-iworld in (second in-out) info)]) + ; (set! iworlds (cons w iworlds)) (pnew w) (send gui add (format "~a signed up" info)) (loop))] [else (loop)]))) - (define (world-wait-for-msg p) - (handle-evt (world-in p) + (define (iworld-wait-for-msg p) + (handle-evt (iworld-in p) (lambda (in) (with-handlers ((tcp-eof? (lambda (e) (handler p e (lambda () - (if (null? worlds) + (if (null? iworlds) (restart) (loop))))))) (define r (tcp-receive in)) - (send gui add (format "~a ->: ~a" (world-name p) r)) + (send gui add (format "~a ->: ~a" (iworld-name p) r)) (pmsg p r) (loop))))) (define tcp-listener (with-handlers ((exn:fail:network? (lambda (x) (stop! x)))) (tcp-listen SQPORT 4 #t))) ;; --- go universe go --- - (set! worlds '()) + (set! iworlds '()) (set! universe universe0) (send gui add "a new universe is up and running") (thread loop))) ;; World Exn (-> X) -> X (define/private (handler p e cont) - (close-output-port (world-out p)) - (close-input-port (world-in p)) - (send gui add (format "~a !! closed port" (world-name p))) - (set! worlds (remq p worlds)) + (close-output-port (iworld-out p)) + (close-input-port (iworld-in p)) + (send gui add (format "~a !! closed port" (iworld-name p))) + (set! iworlds (remq p iworlds)) (pdisconnect p) (cont)) @@ -163,12 +163,12 @@ ;; (handler (with-handlers ((exn? (lambda (e) (printf "\n\n*** to be done ***\n\n")))) (define w (mail-to p+m)) - (define n (world-name w)) + (define n (iworld-name w)) (define p (mail-content p+m)) - (unless (memq w worlds) + (unless (memq w iworlds) (send gui add (format "~s not on list" n))) - (when (memq w worlds) - (world-send w p) + (when (memq w iworlds) + (iworld-send w p) (send gui add (format "-> ~a: ~a" n p))))) lm)) @@ -184,9 +184,9 @@ (send gui add "stopping the universe") (send gui add "----------------------------------") (for-each (lambda (w) - (close-input-port (world-in w)) - (close-output-port (world-out w))) - worlds) + (close-input-port (iworld-in w)) + (close-output-port (iworld-out w))) + iworlds) (custodian-shutdown-all the-custodian) (semaphore-post go))) @@ -217,35 +217,35 @@ ; (provide - world? ;; Any -> Boolean - world=? ;; World World -> Boolean - world-name ;; World -> Symbol - world1 ;; sample worlds - world2 - world3) + iworld? ;; Any -> Boolean + iworld=? ;; World World -> Boolean + iworld-name ;; World -> Symbol + iworld1 ;; sample worlds + iworld2 + iworld3) ;; --- the server representation of a world --- -(define-struct world (in out name info) #:transparent) -;; World = (make-world IPort OPort Symbol [Listof Sexp]) +(define-struct iworld (in out name info) #:transparent) +;; World = (make-iworld IPort OPort Symbol [Listof Sexp]) -(define world1 (make-world (current-input-port) (current-output-port) 'sk '())) -(define world2 (make-world (current-input-port) (current-output-port) 'mf '())) -(define world3 (make-world (current-input-port) (current-output-port) 'rf '())) +(define iworld1 (make-iworld (current-input-port) (current-output-port) 'sk '())) +(define iworld2 (make-iworld (current-input-port) (current-output-port) 'mf '())) +(define iworld3 (make-iworld (current-input-port) (current-output-port) 'rf '())) -(define (world=? u v) - (check-arg 'world=? (world? u) 'world "first" u) - (check-arg 'world=? (world? v) 'world "second" v) +(define (iworld=? u v) + (check-arg 'iworld=? (iworld? u) 'iworld "first" u) + (check-arg 'iworld=? (iworld? v) 'iworld "second" v) (eq? u v)) ;; IPort OPort Sexp -> Player -(define (create-world i o info) +(define (create-iworld i o info) (if (and (pair? info) (symbol? (car info))) - (make-world i o (car info) (cdr info)) - (make-world i o (gensym 'world) info))) + (make-iworld i o (car info) (cdr info)) + (make-iworld i o (gensym 'iworld) info))) ;; Player S-exp -> Void -(define (world-send p sexp) - (tcp-send (world-out p) sexp)) +(define (iworld-send p sexp) + (tcp-send (iworld-out p) sexp)) ; ; @@ -351,16 +351,16 @@ (set! make-bundle (let ([make-bundle make-bundle]) (lambda (low state mails) - (check-arg-list 'make-bundle low world? "world" "first") + (check-arg-list 'make-bundle low iworld? "iworld" "first") (check-arg-list 'make-bundle mails mail? "mail" "third") (make-bundle low state mails)))) ;; Symbol Any (Any -> Boolean) String String -> Void ;; raise a TP exception if low is not a list of world? elements -(define (check-arg-list tag low world? msg rank) +(define (check-arg-list tag low iworld? msg rank) (check-arg tag (list? low) (format "list [of ~as]" msg) rank low) (for-each (lambda (c) - (check-arg tag (world? c) msg (format "(elements of) ~a" rank) c)) + (check-arg tag (iworld? c) msg (format "(elements of) ~a" rank) c)) low)) (define-struct mail (to content) #:transparent) @@ -368,6 +368,6 @@ (set! make-mail (let ([make-mail make-mail]) (lambda (to content) - (check-arg 'make-mail (world? to) 'world "first" to) + (check-arg 'make-mail (iworld? to) 'iworld "first" to) (check-arg 'make-mail (sexp? content) 'S-expression "second" content) (make-mail to content)))) diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index 4d2758168a..d26ef51db2 100644 --- a/collects/2htdp/universe.ss +++ b/collects/2htdp/universe.ss @@ -226,12 +226,12 @@ (provide ;; type World - world? ;; Any -> Boolean - world=? ;; World World -> Boolean - world-name ;; World -> Symbol - world1 ;; sample worlds - world2 - world3 + iworld? ;; Any -> Boolean + iworld=? ;; World World -> Boolean + iworld-name ;; World -> Symbol + iworld1 ;; sample worlds + iworld2 + iworld3 ;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail]) ;; type Mail = (make-mail World S-expression) make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 430a3df3fe..2d3e051e73 100755 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1,34 +1,58 @@ #reader "literate-reader.ss" + + +@title{Chat Noir} + +Chat Noir. What a game. + @chunk[
] -The first main data definition for Chat Noir is the state of the world. +@schememodname[htdp/world] + +@section{Data Definitions} + +The main data structure for Chat Noir is @tt{world}. @chunk[ -(define-struct world (board cat state size mouse-posn h-down?) #:transparent) +(define-struct world (board cat state size mouse-posn h-down?) + #:transparent) ] -;; a world is: -;; (make-world board posn state number mouse posn-or-false boolean) - - -;; a state is either: -;; - 'playing -;; - 'cat-won -;; - 'cat-lost - -;; a board is -;; (listof cell) +It consists of a structure with six fields: +@itemize{ +@item{ +a @scheme[board],} +@item{ +a @scheme[posn] for the cat,} +@item{the state of the game (@scheme[state] below), which can be one of +@itemize{ +@item{@scheme['playing], indicating that the game is still going; this is the initial state. + } +@item{@scheme['cat-won], indicating that the game is over and the cat won, or} +@item{@scheme['cat-lost], indicating that the game is over and the cat lost.}} + } +@item{ +a @scheme[posn] for the location of the mouse (or @scheme[#f] if the +mouse is not in the window),} +@item{and a boolean indicating if the @tt{h} +key has been pushed down.} +} +@verbatim[#<<--- ;; a cell is ;; (make-cell (make-posn int[0-board-size] ;; int[0-board-size]) ;; boolean) +--- +] + @chunk[ (define-struct cell (p blocked?) #:transparent)] +@section{Init Junk} @chunk[ @@ -68,6 +92,9 @@ The first main data definition for Chat Noir is the state of the world. (map (λ (x) (cons (car x) (cadr x))) init)))] +@section{Everything Else} + + @chunk[ #;'() diff --git a/collects/games/chat-noir/literate-lang.ss b/collects/games/chat-noir/literate-lang.ss index 86eaf4441b..0c6aa80992 100755 --- a/collects/games/chat-noir/literate-lang.ss +++ b/collects/games/chat-noir/literate-lang.ss @@ -15,16 +15,22 @@ (begin-for-syntax (define main-id #f) + (define (mapping-get mapping id) + (free-identifier-mapping-get mapping id (lambda () '()))) + ;; maps a block identifier to its collected expressions (define code-blocks (make-free-identifier-mapping)) - (define (get-id-exprs id) - (free-identifier-mapping-get code-blocks id (lambda () '()))) + ;; maps a block identifier to all identifiers that are used to define it + (define block-groups (make-free-identifier-mapping)) (define (get-block id) - (map syntax-local-introduce (get-id-exprs id))) + (map syntax-local-introduce (mapping-get code-blocks id))) (define (add-to-block! id exprs) (unless main-id (set! main-id id)) + (free-identifier-mapping-put! + block-groups id + (cons (syntax-local-introduce id) (mapping-get block-groups id))) (free-identifier-mapping-put! code-blocks id - `(,@(get-id-exprs id) ,@(map syntax-local-introduce exprs))))) + `(,@(mapping-get code-blocks id) ,@(map syntax-local-introduce exprs))))) (define :make-splice make-splice) @@ -45,17 +51,31 @@ (schemeblock expr ...))))])) (define-syntax (tangle stx) - #`(begin - #,@(let loop ([block (get-block main-id)]) - (append-map (lambda (expr) - (if (identifier? expr) - (let ([subs (get-block expr)]) - (if (pair? subs) (loop subs) (list expr))) - (let ([subs (syntax->list expr)]) - (if subs - (list (loop subs)) - (list expr))))) - block)))) + (define block-mentions '()) + (define body + (let loop ([block (get-block main-id)]) + (append-map + (lambda (expr) + (if (identifier? expr) + (let ([subs (get-block expr)]) + (if (pair? subs) + (begin (set! block-mentions (cons expr block-mentions)) + (loop subs)) + (list expr))) + (let ([subs (syntax->list expr)]) + (if subs + (list (loop subs)) + (list expr))))) + block))) + (with-syntax ([(body ...) body] + ;; construct arrows manually + [((b-use b-id) ...) + (append-map (lambda (m) + (map (lambda (u) + (list m (syntax-local-introduce u))) + (mapping-get block-groups m))) + block-mentions)]) + #`(begin body ... (let ([b-id (void)]) b-use) ...))) (define-syntax (module-begin stx) (syntax-case stx () diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss index 6db345a023..1d81a3ace1 100644 --- a/collects/lang/private/beginner-funs.ss +++ b/collects/lang/private/beginner-funs.ss @@ -14,7 +14,7 @@ ("Numbers: Integers, Rationals, Reals, Complex, Exacts, Inexacts" (number? (any -> boolean) "to determine whether some value is a number") - (= (num num num ... -> boolean) + (= (number number number ... -> boolean) "to compare numbers for equality") (< (real real real ... -> boolean) "to compare real numbers for less-than") @@ -25,30 +25,32 @@ (>= (real real ... -> boolean) "to compare real numbers for greater-than or equality") - ((beginner-+ +) (num num num ... -> num) + ((beginner-+ +) (number number number ... -> number) "to compute the sum of the input numbers") - (- (num num ... -> num) + (- (number number ... -> number) "to subtract the second (and following) number(s) from the first; negate the number if there is only one argument") - ((beginner-* *) (num num num ... -> num) + ((beginner-* *) (number number number ... -> number) "to compute the product of all of the input numbers") - ((beginner-/ /) (num num num ... -> num) + ((beginner-/ /) (number number number ... -> number) "to divide the first by the second (and all following) number(s); try (/ 3 4) and (/ 3 2 2)" " only the first number can be zero.") (max (real real ... -> real) "to determine the largest number") (min (real real ... -> real) "to determine the smallest number") - (quotient (int int -> int) - "to divide the first integer into the second; try (quotient 3 4) and (quotient 4 3)") - (remainder (int int -> int) - "to determine the remainder of dividing the first by the second integer") - (modulo (int int -> int) + (quotient (integer integer -> integer) + "to divide the first integer (exact or inexact) into the second; try (quotient 3 4) and (quotient 4 3)") + (remainder (integer integer -> integer) + "to determine the remainder of dividing the first by the second integer (exact or inexact)") + (modulo (integer integer -> integer) "to find the remainder of the division of the first number by the second; try (modulo 4 3) (modulo 4 -3)") - (sqr (num -> num) + (sqr (number -> number) "to compute the square of a number") - (sqrt (num -> num) - "to compute the square root of a number") - (expt (num num -> num) + (sqrt (number -> number) + "to compute the square root of a number") + (integer-sqrt (number -> integer) + "to compute the integer (exact or inexact) square root of a number") + (expt (number number -> number) "to compute the power of the first to the second number") (abs (real -> real) "to compute the absolute value of a real number") @@ -56,31 +58,31 @@ "to compute the sign of a real number") ;; fancy numeric - (exp (num -> num) + (exp (number -> number) "to compute e raised to a number") - (log (num -> num) + (log (number -> number) "to compute the base-e logarithm of a number") ;; trigonometry - (sin (num -> num) + (sin (number -> number) "to compute the sine of a number (radians)") - (cos (num -> num) + (cos (number -> number) "to compute the cosine of a number (radians)") - (tan (num -> num) + (tan (number -> number) "to compute the tangent of a number (radians)") - (asin (num -> num) + (asin (number -> number) "to compute the arcsine (inverse of sin) of a number") - (acos (num -> num) + (acos (number -> number) "to compute the arccosine (inverse of cos) of a number") - (atan (num -> num) + (atan (number -> number) "to compute the arctan (inverse of tan) of a number") - (sinh (num -> num) + (sinh (number -> number) "to compute the hyperbolic sine of a number") - (cosh (num -> num) + (cosh (number -> number) "to compute the hyperbolic cosine of a number") - (exact? (num -> boolean) + (exact? (number -> boolean) "to determine whether some number is exact") (integer? (any -> boolean) @@ -93,84 +95,88 @@ (negative? (number -> boolean) "to determine if some value is strictly smaller than zero") (odd? (integer -> boolean) - "to determine if some value is odd or not") + "to determine if some integer (exact or inexact) is odd or not") (even? (integer -> boolean) - "to determine if some value is even or not") + "to determine if some integer (exact or inexact) is even or not") (add1 (number -> number) "to compute a number one larger than a given number") (sub1 (number -> number) "to compute a number one smaller than a given number") - (lcm (int int ... -> int) - "to compute the least common multiple of two integers") + (lcm (integer integer ... -> integer) + "to compute the least common multiple of two integers (exact or inexact)") - (gcd (int int ... -> int) - "to compute the greatest common divisior") + (gcd (integer integer ... -> integer) + "to compute the greatest common divisior of two integers (exact or inexact)") (rational? (any -> boolean) "to determine whether some value is a rational number") - (numerator (rat -> int) + (numerator (rat -> integer) "to compute the numerator of a rational") - (denominator (rat -> int) + (denominator (rat -> integer) "to compute the denominator of a rational") - (inexact? (num -> boolean) + (inexact? (number -> boolean) "to determine whether some number is inexact") (real? (any -> boolean) "to determine whether some value is a real number") - (floor (real -> int) - "to determine the closest integer below a real number") + (floor (real -> integer) + "to determine the closest integer (exact or inexact) below a real number") - (ceiling (real -> int) - "to determine the closest integer above a real number") + (ceiling (real -> integer) + "to determine the closest integer (exact or inexact) above a real number") - (round (real -> int) + (round (real -> integer) "to round a real number to an integer (rounds to even to break ties)") (complex? (any -> boolean) "to determine whether some value is complex") - (make-polar (real real -> num) + (make-polar (real real -> number) "to create a complex from a magnitude and angle") + + (make-rectangular (real real -> number) + "to create a complex from a real and an imaginary part") - (real-part (num -> real) + (real-part (number -> real) "to extract the real part from a complex number") - (imag-part (num -> real) + (imag-part (number -> real) "to extract the imaginary part from a complex number") - (magnitude (num -> real) + (magnitude (number -> real) "to determine the magnitude of a complex number") - (angle (num -> real) + (angle (number -> real) "to extract the angle from a complex number") - (conjugate (num -> num) + (conjugate (number -> number) "to compute the conjugate of a complex number") - (exact->inexact (num -> num) + (exact->inexact (number -> number) "to convert an exact number to an inexact one") - (inexact->exact (num -> num) + (inexact->exact (number -> number) "to approximate an inexact number by an exact one") ; "Odds and ends" - (number->string (num -> string) + (number->string (number -> string) "to convert a number to a string") - (integer->char (int -> char) - "to lookup the character that corresponds to the given integer in the ASCII table (if any)") + (integer->char (integer -> char) + "to lookup the character that corresponds to the given integer (exact only!) in the ASCII table (if any)") - (random (int -> int) - "to generate a random natural number less than some given integer") + (random (integer -> integer) + "to generate a random natural number less than some given integer + (exact only!)") - (current-seconds (-> int) + (current-seconds (-> integer) "to compute the current time in seconds elapsed" " (since a platform-specific starting date)") diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 49ad4d8b49..b8eede078a 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -111,16 +111,21 @@ (parameterize ((error-syntax stx)) (raise-stx-err "illegal use of signature form")))) - ;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier) - (define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder) + ;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier boolean) + (define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder contracted?) (lambda (struct stx) (with-syntax ((u (unit-info-unit-id struct))) (syntax-case stx (set!) ((set! x y) - #`(begin - #,(syntax/loc #'y (check-unit y 'set!)) - #,(syntax/loc #'y (check-sigs y (unit-import-sigs u) (unit-export-sigs u) 'set!)) - (set! u y))) + (if (unit-info-contracted? struct) + (raise-syntax-error 'set! + "cannot set! a contracted unit" + stx + (syntax x)) + #`(begin + #,(syntax/loc #'y (check-unit y 'set!)) + #,(syntax/loc #'y (check-sigs y (unit-import-sigs u) (unit-export-sigs u) 'set!)) + (set! u y)))) ((_ . y) (syntax/loc stx (u . y))) (x diff --git a/collects/mzlib/private/unit-contract-syntax.ss b/collects/mzlib/private/unit-contract-syntax.ss index 8f6fa734f5..97a6af6659 100644 --- a/collects/mzlib/private/unit-contract-syntax.ss +++ b/collects/mzlib/private/unit-contract-syntax.ss @@ -4,7 +4,8 @@ "unit-compiletime.ss" (for-template "unit-keywords.ss")) -(provide import-clause export-clause) +(provide import-clause/contract export-clause/contract dep-clause + import-clause/c export-clause/c) (define-syntax-class sig-id #:attributes () @@ -14,29 +15,55 @@ (signature? (set!-trans-extract x)))))) (define-syntax-class sig-spec #:literals (prefix rename only except) + #:attributes ((name 0)) + #:transparent + (pattern name:sig-id) + (pattern (prefix i:identifier s:sig-spec) + #:with name #'s.name) + (pattern (rename s:sig-spec [int:identifier ext:identifier] ...) + #:with name #'s.name) + (pattern (only s:sig-spec i:identifier ...) + #:with name #'s.name) + (pattern (except s:sig-spec i:identifier ...) + #:with name #'s.name)) + +(define-syntax-class tagged-sig-spec #:literals (tag) + #:transparent + (pattern s:sig-spec + #:with i #f) + (pattern (tag i:identifier s:sig-spec))) + +(define-syntax-class tagged-sig-id #:literals (tag) #:attributes () #:transparent (pattern s:sig-id) - (pattern (prefix i:identifier s:sig-spec)) - (pattern (rename s:sig-spec [int:identifier ext:identifier] ...)) - (pattern (only s:sig-spec i:identifier ...)) - (pattern (except s:sig-spec i:identifier ...))) - -(define-syntax-class tagged-sig-spec #:literals (tag) - #:attributes () - #:transparent - (pattern s:sig-spec) - (pattern (tag i:identifier s:sig-spec))) + (pattern (tag i:identifier s:sig-id))) (define-syntax-class unit/c-clause + #:transparent + (pattern (s:tagged-sig-id [x:identifier c:expr] ...)) + (pattern s:tagged-sig-id ;; allow a non-wrapped sig, which is the same as (sig) + #:with (x ...) null + #:with (c ...) null)) +(define-syntax-class import-clause/c #:literals (import) + #:transparent + (pattern (import i:unit/c-clause ...))) +(define-syntax-class export-clause/c #:literals (export) + #:transparent + (pattern (export e:unit/c-clause ...))) + +(define-syntax-class unit/contract-clause #:transparent (pattern (s:tagged-sig-spec [x:identifier c:expr] ...)) (pattern s:tagged-sig-spec ;; allow a non-wrapped sig, which is the same as (sig) #:with (x ...) null #:with (c ...) null)) -(define-syntax-class import-clause #:literals (import) +(define-syntax-class import-clause/contract #:literals (import) #:transparent - (pattern (import i:unit/c-clause ...))) -(define-syntax-class export-clause #:literals (export) + (pattern (import i:unit/contract-clause ...))) +(define-syntax-class export-clause/contract #:literals (export) #:transparent - (pattern (export e:unit/c-clause ...))) \ No newline at end of file + (pattern (export e:unit/contract-clause ...))) +(define-syntax-class dep-clause #:literals (init-depend) + #:transparent + (pattern (init-depend s:tagged-sig-id ...))) \ No newline at end of file diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 861ddfba68..a3813b91e2 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -4,18 +4,57 @@ stxclass syntax/boundmap "unit-compiletime.ss" - "unit-contract-syntax.ss") + "unit-contract-syntax.ss" + "unit-syntax.ss") scheme/contract "unit-utils.ss" "unit-runtime.ss") -(provide unit/c) +(provide (for-syntax unit/c/core) unit/c) + +#| +We want to think of the contract as sitting between the outside world +and the unit in question. In the case where the signature in question +is contracted, we have: + + pos unit/c neg + | + --- | + | | | + <---- | i | <-----|------ (v, o) + | | | + --- | + | | | +(v, u) ----> | e | ------|-----> + | | | + --- | + | + +So for an import, we start out with (v, o) coming in when the +import is being set. We need to first check the contract +(sig-ctc, o, neg), to make sure what's coming in appropriately +satisfies that contract (since it already has given us the +positive blame for the value incoming). Then we need to check +(ctc, neg, pos) (i.e. apply the projection with the blame +"switched"). That leaves pos as the appropriate thing to pack +with the value for the sig-ctc check inside the unit. When +the unit pulls it out (which isn't affected by the unit/c +contract combinator), it'll have the correct party to blame as +far as it knows. + +For an export, we start on the other side, so we don't need to do +anything to the setting function as the unit will handle that. So for +the accessing function, we need to grab what's in the box, +check (sig-ctc, u, pos), then check (ctc, pos, neg) via projection +application, then last, but not least, return the resulting value +packed with the neg blame. +|# (define-for-syntax (contract-imports/exports import?) (λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name) (define def-table (make-bound-identifier-mapping)) - (define (convert-reference vref ctc sig-ctc rename-bindings) + (define (convert-reference var vref ctc sig-ctc rename-bindings) (let ([wrap-with-proj (λ (ctc stx) ;; If contract coersion ends up being a large overhead, we can @@ -30,21 +69,33 @@ #,stx)))]) (if ctc #`(cons - (λ () - (let* ([old-v - #,(if sig-ctc - #`(let ([old-v/c ((car #,vref))]) - (cons #,(wrap-with-proj ctc #'(car old-v/c)) - (cdr old-v/c))) - (wrap-with-proj ctc #`((car #,vref))))]) - old-v)) - (λ (v) - (let* ([new-v - #,(if sig-ctc - #`(cons #,(wrap-with-proj ctc #'(car v)) - (cdr v)) - (wrap-with-proj ctc #'v))]) - ((cdr #,vref) new-v)))) + #,(if import? + #`(car #,vref) + #`(λ () + (let* ([old-v + #,(if sig-ctc + #`(let ([old-v/c ((car #,vref))]) + (cons #,(wrap-with-proj + ctc + #`(contract #,sig-ctc (car old-v/c) + (cdr old-v/c) #,pos + #,(id->contract-src-info var))) + #,neg)) + (wrap-with-proj ctc #`((car #,vref))))]) + old-v))) + #,(if import? + #`(λ (v) + (let* ([new-v + #,(if sig-ctc + #`(cons #,(wrap-with-proj + ctc + #`(contract #,sig-ctc (car v) + (cdr v) #,neg + #,(id->contract-src-info var))) + #,pos) + (wrap-with-proj ctc #'v))]) + ((cdr #,vref) new-v))) + #`(cdr #,vref))) vref))) (for ([tagged-info (in-list import-tagged-infos)] [sig (in-list import-sigs)]) @@ -60,16 +111,13 @@ (get-member-bindings def-table target-sig pos)]) (for/list ([target-int/ext-name (in-list (car target-sig))] [sig-ctc (in-list (cadddr target-sig))]) - (let* ([vref - (bound-identifier-mapping-get - def-table - (car target-int/ext-name))] + (let* ([var (car target-int/ext-name)] + [vref + (bound-identifier-mapping-get def-table var)] [ctc (bound-identifier-mapping-get - ctc-table - (car target-int/ext-name) - (λ () #f))]) - (convert-reference vref ctc sig-ctc rename-bindings)))))) + ctc-table var (λ () #f))]) + (convert-reference var vref ctc sig-ctc rename-bindings)))))) (((export-keys ...) ...) (map tagged-info->keys import-tagged-infos))) #'(unit-export ((export-keys ...) @@ -78,9 +126,9 @@ (define-for-syntax contract-imports (contract-imports/exports #t)) (define-for-syntax contract-exports (contract-imports/exports #f)) -(define-syntax/err-param (unit/c stx) +(define-for-syntax (unit/c/core stx) (syntax-parse stx - [(_ :import-clause :export-clause) + [(:import-clause/c :export-clause/c) (begin (define-values (isig tagged-import-sigs import-tagged-infos import-tagged-sigids import-sigs) @@ -97,17 +145,15 @@ (define xs-list (syntax->list xs)) (let ([dup (check-duplicate-identifier xs-list)]) (when dup - (raise-syntax-error 'unit/c - (format "duplicate identifier found for signature ~a" - (syntax->datum name)) - dup))) + (raise-stx-err (format "duplicate identifier found for signature ~a" + (syntax->datum name)) + dup))) (let ([ids (map car (car sig))]) (for-each (λ (id) (unless (memf (λ (i) (bound-identifier=? id i)) ids) - (raise-syntax-error 'unit/c - (format "identifier not member of signature ~a" - (syntax-e name)) - id))) + (raise-stx-err (format "identifier not member of signature ~a" + (syntax-e name)) + id))) xs-list)) (for ([x (in-list xs-list)] [c (in-list (syntax->list cs))]) @@ -130,7 +176,9 @@ (syntax->list #'((e.x ...) ...)) (syntax->list #'((e.c ...) ...))) - (with-syntax ([((import-key ...) ...) + (with-syntax ([(isig ...) isig] + [(esig ...) esig] + [((import-key ...) ...) (map tagged-info->keys import-tagged-infos)] [((export-key ...) ...) (map tagged-info->keys export-tagged-infos)] @@ -210,6 +258,11 @@ (list #f "not-used") 'not-used null)) #t)))))))])) +(define-syntax/err-param (unit/c stx) + (syntax-case stx () + [(_ . sstx) + (unit/c/core #'sstx)])) + (define (contract-check-helper sub-sig super-sig import? val src-info blame ctc) (define t (make-hash)) (let loop ([i (sub1 (vector-length sub-sig))]) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 3c1720252a..95f2bced3a 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1,11 +1,13 @@ (module unit mzscheme (require-for-syntax mzlib/list + stxclass syntax/boundmap syntax/context syntax/kerncase syntax/name syntax/struct syntax/stx + "private/unit-contract-syntax.ss" "private/unit-compiletime.ss" "private/unit-syntax.ss") @@ -20,14 +22,15 @@ (provide define-signature-form struct open define-signature provide-signature-elements only except rename import export prefix link tag init-depend extends contracted - unit? (all-from "private/unit-contract.ss") + unit? (rename :unit unit) define-unit compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer invoke-unit define-values/invoke-unit invoke-unit/infer define-values/invoke-unit/infer unit-from-context define-unit-from-context define-unit-binding - unit/new-import-export define-unit/new-import-export) + unit/new-import-export define-unit/new-import-export + unit/c define-unit/contract) (define-syntax/err-param (define-signature-form stx) (syntax-case stx () @@ -1148,10 +1151,19 @@ (dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs)))) (out-vec (generate-temporaries out-sigs)) (tmarker (make-syntax-introducer)) - (vmarker (make-syntax-introducer)) - (tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs))) + (tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)) + (def-table (make-bound-identifier-mapping))) (when dup (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) + (for-each + (λ (sig new-xs) + (for-each + (λ (old new) + (bound-identifier-mapping-put! def-table old new)) + (map car (car sig)) + new-xs)) + out-sigs + tmp-bindings) (with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags)) ((((int-binding . ext-binding) ...) ...) (map car out-sigs)) ((out-vec ...) out-vec) @@ -1164,34 +1176,26 @@ (map (lambda (info) (car (siginfo-names (cdr info)))) out-tags)) (((tmp-binding ...) ...) tmp-bindings) - (((val-binding ...) ...) (map (λ (s) (map vmarker (map car (car s)))) out-sigs)) (((out-code ...) ...) (map (lambda (os ov) (map (lambda (i) - #`((car (vector-ref #,ov #,i)))) + #`(vector-ref #,ov #,i)) (iota (length (car os))))) out-sigs out-vec)) - (((val-code ...) ...) - (map (λ (tbs os) - (map (λ (tb c) - (if c - #`(car #,tb) - tb)) - tbs - (cadddr os))) - tmp-bindings - out-sigs)) (((wrap-code ...) ...) (map (λ (os ov tbs) + (define rename-bindings + (get-member-bindings def-table os #'(#%variable-reference))) (map (λ (tb i v c) - (if c - #`(contract #,(vmarker c) (car #,tb) (cdr #,tb) - (current-contract-region) - #,(id->contract-src-info v)) - tb)) + #`(let ([v/c ((car #,tb))]) + #,(if c + #`(contract (letrec-syntax #,rename-bindings #,c) (car v/c) (cdr v/c) + (current-contract-region) + #,(id->contract-src-info v)) + #'v/c))) tbs (iota (length (car os))) (map car (car os)) @@ -1215,8 +1219,6 @@ (let ([out-vec (hash-table-get export-table key1)] ...) (unit-fn #f) (values out-code ... ...)))))) - (define-values (val-binding ... ...) - (values val-code ... ...)) (define-values (int-binding ... ...) (values wrap-code ... ...)) (define-syntaxes . renames) ... @@ -1264,32 +1266,38 @@ + (define-for-syntax (build-define-unit-helper contracted?) + (lambda (stx build err-msg) + (syntax-case stx () + ((_ name . rest) + (begin + (check-id #'name) + (let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))]) + (build #'rest )))) + (with-syntax ((((itag . isig) ...) i) + (((etag . esig) ...) e) + (((deptag . depsig) ...) d) + (contracted? contracted?)) + (quasisyntax/loc (error-syntax) + (begin + (define u #,exp) + (define-syntax name + (make-set!-transformer + (make-unit-info ((syntax-local-certifier) (quote-syntax u)) + (list (cons 'itag (quote-syntax isig)) ...) + (list (cons 'etag (quote-syntax esig)) ...) + (list (cons 'deptag (quote-syntax deptag)) ...) + (quote-syntax name) + contracted?))))))))) + ((_) + (raise-stx-err err-msg))))) + ;; build-define-unit : syntax-object ;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier)) ;; string -> ;; syntax-object - (define-for-syntax (build-define-unit stx build err-msg) - (syntax-case stx () - ((_ name . rest) - (begin - (check-id #'name) - (let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))]) - (build #'rest )))) - (with-syntax ((((itag . isig) ...) i) - (((etag . esig) ...) e) - (((deptag . depsig) ...) d)) - (quasisyntax/loc (error-syntax) - (begin - (define u #,exp) - (define-syntax name - (make-set!-transformer - (make-unit-info ((syntax-local-certifier) (quote-syntax u)) - (list (cons 'itag (quote-syntax isig)) ...) - (list (cons 'etag (quote-syntax esig)) ...) - (list (cons 'deptag (quote-syntax deptag)) ...) - (quote-syntax name)))))))))) - ((_) - (raise-stx-err err-msg)))) + (define-for-syntax build-define-unit (build-define-unit-helper #f)) + (define-for-syntax build-define-unit/contracted (build-define-unit-helper #t)) (define-for-syntax (build-define-unit-binding stx) @@ -1360,6 +1368,46 @@ (check-ufc-syntax sig) (build-unit-from-context sig)) "missing unit name and signature")) + + (define-for-syntax (build-unit/contract stx) + (syntax-parse stx + [(:import-clause/contract :export-clause/contract dep:dep-clause . body) + (let-values ([(exp isigs esigs deps) + (build-unit + (check-unit-syntax + (syntax/loc stx + ((import i.s ...) (export e.s ...) dep . body))))]) + (with-syntax ([name (syntax-local-infer-name (error-syntax))] + [(import-tagged-sig-id ...) + (map (λ (i s) + (if (identifier? i) #`(tag #,i #,s) s)) + (syntax->list #'(i.s.i ...)) + (syntax->list #'(i.s.s.name ...)))] + [(export-tagged-sig-id ...) + (map (λ (i s) + (if (identifier? i) #`(tag #,i #,s) s)) + (syntax->list #'(e.s.i ...)) + (syntax->list #'(e.s.s.name ...)))]) + (with-syntax ([new-unit exp] + [unit-contract + (unit/c/core + (syntax/loc stx + ((import (import-tagged-sig-id [i.x i.c] ...) ...) + (export (export-tagged-sig-id [e.x e.c] ...) ...))))] + [src-info (id->contract-src-info #'name)]) + (values + (syntax/loc stx + (contract unit-contract new-unit '(unit name) (current-contract-region) src-info)) + isigs esigs deps))))] + [(ic:import-clause/contract ec:export-clause/contract . body) + (build-unit/contract + (syntax/loc stx + (ic ec (init-depend) . body)))])) + + (define-syntax/err-param (define-unit/contract stx) + (build-define-unit/contracted stx (λ (stx) + (build-unit/contract stx)) + "missing unit name")) (define-for-syntax (unprocess-tagged-id ti) (if (car ti) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index b64902d978..651b51c14c 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "14feb2009") +#lang scheme/base (provide stamp) (define stamp "15feb2009") diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index b62c4be140..15f476b2fb 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -442,6 +442,37 @@ improve method arity mismatch contract violation error messages? [(_ p/c-ele ...) (let () + ;; ids : table[id -o> (listof id)] + ;; code-for-each-clause adds identifiers to this map. + ;; when it binds things; they are then used to signal + ;; a syntax error for duplicates + (define dups-table (make-hash)) + (define (add-to-dups-table id) + (hash-update! + dups-table + (syntax-e id) + (λ (ids) (cons id ids)) + '())) + (define (signal-dup-syntax-error) + (hash-for-each + dups-table + (λ (k ids) + (let loop ([ids ids]) + (cond + [(null? ids) (void)] + [else + (cond + [(ormap (λ (x) (bound-identifier=? (car ids) x)) (cdr ids)) + (let ([dups (filter (λ (x) (bound-identifier=? (car ids) x)) + ids)]) + (raise-syntax-error 'provide/contract + "duplicate identifiers" + provide-stx + (car dups) + (cdr dups)))] + [else + (loop (cdr ids))])]))))) + ;; code-for-each-clause : (listof syntax) -> (listof syntax) ;; constructs code for each clause of a provide/contract (define (code-for-each-clause clauses) @@ -454,8 +485,10 @@ improve method arity mismatch contract violation error messages? [(rename this-name new-name contract) (and (identifier? (syntax this-name)) (identifier? (syntax new-name))) - (cons (code-for-one-id provide-stx (syntax this-name) (syntax contract) (syntax new-name)) - (code-for-each-clause (cdr clauses)))] + (begin + (add-to-dups-table #'new-name) + (cons (code-for-one-id provide-stx (syntax this-name) (syntax contract) (syntax new-name)) + (code-for-each-clause (cdr clauses))))] [(rename this-name new-name contract) (identifier? (syntax this-name)) (raise-syntax-error 'provide/contract @@ -477,6 +510,7 @@ improve method arity mismatch contract violation error messages? (syntax struct-name) (syntax->list (syntax (field-name ...))) (syntax->list (syntax (contract ...))))]) + (add-to-dups-table #'struct-name) (cons sc (code-for-each-clause (cdr clauses))))] [(struct name) (identifier? (syntax name)) @@ -516,8 +550,10 @@ improve method arity mismatch contract violation error messages? clause)] [(name contract) (identifier? (syntax name)) - (cons (code-for-one-id provide-stx (syntax name) (syntax contract) #f) - (code-for-each-clause (cdr clauses)))] + (begin + (add-to-dups-table #'name) + (cons (code-for-one-id provide-stx (syntax name) (syntax contract) #f) + (code-for-each-clause (cdr clauses))))] [(name contract) (raise-syntax-error 'provide/contract "expected identifier" @@ -935,6 +971,7 @@ improve method arity mismatch contract violation error messages? (syntax (code id-rename)))))])) (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) + (signal-dup-syntax-error) (syntax (begin bodies ...))))])) diff --git a/collects/scribblings/guide/info.ss b/collects/scribblings/guide/info.ss index 75a56e7705..c4531297a3 100644 --- a/collects/scribblings/guide/info.ss +++ b/collects/scribblings/guide/info.ss @@ -1,5 +1,5 @@ #lang setup/infotab -(define scribblings '(("guide.scrbl" (multi-page) (getting-started)))) +(define scribblings '(("guide.scrbl" (multi-page) (getting-started -10)))) (define compile-omit-paths '("contracts-examples")) diff --git a/collects/scribblings/guide/unit.scrbl b/collects/scribblings/guide/unit.scrbl index 723b02fae1..e19dec8598 100644 --- a/collects/scribblings/guide/unit.scrbl +++ b/collects/scribblings/guide/unit.scrbl @@ -530,85 +530,49 @@ causes the appropriate contract errors. However, sometimes we may have a unit that must conform to an already existing signature that is not contracted. In this case, -we can use the @scheme[unit/c] contract combinator, which creates -a new unit that protects parts of the wrapped unit as desired. +we can create a unit contract with @scheme[unit/c] or use +the @scheme[define-unit/contract] form, which defines a unit which +has been wrapped with a unit contract. -For example, here's a version of @scheme[toy-store@] which has a -slightly buggy implementation of the uncontracted @scheme[toy-store^] -signature. When we provide the new @scheme[wrapped-toy-store@] unit, -we protect its exports. +For example, here's a version of @scheme[toy-factory@] which still +implements the regular @scheme[toy-factory^], but whose exports +have been protected with an appropriate unit contract. @schememod/eval[[#:file -"wrapped-toy-store-unit.ss" +"wrapped-simple-factory-unit.ss" scheme -(require "toy-store-sig.ss" - "toy-factory-sig.ss")] +(require "toy-factory-sig.ss")] -(define-unit wrapped-toy-store@ - (import toy-factory^) - (export toy-store^) +(define-unit/contract wrapped-simple-factory@ + (import) + (export (toy-factory^ + [build-toys (-> integer? (listof toy?))] + [repaint (-> toy? symbol? toy?)] + [toy? (-> any/c boolean?)] + [toy-color (-> toy? symbol?)])) - (define inventory null) + (printf "Factory started.\n") - (define (store-color) 3) (code:comment #, @t{Not a valid color!}) + (define-struct toy (color) #:transparent) - (define (maybe-repaint t) - (if (eq? (toy-color t) (store-color)) - t - (repaint t (store-color)))) + (define (build-toys n) + (for/list ([i (in-range n)]) + (make-toy 'blue))) - (define (stock! n) - (set! inventory - (append inventory - (map maybe-repaint - (build-toys n))))) + (define (repaint t col) + (make-toy col))) - (define (get-inventory) inventory)) - -(provide/contract - [wrapped-toy-store@ - (unit/c (import toy-factory^) - (export (toy-store^ - [store-color (-> symbol?)] - [stock! (-> integer? void?)] - [get-inventory (-> (listof toy?))])))]) +(provide contracted-simple-factory@) ] -Since the result of the @scheme[unit/c] combinator is a new unit value -which has not been defined with @scheme[define-unit] or another similar -form, we run into problems with signature inference. The section -@secref{firstclassunits} lists options that we can use to handle the -resulting values. - @interaction[ #:eval toy-eval -(eval:alts (require "wrapped-toy-store-unit.ss") - (define wrapped-toy-store@ - (contract (unit/c (import toy-factory^) - (export (toy-store^ - [store-color (-> symbol?)] - [stock! (-> integer? void?)] - [get-inventory (-> (listof toy?))]))) - wrapped-toy-store@ - 'wrapped-toy-store-unit - 'top-level - (list (make-srcloc 'top-level #f #f #f #f) "wrapped-toy-store@")))) -(define-unit-binding protected-toy-store@ - wrapped-toy-store@ - (import toy-factory^) - (export toy-store^)) -(define-compound-unit/infer checked-toy-store+factory@ - (import) - (export toy-factory^ toy-store^) - (link store-specific-factory@ protected-toy-store@)) -(define-values/invoke-unit/infer checked-toy-store+factory@) -(store-color) -(stock! 'a) -(code:comment #, @t{This fails because of the factory's (store-color) call}) -(stock! 4) -(code:comment #, @t{Since it failed, there's no inventory}) -(get-inventory) +(eval:alts (require "wrapped-simple-factory-unit.ss") (void)) +(define-values/invoke-unit/infer wrapped-simple-factory@) +(build-toys 3) +(build-toys #f) +(repaint 3 'blue) ] diff --git a/collects/scribblings/main/config.ss b/collects/scribblings/main/config.ss index fc404e023a..c9a169f2c6 100644 --- a/collects/scribblings/main/config.ss +++ b/collects/scribblings/main/config.ss @@ -26,7 +26,7 @@ ;; Section definitions for manuals that appear on the start page. (define manual-sections - '((getting-started "Getting Started") + '((getting-started (link "Getting Started" (lib "scribblings/main/getting-started.scrbl"))) (language "Languages") (tool "Tools") (gui-library "GUI and Graphics Libraries") diff --git a/collects/scribblings/main/getting-started.scrbl b/collects/scribblings/main/getting-started.scrbl new file mode 100644 index 0000000000..0e2c2a4ace --- /dev/null +++ b/collects/scribblings/main/getting-started.scrbl @@ -0,0 +1,44 @@ +#lang scribble/doc +@(require scribble/manual) + +@title{Getting Started with PLT Scheme} + +If you are new to programming or if you have the patience to work +through a textbook: + +@itemize[ + + @item{@italic{@link["http:///www.htdp.org/"]{How to + Design Programs}} is the best place to start.} + + @item{@other-manual['(lib "web-server/scribblings/tutorial/continue.scrbl")] + introduces you to the Module language and building web applications.} + + @item{@other-manual['(lib "scribblings/guide/guide.scrbl")] describes + the rest of the PLT Scheme language, which is much bigger than + the learning-oriented languages of the textbook. Since you + learned functional programming from the textbook, you'll be + able to skim chapters 1 and 2 of the Guide.} + +] + + +If you're already a programmer and you're in more of a hurry: + +@itemize[ + + @item{@other-manual['(lib "scribblings/quick/quick.scrbl")] gives you + a taste of PLT Scheme.} + + @item{@other-manual['(lib "scribblings/more/more.scrbl")] dives much + deeper and much faster. If it's too much, just skip to the + Guide.} + + @item{@other-manual['(lib "scribblings/guide/guide.scrbl")] starts + with a tutorial on Scheme based, and then it describes the rest + of the PLT Scheme language.} + +] + +Of course, you should feel free to mix and match the above two tracks, +since there is information in each that is not in the other. diff --git a/collects/scribblings/main/info.ss b/collects/scribblings/main/info.ss index bb178dfcb0..28faa2f7d1 100644 --- a/collects/scribblings/main/info.ss +++ b/collects/scribblings/main/info.ss @@ -9,6 +9,7 @@ ("master-index.scrbl" (depends-all-main no-depend-on) (omit)) ("user/search.scrbl" (user-doc depends-all no-depend-on) (omit)) ("user/master-index.scrbl" (user-doc depends-all no-depend-on) (omit)) + ("getting-started.scrbl" () (omit)) ("license.scrbl" () (omit)) ("acks.scrbl" () (omit)) ("release.scrbl" () (omit)))) diff --git a/collects/scribblings/main/private/manuals.ss b/collects/scribblings/main/private/manuals.ss index 9de7f40659..4c5b02600e 100644 --- a/collects/scribblings/main/private/manuals.ss +++ b/collects/scribblings/main/private/manuals.ss @@ -80,12 +80,29 @@ s))) infos recs)] + [docs (cons + ;; Add HtDP + (list + ;; Category + 'getting-started + ;; Priority + 7 + ;; Priority label (not used): + "" + ;; Path + '(url "http://www.htdp.org/") + ;; Spec + (italic (link #:underline? #f "http://www.htdp.org/" "How to Design Programs"))) + docs)] [plain-line (lambda content (list (make-flow (list (make-paragraph content)))))] [line (lambda (spec) - (plain-line (hspace 2) (other-manual spec #:underline? #f)))]) + (plain-line (hspace 2) + (if (element? spec) + spec + (other-manual spec #:underline? #f))))]) (define (contents renderer part resolve-info) (make-table #f @@ -96,7 +113,10 @@ docs)]) (list* (plain-line (hspace 1)) - (plain-line (sec-label sec)) + (plain-line (let ([s (sec-label sec)]) + (if (and (list? s) (eq? 'link (car s))) + (seclink "top" #:doc (caddr s) #:underline? #f (cadr s)) + s))) (add-sections (sec-cat sec) (lambda (str) diff --git a/collects/scribblings/more/info.ss b/collects/scribblings/more/info.ss index d711129f4a..56d87e0160 100644 --- a/collects/scribblings/more/info.ss +++ b/collects/scribblings/more/info.ss @@ -1,3 +1,3 @@ #lang setup/infotab -(define scribblings '(("more.scrbl" () (getting-started 5)))) +(define scribblings '(("more.scrbl" () (getting-started 3)))) diff --git a/collects/scribblings/quick/quick.scrbl b/collects/scribblings/quick/quick.scrbl index 0f589a42a0..40203b2090 100644 --- a/collects/scribblings/quick/quick.scrbl +++ b/collects/scribblings/quick/quick.scrbl @@ -582,9 +582,16 @@ threads. That is, instead of a ``minimalist'' language---which is the way that Scheme is often described---PLT Scheme offers a rich language with an extensive set of libraries and tools. -To continue touring PLT Scheme, but from a systems-oriented -perspective instead of pictures, your next stop is @other-manual['(lib -"scribblings/more/more.scrbl")]. +If you are new to programming or if you have the patience to work +through a textbook, we recommend reading +@italic{@link["http://www.htdp.org/"]{How to Design Programs}}. If you +have already read it, or if you want to see where the book will take +you, then see @other-manual['(lib +"web-server/scribblings/tutorial/continue.scrbl")]. + +For experienced programmers, to continue touring PLT Scheme from a +systems-oriented perspective instead of pictures, your next stop is +@other-manual['(lib "scribblings/more/more.scrbl")]. To instead start learning about the full PLT Scheme language and tools in depth, move on to @other-manual['(lib "guide.scrbl" diff --git a/collects/scribblings/reference/exns.scrbl b/collects/scribblings/reference/exns.scrbl index 37a1879cac..81e20b596b 100644 --- a/collects/scribblings/reference/exns.scrbl +++ b/collects/scribblings/reference/exns.scrbl @@ -150,21 +150,24 @@ is provided; it is described in more detail below. The @scheme[message] is used as the main body of the error message. The optional @scheme[expr] argument is the erroneous source syntax -object or S-expression. The optional @scheme[sub-expr] argument is a -syntax object or S-expression within @scheme[expr] that more precisely -locates the error. Both may appear in the generated error-message -text if @scheme[error-print-source-location] is @scheme[#t]. Source -location information in the error-message text is similarly extracted -from @scheme[sub-expr] or @scheme[expr] when at least one is a syntax +object or S-expression (but the expression @scheme[#f] cannot be +represented by itself; it must be wrapped as a @tech{syntax +object}). The optional @scheme[sub-expr] argument is a syntax object +or S-expression (again, @scheme[#f] cannot represent itself) within +@scheme[expr] that more precisely locates the error. Both may appear +in the generated error-message text if +@scheme[error-print-source-location] is @scheme[#t]. Source location +information in the error-message text is similarly extracted from +@scheme[sub-expr] or @scheme[expr] when at least one is a syntax object and @scheme[error-print-source-location] is @scheme[#t]. -If @scheme[sub-expr] is provided, it is used (in syntax form) for the -@scheme[exprs] field of the generated exception record, else the -@scheme[expr] is used if provided. In either case, the syntax object -is @scheme[cons]ed onto @scheme[extra-sources] to produce the -@scheme[exprs] field, or @scheme[extra-sources] is used directly for -@scheme[exprs] if neither @scheme[expr] nor @scheme[sub-expr] is -provided. +If @scheme[sub-expr] is provided and not @scheme[#f], it is used (in +syntax form) for the @scheme[exprs] field of the generated exception +record, else the @scheme[expr] is used if provided and not +@scheme[#f]. In either case, the syntax object is @scheme[cons]ed onto +@scheme[extra-sources] to produce the @scheme[exprs] field, or +@scheme[extra-sources] is used directly for @scheme[exprs] if neither +@scheme[expr] nor @scheme[sub-expr] is provided and not @scheme[#f]. The form name used in the generated error message is determined through a combination of the @scheme[name], @scheme[expr], and diff --git a/collects/scribblings/reference/hashes.scrbl b/collects/scribblings/reference/hashes.scrbl index 42330cdeff..18c7c9daef 100644 --- a/collects/scribblings/reference/hashes.scrbl +++ b/collects/scribblings/reference/hashes.scrbl @@ -3,6 +3,18 @@ @title[#:tag "hashtables"]{Hash Tables} +@(define (concurrency-caveat) + @elemref['(caveat "concurrency")]{caveats concerning concurrent modification}) +@(define (mutable-key-caveat) + @elemref['(caveat "mutable-keys")]{caveat concerning mutable keys}) + +@(define (see-also-caveats) + @t{See also the @concurrency-caveat[] and the @mutable-key-caveat[] above.}) +@(define (see-also-concurrency-caveat) + @t{See also the @concurrency-caveat[] above.}) +@(define (see-also-mutable-key-caveat) + @t{See also the @mutable-key-caveat[] above.}) + @guideintro["hash-tables"]{hash tables} A @deftech{hash table} (or simply @deftech{hash}) maps each of its @@ -26,18 +38,18 @@ key-comparison procedure (@scheme[equal?], @scheme[eqv?], or @scheme[eq?]), both hold keys strongly or weakly, and have the same mutability. -@bold{Caveats concerning concurrent modification:} A mutable hash -table can be manipulated with @scheme[hash-ref], @scheme[hash-set!], -and @scheme[hash-remove!] concurrently by multiple threads, and the -operations are protected by a table-specific semaphore as needed. Three -caveats apply, however: +@elemtag['(caveat "concurrency")]{@bold{Caveats concerning concurrent +modification:}} A mutable hash table can be manipulated with +@scheme[hash-ref], @scheme[hash-set!], and @scheme[hash-remove!] +concurrently by multiple threads, and the operations are protected by +a table-specific semaphore as needed. Three caveats apply, however: @itemize{ @item{If a thread is terminated while applying @scheme[hash-ref], @scheme[hash-set!], or @scheme[hash-remove!] to a hash table that - uses @scheme[equal?] key comparisons, all current and future - operations on the hash table block indefinitely.} + uses @scheme[equal?] or @scheme[eqv?] key comparisons, all current + and future operations on the hash table block indefinitely.} @item{The @scheme[hash-map] and @scheme[hash-for-each] procedures do not use the table's semaphore. Consequently, if a hash table is @@ -58,10 +70,11 @@ caveats apply, however: } -@bold{Caveat concerning mutable keys:} If a key into an -@scheme[equal?]-based hash table is mutated (e.g., a key string is -modified with @scheme[string-set!]), then the hash table's behavior -for insertion and lookup operations becomes unpredictable. +@elemtag['(caveat "mutable-keys")]{@bold{Caveat concerning mutable +keys:}} If a key in an @scheme[equal?]-based hash table is mutated +(e.g., a key string is modified with @scheme[string-set!]), then the +hash table's behavior for insertion and lookup operations becomes +unpredictable. @defproc[(hash? [v any/c]) boolean?]{ @@ -152,7 +165,9 @@ compares keys with @scheme[eq?].} [v any/c]) void?]{ Maps @scheme[key] to @scheme[v] in @scheme[hash], overwriting -any existing mapping for @scheme[key].} +any existing mapping for @scheme[key]. + +@see-also-caveats[]} @defproc[(hash-set [hash (and/c hash? immutable?)] @@ -162,7 +177,9 @@ any existing mapping for @scheme[key].} Functionally extends @scheme[hash] by mapping @scheme[key] to @scheme[v], overwriting any existing mapping for @scheme[key], and -returning the extended hash table.} +returning the extended hash table. + +@see-also-mutable-key-caveat[]} @defproc[(hash-ref [hash hash?] @@ -182,7 +199,9 @@ result: @item{Otherwise, @scheme[failure-result] is returned as the result.} -}} +} + +@see-also-caveats[]} @defproc[(hash-update! [hash (and/c hash? (not/c immutable?))] @@ -196,7 +215,9 @@ Composes @scheme[hash-ref] and @scheme[hash-set!] to update an existing mapping in @scheme[hash], where the optional @scheme[failure-result] argument is used as in @scheme[hash-ref] when no mapping exists for @scheme[key] already. See the caveat above about -concurrent updates.} +concurrent updates. + +@see-also-caveats[]} @defproc[(hash-update [hash (and/c hash? immutable?)] @@ -209,14 +230,18 @@ concurrent updates.} Composes @scheme[hash-ref] and @scheme[hash-set] to functionally update an existing mapping in @scheme[hash], where the optional @scheme[failure-result] argument is used as in @scheme[hash-ref] when -no mapping exists for @scheme[key] already.} +no mapping exists for @scheme[key] already. + +@see-also-mutable-key-caveat[]} @defproc[(hash-remove! [hash (and/c hash? (not/c immutable?))] [key any/c]) void?]{ -Removes any existing mapping for @scheme[key] in @scheme[hash].} +Removes any existing mapping for @scheme[key] in @scheme[hash]. + +@see-also-caveats[]} @defproc[(hash-remove [hash (and/c hash? immutable?)] @@ -224,7 +249,9 @@ Removes any existing mapping for @scheme[key] in @scheme[hash].} (and/c hash? immutable?)]{ Functionally removes any existing mapping for @scheme[key] in -@scheme[hash], returning the fresh hash table.} +@scheme[hash], returning the fresh hash table. + +@see-also-mutable-key-caveat[]} @defproc[(hash-map [hash hash?] @@ -235,7 +262,9 @@ Applies the procedure @scheme[proc] to each element in @scheme[hash] in an unspecified order, accumulating the results into a list. The procedure @scheme[proc] is called each time with a key and its value. See the caveat above about concurrent -modification.} +modification. + +@see-also-concurrency-caveat[]} @defproc[(hash-for-each [hash hash?] @@ -245,17 +274,18 @@ modification.} Applies @scheme[proc] to each element in @scheme[hash] (for the side-effects of @scheme[proc]) in an unspecified order. The procedure @scheme[proc] is called each time with a key and its value. See the -caveat above about concurrent modification.} +caveat above about concurrent modification. + +@see-also-concurrency-caveat[]} @defproc[(hash-count [hash hash?]) exact-nonnegative-integer?]{ -Returns the number of keys mapped by @scheme[hash]. If -@scheme[hash] is not created with @scheme['weak], then the -result is computed in constant time and atomically. If -@scheme[hash] is created with @scheme['weak], see the caveat -above about concurrent modification.} +Returns the number of keys mapped by @scheme[hash]. If @scheme[hash] +is not created with @scheme['weak], then the result is computed in +constant time and atomically. If @scheme[hash] is created with +@scheme['weak], see the @concurrency-caveat[] above.} @defproc[(hash-iterate-first [hash hash?]) @@ -311,24 +341,24 @@ key-comparison mode, and same key-holding strength as @scheme[hash].} Returns an exact integer; for any two @scheme[eq?] values, the returned integer is the same. Furthermore, for the result integer -@scheme[k] and any other exact integer @scheme[j], @scheme[(= k j)] -implies @scheme[(eq? k j)].} +@scheme[_k] and any other exact integer @scheme[_j], @scheme[(= _k _j)] +implies @scheme[(eq? _k _j)].} @defproc[(eqv-hash-code [v any/c]) exact-integer?]{ Returns an exact integer; for any two @scheme[eqv?] values, the returned integer is the same. Furthermore, for the result integer -@scheme[k] and any other exact integer @scheme[j], @scheme[(= k j)] -implies @scheme[(eq? k j)].} +@scheme[_k] and any other exact integer @scheme[_j], @scheme[(= _k _j)] +implies @scheme[(eq? _k _j)].} @defproc[(equal-hash-code [v any/c]) exact-integer?]{ Returns an exact integer; for any two @scheme[equal?] values, the returned integer is the same. Furthermore, for the result integer -@scheme[k] and any other exact integer @scheme[j], @scheme[(= k j)] -implies @scheme[(eq? k j)]. A has code is computed even when +@scheme[_k] and any other exact integer @scheme[_j], @scheme[(= _k _j)] +implies @scheme[(eq? _k _j)]. A has code is computed even when @scheme[v] contains a cycle through pairs, vectors, boxes, and/or inspectable structure fields. See also @scheme[prop:equal+hash].} diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index 2d3e585712..5ff110a198 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -635,8 +635,8 @@ Expands to a @scheme[provide] of all identifiers implied by the @defform/subs[#:literals (import export) (unit/c (import sig-block ...) (export sig-block ...)) - ([sig-block (tagged-sig-spec [id contract] ...) - tagged-sig-spec])]{ + ([sig-block (tagged-sig-id [id contract] ...) + tagged-sig-id])]{ A @deftech{unit contract} wraps a unit and checks both its imported and exported identifiers to ensure that they match the appropriate contracts. @@ -649,6 +649,20 @@ identifier which is not listed for a given signature is left alone. Variables used in a given @scheme[contract] expression first refer to other variables in the same signature, and then to the context of the @scheme[unit/c] expression.} + +@defform/subs[#:literals (import export) + (define-unit/contract unit-id + (import sig-spec-block ...) + (export sig-spec-block ...) + init-depends-decl + unit-body-expr-or-defn + ...) + ([sig-spec-block (tagged-sig-spec [id contract] ...) + tagged-sig-spec])]{ +The @scheme[define-unit/contract] form defines an unit compatible with +link inference whose imports and exports are contracted with a unit +contract. The unit name is used for the positive blame of the contract.} + @; ------------------------------------------------------------------------ diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 137629680e..a64bcff87f 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -906,41 +906,41 @@ Understanding the server's event handling functions demands several data data representation of the @tech{world}s that participate in the universe. -@defproc[(world? [x any/c]) boolean?]{ - determines whether @scheme[x] is a @emph{world}. Because the universe server +@defproc[(iworld? [x any/c]) boolean?]{ + determines whether @scheme[x] is a @emph{iworld}. Because the universe server represents worlds via structures that collect essential information about the connections, the teachpack does not export any constructor or selector functions on worlds.} -@defproc[(world=? [u world?][v world?]) boolean?]{ - compares two @emph{world}s for equality.} +@defproc[(iworld=? [u iworld?][v iworld?]) boolean?]{ + compares two @emph{iworld}s for equality.} -@defproc[(world-name [w world?]) symbol?]{ - extracts the name from a @emph{world} structure.} +@defproc[(iworld-name [w iworld?]) symbol?]{ + extracts the name from a @emph{iworld} structure.} -@defthing[world1 world?]{a world for testing your programs} -@defthing[world2 world?]{another world for testing your programs} -@defthing[world3 world?]{and a third one} +@defthing[iworld1 iworld?]{an @emph{iworld} for testing your programs} +@defthing[iworld2 iworld?]{another iworld for testing your programs} +@defthing[iworld3 iworld?]{and a third one} -The three sample worlds are provided so that you can test your functions +The three sample iworlds are provided so that you can test your functions for universe programs. For example: @schemeblock[ -(check-expect (world=? world1 world2) false) -(check-expect (world=? world2 world2) true) +(check-expect (iworld=? iworld1 iworld2) false) +(check-expect (iworld=? iworld2 iworld2) true) ] } @item{Each event handler produces a @emph{bundle}, which is a structure - that contains the list of @emph{world}s to keep track of; the + that contains the list of @emph{iworld}s to keep track of; the @tech{server}'s remaining state; and a list of mails to other worlds: @defproc[(bundle? [x any/c]) boolean?]{ determines whether @scheme[x] is a @emph{bundle}.} -@defproc[(make-bundle [low (listof world?)] [state any/c] [mails (listof mail?)]) bundle?]{ - creates a @emph{bundle} from a list of worlds, a piece of data that represents a server +@defproc[(make-bundle [low (listof iworld?)] [state any/c] [mails (listof mail?)]) bundle?]{ + creates a @emph{bundle} from a list of iworlds, a piece of data that represents a server state, and a list of mails.} A @emph{mail} represents a message from an event handler to a world. The @@ -949,8 +949,8 @@ teachpack provides only a predicate and a constructor for these structures: @defproc[(mail? [x any/c]) boolean?]{ determines whether @scheme[x] is a @emph{mail}.} -@defproc[(make-mail [to world?] [content sexp?]) mail?]{ - creates a @emph{mail} from a @emph{world} and an @tech{S-expression}.} +@defproc[(make-mail [to iworld?] [content sexp?]) mail?]{ + creates a @emph{mail} from a @emph{iworld} and an @tech{S-expression}.} } ] @@ -977,8 +977,7 @@ The @tech{server} itself is created with a description that includes the @defform/subs[#:id universe #:literals - (start stop max-worlds on-new on-msg on-tick - on-disconnect to-string) + (on-new on-msg on-tick on-disconnect to-string) (universe state-expr clause ...) ([clause (on-new new-expr) @@ -1012,10 +1011,10 @@ The mandatory clauses of a @scheme[universe] server description are @item{ @defform[(on-new new-expr) #:contracts - ([new-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? bundle?)])]{ + ([new-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) iworld? bundle?)])]{ tell DrScheme to call the function @scheme[new-expr] every time another world joins the - universe. The event handler is called on the current list of worlds and the - joining world, which isn't on the list yet. In particular, the handler may + universe. The event handler is called on the current list of iworlds and the + joining iworld, which isn't on the list yet. In particular, the handler may reject a @tech{world} program from participating in a @tech{universe}, simply by not including it in the resulting @scheme[bundle] structure. The handler may still send one message to the world that attempts to join. } @@ -1024,7 +1023,7 @@ The mandatory clauses of a @scheme[universe] server description are @item{ @defform[(on-msg msg-expr) #:contracts - ([msg-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? sexp? bundle?)])]{ + ([msg-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) iworld? sexp? bundle?)])]{ tell DrScheme to apply @scheme[msg-expr] to the list of currently participating worlds @scheme[low], the current state of the universe, the world @@ -1055,7 +1054,7 @@ optional handlers: @item{ @defform/none[(on-tick tick-expr) #:contracts - ([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)])]{ + ([tick-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) bundle?)])]{ tell DrScheme to apply @scheme[tick-expr] to the current list of participating worlds and the current state of the universe. @@ -1063,7 +1062,7 @@ optional handlers: @defform/none[(on-tick tick-expr rate-expr) #:contracts - ([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)] + ([tick-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) bundle?)] [rate-expr natural-number/c])]{ tell DrScheme to apply @scheme[tick-expr] as above but use the specified clock tick rate instead of the default. @@ -1074,7 +1073,7 @@ optional handlers: @item{ @defform[(on-disconnect dis-expr) #:contracts - ([dis-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? bundle?)])]{ + ([dis-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) iworld? bundle?)])]{ tell DrScheme to invoke @scheme[dis-expr] every time a participating @tech{world} drops its connection to the server. The first two arguments are the current list of participating worlds and the state of the @@ -1085,7 +1084,7 @@ optional handlers: @item{ @defform[(to-string render-expr) #:contracts - ([render-expr (-> [listof world?] (unsyntax @tech{UniverseState}) string?)])]{ + ([render-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) string?)])]{ tell DrScheme to render the state of the universe after each event and to display this string in the universe console. } @@ -1212,14 +1211,14 @@ translates into the design of two functions with the following headers, #reader scribble/comment-reader (schemeblock ;; Bundle is -;; (make-bundle [Listof world?] UniverseState [Listof mail?]) +;; (make-bundle [Listof iworld?] UniverseState [Listof mail?]) -;; [Listof world?] UniverseState world? -> Bundle +;; [Listof iworld?] UniverseState iworld? -> Bundle ;; compute next list of worlds and new @tech{UniverseState} ;; when world w is joining the universe, which is in state s; (define (add-world s w) ...) -;; [Listof world?] UniverseState world? W2U -> Bundle +;; [Listof iworld?] UniverseState iworld? W2U -> Bundle ;; compute next list of worlds and new @tech{UniverseState} ;; when world w is sending message m to universe in state s (define (process s p m) ...) @@ -1245,27 +1244,27 @@ As for the server's state, it must obviously keep track of all @tech{world}s tha no @tech{world}s and, at that point, the server has nothing to track. While there are many different useful ways of representing such a - @tech{universe}, we just use the list of @emph{worlds} that is handed to + @tech{universe}, we just use the list of @emph{iworlds} that is handed to each handler and that handlers return via their bundles. The @tech{UniverseState} itself is useless for this trivial example. We - interpret non-empty lists as those where the first @tech{world} is active - and the remainder are the passive @tech{world}s. As for the two possible + interpret non-empty lists as those where the first @emph{iworld} is active + and the remainder are the passive @emph{iworld}s. As for the two possible events, @itemize[ -@item{it is natural to add new @tech{world}s to the end of the list; and} +@item{it is natural to add new @emph{iworld}s to the end of the list; and} -@item{it is natural to move an active @tech{world} that relinquishes its turn to +@item{it is natural to move an active @emph{iworld} that relinquishes its turn to the end of the list, too.} ] -The server should send messages to the first @tech{world} of its list as - long as it wishes this @tech{world} to remain active. In turn, it should - expect to receive messages only from this one active @tech{world} and no - other @tech{world}. The content of these two messages is nearly irrelevant - because a message from the server to a @tech{world} means that it is the - @tech{world}'s turn and a message from the @tech{world} to the server +The server should send messages to the first @emph{iworld} of its list as + long as it wishes this @emph{iworld} to remain active. In turn, it should + expect to receive messages only from this one active @emph{iworld} and no + other @emph{iworld}. The content of these two messages is nearly irrelevant + because a message from the server to a @emph{iworld} means that it is the + @emph{iworld}'s turn and a message from the @emph{iworld} to the server means that the turn is over. Just so that we don't confuse ourselves, we use two distinct symbols for these two messages: @itemize[ diff --git a/collects/teachpack/htdp/scribblings/world.scrbl b/collects/teachpack/htdp/scribblings/world.scrbl index 641bbd64f0..26432d2459 100644 --- a/collects/teachpack/htdp/scribblings/world.scrbl +++ b/collects/teachpack/htdp/scribblings/world.scrbl @@ -307,14 +307,14 @@ Second, we must translate the "world" actions---the arrows in the above ;; deal with the passing of time (define (tick w) ...) -;; click : @tech{D} @scheme{Number} @scheme{Number} @tech{MouseEvent} -> @tech{D} -;; deal with a mouse click at (x,y) of kind @scheme{me} -;; in the current world @scheme{w} +;; click : @tech{D} @scheme[Number] @scheme[Number] @tech{MouseEvent} -> @tech{D} +;; deal with a mouse click at (x,y) of kind @scheme[me] +;; in the current world @scheme[w] (define (click w x y me) ...) ;; control : @tech{D} @tech{KeyEvent} -> @tech{D} -;; deal with a key event (symbol, char) @scheme{ke} -;; in the current world @scheme{w} +;; deal with a key event (symbol, char) @scheme[ke] +;; in the current world @scheme[w] (define (control w ke) ...) )) @@ -357,9 +357,9 @@ Now that we have a data definition, we must also decide which computer function that simulates time. For the other three arrows, we could use either keyboard events or mouse clicks or both. Our solution uses three keystrokes: -@scheme{#\u} for unlocking the door, -@scheme{#\l} for locking it, and -@scheme{#\space} for pushing it open. +@scheme[#\u] for unlocking the door, +@scheme[#\l] for locking it, and +@scheme[#\space] for pushing it open. We can express these choices graphically by translating the above "state machine" from the world of information into the world of data: @@ -372,17 +372,17 @@ Our analysis and data definition leaves us with three functions to design: @itemize[ -@item{@scheme{automatic-closer}, which closes the time during one tick;} +@item{@scheme[automatic-closer], which closes the time during one tick;} -@item{@scheme{door-actions}, which manipulates the time in response to +@item{@scheme[door-actions], which manipulates the time in response to pressing a key; and} -@item{@scheme{render}, which translates the current state of the door into +@item{@scheme[render], which translates the current state of the door into a visible scene.} ] -Let's start with @scheme{automatic-closer}. We know its contract and it is +Let's start with @scheme[automatic-closer]. We know its contract and it is easy to refine the purpose statement, too: @(begin @@ -490,15 +490,15 @@ this purpose: @(begin #reader scribble/comment-reader (schemeblock -;; render : @tech{SD} -> @scheme{Scene} +;; render : @tech{SD} -> @scheme[Scene] ;; translate the current state of the door into a large text (define (render s) (text (symbol->string s) 40 'red)) (check-expecy (render 'closed) (text "closed" 40 'red)) )) - The function @scheme{symbol->string} translates a symbol into a string, - which is needed because @scheme{text} can deal only with the latter, not + The function @scheme[symbol->string] translates a symbol into a string, + which is needed because @scheme[text] can deal only with the latter, not the former. A look into the language documentation revealed that this conversion function exists, and so we use it. diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss index 360ed179bf..70c866aab3 100644 --- a/collects/tests/units/test-unit-contracts.ss +++ b/collects/tests/units/test-unit-contracts.ss @@ -1,5 +1,6 @@ (require "test-harness.ss" - scheme/unit) + scheme/unit + scheme/contract) (define-signature sig1 ((contracted [x number?]))) @@ -717,4 +718,78 @@ (f 0) (test-runtime-error exn:fail:contract? "V@ broke contract on f" - (f 3))) \ No newline at end of file + (f 3))) + +(let () + (define-signature foo^ (x y)) + (define-unit/contract U@ + (import) + (export (foo^ [x (-> number? number?)])) + (define (x n) (zero? n)) + (define y 4)) + (define-unit V@ + (import foo^) + (export) + (x 4)) + (define-compound-unit/infer W@ + (import) (export) (link U@ V@)) + (define-values/invoke-unit/infer U@) + y + (test-runtime-error exn:fail:contract? "top-level broke contract on x" + (x #t)) + (test-runtime-error exn:fail:contract? "U@ broke contract on x" + (x 3)) + (test-runtime-error exn:fail:contract? "U@ broke contract on x" + (invoke-unit W@))) + +(let () + (define-signature foo^ (x? f)) + (define-unit/contract U@ + (import) + (export (foo^ [f (-> x? number?)])) + (define (x? n) (or (= n 3) + (zero? n))) + (define (f n) (if (= n 3) #t n))) + (define-unit V@ + (import foo^) + (export) + (test-runtime-error exn:fail:contract? "top-level broke contract on x" + (f 2)) + (test-runtime-error exn:fail:contract? "U@ broke contract on x" + (f 3))) + (define-compound-unit/infer W@ + (import) (export) (link U@ V@)) + (define-values/invoke-unit/infer U@) + (test-runtime-error exn:fail:contract? "top-level broke contract on x" + (f 4)) + (test-runtime-error exn:fail:contract? "U@ broke contract on x" + (f 3)) + (invoke-unit W@)) + +(let () + (define-signature foo^ + ((contracted + [x? (-> number? boolean?)] + [f (-> x? number?)]))) + + (define-unit/contract foo@ + (import) + (export (foo^ [x? (-> any/c boolean?)])) + + (define (x? n) (zero? n)) + (define (f x) 3)) + + (define-values/invoke-unit/infer foo@) + + (f 0) + (test-runtime-error exn:fail:contract? "top-level broke the contract on x" + (f 4)) + ;; This is a weird one. The definition for foo@ has two conflicting + ;; contracts. Who gets blamed? Still the top-level, since foo@ can't + ;; get blamed for breaking its own contract. In theory you could say + ;; that perhaps the top-level shouldn't be blamed, and that it should + ;; just be an "overriding" contract, but a) that won't really work and + ;; b) what about other units that might link with foo@, that expect + ;; the stronger contract? + (test-runtime-error exn:fail:contract? "top-level broke the contract on x" + (f #t))) diff --git a/collects/tex2page/tex2page.tex b/collects/tex2page/tex2page.tex new file mode 100644 index 0000000000..0d49803775 --- /dev/null +++ b/collects/tex2page/tex2page.tex @@ -0,0 +1,1238 @@ +% tex2page.tex +% Dorai Sitaram + +% TeX files using these macros +% can be converted by the program +% tex2page into HTML + +\ifx\shipout\UnDeFiNeD\endinput\fi + +\message{version 2008-03-02} % last change + +\let\texonly\relax +\let\endtexonly\relax + +\let\htmlonly\iffalse +\let\endhtmlonly\fi + +\edef\atcatcodebeforetexzpage{% + \noexpand\catcode`\noexpand\@=\the\catcode`\@} +\catcode`\@11 + +% + +\def\verbwritefile{% + \ifx\verbwritefileQport\UnDeFiNeD + \expandafter\csname newwrite\endcsname\verbwritefileQport + \else\immediate\closeout\verbwritefileQport + \fi + \futurelet\verbwritefileQnext\verbwritefileQcheckchar} + +\def\verbwritefileQcheckchar{% + \ifx\verbwritefileQnext\bgroup + \let\verbwritefileQnext\verbwritefileQbracedfile + \else + \let\verbwritefileQnext\verbwritefileQspacedfile + \fi\verbwritefileQnext} + +\def\verbwritefileQspacedfile#1 {% + \immediate\openout\verbwritefileQport #1 +} + +\def\verbwritefileQbracedfile#1{% + \verbwritefileQspacedfile #1 +} + +\def\verbwrite{% + \ifx\verbwritefileQport\UnDeFiNeD + \verbwritefile \jobname.txt \fi + \begingroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \catcode`\^^M=12 \newlinechar=`\^^M% + \futurelet\verbwriteQopeningchar\verbwriteQii} + +\def\verbwriteQii{\ifx\verbwriteQopeningchar\bgroup + \let\verbwriteQiii\verbwriteQbrace\else + \let\verbwriteQiii\verbwriteQnonbrace\fi + \verbwriteQiii} + +\def\verbwriteQbrace#1{\immediate + \write\verbwritefileQport{#1}\endgroup} + +\def\verbwriteQnonbrace#1{% + \catcode`\{12 \catcode`\}12 + \def\verbwriteQnonbraceQii##1#1{% + \immediate\write\verbwritefileQport{##1}\endgroup}% + \verbwriteQnonbraceQii} + +\ifx\slatexignorecurrentfile\UnDeFiNeD\relax\fi + +% + +\def\defcsactive#1{\defnumactive{`#1}} + +\def\defnumactive#1{\catcode#1\active + \begingroup\lccode`\~#1% + \lowercase{\endgroup\def~}} + +% gobblegobblegobble + +\def\gobblegroup{\bgroup + \def\do##1{\catcode`##1=9 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \gobblegroupQii} + +\def\gobblegroupQii#1{\egroup} + +% \verb +% Usage: \verb{...lines...} or \verb|...lines...| +% In the former case, | can be used as escape char within +% the verbatim text + +\let\verbhook\relax + +\def\verbfont{\tt} +%\hyphenchar\tentt-1 + +\def\verbsetup{\frenchspacing + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\|=12 % needed? + \verbfont + \edef\verbQoldhyphenchar{\the\hyphenchar\font}% + \hyphenchar\font-1 + \def\verbQendgroup{\hyphenchar\font\verbQoldhyphenchar\endgroup}% +} + +\def\verbavoidligs{% avoid ligatures + \defcsactive\`{\relax\lq}% + \defcsactive\ {\leavevmode\ }% + \defcsactive\^^I{\leavevmode\ \ \ \ \ \ \ \ }% + \defcsactive\^^M{\leavevmode\endgraf}% + \ifx\noncmttQspecific\UnDeFiNeD\else\noncmttQspecific\fi} + +\def\verbinsertskip{% + \let\firstpar y% + \defcsactive\^^M{\ifx\firstpar y% + \let\firstpar n% + \verbdisplayskip + \parskip 0pt + \aftergroup\verbdisplayskip + \else\leavevmode\fi\endgraf}% + \verbhook} + +%\def\verb{\begingroup +% \verbsetup\verbQii} + +\ifx\verb\UnDeFiNeD\else % save away LaTeX's \verb + \let\LaTeXverb\verb +\fi + +\def\verb{\begingroup + \verbsetup\verbavoidligs\verbQcheckstar}% + +\def\verbQcheckstar{% + \futurelet\verbQcheckstarQnext\verbQcheckstarQii} + +\def\verbQcheckstarQii{% + \if\verbQcheckstarQnext*% + \let\verbQcheckstarQnext\verbQcheckstarQiii + \else + \let\verbQcheckstarQnext\verbQii + \fi + \verbQcheckstarQnext} + +\def\verbQcheckstarQiii#1{% + \defcsactive\ {\relax\char`\ }% + \verbQii} + +\newcount\verbbracebalancecount + +\def\verblbrace{\char`\{} +\def\verbrbrace{\char`\}} + +\ifx\verbatimescapechar\UnDeFiNeD +% don't clobber Eplain's \verbatimescapechar +\def\verbatimescapechar#1{% + \def\@makeverbatimescapechar{\catcode`#1=0 }}% +\fi +\let\verbescapechar\verbatimescapechar + +\verbatimescapechar\| + +{\catcode`\[1 \catcode`\]2 +\catcode`\{12 \catcode`\}12 +\gdef\verbQii#1[%\verbavoidligs + \verbinsertskip\verbhook + %\edef\verbQoldhyphenchar{\the\hyphenchar\tentt}% + %\hyphenchar\tentt=-1 + %\def\verbQendgroup{\hyphenchar\tentt\verbQoldhyphenchar\endgroup}% + %\let\verbQendgroup\endgroup% + \if#1{\@makeverbatimescapechar + \def\{[\char`\{]% + \def\}[\char`\}]% + \def\|[\char`\|]% + \verbbracebalancecount0 + \defcsactive\{[\advance\verbbracebalancecount by 1 + \verblbrace]% + \defcsactive\}[\ifnum\verbbracebalancecount=0 + \let\verbrbracenext\verbQendgroup\else + \advance\verbbracebalancecount by -1 + \let\verbrbracenext\verbrbrace\fi + \verbrbracenext]\else + \defcsactive#1[\verbQendgroup]\fi + \verbQiii +]] + +\def\verbQiii{\futurelet\verbQiiinext\verbQiv} + +{\catcode`\^^M\active% +\gdef\verbQiv{\ifx\verbQiiinext^^M\else% + \defcsactive\^^M{\leavevmode\ }\fi}} + +\let\verbdisplayskip\medbreak + +% \verbatiminput FILENAME +% displays contents of file FILENAME verbatim. + +%\def\verbatiminput#1 {{\verbsetup\verbavoidligs\verbhook +% \input #1 }} + +% ^ original \verbatiminput + +\ifx\verbatiminput\UnDeFiNeD +% LaTeX's (optional) verbatim package defines a \verbatiminput -- +% don't clobber it +\def\verbatiminput{% + \futurelet\verbatiminputQnext\verbatiminputQcheckchar}% +\fi + +\def\verbatiminputQcheckchar{% + \ifx\verbatiminputQnext\bgroup + \let\verbatiminputQnext\verbatiminputQbracedfile + \else + \let\verbatiminputQnext\verbatiminputQspacedfile + \fi\verbatiminputQnext} + +\def\verbatiminputQbracedfile#1{\verbatiminputQdoit{#1}} + +\def\verbatiminputQspacedfile#1 {\verbatiminputQdoit{#1}} + +\def\verbatiminputQdoit#1{{\verbsetup + \verbavoidligs\verbhook + \input #1 }} + +% \url{URL} becomes +% URL in HTML, and +% URL in DVI. + +% A-VERY-VERY-LONG-URL in a .bib file +% could be split by BibTeX +% across a linebreak, with % before the newline. +% To accommodate this, %-followed-by-newline will +% be ignored in the URL argument of \url and related +% macros. + +\ifx\url\UnDeFiNeD +\def\url{\bgroup\urlsetup\let\dummy=}% +\fi + +\def\urlsetup{\verbsetup\urlfont\verbavoidligs + \catcode`\{1 \catcode`\}2 + \defcsactive\%{\urlQpacifybibtex}% + \defcsactive\ {\relax}% + \defcsactive\^^M{\relax}% + \defcsactive\.{\discretionary{}{\char`\.}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \defcsactive\`{\relax\lq}} + +\let\urlfont\relax + +\def\urlQpacifybibtex{\futurelet\urlQpacifybibtexQnext\urlQpacifybibtexQii} + +\def\urlQpacifybibtexQii{\ifx\urlQpacifybibtexQnext^^M% + \else\%\fi} + + +% \urlh{URL}{TEXT} becomes +% TEXT in HTML, and +% TEXT in DVI. + +% If TEXT contains \\, the part after \\ appears in +% the DVI only. If, further, this part contains \1, +% the latter is replaced by a fixed-width representation +% of URL. + +\def\urlh{\bgroup\urlsetup + \afterassignment\urlhQii + \gdef\urlhQurlarg} + +\def\urlhQii{\egroup + \bgroup + \let\\\relax + \def\1{{\urlsetup\urlhQurlarg}}% + \let\dummy=} + +\def\urlp#1{{#1} \bgroup\urlsetup + \afterassignment\urlpQwrapparens + \gdef\urlpQurlarg} + +\def\urlpQwrapparens{\egroup + {\rm(}{\urlsetup\urlpQurlarg}{\rm)}} + +% \urlhd{URL}{HTML-TEXT}{DVI-TEXT} becomes +% HTML-TEXT in HTML, and +% DVI-TEXT in DVI + +\def\urlhd{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 + \urlhdQeaturlhtmlargs} + +\def\urlhdQeaturlhtmlargs#1#2{\egroup} + +\ifx\href\UnDeFiNeD +\let\href\urlh +\fi + +% Scheme + +\let\scm\verb +\let\scminput\verbatiminput +\let\scmdribble\scm + + +% Images + +\let\imgdef\def + +\let\makehtmlimage\relax + +\def\mathg{$\bgroup\aftergroup\closemathg\let\dummy=} +\def\closemathg{$} + +\let\mathp\mathg + +\def\mathdg{$$\bgroup\aftergroup\closemathdg\let\dummy=} +\def\closemathdg{$$} + +% + +\ifx\label\UnDeFiNeD +\else +\def\xrtag#1#2{\@bsphack + \protected@write\@auxout{}% + {\string\newlabel{#1}{{#2}{\thepage}}}% +\@esphack}% +%\let\tagref\ref +\fi + +\ifx\definexref\UnDeFiNeD +\else +\def\xrtag#1#2{\definexref{#1}{#2}{}}% +\fi + +\ifx\IfFileExists\UnDeFiNeD +\def\IfFileExists#1#2#3{% + \openin0 #1 % + \ifeof0 % + #3% + \else + #2\fi + \closein0 }% +\fi + +\ifx\futurenonspacelet\UnDeFiNeD +\ifx\@futurenonspacelet\UnDeFiNeD +% +\def\futurenonspaceletQpickupspace/{% + \global\let\futurenonspaceletQspacetoken= }% +\futurenonspaceletQpickupspace/ % +% +\def\futurenonspacelet#1{\def\futurenonspaceletQargQi{#1}% + \afterassignment\futurenonspaceletQstepQone + \let\futurenonspaceletQargQii=}% +% +\def\futurenonspaceletQstepQone{% + \expandafter\futurelet\futurenonspaceletQargQi + \futurenonspaceletQstepQtwo}% +% +\def\futurenonspaceletQstepQtwo{% + \expandafter\ifx\futurenonspaceletQargQi\futurenonspaceletQspacetoken + \let\futurenonspaceletQnext=\futurenonspaceletQstepQthree + \else\let\futurenonspaceletQnext=\futurenonspaceletQargQii + \fi\futurenonspaceletQnext}% +% +\def\futurenonspaceletQstepQthree{% + \afterassignment\futurenonspaceletQstepQone + \let\futurenonspaceletQnext= }% +% +\else\let\futurenonspacelet\@futurenonspacelet +\fi +\fi + +\ifx\slatexversion\UnDeFiNeD +% SLaTeX compat +\let\scmkeyword\gobblegroup +\let\scmbuiltin\gobblegroup +\let\scmconstant\scmbuiltin +\let\scmvariable\scmbuiltin +\let\setbuiltin\scmbuiltin +\let\setconstant\scmbuiltin +\let\setkeyword\scmkeyword +\let\setvariable\scmvariable +\def\schemedisplay{\begingroup + \verbsetup\verbavoidligs + \verbinsertskip + \schemedisplayI}% +\def\schemeresponse{\begingroup + \verbsetup\verbavoidligs + \verbinsertskip + \schemeresponseI}% +{\catcode`\|0 |catcode`|\12 + |long|gdef|schemedisplayI#1\endschemedisplay{% + #1|endgroup}% + |long|gdef|schemeresponseI#1\endschemeresponse{% + #1|endgroup}}% +\fi + + +% STOP LOADING HERE FOR LATEX + +\ifx\section\UnDeFiNeD +\let\maybeloadfollowing\relax +\else +\atcatcodebeforetexzpage +\let\maybeloadfollowing\endinput +\fi\maybeloadfollowing + +\newwrite\sectionQscratchfileport + +% Title + +\def\subject{% + \immediate\openout\sectionQscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \subjectI} + +\def\subjectI#1{\endgroup + \immediate\write\sectionQscratchfileport {#1}% + \immediate\closeout\sectionQscratchfileport + $$\vbox{\bf \def\\{\cr}% + \halign{\hfil##\hfil\cr + \input Z-sec-temp + \cr}}$$% + \medskip} + +\let\title\subject + +% toc + +\let\tocactive0 + +\newcount\tocdepth + +%\tocdepth=10 +\tocdepth=3 + +\def\tocoutensure{\ifx\tocout\UnDeFiNeD + \csname newwrite\endcsname\tocout\fi} + +\def\tocactivate{\ifx\tocactive0% + \tocoutensure + \tocsave + \openout\tocout \jobname.toc + \global\let\tocactive1\fi} + +\def\tocspecials{\def\do##1{\catcode`##1=12 }\dospecials} + +\def\tocsave{\openin0=\jobname.toc + \ifeof0 \closein0 \else + \openout\tocout Z-T-\jobname.tex + \let\tocsaved 0% + \loop + \ifeof0 \closeout\tocout + \let\tocsaved1% + \else{\tocspecials + \read0 to \tocsaveline + \edef\temp{\write\tocout{\tocsaveline}}\temp}% + \fi + \ifx\tocsaved0% + \repeat + \fi + \closein0 } + +\def\tocentry#1#2{% + %#1=depth #2=secnum + \def\tocentryQsecnum{#2}% + \ifnum#1=1 + \ifnum\tocdepth>2 + \medbreak\begingroup\bf + \else\begingroup\fi + \else\begingroup\fi + \vtop\bgroup\raggedright + \noindent\hskip #1 em + \ifx\tocentryQsecnum\empty + \else\qquad\llap{\tocentryQsecnum}\enspace\fi + \bgroup + \aftergroup\tocentryQii + %read section title + \let\dummy=} + +\def\tocentryQii#1{% + %#1=page nr + , #1\strut\egroup + \endgroup\par +} + + +% allow {thebibliography} to be used directly +% in (plain-TeX) source document without +% generating it via BibTeX + +\ifx\thebibliography\UnDeFiNeD +\def\thebibliography#1{\vskip-\lastskip + \begingroup + \def\endthebibliography{\endgroup\endgroup}% + \def\input##1 ##2{\relax}% + \setbox0=\hbox{\biblabelcontents{#1}}% + \biblabelwidth=\wd0 + \@readbblfile}% +\fi + + +% + +\def\italiccorrection{\futurelet\italiccorrectionI + \italiccorrectionII} + +\def\italiccorrectionII{% + \if\noexpand\italiccorrectionI,\else + \if\noexpand\italiccorrectionI.\else + \/\fi\fi} + +\def\em{\it\ifmmode\else\aftergroup\italiccorrection\fi} + +\def\emph{\bgroup\it + \ifmmode\else\aftergroup\italiccorrection\fi + \let\dummy=} + + +\def\begin#1{\begingroup + \def\end##1{\csname end#1\endcsname\endgroup}% + \csname #1\endcsname} + + +\def\textdegree{\ifmmode^\circ\else$^\circ$\fi} + + +% STOP LOADING HERE FOR EPLAIN + +\ifx\eplain\UnDeFiNeD +\let\maybeloadfollowing\relax +\else +\atcatcodebeforetexzpage +\let\maybeloadfollowing\endinput +\fi\maybeloadfollowing +% + +% Index generation +% +% Your TeX source contains \index{NAME} to +% signal that NAME should be included in the index. +% Check the makeindex documentation to see the various +% ways NAME can be specified, eg, for subitems, for +% explicitly specifying the alphabetization for a name +% involving TeX control sequences, etc. +% +% The first run of TeX will create \jobname.idx. +% makeindex on \jobname[.idx] will create the sorted +% index \jobname.ind. +% +% Use \inputindex (without arguments) to include this +% sorted index, typically somewhere to the end of your +% document. This will produce the items and subitems. +% It won't produce a section heading however -- you +% will have to typeset one yourself. + +%\def\sanitizeidxletters{\def\do##1{\catcode`##1=11 }% +% \dospecials +% \catcode`\{=1 \catcode`\}=2 \catcode`\ =10 } + +\def\sanitizeidxletters{\def\do##1{\catcode`##1=11 }% + \do\\\do\$\do\&\do\#\do\^\do\_\do\%\do\~% + \do\@\do\"\do\!\do\|\do\-\do\ \do\'} + +\def\index{%\unskip + \ifx\indexout\UnDeFiNeD + \csname newwrite\endcsname\indexout + \openout\indexout \jobname.idx\fi + \begingroup + \sanitizeidxletters + \indexQii} + +\def\indexQii#1{\endgroup + \write\indexout{\string\indexentry{#1}{\folio}}% + \ignorespaces} + +% The following index style indents subitems on a +% separate lines + +\def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\indexitem##1{\par\hangindent30pt \hangafter1 + \hskip ##1 }% + \def\item{\indexitem{0em}}% + \def\subitem{\indexitem{2em}}% + \def\subsubitem{\indexitem{4em}}% + \def\see{{\it see} \bgroup\aftergroup\gobblegroup\let\dummy=}% + \let\indexspace\medskip} + +\def\endtheindex{\endgroup} + +\def\inputindex{% + \openin0 \jobname.ind + \ifeof0 \closein0 + \message{\jobname.ind missing.}% + \else\closein0 + \begingroup + \def\begin##1{\csname##1\endcsname}% + \def\end##1{\csname end##1\endcsname}% + \input\jobname.ind + \endgroup\fi} + +% Cross-references + +% \openxrefout loads all the TAG-VALUE associations in +% \jobname.xrf and then opens \jobname.xrf as an +% output channel that \xrtag can use + +\def\openxrefout{% + \openin0=\jobname.xrf + \ifeof0 \closein0 + \else \closein0 {\catcode`\\0 \input \jobname.xrf }% + \fi + \expandafter\csname newwrite\endcsname\xrefout + \openout\xrefout=\jobname.xrf +} + +% I'd like to call \openxrefout lazily, but +% unfortunately it produces a bug in MiKTeX. +% So let's call it up front. + +\openxrefout + +% \xrtag{TAG}{VALUE} associates TAG with VALUE. +% Hereafter, \ref{TAG} will output VALUE. +% \xrtag stores its associations in \xrefout. +% \xrtag calls \openxrefout if \jobname.xrf hasn't +% already been opened + +\def\xrtag#1#2{\ifx\xrefout\UnDeFiNeD\openxrefout\fi + {\let\folio0% + \edef\temp{% + \write\xrefout{\string\expandafter\string\gdef + \string\csname\space XREF#1\string\endcsname + {#2}\string\relax}}% + \temp}\ignorespaces} + + +% \ref{TAG} outputs VALUE, assuming \xrtag put such +% an association into \xrefout. \ref calls +% \openxrefout if \jobname.xrf hasn't already +% been opened + +\def\ref#1{\ifx\xrefout\UnDeFiNeD\openxrefout\fi + \expandafter\ifx\csname XREF#1\endcsname\relax + %\message or \write16 ? + \message{\the\inputlineno: Unresolved label `#1'.}?\else + \csname XREF#1\endcsname\fi} + + +% + +\def\writenumberedtocline#1#2#3{% + %#1=depth + %#2=secnum + %#3=title + \tocactivate + \edef\@currentlabel{#2}% + {\let\folio0% + \edef\writetotocQtemp{\write\tocout + {\string\tocentry{#1}{#2}{#3}{\folio}}}% + \writetotocQtemp}} + +\def\tableofcontents{% + \ifx\tocactive0% + \openin0 \jobname.toc + \edef\QatcatcodebeforeToC{% + \noexpand\catcode`\noexpand\@=\the\catcode`\@}% + \catcode`\@=11 + \ifeof0 \closein0 \else + \closein0 \input \jobname.toc + \fi + \QatcatcodebeforeToC + \tocoutensure + \openout\tocout \jobname.toc + \global\let\tocactive1% + \else + \input Z-T-\jobname.tex + \fi} + +% + +\ifx\TZPplain\UnDeFiNeD +\let\maybeloadfollowing\relax +\else +\atcatcodebeforetexzpage +\let\maybeloadfollowing\endinput +\fi\maybeloadfollowing + +% Tally control sequences are cheap count +% registers: they doesn't use up TeX's limited number of +% real count registers. + +% A tally is a macro that expands to the +% number kept track of. Thus \edef\kount{0} defines a +% tally \kount that currently contains 0. + +% \advancetally\kount n increments \kount by n. +% \globaladvancetally increments the global \kount. +% If \kount is not defined, the \[global]advancetally +% macros define it to be 0 before proceeding with the +% incrementation. + +\def\newtally#1{\edef#1{0}} + +\def\advancetallyhelper#1#2#3{% + \ifx#2\UnDeFiNeD + #1\edef#2{0}\fi + \edef\setcountCCLV{\count255=#2 }% + \setcountCCLV + \advance\count255 by #3 + #1\edef#2{\the\count255 }} + +\def\advancetally{\advancetallyhelper\relax} +\def\globaladvancetally{\advancetallyhelper\global} + +% Sections + +\def\tracksectionchangeatlevel#1{% + \expandafter\let\expandafter\thiscount\csname + sectionnumber#1\endcsname + \ifx\thiscount\relax + \expandafter\edef\csname sectionnumber#1\endcsname{0}% + \fi + \expandafter\advancetally + \csname sectionnumber#1\endcsname 1% + \ifx\doingappendix0% + \edef\@currentlabel{\csname sectionnumber1\endcsname}% + \else + %\count255=\expandafter\csname sectionnumber1\endcsname + \edef\@currentlabel{\char\csname sectionnumber1\endcsname}% + \fi + \count255=0 + \loop + \advance\count255 by 1 + \ifnum\count255=1 + \else\edef\@currentlabel{\@currentlabel.\csname + sectionnumber\the\count255\endcsname}\fi + \ifnum\count255<#1% + \repeat + \loop + \advance\count255 by 1 + \expandafter\let\expandafter\nextcount\csname + sectionnumber\the\count255\endcsname + \ifx\nextcount\relax + \let\continue0% + \else + \expandafter\edef\csname + sectionnumber\the\count255\endcsname{0}% + \let\continue1\fi + \ifx\continue1% + \repeat} +\newcount\secnumdepth + +\secnumdepth=3 + +\def\sectiond#1{\count255=#1% + \ifx\usingchapters1\advance\count255 by 1 \fi + \edef\sectiondlvl{\the\count255 }% + \futurelet\sectionnextchar\sectiondispatch} + +\def\sectiondispatch{\ifx\sectionnextchar*% + \def\sectioncontinue{\sectionstar{\sectiondlvl}}\else + \ifnum\sectiondlvl>\secnumdepth + \def\sectioncontinue{\sectionhelp{\sectiondlvl}{}}\else + \tracksectionchangeatlevel{\sectiondlvl}% + \def\sectioncontinue{\sectionhelp{\sectiondlvl}% + {\@currentlabel}}\fi\fi + \sectioncontinue} + +\def\sectionstar#1*{\sectionhelp{#1}{}} + +\def\sectionhelp#1#2{% + \edef\sectiondepth{#1}% + \def\sectionnr{#2}% + \immediate\openout\sectionQscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}= 2 + \sectionheader} + +% Vanilla section-header look -- change this macro for new look + +\def\sectionheader#1{\endgroup + \immediate\write\sectionQscratchfileport {#1}% + \immediate\closeout\sectionQscratchfileport + \vskip -\lastskip + \ifnum\sectiondepth>\tocdepth\else + \writenumberedtocline{\sectiondepth}{\sectionnr}{#1}% + \fi + \vskip1.5\bigskipamount + \goodbreak %??? + \noindent + \hbox{\vtop{\pretolerance 10000 + \raggedright + \noindent\bf + \ifx\sectionnr\empty\else + \sectionnr\enspace\fi + \input Z-sec-temp }}% + \nobreak + \smallskip + %\noindent + } + +% \edef\temp{\write\tocout{\string\hskip#1\space em\string\relax\space #2% +% \string\vtop{\string\hsize=.7\string\hsize +% \string\noindent\string\raggedright\space #3}\string\par}}\temp + + + +\def\section{\sectiond1} +\def\subsection{\sectiond2} +\def\subsubsection{\sectiond3} +\def\paragraph{\sectiond4} +\def\subparagraph{\sectiond5} + +\let\usingchapters0 + +\def\chapter{\global\let\usingchapters1% +\global\footnotenumber=0 +\futurelet\chapternextchar\chapterdispatch} + +\def\chapterdispatch{\ifx\chapternextchar*% + \let\chaptercontinue\chapterstar\else + \tracksectionchangeatlevel{1}% + \def\chaptercontinue{\chapterhelp{\@currentlabel}}\fi + \chaptercontinue} + +\def\chapterstar*{\chapterhelp{}} + +\def\chapterhelp#1{% + % #1=number #2=heading-text + \def\chapternr{#1}% + \immediate\openout\sectionQscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \chapterheader} + +\def\chapterheader#1{\endgroup + \immediate\write\sectionQscratchfileport {#1}% + \immediate\closeout\sectionQscratchfileport + \writenumberedtocline{1}{\chapternr}{#1}% + \vfill\eject + \null\vskip3em + \noindent + \ifx\chapternr\empty\hbox{~}\else + \ifx\doingappendix0% + \hbox{\bf Chapter \chapternr}\else + \hbox{\bf Appendix \chapternr}\fi\fi + \vskip 1em + \noindent + \hbox{\bf\vtop{%\hsize=.7\hsize + \pretolerance 10000 + \noindent\raggedright\input Z-sec-temp }}% + \nobreak\vskip3em + %\noindent + } + +\let\doingappendix=0 + +\def\appendix{\let\doingappendix=1% + \count255=`\A% + \advance\count255 by -1 + \expandafter\edef\csname + sectionnumber1\endcsname{\the\count255 }} + +% Numbered footnotes + +\ifx\plainfootnote\UnDeFiNeD + \let\plainfootnote\footnote +\fi + +\newcount\footnotenumber + +\def\numberedfootnote{\global\advance\footnotenumber 1 + \bgroup\csname footnotehook\endcsname + \plainfootnote{$^{\the\footnotenumber}$}\bgroup + \edef\@currentlabel{\the\footnotenumber}% + \aftergroup\egroup + \let\dummy=} + + +\let\@currentlabel\relax + +% \label, as in LaTeX + +% The sectioning commands +% define \@currentlabel so a subsequent call to \label will pick up the +% right label. + +\def\label#1{\xrtag{#1}{\@currentlabel}% + \xrtag{PAGE#1}{\folio}} + +% \pageref, as in LaTeX + +\def\pageref#1{\ref{PAGE#1}} + + +% + +\def\itemize{\par\begingroup + \advance\leftskip\parindent + \smallbreak + \def\item{\smallbreak\noindent + \llap{$\bullet$\enspace}\ignorespaces}} + +\def\enditemize{\smallbreak\smallbreak\endgroup\par} + +\newtally\enumeratelevel + +\def\enumerate{\par\begingroup + \advancetally\enumeratelevel1% + \newtally\enumeratenumber + \advance\leftskip\parindent + \smallbreak + \def\item{\smallbreak\noindent + \advancetally\enumeratenumber1% + \ifnum\enumeratelevel=1 + \edef\enumeratemark{\enumeratenumber}\else + \ifnum\enumeratelevel=2 + \count255=\enumeratenumber + \advance\count255 by -1 \advance\count255 by `a + \edef\enumeratemark{\noexpand\char\the\count255 }\else + \ifnum\enumeratelevel=3 + \edef\enumeratemark{\Romannumeral\enumeratenumber}\else + \ifnum\enumeratelevel=4 + \count255=\enumeratenumber + \advance\count255 by -1 \advance\count255 by `A + \edef\enumeratemark{\noexpand\char\the\count255 }\else + \edef\enumeratemark{\enumeratenumber}\fi\fi\fi\fi + \edef\@currentlabel{\enumeratemark}% needed? + \llap{\enumeratemark.\enspace}\ignorespaces}} + +\def\endenumerate{\smallbreak\smallbreak\endgroup\par} + +% \path is like \verb except that its argument +% can break across lines at `.' and `/'. + +\ifx\path\UnDeFiNeD +\def\path{\begingroup\verbsetup + \pathfont + \defcsactive\.{\discretionary{\char`\.}{}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \verbQii}% +\fi + +\let\pathfont\relax +% + +% plain's \{left,center,right}line can't handle catcode change +% within their argument + +\def\leftline{\line\bgroup\bgroup + \aftergroup\leftlinefinish + \let\dummy=} + +\def\leftlinefinish{\hss\egroup} + +\def\centerline{\line\bgroup\bgroup + \aftergroup\leftlinefinish + \hss\let\dummy=} + +\def\rightline{\line\bgroup\hss\let\dummy=} + +% +% definitions (useful in reference manuals) + +\def\defun#1{\def\defuntype{#1}% +\medbreak +\line\bgroup + \hbox\bgroup + \aftergroup\enddefun + \vrule width .5ex \thinspace + \vrule \enspace + \vbox\bgroup\setbox0=\hbox{\defuntype}% + \advance\hsize-\wd0 + \advance\hsize-1em + \obeylines + \parindent=0pt + \aftergroup\egroup + \strut + \let\dummy=} + +\def\enddefun{\hfil\defuntype\egroup\smallskip} + +% + +%\def\hr{\smallskip\line{\leaders\hbox{~.~}\hfill}\smallskip} + +% + +\def\sidemargin{\afterassignment\sidemarginQadjustoffset + \hoffset} + +\def\sidemarginQadjustoffset{% + \advance\hoffset -1true in + \advance\hsize -2\hoffset} + +% don't let caps disable end-of-sentence spacing -- assumes we won't use +% dots after caps for abbrevs + +\def\nocapdot{% +\count255=`\A +\loop +\sfcode\the\count255=1000 +\ifnum\count255<`\Z +\advance\count255 by 1 +\repeat +} + +% " --> `` or '' + +\def\smartdoublequotes{% + \defcsactive\"{\futurelet\smartdoublequotesI + \smartdoublequotesII}% + \def\smartdoublequotesII{% + \ifcat\noexpand\smartdoublequotesI a``\else + \if\noexpand\smartdoublequotesI 0``\else + \if\noexpand\smartdoublequotesI 1``\else + \if\noexpand\smartdoublequotesI 2``\else + \if\noexpand\smartdoublequotesI 3``\else + \if\noexpand\smartdoublequotesI 4``\else + \if\noexpand\smartdoublequotesI 5``\else + \if\noexpand\smartdoublequotesI 6``\else + \if\noexpand\smartdoublequotesI 7``\else + \if\noexpand\smartdoublequotesI 8``\else + \if\noexpand\smartdoublequotesI 9``\else + ''\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi}% +} + +% + +\def\emailliketext{\nocapdot\smartdoublequotes} + +% + +\def\gobbleencl{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \futurelet\gobbleenclQnext\gobbleenclQii} + +\def\gobbleenclQii{\ifx\gobbleenclQnext\bgroup + \let\gobbleenclQnext\gobblegroupQii + \else\let\gobbleenclQnext\gobbleenclQiii\fi + \gobbleenclQnext} + +\def\gobbleenclQiii#1{% + \def\gobbleenclQiv##1#1{\egroup}% + \gobbleenclQiv} + +% + +\let\strike\fiverm % can be much better! +% + +\ifx\InputIfFileExists\UnDeFiNeD +\def\InputIfFileExists#1#2#3{% + \IfFileExists{#1}{#2\input #1 }{#3}}% +\fi + +% \packindex declares that subitems be bundled into one +% semicolon-separated paragraph + +\def\packindex{% + \def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\item{\par\hangindent20pt \hangafter1 }% + \def\subitem{\unskip; }% + \def\subsubitem{\unskip; }% + \def\see{\bgroup\it see \aftergroup\gobblegroup\let\dummy=}% + \let\indexspace\medskip}} + +% Use \printindex instead of \inputindex if you want +% the section heading ``Index'' automatically generated. + +\def\printindex{\csname beginsection\endcsname Index\par + \inputindex} + +\def\inputepsf{% +\ifx\pdfoutput\UnDeFiNeD + \input epsf +\else + \input supp-pdf + \def\epsfbox##1{\convertMPtoPDF{##1}{1}{1}}% +\fi +} + +\def\r#1{{\accent23 #1}} + +\def\verbc{\begingroup + \verbsetup\afterassignment\verbcI + \let\verbcII=} + +\def\verbcI{{\verbfont\verbcII}\endgroup} + +\let\E\verbc + +% The current font is cmtt iff fontdimen3 = 0 _and_ +% fontdimen7 != 0 + +\def\noncmttQspecific{\let\noncmttQspecificQdoit y% + \ifdim\the\fontdimen3\the\font=0.0pt + \ifdim\the\fontdimen7\the\font=0.0pt + \let\noncmttQspecificQdoit n\fi\fi + \ifx\noncmttQspecificQdoit y% + \defcsactive\<{\relax\char`\<}% + \defcsactive\>{\relax\char`\>}% + \defcsactive\-{\variablelengthhyphen}% + \fi} + +% In a nonmonospaced font, - followed by a letter +% is a regular hyphen. Followed by anything else, it is a +% typewriter hyphen. + +\def\variablelengthhyphen{\futurelet\variablelengthhyphenI + \variablelengthhyphenII} + +\def\variablelengthhyphenII{\ifcat\noexpand\variablelengthhyphenI + a-\else{\tt\char`\-}\fi} + +% uppercase version of \romannumeral + +\def\Romannumeral{\afterassignment\RomannumeralI\count255=} + +\def\RomannumeralI{\uppercase\expandafter{\romannumeral\the\count255 }} + +% \xrdef, as in Eplain + +\def\xrdef#1{\xrtag{#1}{\folio}} + +% + +\def\quote{\bgroup\narrower\smallbreak} +\def\endquote{\smallbreak\egroup} + + +\ifx\frac\UnDeFiNeD +\def\frac#1/#2{{#1\over#2}}% +\fi + +\ifx\bull\UnDeFiNeD +\def\bull{$\bullet$}% +\fi + +% \mailto{ADDRESS} becomes +% ADDRESS in HTML, and +% ADDRESS in DVI. + +\let\mailto\url + +\def\raggedleft{% + \leftskip 0pt plus 1fil + \parfillskip 0pt +} + +%\def\rawhtml{\errmessage{Can't occur outside +% \string\htmlonly}} +%\def\endrawhtml{\errmessage{Can't occur outside +% \string\htmlonly}} + +\let\rawhtml\iffalse +\let\endrawhtml\fi + +\let\htmlheadonly\iffalse +\let\endhtmlheadonly\fi + +\let\cssblock\iffalse +\let\endcssblock\fi + +\def\inputcss#1 {\relax} +\let\htmladdimg\gobblegroup + +\def\htmlref{\bgroup\aftergroup\gobblegroup\let\dummy=} + +% + +\let\htmlcolophon\gobblegroup +\let\htmldoctype\gobblegroup +\let\htmlmathstyle\gobblegroup + +\let\slatexlikecomments\relax +\let\noslatexlikecomments\relax + +\let\imgpreamble\iffalse +\let\endimgpreamble\fi + +\def\inputexternallabels#1 {\relax} +\def\includeexternallabels#1 {\relax} + +\ifx\eval\UnDeFiNeD +\IfFileExists{eval4tex.tex}{\input eval4tex }{}\fi + +\let\evalh\gobblegroup +\let\evalq\gobblegroup + +\let\htmlpagebreak\relax + +\let\htmlpagelabel\gobblegroup + +\def\htmlpageref{\errmessage{Can't occur except inside + \string\htmlonly}} + +% Miscellaneous stuff + +%\def\hr{$$\hbox{---}$$} +\def\hr{\medbreak\centerline{---}\medbreak} +%\def\hr{\par\centerline{$*$}\par} + + +\let\htmlimageformat\gobblegroup +\let\htmlimageconversionprogram\gobblegroup + +\let\externaltitle\gobblegroup +\let\ignorenextinputtimestamp\relax + +% + +\let\htmladvancedentities\relax +\let\n\noindent +\let\p\verb +\let\q\scm +\let\f\numberedfootnote +\let\scmp\scm +\let\numfootnote\numberedfootnote +\let\writetotoc\writenumberedtocline +\let\tag\xrtag +\let\scmfilename\verbwritefile +\let\scmwrite\verbwrite + +% + +\atcatcodebeforetexzpage + +% end of file diff --git a/collects/web-server/info.ss b/collects/web-server/info.ss index 97d5076bce..3992ca5f84 100644 --- a/collects/web-server/info.ss +++ b/collects/web-server/info.ss @@ -2,7 +2,7 @@ (define scribblings '(("scribblings/web-server.scrbl" (multi-page) (tool)) - ("scribblings/tutorial/continue.scrbl" () (getting-started)))) + ("scribblings/tutorial/continue.scrbl" () (getting-started 5)))) (define mzscheme-launcher-libraries '("main.ss")) (define mzscheme-launcher-names '("PLT Web Server")) diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index f60d0b79f3..24eedf89c4 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -16,8 +16,10 @@ up a web server, how to generate dynamic web content, and how to interact with the user. The target audience for this tutorial are students who've gone through -the design and use of structures in @link["http://htdp.org/"]{How to Design Programs}, with some -higher-order functions, @scheme[local], and a minor bit of mutation. +the design and use of structures in +@italic{@link["http://www.htdp.org/"]{How to Design Programs}}, with +some higher-order functions, @scheme[local], and a minor bit of +mutation. @section{Getting Started} diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index d033fc934a..f27c57b7b6 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,3 +1,8 @@ +------------------------------------------------------------------------ +Version 4.1.****** [Sat Feb 14 20:12:23 EST 2009] + +* the universe teachpack exports iworld, not world now + ------------------------------------------------------------------------ Version 4.1.4 [Sun Jan 18 21:18:34 EST 2009] diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 71c477963a..5462977929 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -52,6 +52,12 @@ #define PAGEMAP32_BITS(x) (NUM(x) >> LOG_APAGE_SIZE) #endif +#if 0 +# define GC_ASSERT(x) assert(x) +#else +# define GC_ASSERT(x) /* empty */ +#endif + /* the page type constants */ enum { PAGE_TAGGED = 0, @@ -1827,7 +1833,7 @@ static void propagate_marks(NewGC *gc) if((unsigned long)mark_table[tag] < PAGE_TYPES) { /* atomic */ } else { - assert(mark_table[tag]); + GC_ASSERT(mark_table[tag]); mark_table[tag](start); break; } } @@ -1838,7 +1844,7 @@ static void propagate_marks(NewGC *gc) unsigned short tag = *(unsigned short *)start; end -= INSET_WORDS; while(start < end) { - assert(mark_table[tag]); + GC_ASSERT(mark_table[tag]); start += mark_table[tag](start); } break; @@ -1853,7 +1859,7 @@ static void propagate_marks(NewGC *gc) case PAGE_TAGGED: { unsigned short tag = *(unsigned short*)p; - assert(mark_table[tag]); + GC_ASSERT(mark_table[tag]); mark_table[tag](p); break; } @@ -1869,7 +1875,7 @@ static void propagate_marks(NewGC *gc) void **end = PPTR(info) + (info->size - INSET_WORDS); unsigned short tag = *(unsigned short *)start; while(start < end) { - assert(mark_table[tag]); + GC_ASSERT(mark_table[tag]); start += mark_table[tag](start); } break; diff --git a/src/mzscheme/gc2/sighand.c b/src/mzscheme/gc2/sighand.c index 19e7a1130f..02b69091ad 100644 --- a/src/mzscheme/gc2/sighand.c +++ b/src/mzscheme/gc2/sighand.c @@ -18,6 +18,11 @@ #include #include +#ifndef WAIT_FOR_GDB +# define WAIT_FOR_GDB 0 +#endif + +#if WAIT_FOR_GDB static void launchgdb() { pid_t pid = getpid(); char inbuffer[10]; @@ -31,13 +36,16 @@ static void launchgdb() { } } } +#endif void fault_handler(int sn, struct siginfo *si, void *ctx) { void *p = si->si_addr; if (si->si_code != SEGV_ACCERR) { /*SEGV_MAPERR*/ printf("SIGSEGV fault on %p\n", p); +#if WAIT_FOR_GDB launchgdb(); +#endif abort(); } diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 446d809fe4..0b0ed9010a 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -2035,6 +2035,7 @@ static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]) while (SCHEME_PAIRP(extra_sources)) { if (!SCHEME_STXP(SCHEME_CAR(extra_sources))) break; + extra_sources = SCHEME_CDR(extra_sources); } if (!SCHEME_NULLP(extra_sources)) { scheme_wrong_type("raise-syntax-error", "list of syntax", 4, argc, argv); @@ -2044,8 +2045,8 @@ static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]) } scheme_wrong_syntax_with_more_sources(who, - (argc > 3) ? argv[3] : NULL, - (argc > 2) ? argv[2] : NULL, + ((argc > 3) && !SCHEME_FALSEP(argv[3])) ? argv[3] : NULL, + ((argc > 2) && !SCHEME_FALSEP(argv[2])) ? argv[2] : NULL, extra_sources, "%T", str); From aefaaa26d0daba7dd1e49fe21df8b25a6bfc678e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 20:47:49 +0000 Subject: [PATCH 08/13] re-enable code svn: r13612 --- collects/drscheme/syncheck/extra-typed.ss | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/collects/drscheme/syncheck/extra-typed.ss b/collects/drscheme/syncheck/extra-typed.ss index 4e79dc7b21..6c1555dc9f 100644 --- a/collects/drscheme/syncheck/extra-typed.ss +++ b/collects/drscheme/syncheck/extra-typed.ss @@ -17,15 +17,15 @@ [else (let: loop : (Listof Syntax) ([fst : Syntax (car ids)] [rst : (Listof Syntax) (cdr ids)]) - (error 'foo) #;(cond - [(null? rst) (list fst)] - [else (if (and (eq? (syntax-source fst) - (syntax-source (car rst))) - ;; CHANGE - used eqv? instead of =, since these might be #f - (eqv? (syntax-position fst) - (syntax-position (car rst)))) - (loop fst (cdr rst)) - (cons fst (loop (car rst) (cdr rst))))]))])) + (cond + [(null? rst) (list fst)] + [else (if (and (eq? (syntax-source fst) + (syntax-source (car rst))) + ;; CHANGE - used eqv? instead of =, since these might be #f + (eqv? (syntax-position fst) + (syntax-position (car rst)))) + (loop fst (cdr rst)) + (cons fst (loop (car rst) (cdr rst))))]))])) ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean From ed83737d5f6943687c2148457e582dc707363f34 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 21:30:02 +0000 Subject: [PATCH 09/13] subtype caching svn: r13615 --- collects/typed-scheme/private/subtype.ss | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 513c453533..0c2ffdb722 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -40,13 +40,26 @@ (define (remember s t A) (cons (seen-before s t) A)) (define (seen? s t) (member (seen-before s t) (current-seen))) +(define subtype-cache (make-hash)) +(define (cache-types s t) + (cache-keys (Type-seq s) (Type-seq t))) +(define (cache-keys ks kt) + (hash-set! subtype-cache (cons ks kt) #t)) +(define (cached? s t) + (hash-ref subtype-cache (cons (Type-seq s) (Type-seq t)) #f)) ;; is s a subtype of t? ;; type type -> boolean (define (subtype s t) - (with-handlers - ([exn:subtype? (lambda _ #f)]) - (subtype* (current-seen) s t))) + (define k (cons (Type-seq s) (Type-seq t))) + (define lookup? (hash-ref subtype-cache k 'no)) + (if (eq? 'no lookup?) + (let ([result (with-handlers + ([exn:subtype? (lambda _ #f)]) + (subtype* (current-seen) s t))]) + (hash-set! subtype-cache k result) + result) + lookup?)) ;; are all the s's subtypes of all the t's? ;; [type] [type] -> boolean From 2518d54da186c727c23fda674a4ebe6b6080b7ff Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 21:48:41 +0000 Subject: [PATCH 10/13] syncheck.ss now uses typed code svn: r13616 --- collects/drscheme/syncheck.ss | 159 +- collects/drscheme/syncheck/annotate.ss | 634 ---- collects/drscheme/syncheck/color.ss | 84 - collects/drscheme/syncheck/extra-stxcase.ss | 44 - collects/drscheme/syncheck/extra-typed.ss | 288 +- collects/drscheme/syncheck/make-traversal.ss | 86 - collects/drscheme/syncheck/syncheck.ss | 2755 ------------------ 7 files changed, 16 insertions(+), 4034 deletions(-) delete mode 100644 collects/drscheme/syncheck/annotate.ss delete mode 100644 collects/drscheme/syncheck/color.ss delete mode 100644 collects/drscheme/syncheck/extra-stxcase.ss delete mode 100644 collects/drscheme/syncheck/make-traversal.ss delete mode 100644 collects/drscheme/syncheck/syncheck.ss diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 0e8256683e..9e5f4f7707 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -36,6 +36,8 @@ If the namespace does not, they are colored the unbound color. net/url net/uri-codec browser/external + "syncheck/id-sets.ss" + "syncheck/extra-typed.ss" (for-syntax scheme/base)) (provide tool@) @@ -1475,10 +1477,7 @@ If the namespace does not, they are colored the unbound color. tl-require-for-labels)))]) (values expanded-expression expansion-completed))) - - ;; type req/tag = (make-req/tag syntax sexp boolean) - (define-struct req/tag (req-stx req-sexp used?)) - + ;; annotate-basic : syntax ;; namespace ;; string[directory] @@ -2160,25 +2159,6 @@ If the namespace does not, they are colored the unbound color. [enclosing-editor (send editor-snip-admin get-editor)]) (loop enclosing-editor))))]))) - ;; annotate-tail-position/last : (listof syntax) -> void - (define (annotate-tail-position/last orig-stx stxs tail-ht) - (unless (null? stxs) - (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht))) - - ;; annotate-tail-position : syntax -> void - ;; colors the parens (if any) around the argument - ;; to indicate this is a tail call. - (define (annotate-tail-position orig-stx tail-stx tail-ht) - (hash-set! - tail-ht - orig-stx - (cons - tail-stx - (hash-ref - tail-ht - orig-stx - (λ () null))))) - ;; annotate-require-open : namespace string -> (stx -> void) ;; relies on current-module-name-resolver, which in turn depends on ;; current-directory and current-namespace @@ -2225,37 +2205,6 @@ If the namespace does not, they are colored the unbound color. (callback (λ (x y) (fw:handler:edit-file file)))) (void)))) - ;; possible-suffixes : (listof string) - ;; these are the suffixes that are checked for the reverse - ;; module-path mapping. - (define possible-suffixes '(".ss" ".scm" "")) - - ;; module-name-sym->filename : symbol -> (union #f string) - (define (module-name-sym->filename sym) - (let ([str (symbol->string sym)]) - (and ((string-length str) . > . 1) - (char=? (string-ref str 0) #\,) - (let ([fn (substring str 1 (string-length str))]) - (ormap (λ (x) - (let ([test (string->path (string-append fn x))]) - (and (file-exists? test) - test))) - possible-suffixes))))) - - ;; add-origins : sexp id-set -> void - (define (add-origins sexp id-set) - (let ([origin (syntax-property sexp 'origin)]) - (when origin - (let loop ([ct origin]) - (cond - [(pair? ct) - (loop (car ct)) - (loop (cdr ct))] - [(syntax? ct) - (when (syntax-original? ct) - (add-id id-set ct))] - [else (void)]))))) - ;; FIXME: handle for-template and for-label ;; extract-provided-vars : syntax -> (listof syntax[identifier]) (define (extract-provided-vars stx) @@ -2295,42 +2244,6 @@ If the namespace does not, they are colored the unbound color. (syntax module-name)] [_ require-spec])) - (define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y))) - - ;; add-binders : syntax id-set -> void - ;; transforms an argument list into a bunch of symbols/symbols - ;; and puts them into the id-set - ;; effect: colors the identifiers - (define (add-binders stx id-set) - (let loop ([stx stx]) - (let ([e (if (syntax? stx) (syntax-e stx) stx)]) - (cond - [(cons? e) - (let ([fst (car e)] - [rst (cdr e)]) - (if (syntax? fst) - (begin - (when (syntax-original? fst) - (add-id id-set fst)) - (loop rst)) - (loop rst)))] - [(null? e) (void)] - [else - (when (syntax-original? stx) - (add-id id-set stx))])))) - - ;; annotate-raw-keyword : syntax id-map -> void - ;; annotates keywords when they were never expanded. eg. - ;; if someone just types `(λ (x) x)' it has no 'origin - ;; field, but there still are keywords. - (define (annotate-raw-keyword stx id-map) - (let ([lst (syntax-e stx)]) - (when (pair? lst) - (let ([f-stx (car lst)]) - (when (and (syntax-original? f-stx) - (identifier? f-stx)) - (add-id id-map f-stx)))))) - ;; color-internal-structure : syntax str -> void (define (color-internal-structure stx style-name) (let ([ht (make-hasheq)]) @@ -2701,72 +2614,6 @@ If the namespace does not, they are colored the unbound color. (λ (txt) (send txt end-edit-sequence)) txts)))))))) - ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean - ;; returns #t if the name chosen would be the same as another name in this scope. - (define (name-duplication? to-be-renamed id-sets new-str) - (let ([new-ids (map (λ (id) (datum->syntax id (string->symbol new-str))) - to-be-renamed)]) - (ormap (λ (id-set) - (ormap (λ (new-id) (get-ids id-set new-id)) - new-ids)) - id-sets))) - - ;; remove-duplicates : (listof syntax[original]) -> (listof syntax[original]) - ;; removes duplicates, based on the source locations of the identifiers - (define (remove-duplicates ids) - (cond - [(null? ids) null] - [else (let loop ([fst (car ids)] - [rst (cdr ids)]) - (cond - [(null? rst) (list fst)] - [else (if (and (eq? (syntax-source fst) - (syntax-source (car rst))) - (= (syntax-position fst) - (syntax-position (car rst)))) - (loop fst (cdr rst)) - (cons fst (loop (car rst) (cdr rst))))]))])) - - - ; - ; - ; - ; ; ; - ; ; - ; ; ; - ; ; ;; ; ;;; ;;; ;;;; ;;; - ; ; ; ;; ; ; ; ; ; - ; ; ; ; ;; ; ; ; ;; - ; ; ; ; ;; ;;;;;; ; ;; - ; ; ; ; ; ; ; ; - ; ; ; ;; ; ; ; ; - ; ; ;; ; ;;; ;;;; ;; ;;; - ; - ; - ; - - ;; make-id-set : -> id-set - (define (make-id-set) (make-module-identifier-mapping)) - - ;; add-id : id-set identifier -> void - (define (add-id mapping id) - (let* ([old (module-identifier-mapping-get mapping id (λ () '()))] - [new (cons id old)]) - (module-identifier-mapping-put! mapping id new))) - - ;; get-idss : id-set -> (listof (listof identifier)) - (define (get-idss mapping) - (module-identifier-mapping-map mapping (λ (x y) y))) - - ;; get-ids : id-set identifier -> (union (listof identifier) #f) - (define (get-ids mapping var) - (module-identifier-mapping-get mapping var (λ () #f))) - - ;; for-each-ids : id-set ((listof identifier) -> void) -> void - (define (for-each-ids mapping f) - (module-identifier-mapping-for-each mapping (λ (x y) (f y)))) - - ; ; ; diff --git a/collects/drscheme/syncheck/annotate.ss b/collects/drscheme/syncheck/annotate.ss deleted file mode 100644 index 087aba6e3b..0000000000 --- a/collects/drscheme/syncheck/annotate.ss +++ /dev/null @@ -1,634 +0,0 @@ -#lang scheme/base - -(provide (all-defined-out)) - -(require string-constants/string-constant - scheme/unit - scheme/contract - scheme/class - drscheme/tool - mzlib/list - syntax/toplevel - syntax/boundmap - mrlib/bitmap-label - (prefix-in drscheme:arrow: drscheme/arrow) - (prefix-in fw: framework/framework) - mred/mred - setup/xref - scribble/xref - scribble/manual-struct - net/url - net/uri-codec - browser/external - (for-syntax scheme/base) - "extra-stxcase.ss" - "id-sets.ss" - "extra-typed.ss" - "utils.ss") - - - ; - ; - ; - ; ; - ; ; - ; ; ; ; - ; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;; - ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; - ; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;; - ; ; - ; ; - ; ; - - - - ;; annotate-basic : syntax - ;; namespace - ;; string[directory] - ;; syntax[id] - ;; id-set (six of them) - ;; hash-table[require-spec -> syntax] (three of them) - ;; -> void - (define (annotate-basic sexp user-namespace user-directory jump-to-id - low-binders high-binders - low-varrefs high-varrefs - low-tops high-tops - templrefs - requires require-for-syntaxes require-for-templates require-for-labels) - (let ([tail-ht (make-hash-table)] - [maybe-jump - (λ (vars) - (when jump-to-id - (for-each (λ (id) - (let ([binding (identifier-binding id)]) - (when (pair? binding) - (let ([nominal-source-id (list-ref binding 3)]) - (when (eq? nominal-source-id jump-to-id) - (jump-to id)))))) - (syntax->list vars))))]) - - (let level-loop ([sexp sexp] - [high-level? #f]) - (let* ([loop (λ (sexp) (level-loop sexp high-level?))] - [varrefs (if high-level? high-varrefs low-varrefs)] - [binders (if high-level? high-binders low-binders)] - [tops (if high-level? high-tops low-tops)] - [collect-general-info - (λ (stx) - (add-origins stx varrefs) - (add-disappeared-bindings stx binders varrefs) - (add-disappeared-uses stx varrefs))]) - (collect-general-info sexp) - (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! - quote quote-syntax with-continuation-mark - #%plain-app #%top #%plain-module-begin - define-values define-syntaxes define-values-for-syntax module - #%require #%provide #%expression) - (if high-level? free-transformer-identifier=? free-identifier=?) - [(#%plain-lambda args bodies ...) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) - (add-binders (syntax args) binders) - (for-each loop (syntax->list (syntax (bodies ...)))))] - [(case-lambda [argss bodiess ...]...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each (λ (bodies/stx) (annotate-tail-position/last sexp - (syntax->list bodies/stx) - tail-ht)) - (syntax->list (syntax ((bodiess ...) ...)))) - (for-each - (λ (args bodies) - (add-binders args binders) - (for-each loop (syntax->list bodies))) - (syntax->list (syntax (argss ...))) - (syntax->list (syntax ((bodiess ...) ...)))))] - [(if test then else) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax then) tail-ht) - (annotate-tail-position sexp (syntax else) tail-ht) - (loop (syntax test)) - (loop (syntax else)) - (loop (syntax then)))] - [(begin bodies ...) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) - (for-each loop (syntax->list (syntax (bodies ...)))))] - - ;; treat a single body expression specially, since this has - ;; different tail behavior. - [(begin0 body) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax body) tail-ht) - (loop (syntax body)))] - - [(begin0 bodies ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each loop (syntax->list (syntax (bodies ...)))))] - - [(let-values (bindings ...) bs ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each collect-general-info (syntax->list (syntax (bindings ...)))) - (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) - (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) - (for-each (λ (x) (add-binders x binders)) - (syntax->list (syntax ((xss ...) ...)))) - (for-each loop (syntax->list (syntax (es ...)))) - (for-each loop (syntax->list (syntax (bs ...))))))] - [(letrec-values (bindings ...) bs ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each collect-general-info (syntax->list (syntax (bindings ...)))) - (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) - (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) - (for-each (λ (x) (add-binders x binders)) - (syntax->list (syntax ((xss ...) ...)))) - (for-each loop (syntax->list (syntax (es ...)))) - (for-each loop (syntax->list (syntax (bs ...))))))] - [(set! var e) - (begin - (annotate-raw-keyword sexp varrefs) - - ;; tops are used here because a binding free use of a set!'d variable - ;; is treated just the same as (#%top . x). - (when (syntax-original? (syntax var)) - (if (identifier-binding (syntax var)) - (add-id varrefs (syntax var)) - (add-id tops (syntax var)))) - - (loop (syntax e)))] - [(quote datum) - ;(color-internal-structure (syntax datum) constant-style-name) - (annotate-raw-keyword sexp varrefs)] - [(quote-syntax datum) - ;(color-internal-structure (syntax datum) constant-style-name) - (annotate-raw-keyword sexp varrefs) - (let loop ([stx #'datum]) - (cond [(identifier? stx) - (when (syntax-original? stx) - (add-id templrefs stx))] - [(syntax? stx) - (loop (syntax-e stx))] - [(pair? stx) - (loop (car stx)) - (loop (cdr stx))] - [(vector? stx) - (for-each loop (vector->list stx))] - [(box? stx) - (loop (unbox stx))] - [else (void)]))] - [(with-continuation-mark a b c) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax c) tail-ht) - (loop (syntax a)) - (loop (syntax b)) - (loop (syntax c)))] - [(#%plain-app pieces ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each loop (syntax->list (syntax (pieces ...)))))] - [(#%top . var) - (begin - (annotate-raw-keyword sexp varrefs) - (when (syntax-original? (syntax var)) - (add-id tops (syntax var))))] - [(define-values vars b) - (begin - (annotate-raw-keyword sexp varrefs) - (add-binders (syntax vars) binders) - (maybe-jump (syntax vars)) - (loop (syntax b)))] - [(define-syntaxes names exp) - (begin - (annotate-raw-keyword sexp varrefs) - (add-binders (syntax names) binders) - (maybe-jump (syntax names)) - (level-loop (syntax exp) #t))] - [(define-values-for-syntax names exp) - (begin - (annotate-raw-keyword sexp varrefs) - (add-binders (syntax names) high-binders) - (maybe-jump (syntax names)) - (level-loop (syntax exp) #t))] - [(module m-name lang (#%plain-module-begin bodies ...)) - (begin - (annotate-raw-keyword sexp varrefs) - ((annotate-require-open user-namespace user-directory) (syntax lang)) - - ;; temporarily removed until Matthew fixes whatever. - #; - (hash-table-put! requires - (syntax->datum (syntax lang)) - (cons (syntax lang) - (hash-table-get requires - (syntax->datum (syntax lang)) - (λ () '())))) - (for-each loop (syntax->list (syntax (bodies ...)))))] - - ; top level or module top level only: - [(#%require require-specs ...) - (let ([at-phase - (lambda (stx requires) - (syntax-case stx () - [(_ require-specs ...) - (let ([new-specs (map trim-require-prefix - (syntax->list (syntax (require-specs ...))))]) - (annotate-raw-keyword sexp varrefs) - (for-each (annotate-require-open user-namespace user-directory) new-specs) - (for-each (add-require-spec requires) - new-specs - (syntax->list (syntax (require-specs ...)))))]))]) - (for-each (lambda (spec) - (syntax-case* spec (for-syntax for-template for-label) (lambda (a b) - (eq? (syntax-e a) (syntax-e b))) - [(for-syntax specs ...) - (at-phase spec require-for-syntaxes)] - [(for-template specs ...) - (at-phase spec require-for-templates)] - [(for-label specs ...) - (at-phase spec require-for-labels)] - [else - (at-phase (list #f spec) requires)])) - (syntax->list #'(require-specs ...))))] - - ; module top level only: - [(#%provide provide-specs ...) - (let ([provided-varss (map extract-provided-vars - (syntax->list (syntax (provide-specs ...))))]) - (annotate-raw-keyword sexp varrefs) - (for-each (λ (provided-vars) - (for-each - (λ (provided-var) - (when (syntax-original? provided-var) - (add-id varrefs provided-var))) - provided-vars)) - provided-varss))] - - [(#%expression arg) - (begin - (annotate-raw-keyword sexp varrefs) - (loop #'arg))] - [id - (identifier? (syntax id)) - (when (syntax-original? sexp) - (add-id varrefs sexp))] - [_ - (begin - #; - (printf "unknown stx: ~e datum: ~e source: ~e\n" - sexp - (and (syntax? sexp) - (syntax->datum sexp)) - (and (syntax? sexp) - (syntax-source sexp))) - (void))]))) - (add-tail-ht-links tail-ht))) - - ;; jump-to : syntax -> void - (define (jump-to stx) - (let ([src (find-source-editor stx)] - [pos (syntax-position stx)] - [span (syntax-span stx)]) - (when (and (is-a? src text%) - pos - span) - (send src set-position (- pos 1) (+ pos span -1))))) - - - ;; annotate-require-open : namespace string -> (stx -> void) - ;; relies on current-module-name-resolver, which in turn depends on - ;; current-directory and current-namespace - (define (annotate-require-open user-namespace user-directory) - (λ (require-spec) - (when (syntax-original? require-spec) - (let ([source (find-source-editor require-spec)]) - (when (and (is-a? source text%) - (syntax-position require-spec) - (syntax-span require-spec)) - (let ([defs-text (get-defs-text)]) - (when defs-text - (let* ([start (- (syntax-position require-spec) 1)] - [end (+ start (syntax-span require-spec))] - [file (get-require-filename (syntax->datum require-spec) - user-namespace - user-directory)]) - (when file - (send defs-text syncheck:add-menu - source - start end - #f - (make-require-open-menu file))))))))))) - - ;; hash-table[syntax -o> (listof syntax)] -> void - (define (add-tail-ht-links tail-ht) - (hash-table-for-each - tail-ht - (λ (stx-from stx-tos) - (for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to)) - stx-tos)))) - - ;; add-tail-ht-link : syntax syntax -> void - (define (add-tail-ht-link from-stx to-stx) - (let* ([to-src (find-source-editor to-stx)] - [from-src (find-source-editor from-stx)] - [defs-text (get-defs-text)]) - (when (and to-src from-src defs-text) - (let ([from-pos (syntax-position from-stx)] - [to-pos (syntax-position to-stx)]) - (when (and from-pos to-pos) - (send defs-text syncheck:add-tail-arrow - from-src (- from-pos 1) - to-src (- to-pos 1))))))) - - ;; find-source : definitions-text source -> editor or false - (define (find-source-editor stx) - (let ([defs-text (get-defs-text)]) - (and defs-text - (let txt-loop ([text defs-text]) - (cond - [(and (is-a? text fw:text:basic<%>) - (send text port-name-matches? (syntax-source stx))) - text] - [else - (let snip-loop ([snip (send text find-first-snip)]) - (cond - [(not snip) - #f] - [(and (is-a? snip editor-snip%) - (send snip get-editor)) - (or (txt-loop (send snip get-editor)) - (snip-loop (send snip next)))] - [else - (snip-loop (send snip next))]))]))))) - - ;; get-defs-text : -> text or false - (define (get-defs-text) - (let ([drs-frame (currently-processing-drscheme-frame)]) - (and drs-frame - (send drs-frame get-definitions-text)))) - - - - - ;; record-renamable-var : rename-ht syntax -> void - (define (record-renamable-var rename-ht stx) - (let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))]) - (hash-table-put! rename-ht - key - (cons stx (hash-table-get rename-ht key (λ () '())))))) - - - ;; connect-identifier : syntax - ;; id-set - ;; (union #f hash-table) - ;; (union #f hash-table) - ;; (union identifier-binding identifier-transformer-binding) - ;; (listof id-set) - ;; namespace - ;; directory - ;; boolean - ;; -> void - ;; adds arrows and rename menus for binders/bindings - (define (connect-identifier var rename-ht all-binders unused requires get-binding user-namespace user-directory actual?) - (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) - (when (and actual? (get-ids all-binders var)) - (record-renamable-var rename-ht var))) - - ;; connect-identifier/arrow : syntax - ;; id-set - ;; (union #f hash-table) - ;; (union #f hash-table) - ;; (union identifier-binding identifier-transformer-binding) - ;; boolean - ;; -> void - ;; adds the arrows that correspond to binders/bindings - (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) - (let ([binders (get-ids all-binders var)]) - (when binders - (for-each (λ (x) - (when (syntax-original? x) - (connect-syntaxes x var actual?))) - binders)) - - (when (and unused requires) - (let ([req-path/pr (get-module-req-path (get-binding var))]) - (when req-path/pr - (let* ([req-path (car req-path/pr)] - [id (cdr req-path/pr)] - [req-stxes (hash-table-get requires req-path (λ () #f))]) - (when req-stxes - (hash-table-remove! unused req-path) - (for-each (λ (req-stx) - (when (id/require-match? (syntax->datum var) - id - (syntax->datum req-stx)) - (when id - (add-jump-to-definition - var - id - (get-require-filename req-path user-namespace user-directory))) - (add-mouse-over var (fw:gui-utils:format-literal-label (string-constant cs-mouse-over-import) - (syntax-e var) - req-path)) - (connect-syntaxes req-stx var actual?))) - req-stxes)))))))) - - (define (id/require-match? var id req-stx) - (cond - [(and (pair? req-stx) - (eq? (list-ref req-stx 0) 'prefix)) - (let ([prefix (list-ref req-stx 1)]) - (equal? (format "~a~a" prefix id) - (symbol->string var)))] - [(and (pair? req-stx) - (eq? (list-ref req-stx 0) 'prefix-all-except)) - (let ([prefix (list-ref req-stx 1)]) - (and (not (memq id (cdddr req-stx))) - (equal? (format "~a~a" prefix id) - (symbol->string var))))] - [(and (pair? req-stx) - (eq? (list-ref req-stx 0) 'rename)) - (eq? (list-ref req-stx 2) - var)] - [else (eq? var id)])) - - - ;; color/connect-top : namespace directory id-set syntax -> void - (define (color/connect-top rename-ht user-namespace user-directory binders var) - (let ([top-bound? - (or (get-ids binders var) - (parameterize ([current-namespace user-namespace]) - (let/ec k - (namespace-variable-value (syntax-e var) #t (λ () (k #f))) - #t)))]) - (if top-bound? - (color var lexically-bound-variable-style-name) - (color var error-style-name)) - (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t))) - - - ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void - (define (color-unused requires unused) - (hash-table-for-each - unused - (λ (k v) - (for-each (λ (stx) (color stx error-style-name)) - (hash-table-get requires k))))) - - - - - ; - ; - ; - ; ; - ; ; - ; - ; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; - ; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;; - ; ; - ; ; ; - ; ;;; - - - ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void - (define (make-rename-menu stxs id-sets) - (let ([defs-frame (currently-processing-drscheme-frame)]) - (when defs-frame - (let* ([defs-text (send defs-frame get-definitions-text)] - [source (syntax-source (car stxs))]) ;; all stxs in the list must have the same source - (when (and (send defs-text port-name-matches? source) - (send defs-text port-name-matches? source)) - (let* ([name-to-offer (format "~a" (syntax->datum (car stxs)))] - [start (- (syntax-position (car stxs)) 1)] - [fin (+ start (syntax-span (car stxs)))]) - (send defs-text syncheck:add-menu - defs-text - start - fin - (syntax-e (car stxs)) - (λ (menu) - (instantiate menu-item% () - (parent menu) - (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) - (callback - (λ (x y) - (let ([frame-parent (find-menu-parent menu)]) - (rename-callback name-to-offer - defs-text - stxs - id-sets - frame-parent))))))))))))) - - ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) - (define (find-menu-parent menu) - (let loop ([menu menu]) - (cond - [(is-a? menu menu-bar%) (send menu get-frame)] - [(is-a? menu popup-menu%) - (let ([target (send menu get-popup-target)]) - (cond - [(is-a? target editor<%>) - (let ([canvas (send target get-canvas)]) - (and canvas - (send canvas get-top-level-window)))] - [(is-a? target window<%>) - (send target get-top-level-window)] - [else #f]))] - [(is-a? menu menu-item<%>) (loop (send menu get-parent))] - [else #f]))) - - ;; rename-callback : string - ;; (and/c syncheck-text<%> definitions-text<%>) - ;; (listof syntax[original]) - ;; (listof id-set) - ;; (union #f (is-a?/c top-level-window<%>)) - ;; -> void - ;; callback for the rename popup menu item - (define (rename-callback name-to-offer defs-text stxs id-sets parent) - (let ([new-str - (fw:keymap:call/text-keymap-initializer - (λ () - (get-text-from-user - (string-constant cs-rename-id) - (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) - parent - name-to-offer)))]) - (when new-str - (let ([new-sym (format "~s" (string->symbol new-str))]) - (let* ([to-be-renamed - (remove-duplicates - (sort - (apply - append - (map (λ (id-set) - (apply - append - (map (λ (stx) (or (get-ids id-set stx) '())) stxs))) - id-sets)) - (λ (x y) - ((syntax-position x) . >= . (syntax-position y)))))] - [do-renaming? - (or (not (name-duplication? to-be-renamed id-sets new-sym)) - (equal? - (message-box/custom - (string-constant check-syntax) - (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) - new-sym) - (string-constant cs-rename-anyway) - (string-constant cancel) - #f - parent - '(stop default=2)) - 1))]) - (when do-renaming? - (unless (null? to-be-renamed) - (send defs-text begin-edit-sequence) - (for-each (λ (stx) - (let ([source (syntax-source stx)]) - (when (send defs-text port-name-matches? source) - (let* ([start (- (syntax-position stx) 1)] - [end (+ start (syntax-span stx))]) - (send defs-text delete start end #f) - (send defs-text insert new-sym start start #f))))) - to-be-renamed) - (send defs-text invalidate-bitmap-cache) - (send defs-text end-edit-sequence)))))))) - - ;; get-require-filename : sexp namespace string[directory] -> filename - ;; finds the filename corresponding to the require in stx - (define (get-require-filename datum user-namespace user-directory) - (let ([mp - (parameterize ([current-namespace user-namespace] - [current-directory user-directory] - [current-load-relative-directory user-directory]) - (with-handlers ([exn:fail? (λ (x) #f)]) - ((current-module-name-resolver) datum #f #f)))]) - (and (resolved-module-path? mp) - (resolved-module-path-name mp)))) - - - ;; make-require-open-menu : path -> menu -> void - (define (make-require-open-menu file) - (λ (menu) - (let-values ([(base name dir?) (split-path file)]) - (instantiate menu-item% () - (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) - (parent menu) - (callback (λ (x y) (fw:handler:edit-file file)))) - (void)))) \ No newline at end of file diff --git a/collects/drscheme/syncheck/color.ss b/collects/drscheme/syncheck/color.ss deleted file mode 100644 index a1c6ef45a9..0000000000 --- a/collects/drscheme/syncheck/color.ss +++ /dev/null @@ -1,84 +0,0 @@ -#lang scheme/base - -(require string-constants/string-constant - scheme/unit - scheme/contract - scheme/class - drscheme/tool - mzlib/list - syntax/toplevel - syntax/boundmap - mrlib/bitmap-label - (prefix-in drscheme:arrow: drscheme/arrow) - (prefix-in fw: framework/framework) - mred/mred - setup/xref - scribble/xref - scribble/manual-struct - net/url - net/uri-codec - browser/external - (for-syntax scheme/base) - "extra-stxcase.ss" - "id-sets.ss" - "extra-typed.ss") -;; color : syntax[original] str -> void -;; colors the syntax with style-name's style -(define (color stx style-name) - (let ([source (find-source-editor stx)]) - (when (is-a? source text%) - (let ([pos (- (syntax-position stx) 1)] - [span (syntax-span stx)]) - (color-range source pos (+ pos span) style-name))))) - -;; color-range : text start finish style-name -;; colors a range in the text based on `style-name' -(define (color-range source start finish style-name) - (let ([style (send (send source get-style-list) - find-named-style - style-name)]) - (add-to-cleanup-texts source) - (send source change-style style start finish #f))) - - ;; find-source : definitions-text source -> editor or false - (define (find-source-editor stx) - (let ([defs-text (get-defs-text)]) - (and defs-text - (let txt-loop ([text defs-text]) - (cond - [(and (is-a? text fw:text:basic<%>) - (send text port-name-matches? (syntax-source stx))) - text] - [else - (let snip-loop ([snip (send text find-first-snip)]) - (cond - [(not snip) - #f] - [(and (is-a? snip editor-snip%) - (send snip get-editor)) - (or (txt-loop (send snip get-editor)) - (snip-loop (send snip next)))] - [else - (snip-loop (send snip next))]))]))))) - -;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void - (define (add-to-cleanup-texts ed) - (let ([ed (find-outermost-editor ed)]) - (when (is-a? ed drscheme:unit:definitions-text<%>) - (let ([tab (send ed get-tab)]) - (send tab syncheck:add-to-cleanup-texts ed))))) - - ;; get-defs-text : -> text or false - (define (get-defs-text) - (let ([drs-frame (currently-processing-drscheme-frame)]) - (and drs-frame - (send drs-frame get-definitions-text)))) - - (define (find-outermost-editor ed) - (let loop ([ed ed]) - (let ([admin (send ed get-admin)]) - (if (is-a? admin editor-snip-editor-admin<%>) - (let* ([enclosing-snip (send admin get-snip)] - [enclosing-snip-admin (send enclosing-snip get-admin)]) - (loop (send enclosing-snip-admin get-editor))) - ed)))) \ No newline at end of file diff --git a/collects/drscheme/syncheck/extra-stxcase.ss b/collects/drscheme/syncheck/extra-stxcase.ss deleted file mode 100644 index d5ac6927cc..0000000000 --- a/collects/drscheme/syncheck/extra-stxcase.ss +++ /dev/null @@ -1,44 +0,0 @@ -#lang scheme/base - -(require (only-in "extra-typed.ss" symbolic-compare?)) - -(provide (all-defined-out)) - -;; FIXME: handle for-template and for-label -;; extract-provided-vars : syntax -> (listof syntax[identifier]) -(define (extract-provided-vars stx) - (syntax-case* stx (rename struct all-from all-from-except all-defined-except) symbolic-compare? - [identifier - (identifier? (syntax identifier)) - (list (syntax identifier))] - - [(rename local-identifier export-identifier) - (list (syntax local-identifier))] - - ;; why do I even see this?!? - [(struct struct-identifier (field-identifier ...)) - null] - - [(all-from module-name) null] - [(all-from-except module-name identifier ...) - null] - [(all-defined-except identifier ...) - (syntax->list #'(identifier ...))] - [_ - null])) - - -;; trim-require-prefix : syntax -> syntax -(define (trim-require-prefix require-spec) - (syntax-case* require-spec (only prefix all-except prefix-all-except rename) symbolic-compare? - [(only module-name identifer ...) - (syntax module-name)] - [(prefix identifier module-name) - (syntax module-name)] - [(all-except module-name identifer ...) - (syntax module-name)] - [(prefix-all-except module-name identifer ...) - (syntax module-name)] - [(rename module-name local-identifer exported-identifer) - (syntax module-name)] - [_ require-spec])) \ No newline at end of file diff --git a/collects/drscheme/syncheck/extra-typed.ss b/collects/drscheme/syncheck/extra-typed.ss index 6c1555dc9f..6d2a4d3f93 100644 --- a/collects/drscheme/syncheck/extra-typed.ss +++ b/collects/drscheme/syncheck/extra-typed.ss @@ -79,7 +79,6 @@ (define-type-alias TailHT (HashTable Syntax (Listof Syntax))) -;; annotate-tail-position/last : (listof syntax) -> void (: annotate-tail-position/last (Syntax (Listof Syntax) TailHT -> Void)) (define (annotate-tail-position/last orig-stx stxs tail-ht) (unless (null? stxs) @@ -100,7 +99,19 @@ orig-stx (λ () null))))) -;; add-disappeared-uses : syntax id-set -> void +(: add-disappeared-bindings (Syntax Id-Set Id-Set -> Void)) +(define (add-disappeared-bindings stx binders disappaeared-uses) + (let ([prop (syntax-property stx 'disappeared-binding)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-origins prop disappaeared-uses) + (add-id binders prop)]))))) + (: add-disappeared-uses (Syntax Id-Set -> Void)) (define (add-disappeared-uses stx id-set) (let ([prop (syntax-property stx 'disappeared-use)]) @@ -129,13 +140,11 @@ key (λ () '())))))))) -;; possible-suffixes : (listof string) ;; these are the suffixes that are checked for the reverse ;; module-path mapping. (: possible-suffixes (Listof String)) (define possible-suffixes '(".ss" ".scm" "")) -;; add-origins : sexp id-set -> void (: add-origins (Syntax Id-Set -> Void)) (define (add-origins sexp id-set) (let ([origin (syntax-property sexp 'origin)]) @@ -151,21 +160,6 @@ [else (void)]))))) -;; add-disappeared-bindings : syntax id-set -> void -(: add-disappeared-bindings (Syntax Id-Set Id-Set -> Void)) -(define (add-disappeared-bindings stx binders disappaeared-uses) - (let ([prop (syntax-property stx 'disappeared-binding)]) - (when prop - (let loop ([prop prop]) - (cond - [(pair? prop) - (loop (car prop)) - (loop (cdr prop))] - [(identifier? prop) - (add-origins prop disappaeared-uses) - (add-id binders prop)]))))) - -;; module-name-sym->filename : symbol -> (union #f string) (: module-name-sym->filename (Symbol -> (Option Path))) (define (module-name-sym->filename sym) (let ([str (symbol->string sym)]) @@ -193,259 +187,3 @@ [prev (hash-ref ht #{key :: Any} (λ () #{null :: (Listof Any)}))]) (hash-set! ht #{key :: Any} #{(cons var prev) :: (Listof Any)})))) -#| -;; annotate-basic : syntax -;; namespace -;; string[directory] -;; syntax[id] -;; id-set (six of them) -;; hash-table[require-spec -> syntax] (three of them) -;; -> void -(: annotate-basic (Syntax - Any String Syntax - Id-Set Id-Set Id-Set Id-Set Id-Set Id-Set - Any - (HashTable Syntax Syntax) (HashTable Syntax Syntax) (HashTable Syntax Syntax) (HashTable Syntax Syntax) - -> Void)) -(define (annotate-basic sexp user-namespace user-directory jump-to-id - low-binders high-binders - low-varrefs high-varrefs - low-tops high-tops - templrefs - requires require-for-syntaxes require-for-templates require-for-labels) - (let ([tail-ht (make-hash-table)] - [maybe-jump - (λ: ([vars : Syntax]) - (when jump-to-id - (for-each (λ: ([id : Identifier]) - (let ([binding (identifier-binding id)]) - (when (pair? binding) - (let ([nominal-source-id (list-ref binding 3)]) - (when (eq? nominal-source-id jump-to-id) - (jump-to id)))))) - (syntax->list vars))))]) - - (let level-loop ([sexp sexp] - [high-level? #f]) - (let* ([loop (λ (sexp) (level-loop sexp high-level?))] - [varrefs (if high-level? high-varrefs low-varrefs)] - [binders (if high-level? high-binders low-binders)] - [tops (if high-level? high-tops low-tops)] - [collect-general-info - (λ (stx) - (add-origins stx varrefs) - (add-disappeared-bindings stx binders varrefs) - (add-disappeared-uses stx varrefs))]) - (collect-general-info sexp) - (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! - quote quote-syntax with-continuation-mark - #%plain-app #%top #%plain-module-begin - define-values define-syntaxes define-values-for-syntax module - #%require #%provide #%expression) - (if high-level? free-transformer-identifier=? free-identifier=?) - [(#%plain-lambda args bodies ...) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) - (add-binders (syntax args) binders) - (for-each loop (syntax->list (syntax (bodies ...)))))] - [(case-lambda [argss bodiess ...]...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each (λ (bodies/stx) (annotate-tail-position/last sexp - (syntax->list bodies/stx) - tail-ht)) - (syntax->list (syntax ((bodiess ...) ...)))) - (for-each - (λ (args bodies) - (add-binders args binders) - (for-each loop (syntax->list bodies))) - (syntax->list (syntax (argss ...))) - (syntax->list (syntax ((bodiess ...) ...)))))] - [(if test then else) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax then) tail-ht) - (annotate-tail-position sexp (syntax else) tail-ht) - (loop (syntax test)) - (loop (syntax else)) - (loop (syntax then)))] - [(begin bodies ...) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) - (for-each loop (syntax->list (syntax (bodies ...)))))] - - ;; treat a single body expression specially, since this has - ;; different tail behavior. - [(begin0 body) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax body) tail-ht) - (loop (syntax body)))] - - [(begin0 bodies ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each loop (syntax->list (syntax (bodies ...)))))] - - [(let-values (bindings ...) bs ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each collect-general-info (syntax->list (syntax (bindings ...)))) - (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) - (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) - (for-each (λ (x) (add-binders x binders)) - (syntax->list (syntax ((xss ...) ...)))) - (for-each loop (syntax->list (syntax (es ...)))) - (for-each loop (syntax->list (syntax (bs ...))))))] - [(letrec-values (bindings ...) bs ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each collect-general-info (syntax->list (syntax (bindings ...)))) - (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) - (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) - (for-each (λ (x) (add-binders x binders)) - (syntax->list (syntax ((xss ...) ...)))) - (for-each loop (syntax->list (syntax (es ...)))) - (for-each loop (syntax->list (syntax (bs ...))))))] - [(set! var e) - (begin - (annotate-raw-keyword sexp varrefs) - - ;; tops are used here because a binding free use of a set!'d variable - ;; is treated just the same as (#%top . x). - (when (syntax-original? (syntax var)) - (if (identifier-binding (syntax var)) - (add-id varrefs (syntax var)) - (add-id tops (syntax var)))) - - (loop (syntax e)))] - [(quote datum) - ;(color-internal-structure (syntax datum) constant-style-name) - (annotate-raw-keyword sexp varrefs)] - [(quote-syntax datum) - ;(color-internal-structure (syntax datum) constant-style-name) - (annotate-raw-keyword sexp varrefs) - (let loop ([stx #'datum]) - (cond [(identifier? stx) - (when (syntax-original? stx) - (add-id templrefs stx))] - [(syntax? stx) - (loop (syntax-e stx))] - [(pair? stx) - (loop (car stx)) - (loop (cdr stx))] - [(vector? stx) - (for-each loop (vector->list stx))] - [(box? stx) - (loop (unbox stx))] - [else (void)]))] - [(with-continuation-mark a b c) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax c) tail-ht) - (loop (syntax a)) - (loop (syntax b)) - (loop (syntax c)))] - [(#%plain-app pieces ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each loop (syntax->list (syntax (pieces ...)))))] - [(#%top . var) - (begin - (annotate-raw-keyword sexp varrefs) - (when (syntax-original? (syntax var)) - (add-id tops (syntax var))))] - [(define-values vars b) - (begin - (annotate-raw-keyword sexp varrefs) - (add-binders (syntax vars) binders) - (maybe-jump (syntax vars)) - (loop (syntax b)))] - [(define-syntaxes names exp) - (begin - (annotate-raw-keyword sexp varrefs) - (add-binders (syntax names) binders) - (maybe-jump (syntax names)) - (level-loop (syntax exp) #t))] - [(define-values-for-syntax names exp) - (begin - (annotate-raw-keyword sexp varrefs) - (add-binders (syntax names) high-binders) - (maybe-jump (syntax names)) - (level-loop (syntax exp) #t))] - [(module m-name lang (#%plain-module-begin bodies ...)) - (begin - (annotate-raw-keyword sexp varrefs) - ((annotate-require-open user-namespace user-directory) (syntax lang)) - - ;; temporarily removed until Matthew fixes whatever. - #; - (hash-table-put! requires - (syntax->datum (syntax lang)) - (cons (syntax lang) - (hash-table-get requires - (syntax->datum (syntax lang)) - (λ () '())))) - (for-each loop (syntax->list (syntax (bodies ...)))))] - - ; top level or module top level only: - [(#%require require-specs ...) - (let ([at-phase - (lambda (stx requires) - (syntax-case stx () - [(_ require-specs ...) - (let ([new-specs (map trim-require-prefix - (syntax->list (syntax (require-specs ...))))]) - (annotate-raw-keyword sexp varrefs) - (for-each (annotate-require-open user-namespace user-directory) new-specs) - (for-each (add-require-spec requires) - new-specs - (syntax->list (syntax (require-specs ...)))))]))]) - (for-each (lambda (spec) - (syntax-case* spec (for-syntax for-template for-label) (lambda (a b) - (eq? (syntax-e a) (syntax-e b))) - [(for-syntax specs ...) - (at-phase spec require-for-syntaxes)] - [(for-template specs ...) - (at-phase spec require-for-templates)] - [(for-label specs ...) - (at-phase spec require-for-labels)] - [else - (at-phase (list #f spec) requires)])) - (syntax->list #'(require-specs ...))))] - - ; module top level only: - [(#%provide provide-specs ...) - (let ([provided-varss (map extract-provided-vars - (syntax->list (syntax (provide-specs ...))))]) - (annotate-raw-keyword sexp varrefs) - (for-each (λ (provided-vars) - (for-each - (λ (provided-var) - (when (syntax-original? provided-var) - (add-id varrefs provided-var))) - provided-vars)) - provided-varss))] - - [(#%expression arg) - (begin - (annotate-raw-keyword sexp varrefs) - (loop #'arg))] - [id - (identifier? (syntax id)) - (when (syntax-original? sexp) - (add-id varrefs sexp))] - [_ - (begin - #; - (printf "unknown stx: ~e datum: ~e source: ~e\n" - sexp - (and (syntax? sexp) - (syntax->datum sexp)) - (and (syntax? sexp) - (syntax-source sexp))) - (void))]))) - (add-tail-ht-links tail-ht))) -|# diff --git a/collects/drscheme/syncheck/make-traversal.ss b/collects/drscheme/syncheck/make-traversal.ss deleted file mode 100644 index efe7dd3dff..0000000000 --- a/collects/drscheme/syncheck/make-traversal.ss +++ /dev/null @@ -1,86 +0,0 @@ -#lang scheme/base - -(require "id-sets.ss" - "annotate.ss") - -;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void) -;; (namespace string[directory] -> void)) -;; returns a pair of functions that close over some state that -;; represents the top-level of a single program. The first value -;; is called once for each top-level expression and the second -;; value is called once, after all expansion is complete. -(define (make-traversal) - (let* ([tl-low-binders (make-id-set)] - [tl-high-binders (make-id-set)] - [tl-low-varrefs (make-id-set)] - [tl-high-varrefs (make-id-set)] - [tl-low-tops (make-id-set)] - [tl-high-tops (make-id-set)] - [tl-templrefs (make-id-set)] - [tl-requires (make-hash-table 'equal)] - [tl-require-for-syntaxes (make-hash-table 'equal)] - [tl-require-for-templates (make-hash-table 'equal)] - [tl-require-for-labels (make-hash-table 'equal)] - [expanded-expression - (λ (user-namespace user-directory sexp jump-to-id) - (parameterize ([current-load-relative-directory user-directory]) - (let ([is-module? (syntax-case sexp (module) - [(module . rest) #t] - [else #f])]) - (cond - [is-module? - (let ([low-binders (make-id-set)] - [high-binders (make-id-set)] - [varrefs (make-id-set)] - [high-varrefs (make-id-set)] - [low-tops (make-id-set)] - [high-tops (make-id-set)] - [templrefs (make-id-set)] - [requires (make-hash-table 'equal)] - [require-for-syntaxes (make-hash-table 'equal)] - [require-for-templates (make-hash-table 'equal)] - [require-for-labels (make-hash-table 'equal)]) - (annotate-basic sexp user-namespace user-directory jump-to-id - low-binders high-binders varrefs high-varrefs low-tops high-tops - templrefs - requires require-for-syntaxes require-for-templates require-for-labels) - (annotate-variables user-namespace - user-directory - low-binders - high-binders - varrefs - high-varrefs - low-tops - high-tops - templrefs - requires - require-for-syntaxes - require-for-templates - require-for-labels))] - [else - (annotate-basic sexp user-namespace user-directory jump-to-id - tl-low-binders tl-high-binders - tl-low-varrefs tl-high-varrefs - tl-low-tops tl-high-tops - tl-templrefs - tl-requires - tl-require-for-syntaxes - tl-require-for-templates - tl-require-for-labels)]))))] - [expansion-completed - (λ (user-namespace user-directory) - (parameterize ([current-load-relative-directory user-directory]) - (annotate-variables user-namespace - user-directory - tl-low-binders - tl-high-binders - tl-low-varrefs - tl-high-varrefs - tl-low-tops - tl-high-tops - tl-templrefs - tl-requires - tl-require-for-syntaxes - tl-require-for-templates - tl-require-for-labels)))]) - (values expanded-expression expansion-completed))) \ No newline at end of file diff --git a/collects/drscheme/syncheck/syncheck.ss b/collects/drscheme/syncheck/syncheck.ss deleted file mode 100644 index 0e5055440d..0000000000 --- a/collects/drscheme/syncheck/syncheck.ss +++ /dev/null @@ -1,2755 +0,0 @@ -#lang scheme/base -#| - -Check Syntax separates two classes of identifiers, -those bound in this file and those bound by require, -and uses identifier-binding and identifier-transformer-binding -to distinguish them. - -Variables come from 'origin, 'disappeared-use, and 'disappeared-binding -syntax properties, as well as from variable references and binding (letrec-values, -let-values, define-values) in the fully expanded text. - -Variables inside #%top (not inside a module) are treated specially. -If the namespace has a binding for them, they are colored bound color. -If the namespace does not, they are colored the unbound color. - -|# - - -(require string-constants - scheme/unit - scheme/contract - scheme/class - drscheme/tool - mzlib/list - syntax/toplevel - syntax/boundmap - mrlib/switchable-button - (prefix-in drscheme:arrow: drscheme/arrow) - (prefix-in fw: framework/framework) - mred - framework - setup/xref - scribble/xref - scribble/manual-struct - net/url - net/uri-codec - browser/external - (for-syntax scheme/base)) -(provide tool@) - -(define o (current-output-port)) - -(define status-init (string-constant cs-status-init)) -(define status-coloring-program (string-constant cs-status-coloring-program)) -(define status-eval-compile-time (string-constant cs-status-eval-compile-time)) -(define status-expanding-expression (string-constant cs-status-expanding-expression)) -(define status-loading-docs-index (string-constant cs-status-loading-docs-index)) - -(define jump-to-next-bound-occurrence (string-constant cs-jump-to-next-bound-occurrence)) -(define jump-to-binding (string-constant cs-jump-to-binding)) -(define jump-to-definition (string-constant cs-jump-to-definition)) - -(define-local-member-name - syncheck:init-arrows - syncheck:clear-arrows - syncheck:add-menu - syncheck:add-arrow - syncheck:add-tail-arrow - syncheck:add-mouse-over-status - syncheck:add-jump-to-definition - syncheck:sort-bindings-table - syncheck:jump-to-next-bound-occurrence - syncheck:jump-to-binding-occurrence - syncheck:jump-to-definition - - syncheck:clear-highlighting - syncheck:button-callback - syncheck:add-to-cleanup-texts - ;syncheck:error-report-visible? ;; test suite uses this one. - ;syncheck:get-bindings-table ;; test suite uses this one. - syncheck:clear-error-message - - hide-error-report - get-error-report-text - get-error-report-visible? - - turn-off-error-report - turn-on-error-report - - update-button-visibility/settings) - -(define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - - ;; use this to communicate the frame being - ;; syntax checked w/out having to add new - ;; parameters to all of the functions - (define currently-processing-definitions-text (make-parameter #f)) - - (define (phase1) - (drscheme:unit:add-to-program-editor-mixin clearing-text-mixin)) - (define (phase2) (void)) - - (define (printf . args) (apply fprintf o args)) - - - (define xref 'not-yet-loaded-xref) - (define (get-xref) - (cond - [(equal? xref 'failed-to-load) #f] - [else - (when (symbol? xref) - (error 'get-xref "xref has not yet been loaded")) - xref])) - (define (force-xref th) - (cond - [(equal? xref 'failed-to-load) - (void)] - [(symbol? xref) - (th) - (with-handlers ((exn? (λ (exn) (set! xref 'failed-to-load)))) - (set! xref (load-collections-xref)))] - [else - (void)])) - - - - ;;; ;;; ;;; ;;;;; - ; ; ; ; ; - ; ; ; ; ; - ; ; ; ; - ; ;; ; ; ; - ; ; ; ; ; - ; ; ;; ;; ; - ;;; ;;; ;;;;; - - - ;; used for quicker debugging of the preference panel - '(define test-preference-panel - (λ (name f) - (let ([frame (make-object frame% name)]) - (f frame) - (send frame show #t)))) - - (define-struct graphic (pos* locs->thunks draw-fn click-fn)) - - (define-struct arrow (start-x start-y end-x end-y) #:mutable) - (define-struct (var-arrow arrow) - (start-text start-pos-left start-pos-right - end-text end-pos-left end-pos-right - actual? level)) ;; level is one of 'lexical, 'top-level, 'import - (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos)) - - ;; color : string - ;; text: text:basic<%> - ;; start, fin: number - ;; used to represent regions to highlight when passing the mouse over the syncheck window - (define-struct colored-region (color text start fin)) - - ;; id : symbol -- the nominal-source-id from identifier-binding - ;; filename : path - (define-struct def-link (id filename) #:inspector (make-inspector)) - - (define tacked-var-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)) - (define var-pen (send the-pen-list find-or-create-pen "BLUE" 1 'solid)) - - (define templ-color (send the-color-database find-color "purple")) - (define templ-pen (send the-pen-list find-or-create-pen templ-color 1 'solid)) - (define tacked-templ-brush (send the-brush-list find-or-create-brush templ-color 'solid)) - - (define tail-pen (send the-pen-list find-or-create-pen "orchid" 1 'solid)) - (define tacked-tail-brush (send the-brush-list find-or-create-brush "orchid" 'solid)) - (define untacked-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) - - (define syncheck-text<%> - (interface () - syncheck:init-arrows - syncheck:clear-arrows - syncheck:add-menu - syncheck:add-arrow - syncheck:add-tail-arrow - syncheck:add-mouse-over-status - syncheck:add-jump-to-definition - syncheck:sort-bindings-table - syncheck:get-bindings-table - syncheck:jump-to-next-bound-occurrence - syncheck:jump-to-binding-occurrence - syncheck:jump-to-definition)) - - ;; clearing-text-mixin : (mixin text%) - ;; overrides methods that make sure the arrows go away appropriately. - ;; adds a begin/end-edit-sequence to the insertion and deletion - ;; to ensure that the on-change method isn't called until after - ;; the arrows are cleared. - (define clearing-text-mixin - (mixin ((class->interface text%)) () - - (inherit begin-edit-sequence end-edit-sequence) - (define/augment (on-delete start len) - (begin-edit-sequence) - (inner (void) on-delete start len)) - (define/augment (after-delete start len) - (inner (void) after-delete start len) - (clean-up) - (end-edit-sequence)) - - (define/augment (on-insert start len) - (begin-edit-sequence) - (inner (void) on-insert start len)) - (define/augment (after-insert start len) - (inner (void) after-insert start len) - (clean-up) - (end-edit-sequence)) - - (define/private (clean-up) - (let ([st (find-syncheck-text this)]) - (when (and st - (is-a? st drscheme:unit:definitions-text<%>)) - (let ([tab (send st get-tab)]) - (send tab syncheck:clear-error-message) - (send tab syncheck:clear-highlighting))))) - - (super-new))) - - (define make-syncheck-text% - (λ (super%) - (let* ([cursor-arrow (make-object cursor% 'arrow)]) - (class* super% (syncheck-text<%>) - (inherit set-cursor get-admin invalidate-bitmap-cache set-position - get-pos/text position-location - get-canvas last-position dc-location-to-editor-location - find-position begin-edit-sequence end-edit-sequence - highlight-range unhighlight-range - paragraph-end-position first-line-currently-drawn-specially?) - - - - ;; arrow-vectors : - ;; (union - ;; #f - ;; (hash-table - ;; (text% - ;; . -o> . - ;; (vector (listof (union (cons (union #f sym) (menu -> void)) - ;; def-link - ;; tail-link - ;; arrow - ;; string)))))) - (define arrow-vectors #f) - - - ;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))] - ;; this is a private field - (define bindings-table (make-hash)) - - ;; add-to-bindings-table : text number number text number number -> boolean - ;; results indicates if the binding was added to the table. It is added, unless - ;; 1) it is already there, or - ;; 2) it is a link to itself - (define/private (add-to-bindings-table start-text start-left start-right - end-text end-left end-right) - (cond - [(and (object=? start-text end-text) - (= start-left end-left) - (= start-right end-right)) - #f] - [else - (let* ([key (list start-text start-left start-right)] - [priors (hash-ref bindings-table key (λ () '()))] - [new (list end-text end-left end-right)]) - (cond - [(member new priors) - #f] - [else - (hash-set! bindings-table key (cons new priors)) - #t]))])) - - ;; for use in the automatic test suite - (define/public (syncheck:get-bindings-table) bindings-table) - - (define/public (syncheck:sort-bindings-table) - - ;; compare-bindings : (list text number number) (list text number number) -> boolean - (define (compare-bindings l1 l2) - (let ([start-text (list-ref l1 0)] - [start-left (list-ref l1 1)] - [end-text (list-ref l2 0)] - [end-left (list-ref l2 1)]) - (let-values ([(sx sy) (find-dc-location start-text start-left)] - [(ex ey) (find-dc-location end-text end-left)]) - (cond - [(= sy ey) (< sx ex)] - [else (< sy ey)])))) - - ;; find-dc-location : text number -> (values number number) - (define (find-dc-location text pos) - (let ([bx (box 0)] - [by (box 0)]) - (send text position-location pos bx by) - (send text editor-location-to-dc-location (unbox bx) (unbox by)))) - - (hash-for-each - bindings-table - (λ (k v) - (hash-set! bindings-table k (sort v compare-bindings))))) - - (define tacked-hash-table (make-hasheq)) - (define cursor-location #f) - (define cursor-text #f) - (define cursor-eles #f) - - ;; find-char-box : text number number -> (values number number number number) - ;; returns the bounding box (left, top, right, bottom) for the text range. - ;; only works right if the text is on a single line. - (define/private (find-char-box text left-pos right-pos) - (let ([xlb (box 0)] - [ylb (box 0)] - [xrb (box 0)] - [yrb (box 0)]) - (send text position-location left-pos xlb ylb #t) - (send text position-location right-pos xrb yrb #f) - (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] - [(xl yl) (dc-location-to-editor-location xl-off yl-off)] - [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] - [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) - (values - xl - yl - xr - yr)))) - - (define/private (update-arrow-poss arrow) - (cond - [(var-arrow? arrow) (update-var-arrow-poss arrow)] - [(tail-arrow? arrow) (update-tail-arrow-poss arrow)])) - - (define/private (update-var-arrow-poss arrow) - (let-values ([(start-x start-y) (find-poss - (var-arrow-start-text arrow) - (var-arrow-start-pos-left arrow) - (var-arrow-start-pos-right arrow))] - [(end-x end-y) (find-poss - (var-arrow-end-text arrow) - (var-arrow-end-pos-left arrow) - (var-arrow-end-pos-right arrow))]) - (set-arrow-start-x! arrow start-x) - (set-arrow-start-y! arrow start-y) - (set-arrow-end-x! arrow end-x) - (set-arrow-end-y! arrow end-y))) - - - (define/private (update-tail-arrow-poss arrow) - ;; If the item is an embedded editor snip, redirect - ;; the arrow to point at the left edge rather than the - ;; midpoint. - (define (find-poss/embedded text pos) - (let* ([snip (send text find-snip pos 'after)]) - (cond - [(and snip - (is-a? snip editor-snip%) - (= pos (send text get-snip-position snip))) - (find-poss text pos pos)] - [else - (find-poss text pos (+ pos 1))]))) - (let-values ([(start-x start-y) (find-poss/embedded - (tail-arrow-from-text arrow) - (tail-arrow-from-pos arrow))] - [(end-x end-y) (find-poss/embedded - (tail-arrow-to-text arrow) - (tail-arrow-to-pos arrow))]) - (set-arrow-start-x! arrow start-x) - (set-arrow-start-y! arrow start-y) - (set-arrow-end-x! arrow end-x) - (set-arrow-end-y! arrow end-y))) - - (define/private (find-poss text left-pos right-pos) - (let ([xlb (box 0)] - [ylb (box 0)] - [xrb (box 0)] - [yrb (box 0)]) - (send text position-location left-pos xlb ylb #t) - (send text position-location right-pos xrb yrb #f) - (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] - [(xl yl) (dc-location-to-editor-location xl-off yl-off)] - [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] - [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) - (values (/ (+ xl xr) 2) - (/ (+ yl yr) 2))))) - - ;; syncheck:init-arrows : -> void - (define/public (syncheck:init-arrows) - (set! tacked-hash-table (make-hasheq)) - (set! arrow-vectors (make-hasheq)) - (set! bindings-table (make-hash)) - (let ([f (get-top-level-window)]) - (when f - (send f open-status-line 'drscheme:check-syntax:mouse-over)))) - - ;; syncheck:clear-arrows : -> void - (define/public (syncheck:clear-arrows) - (when (or arrow-vectors cursor-location cursor-text) - (let ([any-tacked? #f]) - (when tacked-hash-table - (let/ec k - (hash-for-each - tacked-hash-table - (λ (key val) - (set! any-tacked? #t) - (k (void)))))) - (set! tacked-hash-table #f) - (set! arrow-vectors #f) - (set! cursor-location #f) - (set! cursor-text #f) - (set! cursor-eles #f) - (when any-tacked? - (invalidate-bitmap-cache)) - (update-docs-background #f) - (let ([f (get-top-level-window)]) - (when f - (send f close-status-line 'drscheme:check-syntax:mouse-over)))))) - (define/public (syncheck:add-menu text start-pos end-pos key make-menu) - (when (and (<= 0 start-pos end-pos (last-position))) - (add-to-range/key text start-pos end-pos make-menu key #t))) - - (define/public (syncheck:add-background-color text color start fin key) - (when (is-a? text text:basic<%>) - (add-to-range/key text start fin (make-colored-region color text start fin) key #f))) - - ;; syncheck:add-arrow : symbol text number number text number number boolean -> void - ;; pre: start-editor, end-editor are embedded in `this' (or are `this') - (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right - end-text end-pos-left end-pos-right - actual? level) - (let* ([arrow (make-var-arrow #f #f #f #f - start-text start-pos-left start-pos-right - end-text end-pos-left end-pos-right - actual? level)]) - (when (add-to-bindings-table - start-text start-pos-left start-pos-right - end-text end-pos-left end-pos-right) - (add-to-range/key start-text start-pos-left start-pos-right arrow #f #f) - (add-to-range/key end-text end-pos-left end-pos-right arrow #f #f)))) - - ;; syncheck:add-tail-arrow : text number text number -> void - (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) - (let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)]) - (add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f) - (add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f))) - - ;; syncheck:add-jump-to-definition : text start end id filename -> void - (define/public (syncheck:add-jump-to-definition text start end id filename) - (add-to-range/key text start end (make-def-link id filename) #f #f)) - - ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void - (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) - (add-to-range/key text pos-left pos-right str #f #f)) - - ;; add-to-range/key : text number number any any boolean -> void - ;; adds `key' to the range `start' - `end' in the editor - ;; If use-key? is #t, it adds `to-add' with the key, and does not - ;; replace a value with that key already there. - ;; If use-key? is #f, it adds `to-add' without a key. - ;; pre: arrow-vectors is not #f - (define/private (add-to-range/key text start end to-add key use-key?) - (let ([arrow-vector (hash-ref - arrow-vectors - text - (λ () - (let ([new-vec - (make-vector - (add1 (send text last-position)) - null)]) - (hash-set! - arrow-vectors - text - new-vec) - new-vec)))]) - (let loop ([p start]) - (when (and (<= p end) - (< p (vector-length arrow-vector))) - ;; the last test in the above and is because some syntax objects - ;; appear to be from the original source, but can have bogus information. - - (let ([r (vector-ref arrow-vector p)]) - (cond - [use-key? - (unless (ormap (λ (x) - (and (pair? x) - (car x) - (eq? (car x) key))) - r) - (vector-set! arrow-vector p (cons (cons key to-add) r)))] - [else - (vector-set! arrow-vector p (cons to-add r))])) - (loop (add1 p)))))) - - (inherit get-top-level-window) - - (define/augment (on-change) - (inner (void) on-change) - (when arrow-vectors - (flush-arrow-coordinates-cache) - (let ([any-tacked? #f]) - (when tacked-hash-table - (let/ec k - (hash-for-each - tacked-hash-table - (λ (key val) - (set! any-tacked? #t) - (k (void)))))) - (when any-tacked? - (invalidate-bitmap-cache))))) - - ;; flush-arrow-coordinates-cache : -> void - ;; pre-condition: arrow-vector is not #f. - (define/private (flush-arrow-coordinates-cache) - (hash-for-each - arrow-vectors - (λ (text arrow-vector) - (let loop ([n (vector-length arrow-vector)]) - (unless (zero? n) - (let ([eles (vector-ref arrow-vector (- n 1))]) - (for-each (λ (ele) - (cond - [(arrow? ele) - (set-arrow-start-x! ele #f) - (set-arrow-start-y! ele #f) - (set-arrow-end-x! ele #f) - (set-arrow-end-y! ele #f)])) - eles)) - (loop (- n 1))))))) - - (define/override (on-paint before dc left top right bottom dx dy draw-caret) - (when (and arrow-vectors (not before)) - (let ([draw-arrow2 - (λ (arrow) - (unless (arrow-start-x arrow) - (update-arrow-poss arrow)) - (let ([start-x (arrow-start-x arrow)] - [start-y (arrow-start-y arrow)] - [end-x (arrow-end-x arrow)] - [end-y (arrow-end-y arrow)]) - (unless (and (= start-x end-x) - (= start-y end-y)) - (drscheme:arrow:draw-arrow dc start-x start-y end-x end-y dx dy) - (when (and (var-arrow? arrow) (not (var-arrow-actual? arrow))) - (let-values ([(fw fh _d _v) (send dc get-text-extent "x")]) - (send dc draw-text "?" - (+ end-x dx fw) - (+ end-y dy (- fh))))))))] - [old-brush (send dc get-brush)] - [old-pen (send dc get-pen)] - [old-font (send dc get-font)] - [old-text-foreground (send dc get-text-foreground)] - [old-text-mode (send dc get-text-mode)]) - (send dc set-font - (send the-font-list find-or-create-font - (send old-font get-point-size) - 'default - 'normal - 'bold)) - (send dc set-text-foreground templ-color) - (hash-for-each tacked-hash-table - (λ (arrow v) - (when v - (cond - [(var-arrow? arrow) - (if (var-arrow-actual? arrow) - (begin (send dc set-pen var-pen) - (send dc set-brush tacked-var-brush)) - (begin (send dc set-pen templ-pen) - (send dc set-brush tacked-templ-brush)))] - [(tail-arrow? arrow) - (send dc set-pen tail-pen) - (send dc set-brush tacked-tail-brush)]) - (draw-arrow2 arrow)))) - (when (and cursor-location - cursor-text) - (let* ([arrow-vector (hash-ref arrow-vectors cursor-text (λ () #f))]) - (when arrow-vector - (let ([eles (vector-ref arrow-vector cursor-location)]) - (for-each (λ (ele) - (cond - [(var-arrow? ele) - (if (var-arrow-actual? ele) - (begin (send dc set-pen var-pen) - (send dc set-brush untacked-brush)) - (begin (send dc set-pen templ-pen) - (send dc set-brush untacked-brush))) - (draw-arrow2 ele)] - [(tail-arrow? ele) - (send dc set-pen tail-pen) - (send dc set-brush untacked-brush) - (for-each-tail-arrows draw-arrow2 ele)])) - eles))))) - (send dc set-brush old-brush) - (send dc set-pen old-pen) - (send dc set-font old-font) - (send dc set-text-foreground old-text-foreground) - (send dc set-text-mode old-text-mode))) - - ;; do the drawing before calling super so that the arrows don't - ;; cross the "#lang ..." line, if it is present. - (super on-paint before dc left top right bottom dx dy draw-caret)) - - ;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void - (define/private (for-each-tail-arrows f tail-arrow) - ;; call-f-ht ensures that `f' is only called once per arrow - (define call-f-ht (make-hasheq)) - - (define (for-each-tail-arrows/to/from tail-arrow-pos tail-arrow-text - tail-arrow-other-pos tail-arrow-other-text) - - ;; traversal-ht ensures that we don't loop in the arrow traversal. - (let ([traversal-ht (make-hasheq)]) - (let loop ([tail-arrow tail-arrow]) - (unless (hash-ref traversal-ht tail-arrow (λ () #f)) - (hash-set! traversal-ht tail-arrow #t) - (unless (hash-ref call-f-ht tail-arrow (λ () #f)) - (hash-set! call-f-ht tail-arrow #t) - (f tail-arrow)) - (let* ([next-pos (tail-arrow-pos tail-arrow)] - [next-text (tail-arrow-text tail-arrow)] - [arrow-vector (hash-ref arrow-vectors next-text (λ () #f))]) - (when arrow-vector - (let ([eles (vector-ref arrow-vector next-pos)]) - (for-each (λ (ele) - (cond - [(tail-arrow? ele) - (let ([other-pos (tail-arrow-other-pos ele)] - [other-text (tail-arrow-other-text ele)]) - (when (and (= other-pos next-pos) - (eq? other-text next-text)) - (loop ele)))])) - eles)))))))) - - (for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text - tail-arrow-from-pos tail-arrow-from-text) - (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text - tail-arrow-to-pos tail-arrow-to-text)) - - (define/override (on-event event) - (if arrow-vectors - (cond - [(send event leaving?) - (update-docs-background #f) - (when (and cursor-location cursor-text) - (set! cursor-location #f) - (set! cursor-text #f) - (set! cursor-eles #f) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drscheme:check-syntax:mouse-over #f))) - (invalidate-bitmap-cache)) - (super on-event event)] - [(or (send event moving?) - (send event entering?)) - (let-values ([(pos text) (get-pos/text event)]) - (cond - [(and pos (is-a? text text%)) - (unless (and (equal? pos cursor-location) - (eq? cursor-text text)) - (set! cursor-location pos) - (set! cursor-text text) - - (let* ([arrow-vector (hash-ref arrow-vectors cursor-text (λ () #f))] - [eles (and arrow-vector (vector-ref arrow-vector cursor-location))]) - - (unless (equal? cursor-eles eles) - (set! cursor-eles eles) - (update-docs-background eles) - (when eles - (update-status-line eles) - (for-each (λ (ele) - (cond - [(arrow? ele) - (update-arrow-poss ele)])) - eles) - (invalidate-bitmap-cache)))))] - [else - (update-docs-background #f) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drscheme:check-syntax:mouse-over #f))) - (when (or cursor-location cursor-text) - (set! cursor-location #f) - (set! cursor-text #f) - (set! cursor-eles #f) - (invalidate-bitmap-cache))])) - (super on-event event)] - [(send event button-down? 'right) - (let-values ([(pos text) (get-pos/text event)]) - (if (and pos (is-a? text text%)) - (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) - (when arrow-vector - (let ([vec-ents (vector-ref arrow-vector pos)] - [start-selection (send text get-start-position)] - [end-selection (send text get-end-position)]) - (cond - [(and (null? vec-ents) (= start-selection end-selection)) - (super on-event event)] - [else - (let* ([menu (make-object popup-menu% #f)] - [arrows (filter arrow? vec-ents)] - [def-links (filter def-link? vec-ents)] - [var-arrows (filter var-arrow? arrows)] - [add-menus (map cdr (filter pair? vec-ents))]) - (unless (null? arrows) - (make-object menu-item% - (string-constant cs-tack/untack-arrow) - menu - (λ (item evt) (tack/untack-callback arrows)))) - (unless (null? def-links) - (let ([def-link (car def-links)]) - (make-object menu-item% - jump-to-definition - menu - (λ (item evt) - (jump-to-definition-callback def-link))))) - (unless (null? var-arrows) - (make-object menu-item% - jump-to-next-bound-occurrence - menu - (λ (item evt) (jump-to-next-callback pos text arrows))) - (make-object menu-item% - jump-to-binding - menu - (λ (item evt) (jump-to-binding-callback arrows)))) - (unless (= start-selection end-selection) - (let ([arrows-menu - (make-object menu% - "Arrows crossing selection" - menu)] - [callback - (lambda (accept) - (tack-crossing-arrows-callback - arrow-vector - start-selection - end-selection - text - accept))]) - (make-object menu-item% - "Tack arrows" - arrows-menu - (lambda (item evt) - (callback - '(lexical top-level imported)))) - (make-object menu-item% - "Tack non-import arrows" - arrows-menu - (lambda (item evt) - (callback - '(lexical top-level)))) - (make-object menu-item% - "Untack arrows" - arrows-menu - (lambda (item evt) - (untack-crossing-arrows - arrow-vector - start-selection - end-selection))))) - (for-each (λ (f) (f menu)) add-menus) - (send (get-canvas) popup-menu menu - (+ 1 (inexact->exact (floor (send event get-x)))) - (+ 1 (inexact->exact (floor (send event get-y))))))])))) - (super on-event event)))] - [else (super on-event event)]) - (super on-event event))) - - (define/private (update-status-line eles) - (let ([has-txt? #f]) - (for-each (λ (ele) - (cond - [(string? ele) - (set! has-txt? #t) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line - 'drscheme:check-syntax:mouse-over - ele)))])) - eles) - (unless has-txt? - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drscheme:check-syntax:mouse-over #f)))))) - - (define current-colored-region #f) - ;; update-docs-background : (or/c false/c (listof any)) -> void - (define/private (update-docs-background eles) - (let ([new-region (and eles (ormap (λ (x) (and (colored-region? x) x)) eles))]) - (unless (eq? current-colored-region new-region) - (when current-colored-region - (send (colored-region-text current-colored-region) unhighlight-range - (colored-region-start current-colored-region) - (colored-region-fin current-colored-region) - (send the-color-database find-color (colored-region-color current-colored-region)))) - (when new-region - (send (colored-region-text new-region) highlight-range - (colored-region-start new-region) - (colored-region-fin new-region) - (send the-color-database find-color (colored-region-color new-region)))) - (set! current-colored-region new-region)))) - - ;; tack/untack-callback : (listof arrow) -> void - ;; callback for the tack/untack menu item - (define/private (tack/untack-callback arrows) - (let ([arrow-tacked? - (λ (arrow) - (hash-ref - tacked-hash-table - arrow - (λ () #f)))] - [untack-arrows? #f]) - (for-each - (λ (arrow) - (cond - [(var-arrow? arrow) - (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))] - [(tail-arrow? arrow) - (for-each-tail-arrows - (λ (arrow) (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))) - arrow)])) - arrows) - (for-each - (λ (arrow) - (cond - [(var-arrow? arrow) - (hash-set! tacked-hash-table arrow (not untack-arrows?))] - [(tail-arrow? arrow) - (for-each-tail-arrows - (λ (arrow) - (hash-set! tacked-hash-table arrow (not untack-arrows?))) - arrow)])) - arrows)) - (invalidate-bitmap-cache)) - - (define/private (tack-crossing-arrows-callback arrow-vector start end text kinds) - (define (xor a b) - (or (and a (not b)) (and (not a) b))) - (define (within t p) - (and (eq? t text) - (<= start p end))) - (for ([position (in-range start end)]) - (define things (vector-ref arrow-vector position)) - (for ([va things] #:when (var-arrow? va)) - (define va-start (var-arrow-start-pos-left va)) - (define va-start-text (var-arrow-start-text va)) - (define va-end (var-arrow-end-pos-left va)) - (define va-end-text (var-arrow-end-text va)) - (when (xor (within va-start-text va-start) - (within va-end-text va-end)) - (when (memq (var-arrow-level va) kinds) - (hash-set! tacked-hash-table va #t))))) - (invalidate-bitmap-cache)) - - (define/private (untack-crossing-arrows arrow-vector start end) - (for ([position (in-range start end)]) - (for ([va (vector-ref arrow-vector position)] #:when (var-arrow? va)) - (hash-set! tacked-hash-table va #f)))) - - ;; syncheck:jump-to-binding-occurrence : text -> void - ;; jumps to the next occurrence, based on the insertion point - (define/public (syncheck:jump-to-next-bound-occurrence text) - (jump-to-binding/bound-helper - text - (λ (pos text vec-ents) - (jump-to-next-callback pos text vec-ents)))) - - ;; syncheck:jump-to-binding-occurrence : text -> void - (define/public (syncheck:jump-to-binding-occurrence text) - (jump-to-binding/bound-helper - text - (λ (pos text vec-ents) - (jump-to-binding-callback vec-ents)))) - - (define/private (jump-to-binding/bound-helper text do-jump) - (let ([pos (send text get-start-position)]) - (when arrow-vectors - (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) - (when arrow-vector - (let ([vec-ents (filter var-arrow? (vector-ref arrow-vector pos))]) - (unless (null? vec-ents) - (do-jump pos text vec-ents)))))))) - - ;; jump-to-next-callback : (listof arrow) -> void - ;; callback for the jump popup menu item - (define/private (jump-to-next-callback pos txt input-arrows) - (unless (null? input-arrows) - (let* ([arrow-key (car input-arrows)] - [orig-arrows (hash-ref bindings-table - (list (var-arrow-start-text arrow-key) - (var-arrow-start-pos-left arrow-key) - (var-arrow-start-pos-right arrow-key)) - (λ () '()))]) - (cond - [(null? orig-arrows) (void)] - [(null? (cdr orig-arrows)) (jump-to (car orig-arrows))] - [else - (let loop ([arrows orig-arrows]) - (cond - [(null? arrows) (jump-to (car orig-arrows))] - [else (let ([arrow (car arrows)]) - (cond - [(and (object=? txt (list-ref arrow 0)) - (<= (list-ref arrow 1) pos (list-ref arrow 2))) - (jump-to (if (null? (cdr arrows)) - (car orig-arrows) - (cadr arrows)))] - [else (loop (cdr arrows))]))]))])))) - - ;; jump-to : (list text number number) -> void - (define/private (jump-to to-arrow) - (let ([end-text (list-ref to-arrow 0)] - [end-pos-left (list-ref to-arrow 1)] - [end-pos-right (list-ref to-arrow 2)]) - (send end-text set-position end-pos-left end-pos-right) - (send end-text set-caret-owner #f 'global))) - - ;; jump-to-binding-callback : (listof arrow) -> void - ;; callback for the jump popup menu item - (define/private (jump-to-binding-callback arrows) - (unless (null? arrows) - (let* ([arrow (car arrows)] - [start-text (var-arrow-start-text arrow)] - [start-pos-left (var-arrow-start-pos-left arrow)] - [start-pos-right (var-arrow-start-pos-right arrow)]) - (send start-text set-position start-pos-left start-pos-right) - (send start-text set-caret-owner #f 'global)))) - - ;; syncheck:jump-to-definition : text -> void - (define/public (syncheck:jump-to-definition text) - (let ([pos (send text get-start-position)]) - (when arrow-vectors - (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) - (when arrow-vector - (let ([vec-ents (filter def-link? (vector-ref arrow-vector pos))]) - (unless (null? vec-ents) - (jump-to-definition-callback (car vec-ents))))))))) - - (define/private (jump-to-definition-callback def-link) - (let* ([filename (def-link-filename def-link)] - [id-from-def (def-link-id def-link)] - [frame (fw:handler:edit-file filename)]) - (when (is-a? frame syncheck-frame<%>) - (send frame syncheck:button-callback id-from-def)))) - - (define/augment (after-set-next-settings settings) - (let ([frame (get-top-level-window)]) - (when frame - (send frame update-button-visibility/settings settings))) - (inner (void) after-set-next-settings settings)) - - (super-new))))) - - (define syncheck-bitmap (make-object bitmap% (build-path (collection-path "icons") "syncheck.png") 'png/mask)) - - (define syncheck-frame<%> - (interface () - syncheck:button-callback - syncheck:error-report-visible?)) - - (define tab-mixin - - (mixin (drscheme:unit:tab<%>) () - (inherit is-current-tab? get-defs get-frame) - - (define report-error-text (new (fw:text:ports-mixin fw:scheme:text%))) - (define error-report-visible? #f) - (send report-error-text auto-wrap #t) - (send report-error-text set-autowrap-bitmap #f) - (send report-error-text lock #t) - - (define/public (get-error-report-text) report-error-text) - (define/public (get-error-report-visible?) error-report-visible?) - (define/public (turn-on-error-report) (set! error-report-visible? #t)) - (define/public (turn-off-error-report) (set! error-report-visible? #f)) - (define/augment (clear-annotations) - (inner (void) clear-annotations) - (syncheck:clear-error-message) - (syncheck:clear-highlighting)) - - (define/public (syncheck:clear-error-message) - (set! error-report-visible? #f) - (send report-error-text clear-output-ports) - (send report-error-text lock #f) - (send report-error-text delete/io 0 (send report-error-text last-position)) - (send report-error-text lock #t) - (when (is-current-tab?) - (send (get-frame) hide-error-report))) - - (define cleanup-texts '()) - (define/public (syncheck:clear-highlighting) - (let* ([definitions (get-defs)] - [locked? (send definitions is-locked?)]) - (send definitions begin-edit-sequence #f) - (send definitions lock #f) - (send definitions syncheck:clear-arrows) - (for-each (λ (text) - (send text thaw-colorer)) - cleanup-texts) - (set! cleanup-texts '()) - (send definitions lock locked?) - (send definitions end-edit-sequence))) - - (define/augment (can-close?) - (and (send report-error-text can-close?) - (inner #t can-close?))) - - (define/augment (on-close) - (send report-error-text on-close) - (send (get-defs) syncheck:clear-arrows) - (inner (void) on-close)) - - ;; syncheck:add-to-cleanup-texts : (is-a?/c text%) -> void - (define/public (syncheck:add-to-cleanup-texts txt) - (unless (memq txt cleanup-texts) - (send txt freeze-colorer) - (set! cleanup-texts (cons txt cleanup-texts)))) - - (super-new))) - - (define unit-frame-mixin - (mixin (drscheme:unit:frame<%>) (syncheck-frame<%>) - - (inherit get-button-panel - get-definitions-canvas - get-definitions-text - get-interactions-text - get-current-tab) - - (define/augment (on-tab-change old-tab new-tab) - (inner (void) on-tab-change old-tab new-tab) - (if (send new-tab get-error-report-visible?) - (show-error-report) - (hide-error-report)) - (send report-error-canvas set-editor (send new-tab get-error-report-text)) - (update-button-visibility/tab new-tab)) - - (define/private (update-button-visibility/tab tab) - (update-button-visibility/settings (send (send tab get-defs) get-next-settings))) - (define/public (update-button-visibility/settings settings) - (let* ([lang (drscheme:language-configuration:language-settings-language settings)] - [visible? (send lang capability-value 'drscheme:check-syntax-button)]) - (send check-syntax-button-parent-panel change-children - (λ (l) - (if visible? - (list check-syntax-button) - '()))))) - - (define/augment (enable-evaluation) - (send check-syntax-button enable #t) - (inner (void) enable-evaluation)) - - (define/augment (disable-evaluation) - (send check-syntax-button enable #f) - (inner (void) disable-evaluation)) - - (define report-error-parent-panel 'uninitialized-report-error-parent-panel) - (define report-error-panel 'uninitialized-report-error-panel) - (define report-error-canvas 'uninitialized-report-error-editor-canvas) - (define/override (get-definitions/interactions-panel-parent) - (set! report-error-parent-panel - (make-object vertical-panel% - (super get-definitions/interactions-panel-parent))) - (set! report-error-panel (instantiate horizontal-panel% () - (parent report-error-parent-panel) - (stretchable-height #f) - (alignment '(center center)) - (style '(border)))) - (send report-error-parent-panel change-children (λ (l) null)) - (let ([message-panel (instantiate vertical-panel% () - (parent report-error-panel) - (stretchable-width #f) - (stretchable-height #f) - (alignment '(left center)))]) - (make-object message% (string-constant check-syntax) message-panel) - (make-object message% (string-constant cs-error-message) message-panel)) - (set! report-error-canvas (new editor-canvas% - (parent report-error-panel) - (editor (send (get-current-tab) get-error-report-text)) - (line-count 3) - (style '(no-hscroll)))) - (instantiate button% () - (label (string-constant hide)) - (parent report-error-panel) - (callback (λ (x y) (hide-error-report))) - (stretchable-height #t)) - (make-object vertical-panel% report-error-parent-panel)) - - (define/public-final (syncheck:error-report-visible?) - (and (is-a? report-error-parent-panel area-container<%>) - (member report-error-panel (send report-error-parent-panel get-children)))) - - (define/public (hide-error-report) - (when (syncheck:error-report-visible?) - (send (get-current-tab) turn-off-error-report) - (send report-error-parent-panel change-children - (λ (l) (remq report-error-panel l))))) - - (define/private (show-error-report) - (unless (syncheck:error-report-visible?) - (send report-error-parent-panel change-children - (λ (l) (cons report-error-panel l))))) - - (define rest-panel 'uninitialized-root) - (define super-root 'uninitialized-super-root) - (define/override (make-root-area-container % parent) - (let* ([s-root (super make-root-area-container - vertical-panel% - parent)] - [r-root (make-object % s-root)]) - (set! super-root s-root) - (set! rest-panel r-root) - r-root)) - - (inherit open-status-line close-status-line update-status-line ensure-rep-hidden) - ;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void) - ;; this is the only function that has any code running on the user's thread - (define/public syncheck:button-callback - (case-lambda - [() (syncheck:button-callback #f)] - [(jump-to-id) - (when (send check-syntax-button is-enabled?) - (open-status-line 'drscheme:check-syntax) - (update-status-line 'drscheme:check-syntax status-init) - (ensure-rep-hidden) - (let-values ([(expanded-expression expansion-completed) (make-traversal)]) - (let* ([definitions-text (get-definitions-text)] - [interactions-text (get-interactions-text)] - [drs-eventspace (current-eventspace)] - [the-tab (get-current-tab)]) - (let-values ([(old-break-thread old-custodian) (send the-tab get-breakables)]) - (let* ([user-namespace #f] - [user-directory #f] - [user-custodian #f] - [normal-termination? #f] - - [show-error-report/tab - (λ () ; =drs= - (send the-tab turn-on-error-report) - (send (send the-tab get-error-report-text) scroll-to-position 0) - (when (eq? (get-current-tab) the-tab) - (show-error-report)))] - [cleanup - (λ () ; =drs= - (send the-tab set-breakables old-break-thread old-custodian) - (send the-tab enable-evaluation) - (send definitions-text end-edit-sequence) - (close-status-line 'drscheme:check-syntax) - - ;; do this with some lag ... not great, but should be okay. - (thread - (λ () - (flush-output (send (send the-tab get-error-report-text) get-err-port)) - (queue-callback - (λ () - (unless (= 0 (send (send the-tab get-error-report-text) last-position)) - (show-error-report/tab)))))))] - [kill-termination - (λ () - (unless normal-termination? - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () - (send the-tab syncheck:clear-highlighting) - (cleanup) - (custodian-shutdown-all user-custodian))))))] - [error-display-semaphore (make-semaphore 0)] - [uncaught-exception-raised - (λ () ;; =user= - (set! normal-termination? #t) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ;; =drs= - (yield error-display-semaphore) ;; let error display go first - (send the-tab syncheck:clear-highlighting) - (cleanup) - (custodian-shutdown-all user-custodian)))))] - [error-port (send (send the-tab get-error-report-text) get-err-port)] - [init-proc - (λ () ; =user= - (send the-tab set-breakables (current-thread) (current-custodian)) - (set-directory definitions-text) - (current-error-port error-port) - (error-display-handler - (λ (msg exn) ;; =user= - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ;; =drs= - - ;; a call like this one also happens in - ;; drscheme:debug:error-display-handler/stacktrace - ;; but that call won't happen here, because - ;; the rep is not in the current-rep parameter - (send interactions-text highlight-errors/exn exn) - - (show-error-report/tab)))) - - (drscheme:debug:error-display-handler/stacktrace - msg - exn - '()) - - (semaphore-post error-display-semaphore))) - - (error-print-source-location #f) ; need to build code to render error first - (uncaught-exception-handler - (let ([oh (uncaught-exception-handler)]) - (λ (exn) - (uncaught-exception-raised) - (oh exn)))) - (update-status-line 'drscheme:check-syntax status-expanding-expression) - (set! user-custodian (current-custodian)) - (set! user-directory (current-directory)) ;; set by set-directory above - (set! user-namespace (current-namespace)))]) - (send the-tab disable-evaluation) ;; this locks the editor, so must be outside. - (send definitions-text begin-edit-sequence #f) - (with-lock/edit-sequence - definitions-text - (λ () - (send the-tab clear-annotations) - (send the-tab reset-offer-kill) - (send (send the-tab get-defs) syncheck:init-arrows) - - (drscheme:eval:expand-program - (drscheme:language:make-text/pos definitions-text 0 (send definitions-text last-position)) - (send definitions-text get-next-settings) - #t - init-proc - kill-termination - (λ (sexp loop) ; =user= - (cond - [(eof-object? sexp) - (set! normal-termination? #t) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ; =drs= - (with-lock/edit-sequence - definitions-text - (λ () - (parameterize ([currently-processing-definitions-text definitions-text]) - (expansion-completed user-namespace user-directory) - (send definitions-text syncheck:sort-bindings-table)))) - (cleanup) - (custodian-shutdown-all user-custodian))))] - [else - (update-status-line 'drscheme:check-syntax status-eval-compile-time) - (eval-compile-time-part-of-top-level sexp) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ; =drs= - (with-lock/edit-sequence - definitions-text - (λ () - (open-status-line 'drscheme:check-syntax) - (force-xref (λ () (update-status-line 'drscheme:check-syntax status-loading-docs-index))) - (update-status-line 'drscheme:check-syntax status-coloring-program) - (parameterize ([currently-processing-definitions-text definitions-text]) - (expanded-expression user-namespace user-directory sexp jump-to-id)) - (close-status-line 'drscheme:check-syntax)))))) - (update-status-line 'drscheme:check-syntax status-expanding-expression) - (loop)]))))))))))])) - - ;; set-directory : text -> void - ;; sets the current-directory and current-load-relative-directory - ;; based on the file saved in the definitions-text - (define/private (set-directory definitions-text) - (let* ([tmp-b (box #f)] - [fn (send definitions-text get-filename tmp-b)]) - (unless (unbox tmp-b) - (when fn - (let-values ([(base name dir?) (split-path fn)]) - (current-directory base) - (current-load-relative-directory base)))))) - - ;; with-lock/edit-sequence : text (-> void) -> void - ;; sets and restores some state of the definitions text - ;; so that edits to the definitions text work out. - (define/private (with-lock/edit-sequence definitions-text thnk) - (let* ([locked? (send definitions-text is-locked?)]) - (send definitions-text begin-edit-sequence) - (send definitions-text lock #f) - (thnk) - (send definitions-text end-edit-sequence) - (send definitions-text lock locked?))) - - (super-new) - - (define check-syntax-button-parent-panel - (new horizontal-panel% - [parent (get-button-panel)] - [stretchable-width #f] - [stretchable-height #f])) - (define check-syntax-button - (new switchable-button% - (label (string-constant check-syntax)) - (bitmap syncheck-bitmap) - (parent check-syntax-button-parent-panel) - (callback (λ (button) (syncheck:button-callback))))) - (inherit register-toolbar-button) - (register-toolbar-button check-syntax-button) - (define/public (syncheck:get-button) check-syntax-button) - (send (get-button-panel) change-children - (λ (l) - (cons check-syntax-button-parent-panel - (remove check-syntax-button-parent-panel l)))) - (update-button-visibility/tab (get-current-tab)))) - - (define report-error-style (make-object style-delta% 'change-style 'italic)) - (send report-error-style set-delta-foreground "red") - - (define (add-check-syntax-key-bindings keymap) - (send keymap add-function - "check syntax" - (λ (obj evt) - (when (is-a? obj editor<%>) - (let ([canvas (send obj get-canvas)]) - (when canvas - (let ([frame (send canvas get-top-level-window)]) - (when (is-a? frame syncheck-frame<%>) - (send frame syncheck:button-callback)))))))) - - (let ([jump-callback - (λ (send-msg) - (λ (obj evt) - (when (is-a? obj text%) - (let ([canvas (send obj get-canvas)]) - (when canvas - (let ([frame (send canvas get-top-level-window)]) - (when (is-a? frame syncheck-frame<%>) - (let ([defs (send frame get-definitions-text)]) - (when (is-a? defs syncheck-text<%>) - (send-msg defs obj))))))))))]) - (send keymap add-function - "jump to binding occurrence" - (jump-callback (λ (defs obj) (send defs syncheck:jump-to-binding-occurrence obj)))) - (send keymap add-function - "jump to next bound occurrence" - (jump-callback (λ (defs obj) (send defs syncheck:jump-to-next-bound-occurrence obj)))) - (send keymap add-function - "jump to definition (in other file)" - (jump-callback (λ (defs obj) (send defs syncheck:jump-to-definition obj))))) - - (send keymap map-function "f6" "check syntax") - (send keymap map-function "c:c;c:c" "check syntax") - (send keymap map-function "c:x;b" "jump to binding occurrence") - (send keymap map-function "c:x;n" "jump to next bound occurrence") - (send keymap map-function "c:x;d" "jump to definition (in other file)")) - - (define lexically-bound-variable-style-pref 'drscheme:check-syntax:lexically-bound) - (define imported-variable-style-pref 'drscheme:check-syntax:imported) - - (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 error-style-name (fw:scheme:short-sym->style-name 'error)) - ;(define constant-style-name (fw:scheme:short-sym->style-name 'constant)) - - (define (syncheck-add-to-preferences-panel parent) - (fw:color-prefs:build-color-selection-panel parent - lexically-bound-variable-style-pref - lexically-bound-variable-style-name - (string-constant cs-lexical-variable)) - (fw:color-prefs:build-color-selection-panel parent - imported-variable-style-pref - imported-variable-style-name - (string-constant cs-imported-variable))) - - (fw: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)) - (fw: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)) - - - - - - ; - ; - ; - ; ; - ; ; - ; ; ; ; - ; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;; - ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; - ; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;; - ; ; - ; ; - ; ; - - - - ;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void) - ;; (namespace string[directory] -> void)) - ;; returns a pair of functions that close over some state that - ;; represents the top-level of a single program. The first value - ;; is called once for each top-level expression and the second - ;; value is called once, after all expansion is complete. - (define (make-traversal) - (let* ([tl-low-binders (make-id-set)] - [tl-high-binders (make-id-set)] - [tl-low-varrefs (make-id-set)] - [tl-high-varrefs (make-id-set)] - [tl-low-tops (make-id-set)] - [tl-high-tops (make-id-set)] - [tl-templrefs (make-id-set)] - [tl-requires (make-hash)] - [tl-require-for-syntaxes (make-hash)] - [tl-require-for-templates (make-hash)] - [tl-require-for-labels (make-hash)] - [expanded-expression - (λ (user-namespace user-directory sexp jump-to-id) - (parameterize ([current-load-relative-directory user-directory]) - (let ([is-module? (syntax-case sexp (module) - [(module . rest) #t] - [else #f])]) - (cond - [is-module? - (let ([low-binders (make-id-set)] - [high-binders (make-id-set)] - [varrefs (make-id-set)] - [high-varrefs (make-id-set)] - [low-tops (make-id-set)] - [high-tops (make-id-set)] - [templrefs (make-id-set)] - [requires (make-hash)] - [require-for-syntaxes (make-hash)] - [require-for-templates (make-hash)] - [require-for-labels (make-hash)]) - (annotate-basic sexp - user-namespace user-directory jump-to-id - low-binders high-binders varrefs high-varrefs low-tops high-tops - templrefs - requires require-for-syntaxes require-for-templates require-for-labels) - (annotate-variables user-namespace - user-directory - low-binders - high-binders - varrefs - high-varrefs - low-tops - high-tops - templrefs - requires - require-for-syntaxes - require-for-templates - require-for-labels))] - [else - (annotate-basic sexp - user-namespace user-directory jump-to-id - tl-low-binders tl-high-binders - tl-low-varrefs tl-high-varrefs - tl-low-tops tl-high-tops - tl-templrefs - tl-requires - tl-require-for-syntaxes - tl-require-for-templates - tl-require-for-labels)]))))] - [expansion-completed - (λ (user-namespace user-directory) - (parameterize ([current-load-relative-directory user-directory]) - (annotate-variables user-namespace - user-directory - tl-low-binders - tl-high-binders - tl-low-varrefs - tl-high-varrefs - tl-low-tops - tl-high-tops - tl-templrefs - tl-requires - tl-require-for-syntaxes - tl-require-for-templates - tl-require-for-labels)))]) - (values expanded-expression expansion-completed))) - - - ;; type req/tag = (make-req/tag syntax sexp boolean) - (define-struct req/tag (req-stx req-sexp used?)) - - ;; annotate-basic : syntax - ;; namespace - ;; string[directory] - ;; syntax[id] - ;; id-set (six of them) - ;; hash-table[require-spec -> syntax] (three of them) - ;; -> void - (define (annotate-basic sexp - user-namespace user-directory jump-to-id - low-binders high-binders - low-varrefs high-varrefs - low-tops high-tops - templrefs - requires require-for-syntaxes require-for-templates require-for-labels) - - (let ([tail-ht (make-hasheq)] - [maybe-jump - (λ (vars) - (when jump-to-id - (for-each (λ (id) - (let ([binding (identifier-binding id)]) - (when (pair? binding) - (let ([nominal-source-id (list-ref binding 3)]) - (when (eq? nominal-source-id jump-to-id) - (jump-to id)))))) - (syntax->list vars))))]) - - (let level-loop ([sexp sexp] - [high-level? #f]) - - (let* ([loop (λ (sexp) (level-loop sexp high-level?))] - [varrefs (if high-level? high-varrefs low-varrefs)] - [binders (if high-level? high-binders low-binders)] - [tops (if high-level? high-tops low-tops)] - [collect-general-info - (λ (stx) - (add-origins stx varrefs) - (add-disappeared-bindings stx binders varrefs) - (add-disappeared-uses stx varrefs))]) - (collect-general-info sexp) - (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! - quote quote-syntax with-continuation-mark - #%plain-app #%top #%plain-module-begin - define-values define-syntaxes define-values-for-syntax module - #%require #%provide #%expression) - (if high-level? free-transformer-identifier=? free-identifier=?) - [(#%plain-lambda args bodies ...) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) - (add-binders (syntax args) binders) - (for-each loop (syntax->list (syntax (bodies ...)))))] - [(case-lambda [argss bodiess ...]...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each (λ (bodies/stx) (annotate-tail-position/last sexp - (syntax->list bodies/stx) - tail-ht)) - (syntax->list (syntax ((bodiess ...) ...)))) - (for-each - (λ (args bodies) - (add-binders args binders) - (for-each loop (syntax->list bodies))) - (syntax->list (syntax (argss ...))) - (syntax->list (syntax ((bodiess ...) ...)))))] - [(if test then else) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax then) tail-ht) - (annotate-tail-position sexp (syntax else) tail-ht) - (loop (syntax test)) - (loop (syntax else)) - (loop (syntax then)))] - [(begin bodies ...) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) - (for-each loop (syntax->list (syntax (bodies ...)))))] - - ;; treat a single body expression specially, since this has - ;; different tail behavior. - [(begin0 body) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax body) tail-ht) - (loop (syntax body)))] - - [(begin0 bodies ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each loop (syntax->list (syntax (bodies ...)))))] - - [(let-values (bindings ...) bs ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each collect-general-info (syntax->list (syntax (bindings ...)))) - (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) - (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) - (for-each (λ (x) (add-binders x binders)) - (syntax->list (syntax ((xss ...) ...)))) - (for-each loop (syntax->list (syntax (es ...)))) - (for-each loop (syntax->list (syntax (bs ...))))))] - [(letrec-values (bindings ...) bs ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each collect-general-info (syntax->list (syntax (bindings ...)))) - (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) - (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) - (for-each (λ (x) (add-binders x binders)) - (syntax->list (syntax ((xss ...) ...)))) - (for-each loop (syntax->list (syntax (es ...)))) - (for-each loop (syntax->list (syntax (bs ...))))))] - [(set! var e) - (begin - (annotate-raw-keyword sexp varrefs) - - ;; tops are used here because a binding free use of a set!'d variable - ;; is treated just the same as (#%top . x). - (when (syntax-original? (syntax var)) - (if (identifier-binding (syntax var)) - (add-id varrefs (syntax var)) - (add-id tops (syntax var)))) - - (loop (syntax e)))] - [(quote datum) - ;(color-internal-structure (syntax datum) constant-style-name) - (annotate-raw-keyword sexp varrefs)] - [(quote-syntax datum) - ;(color-internal-structure (syntax datum) constant-style-name) - (annotate-raw-keyword sexp varrefs) - (let loop ([stx #'datum]) - (cond [(identifier? stx) - (when (syntax-original? stx) - (add-id templrefs stx))] - [(syntax? stx) - (loop (syntax-e stx))] - [(pair? stx) - (loop (car stx)) - (loop (cdr stx))] - [(vector? stx) - (for-each loop (vector->list stx))] - [(box? stx) - (loop (unbox stx))] - [else (void)]))] - [(with-continuation-mark a b c) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax c) tail-ht) - (loop (syntax a)) - (loop (syntax b)) - (loop (syntax c)))] - [(#%plain-app pieces ...) - (begin - (annotate-raw-keyword sexp varrefs) - (for-each loop (syntax->list (syntax (pieces ...)))))] - [(#%top . var) - (begin - (annotate-raw-keyword sexp varrefs) - (when (syntax-original? (syntax var)) - (add-id tops (syntax var))))] - [(define-values vars b) - (begin - (annotate-raw-keyword sexp varrefs) - (add-binders (syntax vars) binders) - (maybe-jump (syntax vars)) - (loop (syntax b)))] - [(define-syntaxes names exp) - (begin - (annotate-raw-keyword sexp varrefs) - (add-binders (syntax names) binders) - (maybe-jump (syntax names)) - (level-loop (syntax exp) #t))] - [(define-values-for-syntax names exp) - (begin - (annotate-raw-keyword sexp varrefs) - (add-binders (syntax names) high-binders) - (maybe-jump (syntax names)) - (level-loop (syntax exp) #t))] - [(module m-name lang (#%plain-module-begin bodies ...)) - (begin - (annotate-raw-keyword sexp varrefs) - ((annotate-require-open user-namespace user-directory) (syntax lang)) - - (hash-cons! requires (syntax->datum (syntax lang)) (syntax lang)) - (for-each loop (syntax->list (syntax (bodies ...)))))] - - ; top level or module top level only: - [(#%require require-specs ...) - (let ([at-phase - (lambda (stx requires) - (syntax-case stx () - [(_ require-specs ...) - (with-syntax ([((require-specs ...) ...) - (map (lambda (spec) - (syntax-case spec (just-meta) - [(just-meta m spec ...) - #'(spec ...)] - [else (list spec)])) - (syntax->list #'(require-specs ...)))]) - (let ([new-specs (map trim-require-prefix - (syntax->list (syntax (require-specs ... ...))))]) - (annotate-raw-keyword sexp varrefs) - (for-each (annotate-require-open user-namespace - user-directory) - new-specs) - (for-each (add-require-spec requires) - new-specs - (syntax->list (syntax (require-specs ... ...))))))]))]) - (for-each (lambda (spec) - (let loop ([spec spec]) - (syntax-case* spec (for-syntax for-template for-label for-meta just-meta) - (lambda (a b) - (eq? (syntax-e a) (syntax-e b))) - [(just-meta phase specs ...) - (for-each loop (syntax->list #'(specs ...)))] - [(for-syntax specs ...) - (at-phase spec require-for-syntaxes)] - [(for-meta 1 specs ...) - (at-phase #'(for-syntax specs ...) require-for-syntaxes)] - [(for-template specs ...) - (at-phase spec require-for-templates)] - [(for-meta -1 specs ...) - (at-phase #'(for-template specs ...) require-for-templates)] - [(for-label specs ...) - (at-phase spec require-for-labels)] - [(for-meta #f specs ...) - (at-phase #'(for-label specs ...) require-for-labels)] - [(for-meta 0 specs ...) - (at-phase #'(for-run specs ...) requires)] - [(for-meta . _) (void)] - [else - (at-phase (list #f spec) requires)]))) - (syntax->list #'(require-specs ...))))] - - ; module top level only: - [(#%provide provide-specs ...) - (let ([provided-varss (map extract-provided-vars - (syntax->list (syntax (provide-specs ...))))]) - (annotate-raw-keyword sexp varrefs) - (for-each (λ (provided-vars) - (for-each - (λ (provided-var) - (when (syntax-original? provided-var) - (add-id varrefs provided-var))) - provided-vars)) - provided-varss))] - - [(#%expression arg) - (begin - (annotate-raw-keyword sexp varrefs) - (loop #'arg))] - [id - (identifier? (syntax id)) - (when (syntax-original? sexp) - (add-id varrefs sexp))] - [_ - (begin - #; - (printf "unknown stx: ~e datum: ~e source: ~e\n" - sexp - (and (syntax? sexp) - (syntax->datum sexp)) - (and (syntax? sexp) - (syntax-source sexp))) - (void))]))) - (add-tail-ht-links tail-ht))) - - (define (hash-cons! ht k v) - (hash-set! ht k (cons v (hash-ref ht k '())))) - - ;; add-disappeared-bindings : syntax id-set -> void - (define (add-disappeared-bindings stx binders disappaeared-uses) - (let ([prop (syntax-property stx 'disappeared-binding)]) - (when prop - (let loop ([prop prop]) - (cond - [(pair? prop) - (loop (car prop)) - (loop (cdr prop))] - [(identifier? prop) - (add-origins prop disappaeared-uses) - (add-id binders prop)]))))) - - ;; add-disappeared-uses : syntax id-set -> void - (define (add-disappeared-uses stx id-set) - (let ([prop (syntax-property stx 'disappeared-use)]) - (when prop - (let loop ([prop prop]) - (cond - [(pair? prop) - (loop (car prop)) - (loop (cdr prop))] - [(identifier? prop) - (add-id id-set prop)]))))) - - ;; add-require-spec : hash-table[sexp[require-spec] -o> (listof syntax)] - ;; -> sexp[require-spec] - ;; syntax - ;; -> void - (define (add-require-spec require-ht) - (λ (raw-spec syntax) - (when (syntax-original? syntax) - (let ([key (syntax->datum raw-spec)]) - (hash-set! require-ht - key - (cons syntax - (hash-ref require-ht - key - (λ () '())))))))) - - ;; annotate-variables : namespace directory string id-set[four of them] (listof syntax) (listof syntax) -> void - ;; colors in and draws arrows for variables, according to their classifications - ;; in the various id-sets - (define (annotate-variables user-namespace - user-directory - low-binders - high-binders - low-varrefs - high-varrefs - low-tops - high-tops - templrefs - requires - require-for-syntaxes - require-for-templates - require-for-labels) - - (let ([rename-ht - ;; hash-table[(list source number number) -> (listof syntax)] - (make-hash)] - [unused-requires (make-hash)] - [unused-require-for-syntaxes (make-hash)] - [unused-require-for-templates (make-hash)] - [unused-require-for-labels (make-hash)] - ;; there is no define-for-template form, thus no for-template binders - [template-binders (make-id-set)] - [label-binders (make-id-set)] - [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)]) - - (hash-for-each requires - (λ (k v) (hash-set! unused-requires k #t))) - (hash-for-each require-for-syntaxes - (λ (k v) (hash-set! unused-require-for-syntaxes k #t))) - (hash-for-each require-for-templates - (lambda (k v) (hash-set! unused-require-for-templates k #t))) - (hash-for-each require-for-labels - (lambda (k v) (hash-set! unused-require-for-labels k #t))) - - (for-each (λ (vars) - (for-each (λ (var) - (when (syntax-original? var) - (color-variable var identifier-binding) - (document-variable var identifier-binding) - (record-renamable-var rename-ht var))) - vars)) - (append (get-idss high-binders) - (get-idss low-binders))) - - (for-each (λ (vars) (for-each - (λ (var) - (color-variable var identifier-binding) - (document-variable var identifier-binding) - (connect-identifier var - rename-ht - low-binders - unused-requires - requires - identifier-binding - user-namespace - user-directory - #t)) - vars)) - (get-idss low-varrefs)) - - (for-each (λ (vars) (for-each - (λ (var) - (color-variable var identifier-transformer-binding) - (document-variable var identifier-transformer-binding) - (connect-identifier var - rename-ht - high-binders - unused-require-for-syntaxes - require-for-syntaxes - identifier-transformer-binding - user-namespace - user-directory - #t)) - vars)) - (get-idss high-varrefs)) - - (for-each (lambda (vars) (for-each - (lambda (var) - ;; no color variable - (connect-identifier var - rename-ht - low-binders - unused-requires - requires - identifier-binding - user-namespace - user-directory - #f) - (connect-identifier var - rename-ht - high-binders - unused-require-for-syntaxes - require-for-syntaxes - identifier-transformer-binding - user-namespace - user-directory - #f) - (connect-identifier var - rename-ht - template-binders ;; dummy; always empty - unused-require-for-templates - require-for-templates - identifier-template-binding - user-namespace - user-directory - #f) - (connect-identifier var - rename-ht - label-binders ;; dummy; always empty - unused-require-for-labels - require-for-labels - identifier-label-binding - user-namespace - user-directory - #f)) - vars)) - (get-idss templrefs)) - - (for-each - (λ (vars) - (for-each - (λ (var) - (color/connect-top rename-ht user-namespace user-directory low-binders var)) - vars)) - (get-idss low-tops)) - - (for-each - (λ (vars) - (for-each - (λ (var) - (color/connect-top rename-ht user-namespace user-directory high-binders var)) - vars)) - (get-idss high-tops)) - - (color-unused require-for-labels unused-require-for-labels) - (color-unused require-for-templates unused-require-for-templates) - (color-unused require-for-syntaxes unused-require-for-syntaxes) - (color-unused requires unused-requires) - (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets))))) - - ;; record-renamable-var : rename-ht syntax -> void - (define (record-renamable-var rename-ht stx) - (let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))]) - (hash-set! rename-ht - key - (cons stx (hash-ref rename-ht key '()))))) - - ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void - (define (color-unused requires unused) - (hash-for-each - unused - (λ (k v) - (for-each (λ (stx) (color stx error-style-name)) - (hash-ref requires k))))) - - ;; connect-identifier : syntax - ;; id-set - ;; (union #f hash-table) - ;; (union #f hash-table) - ;; (union identifier-binding identifier-transformer-binding) - ;; (listof id-set) - ;; namespace - ;; directory - ;; boolean - ;; -> void - ;; adds arrows and rename menus for binders/bindings - (define (connect-identifier var rename-ht all-binders - unused requires get-binding user-namespace user-directory actual?) - (connect-identifier/arrow var all-binders - unused requires get-binding user-namespace user-directory actual?) - (when (and actual? (get-ids all-binders var)) - (record-renamable-var rename-ht var))) - - ;; id-level : identifier-binding-function identifier -> symbol - (define (id-level get-binding id) - (define (self-module? mpi) - (let-values ([(a b) (module-path-index-split mpi)]) - (and (not a) (not b)))) - (let ([binding (get-binding id)]) - (cond [(list? binding) - (if (self-module? (car binding)) - 'top-level - 'imported)] - [(eq? binding 'lexical) 'lexical] - [else 'top-level]))) - - ;; connect-identifier/arrow : syntax - ;; id-set - ;; (union #f hash-table) - ;; (union #f hash-table) - ;; (union identifier-binding identifier-transformer-binding) - ;; boolean - ;; -> void - ;; adds the arrows that correspond to binders/bindings - (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) - (let ([binders (get-ids all-binders var)]) - (when binders - (for-each (λ (x) - (when (syntax-original? x) - (connect-syntaxes x var actual? (id-level get-binding x)))) - binders)) - - (when (and unused requires) - (let ([req-path/pr (get-module-req-path (get-binding var))]) - (when req-path/pr - (let* ([req-path (car req-path/pr)] - [id (cdr req-path/pr)] - [req-stxes (hash-ref requires req-path (λ () #f))]) - (when req-stxes - (hash-remove! unused req-path) - (for-each (λ (req-stx) - (when (id/require-match? (syntax->datum var) - id - (syntax->datum req-stx)) - (when id - (add-jump-to-definition - var - id - (get-require-filename req-path user-namespace user-directory))) - (add-mouse-over var - (fw:gui-utils:format-literal-label - (string-constant cs-mouse-over-import) - (syntax-e var) - req-path)) - (connect-syntaxes req-stx var actual? - (id-level get-binding var)))) - req-stxes)))))))) - - (define (id/require-match? var id req-stx) - (cond - [(and (pair? req-stx) - (eq? (list-ref req-stx 0) 'prefix)) - (let ([prefix (list-ref req-stx 1)]) - (equal? (format "~a~a" prefix id) - (symbol->string var)))] - [(and (pair? req-stx) - (eq? (list-ref req-stx 0) 'prefix-all-except)) - (let ([prefix (list-ref req-stx 1)]) - (and (not (memq id (cdddr req-stx))) - (equal? (format "~a~a" prefix id) - (symbol->string var))))] - [(and (pair? req-stx) - (eq? (list-ref req-stx 0) 'rename)) - (eq? (list-ref req-stx 2) - var)] - [else (eq? var id)])) - - - ;; get-module-req-path : binding -> (union #f (cons require-sexp sym)) - ;; argument is the result of identifier-binding or identifier-transformer-binding - (define (get-module-req-path binding) - (and (pair? binding) - (let ([mod-path (list-ref binding 2)]) - (cond - [(module-path-index? mod-path) - (let-values ([(base offset) (module-path-index-split mod-path)]) - (cons base (list-ref binding 3)))] - [(symbol? mod-path) - (cons mod-path (list-ref binding 3))])))) - - ;; color/connect-top : namespace directory id-set syntax -> void - (define (color/connect-top rename-ht user-namespace user-directory binders var) - (let ([top-bound? - (or (get-ids binders var) - (parameterize ([current-namespace user-namespace]) - (let/ec k - (namespace-variable-value (syntax-e var) #t (λ () (k #f))) - #t)))]) - (if top-bound? - (color var lexically-bound-variable-style-name) - (color var error-style-name)) - (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t))) - - ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void - (define (color-variable var get-binding) - (let* ([b (get-binding var)] - [lexical? - (or (not b) - (eq? b 'lexical) - (and (pair? b) - (let ([path (caddr b)]) - (and (module-path-index? path) - (let-values ([(a b) (module-path-index-split path)]) - (and (not a) - (not b)))))))]) - (cond - [lexical? (color var lexically-bound-variable-style-name)] - [(pair? b) (color var imported-variable-style-name)]))) - - ;; add-var : hash-table -> syntax -> void - ;; adds the variable to the hash table. - (define (add-var ht) - (λ (var) - (let* ([key (syntax-e var)] - [prev (hash-ref ht key (λ () null))]) - (hash-set! ht key (cons var prev))))) - - ;; connect-syntaxes : syntax[original] syntax[original] boolean symbol -> void - ;; adds an arrow from `from' to `to', unless they have the same source loc. - (define (connect-syntaxes from to actual? level) - (let ([from-source (find-source-editor from)] - [to-source (find-source-editor to)] - [defs-text (get-defs-text)]) - (when (and from-source to-source defs-text) - (let ([pos-from (syntax-position from)] - [span-from (syntax-span from)] - [pos-to (syntax-position to)] - [span-to (syntax-span to)]) - (when (and pos-from span-from pos-to span-to) - (let* ([from-pos-left (- (syntax-position from) 1)] - [from-pos-right (+ from-pos-left (syntax-span from))] - [to-pos-left (- (syntax-position to) 1)] - [to-pos-right (+ to-pos-left (syntax-span to))]) - (unless (= from-pos-left to-pos-left) - (send defs-text syncheck:add-arrow - from-source from-pos-left from-pos-right - to-source to-pos-left to-pos-right - actual? level)))))))) - - ;; add-mouse-over : syntax[original] string -> void - ;; registers the range in the editor so that a mouse over - ;; this area shows up in the status line. - (define (add-mouse-over stx str) - (let* ([source (find-source-editor stx)] - [defs-text (get-defs-text)]) - (when (and defs-text - source - (syntax-position stx) - (syntax-span stx)) - (let* ([pos-left (- (syntax-position stx) 1)] - [pos-right (+ pos-left (syntax-span stx))]) - (send defs-text syncheck:add-mouse-over-status - source pos-left pos-right str))))) - - ;; add-jump-to-definition : syntax symbol path -> void - ;; registers the range in the editor so that the - ;; popup menu in this area allows the programmer to jump - ;; to the definition of the id. - (define (add-jump-to-definition stx id filename) - (let ([source (find-source-editor stx)] - [defs-text (get-defs-text)]) - (when (and source - defs-text - (syntax-position stx) - (syntax-span stx)) - (let* ([pos-left (- (syntax-position stx) 1)] - [pos-right (+ pos-left (syntax-span stx))]) - (send defs-text syncheck:add-jump-to-definition - source - pos-left - pos-right - id - filename))))) - - ;; find-syncheck-text : text% -> (union #f (is-a?/c syncheck-text<%>)) - (define (find-syncheck-text text) - (let loop ([text text]) - (cond - [(is-a? text syncheck-text<%>) text] - [else - (let ([admin (send text get-admin)]) - (and (is-a? admin editor-snip-editor-admin<%>) - (let* ([enclosing-editor-snip (send admin get-snip)] - [editor-snip-admin (send enclosing-editor-snip get-admin)] - [enclosing-editor (send editor-snip-admin get-editor)]) - (loop enclosing-editor))))]))) - - ;; annotate-tail-position/last : (listof syntax) -> void - (define (annotate-tail-position/last orig-stx stxs tail-ht) - (unless (null? stxs) - (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht))) - - ;; annotate-tail-position : syntax -> void - ;; colors the parens (if any) around the argument - ;; to indicate this is a tail call. - (define (annotate-tail-position orig-stx tail-stx tail-ht) - (hash-set! - tail-ht - orig-stx - (cons - tail-stx - (hash-ref - tail-ht - orig-stx - (λ () null))))) - - ;; annotate-require-open : namespace string -> (stx -> void) - ;; relies on current-module-name-resolver, which in turn depends on - ;; current-directory and current-namespace - (define (annotate-require-open user-namespace user-directory) - (λ (require-spec) - (when (syntax-original? require-spec) - (let ([source (find-source-editor require-spec)]) - (when (and (is-a? source text%) - (syntax-position require-spec) - (syntax-span require-spec)) - (let ([defs-text (get-defs-text)]) - (when defs-text - (let* ([start (- (syntax-position require-spec) 1)] - [end (+ start (syntax-span require-spec))] - [file (get-require-filename (syntax->datum require-spec) - user-namespace - user-directory)]) - (when file - (send defs-text syncheck:add-menu - source - start end - #f - (make-require-open-menu file))))))))))) - - ;; get-require-filename : sexp namespace string[directory] -> filename - ;; finds the filename corresponding to the require in stx - (define (get-require-filename datum user-namespace user-directory) - (let ([mp - (parameterize ([current-namespace user-namespace] - [current-directory user-directory] - [current-load-relative-directory user-directory]) - (with-handlers ([exn:fail? (λ (x) #f)]) - ((current-module-name-resolver) datum #f #f)))]) - (and (resolved-module-path? mp) - (resolved-module-path-name mp)))) - - ;; make-require-open-menu : path -> menu -> void - (define (make-require-open-menu file) - (λ (menu) - (let-values ([(base name dir?) (split-path file)]) - (instantiate menu-item% () - (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) - (parent menu) - (callback (λ (x y) (fw:handler:edit-file file)))) - (void)))) - - ;; possible-suffixes : (listof string) - ;; these are the suffixes that are checked for the reverse - ;; module-path mapping. - (define possible-suffixes '(".ss" ".scm" "")) - - ;; module-name-sym->filename : symbol -> (union #f string) - (define (module-name-sym->filename sym) - (let ([str (symbol->string sym)]) - (and ((string-length str) . > . 1) - (char=? (string-ref str 0) #\,) - (let ([fn (substring str 1 (string-length str))]) - (ormap (λ (x) - (let ([test (string->path (string-append fn x))]) - (and (file-exists? test) - test))) - possible-suffixes))))) - - ;; add-origins : sexp id-set -> void - (define (add-origins sexp id-set) - (let ([origin (syntax-property sexp 'origin)]) - (when origin - (let loop ([ct origin]) - (cond - [(pair? ct) - (loop (car ct)) - (loop (cdr ct))] - [(syntax? ct) - (when (syntax-original? ct) - (add-id id-set ct))] - [else (void)]))))) - - ;; FIXME: handle for-template and for-label - ;; extract-provided-vars : syntax -> (listof syntax[identifier]) - (define (extract-provided-vars stx) - (syntax-case* stx (rename struct all-from all-from-except all-defined-except) symbolic-compare? - [identifier - (identifier? (syntax identifier)) - (list (syntax identifier))] - - [(rename local-identifier export-identifier) - (list (syntax local-identifier))] - - ;; why do I even see this?!? - [(struct struct-identifier (field-identifier ...)) - null] - - [(all-from module-name) null] - [(all-from-except module-name identifier ...) - null] - [(all-defined-except identifier ...) - (syntax->list #'(identifier ...))] - [_ - null])) - - - ;; trim-require-prefix : syntax -> syntax - (define (trim-require-prefix require-spec) - (syntax-case* require-spec (only prefix all-except prefix-all-except rename just-meta) symbolic-compare? - [(only module-name identifer ...) - (syntax module-name)] - [(prefix identifier module-name) - (syntax module-name)] - [(all-except module-name identifer ...) - (syntax module-name)] - [(prefix-all-except module-name identifer ...) - (syntax module-name)] - [(rename module-name local-identifer exported-identifer) - (syntax module-name)] - [_ require-spec])) - - (define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y))) - - ;; add-binders : syntax id-set -> void - ;; transforms an argument list into a bunch of symbols/symbols - ;; and puts them into the id-set - ;; effect: colors the identifiers - (define (add-binders stx id-set) - (let loop ([stx stx]) - (let ([e (if (syntax? stx) (syntax-e stx) stx)]) - (cond - [(cons? e) - (let ([fst (car e)] - [rst (cdr e)]) - (if (syntax? fst) - (begin - (when (syntax-original? fst) - (add-id id-set fst)) - (loop rst)) - (loop rst)))] - [(null? e) (void)] - [else - (when (syntax-original? stx) - (add-id id-set stx))])))) - - ;; annotate-raw-keyword : syntax id-map -> void - ;; annotates keywords when they were never expanded. eg. - ;; if someone just types `(λ (x) x)' it has no 'origin - ;; field, but there still are keywords. - (define (annotate-raw-keyword stx id-map) - (let ([lst (syntax-e stx)]) - (when (pair? lst) - (let ([f-stx (car lst)]) - (when (and (syntax-original? f-stx) - (identifier? f-stx)) - (add-id id-map f-stx)))))) - - ;; color-internal-structure : syntax str -> void - (define (color-internal-structure stx style-name) - (let ([ht (make-hasheq)]) - ;; ht : stx -o> true - ;; indicates if we've seen this syntax object before - - (let loop ([stx stx] - [datum (syntax->datum stx)]) - (unless (hash-ref ht datum (λ () #f)) - (hash-set! ht datum #t) - (cond - [(pair? stx) - (loop (car stx) (car datum)) - (loop (cdr stx) (cdr datum))] - [(syntax? stx) - (when (syntax-original? stx) - (color stx style-name)) - (let ([stx-e (syntax-e stx)]) - (cond - [(cons? stx-e) - (loop (car stx-e) (car datum)) - (loop (cdr stx-e) (cdr datum))] - [(null? stx-e) - (void)] - [(vector? stx-e) - (for-each loop - (vector->list stx-e) - (vector->list datum))] - [(box? stx-e) - (loop (unbox stx-e) (unbox datum))] - [else (void)]))]))))) - - ;; jump-to : syntax -> void - (define (jump-to stx) - (let ([src (find-source-editor stx)] - [pos (syntax-position stx)] - [span (syntax-span stx)]) - (when (and (is-a? src text%) - pos - span) - (send src set-position (- pos 1) (+ pos span -1))))) - - ;; color : syntax[original] str -> void - ;; colors the syntax with style-name's style - (define (color stx style-name) - (let ([source (find-source-editor stx)]) - (when (and (is-a? source text%) - (syntax-position stx) - (syntax-span stx)) - (let ([pos (- (syntax-position stx) 1)] - [span (syntax-span stx)]) - (color-range source pos (+ pos span) style-name))))) - - ;; color-range : text start finish style-name - ;; colors a range in the text based on `style-name' - (define (color-range source start finish style-name) - (let ([style (send (send source get-style-list) - find-named-style - style-name)]) - (add-to-cleanup-texts source) - (send source change-style style start finish #f))) - - ;; hash-table[syntax -o> (listof syntax)] -> void - (define (add-tail-ht-links tail-ht) - (begin - (collapse-tail-links tail-ht) - (hash-for-each - tail-ht - (λ (stx-from stx-tos) - (for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to)) - stx-tos))))) - - ;; hash-table[syntax -o> (listof syntax)] -> void - ;; take something like a transitive closure, except - ;; only when there are non-original links in between - - (define (collapse-tail-links tail-ht) - (let loop () - (let ([found-one? #f]) - (hash-for-each - tail-ht - (λ (stx-from stx-tos) - (for-each - (λ (stx-to) - (let ([stx-to-tos (hash-ref tail-ht stx-to '())]) - (for-each - (λ (stx-to-to) - (unless (and (add-tail-link? stx-from stx-to) - (add-tail-link? stx-to stx-to-to)) - (unless (memq stx-to-to (hash-ref tail-ht stx-from '())) - (set! found-one? #t) - (hash-cons! tail-ht stx-from stx-to-to)))) - stx-to-tos))) - stx-tos))) - - ;; this takes O(n^3) in general, so we just do - ;; one iteration. This doesn't work for case - ;; expressions but it seems to for most others. - ;; turning this on makes this function go from about - ;; 55 msec to about 2400 msec on my laptop, - ;; (a 43x slowdown) when checking the syntax of this file. - - #; - (when found-one? - (loop))))) - - ;; add-tail-ht-link : syntax syntax -> void - (define (add-tail-ht-link from-stx to-stx) - (let* ([to-src (find-source-editor to-stx)] - [from-src (find-source-editor from-stx)] - [defs-text (get-defs-text)]) - (when (and to-src from-src defs-text) - (let ([from-pos (syntax-position from-stx)] - [to-pos (syntax-position to-stx)]) - (when (and from-pos to-pos) - (send defs-text syncheck:add-tail-arrow - from-src (- from-pos 1) - to-src (- to-pos 1))))))) - - ;; add-tail-link? : syntax syntax -> boolean - (define (add-tail-link? from-stx to-stx) - (let* ([to-src (find-source-editor to-stx)] - [from-src (find-source-editor from-stx)] - [defs-text (get-defs-text)]) - (and to-src from-src defs-text - (let ([from-pos (syntax-position from-stx)] - [to-pos (syntax-position to-stx)]) - (and from-pos to-pos))))) - - ;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void - (define (add-to-cleanup-texts ed) - (let ([ed (find-outermost-editor ed)]) - (when (is-a? ed drscheme:unit:definitions-text<%>) - (let ([tab (send ed get-tab)]) - (send tab syncheck:add-to-cleanup-texts ed))))) - - (define (find-outermost-editor ed) - (let loop ([ed ed]) - (let ([admin (send ed get-admin)]) - (if (is-a? admin editor-snip-editor-admin<%>) - (let* ([enclosing-snip (send admin get-snip)] - [enclosing-snip-admin (send enclosing-snip get-admin)]) - (loop (send enclosing-snip-admin get-editor))) - ed)))) - - ;; find-source-editor : stx -> editor or false - (define (find-source-editor stx) - (let ([defs-text (get-defs-text)]) - (and defs-text - (find-source-editor/defs stx defs-text)))) - - ;; find-source-editor : stx text -> editor or false - (define (find-source-editor/defs stx defs-text) - (cond - [(not (syntax-source stx)) #f] - [(and (symbol? (syntax-source stx)) - (text:lookup-port-name (syntax-source stx))) - => values] - [else - (let txt-loop ([text defs-text]) - (cond - [(and (is-a? text fw:text:basic<%>) - (send text port-name-matches? (syntax-source stx))) - text] - [else - (let snip-loop ([snip (send text find-first-snip)]) - (cond - [(not snip) - #f] - [(and (is-a? snip editor-snip%) - (send snip get-editor)) - (or (txt-loop (send snip get-editor)) - (snip-loop (send snip next)))] - [else - (snip-loop (send snip next))]))]))])) - ;; get-defs-text : -> text or false - (define (get-defs-text) - (currently-processing-definitions-text)) - - -; -; -; ; -; ; ; -; ; ; ; -; ;; ; ;;; ;;;; ; ; ; ;; ;; ;;; ; ;; ;;;;; ;;;; ;;;;; ;;; ;;; ; ;; -; ; ;; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;;;; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; -; ;; ; ;;; ;;;; ;; ; ; ; ; ;;;; ; ; ;;; ;; ; ;;; ; ;;; ; ; -; -; -; - - - ;; document-variable : stx identifier-binding -> void - (define (document-variable stx get-binding) - (when (syntax-original? stx) - (let ([defs-text (currently-processing-definitions-text)]) - (when defs-text - (let ([binding-info (get-binding stx)]) - (when (and (pair? binding-info) - (syntax-position stx) - (syntax-span stx)) - (let* ([start (- (syntax-position stx) 1)] - [fin (+ start (syntax-span stx))] - [source-editor (find-source-editor stx)] - [xref (get-xref)]) - (when (and xref source-editor) - (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)]) - (when definition-tag - (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) - (when path - (let ([index-entry (xref-tag->index-entry xref definition-tag)]) - (when index-entry - (send defs-text syncheck:add-background-color source-editor "navajowhite" start fin (syntax-e stx)) - (send defs-text syncheck:add-menu - source-editor - start - fin - (syntax-e stx) - (λ (menu) - (instantiate menu-item% () - (parent menu) - (label (fw:gui-utils:format-literal-label (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry)))) - (callback - (λ (x y) - (let* ([url (path->url path)] - [url2 (if tag - (make-url (url-scheme url) - (url-user url) - (url-host url) - (url-port url) - (url-path-absolute? url) - (url-path url) - (url-query url) - tag) - url)]) - (send-url (url->string url2)))))))))))))))))))))) - - - - ; - ; - ; - ; ; - ; ; - ; - ; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;; - ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; - ; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;; - ; ; - ; ; ; - ; ;;; - - - ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void - (define (make-rename-menu stxs id-sets) - (let ([defs-text (currently-processing-definitions-text)]) - (when defs-text - (let* ([source (syntax-source (car stxs))] ;; all stxs in the list must have the same source - [source-editor (find-source-editor (car stxs))]) - (when (is-a? source-editor text%) - (let* ([start (- (syntax-position (car stxs)) 1)] - [fin (+ start (syntax-span (car stxs)))]) - (send defs-text syncheck:add-menu - source-editor - start - fin - (syntax-e (car stxs)) - (λ (menu) - (let ([name-to-offer (format "~a" (syntax->datum (car stxs)))]) - (instantiate menu-item% () - (parent menu) - (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) - (callback - (λ (x y) - (let ([frame-parent (find-menu-parent menu)]) - (rename-callback name-to-offer - defs-text - stxs - id-sets - frame-parent)))))))))))))) - - ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) - (define (find-menu-parent menu) - (let loop ([menu menu]) - (cond - [(is-a? menu menu-bar%) (send menu get-frame)] - [(is-a? menu popup-menu%) - (let ([target (send menu get-popup-target)]) - (cond - [(is-a? target editor<%>) - (let ([canvas (send target get-canvas)]) - (and canvas - (send canvas get-top-level-window)))] - [(is-a? target window<%>) - (send target get-top-level-window)] - [else #f]))] - [(is-a? menu menu-item<%>) (loop (send menu get-parent))] - [else #f]))) - - ;; rename-callback : string - ;; (and/c syncheck-text<%> definitions-text<%>) - ;; (listof syntax[original]) - ;; (listof id-set) - ;; (union #f (is-a?/c top-level-window<%>)) - ;; -> void - ;; callback for the rename popup menu item - (define (rename-callback name-to-offer defs-text stxs id-sets parent) - (let ([new-str - (fw:keymap:call/text-keymap-initializer - (λ () - (get-text-from-user - (string-constant cs-rename-id) - (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) - parent - name-to-offer)))]) - (when new-str - (let* ([new-sym (format "~s" (string->symbol new-str))] - [to-be-renamed - (remove-duplicates - (sort - (apply - append - (map (λ (id-set) - (apply - append - (map (λ (stx) (or (get-ids id-set stx) '())) stxs))) - id-sets)) - (λ (x y) - ((syntax-position x) . >= . (syntax-position y)))))] - [do-renaming? - (or (not (name-duplication? to-be-renamed id-sets new-sym)) - (equal? - (message-box/custom - (string-constant check-syntax) - (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) - new-sym) - (string-constant cs-rename-anyway) - (string-constant cancel) - #f - parent - '(stop default=2)) - 1))]) - (when do-renaming? - (unless (null? to-be-renamed) - (let ([txts (list defs-text)]) - (send defs-text begin-edit-sequence) - (for-each (λ (stx) - (let ([source-editor (find-source-editor/defs stx defs-text)]) - (when (is-a? source-editor text%) - (unless (memq source-editor txts) - (send source-editor begin-edit-sequence) - (set! txts (cons source-editor txts))) - (let* ([start (- (syntax-position stx) 1)] - [end (+ start (syntax-span stx))]) - (send source-editor delete start end #f) - (send source-editor insert new-sym start start #f))))) - to-be-renamed) - (send defs-text invalidate-bitmap-cache) - (for-each - (λ (txt) (send txt end-edit-sequence)) - txts)))))))) - - ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean - ;; returns #t if the name chosen would be the same as another name in this scope. - (define (name-duplication? to-be-renamed id-sets new-str) - (let ([new-ids (map (λ (id) (datum->syntax id (string->symbol new-str))) - to-be-renamed)]) - (ormap (λ (id-set) - (ormap (λ (new-id) (get-ids id-set new-id)) - new-ids)) - id-sets))) - - ;; remove-duplicates : (listof syntax[original]) -> (listof syntax[original]) - ;; removes duplicates, based on the source locations of the identifiers - (define (remove-duplicates ids) - (cond - [(null? ids) null] - [else (let loop ([fst (car ids)] - [rst (cdr ids)]) - (cond - [(null? rst) (list fst)] - [else (if (and (eq? (syntax-source fst) - (syntax-source (car rst))) - (= (syntax-position fst) - (syntax-position (car rst)))) - (loop fst (cdr rst)) - (cons fst (loop (car rst) (cdr rst))))]))])) - - - ; - ; - ; - ; ; ; ; ; - ; ; ; ; - ; ; ; ; ; - ; ; ; ; ; ; ; ; ;;; ; ; ; ;; - ; ; ; ; ; ; ;; ; ; ; ; ;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;;;;;; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ;; ; - ; ; ; ; ; ;;;; ;; ; ; ;; - ; ; - ; ; - ; ; - - - (add-check-syntax-key-bindings (drscheme:rep:get-drs-bindings-keymap)) - (fw:color-prefs:add-to-preferences-panel (string-constant check-syntax) - syncheck-add-to-preferences-panel) - (drscheme:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t) - (drscheme:get/extend:extend-definitions-text make-syncheck-text%) - (drscheme:get/extend:extend-unit-frame unit-frame-mixin #f) - (drscheme:get/extend:extend-tab tab-mixin))) From bf1aaa9dcbeb5ab8a51dd885f664e205dcd38628 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 21:55:03 +0000 Subject: [PATCH 11/13] add contract conversion for hashtables svn: r13617 --- collects/typed-scheme/private/type-contract.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 9e1366ab36..da0990418e 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -121,6 +121,7 @@ #`(syntax/c #,(t->c t)))] [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))] [(Param: in out) #`(parameter/c #,(t->c out))] + [(Hashtable: k v) #`hash?] [else (exit (fail))])))) From 204806a13acc831a2c6954c4b9ef00e3239c2e86 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 21:57:30 +0000 Subject: [PATCH 12/13] revert back to regular parse type svn: r13619 --- .../typed-scheme/unit-tests/parse-type-tests.ss | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index caf3dda7c2..cfe775ea65 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -3,13 +3,14 @@ (require (utils tc-utils) (env type-alias-env type-environments type-name-env init-envs) (rep type-rep) - (private type-comparison parse-type subtype - union type-utils) + (rename-in (private type-comparison parse-type subtype + union type-utils) + [Un t:Un]) (schemeunit)) (require (rename-in (private type-effect-convenience) [-> t:->]) - (private base-types) - (for-template (private base-types))) + (private base-types base-types-extra) + (for-template (private base-types base-types-extra))) (provide parse-type-tests) @@ -72,9 +73,9 @@ [(Number Number Number Boolean -> Number) (N N N B . t:-> . N)] [(Number Number Number * -> Boolean) ((list N N) N . ->* . B)] ;[((. Number) -> Number) (->* (list) N N)] ;; not legal syntax - [(U Number Boolean) (Un N B)] - [(U Number Boolean Number) (Un N B)] - [(U Number Boolean 1) (Un N B)] + [(U Number Boolean) (t:Un N B)] + [(U Number Boolean Number) (t:Un N B)] + [(U Number Boolean 1) (t:Un N B)] [(All (a) (Listof a)) (-poly (a) (make-Listof a))] [(All (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] [(∀ (a) (Listof a)) (-poly (a) (make-Listof a))] From 3dd83a4e1c94cf5fd53464cad4a1fd693cba79f0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 22:29:27 +0000 Subject: [PATCH 13/13] remove this junk svn: r13625 --- collects/drscheme/private/mred-typed.ss | 103 ------------------------ 1 file changed, 103 deletions(-) delete mode 100644 collects/drscheme/private/mred-typed.ss diff --git a/collects/drscheme/private/mred-typed.ss b/collects/drscheme/private/mred-typed.ss deleted file mode 100644 index e906dbc81a..0000000000 --- a/collects/drscheme/private/mred-typed.ss +++ /dev/null @@ -1,103 +0,0 @@ -#lang planet plt typed-scheme.plt 3 1 - -;(require mred/mred) -(provide (all-defined-out)) - -(define-type-alias Bitmap% (Class (Number Number Boolean) - () - ([get-width (-> Number)] - [get-height (-> Number)]))) -(define-type-alias Font-List% (Class () () ([find-or-create-font (Any .. -> (Instance Font%))]))) -(define-type-alias Font% (Class () () ([get-face (-> (Option String))] - [get-point-size (-> Number)]))) -(define-type-alias Dialog% (Class () - ([parent Any] [width Number] [label String]) - ([show (Any -> Void)]))) -(define-type-alias Text-Field% (Class () - ([parent Any] [callback Any] [label String]) - ([get-value (-> String)] - [focus (-> String)]))) -(define-type-alias Horizontal-Panel% (Class () - ([parent Any] - [stretchable-height Any #t] - [alignment (List Symbol Symbol) #t]) - ())) -(define-type-alias Choice% (Class () - ([parent Any] [label String] [choices List] [callback Any]) - ([get-string-selection (-> (Option String))] - [set-string-selection (String -> Void)]))) -(define-type-alias Message% (Class () - ([parent Any] [label String]) - ([set-label ((U String (Instance Bitmap%)) -> Void)]))) -(define-type-alias Horizontal-Pane% (Class () - ([parent Any]) - ())) -(define-type-alias Editor-Canvas% (Class () - ([parent Any] [editor Any]) - ([set-line-count (Number -> Void)]))) -(define-type-alias Bitmap-DC% (Class ((Instance Bitmap%)) - () - ([get-text-extent (String (Instance Font%) -> (values Number Number Number Number))] - [get-pixel (Number Number (Instance Color%) -> Boolean)] - [set-bitmap ((Option (Instance Bitmap%)) -> Void)] - [clear (-> Void)] - [set-font ((Instance Font%) -> Void)] - [draw-text (String Number Number -> Void)]))) -(define-type-alias Color% (Class () () ([red (-> Number)]))) -(define-type-alias Style-List% (Class () - () - ([find-named-style - (String -> (Instance (Class () - () - ([get-font (-> (Instance Font%))]))))]))) - -(define-type-alias Scheme:Text% (Class () - () - ([begin-edit-sequence (-> Void)] - [end-edit-sequence (-> Void)] - [lock (Boolean -> Void)] - [last-position (-> Number)] - [last-paragraph (-> Number)] - [delete (Number Number -> Void)] - [auto-wrap (Any -> Void)] - [paragraph-end-position (Number -> Number)] - [paragraph-start-position (Number -> Number)] - [get-start-position (-> Number)] - [get-end-position (-> Number)] - [insert (String Number Number -> Void)]))) - -(require/typed mred/mred - [the-font-list (Instance Font-List%)] - [dialog% Dialog%] - [text-field% Text-Field%] - [horizontal-panel% Horizontal-Panel%] - [choice% Choice%] - [get-face-list (-> (Listof String))] - [message% Message%] - [horizontal-pane% Horizontal-Pane%] - [editor-canvas% Editor-Canvas%] - [bitmap-dc% Bitmap-DC%] - [bitmap% Bitmap%] - [color% Color%]) - -(require/typed framework/framework - [preferences:set-default (Symbol Any Any -> Void)] - [preferences:set (Symbol Any -> Void)] - [editor:get-standard-style-list - (-> (Instance Style-List%))] - [scheme:text% Scheme:Text%] - [gui-utils:ok/cancel-buttons (Any (Any Any -> Any) (Any Any -> Any) -> (values Any Any))]) - -(require/typed "prefs-contract.ss" - [preferences:get-drscheme:large-letters-font (-> (Pair Symbol Number))]) - -(require (only-in "prefs-contract.ss" preferences:get)) -(provide preferences:get preferences:get-drscheme:large-letters-font) - -(define-type-alias Bitmap-Message% (Class () - ([parent Any]) - ([set-bm ((Instance Bitmap%) -> Void)]))) - - -(require/typed "bitmap-message.ss" - [bitmap-message% Bitmap-Message%]) \ No newline at end of file