adjust the drracket, menu-based teachpacks to be found via info.rkt files

Pre 6.0, the teachpacks were found using collection-path, but that doesn't
work anymore. Pre this commit, they were found by using

  (collection-file-path "image.rkt" "teachpack" "htdp")

and

  (collection-file-path "image.rkt" "teachpack" "2htdp")

and then looking for files in the same directory. This worked, but is
a total hack.

This commit changes to an info.rkt-based setup, but the changes ended up
percolating around the teachpack & teaching languages implementation more
than I would have liked (specifically because the internal
datastructure for a teachpack references was an sexp of the form:

  `(lib ,(? string-without-slashes?) ...)

but now teachpack references can be arbitrary results of
path->module-path, which never seems to be the above (instead using
the slash-based `lib' module paths)).

So a bunch of places in the teaching langauges code changed to
recognize the right slashes for the teachpacks that have always been
there to preseve the DrRacket API and fall back to just showing the
module path otherwise. There may be places I've missed, tho, that
are expecting the simple lib form and may now be surprised.

On the upside, 3rd parties (via new packages) can now add things
to the teachpack menu item. On the downside (beyond the likely
bugs I've just introduced in this commit), we're supposed to be
getting rid of this dialog, not making it more extensible.

pkgs/drracket-pkgs/drracket/scribblings/drracket/extending.scrbl

@@ -102,6 +102,24 @@ the list @racket[all-nums] is bound to an infinite list
 For more examples, see the @filepath{htdp} sub-collection in the
 @filepath{teachpack} collection of the PLT installation.
 
+@subsection{Adding Your Own Teachpacks to the Teachpack Dialog}
+
+The @onscreen{Language|Add Teachpack...} dialog is extensible
+in two ways. First, users can add teachpacks to the third column
+by clicking the button at the bottom of the column. These additions
+are stored in the preferences file, so one way to add site-specific
+teachpacks is to provide a default preferences file.
+
+The first two columns are also extensible. When a collection has
+an @tech{info.rkt} file 
+(see also @secref[#:doc '(lib "scribblings/raco/raco.scrbl") "info.rkt"])
+that defines @racket[htdp-teachpacks] or @racket[2htdp-teachpacks],
+then they are expected to be either a list of (collection-relative)
+paths containing teachpacks to add to the dialog, or the symbol
+@racket['all], which means that all of the (top-level) files in the collection
+that end with @filepath{.rkt}, @filepath{.ss}, or @filepath{.scm}
+are teachpacks (except @filepath{info.rkt} or @filepath{info.ss}).
+
 @; ----------------------------------------------------------------------
 
 @section[#:tag "environment-variables"]{Environment Variables}

pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt

@@ -18,9 +18,11 @@
          mrlib/cache-image-snip
          (prefix-in ic: mrlib/image-core)
          setup/dirs
+         setup/getinfo
+         setup/collects
          test-engine/racket-tests
 
-         ;; this module is shared between the drscheme's namespace (so loaded here) 
+         ;; this module is shared between the drracket namespace (so loaded here) 
          ;; and the user's namespace in the teaching languages
          "private/set-result.rkt"
          "private/rewrite-error-message.rkt"
@@ -38,8 +40,7 @@
                   scheme-test-data error-handler test-format test-execute display-results
                   build-test-engine)
          (lib "test-engine/test-display.scm")
-         deinprogramm/signature/signature
+         deinprogramm/signature/signature)
-         )
   
   
   (provide tool@)
@@ -454,23 +455,23 @@
               (cond
                 [(= 1 (length tps))
                  (go ": " welcome)
-                 (go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))]
+                 (go (tp-require->str (car tps)) (drscheme:rep:get-dark-green-delta))]
                 [(= 2 (length tps))
                  (go "s: " welcome)
-                 (go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))
+                 (go (tp-require->str (car tps)) (drscheme:rep:get-dark-green-delta))
                  (go " and " welcome)
-                 (go (cadr (cadr tps)) (drscheme:rep:get-dark-green-delta))]
+                 (go (tp-require->str (cadr tps)) (drscheme:rep:get-dark-green-delta))]
                 [else
                  (go "s: " welcome)
-                 (go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))
+                 (go (tp-require->str (car tps)) (drscheme:rep:get-dark-green-delta))
                  (let loop ([these-tps (cdr tps)])
                    (cond
                      [(null? (cdr these-tps))
                       (go ", and " welcome)
-                      (go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))]
+                      (go (tp-require->str (car these-tps)) (drscheme:rep:get-dark-green-delta))]
                      [else
                       (go ", " welcome)
-                      (go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))
+                      (go (tp-require->str (car these-tps)) (drscheme:rep:get-dark-green-delta))
                       (loop (cdr these-tps))]))])
               (go "." welcome)
               (newline port)))
