Go back to previous expansion strategy.

The DrRacket expansion functions don't offer anything more than plain
expand + a sandbox, and using them made the code less readable.

This reverts commit 96eee2b317.
This reverts commit 19ce4d44a5.
This reverts commit 58fbd8ba75.
This reverts commit b305ea9c62.
This reverts commit 860feb30ae.

collects/typed-scheme/optimizer/tool/display.rkt

@@ -2,7 +2,7 @@
 
 (require racket/string racket/class racket/gui/base racket/match racket/port
          framework syntax/to-string
-         "report-structs.rkt"
+         "report.rkt"
          unstable/sequence unstable/pretty)
 
 (provide popup-callback make-color-table)

collects/typed-scheme/optimizer/tool/report-sig.rkt

@@ -1,3 +0,0 @@
-#lang racket/signature
-
-generate-report

collects/typed-scheme/optimizer/tool/report-structs.rkt

@@ -1,18 +0,0 @@
-#lang racket/base
-
-(provide (struct-out report-entry)
-         (struct-out sub-report-entry)
-         (struct-out opt-report-entry)
-         (struct-out missed-opt-report-entry))
-
-;; Similar to the log-entry family of structs, but geared towards GUI display.
-;; Also designed to contain info for multiple overlapping log entries.
-;; - subs is a list of sub-report-entry, corresponding to all the entries
-;;   between start and end
-;; - badness is 0 for a report-entry containing only optimizations
-;;   otherwise, it's the sum for all the subs
-(struct report-entry (subs start end badness))
-;; multiple of these can be contained in a report-entry
-(struct sub-report-entry (stx msg))
-(struct opt-report-entry        sub-report-entry ())
-(struct missed-opt-report-entry sub-report-entry (badness irritants))

collects/typed-scheme/optimizer/tool/report.rkt

@@ -1,51 +1,38 @@
-#lang racket/unit
+#lang racket/base
 
 (require racket/class racket/gui/base racket/match
-         unstable/syntax drracket/tool
+         unstable/syntax)
-         unstable/logging)
 
-(require typed-scheme/optimizer/logging
+(require (prefix-in tr: typed-scheme/typed-reader)
-         "report-sig.rkt" "report-structs.rkt")
+         typed-scheme/optimizer/logging)
 
-(import drracket:tool^)
+(provide (struct-out report-entry)
-(export report^)
+         (struct-out sub-report-entry)
+         (struct-out opt-report-entry)
+         (struct-out missed-opt-report-entry)
+         generate-report)
 
