Highlight opts and missed-opts in the editor.

collects/typed-scheme/optimizer/logging.rkt

@@ -6,7 +6,8 @@
 
 (provide log-optimization log-missed-optimization
          print-log clear-log
-         with-tr-logging-to-port)
+         with-intercepted-tr-logging with-tr-logging-to-port
+         (struct-out log-entry))
 
 (define (line+col->string stx)
   (let ([line (syntax-line stx)]
@@ -15,7 +16,7 @@
         (format "~a:~a" line col)
         "(no location)")))
 
-(struct log-entry (msg stx pos) #:transparent)
+(struct log-entry (msg stx pos) #:prefab)
 
 ;; to identify log messages that come from the optimizer
 ;; to be stored in the data section of log messages
@@ -190,13 +191,21 @@
                  ", "))
         kind)))
 
-(define (with-tr-logging-to-port port thunk)
-  (with-intercepted-logging ; catch opt logs
+;; only intercepts TR log messages
+(define (with-intercepted-tr-logging interceptor thunk)
+  (with-intercepted-logging
+   #:level 'warning
    (lambda (l)
      (let ([data (vector-ref l 2)])
        ;; look only for optimizer messages
        (when (and (pair? data)
                   (eq? (car data) optimization-log-key))
-       (displayln (vector-ref l 1) port)))) ; print log message
-   thunk
-   #:level 'warning))
+         (interceptor l))))
+   thunk))
+
+(define (with-tr-logging-to-port port thunk)
+  (with-intercepted-tr-logging
+   #:level 'warning
+   (lambda (l)
+     (displayln (vector-ref l 1) port)) ; print log message
+   thunk))

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

@@ -1,6 +1,6 @@
 #lang racket/base
 
-(require racket/unit racket/class racket/port
+(require racket/unit racket/class racket/port racket/list
          racket/gui/base mrlib/switchable-button)
 
 (require (prefix-in tr: typed-scheme/typed-reader)
@@ -29,16 +29,32 @@
   (define portname (send defs      get-port-name))
   (define input    (open-input-text-editor defs))
   (port-count-lines! input)
+  (define log '())
+  (with-intercepted-tr-logging
+   (lambda (l)
+     (set! log (cons (cdr (vector-ref l 2)) ; log-entry struct
+                     log)))
+   (lambda ()
+     (parameterize ([current-namespace  (make-base-namespace)]
+                    [read-accept-reader #t])
+       (expand (tr:read-syntax portname input)))))
+  (set! log (reverse log))
+  ;; highlight
+  (for ([l (in-list log)])
+    (let ([stx (log-entry-stx l)]
+          [pos (sub1 (log-entry-pos l))]
+          ;; opt or missed opt?
+          [opt? (regexp-match #rx"^TR opt:" (log-entry-msg l))])
+      (send defs highlight-range
+            pos
+            (+ pos (syntax-span stx))
+            (if opt? "lightgreen" "pink"))))
   (message-box
    "Performance Report"
    (with-output-to-string
-     (lambda ()
-       (with-tr-logging-to-port
-        (current-output-port)
-        (lambda ()
-          (parameterize ([current-namespace  (make-base-namespace)]
-                         [read-accept-reader #t])
-            (expand (tr:read-syntax portname input)))))))))
+    (lambda ()
+      (for ([l (in-list log)])
+        (displayln (log-entry-msg l)))))))
 
 (define performance-report-drracket-button
   (list