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

add show-content as a simple way to get started with the

Browse Source 
drracket/check-syntax library
This commit is contained in:
Robby Findler 2014-10-04 16:18:53 -05:00
parent d46b097bc8
commit a50eeb458f
4 changed files with 166 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
pkgs/drracket-pkgs/drracket-tool-doc/scribblings/drracket-tools/drracket-tools.scrbl
View File

@ -2,6 +2,11 @@
@(require scribble/eval
(for-label drracket/check-syntax
racket))
@(define syncheck-example-eval (make-base-eval))
@(begin
(syncheck-example-eval
'(require drracket/check-syntax racket/class)))
@title{DrRacket Tools}
@author{Robert Bruce Findler}
@ -15,6 +20,36 @@ that are exposed via Racket APIs to be used with other editors.
@defmodule[drracket/check-syntax]
@defproc[(show-content [file-or-stx (or/c path-string?
(and/c syntax?
(λ (x) (path-string? (syntax-source x)))))])
(listof vector?)]{
This procedure composes the other pieces of this library together in a way that can be used
for REPL-style experimentation with the results from Check Syntax, as shown in the example
below. The list it returns has one vector for each call that would be made to the
object in @racket[current-annotations]. Each vector's first element is a symbol naming
a method in @racket[syncheck-annotations<%>] and the other elements of the vector are
the arguments passed to the method.
This doesn't work as well for use in a real tool, however, because it doesn't account for
the callback procedures present in @method[syncheck-annotations<%> syncheck:add-arrow/name-dup]
and @method[syncheck-annotations<%> syncheck:add-id-set] and the resulting vectors are probably less
convenient to work with than direct method calls for most uses of this library. Nevertheless,
it gives a quick feel for the results that can come back from Check Syntax.
See @racket[annotations-mixin] for some example code to use the other parts of this library.
@interaction[#:eval
syncheck-example-eval
(let ([example-module
'(module m racket (λ (x) x))])
(show-content
(read-syntax
(build-path (current-directory) "dummy-file.rkt")
(open-input-string (format "~s" example-module)))))]
}
@defproc[(make-traversal [namespace namespace?]
[path (or/c #f path-string?)])
(values (->* (syntax?)
@ -218,8 +253,6 @@ that are exposed via Racket APIs to be used with other editors.
}
}
@(define syncheck-example-eval (make-base-eval))
@defmixin[annotations-mixin () (syncheck-annotations<%>)]{
Supplies all of the methods in @racket[syncheck-annotations<%>]
with default behavior. Be sure to use this mixin to future-proof
@ -242,7 +275,6 @@ that are exposed via Racket APIs to be used with other editors.
call to @racket[datum->syntax].
@interaction[#:eval
syncheck-example-eval
(require drracket/check-syntax racket/class)
(define arrows-collector%
(class (annotations-mixin object%)
(super-new)
@ -279,8 +311,6 @@ that are exposed via Racket APIs to be used with other editors.
(arrows `(λ (,(make-id 'x 1 #t)) x))]
}
@(close-eval syncheck-example-eval)
@(define-syntax-rule
(syncheck-method-id x ...)
(begin @defidform[x]{Bound to an identifier created with
@ -306,4 +336,7 @@ that are exposed via Racket APIs to be used with other editors.
@defproc[(module-browser [path path-string?]) void?]{
Opens a window containing the module browser for @racket[path].
}
}
@(close-eval syncheck-example-eval)

75
pkgs/drracket-pkgs/drracket-tool-lib/drracket/check-syntax.rkt
View File

@ -1,26 +1,35 @@
#lang at-exp racket/base
#lang racket/base
(require racket/contract
racket/class
syntax/modread
"private/syncheck/traversals.rkt"
"private/syncheck/syncheck-intf.rkt"
"private/syncheck/syncheck-local-member-names.rkt")
(provide/contract
[make-traversal
(-> namespace?
(or/c path-string? #f)
(values (->* (syntax?) ((-> any/c void?)) void?)
(-> void?)))]
[current-max-to-send-at-once
(parameter/c (or/c +inf.0 (and/c exact-integer? (>=/c 2))))]
[syncheck-annotations<%>
interface?]
[current-annotations
(parameter/c (or/c #f (is-a?/c syncheck-annotations<%>)))]
[annotations-mixin
(and/c mixin-contract
(-> any/c (implementation?/c syncheck-annotations<%>)))])
(provide
(contract-out
[show-content (-> (or/c path-string?
(and/c syntax?
has-path-string-source?))
(listof vector?))]
[make-traversal
(-> namespace?
(or/c path-string? #f)
(values (->* (syntax?) ((-> any/c void?)) void?)
(-> void?)))]
[current-max-to-send-at-once
(parameter/c (or/c +inf.0 (and/c exact-integer? (>=/c 2))))]
[syncheck-annotations<%>
interface?]
[current-annotations
(parameter/c (or/c #f (is-a?/c syncheck-annotations<%>)))]
[annotations-mixin
(and/c mixin-contract
(-> any/c (implementation?/c syncheck-annotations<%>)))]))
(define (has-path-string-source? stx)
(path-string? (syntax-source stx)))
;; methods in syncheck-annotations<%>
(provide
@ -36,3 +45,35 @@
syncheck:add-mouse-over-status
syncheck:add-jump-to-definition
syncheck:color-range)
(define (show-content file-or-stx)
(define ns (make-base-namespace))
(define src
(cond
[(path-string? file-or-stx)
file-or-stx]
[(syntax? file-or-stx)
(syntax-source file-or-stx)]))
(define o (new build-trace% [src src]))
(parameterize ([current-annotations o])
(define-values (expanded-expression expansion-completed)
(make-traversal ns src))
(cond
[(path-string? file-or-stx)
(parameterize ([current-namespace ns])
(expanded-expression
(expand
(call-with-input-file file-or-stx
(λ (port)
(with-module-reading-parameterization
(λ ()
(read-syntax file-or-stx port))))))))]
[else
(parameterize ([current-namespace ns])
(expanded-expression
(expand
file-or-stx)))])
(expansion-completed))
(send o get-trace))

46
pkgs/drracket-pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt
View File

@ -15,12 +15,14 @@
racket/contract
racket/pretty
syntax/boundmap
scribble/manual-struct)
scribble/manual-struct
(for-syntax racket/base))
(define-logger check-syntax)
(provide make-traversal
current-max-to-send-at-once)
current-max-to-send-at-once
build-trace%)
(define current-max-to-send-at-once (make-parameter +inf.0))
@ -1306,3 +1308,43 @@
;; for-each-ids : id-set ((listof identifier) -> void) -> void
(define (for-each-ids mapping f)
(free-identifier-mapping-for-each mapping (λ (x y) (f y))))
(define build-trace%
(class (annotations-mixin object%)
(init-field src)
(define trace '())
(define/override (syncheck:find-source-object stx)
(and (equal? src (syntax-source stx))
src))
;; send over the non _ variables in the message to the main drracket place
(define-syntax (log stx)
(syntax-case stx ()
[(_ name args ...)
(with-syntax ([(wanted-args ...)
(filter (λ (x) (not (regexp-match #rx"^_" (symbol->string (syntax-e x)))))
(syntax->list #'(args ...)))])
#'(define/override (name args ...)
(add-to-trace (vector 'name wanted-args ...))))]))
(log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos)
(log syncheck:add-arrow/name-dup
_start-text start-pos-left start-pos-right
_end-text end-pos-left end-pos-right
actual? level require-arrow? name-dup?)
(log syncheck:add-mouse-over-status _text pos-left pos-right str)
(log syncheck:add-background-color _text color start fin)
(log syncheck:add-jump-to-definition _text start end id filename submods)
(log syncheck:add-definition-target _text start-pos end-pos id mods)
(log syncheck:add-require-open-menu _text start-pos end-pos file)
(log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag)
(log syncheck:add-id-set to-be-renamed/poss dup-name?)
(define/public (get-trace) (reverse trace))
(define/public (add-to-trace thing)
(set! trace (cons thing trace)))
(super-new)))

76
pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt
View File

@ -13,56 +13,6 @@
(provide go monitor)
(define obj%
(class (annotations-mixin object%)
(init-field src orig-cust)
(define trace '())
(define-values (remote-chan local-chan) (place-channel))
(define table (make-hash))
(create-rename-answerer-thread orig-cust local-chan table)
(define/override (syncheck:find-source-object stx)
(and (equal? src (syntax-source stx))
src))
;; send over the non _ variables in the message to the main drracket place
(define-syntax (log stx)
(syntax-case stx ()
[(_ name args ...)
(with-syntax ([(wanted-args ...)
(filter (λ (x) (not (regexp-match #rx"^_" (symbol->string (syntax-e x)))))
(syntax->list #'(args ...)))])
#'(define/override (name args ...)
(add-to-trace (vector 'name wanted-args ...))))]))
(define/override (syncheck:add-arrow/name-dup _start-text start-pos-left start-pos-right
_end-text end-pos-left end-pos-right
actual? level require-arrow? name-dup?)
(define id (hash-count table))
(hash-set! table id name-dup?)
(add-to-trace (vector 'syncheck:add-arrow/name-dup
start-pos-left start-pos-right
end-pos-left end-pos-right
actual? level require-arrow? remote-chan id)))
(log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos)
(log syncheck:add-mouse-over-status _text pos-left pos-right str)
(log syncheck:add-background-color _text color start fin)
(log syncheck:add-jump-to-definition _text start end id filename submods)
(log syncheck:add-definition-target _text start-pos end-pos id mods)
(log syncheck:add-require-open-menu _text start-pos end-pos file)
(log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag)
(define/override (syncheck:add-id-set to-be-renamed/poss dup-name?)
(define id (hash-count table))
(hash-set! table id dup-name?)
(add-to-trace (vector 'syncheck:add-id-set (map cdr to-be-renamed/poss) remote-chan id)))
(define/public (get-trace) (reverse trace))
(define/private (add-to-trace thing)
(set! trace (cons thing trace)))
(super-new)))
(define (create-rename-answerer-thread orig-cust local-chan table)
;; the hope is that changing the custodian like this
;; shouldn't leak these threads, but it does seem to
@ -103,7 +53,7 @@
(printf " ~s\n" x))
(printf "===\n")
(raise x))))
(define obj (new obj%
(define obj (new build-place-chan-trace%
[src the-source]
[orig-cust orig-cust]))
(define-values (expanded-expression expansion-completed)
@ -115,6 +65,30 @@
(expansion-completed))
(send obj get-trace))))
(define build-place-chan-trace%
(class build-trace%
(inherit add-to-trace)
(init-field orig-cust)
(define-values (remote-chan local-chan) (place-channel))
(define table (make-hash))
(create-rename-answerer-thread orig-cust local-chan table)
(define/override (syncheck:add-arrow/name-dup _start-text start-pos-left start-pos-right
_end-text end-pos-left end-pos-right
actual? level require-arrow? name-dup?)
(define id (hash-count table))
(hash-set! table id name-dup?)
(add-to-trace (vector 'syncheck:add-arrow/name-dup
start-pos-left start-pos-right
end-pos-left end-pos-right
actual? level require-arrow? remote-chan id)))
(define/override (syncheck:add-id-set to-be-renamed/poss dup-name?)
(define id (hash-count table))
(hash-set! table id dup-name?)
(add-to-trace (vector 'syncheck:add-id-set (map cdr to-be-renamed/poss) remote-chan id)))
(super-new)))
(define (monitor send-back path the-source orig-cust)
(define lr (make-log-receiver (current-logger)
'info