From 6741e4d3e7245cf37a74f04097c8682eb736d65b Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 7 Jun 2007 14:27:26 +0000
Subject: [PATCH] avoid compilation of a teachpack in the same way we avoid it
 in an executable

svn: r6514
---
 collects/lang/htdp-langs.ss | 105 ++++++++++++++++++++----------------
 1 file changed, 58 insertions(+), 47 deletions(-)

diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss
index a9f56b067e..75ee8bb16c 100644
--- a/collects/lang/htdp-langs.ss
+++ b/collects/lang/htdp-langs.ss
@@ -414,24 +414,7 @@
                     #:literal-expression `(require ,(filename->require-symbol program-filename))
                     #:cmdline '("-Zmvq")
                     #:src-filter
-                    (λ (path)
-                      (call-with-input-file path
-                        (λ (port) 
-                          (let ([ok-to-compile-names 
-                                 (map (λ (x) (format "~s" x))
-                                      '(wxtext
-                                        (lib "comment-snip.ss" "framework")
-                                        (lib "xml-snipclass.ss" "xml")
-                                        (lib "scheme-snipclass.ss" "xml")))])
-                            (and (is-wxme-stream? port)
-                                 (let-values ([(snip-class-names data-class-names)
-                                               (extract-used-classes port)])
-                                   (not (and (andmap
-                                              (λ (used-name) (member used-name ok-to-compile-names))
-                                              snip-class-names)
-                                             (andmap
-                                              (λ (used-name) (member used-name ok-to-compile-names))
-                                              data-class-names)))))))))
+                    (λ (path) (cannot-compile? path))
                     #:get-extra-imports
                     (λ (path cm)
                       (call-with-input-file path
@@ -655,6 +638,27 @@
           
           (super-new)))
       
+      ;; cannot-compile? : path -> boolean
+      ;; returns #t if the file cannot be compiled, #f otherwise
+      (define (cannot-compile? path)
+        (call-with-input-file path
+          (λ (port) 
+            (let ([ok-to-compile-names 
+                   (map (λ (x) (format "~s" x))
+                        '(wxtext
+                          (lib "comment-snip.ss" "framework")
+                          (lib "xml-snipclass.ss" "xml")
+                          (lib "scheme-snipclass.ss" "xml")))])
+              (and (is-wxme-stream? port)
+                   (let-values ([(snip-class-names data-class-names)
+                                 (extract-used-classes port)])
+                     (not (and (andmap
+                                (λ (used-name) (member used-name ok-to-compile-names))
+                                snip-class-names)
+                               (andmap
+                                (λ (used-name) (member used-name ok-to-compile-names))
+                                data-class-names)))))))))
+      
       (define (get-teachpack-from-user parent)
         (define tp-dir (collection-path "teachpack" "htdp"))
         (define columns 2)
@@ -748,35 +752,42 @@
         
         (define (compile-new-teachpack filename)
           (let-values ([(_1 short-name _2) (split-path filename)])
-            (send compiling-message set-label
-                  (format (string-constant compiling-teachpack) 
-                          (path->string short-name)))
-            (starting-compilation)
-            (let ([nc (make-custodian)]
-                  [exn #f])
-              (let ([t 
-                     (parameterize ([current-custodian nc])
-                       (thread (λ () 
-                                 (with-handlers ((exn? (λ (x) (set! exn x))))
-                                   (parameterize ([read-accept-reader #t])
-                                     (compile-file filename))))))])
-                (thread
-                 (λ ()
-                   (thread-wait t)
-                   (queue-callback
-                    (λ () 
-                      (cond
-                        [exn
-                         (message-box (string-constant drscheme)
-                                      (exn-message exn))
-                         (delete-file filename)
-                         (update-user-installed-lb)]
-                        [else
-                         (update-user-installed-lb)
-                         (clear-selection pre-installed-lb)
-                         (send user-installed-lb set-string-selection (path->string short-name))])
-                      (done-compilation)
-                      (send compiling-message set-label "")))))))))
+            (cond
+              [(cannot-compile? filename)
+               (post-compilation-gui-cleanup short-name)]
+              [else
+               (send compiling-message set-label
+                     (format (string-constant compiling-teachpack) 
+                             (path->string short-name)))
+               (starting-compilation)
+               (let ([nc (make-custodian)]
+                     [exn #f])
+                 (let ([t 
+                        (parameterize ([current-custodian nc])
+                          (thread (λ () 
+                                    (with-handlers ((exn? (λ (x) (set! exn x))))
+                                      (parameterize ([read-accept-reader #t])
+                                        (compile-file filename))))))])
+                   (thread
+                    (λ ()
+                      (thread-wait t)
+                      (queue-callback
+                       (λ () 
+                         (cond
+                           [exn
+                            (message-box (string-constant drscheme)
+                                         (exn-message exn))
+                            (delete-file filename)
+                            (update-user-installed-lb)]
+                           [else
+                            (post-compilation-gui-cleanup short-name)])
+                         (done-compilation)
+                         (send compiling-message set-label "")))))))])))
+        
+        (define (post-compilation-gui-cleanup short-name)
+          (update-user-installed-lb)
+          (clear-selection pre-installed-lb)
+          (send user-installed-lb set-string-selection (path->string short-name)))
         
         (define (starting-compilation)
           (set! compiling? #t)