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

Rackety: bring down below 102 columns

Browse Source
This commit is contained in:
Robby Findler 2013-07-25 10:00:07 -05:00
parent 3c219e513f
commit 52462ecfa1
1 changed files with 44 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
pkgs/drracket-pkgs/drracket/drracket/private/syncheck/traversals.rkt
View File

@ -21,25 +21,6 @@
(define current-max-to-send-at-once (make-parameter +inf.0)) (define current-max-to-send-at-once (make-parameter +inf.0))
;
;
;
; ;
; ;
; ; ; ;
; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;;
; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;;
; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;;
; ;
; ;
; ;
;; make-traversal : namespace string[directory] -> (values (syntax (union #f syntax) -> void) ;; make-traversal : namespace string[directory] -> (values (syntax (union #f syntax) -> void)
;; (-> void)) ;; (-> void))
;; returns a pair of functions that close over some state that ;; returns a pair of functions that close over some state that
@ -152,7 +133,8 @@
[tail-parent-pos #f] [tail-parent-pos #f]
;; mods: (or/f #f ; => outside a module ;; mods: (or/f #f ; => outside a module
;; '() ; => inside the main module in this file ;; '() ; => inside the main module in this file
;; '(name names ...) ; => inside some submodules named by name & names ;; '(name names ...) ; => inside some submodules
;; named by name & names
[mods #f]) [mods #f])
(define-values (next-tail-parent-src next-tail-parent-pos) (define-values (next-tail-parent-src next-tail-parent-pos)
(let ([child-src (find-source-editor stx-obj)] (let ([child-src (find-source-editor stx-obj)]
@ -181,12 +163,17 @@
(if mods (if mods
(cons mod mods) (cons mod mods)
'())))] '())))]
[loop (λ (sexp) (level+tail+mod-loop sexp level level-of-enclosing-module #f #f mods))] [loop (λ (sexp) (level+tail+mod-loop sexp level level-of-enclosing-module
[varrefs (lookup-phase-to-mapping phase-to-varrefs (+ level level-of-enclosing-module))] #f #f mods))]
[varsets (lookup-phase-to-mapping phase-to-varsets (+ level level-of-enclosing-module))] [varrefs (lookup-phase-to-mapping phase-to-varrefs
[binders (lookup-phase-to-mapping phase-to-binders (+ level level-of-enclosing-module))] (+ level level-of-enclosing-module))]
[varsets (lookup-phase-to-mapping phase-to-varsets
(+ level level-of-enclosing-module))]
[binders (lookup-phase-to-mapping phase-to-binders
(+ level level-of-enclosing-module))]
[tops (lookup-phase-to-mapping phase-to-tops (+ level level-of-enclosing-module))] [tops (lookup-phase-to-mapping phase-to-tops (+ level level-of-enclosing-module))]
[requires (hash-ref! phase-to-requires (+ level level-of-enclosing-module) (λ () (make-hash)))] [requires (hash-ref! phase-to-requires (+ level level-of-enclosing-module)
(λ () (make-hash)))]
[collect-general-info [collect-general-info
(λ (stx) (λ (stx)
(add-origins stx varrefs level-of-enclosing-module) (add-origins stx varrefs level-of-enclosing-module)
@ -205,8 +192,8 @@
(loop fst) (loop fst)
(body-loop (car bodies) (cdr bodies))])))) (body-loop (car bodies) (cdr bodies))]))))
(syntax-case* stx-obj (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! (syntax-case* stx-obj (#%plain-lambda case-lambda if begin begin0 let-values letrec-values
quote quote-syntax with-continuation-mark set! quote quote-syntax with-continuation-mark
#%plain-app #%top #%plain-module-begin #%plain-app #%top #%plain-module-begin
define-values define-syntaxes begin-for-syntax define-values define-syntaxes begin-for-syntax
module module* module module*
@ -254,7 +241,8 @@
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module) (annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
(for-each collect-general-info (syntax->list (syntax (bindings ...)))) (for-each collect-general-info (syntax->list (syntax (bindings ...))))
(with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
(for-each (λ (x es) (add-binders x binders binding-inits es level-of-enclosing-module)) (for-each (λ (x es) (add-binders x binders binding-inits es
level-of-enclosing-module))
(syntax->list (syntax ((xss ...) ...))) (syntax->list (syntax ((xss ...) ...)))
(syntax->list (syntax (es ...)))) (syntax->list (syntax (es ...))))
(for-each loop (syntax->list (syntax (es ...)))) (for-each loop (syntax->list (syntax (es ...))))
@ -264,7 +252,8 @@
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module) (annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
(for-each collect-general-info (syntax->list (syntax (bindings ...)))) (for-each collect-general-info (syntax->list (syntax (bindings ...))))
(with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))])
(for-each (λ (x es) (add-binders x binders binding-inits es level-of-enclosing-module)) (for-each (λ (x es) (add-binders x binders binding-inits es
level-of-enclosing-module))
(syntax->list (syntax ((xss ...) ...))) (syntax->list (syntax ((xss ...) ...)))
(syntax->list (syntax (es ...)))) (syntax->list (syntax (es ...))))
(for-each loop (syntax->list (syntax (es ...)))) (for-each loop (syntax->list (syntax (es ...))))
@ -328,7 +317,8 @@
[(begin-for-syntax exp ...) [(begin-for-syntax exp ...)
(begin (begin
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module) (annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
(for-each (lambda (e) (level-loop e (+ level 1))) (syntax->list (syntax (exp ...)))))] (for ([e (in-list (syntax->list (syntax (exp ...))))])
(level-loop e (+ level 1))))]
[(module m-name lang (#%plain-module-begin bodies ...)) [(module m-name lang (#%plain-module-begin bodies ...))
(begin (begin
(annotate-raw-keyword stx-obj varrefs level-of-enclosing-module) (annotate-raw-keyword stx-obj varrefs level-of-enclosing-module)
@ -356,7 +346,8 @@
(let loop ([spec spec] (let loop ([spec spec]
[level level]) [level level])
(define (add-to-level n) (and n level (+ n level))) (define (add-to-level n) (and n level (+ n level)))
(syntax-case* spec (for-meta for-syntax for-template for-label just-meta) symbolic-compare? (syntax-case* spec (for-meta for-syntax for-template for-label just-meta)
symbolic-compare?
[(for-meta phase specs ...) [(for-meta phase specs ...)
(for ([spec (in-list (syntax->list #'(specs ...)))]) (for ([spec (in-list (syntax->list #'(specs ...)))])
(loop spec (add-to-level (syntax-e #'phase))))] (loop spec (add-to-level (syntax-e #'phase))))]
@ -452,7 +443,9 @@
[(identifier? prop) [(identifier? prop)
(add-id id-set prop level-of-enclosing-module)]))))) (add-id id-set prop level-of-enclosing-module)])))))
;; annotate-variables : namespace directory string id-set[four of them] (listof syntax) (listof syntax) -> void ;; 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 ;; colors in and draws arrows for variables, according to their classifications
;; in the various id-sets ;; in the various id-sets
(define (annotate-variables user-namespace (define (annotate-variables user-namespace
@ -471,8 +464,10 @@
(define unused-require-for-labels (make-hash)) (define unused-require-for-labels (make-hash))
(define unused/phases (make-hash)) (define unused/phases (make-hash))
;; hash[(list (list src pos pos) (list src pos pos)) -o> #t ;; indicates if this arrow has been recorded ;; hash[(list (list src pos pos) (list src pos pos)) -o> #t
;; (list src pos pos) -o> (cons number number)] ;; indicates the number of defs and uses at this spot ;; above indicates if this arrow has been recorded
;; below indicates the number of defs and uses at this spot
;; (list src pos pos) -o> (cons number number)]
(define connections (make-hash)) (define connections (make-hash))
(for ([(level requires) (in-hash phase-to-requires)]) (for ([(level requires) (in-hash phase-to-requires)])
@ -541,7 +536,8 @@
(annotate-counts connections)) (annotate-counts connections))
;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] hash-table[syntax -o> #t] -> void ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] hash-table[syntax -o> #t]
;; -> void
(define (color-unused requires unused module-lang-requires) (define (color-unused requires unused module-lang-requires)
(hash-for-each (hash-for-each
unused unused
@ -561,7 +557,9 @@
(color stx unused-require-style-name))) (color stx unused-require-style-name)))
(hash-ref requires k (hash-ref requires k
(λ () (λ ()
(error 'syncheck/traversals.rkt "requires doesn't have a mapping for ~s" k))))))) (error 'syncheck/traversals.rkt
"requires doesn't have a mapping for ~s"
k)))))))
;; id-level : integer-or-#f-or-'lexical identifier -> symbol ;; id-level : integer-or-#f-or-'lexical identifier -> symbol
(define (id-level phase-level id) (define (id-level phase-level id)
@ -614,7 +612,8 @@
id id
(syntax->datum req-stx)) (syntax->datum req-stx))
(when id (when id
(define-values (filename submods) (get-require-filename source-req-path user-namespace user-directory)) (define-values (filename submods)
(get-require-filename source-req-path user-namespace user-directory))
(when filename (when filename
(add-jump-to-definition (add-jump-to-definition
var var
@ -664,7 +663,8 @@
[_ stx])) [_ stx]))
;; get-module-req-path : identifier number [#:nominal? boolean] -> (union #f (list require-sexp sym ?? module-path)) ;; get-module-req-path : identifier number [#:nominal? boolean]
;; -> (union #f (list require-sexp sym ?? module-path))
(define (get-module-req-path var phase-level #:nominal? [nominal-source-path? #t]) (define (get-module-req-path var phase-level #:nominal? [nominal-source-path? #t])
(define binding (identifier-binding var phase-level)) (define binding (identifier-binding var phase-level))
(and (pair? binding) (and (pair? binding)
@ -789,8 +789,10 @@
(hash-set! connections connections-key #t) (hash-set! connections connections-key #t)
(define start-before (or (hash-ref connections connections-start #f) (cons 0 0))) (define start-before (or (hash-ref connections connections-start #f) (cons 0 0)))
(define end-before (or (hash-ref connections connections-end #f) (cons 0 0))) (define end-before (or (hash-ref connections connections-end #f) (cons 0 0)))
(hash-set! connections connections-start (cons (+ (car start-before) 1) (cdr start-before))) (hash-set! connections connections-start (cons (+ (car start-before) 1)
(hash-set! connections connections-end (cons (car end-before) (+ 1 (cdr end-before))))) (cdr start-before)))
(hash-set! connections connections-end (cons (car end-before)
(+ 1 (cdr end-before)))))
(define (name-dup? str) (define (name-dup? str)
(define sym (string->symbol str)) (define sym (string->symbol str))
(define id1 (datum->syntax from sym)) (define id1 (datum->syntax from sym))
@ -946,7 +948,8 @@
;; trim-require-prefix : syntax -> syntax ;; trim-require-prefix : syntax -> syntax
(define (trim-require-prefix require-spec) (define (trim-require-prefix require-spec)
(syntax-case* require-spec (only prefix all-except prefix-all-except rename just-meta) symbolic-compare? (syntax-case* require-spec (only prefix all-except prefix-all-except rename just-meta)
symbolic-compare?
[(only module-name identifier ...) [(only module-name identifier ...)
(syntax module-name)] (syntax module-name)]
[(prefix identifier module-name) [(prefix identifier module-name)