From efd26833015a41706b1e26a8b13efda9ada0eb2b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 16 Aug 2013 14:01:42 -0500 Subject: [PATCH] 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. --- .../scribblings/drracket/extending.scrbl | 18 +++ pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt | 131 ++++++++++++------ .../htdp-lib/lang/run-teaching-program.rkt | 11 +- .../htdp-lib/teachpack/2htdp/info.rkt | 4 + .../htdp-lib/teachpack/htdp/info.rkt | 5 + 5 files changed, 122 insertions(+), 47 deletions(-) create mode 100644 pkgs/htdp-pkgs/htdp-lib/teachpack/2htdp/info.rkt create mode 100644 pkgs/htdp-pkgs/htdp-lib/teachpack/htdp/info.rkt diff --git a/pkgs/drracket-pkgs/drracket/scribblings/drracket/extending.scrbl b/pkgs/drracket-pkgs/drracket/scribblings/drracket/extending.scrbl index 6fbd48509f..88c5ca2773 100644 --- a/pkgs/drracket-pkgs/drracket/scribblings/drracket/extending.scrbl +++ b/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} diff --git a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt b/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt index a147048c45..a5d1d80290 100644 --- a/pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt +++ b/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 sort-order (λ (x y) (string<=? (path->string x) (path->string y)))) - (define pre-installed-tpss (map (λ (tps) (sort tps sort-order)) tpss)) + (define tp-syms '(htdp-teachpacks 2htdp-teachpacks)) + (define tpss (map tp-dir->tps tp-syms)) + + (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 stringstring pre-installed-tps)] - [stretchable-height #t] - [min-height 300] - [min-width 200] - [callback - (λ (this evt) - (case (send evt get-event-type) - [(list-box-dclick) (selected this)] - [else - (for-each (λ (x) (unless (eq? x this) (clear-selection x))) - (cons user-installed-lb - pre-installed-lbs)) - (update-button)]))] - [parent pre-installed-gb])) + (define lb + (new list-box% + [label #f] + [choices (map (λ (x) (gui-utils:trim-string (list-ref x 0) 200)) + pre-installed-tps)] + [stretchable-height #t] + [min-height 300] + [min-width 200] + [callback + (λ (this evt) + (case (send evt get-event-type) + [(list-box-dclick) (selected this)] + [else + (for ([x (in-list (cons user-installed-lb + pre-installed-lbs))] + #: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-selection))))) + (send pre-installed-lb get-data + (send pre-installed-lb get-selection)))) pre-installed-lbs tp-dirs) => - (λ (pr) - (define-values (tp-dir f) (apply values pr)) - `(lib ,f "teachpack" ,tp-dir))] + values] [(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 known-tp (collection-file-path "image.rkt" "teachpack" tp-dir)) - (define-values (base name dir?) (split-path known-tp)) + (define (tp-dir->tps tp-sym) (filter - (λ (x) (file-exists? (build-path base x))) - (directory-list base))) + values + (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)))) diff --git a/pkgs/htdp-pkgs/htdp-lib/lang/run-teaching-program.rkt b/pkgs/htdp-pkgs/htdp-lib/lang/run-teaching-program.rkt index b33176a7ef..ccb9f20f40 100644 --- a/pkgs/htdp-pkgs/htdp-lib/lang/run-teaching-program.rkt +++ b/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)) - (cadr tp))) + [(with-handlers ((exn:fail? (λ (x) #f))) + (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))] - [name (if m - (cadr m) - (cadr x))]) - (format "the teachpack '~a' was not found" name))) + (format "the teachpack '~s' was not found" x)) ;; rewrite-module : syntax -> syntax diff --git a/pkgs/htdp-pkgs/htdp-lib/teachpack/2htdp/info.rkt b/pkgs/htdp-pkgs/htdp-lib/teachpack/2htdp/info.rkt new file mode 100644 index 0000000000..6ab1a3d7d7 --- /dev/null +++ b/pkgs/htdp-pkgs/htdp-lib/teachpack/2htdp/info.rkt @@ -0,0 +1,4 @@ +#lang info + +(define 2htdp-teachpacks 'all) + diff --git a/pkgs/htdp-pkgs/htdp-lib/teachpack/htdp/info.rkt b/pkgs/htdp-pkgs/htdp-lib/teachpack/htdp/info.rkt new file mode 100644 index 0000000000..7f2608ab88 --- /dev/null +++ b/pkgs/htdp-pkgs/htdp-lib/teachpack/htdp/info.rkt @@ -0,0 +1,5 @@ +#lang info + +(define htdp-teachpacks 'all) + +