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

Define the pre-installed teachpacks to be those teachpacks

Browse Source 
that are in the same directory as the image teachpack (for
htdp and htdp/2e)

closes PR 13967

This isn't the best solution: it would be better if I could
get the directory containing any collection whose name is
teachpack/htdp, but that doesn't seem easy with the current
set of functions

also, bring down below 102 columns
This commit is contained in:
Robby Findler 2013-08-15 12:52:02 -05:00
parent 3980acef04
commit a496cb5a17
1 changed files with 76 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -48,7 +48,8 @@
(define (oprintf . args) (apply fprintf o args)) (define (oprintf . args) (apply fprintf o args))
(define user-installed-teachpacks-collection "installed-teachpacks") (define user-installed-teachpacks-collection "installed-teachpacks")
(define teachpack-installation-dir (build-path (find-user-collects-dir) user-installed-teachpacks-collection)) (define teachpack-installation-dir
(build-path (find-user-collects-dir) user-installed-teachpacks-collection))
(define tool@ (define tool@
@ -141,7 +142,8 @@
[scheme-test-module-name [scheme-test-module-name
((current-module-name-resolver) '(lib "test-engine/racket-tests.ss") #f #f)] ((current-module-name-resolver) '(lib "test-engine/racket-tests.ss") #f #f)]
[scheme-signature-module-name [scheme-signature-module-name
((current-module-name-resolver) '(lib "deinprogramm/signature/signature-english.rkt") #f #f)] ((current-module-name-resolver)
'(lib "deinprogramm/signature/signature-english.rkt") #f #f)]
[tests-on? (preferences:get 'test-engine:enable?)]) [tests-on? (preferences:get 'test-engine:enable?)])
(run-in-user-thread (run-in-user-thread
(lambda () (lambda ()
@ -150,7 +152,8 @@
(namespace-attach-module drs-namespace ''drscheme-secrets) (namespace-attach-module drs-namespace ''drscheme-secrets)
(namespace-attach-module drs-namespace set-result-module-name) (namespace-attach-module drs-namespace set-result-module-name)
(error-display-handler teaching-languages-error-display-handler) (error-display-handler teaching-languages-error-display-handler)
(error-value->string-handler (λ (x y) (teaching-languages-error-value->string settings x y))) (error-value->string-handler
(λ (x y) (teaching-languages-error-value->string settings x y)))
(current-eval (add-annotation (htdp-lang-settings-tracing? settings) (current-eval))) (current-eval (add-annotation (htdp-lang-settings-tracing? settings) (current-eval)))
(error-print-source-location #f) (error-print-source-location #f)
(read-decimal-as-inexact #f) (read-decimal-as-inexact #f)
@ -172,16 +175,18 @@
(scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%)) (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%))
(test-execute tests-on?) (test-execute tests-on?)
(signature-checking-enabled? (get-preference 'signatures:enable-checking? (lambda () #t))) (signature-checking-enabled? (get-preference 'signatures:enable-checking? (lambda () #t)))
(test-format (make-formatter (lambda (v o) (render-value/format v settings o 40))))))) (test-format (make-formatter (λ (v o) (render-value/format v settings o 40)))))))
(super on-execute settings run-in-user-thread) (super on-execute settings run-in-user-thread)
;; set the global-port-print-handler after the super class because the super sets it too ;; set the global-port-print-handler after the super class because the super sets it too
(run-in-user-thread (run-in-user-thread
(lambda () (lambda ()
(define my-setup-printing-parameters (drscheme:language:make-setup-printing-parameters)) (define my-setup-printing-parameters
(drscheme:language:make-setup-printing-parameters))
(global-port-print-handler (global-port-print-handler
(λ (value port [depth 0]) (λ (value port [depth 0])
(teaching-language-render-value/format my-setup-printing-parameters value settings port 'infinity)))))) (teaching-language-render-value/format my-setup-printing-parameters
value settings port 'infinity))))))
(define/private (teaching-languages-error-value->string settings v len) (define/private (teaching-languages-error-value->string settings v len)
(let ([sp (open-output-string)]) (let ([sp (open-output-string)])
@ -239,11 +244,14 @@
(thunk))) (thunk)))
(define/override (render-value/format value settings port width) (define/override (render-value/format value settings port width)
(teaching-language-render-value/format drscheme:language:setup-printing-parameters value settings port width)) (teaching-language-render-value/format drscheme:language:setup-printing-parameters
value settings port width))
(define/override (render-value value settings port) (define/override (render-value value settings port)
(teaching-language-render-value/format drscheme:language:setup-printing-parameters value settings port 'infinity)) (teaching-language-render-value/format drscheme:language:setup-printing-parameters
value settings port 'infinity))
(define/private (teaching-language-render-value/format setup-printing-parameters value settings port width) (define/private (teaching-language-render-value/format setup-printing-parameters
value settings port width)
;; set drscheme's printing parameters ;; set drscheme's printing parameters
(setup-printing-parameters (setup-printing-parameters
(λ () (λ ()
@ -254,7 +262,8 @@
(let-values ([(converted-value write?) (let-values ([(converted-value write?)
(call-with-values (call-with-values
(lambda () (lambda ()
(drscheme:language:simple-module-based-language-convert-value value settings)) (drscheme:language:simple-module-based-language-convert-value
value settings))
(case-lambda (case-lambda
[(converted-value) (values converted-value #t)] [(converted-value) (values converted-value #t)]
[(converted-value write?) (values converted-value write?)]))]) [(converted-value write?) (values converted-value write?)]))])
@ -274,7 +283,8 @@
(super-new))) (super-new)))
;; sharing/not-config-panel : boolean boolean parent -> (case-> (-> settings) (settings -> void)) ;; sharing/not-config-panel : boolean boolean parent
;; -> (case-> (-> settings) (settings -> void))
;; constructs the config-panel for a language without a sharing option. ;; constructs the config-panel for a language without a sharing option.
(define (sharing/not-config-panel allow-sharing-config? accept-quasiquote? _parent) (define (sharing/not-config-panel allow-sharing-config? accept-quasiquote? _parent)
(let* ([parent (make-object vertical-panel% _parent)] (let* ([parent (make-object vertical-panel% _parent)]
@ -365,7 +375,8 @@
(send tracing get-value) (send tracing get-value)
tps)] tps)]
[(settings) [(settings)
(send case-sensitive set-value (drscheme:language:simple-settings-case-sensitive settings)) (send case-sensitive set-value
(drscheme:language:simple-settings-case-sensitive settings))
(send output-style set-selection (send output-style set-selection
(if accept-quasiquote? (if accept-quasiquote?
(case (drscheme:language:simple-settings-printing-style settings) (case (drscheme:language:simple-settings-printing-style settings)
@ -381,7 +392,8 @@
[(mixed-fraction) 0] [(mixed-fraction) 0]
[(repeating-decimal) 1])) [(repeating-decimal) 1]))
(when allow-sharing-config? (when allow-sharing-config?
(send show-sharing set-value (drscheme:language:simple-settings-show-sharing settings))) (send show-sharing set-value
(drscheme:language:simple-settings-show-sharing settings)))
(send insert-newlines set-value (send insert-newlines set-value
(drscheme:language:simple-settings-insert-newlines settings)) (drscheme:language:simple-settings-insert-newlines settings))
(set! tps (htdp-lang-settings-teachpacks settings)) (set! tps (htdp-lang-settings-teachpacks settings))
@ -496,7 +508,9 @@
(string-append no-ext-name ".scm")] (string-append no-ext-name ".scm")]
[(file-exists? no-ext-name) [(file-exists? no-ext-name)
no-ext-name] no-ext-name]
[else (error 'htdp-lang.rkt "could not find language filename ~s" no-ext-name)])] [else (error 'htdp-lang.rkt
"could not find language filename ~s"
no-ext-name)])]
[base-dir (let-values ([(base _1 _2) (split-path full-name)]) base)] [base-dir (let-values ([(base _1 _2) (split-path full-name)]) base)]
[stx [stx
(call-with-input-file full-name (call-with-input-file full-name
@ -561,7 +575,8 @@
(case key (case key
[(drscheme:autocomplete-words) [(drscheme:autocomplete-words)
(unless keywords (unless keywords
(set! keywords (text:get-completions/manuals #f))) ;; complete with everything, which is wrong .. ;; complete with everything, which is wrong ..
(set! keywords (text:get-completions/manuals #f)))
keywords] keywords]
[(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks]
[(drscheme:special:insert-lambda) #f] [(drscheme:special:insert-lambda) #f]
@ -642,7 +657,8 @@
(format "#reader~s~s\n" (format "#reader~s~s\n"
reader-module reader-module
`((modname ,modname) `((modname ,modname)
(read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings)) (read-case-sensitive
,(drscheme:language:simple-settings-case-sensitive settings))
(teachpacks ,(htdp-lang-settings-teachpacks settings)) (teachpacks ,(htdp-lang-settings-teachpacks settings))
(htdp-settings ,(htdp-lang-settings->vector settings)))))) (htdp-settings ,(htdp-lang-settings->vector settings))))))
@ -679,15 +695,12 @@
(define tp-dirs (list "htdp" "2htdp")) (define tp-dirs (list "htdp" "2htdp"))
(define labels (list (string-constant teachpack-pre-installed/htdp) (define labels (list (string-constant teachpack-pre-installed/htdp)
(string-constant teachpack-pre-installed/2htdp))) (string-constant teachpack-pre-installed/2htdp)))
(define tpss (map (λ (tp-dir) (define tpss (map tp-dir->tps tp-dirs))
(let ([base (collection-path "teachpack" tp-dir)])
(filter
(λ (x) (file-exists? (build-path base x)))
(directory-list base))))
tp-dirs))
(define sort-order (λ (x y) (string<=? (path->string x) (path->string y)))) (define sort-order (λ (x y) (string<=? (path->string x) (path->string y))))
(define pre-installed-tpss (map (λ (tps) (sort tps sort-order)) tpss)) (define pre-installed-tpss (map (λ (tps) (sort tps sort-order)) tpss))
(define dlg (new (frame:focus-table-mixin dialog%) [parent parent] [label (string-constant drscheme)])) (define dlg (new (frame:focus-table-mixin dialog%)
[parent parent]
[label (string-constant drscheme)]))
(define hp (new horizontal-panel% [parent dlg])) (define hp (new horizontal-panel% [parent dlg]))
(define answer #f) (define answer #f)
(define compiling? #f) (define compiling? #f)
@ -854,7 +867,10 @@
[parent dlg] [parent dlg]
[alignment '(right center)] [alignment '(right center)]
[stretchable-height #f])) [stretchable-height #f]))
(define compiling-message (new message% [parent button-panel] [label ""] [stretchable-width #t])) (define compiling-message (new message%
[parent button-panel]
[label ""]
[stretchable-width #t]))
(define-values (ok-button cancel-button) (define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons button-panel (gui-utils:ok/cancel-buttons button-panel
(λ (b e) (λ (b e)
@ -868,7 +884,8 @@
(cond (cond
[(ormap (λ (pre-installed-lb tp-dir) [(ormap (λ (pre-installed-lb tp-dir)
(and (send pre-installed-lb get-selection) (and (send pre-installed-lb get-selection)
(list tp-dir (send pre-installed-lb get-string (send pre-installed-lb get-selection))))) (list tp-dir (send pre-installed-lb get-string
(send pre-installed-lb get-selection)))))
pre-installed-lbs pre-installed-lbs
tp-dirs) tp-dirs)
=> =>
@ -888,6 +905,13 @@
(send dlg show #t) (send dlg show #t)
answer) 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))
(filter
(λ (x) (file-exists? (build-path base x)))
(directory-list base)))
(define (stepper-settings-language %) (define (stepper-settings-language %)
(if (implementation? % stepper-language<%>) (if (implementation? % stepper-language<%>)
(class* % (stepper-language<%>) (class* % (stepper-language<%>)
@ -1036,8 +1060,8 @@
;; with-mark : syntax syntax exact-nonnegative-integer -> syntax ;; with-mark : syntax syntax exact-nonnegative-integer -> syntax
;; a member of stacktrace-imports^ ;; a member of stacktrace-imports^
;; guarantees that the continuation marks associated with teaching-languages-continuation-mark-key are ;; guarantees that the continuation marks associated with
;; members of the debug-source type ;; teaching-languages-continuation-mark-key are members of the debug-source type
(define (with-mark source-stx expr phase) (define (with-mark source-stx expr phase)
(let ([source (syntax-source source-stx)] (let ([source (syntax-source source-stx)]
[line (syntax-line source-stx)] [line (syntax-line source-stx)]
@ -1049,8 +1073,10 @@
(number? span)) (number? span))
(with-syntax ([expr expr] (with-syntax ([expr expr]
[mark (list source line col start-position span)] [mark (list source line col start-position span)]
[teaching-languages-continuation-mark-key teaching-languages-continuation-mark-key] [teaching-languages-continuation-mark-key
[wcm (syntax-shift-phase-level #'with-continuation-mark (- phase base-phase))] teaching-languages-continuation-mark-key]
[wcm (syntax-shift-phase-level #'with-continuation-mark
(- phase base-phase))]
[quot (syntax-shift-phase-level #'quote (- phase base-phase))]) [quot (syntax-shift-phase-level #'quote (- phase base-phase))])
#`(wcm (quot teaching-languages-continuation-mark-key) #`(wcm (quot teaching-languages-continuation-mark-key)
(quot mark) (quot mark)
@ -1136,19 +1162,20 @@
; ;
; ;
; ;
; ; ; ; ; ;
; ; ; ; ; ; ;;; ; ; ; ;;;
; ; ; ; ; ; ; ; ; ;;; ;;; ;;; ;;; ;;;
; ; ;; ; ; ;;;; ; ;;;; ;;; ; ; ;;;; ;;; ;; ; ;;; ;;;; ; ;; ;;; ; ; ; ;;; ;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;; ;; ;;; ;;;; ;;;; ;;; ;; ;;;; ;;; ;
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ;; ; ;;;;;;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;;; ;;;;;;; ;; ;;; ;;;; ;;;;;;; ;; ;;; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;;;; ; ; ; ;;;;;; ; ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;
; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;;;;;;; ;;;;;;; ;;;; ;;; ;;;; ;;;; ;;;;; ;;;;;;; ;;;;;; ;;;; ;;; ;;; ;;;;;; ;;;
; ; ;; ;; ; ;; ; ;; ;;;;; ; ; ;; ;;; ;; ; ;;;; ;; ; ; ;;;; ; ; ;;; ;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;;
; ; ; ; ;;; ;;;
; ; ; ; ; ;;; ;;;;;;
; ; ;;;; ;
;
;; add-htdp-language : (instanceof htdp-language<%>) -> void ;; add-htdp-language : (instanceof htdp-language<%>) -> void
@ -1291,7 +1318,8 @@
test-coverage-off-style-name test-coverage-off-style-name
(send the-color-database find-color "orange") (send the-color-database find-color "orange")
(send the-color-database find-color "indianred") (send the-color-database find-color "indianred")
#:background (send the-color-database find-color "black")) #:background
(send the-color-database find-color "black"))
(color-prefs:add-to-preferences-panel (color-prefs:add-to-preferences-panel
"HtDP Languages" "HtDP Languages"
(λ (parent) (λ (parent)