+;; Similar to the log-entry family of structs, but geared towards GUI display.
+;; Also designed to contain info for multiple overlapping log entries.
+;; - subs is a list of sub-report-entry, corresponding to all the entries
+;;   between start and end
+;; - badness is 0 for a report-entry containing only optimizations
+;;   otherwise, it's the sum for all the subs
+(struct report-entry (subs start end badness))
+;; multiple of these can be contained in a report-entry
+(struct sub-report-entry (stx msg))
+(struct opt-report-entry        sub-report-entry ())
+(struct missed-opt-report-entry sub-report-entry (badness irritants))
 
 (define (generate-report this)
   (collapse-report (log->report (generate-log this))))
 
 
 (define (generate-log this)
-
-  ;; expand and capture log messages
-  (define log '())
-  (define listener #f)
-  (define exception #f)
-  (define done-chan (make-channel))
-  (drracket:eval:expand-program
-   (drracket:language:make-text/pos
-    this 0 (send this last-position))
-   (send this get-next-settings) #t
-   (lambda () ; init
-     (uncaught-exception-handler
-      (lambda (e)
-        (set! exception e) ; something went wrong, save exception and die
-        (channel-put done-chan 'done) ; let the rest of the program carry on
-        (custodian-shutdown-all (current-custodian)))) ; kill ourselves
-     (set! listener (start-recording #:level 'warning)))
-   (lambda () ; kill
-     (channel-put done-chan 'done))
-   (lambda (term k)
-     (if (eof-object? term)
-         (begin (set! log (stop-recording listener)) ; done, stash the log
-                (channel-put done-chan 'done))
-         (k)))) ; not done, keep going
-  (channel-get done-chan) ; wait for expansion to finish
-
-  (when exception ; something went wrong, will be caught upstream
-    (raise exception))
-
   (define portname (send this get-port-name))
+  (define input    (open-input-text-editor this))
+  (port-count-lines! input)
+  (define log '())
   (define unsaved-file?
     (and (symbol? portname)
          (regexp-match #rx"^unsaved-editor" (symbol->string portname))))
@@ -64,26 +51,22 @@
            (not f)]
           [else ; different file
            #f]))
-
+  (with-intercepted-tr-logging
-  (define (post-process-log-entry l)
+   (lambda (l)
-    ;; make sure the message is indeed from the optimizer
+     (define log-entry-data (cdr (vector-ref l 2))) ; log-entry struct
-    (cond [(log-message-from-tr-opt? l)
+     (define stx (log-entry-stx log-entry-data))
-           (define log-entry-data (cdr (vector-ref l 2))) ; log-entry struct
+     (define path (if (and (syntax-source-directory stx)
-           (define stx (log-entry-stx log-entry-data))
+                           (syntax-source-file-name stx))
-           (define path (if (and (syntax-source-directory stx)
+                      (build-path (syntax-source-directory stx)
-                                 (syntax-source-file-name stx))
+                                  (syntax-source-file-name stx))
-                            (build-path (syntax-source-directory stx)
+                      #f))
-                                        (syntax-source-file-name stx))
+     (when (right-file? path)
-                            #f))
+       (set! log (cons log-entry-data log))))
-           ;; it also needs to come from the right file
+   (lambda ()
-           (if (right-file? path)
+     (parameterize ([current-namespace  (make-base-namespace)]
-               log-entry-data ; payload
+                    [read-accept-reader #t])
-               #f)]
+       (expand (tr:read-syntax portname input)))))
-          [else #f])) ; drop it
+  log)
-
-  (for/list ([l (in-list (map post-process-log-entry log))]
-             #:when l)
-    l))
 
 ;; converts log-entry structs to report-entry structs for further
 ;; processing

collects/typed-scheme/optimizer/tool/tool.rkt

@@ -3,7 +3,7 @@
 (require racket/class racket/port racket/list racket/match
          racket/gui/base racket/unit drracket/tool)
 
-(require "display.rkt" "report-sig.rkt" "report.rkt" "report-structs.rkt")
+(require "report.rkt" "display.rkt")
 
 (provide performance-report-drracket-button
          tool@)
@@ -17,73 +17,59 @@
 
 ;; performance-report-callback : drracket:unit:frame<%> -> void
 (define (performance-report-callback drr-frame)
-  (with-handlers
+  (send (send drr-frame get-definitions-text) add-highlights))
-      ([exn?
-        ;; typechecking failed, report in the interactions window
-        (lambda (e)
-          (define interactions (send drr-frame get-interactions-text))
-          (send interactions reset-console)
-          (send interactions run-in-evaluation-thread (lambda () (raise e))))])
-    (send (send drr-frame get-definitions-text) add-highlights)))
 
-(define-unit pre-tool@
+(define highlights-mixin
-  (import drracket:tool^ report^)
+  (mixin ((class->interface text%)) ()
-  (export drracket:tool-exports^)
+    (inherit begin-edit-sequence
+             end-edit-sequence
+             insert
+             get-text)
 
-  (define (phase1) (void))
+    (define highlights  '())
-  (define (phase2) (void))
+    (define color-table #f)
 
-  (define highlights-mixin
+    (define (highlight-entry l)
-    (mixin ((class->interface text%)) ()
+      (match l
-      (inherit begin-edit-sequence
+        [(report-entry subs start end badness)
-               end-edit-sequence
+         (let ([color (if (= badness 0)
-               insert
+                          "lightgreen"
-               get-text)
+                          (vector-ref color-table badness))])
+           (send this highlight-range start end color)
+           (send this set-clickback start end (popup-callback l))
+           ;; record highlight to undo it later
+           (list start end color))]))
 
-      (define highlights  '())
+    (define/public (add-highlights)
-      (define color-table #f)
+      (define report (generate-report this))
+      (define max-badness
+        (apply max (cons 0 (map report-entry-badness report))))
+      (unless (= max-badness 0) ; no missed opts, color table code would error
+        (set! color-table (make-color-table max-badness)))
+      (define new-highlights (map highlight-entry report))
+      (set! highlights (append new-highlights highlights)))
 
-      (define (highlight-entry l)
+    (define (clear-highlights)
-        (match l
+      (for ([h (in-list highlights)])
-          [(report-entry subs start end badness)
+        (match h
-           (let ([color (if (= badness 0)
+          [`(,start ,end . ,rest )
-                            "lightgreen"
+           (send this unhighlight-range . h)
-                            (vector-ref color-table badness))])
+           (send this remove-clickback start end)]))
-             (send this highlight-range start end color)
+      (set! highlights '()))
-             (send this set-clickback start end (popup-callback l))
-             ;; record highlight to undo it later
-             (list start end color))]))
 
-      (define/public (add-highlights)
+    (define/augment (after-insert start len)
-        (define report (generate-report this))
+      (clear-highlights))
-        (define max-badness
+    (define/augment (after-delete start len)
-          (apply max (cons 0 (map report-entry-badness report))))
+      (clear-highlights))
-        (unless (= max-badness 0) ; no missed opts, color table code would error
-          (set! color-table (make-color-table max-badness)))
-        (define new-highlights (map highlight-entry report))
-        (set! highlights (append new-highlights highlights)))
 
-      (define (clear-highlights)
+    (super-new)))
-        (for ([h (in-list highlights)])
-          (match h
-            [`(,start ,end . ,rest )
-             (send this unhighlight-range . h)
-             (send this remove-clickback start end)]))
-        (set! highlights '()))
 
-      (define/augment (after-insert start len)
+(define-unit tool@
-        (clear-highlights))
-      (define/augment (after-delete start len)
-        (clear-highlights))
-
-      (super-new)))
-
-  (drracket:get/extend:extend-definitions-text highlights-mixin))
-
-(define-compound-unit/infer tool@
   (import drracket:tool^)
   (export drracket:tool-exports^)
-  (link pre-tool@ report@))
+  (define (phase1) (void))
+  (define (phase2) (void))
+  (drracket:get/extend:extend-definitions-text highlights-mixin))
 
 (define performance-report-drracket-button
   (list