From a50eeb458fad45e8f3f2b1e986cf0f61cdc90301 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 4 Oct 2014 16:18:53 -0500
Subject: [PATCH] add show-content as a simple way to get started with the
 drracket/check-syntax library

---
 .../drracket-tools/drracket-tools.scrbl       | 45 +++++++++--
 .../drracket/check-syntax.rkt                 | 75 +++++++++++++-----
 .../drracket/private/syncheck/traversals.rkt  | 46 ++++++++++-
 .../drracket/private/syncheck/online-comp.rkt | 76 ++++++-------------
 4 files changed, 166 insertions(+), 76 deletions(-)

diff --git a/pkgs/drracket-pkgs/drracket-tool-doc/scribblings/drracket-tools/drracket-tools.scrbl b/pkgs/drracket-pkgs/drracket-tool-doc/scribblings/drracket-tools/drracket-tools.scrbl
index 663108b288..955214b895 100644
--- a/pkgs/drracket-pkgs/drracket-tool-doc/scribblings/drracket-tools/drracket-tools.scrbl
+++ b/pkgs/drracket-pkgs/drracket-tool-doc/scribblings/drracket-tools/drracket-tools.scrbl
@@ -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].
-}
\ No newline at end of file
+}
+
+
+@(close-eval syncheck-example-eval)
diff --git a/pkgs/drracket-pkgs/drracket-tool-lib/drracket/check-syntax.rkt b/pkgs/drracket-pkgs/drracket-tool-lib/drracket/check-syntax.rkt
index 076d4d6903..009f3aa8b3 100644
--- a/pkgs/drracket-pkgs/drracket-tool-lib/drracket/check-syntax.rkt
+++ b/pkgs/drracket-pkgs/drracket-tool-lib/drracket/check-syntax.rkt
@@ -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))
diff --git a/pkgs/drracket-pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt b/pkgs/drracket-pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt
index 544fa7bb29..d21a4752ff 100644
--- a/pkgs/drracket-pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt
+++ b/pkgs/drracket-pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt
@@ -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)))
diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt
index 455365afef..89afe0e519 100644
--- a/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt
+++ b/pkgs/drracket-pkgs/drracket/drracket/private/syncheck/online-comp.rkt
@@ -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