@@ -479,6 +480,15 @@
             (for ([tp (in-list (htdp-lang-settings-teachpacks settings))])
               (namespace-require/constant tp)))
           
+          (define/private (tp-require->str tp)
+            (match tp
+              [`(lib ,x) 
+               (define m (regexp-match #rx"teachpack/2?htdp/(.*)$" x))
+               (if m
+                   (list-ref m 1)
+                   (format "~s" tp))]
+              [_ (format "~s" tp)]))
+          
           (inherit get-module get-transformer-module get-init-code
                    use-namespace-require/copy?)
           (define/override (create-executable setting parent program-filename)
@@ -597,7 +607,8 @@
           (define htdp-teachpack-callbacks
             (drscheme:unit:make-teachpack-callbacks
              (λ (settings) 
-               (map cadr (htdp-lang-settings-teachpacks settings)))
+               (map (λ (x) (tp-require->str x))
+                    (htdp-lang-settings-teachpacks settings)))
              (λ (settings parent) 
                (let ([teachpack (get-teachpack-from-user parent)])
                  (if teachpack
@@ -695,9 +706,24 @@
         (define tp-dirs (list "htdp" "2htdp"))
         (define labels (list (string-constant teachpack-pre-installed/htdp)
                              (string-constant teachpack-pre-installed/2htdp)))
-        (define tpss (map tp-dir->tps tp-dirs))
+        (define tp-syms '(htdp-teachpacks 2htdp-teachpacks))
-        (define sort-order (λ (x y) (string<=? (path->string x) (path->string y))))
+        (define tpss (map tp-dir->tps tp-syms))
-        (define pre-installed-tpss (map (λ (tps) (sort tps sort-order)) tpss))
+        
+        (define label+mpss
+          (for/list ([tps (in-list tpss)])
+            (let ([all-filenames (map (λ (tp) (list-ref tp 0)) tps)])
+              (for/list ([tp (in-list tps)])
+                (define filename (list-ref tp 0))
+                (define mp (list-ref tp 1))
+                (list (path->string 
+                       (or (shrink-path-wrt filename all-filenames)
+                           (let-values ([(base name dir?) (split-path filename)])
+                             name)))
+                      mp)))))
+        
+        (define pre-installed-tpss 
+          (for/list ([label+mps (in-list label+mpss)])
+            (sort label+mps string<? #:key car)))
         (define dlg (new (frame:focus-table-mixin dialog%) 
                          [parent parent]
                          [label (string-constant drscheme)]))
@@ -716,22 +742,29 @@
         
         (define pre-installed-lbs
           (map (λ (pre-installed-gb pre-installed-tps)
-                 (new list-box%
+                 (define lb 
-                      [label #f]
+                   (new list-box%
-                      [choices (map path->string pre-installed-tps)]
+                        [label #f]
-                      [stretchable-height #t]
+                        [choices (map (λ (x) (gui-utils:trim-string (list-ref x 0) 200))
-                      [min-height 300]
+                                      pre-installed-tps)]
-                      [min-width 200]
+                        [stretchable-height #t]
-                      [callback
+                        [min-height 300]
-                       (λ (this evt)
+                        [min-width 200]
-                         (case (send evt get-event-type)
+                        [callback
-                           [(list-box-dclick) (selected this)]
+                         (λ (this evt)
-                           [else
+                           (case (send evt get-event-type)
-                            (for-each (λ (x) (unless (eq? x this) (clear-selection x)))
+                             [(list-box-dclick) (selected this)]
-                                      (cons user-installed-lb
+                             [else
-                                            pre-installed-lbs))
+                              (for ([x (in-list (cons user-installed-lb
-                            (update-button)]))]
+                                                      pre-installed-lbs))]
-                      [parent pre-installed-gb]))
+                                    #:unless (eq? x this))
+                                (clear-selection x))
+                              (update-button)]))]
+                        [parent pre-installed-gb]))
+                 (for ([i (in-naturals)]
+                       [tp (in-list pre-installed-tps)])
+                   (send lb set-data i (list-ref tp 1)))
+                 lb)
                pre-installed-gbs
                pre-installed-tpss))
         
@@ -884,14 +917,12 @@
           (cond
             [(ormap (λ (pre-installed-lb tp-dir) 
                       (and (send pre-installed-lb get-selection)
-                           (list tp-dir (send pre-installed-lb get-string 
+                           (send pre-installed-lb get-data
-                                              (send pre-installed-lb get-selection)))))
+                                 (send pre-installed-lb get-selection))))
                     pre-installed-lbs
                     tp-dirs)
              =>
-             (λ (pr)
+             values]
-               (define-values (tp-dir f) (apply values pr))
-               `(lib ,f "teachpack" ,tp-dir))]
             [(send user-installed-lb get-selection)
              =>
              (λ (i) `(lib ,(send user-installed-lb get-string i)
@@ -905,12 +936,32 @@
         (send dlg show #t)
         answer)
       
-      (define (tp-dir->tps tp-dir)
+      (define (tp-dir->tps tp-sym)
-        (define known-tp (collection-file-path "image.rkt" "teachpack" tp-dir))
-        (define-values (base name dir?) (split-path known-tp))
         (filter
-         (λ (x) (file-exists? (build-path base x)))
+         values
-         (directory-list base)))
+         (for*/list ([dir (in-list (find-relevant-directories (list tp-sym)))]
+                     #:when (let ([inf (get-info/full dir)])
+                              (and inf (inf tp-sym (λ () #f))))
+                     [file-or-dir (in-list
+                                   (let ([files ((get-info/full dir) tp-sym)])
+                                     (cond
+                                       [(eq? files 'all)
+                                        (for/list ([x (in-list (directory-list dir))]
+                                                   #:when
+                                                   (regexp-match #rx"[.](ss|scm|rkt)$"
+                                                                 (path->string x))
+                                                   #:unless
+                                                   (member (path->string x) '("info.rkt" "info.ss")))
+                                          x)]
+                                       [(list? files) files]
+                                       [else '()])))])
+           (let/ec k
+             (unless (path? file-or-dir) (k #f))
+             (define candidate (build-path dir file-or-dir))
+             (unless (file-exists? candidate) (k #f))
+             (define mp (path->module-path candidate))
+             (when (path-string? mp) (k #f))
+             (list candidate mp)))))
 
       (define (stepper-settings-language %)
         (if (implementation? % stepper-language<%>)
@@ -1009,7 +1060,7 @@
       (define mf-note
         (let ([bitmap
                (make-object bitmap%
-                 (build-path (collection-path "icons") "mf.gif"))])
+                 (collection-file-path "mf.gif" "icons"))])
           (and (send bitmap ok?)
                (make-object image-snip% bitmap))))
       

pkgs/htdp-pkgs/htdp-lib/lang/run-teaching-program.rkt

@@ -6,6 +6,7 @@
          scheme/class
          scheme/contract
          test-engine/racket-tests
+         syntax/modresolve
          (only-in racket/list split-at)
          (only-in racket/sequence sequence->list))
 
@@ -102,19 +103,15 @@
    values
    (for/list ([tp (in-list teachpacks)])
      (cond
-       [(file-exists? (build-path (apply collection-path (cddr tp))
+       [(with-handlers ((exn:fail? (λ (x) #f)))
-                                  (cadr tp)))
+          (file-exists? (resolve-module-path tp #f)))
         (stepper-skip
          (datum->syntax #f `(require ,tp)))]
        [else
         (eprintf "~a\n" (missing-tp-message tp))]))))
 
 (define (missing-tp-message x)
-  (let* ([m (regexp-match #rx"/([^/]*)$" (cadr x))]
+  (format "the teachpack '~s' was not found" x))
-         [name (if m
-                   (cadr m)
-                   (cadr x))])
-    (format "the teachpack '~a' was not found" name)))
 
 
 ;; rewrite-module : syntax -> syntax

pkgs/htdp-pkgs/htdp-lib/teachpack/2htdp/info.rkt

@@ -0,0 +1,4 @@
+#lang info
+
+(define 2htdp-teachpacks 'all)
+

pkgs/htdp-pkgs/htdp-lib/teachpack/htdp/info.rkt

@@ -0,0 +1,5 @@
+#lang info
+
+(define htdp-teachpacks 'all)
+
+