suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Robby Findler 2013-08-16 14:01:42 -05:00
parent 736c8ca12b
commit efd2683301
5 changed files with 122 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/drracket-pkgs/drracket/scribblings/drracket/extending.scrbl
View File

@ -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}

131
pkgs/htdp-pkgs/htdp-lib/lang/htdp-langs.rkt
View File

@ -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 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%
[label #f]
[choices (map path->string 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))))

11
pkgs/htdp-pkgs/htdp-lib/lang/run-teaching-program.rkt
View File

@ -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

4
pkgs/htdp-pkgs/htdp-lib/teachpack/2htdp/info.rkt Normal file
View File

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

5
pkgs/htdp-pkgs/htdp-lib/teachpack/htdp/info.rkt Normal file
View File

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