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

changed teachpacks to be language specific

Browse Source 
svn: r6145
This commit is contained in:
Robby Findler 2007-05-04 20:45:15 +00:00
parent 91d0c5e114
commit 41d4b5d28e
22 changed files with 500 additions and 520 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/algol60/tool.ss
View File

@ -49,10 +49,10 @@
(define lang% (define lang%
(class* object% (drscheme:language:language<%>) (class* object% (drscheme:language:language<%>)
(define/public (extra-repl-information settings port) (void))
(define/public (get-reader-module) #f) (define/public (get-reader-module) #f)
(define/public (get-metadata a b) #f) (define/public (get-metadata a b) #f)
(define/public (metadata->settings m) #f) (define/public (metadata->settings m) #f)
(define/public (metadata->teachpacks m) #f)
(define/public (get-metadata-lines) #f) (define/public (get-metadata-lines) #f)
(define/public (capability-value s) (drscheme:language:get-capability-default s)) (define/public (capability-value s) (drscheme:language:get-capability-default s))
@ -72,8 +72,8 @@
(compile-simplified (compile-simplified
(simplify (parse-a60-port port name) base-importing-stx) (simplify (parse-a60-port port name) base-importing-stx)
base-importing-stx))))) base-importing-stx)))))
(define/public (front-end/complete-program port settings teachpack-cache) (front-end port settings)) (define/public (front-end/complete-program port settings) (front-end port settings))
(define/public (front-end/interaction port settings teachpack-cache) (front-end port settings)) (define/public (front-end/interaction port settings) (front-end port settings))
(define/public (get-style-delta) #f) (define/public (get-style-delta) #f)
(define/public (get-language-position) (define/public (get-language-position)
(list (string-constant experimental-languages) (list (string-constant experimental-languages)
@ -107,7 +107,7 @@
(define/public (render-value value settings port) (write value port)) (define/public (render-value value settings port) (write value port))
(define/public (render-value/format value settings port width) (write value port)) (define/public (render-value/format value settings port width) (write value port))
(define/public (unmarshall-settings x) x) (define/public (unmarshall-settings x) x)
(define/public (create-executable settings parent src-file teachpacks) (define/public (create-executable settings parent src-file)
(let ([dst-file (drscheme:language:put-executable (let ([dst-file (drscheme:language:put-executable
parent src-file #f #f parent src-file #f #f
(string-constant save-a-mzscheme-stand-alone-executable))]) (string-constant save-a-mzscheme-stand-alone-executable))])

25
collects/drscheme/private/drsig.ss
View File

@ -21,7 +21,6 @@
drscheme:draw-arrow^ drscheme:draw-arrow^
drscheme:help-desk^ drscheme:help-desk^
drscheme:language^ drscheme:language^
drscheme:teachpack^
drscheme:multi-file-search^ drscheme:multi-file-search^
drscheme:module-overview^ drscheme:module-overview^
drscheme:font^ drscheme:font^
@ -104,11 +103,7 @@
get-default-language-settings get-default-language-settings
settings-preferences-symbol settings-preferences-symbol
add-built-in-languages add-built-in-languages))
;; for the language dialog
add-new-teachpack
clear-all-teachpacks))
(define-signature drscheme:tools^ (define-signature drscheme:tools^
((struct successful-tool (spec bitmap name url)) ((struct successful-tool (spec bitmap name url))
@ -142,7 +137,8 @@
open-drscheme-window open-drscheme-window
find-symbol find-symbol
get-program-editor-mixin get-program-editor-mixin
add-to-program-editor-mixin)) add-to-program-editor-mixin
(struct teachpack-callbacks (get-names remove add))))
(define-signature drscheme:frame^ (define-signature drscheme:frame^
(<%> (<%>
@ -178,6 +174,8 @@
current-value-port current-value-port
get-drs-bindings-keymap get-drs-bindings-keymap
error-delta error-delta
get-welcome-delta
get-dark-green-delta
text% text%
text<%> text<%>
context<%>)) context<%>))
@ -245,18 +243,6 @@
simple-module-based-language->module-based-language-mixin simple-module-based-language->module-based-language-mixin
module-based-language->language-mixin)) module-based-language->language-mixin))
(define-signature drscheme:teachpack^
(install-teachpacks
marshall-teachpack-cache
unmarshall-teachpack-cache
launcher-init-code
launcher-modules-to-embed
new-teachpack-cache
teachpack-cache?
teachpack-cache-filenames
teachpack-cache-require-specs
set-teachpack-cache-filenames!))
(define-signature drscheme:multi-file-search^ (define-signature drscheme:multi-file-search^
(multi-file-search)) (multi-file-search))
@ -279,5 +265,4 @@
(open (prefix drscheme:language: drscheme:language^)) (open (prefix drscheme:language: drscheme:language^))
(open (prefix drscheme:help-desk: drscheme:help-desk^)) (open (prefix drscheme:help-desk: drscheme:help-desk^))
(open (prefix drscheme:eval: drscheme:eval^)) (open (prefix drscheme:eval: drscheme:eval^))
(open (prefix drscheme:teachpack: drscheme:teachpack^))
(open (prefix drscheme:modes: drscheme:modes^))))) (open (prefix drscheme:modes: drscheme:modes^)))))

15
collects/drscheme/private/eval.ss
View File

@ -19,14 +19,13 @@
(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] (import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:rep: drscheme:rep^] [prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:init: drscheme:init^] [prefix drscheme:init: drscheme:init^]
[prefix drscheme:language: drscheme:language^] [prefix drscheme:language: drscheme:language^])
[prefix drscheme:teachpack: drscheme:teachpack^])
(export drscheme:eval^) (export drscheme:eval^)
(define (traverse-program/multiple language-settings (define (traverse-program/multiple language-settings
init init
kill-termination) kill-termination)
(let-values ([(eventspace custodian teachpack-cache) (let-values ([(eventspace custodian)
(build-user-eventspace/custodian (build-user-eventspace/custodian
language-settings language-settings
init init
@ -59,8 +58,8 @@
(λ () (λ ()
(let ([read-thnk (let ([read-thnk
(if complete-program? (if complete-program?
(send language front-end/complete-program port settings teachpack-cache) (send language front-end/complete-program port settings)
(send language front-end/interaction port settings teachpack-cache))]) (send language front-end/interaction port settings))])
(let loop () (let loop ()
(let ([in (read-thnk)]) (let ([in (read-thnk)])
(cond (cond
@ -102,9 +101,8 @@
#t)) #t))
(define (build-user-eventspace/custodian language-settings init kill-termination) (define (build-user-eventspace/custodian language-settings init kill-termination)
(let* ([user-custodian (make-custodian)] (let* ([user-custodian (make-custodian)]
[user-teachpack-cache (preferences:get 'drscheme:teachpacks)]
[eventspace (parameterize ([current-custodian user-custodian]) [eventspace (parameterize ([current-custodian user-custodian])
(make-eventspace))] (make-eventspace))]
[language (drscheme:language-configuration:language-settings-language [language (drscheme:language-configuration:language-settings-language
@ -138,14 +136,13 @@
(run-in-eventspace (run-in-eventspace
(λ () (λ ()
(set! eventspace-main-thread (current-thread)) (set! eventspace-main-thread (current-thread))
(drscheme:teachpack:install-teachpacks user-teachpack-cache)
(init) (init)
(break-enabled #t))) (break-enabled #t)))
(thread (thread
(λ () (λ ()
(thread-wait eventspace-main-thread) (thread-wait eventspace-main-thread)
(kill-termination))) (kill-termination)))
(values eventspace user-custodian user-teachpack-cache))) (values eventspace user-custodian)))
;; get-snip-classes : -> (listof snipclass) ;; get-snip-classes : -> (listof snipclass)
;; returns a list of the snip classes in the current eventspace ;; returns a list of the snip classes in the current eventspace

9
collects/drscheme/private/help-desk.ss
View File

@ -12,8 +12,7 @@
(import [prefix drscheme:frame: drscheme:frame^] (import [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^] [prefix drscheme:language-configuration: drscheme:language-configuration/internal^])
[prefix drscheme:teachpack: drscheme:teachpack^])
(export (rename drscheme:help-desk^ (export (rename drscheme:help-desk^
[-add-help-desk-font-prefs add-help-desk-font-prefs])) [-add-help-desk-font-prefs add-help-desk-font-prefs]))
@ -41,13 +40,7 @@
(cons name (cdr pr)))) (cons name (cdr pr))))
dirs))) dirs)))
(define (get-teachpack-filenames)
(format "~s"
(drscheme:teachpack:teachpack-cache-filenames
(preferences:get 'drscheme:teachpacks))))
(set-bug-report-info! "Computer Language" get-computer-language-info) (set-bug-report-info! "Computer Language" get-computer-language-info)
(set-bug-report-info! "Teachpack filenames" get-teachpack-filenames)
(define drscheme-help-desk-mixin (define drscheme-help-desk-mixin
(mixin (help-desk-frame<%> frame:standard-menus<%>) () (mixin (help-desk-frame<%> frame:standard-menus<%>) ()

81
collects/drscheme/private/language-configuration.ss
View File

@ -24,7 +24,6 @@
(define-unit language-configuration@ (define-unit language-configuration@
(import [prefix drscheme:unit: drscheme:unit^] (import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:rep: drscheme:rep^] [prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:init: drscheme:init^] [prefix drscheme:init: drscheme:init^]
[prefix drscheme:language: drscheme:language^] [prefix drscheme:language: drscheme:language^]
[prefix drscheme:app: drscheme:app^] [prefix drscheme:app: drscheme:app^]
@ -1068,72 +1067,8 @@
(+ 10 ;; upper bound on some platform specific space I don't know how to get. (+ 10 ;; upper bound on some platform specific space I don't know how to get.
(floor (inexact->exact (unbox y-box)))))) (floor (inexact->exact (unbox y-box))))))
(define teachpack-directory
(let ([lib-dir (collection-path "teachpack")])
(if (directory-exists? lib-dir)
lib-dir
#f)))
;; ;;
; ; ;
; ; ;
;;;;; ;;; ;;;; ;;; ; ;; ; ;;; ;;;; ;;; ; ;; ;;;
; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;;;;; ;;;; ; ; ; ; ; ;;;; ; ;; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
;;; ;;; ;;; ; ;;; ;;; ;;; ;;;; ;;; ; ;;; ;; ;; ;;;
;
;
;;;
;; add-new-teachpack : (instanceof frame%) -> boolean
;; querys the user for the name of a teachpack and adds it to the
;; current teachpacks. Uses the argument as the parent to the dialog
;; the result indicates if the teachpacks changed #t if they did and #f if not
(define (add-new-teachpack frame)
(let ([lib-file
(parameterize ([finder:dialog-parent-parameter frame])
(finder:get-file
teachpack-directory
(string-constant select-a-teachpack)
".*\\.(ss|scm)$"))])
(if lib-file
(let* ([interactions-text (send frame get-interactions-text)]
[tp-cache (send interactions-text get-user-teachpack-cache)]
[tp-filenames (drscheme:teachpack:teachpack-cache-filenames tp-cache)]
[new-item (normalize-path lib-file)])
(cond
[(member (normal-case-path new-item) (map normal-case-path tp-filenames))
(message-box (string-constant drscheme-teachpack-message-title)
(format (string-constant already-added-teachpack)
new-item)
frame)]
[else
(let ([new-teachpacks
(drscheme:teachpack:new-teachpack-cache
(append tp-filenames (list new-item)))])
(send interactions-text set-user-teachpack-cache new-teachpacks)
(preferences:set 'drscheme:teachpacks new-teachpacks))])
(set! teachpack-directory (path-only lib-file))
#t)
#f)))
;; clear-all-teachpacks : -> boolean
;; clears all of the teachpack settings
;; the result indicates if the teachpacks changed #t if they did and #f if not
(define (clear-all-teachpacks)
(let ([old (preferences:get 'drscheme:teachpacks)])
(cond
[(null? (drscheme:teachpack:teachpack-cache-filenames old))
#f]
[else
(drscheme:teachpack:set-teachpack-cache-filenames! old null)
(preferences:set 'drscheme:teachpacks old)
#t])))
; ;;; ; ;;;
; ;
@ -1340,10 +1275,10 @@
;; overrides front-end to make the language a language that expands its arguments ;; overrides front-end to make the language a language that expands its arguments
(define (add-expand-to-front-end %) (define (add-expand-to-front-end %)
(class % (class %
(define/override (front-end/complete-program input settings teachpack-cache) (define/override (front-end/complete-program input settings)
(wrap-front-end (super front-end/complete-program input settings teachpack-cache))) (wrap-front-end (super front-end/complete-program input settings)))
(define/override (front-end/interaction input settings teachpack-cache) (define/override (front-end/interaction input settings)
(wrap-front-end (super front-end/interaction input settings teachpack-cache))) (wrap-front-end (super front-end/interaction input settings)))
(define/private (wrap-front-end thnk) (define/private (wrap-front-end thnk)
(λ () (λ ()
(let ([res (thnk)]) (let ([res (thnk)])
@ -1383,7 +1318,7 @@
(define/override (get-one-line-summary) one-line-summary) (define/override (get-one-line-summary) one-line-summary)
(define/override (use-namespace-require/copy?) #t) (define/override (use-namespace-require/copy?) #t)
(inherit get-module get-transformer-module get-init-code) (inherit get-module get-transformer-module get-init-code)
(define/override (create-executable setting parent program-filename teachpacks) (define/override (create-executable setting parent program-filename)
(let ([executable-fn (let ([executable-fn
(drscheme:language:put-executable (drscheme:language:put-executable
parent parent
@ -1399,7 +1334,7 @@
executable-fn executable-fn
(get-module) (get-module)
(get-transformer-module) (get-transformer-module)
(get-init-code setting teachpacks) (get-init-code setting)
mred-launcher? mred-launcher?
(use-namespace-require/copy?))))) (use-namespace-require/copy?)))))
(super-new))))] (super-new))))]
@ -1485,10 +1420,10 @@
(not-a-language-message) (not-a-language-message)
(fprintf (current-error-port) "\n")) (fprintf (current-error-port) "\n"))
(define/override (front-end/interaction input settings teachpack-cache) (define/override (front-end/interaction input settings)
(not-a-language-message) (not-a-language-message)
(λ () eof)) (λ () eof))
(define/override (front-end/complete-program input settings teachpack-cache) (define/override (front-end/complete-program input settings)
(not-a-language-message) (not-a-language-message)
(λ () eof)) (λ () eof))

29
collects/drscheme/private/language.ss
View File

@ -22,7 +22,6 @@
(lib "bundle-dist.ss" "compiler")) (lib "bundle-dist.ss" "compiler"))
(import [prefix drscheme:debug: drscheme:debug^] (import [prefix drscheme:debug: drscheme:debug^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:tools: drscheme:tools^] [prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:help-desk: drscheme:help-desk^]) [prefix drscheme:help-desk: drscheme:help-desk^])
(export drscheme:language^) (export drscheme:language^)
@ -47,6 +46,8 @@
front-end/interaction front-end/interaction
config-panel config-panel
on-execute on-execute
extra-repl-information
first-opened first-opened
render-value/format render-value/format
render-value render-value
@ -196,8 +197,8 @@
(define/public (on-execute setting run-in-user-thread) (define/public (on-execute setting run-in-user-thread)
(initialize-simple-module-based-language setting run-in-user-thread)) (initialize-simple-module-based-language setting run-in-user-thread))
(define/public (get-init-code setting teachpacks) (define/public (get-init-code setting)
(simple-module-based-language-get-init-code setting teachpacks)) (simple-module-based-language-get-init-code setting))
(define/public (render-value/format value settings port width) (define/public (render-value/format value settings port width)
(simple-module-based-language-render-value/format value settings port width)) (simple-module-based-language-render-value/format value settings port width))
@ -443,8 +444,8 @@
(current-inspector (make-inspector)) (current-inspector (make-inspector))
(read-case-sensitive (simple-settings-case-sensitive setting))))) (read-case-sensitive (simple-settings-case-sensitive setting)))))
;; simple-module-based-language-get-init-code : setting teachpack-cache -> sexp[module] ;; simple-module-based-language-get-init-code : setting -> sexp[module]
(define (simple-module-based-language-get-init-code setting teachpack-cache) (define (simple-module-based-language-get-init-code setting)
`(module mod-name mzscheme `(module mod-name mzscheme
(require (lib "pconvert.ss") (require (lib "pconvert.ss")
(lib "pretty.ss")) (lib "pretty.ss"))
@ -483,7 +484,6 @@
`(void)) `(void))
(define (init-code) (define (init-code)
,(drscheme:teachpack:launcher-init-code teachpack-cache)
(current-inspector (make-inspector)) (current-inspector (make-inspector))
(error-value->string-handler executable-error-value->string-handler) (error-value->string-handler executable-error-value->string-handler)
(read-case-sensitive ,(simple-settings-case-sensitive setting))))) (read-case-sensitive ,(simple-settings-case-sensitive setting)))))
@ -533,18 +533,19 @@
(get-module) (get-module)
(get-transformer-module) (get-transformer-module)
run-in-user-thread)) run-in-user-thread))
(define/public (front-end/complete-program port settings teachpack-cache) (define/public (front-end/complete-program port settings)
(module-based-language-front-end port (get-reader))) (module-based-language-front-end port (get-reader)))
(define/public (front-end/interaction port settings teachpack-cache) (define/public (front-end/interaction port settings)
(module-based-language-front-end port (get-reader))) (module-based-language-front-end port (get-reader)))
(define/public (create-executable setting parent program-filename teachpacks) (define/public (create-executable setting parent program-filename)
(create-module-based-language-executable parent (create-module-based-language-executable parent
program-filename program-filename
(get-module) (get-module)
(get-transformer-module) (get-transformer-module)
(get-init-code setting teachpacks) (get-init-code setting)
(use-mred-launcher) (use-mred-launcher)
(use-namespace-require/copy?))) (use-namespace-require/copy?)))
(define/public (extra-repl-information _1 _2) (void))
(define/public (get-reader-module) #f) (define/public (get-reader-module) #f)
(define/public (get-metadata a b c) #f) (define/public (get-metadata a b c) #f)
(define/public (metadata->settings m) #f) (define/public (metadata->settings m) #f)
@ -905,15 +906,11 @@
(cons `(file ,(path->string init-code-tmp-filename)) (cons `(file ,(path->string init-code-tmp-filename))
pre-to-be-embedded-module-specs1)] pre-to-be-embedded-module-specs1)]
[pre-to-be-embedded-module-specs3 [pre-to-be-embedded-module-specs3
(append (drscheme:teachpack:launcher-modules-to-embed
(preferences:get 'drscheme:teachpacks))
pre-to-be-embedded-module-specs2)]
[pre-to-be-embedded-module-specs4
(filter (λ (x) (not (eq? x 'mzscheme))) (filter (λ (x) (not (eq? x 'mzscheme)))
pre-to-be-embedded-module-specs3)] pre-to-be-embedded-module-specs2)]
[to-be-embedded-module-specs [to-be-embedded-module-specs
(map (λ (x) (list #f x)) (map (λ (x) (list #f x))
pre-to-be-embedded-module-specs4)]) pre-to-be-embedded-module-specs3)])
(create-embedding-executable (create-embedding-executable
executable-filename executable-filename

7
collects/drscheme/private/link.ss
View File

@ -6,8 +6,7 @@
"multi-file-search.ss" "multi-file-search.ss"
"debug.ss" "debug.ss"
"module-language.ss" "module-language.ss"
"teachpack.ss" "tools.ss"
"tools.ss"
(lib "unit.ss") (lib "unit.ss")
"language.ss" "language.ss"
"language-configuration.ss" "language-configuration.ss"
@ -35,9 +34,8 @@
drscheme:language^ drscheme:language^
drscheme:help-desk^ drscheme:help-desk^
drscheme:eval^ drscheme:eval^
drscheme:teachpack^
drscheme:modes^) drscheme:modes^)
(link init@ tools@ modes@ text@ teachpack@ eval@ frame@ rep@ language@ (link init@ tools@ modes@ text@ eval@ frame@ rep@ language@
module-overview@ unit@ debug@ multi-file-search@ get-extend@ module-overview@ unit@ debug@ multi-file-search@ get-extend@
language-configuration@ font@ module-language@ help-desk@ app@ main@)) language-configuration@ font@ module-language@ help-desk@ app@ main@))
@ -52,7 +50,6 @@
(prefix drscheme:language: drscheme:language^) (prefix drscheme:language: drscheme:language^)
(prefix drscheme:help-desk: drscheme:help-desk^) (prefix drscheme:help-desk: drscheme:help-desk^)
(prefix drscheme:eval: drscheme:eval^) (prefix drscheme:eval: drscheme:eval^)
(prefix drscheme:teachpack: drscheme:teachpack^)
(prefix drscheme:modes: drscheme:modes^)) (prefix drscheme:modes: drscheme:modes^))
drscheme-unit@))) drscheme-unit@)))

16
collects/drscheme/private/main.ss
View File

@ -20,7 +20,6 @@
[prefix drscheme:get/extend: drscheme:get/extend^] [prefix drscheme:get/extend: drscheme:get/extend^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^] [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:language: drscheme:language^] [prefix drscheme:language: drscheme:language^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:module-language: drscheme:module-language^] [prefix drscheme:module-language: drscheme:module-language^]
[prefix drscheme:tools: drscheme:tools^] [prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:debug: drscheme:debug^] [prefix drscheme:debug: drscheme:debug^]
@ -173,15 +172,6 @@
(or (eq? x #t) (or (eq? x #t)
(not x)))) (not x))))
(preferences:set-default
'drscheme:teachpacks
(drscheme:teachpack:new-teachpack-cache)
drscheme:teachpack:teachpack-cache?)
(preferences:set-un/marshall
'drscheme:teachpacks
drscheme:teachpack:marshall-teachpack-cache
drscheme:teachpack:unmarshall-teachpack-cache)
(preferences:set-default 'drscheme:switch-to-module-language-automatically? #t boolean?) (preferences:set-default 'drscheme:switch-to-module-language-automatically? #t boolean?)
@ -278,7 +268,11 @@
(drscheme:language:register-capability 'drscheme:language-menu-title (drscheme:language:register-capability 'drscheme:language-menu-title
(flat-contract string?) (flat-contract string?)
(string-constant scheme-menu-name)) (string-constant scheme-menu-name))
(drscheme:language:register-capability 'drscheme:teachpack-menu-items
(or/c false/c (flat-contract drscheme:unit:teachpack-callbacks?))
#f)
(handler:current-create-new-window (handler:current-create-new-window
(let ([drscheme-current-create-new-window (let ([drscheme-current-create-new-window
(λ (filename) (λ (filename)

4
collects/drscheme/private/module-language.ss
View File

@ -116,7 +116,7 @@
(define/override (get-style-delta) module-language-style-delta) (define/override (get-style-delta) module-language-style-delta)
(inherit get-reader) (inherit get-reader)
(define/override (front-end/complete-program port settings teachpack-cache) (define/override (front-end/complete-program port settings)
(let* ([super-thunk (λ () ((get-reader) (object-name port) port))] (let* ([super-thunk (λ () ((get-reader) (object-name port) port))]
[filename (get-filename port)] [filename (get-filename port)]
[module-name #f] [module-name #f]
@ -162,7 +162,7 @@
[else eof])))) [else eof]))))
;; printer settings are just ignored here. ;; printer settings are just ignored here.
(define/override (create-executable setting parent program-filename teachpacks) (define/override (create-executable setting parent program-filename)
(let* ([executable-specs (drscheme:language:create-executable-gui (let* ([executable-specs (drscheme:language:create-executable-gui
parent parent
program-filename program-filename

38
collects/drscheme/private/rep.ss
View File

@ -69,7 +69,6 @@ TODO
(prefix drscheme:unit: drscheme:unit^) (prefix drscheme:unit: drscheme:unit^)
(prefix drscheme:text: drscheme:text^) (prefix drscheme:text: drscheme:text^)
(prefix drscheme:help-desk: drscheme:help-desk^) (prefix drscheme:help-desk: drscheme:help-desk^)
(prefix drscheme:teachpack: drscheme:teachpack^)
(prefix drscheme:debug: drscheme:debug^) (prefix drscheme:debug: drscheme:debug^)
[prefix drscheme:eval: drscheme:eval^]) [prefix drscheme:eval: drscheme:eval^])
(export (rename drscheme:rep^ (export (rename drscheme:rep^
@ -91,8 +90,6 @@ TODO
get-user-eventspace get-user-eventspace
get-user-thread get-user-thread
get-user-namespace get-user-namespace
get-user-teachpack-cache
set-user-teachpack-cache
get-definitions-text get-definitions-text
@ -446,6 +443,8 @@ TODO
(send* warning-style-delta (send* warning-style-delta
(set-delta-foreground "BLACK") (set-delta-foreground "BLACK")
(set-delta-background "YELLOW")) (set-delta-background "YELLOW"))
(define (get-welcome-delta) welcome-delta)
(define (get-dark-green-delta) dark-green-delta)
;; is-default-settings? : language-settings -> boolean ;; is-default-settings? : language-settings -> boolean
;; determines if the settings in `language-settings' ;; determines if the settings in `language-settings'
@ -605,6 +604,7 @@ TODO
get-out-port get-out-port
get-snip-position get-snip-position
get-start-position get-start-position
get-styles-fixed
get-style-list get-style-list
get-text get-text
get-top-level-window get-top-level-window
@ -635,6 +635,7 @@ TODO
set-insertion-point set-insertion-point
set-position set-position
set-styles-sticky set-styles-sticky
set-styles-fixed
set-unread-start-point set-unread-start-point
split-snip split-snip
thaw-colorer) thaw-colorer)
@ -904,7 +905,6 @@ TODO
(thread-running? (get-user-thread))))) (thread-running? (get-user-thread)))))
(field (user-language-settings #f) (field (user-language-settings #f)
(user-teachpack-cache (preferences:get 'drscheme:teachpacks))
(user-custodian-parent #f) (user-custodian-parent #f)
(memory-killed-thread #f) (memory-killed-thread #f)
(user-custodian #f) (user-custodian #f)
@ -921,8 +921,6 @@ TODO
(define/public (get-user-language-settings) user-language-settings) (define/public (get-user-language-settings) user-language-settings)
(define/public (get-user-custodian) user-custodian) (define/public (get-user-custodian) user-custodian)
(define/public (get-user-teachpack-cache) user-teachpack-cache)
(define/public (set-user-teachpack-cache tpc) (set! user-teachpack-cache tpc))
(define/public (get-user-eventspace) (weak-box-value user-eventspace-box)) (define/public (get-user-eventspace) (weak-box-value user-eventspace-box))
(define/public (get-user-thread) user-eventspace-main-thread) (define/public (get-user-thread) user-eventspace-main-thread)
(define/public (get-user-namespace) (weak-box-value user-namespace-box)) (define/public (get-user-namespace) (weak-box-value user-namespace-box))
@ -1060,8 +1058,8 @@ TODO
[dummy-value (box #f)] [dummy-value (box #f)]
[get-sexp/syntax/eof [get-sexp/syntax/eof
(if complete-program? (if complete-program?
(send lang front-end/complete-program port settings user-teachpack-cache) (send lang front-end/complete-program port settings)
(send lang front-end/interaction port settings user-teachpack-cache))]) (send lang front-end/interaction port settings))])
; Evaluate the user's expression. We're careful to turn on ; Evaluate the user's expression. We're careful to turn on
; breaks as we go in and turn them off as we go out. ; breaks as we go in and turn them off as we go out.
@ -1230,13 +1228,6 @@ TODO
"copied exn raised when setting up snip values (thunk passed as third argume to drscheme:language:add-snip-value)\n") "copied exn raised when setting up snip values (thunk passed as third argume to drscheme:language:add-snip-value)\n")
(raise exn))) (raise exn)))
;; installs the teachpacks
;; must happen after language is initialized.
(queue-user/wait
(λ () ; =User=, =No-Breaks=
(drscheme:teachpack:install-teachpacks
user-teachpack-cache)))
(parameterize ([current-eventspace user-eventspace]) (parameterize ([current-eventspace user-eventspace])
(queue-callback (queue-callback
(λ () (λ ()
@ -1476,17 +1467,14 @@ TODO
dark-green-delta)) dark-green-delta))
(insert/delta this ".\n" welcome-delta) (insert/delta this ".\n" welcome-delta)
(let ([osf (get-styles-fixed)])
(set-styles-fixed #f)
(send (drscheme:language-configuration:language-settings-language user-language-settings)
extra-repl-information
(drscheme:language-configuration:language-settings-settings user-language-settings)
(open-output-text-editor this 'end))
(set-styles-fixed osf))
(for-each
(λ (fn)
(insert/delta this
(string-append (string-constant teachpack) ": ")
welcome-delta)
(insert/delta this fn dark-green-delta)
(insert/delta this ".\n" welcome-delta))
(map path->string
(drscheme:teachpack:teachpack-cache-filenames
user-teachpack-cache)))
(set! setting-up-repl? #f) (set! setting-up-repl? #f)
(set! already-warned? #f) (set! already-warned? #f)

169
collects/drscheme/private/teachpack.ss
View File

@ -1,169 +0,0 @@
(module teachpack mzscheme
(require (lib "unit.ss")
(lib "list.ss")
(lib "file.ss")
(lib "etc.ss")
(lib "framework.ss" "framework")
(lib "mred.ss" "mred")
(lib "string-constant.ss" "string-constants")
"drsig.ss")
(provide teachpack@)
(define o (current-output-port))
(define (oprintf . args) (apply fprintf o args))
(define-unit teachpack@
(import)
(export drscheme:teachpack^)
;; type teachpack-cache = (make-teachpack-cache (listof cache-entry))
;; the timestamp indicates the last time this teachpack was loaded
(define-struct teachpack-cache (tps))
;; type cache-entry = (make-cache-entry path)
(define-struct cache-entry (filename))
(define (cache-entry-require-spec cache-entry)
(cache-entry-filename cache-entry))
;; new-teachpack-cache : -> teachpack-cache
(define new-teachpack-cache
(opt-lambda ([filenames '[]])
(make-teachpack-cache (map make-cache-entry filenames))))
;; set-teachpack-cache-filenames! : teachpack-cache (listof string) -> void
;; this shouldn't remove all of the #fs.
(define (set-teachpack-cache-filenames! teachpack-cache filenames)
(set-teachpack-cache-tps!
teachpack-cache
(map (λ (filename) (make-cache-entry filename))
filenames)))
;; install-teachpacks : teachpack-cache -> void
;; =User=
;; installs the loaded teachpacks
;; updates the cache, removing those teachpacks that failed to run
;; requires that none of the cache-entries have #fs in them.
(define (install-teachpacks cache)
(for-each install-teachpack (teachpack-cache-tps cache))
(set-teachpack-cache-tps!
cache
(filter cache-entry-filename (teachpack-cache-tps cache))))
;; install-teachpack : cache-entry -> void
;; =User=
;; updates the cache-entry's filename to #f if the teachpack fails
;; to run properly
(define (install-teachpack cache-entry)
(let ([filename (cache-entry-filename cache-entry)])
(with-handlers ([exn:fail?
(λ (exn)
(set-cache-entry-filename! cache-entry #f)
(show-teachpack-error filename exn))])
(verify-no-new-exports filename)
(namespace-require (cache-entry-require-spec cache-entry)))))
;; verify-no-new-exports : string -> void
;; ensures that the teachpack wouldn't override any thing in the user's namespace
(define (verify-no-new-exports filename)
(let ([exports (extract-provided-variables-from-module filename)]
[ns-contents (namespace-mapped-symbols)]
[ht (make-hash-table)])
(for-each (λ (ns-sym) (hash-table-put! ht ns-sym #t)) ns-contents)
(for-each (λ (expt)
(when (hash-table-get ht expt (λ () #f))
(error 'teachpack "export of ~a from ~s conflicts with already existing definitions"
expt filename)))
exports)))
;; extract-provided-variables-from-module : string -> (listof symbol)
(define (extract-provided-variables-from-module filename)
(let* ([module-stx
(parameterize ([current-namespace (make-namespace)])
(let-values ([(base name dir?) (split-path filename)])
(parameterize [(current-load-relative-directory base)
(current-directory base)]
(expand
(parameterize [(read-case-sensitive #f)
(read-square-bracket-as-paren #t)
(read-curly-brace-as-paren #t)
(read-accept-box #t)
(read-accept-compiled #t)
(read-accept-bar-quote #t)
(read-accept-graph #t)
(read-decimal-as-inexact #t)
(read-accept-dot #t)
(read-accept-quasiquote #t)]
(call-with-input-file filename
(λ (port) (read-syntax filename port))))))))]
[var-prop (get-exported-names (syntax-property module-stx 'module-variable-provides))]
[mac-prop (get-exported-names (syntax-property module-stx 'module-syntax-provides))])
(append var-prop mac-prop)))
;; get-exported-names : module-variable-provides / module-syntax-provides info (see mz manual) -> (listof symbol)
(define (get-exported-names names)
(if names
(map (λ (x)
(cond
[(symbol? x) x]
[(symbol? (cdr x)) (car x)]
[else (cadr x)]))
names)
'()))
;; marshall-teachpack-cache : teachpack-cache -> writable
(define (marshall-teachpack-cache cache)
(map (λ (x) (path->bytes (cache-entry-filename x))) (teachpack-cache-tps cache)))
;; unmarshall-teachpack-cache : writable -> teachpack-cache
(define (unmarshall-teachpack-cache lof)
(make-teachpack-cache
(if (and (list? lof)
(andmap bytes? lof))
(map (λ (x) (make-cache-entry (bytes->path x))) lof)
null)))
;; teachpack-cache-filenames : teachpack-cache -> (listof string)
(define (teachpack-cache-filenames cache)
(map cache-entry-filename (teachpack-cache-tps cache)))
;; teachpack-cache-filenames : teachpack-cache -> (listof string)
(define (teachpack-cache-require-specs cache)
(map (λ (x) (cache-entry-require-spec x))
(teachpack-cache-tps cache)))
;; launcher-init-code : teachpack-cache -> sexp
;; constructs code to be put in a module that loads the teachpacks.
;; used with launchers
(define (launcher-init-code cache)
`(begin
(void)
,@(map (λ (ce)
(let ([req-spec (cache-entry-require-spec ce)])
(if (path? req-spec)
`(namespace-require (bytes->path ,(path->bytes req-spec)))
`(namespace-require ',req-spec))))
(teachpack-cache-tps cache))))
;; launcher-modules-to-embed : teachpack-cache -> (listof module-spec)
;; the modules to embed in a stand-alone executable.
(define (launcher-modules-to-embed cache)
(map (λ (ce) (cache-entry-require-spec ce))
(teachpack-cache-tps cache)))
;; show-teachpack-error : string TST -> void
;; shows an error message for a bad teachpack.
(define (show-teachpack-error tp-filename exn)
(message-box
(string-constant teachpack-error-label)
(string-append
(format (string-constant teachpack-didnt-load)
tp-filename)
(string #\newline)
;; should check for error trace and use that here (somehow)
(if (exn? exn)
(format "~a" (exn-message exn))
(format "uncaught exception: ~s" exn)))))))

57
collects/drscheme/private/tool-contracts.ss
View File

@ -561,6 +561,19 @@
; ; ; ;
; ; ; ;
(drscheme:rep:get-welcome-delta
(-> (is-a?/c style-delta%))
()
"Returns a style delta that matches the style and color of the "
"phrase ``Welcome to'' in the beginning of the interactions window.")
(drscheme:rep:get-dark-green-delta
(-> (is-a?/c style-delta%))
()
"Returns a style delta that matches the style and color of the "
"name of a language in the interactions window.")
(drscheme:rep:get-drs-bindings-keymap (drscheme:rep:get-drs-bindings-keymap
(-> (is-a?/c keymap%)) (-> (is-a?/c keymap%))
() ()
@ -1345,46 +1358,7 @@
"they default to \\scmc{\\#t} \\Symbol{keyword+index} and \\Symbol{exact}," "they default to \\scmc{\\#t} \\Symbol{keyword+index} and \\Symbol{exact},"
"and \\Symbol{all} respectively.") "and \\Symbol{all} respectively.")
;
;
;
; ; ;
; ; ;
; ; ; ;
; ;;;; ;;; ;;; ;;; ; ;; ; ;; ;;; ;;; ; ;
; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;;;;;; ;;;; ; ; ; ; ; ;;;; ; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;
; ;; ;;;; ;;;;; ;;; ; ; ; ;; ;;;;; ;;; ; ;
; ;
; ;
; ;
(drscheme:teachpack:install-teachpacks
(drscheme:teachpack:teachpack-cache? . -> . void?)
(teachpack-cache)
"Installs the teachpack cache in the current namespace."
"Passing \\scheme{'drscheme:teachpacks} to"
"@flink preferences:get"
"returns the user's currently selected TeachPacks.")
(drscheme:teachpack:teachpack-cache?
(any/c . -> . boolean?)
(val)
"Determines if \\var{val} is a teachpack"
"cache or not.")
(drscheme:teachpack:teachpack-cache-filenames
(drscheme:teachpack:teachpack-cache? . -> . (listof path?))
(teachpack-cache)
"Returns the list of filenames for the teachpacks"
"in \\var{teachpack-cache}."
""
"See also"
"@flink drscheme:teachpack:install-teachpacks %"
".")
; ;
@ -1414,7 +1388,6 @@
(create-executable (any/c (create-executable (any/c
(or/c (is-a?/c dialog%) (is-a?/c frame%)) (or/c (is-a?/c dialog%) (is-a?/c frame%))
path? path?
drscheme:teachpack:teachpack-cache?
. -> . . -> .
void?)) void?))
(default-settings (-> any/c)) (default-settings (-> any/c))
@ -1422,12 +1395,10 @@
(order-manuals ((listof bytes?) . -> . (values (listof bytes?) boolean?))) (order-manuals ((listof bytes?) . -> . (values (listof bytes?) boolean?)))
(front-end/complete-program (input-port? (front-end/complete-program (input-port?
any/c any/c
drscheme:teachpack:teachpack-cache?
. -> . . -> .
(-> any/c))) (-> any/c)))
(front-end/interaction (input-port? (front-end/interaction (input-port?
any/c any/c
drscheme:teachpack:teachpack-cache?
. -> . . -> .
(-> any/c))) (-> any/c)))
(get-language-name (-> string?)) (get-language-name (-> string?))

1
collects/drscheme/private/tools.ss
View File

@ -20,7 +20,6 @@
[prefix drscheme:init: drscheme:init^] [prefix drscheme:init: drscheme:init^]
[prefix drscheme:debug: drscheme:debug^] [prefix drscheme:debug: drscheme:debug^]
[prefix drscheme:eval: drscheme:eval^] [prefix drscheme:eval: drscheme:eval^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:modes: drscheme:modes^]) [prefix drscheme:modes: drscheme:modes^])
(export drscheme:tools^) (export drscheme:tools^)

107
collects/drscheme/private/unit.ss
View File

@ -52,7 +52,6 @@ module browser threading seems wrong.
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^] [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:language: drscheme:language^] [prefix drscheme:language: drscheme:language^]
[prefix drscheme:get/extend: drscheme:get/extend^] [prefix drscheme:get/extend: drscheme:get/extend^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:module-overview: drscheme:module-overview^] [prefix drscheme:module-overview: drscheme:module-overview^]
[prefix drscheme:tools: drscheme:tools^] [prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:eval: drscheme:eval^] [prefix drscheme:eval: drscheme:eval^]
@ -92,6 +91,15 @@ module browser threading seems wrong.
get-next-settings get-next-settings
after-set-next-settings)) after-set-next-settings))
(define-struct teachpack-callbacks
(get-names ;; settings -> (listof string)
add ;; settings path -> settings
remove ;; string[returned from teachpack-names] settings -> settings
remove-all ;; settings -> settings
))
;; get rid of set-user-teachpack-cache method
(keymap:add-to-right-button-menu (keymap:add-to-right-button-menu
(let ([old (keymap:add-to-right-button-menu)]) (let ([old (keymap:add-to-right-button-menu)])
(λ (menu text event) (λ (menu text event)
@ -269,8 +277,7 @@ module browser threading seems wrong.
create-executable create-executable
(drscheme:language-configuration:language-settings-settings settings) (drscheme:language-configuration:language-settings-settings settings)
frame frame
program-filename program-filename)))])))
(send (send frame get-interactions-text) get-user-teachpack-cache))))])))
(define make-execute-bitmap (define make-execute-bitmap
(bitmap-label-maker (string-constant execute-button-label) (bitmap-label-maker (string-constant execute-button-label)
@ -563,6 +570,8 @@ module browser threading seems wrong.
(send execute-lang marshall-settings (send execute-lang marshall-settings
(drscheme:language-configuration:language-settings-settings next-settings)))))) (drscheme:language-configuration:language-settings-settings next-settings))))))
(define/pubment (set-needs-execution-message msg)
(set! needs-execution-state msg))
(define/pubment (teachpack-changed) (define/pubment (teachpack-changed)
(set! needs-execution-state (string-constant needs-execute-teachpack-changed))) (set! needs-execution-state (string-constant needs-execute-teachpack-changed)))
(define/pubment (just-executed) (define/pubment (just-executed)
@ -2308,28 +2317,6 @@ module browser threading seems wrong.
(define/public (get-definitions-text) definitions-text) (define/public (get-definitions-text) definitions-text)
(define/public (get-interactions-text) interactions-text) (define/public (get-interactions-text) interactions-text)
(define/private (update-teachpack-menu)
(define user-teachpack-cache (send (get-interactions-text) get-user-teachpack-cache))
(for-each (λ (item) (send item delete)) teachpack-items)
(set! teachpack-items
(map (λ (name)
(make-object menu:can-restore-menu-item%
(format (string-constant clear-teachpack)
(mzlib:file:file-name-from-path name))
language-menu
(λ (item evt)
(let ([new-teachpacks
(drscheme:teachpack:new-teachpack-cache
(remove
name
(drscheme:teachpack:teachpack-cache-filenames
user-teachpack-cache)))])
(send (get-interactions-text) set-user-teachpack-cache new-teachpacks)
(preferences:set 'drscheme:teachpacks new-teachpacks)
(send (get-definitions-text) teachpack-changed)))))
(drscheme:teachpack:teachpack-cache-filenames
user-teachpack-cache))))
(define/public (get-definitions/interactions-panel-parent) (define/public (get-definitions/interactions-panel-parent)
(get-area-container)) (get-area-container))
@ -2757,11 +2744,54 @@ module browser threading seems wrong.
(when new-settings (when new-settings
(send definitions-text set-next-settings new-settings)))) (send definitions-text set-next-settings new-settings))))
;; must be called from on-demand (on each menu click), or the state won't be handled properly
(define/private (update-teachpack-menu)
(for-each (λ (item) (send item delete)) teachpack-items)
(let ([tp-callbacks (get-current-capability-value 'drscheme:teachpack-menu-items)])
(cond
[tp-callbacks
(let* ([language (drscheme:language-configuration:language-settings-language
(send (get-definitions-text) get-next-settings))]
[settings (drscheme:language-configuration:language-settings-settings
(send (get-definitions-text) get-next-settings))]
[tp-names ((teachpack-callbacks-get-names tp-callbacks) settings)]
[update-settings
(λ (settings)
(send (get-definitions-text) set-next-settings
(drscheme:language-configuration:make-language-settings language settings))
(send (get-definitions-text) teachpack-changed))])
(set! teachpack-items
(list*
(make-object separator-menu-item% language-menu)
(new menu:can-restore-menu-item%
[label (string-constant add-teachpack-menu-item-label)]
[parent language-menu]
[callback
(λ (_1 _2)
(update-settings ((teachpack-callbacks-add tp-callbacks) settings this)))])
(let ([mi (new menu:can-restore-menu-item%
[label (string-constant clear-all-teachpacks-menu-item-label)]
[parent language-menu]
[callback
(λ (_1 _2)
(update-settings ((teachpack-callbacks-remove-all tp-callbacks) settings)))])])
(send mi enable (not (null? tp-names)))
mi)
(map (λ (name)
(new menu:can-restore-menu-item%
[label (format (string-constant clear-teachpack) name)]
[parent language-menu]
[callback
(λ (item evt)
(update-settings ((teachpack-callbacks-remove tp-callbacks) settings name)))]))
tp-names))))]
[else
(set! teachpack-items '())])))
(define/private (initialize-menus) (define/private (initialize-menus)
(let* ([mb (get-menu-bar)] (let* ([mb (get-menu-bar)]
[language-menu-on-demand [language-menu-on-demand (λ (menu-item) (update-teachpack-menu))]
(λ (menu-item)
(update-teachpack-menu))]
[_ (set! language-menu (make-object (get-menu%) [_ (set! language-menu (make-object (get-menu%)
(string-constant language-menu-name) (string-constant language-menu-name)
mb mb
@ -2786,27 +2816,6 @@ module browser threading seems wrong.
language-menu language-menu
(λ (_1 _2) (choose-language-callback)) (λ (_1 _2) (choose-language-callback))
#\l) #\l)
(make-object separator-menu-item% language-menu)
(make-object menu:can-restore-menu-item%
(string-constant add-teachpack-menu-item-label)
language-menu
(λ (_1 _2)
(when (drscheme:language-configuration:add-new-teachpack this)
(send (get-definitions-text) teachpack-changed))))
(let ([clear-all-on-demand
(λ (menu-item)
(send menu-item enable
(not (null? (drscheme:teachpack:teachpack-cache-filenames
(preferences:get 'drscheme:teachpacks))))))])
(make-object menu:can-restore-menu-item%
(string-constant clear-all-teachpacks-menu-item-label)
language-menu
(λ (_1 _2)
(when (drscheme:language-configuration:clear-all-teachpacks)
(send (get-definitions-text) teachpack-changed)))
#f
#f
clear-all-on-demand))
(set! execute-menu-item (set! execute-menu-item
(make-object menu:can-restore-menu-item% (make-object menu:can-restore-menu-item%

337
collects/lang/htdp-langs.ss
View File

@ -1,8 +1,5 @@
#| #|
tracing todo:
- shorten lines
;; we don't use the built in debugging, use our own ;; we don't use the built in debugging, use our own
;; version here that has no bug icon and only ;; version here that has no bug icon and only
;; annotates code that comes from editors. ;; annotates code that comes from editors.
@ -16,6 +13,7 @@ tracing todo:
(prefix tr: (lib "stacktrace.ss" "trace")) (prefix tr: (lib "stacktrace.ss" "trace"))
(lib "pretty.ss") (lib "pretty.ss")
(prefix pc: (lib "pconvert.ss")) (prefix pc: (lib "pconvert.ss"))
(lib "file.ss")
(lib "unit.ss") (lib "unit.ss")
(lib "class.ss") (lib "class.ss")
(lib "list.ss") (lib "list.ss")
@ -27,7 +25,8 @@ tracing todo:
(lib "cache-image-snip.ss" "mrlib") (lib "cache-image-snip.ss" "mrlib")
(lib "embed.ss" "compiler") (lib "embed.ss" "compiler")
(lib "wxme.ss" "wxme") (lib "wxme.ss" "wxme")
(lib "struct.ss")
(lib "dirs.ss" "setup")
;; this module is shared between the drscheme's namespace (so loaded here) ;; this module is shared between the drscheme's namespace (so loaded here)
;; and the user's namespace in the teaching languages ;; and the user's namespace in the teaching languages
@ -49,6 +48,9 @@ tracing todo:
(define init-eventspace (current-eventspace)) (define init-eventspace (current-eventspace))
(define user-installed-teachpacks-collection "installed-teachpacks")
(define teachpack-installation-dir (build-path (find-user-collects-dir) user-installed-teachpacks-collection))
(define tool@ (define tool@
(unit (unit
(import drscheme:tool^) (import drscheme:tool^)
@ -68,7 +70,9 @@ tracing todo:
(define drs-eventspace (current-eventspace)) (define drs-eventspace (current-eventspace))
(define-struct (htdp-lang-settings drscheme:language:simple-settings) (tracing?)) ;; tracing? : boolean
;; teachpacks : (listof require-spec)
(define-struct (htdp-lang-settings drscheme:language:simple-settings) (tracing? teachpacks))
(define htdp-lang-settings->vector (make-->vector htdp-lang-settings)) (define htdp-lang-settings->vector (make-->vector htdp-lang-settings))
(define image-string "<image>") (define image-string "<image>")
@ -100,21 +104,24 @@ tracing todo:
(get-sharing-printing) (get-sharing-printing)
#t #t
'none 'none
#f)) #f
'()))
(define/override (default-settings? s) (define/override (default-settings? s)
(and (super default-settings? s) (and (super default-settings? s)
(not (htdp-lang-settings-tracing? s)))) (not (htdp-lang-settings-tracing? s))
(null? (htdp-lang-settings-teachpacks s))))
(define/override (marshall-settings x) (define/override (marshall-settings x)
(list (super marshall-settings x) (list (super marshall-settings x)
(htdp-lang-settings-tracing? x))) (htdp-lang-settings-tracing? x)
(htdp-lang-settings-teachpacks x)))
(define/override (unmarshall-settings x) (define/override (unmarshall-settings x)
(if (and (pair? x) (if (and (list? x)
(pair? (cdr x)) (= (length x) 3)
(null? (cddr x)) (boolean? (list-ref x 1))
(boolean? (cadr x))) (list-of-require-specs? (list-ref x 2)))
(let ([drs-settings (super unmarshall-settings (first x))]) (let ([drs-settings (super unmarshall-settings (first x))])
(make-htdp-lang-settings (make-htdp-lang-settings
(drscheme:language:simple-settings-case-sensitive drs-settings) (drscheme:language:simple-settings-case-sensitive drs-settings)
@ -123,9 +130,17 @@ tracing todo:
(drscheme:language:simple-settings-show-sharing drs-settings) (drscheme:language:simple-settings-show-sharing drs-settings)
(drscheme:language:simple-settings-insert-newlines drs-settings) (drscheme:language:simple-settings-insert-newlines drs-settings)
(drscheme:language:simple-settings-annotations drs-settings) (drscheme:language:simple-settings-annotations drs-settings)
(cadr x))) (cadr x)
(caddr x)))
(default-settings))) (default-settings)))
(define/private (list-of-require-specs? l)
(and (list? l)
(andmap (λ (x)
(and (list? x)
(andmap string? x)))
l)))
(inherit get-allow-sharing? get-use-function-output-syntax? (inherit get-allow-sharing? get-use-function-output-syntax?
get-accept-quasiquote? get-read-accept-dot) get-accept-quasiquote? get-read-accept-dot)
(define/override (config-panel parent) (define/override (config-panel parent)
@ -200,6 +215,16 @@ tracing todo:
(label (string-constant output-syntax)) (label (string-constant output-syntax))
(alignment '(left center)))] (alignment '(left center)))]
[tp-group-box (instantiate group-box-panel% ()
(label (string-constant teachpacks))
(parent parent)
(alignment '(center top)))]
[tp-panel (new vertical-panel%
[parent tp-group-box]
[alignment '(center center)]
[stretchable-width #f]
[stretchable-height #f])]
[case-sensitive (make-object check-box% [case-sensitive (make-object check-box%
(string-constant case-sensitive-label) (string-constant case-sensitive-label)
input-panel input-panel
@ -228,7 +253,9 @@ tracing todo:
[tracing (new check-box% [tracing (new check-box%
(parent output-panel) (parent output-panel)
(label sc-tracing) (label sc-tracing)
(callback void))]) (callback void))]
[tps '()])
(when allow-sharing-config? (when allow-sharing-config?
(set! show-sharing (set! show-sharing
@ -261,7 +288,8 @@ tracing todo:
(and allow-sharing-config? (send show-sharing get-value)) (and allow-sharing-config? (send show-sharing get-value))
(send insert-newlines get-value) (send insert-newlines get-value)
'none 'none
(send tracing get-value))] (send tracing get-value)
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
@ -284,6 +312,17 @@ tracing todo:
(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))
(send tp-panel change-children (λ (l) '()))
(if (null? tps)
(new message%
[parent tp-panel]
[label (string-constant teachpacks-none)])
(for-each
(λ (tp) (new message%
[parent tp-panel]
[label (format "~s" tp)]))
tps))
(send tracing set-value (htdp-lang-settings-tracing? settings))]))) (send tracing set-value (htdp-lang-settings-tracing? settings))])))
(define simple-htdp-language% (define simple-htdp-language%
@ -314,12 +353,49 @@ tracing todo:
(class % (class %
(inherit get-manual) (inherit get-manual)
(define/override (extra-repl-information settings port)
(define (go str sd)
(let* ([s (make-object string-snip% str)]
[sl (editor:get-standard-style-list)]
[std (send sl find-named-style "Standard")]
[style (send sl find-or-create-style std sd)])
(send s set-style style)
(write-special s port)))
(define tps (htdp-lang-settings-teachpacks settings))
(unless (null? tps)
(go "Teachpack" (drscheme:rep:get-welcome-delta))
(cond
[(= 1 (length tps))
(go ": " (drscheme:rep:get-welcome-delta))
(go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))]
[(= 2 (length tps))
(go "s: " (drscheme:rep:get-welcome-delta))
(go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))
(go " and " (drscheme:rep:get-welcome-delta))
(go (cadr (cadr tps)) (drscheme:rep:get-dark-green-delta))]
[else
(go "s: " (drscheme:rep:get-welcome-delta))
(go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))
(let loop ([these-tps (cdr tps)])
(cond
[(null? (cdr these-tps))
(go ", and " (drscheme:rep:get-welcome-delta))
(go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))]
[else
(go ", " (drscheme:rep:get-welcome-delta))
(go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))
(loop (cdr these-tps))]))])
(go "." (drscheme:rep:get-welcome-delta))
(newline port)))
(define/override (order-manuals x) (define/override (order-manuals x)
(values (list (get-manual) #"teachpack" #"drscheme" #"help") #f)) (values (list (get-manual) #"teachpack" #"drscheme" #"help") #f))
(inherit get-module get-transformer-module get-init-code (inherit get-module get-transformer-module get-init-code
use-namespace-require/copy?) use-namespace-require/copy?)
(define/override (create-executable setting parent program-filename teachpack-cache) (define/override (create-executable setting parent program-filename)
(let ([dist-filename (let ([dist-filename
(drscheme:language:put-executable (drscheme:language:put-executable
parent program-filename parent program-filename
@ -429,7 +505,7 @@ tracing todo:
(inherit get-reader set-printing-parameters) (inherit get-reader set-printing-parameters)
(define/override (front-end/complete-program port settings teachpacks) (define/override (front-end/complete-program port settings)
(let ([state 'init] (let ([state 'init]
;; state : 'init => 'require => 'done ;; state : 'init => 'require => 'done
[reader (get-reader)]) [reader (get-reader)])
@ -444,16 +520,23 @@ tracing todo:
(if (eof-object? result) (if (eof-object? result)
null null
(cons result (loop)))))] (cons result (loop)))))]
[language-module (get-module)] [language-module (get-module)])
[require-specs (for-each
(drscheme:teachpack:teachpack-cache-require-specs teachpacks)]) (λ (tp)
(rewrite-module (with-handlers ((exn:fail? (λ (x) (error 'teachpack (missing-tp-message tp)))))
(unless (file-exists? (build-path (apply collection-path (cddr tp))
(cadr tp)))
(error))))
(htdp-lang-settings-teachpacks settings))
(rewrite-module
settings
(expand (expand
(datum->syntax-object (datum->syntax-object
#f #f
`(,#'module #%htdp ,language-module `(,#'module #%htdp ,language-module
(,#'require ,@require-specs) ,@(map (λ (x) `(require ,x))
,@body-exps)))))] (htdp-lang-settings-teachpacks settings))
,@body-exps)))))]
[(require) [(require)
(set! state 'done) (set! state 'done)
(syntax (syntax
@ -468,13 +551,73 @@ tracing todo:
(set! done-already? #t) (set! done-already? #t)
(current-namespace (module->namespace '#%htdp)))))))] (current-namespace (module->namespace '#%htdp)))))))]
[(done) eof])))) [(done) eof]))))
(define/private (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)))
(define/augment (capability-value key) (define/augment (capability-value key)
(case key (case key
[(drscheme:teachpack-menu-items) htdp-teachpack-callbacks]
[(drscheme:special:insert-lambda) #f] [(drscheme:special:insert-lambda) #f]
[else (inner (drscheme:language:get-capability-default key) [else (inner (drscheme:language:get-capability-default key)
capability-value capability-value
key)])) key)]))
(define htdp-teachpack-callbacks
(drscheme:unit:make-teachpack-callbacks
(λ (settings)
(map cadr (htdp-lang-settings-teachpacks settings)))
(λ (settings parent)
(let ([teachpack (get-teachpack-from-user parent)])
(if teachpack
(let ([old-tps (htdp-lang-settings-teachpacks settings)])
(if (member teachpack old-tps)
(begin
(message-box (string-constant drscheme)
(format (string-constant already-added-teachpack)
(cadr teachpack)))
settings)
(make-htdp-lang-settings
(drscheme:language:simple-settings-case-sensitive settings)
(drscheme:language:simple-settings-printing-style settings)
(drscheme:language:simple-settings-fraction-style settings)
(drscheme:language:simple-settings-show-sharing settings)
(drscheme:language:simple-settings-insert-newlines settings)
(drscheme:language:simple-settings-annotations settings)
(htdp-lang-settings-tracing? settings)
(append old-tps (list teachpack)))
#;
(copy-struct htdp-lang-settings settings
[htdp-lang-settings-teachpacks
(append old-tps (list teachpack))])))
settings)))
(λ (settings name)
(make-htdp-lang-settings
(drscheme:language:simple-settings-case-sensitive settings)
(drscheme:language:simple-settings-printing-style settings)
(drscheme:language:simple-settings-fraction-style settings)
(drscheme:language:simple-settings-show-sharing settings)
(drscheme:language:simple-settings-insert-newlines settings)
(drscheme:language:simple-settings-annotations settings)
(htdp-lang-settings-tracing? settings)
(filter (λ (x) (not (equal? (cadr x) name)))
(htdp-lang-settings-teachpacks settings))))
(λ (settings)
(make-htdp-lang-settings
(drscheme:language:simple-settings-case-sensitive settings)
(drscheme:language:simple-settings-printing-style settings)
(drscheme:language:simple-settings-fraction-style settings)
(drscheme:language:simple-settings-show-sharing settings)
(drscheme:language:simple-settings-insert-newlines settings)
(drscheme:language:simple-settings-annotations settings)
(htdp-lang-settings-tracing? settings)
'()))))
(inherit-field reader-module) (inherit-field reader-module)
(define/override (get-reader-module) reader-module) (define/override (get-reader-module) reader-module)
@ -486,6 +629,7 @@ tracing todo:
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))
(htdp-settings ,(htdp-lang-settings->vector settings)))))) (htdp-settings ,(htdp-lang-settings->vector settings))))))
(inherit default-settings) (inherit default-settings)
@ -493,7 +637,11 @@ tracing todo:
(let* ([table (metadata->table metadata)] ;; extract the table (let* ([table (metadata->table metadata)] ;; extract the table
[ssv (assoc 'htdp-settings table)]) [ssv (assoc 'htdp-settings table)])
(if ssv (if ssv
(apply make-htdp-lang-settings (vector->list (cadr ssv))) (let ([settings-list (vector->list (cadr ssv))])
(if (equal? (length settings-list)
(procedure-arity make-htdp-lang-settings))
(apply make-htdp-lang-settings settings-list)
(default-settings)))
(default-settings)))) (default-settings))))
(define/private (metadata->table metadata) (define/private (metadata->table metadata)
@ -506,6 +654,137 @@ tracing todo:
(super-new))) (super-new)))
(define (get-teachpack-from-user parent)
(define tp-dir (collection-path "teachpack" "htdp"))
(define columns 2)
(define tps (filter
(λ (x) (file-exists? (build-path tp-dir x)))
(directory-list tp-dir)))
(define sort-order (λ (x y) (string<=? (path->string x) (path->string y))))
(define pre-installed-tps (sort tps sort-order))
(define dlg (new dialog% [parent parent] [label (string-constant drscheme)]))
(define hp (new horizontal-panel% [parent dlg]))
(define answer #f)
(define pre-installed-gb (new group-box-panel%
[label (string-constant teachpack-pre-installed)]
[parent hp]))
(define user-installed-gb (new group-box-panel%
[label (string-constant teachpack-user-installed)]
[parent hp]))
(define pre-installed-lb
(new list-box%
[label #f]
[choices (map path->string pre-installed-tps)]
[stretchable-height #t]
[min-height 300]
[min-width 200]
[callback
(λ (x evt)
(case (send evt get-event-type)
[(list-box-dclick) (selected pre-installed-lb)]
[else
(clear-selection user-installed-lb)
(update-button)]))]
[parent pre-installed-gb]))
(define user-installed-lb
(new list-box%
[label #f]
[choices '()]
[stretchable-height #t]
[min-width 200]
[callback
(λ (x evt)
(case (send evt get-event-type)
[(list-box-dclick) (selected user-installed-lb)]
[else
(clear-selection pre-installed-lb)
(update-button)]))]
[parent user-installed-gb]))
(define (selected lb)
(set! answer (figure-out-answer))
(send dlg show #f))
(define (clear-selection lb)
(for-each
(λ (x) (send lb select x #f))
(send lb get-selections)))
(define add-button (new button%
[parent user-installed-gb]
[label (string-constant install-teachpack...)]
[callback (λ (x y) (install-teachpack))]))
(define (install-teachpack)
(let ([file (get-file (string-constant select-a-teachpack) dlg)])
(when file
(let-values ([(base name dir) (split-path file)])
(let ([dest-file (build-path teachpack-installation-dir name)])
(when (or (not (file-exists? dest-file))
(equal? 1
(message-box/custom
(string-constant drscheme)
(format
(string-constant teachpack-already-installed)
(path->string name))
(string-constant overwrite)
(string-constant cancel)
#f
dlg
'(default=2 caution))))
(make-directory* teachpack-installation-dir)
(when (file-exists? dest-file)
(delete-file dest-file))
(copy-file file dest-file)
(update-user-installed-lb)
(clear-selection pre-installed-lb)
(send user-installed-lb set-string-selection (path->string name))
(update-button)))))))
(define (update-user-installed-lb)
(let ([files
(if (directory-exists? teachpack-installation-dir)
(map path->string (directory-list teachpack-installation-dir))
'())])
(send user-installed-lb set (sort files string<=?))))
(define (update-button)
(send ok-button enable (or (pair? (send user-installed-lb get-selections))
(pair? (send pre-installed-lb get-selections)))))
(define button-panel (new horizontal-panel%
[parent dlg]
[alignment '(right center)]
[stretchable-height #f]))
(define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons button-panel
(λ (b e)
(set! answer (figure-out-answer))
(send dlg show #f))
(λ (b e) (send dlg show #f))
(string-constant ok) (string-constant cancel)))
(define (figure-out-answer)
(cond
[(send pre-installed-lb get-selection)
=>
(λ (i) `(lib ,(send pre-installed-lb get-string i) "teachpack" "htdp"))]
[(send user-installed-lb get-selection)
=>
(λ (i) `(lib ,(send user-installed-lb get-string i) ,user-installed-teachpacks-collection))]
[else (error 'figure-out-answer "no selection!")]))
(send ok-button enable #f)
(update-user-installed-lb)
(send dlg show #t)
answer)
(define (stepper-settings-language %) (define (stepper-settings-language %)
(class* % (stepper-language<%>) (class* % (stepper-language<%>)
(init-field stepper:enable-let-lifting) (init-field stepper:enable-let-lifting)
@ -513,16 +792,16 @@ tracing todo:
(define/override (stepper:enable-let-lifting?) stepper:enable-let-lifting) (define/override (stepper:enable-let-lifting?) stepper:enable-let-lifting)
(super-new))) (super-new)))
;; rewrite-module : syntax -> syntax ;; rewrite-module : settings syntax -> syntax
;; rewrites te module to print out results of non-definitions ;; rewrites te module to print out results of non-definitions
(define (rewrite-module stx) (define (rewrite-module settings stx)
(syntax-case stx (module #%plain-module-begin) (syntax-case stx (module #%plain-module-begin)
[(module name lang (#%plain-module-begin bodies ...)) [(module name lang (#%plain-module-begin bodies ...))
(with-syntax ([(rewritten-bodies ...) (with-syntax ([(rewritten-bodies ...)
(rewrite-bodies (syntax->list (syntax (bodies ...))))]) (rewrite-bodies (syntax->list (syntax (bodies ...))))])
(syntax (module name lang #`(module name lang
(#%plain-module-begin (#%plain-module-begin
rewritten-bodies ...))))] rewritten-bodies ...)))]
[else [else
(raise-syntax-error 'htdp-languages "internal error .1")])) (raise-syntax-error 'htdp-languages "internal error .1")]))

2
collects/lang/htdp-reader.ss
View File

@ -31,6 +31,8 @@
(datum->syntax-object (datum->syntax-object
#f #f
`(module ,(lookup 'modname table) ,spec `(module ,(lookup 'modname table) ,spec
,@(map (λ (x) `(require ,x))
(lookup 'teachpacks table))
,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)]) ,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)])
(get-all-exps source-name port))))))]) (get-all-exps source-name port))))))])
read-syntax))) read-syntax)))

5
collects/profj/tool.ss
View File

@ -150,6 +150,7 @@
(define (java-lang-mixin level name number one-line dyn?) (define (java-lang-mixin level name number one-line dyn?)
(when dyn? (dynamic? #t)) (when dyn? (dynamic? #t))
(class* object% (drscheme:language:language<%>) (class* object% (drscheme:language:language<%>)
(define/public (extra-repl-information settings port) (void))
(define/public (get-reader-module) #f) (define/public (get-reader-module) #f)
(define/public (get-metadata a b) #f) (define/public (get-metadata a b) #f)
(define/public (metadata->settings m) #f) (define/public (metadata->settings m) #f)
@ -446,7 +447,7 @@
;;execute-types: type-record ;;execute-types: type-record
(define execute-types (create-type-record)) (define execute-types (create-type-record))
(define/public (front-end/complete-program port settings teachpack-cache) (define/public (front-end/complete-program port settings)
(set! execute-types (create-type-record)) (set! execute-types (create-type-record))
(mred? #t) (mred? #t)
(let ([name (object-name port)]) (let ([name (object-name port)])
@ -457,7 +458,7 @@
eof eof
(datum->syntax-object #f `(parse-java-full-program ,(parse port name level) (datum->syntax-object #f `(parse-java-full-program ,(parse port name level)
,name) #f))))))) ,name) #f)))))))
(define/public (front-end/interaction port settings teachpack-cache) (define/public (front-end/interaction port settings)
(mred? #t) (mred? #t)
(let ([name (object-name port)] (let ([name (object-name port)]
[executed? #f]) [executed? #f])

8
collects/slideshow/tool.ss
View File

@ -699,15 +699,15 @@ pict snip :
(define slideshow-mixin (define slideshow-mixin
(mixin (drscheme:language:language<%>) () (mixin (drscheme:language:language<%>) ()
(define/override (front-end/complete-program input settings teachpack-cache) (define/override (front-end/complete-program input settings)
(let ([st (super front-end/complete-program input settings teachpack-cache)]) (let ([st (super front-end/complete-program input settings)])
(lambda () (lambda ()
(let ([sv (st)]) (let ([sv (st)])
(cond (cond
[(syntax? sv) (rewrite-syntax sv)] [(syntax? sv) (rewrite-syntax sv)]
[else sv]))))) [else sv])))))
(define/override (front-end/interaction input settings teachpack-cache) (define/override (front-end/interaction input settings)
(let ([st (super front-end/interaction input settings teachpack-cache)]) (let ([st (super front-end/interaction input settings)])
(lambda () (lambda ()
(let ([sv (st)]) (let ([sv (st)])
(cond (cond

6
collects/stepper/debugger-tool.ss
View File

@ -102,6 +102,7 @@
(drscheme:language-configuration:get-settings-preferences-symbol))] (drscheme:language-configuration:get-settings-preferences-symbol))]
[lang (drscheme:language-configuration:language-settings-language lang-settings)] [lang (drscheme:language-configuration:language-settings-language lang-settings)]
[settings (drscheme:language-configuration:language-settings-settings lang-settings)]) [settings (drscheme:language-configuration:language-settings-settings lang-settings)])
(drscheme:eval:expand-program (drscheme:eval:expand-program
(drscheme:language:make-text/pos (drscheme:language:make-text/pos
(get-definitions-text) (get-definitions-text)
@ -119,10 +120,7 @@
(if ((string-length str) . <= . len) (if ((string-length str) . <= . len)
str str
(string-append (substring str 0 (max 0 (- len 3))) (string-append (substring str 0 (max 0 (- len 3)))
"...")))))) "...")))))))
(drscheme:teachpack:install-teachpacks
;; this belongs in model, but I'd need a unit rewrite
(frame:preferences:get 'drscheme:teachpacks)))
void ; kill void ; kill
iter))) iter)))
'program-expander 'program-expander

9
collects/string-constants/english-string-constants.ss
View File

@ -904,7 +904,12 @@ please adhere to these guidelines:
(clear-all-teachpacks-menu-item-label "Clear All Teachpacks") (clear-all-teachpacks-menu-item-label "Clear All Teachpacks")
(drscheme-teachpack-message-title "DrScheme Teachpack") (drscheme-teachpack-message-title "DrScheme Teachpack")
(already-added-teachpack "Already added ~a teachpack") (already-added-teachpack "Already added ~a teachpack")
(teachpack-pre-installed "Preinstalled Teachpacks")
(teachpack-user-installed "User-installed Teachpacks")
(install-teachpack... "Install Teachpack...")
(teachpack-already-installed "A teachpack with the name '~a' has already been installed. Overwrite it?")
;;; Language dialog ;;; Language dialog
(introduction-to-language-dialog (introduction-to-language-dialog
"Please select a language. Students in most introductory courses should use the default language.") "Please select a language. Students in most introductory courses should use the default language.")
@ -920,6 +925,8 @@ please adhere to these guidelines:
(input-syntax "Input Syntax") (input-syntax "Input Syntax")
(dynamic-properties "Dynamic Properties") (dynamic-properties "Dynamic Properties")
(output-syntax "Output Syntax") (output-syntax "Output Syntax")
(teachpacks "Teachpacks") ;; label in the language dialog for the teaching languages
(teachpacks-none "<< none >>") ;; shows up under the previous string, when there are no teachpacks
(no-debugging-or-profiling "No debugging or profiling") (no-debugging-or-profiling "No debugging or profiling")
(debugging "Debugging") (debugging "Debugging")
(debugging-and-profiling "Debugging and profiling") (debugging-and-profiling "Debugging and profiling")

83
collects/tests/drscheme/language-test.ss
View File

@ -66,7 +66,7 @@ the settings above should match r5rs
(test-expression "(sqrt -1)" "0+1i") (test-expression "(sqrt -1)" "0+1i")
(test-expression "class" (regexp "class: bad syntax in: class")) (test-expression "class" (regexp "class: bad syntax in: class"))
(test-expression "shared" "{bug09.gif} reference to undefined identifier: shared") (test-expression "shared" "{bug09.png} reference to undefined identifier: shared")
(test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"")
(test-expression "'(1 . 2)" "(1 . 2)") (test-expression "'(1 . 2)" "(1 . 2)")
@ -77,16 +77,16 @@ the settings above should match r5rs
(test-expression "call/cc" "#<primitive:call-with-current-continuation>") (test-expression "call/cc" "#<primitive:call-with-current-continuation>")
(test-expression "(error 'a \"~a\" 1)" "{bug09.gif} a: 1") (test-expression "(error 'a \"~a\" 1)" "{bug09.png} a: 1")
(test-expression "(error \"a\" \"a\")" "{bug09.gif} a \"a\"") (test-expression "(error \"a\" \"a\")" "{bug09.png} a \"a\"")
(test-expression "(time 1)" (test-expression "(time 1)"
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
(test-expression "true" "{bug09.gif} reference to undefined identifier: true") (test-expression "true" "{bug09.png} reference to undefined identifier: true")
(test-expression "mred^" "{bug09.gif} reference to undefined identifier: mred^") (test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^")
(test-expression "(eq? 'a 'A)" "#f") (test-expression "(eq? 'a 'A)" "#f")
(test-expression "(set! x 1)" "{bug09.gif} set!: cannot set undefined identifier: x") (test-expression "(set! x 1)" "{bug09.png} set!: cannot set undefined identifier: x")
(test-expression "(define qqq 2) (set! qqq 1)" "") (test-expression "(define qqq 2) (set! qqq 1)" "")
(test-expression "(cond [(= 1 2) 3])" "") (test-expression "(cond [(= 1 2) 3])" "")
(test-expression "(cons 1 2)" "(1 . 2)") (test-expression "(cons 1 2)" "(1 . 2)")
@ -119,7 +119,7 @@ the settings above should match r5rs
(test-expression "(exact? 1.5)" "#f") (test-expression "(exact? 1.5)" "#f")
(test-expression "(list 1)" "(1)") (test-expression "(list 1)" "(1)")
(test-expression "(car (list))" "{bug09.gif} car: expects argument of type <pair>; given ()") (test-expression "(car (list))" "{bug09.png} car: expects argument of type <pair>; given ()")
(test-expression "argv" "#0()"))) (test-expression "argv" "#0()")))
@ -161,8 +161,8 @@ the settings above should match r5rs
(test-expression "(sqrt -1)" "0+1i") (test-expression "(sqrt -1)" "0+1i")
(test-expression "class" "{bug09.gif} reference to undefined identifier: class") (test-expression "class" "{bug09.png} reference to undefined identifier: class")
(test-expression "shared" "{bug09.gif} reference to undefined identifier: shared") (test-expression "shared" "{bug09.png} reference to undefined identifier: shared")
(test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"")
(test-expression "'(1 . 2)" "(1 . 2)") (test-expression "'(1 . 2)" "(1 . 2)")
@ -173,16 +173,16 @@ the settings above should match r5rs
(test-expression "call/cc" "#<primitive:call-with-current-continuation>") (test-expression "call/cc" "#<primitive:call-with-current-continuation>")
(test-expression "(error 'a \"~a\" 1)" "{bug09.gif} a: 1") (test-expression "(error 'a \"~a\" 1)" "{bug09.png} a: 1")
(test-expression "(error \"a\" \"a\")" "{bug09.gif} a \"a\"") (test-expression "(error \"a\" \"a\")" "{bug09.png} a \"a\"")
(test-expression "(time 1)" (test-expression "(time 1)"
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
(test-expression "true" "{bug09.gif} reference to undefined identifier: true") (test-expression "true" "{bug09.png} reference to undefined identifier: true")
(test-expression "mred^" "{bug09.gif} reference to undefined identifier: mred^") (test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^")
(test-expression "(eq? 'a 'A)" "#f") (test-expression "(eq? 'a 'A)" "#f")
(test-expression "(set! x 1)" "{bug09.gif} set!: cannot set undefined identifier: x") (test-expression "(set! x 1)" "{bug09.png} set!: cannot set undefined identifier: x")
(test-expression "(define qqq 2) (set! qqq 1)" "") (test-expression "(define qqq 2) (set! qqq 1)" "")
(test-expression "(cond [(= 1 2) 3])" "") (test-expression "(cond [(= 1 2) 3])" "")
(test-expression "(cons 1 2)" "(1 . 2)") (test-expression "(cons 1 2)" "(1 . 2)")
@ -215,7 +215,7 @@ the settings above should match r5rs
(test-expression ",1" "unquote: not in quasiquote in: (unquote 1)") (test-expression ",1" "unquote: not in quasiquote in: (unquote 1)")
(test-expression "(list 1)" "(1)") (test-expression "(list 1)" "(1)")
(test-expression "(car (list))" "{bug09.gif} car: expects argument of type <pair>; given ()") (test-expression "(car (list))" "{bug09.png} car: expects argument of type <pair>; given ()")
(test-expression "argv" "#0()"))) (test-expression "argv" "#0()")))
@ -258,12 +258,12 @@ the settings above should match r5rs
(test-expression "(define x 1)(define x 2)" "") (test-expression "(define x 1)(define x 2)" "")
(test-expression "(define-struct spider (legs))(make-spider 4)" (test-expression "(define-struct spider (legs))(make-spider 4)"
"{bug09.gif} reference to undefined identifier: define-struct") "{bug09.png} reference to undefined identifier: define-struct")
(test-expression "(sqrt -1)" "0+1i") (test-expression "(sqrt -1)" "0+1i")
(test-expression "class" "{bug09.gif} reference to undefined identifier: class") (test-expression "class" "{bug09.png} reference to undefined identifier: class")
(test-expression "shared" "{bug09.gif} reference to undefined identifier: shared") (test-expression "shared" "{bug09.png} reference to undefined identifier: shared")
(test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"") (test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"")
(test-expression "'(1 . 2)" "(1 . 2)") (test-expression "'(1 . 2)" "(1 . 2)")
@ -272,18 +272,18 @@ the settings above should match r5rs
(test-expression "(define (f car) 1)" "") (test-expression "(define (f car) 1)" "")
(test-expression "(define (f empty) 1)" "") (test-expression "(define (f empty) 1)" "")
(test-expression "call/cc" "{bug09.gif} reference to undefined identifier: call/cc") (test-expression "call/cc" "{bug09.png} reference to undefined identifier: call/cc")
(test-expression "(error 'a \"~a\" 1)" "{bug09.gif} reference to undefined identifier: error") (test-expression "(error 'a \"~a\" 1)" "{bug09.png} reference to undefined identifier: error")
(test-expression "(error \"a\" \"a\")" "{bug09.gif} reference to undefined identifier: error") (test-expression "(error \"a\" \"a\")" "{bug09.png} reference to undefined identifier: error")
(test-expression "(time 1)" (test-expression "(time 1)"
"{bug09.gif} reference to undefined identifier: time") "{bug09.png} reference to undefined identifier: time")
(test-expression "true" "{bug09.gif} reference to undefined identifier: true") (test-expression "true" "{bug09.png} reference to undefined identifier: true")
(test-expression "mred^" "{bug09.gif} reference to undefined identifier: mred^") (test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^")
(test-expression "(eq? 'a 'A)" "#t") (test-expression "(eq? 'a 'A)" "#t")
(test-expression "(set! x 1)" "{bug09.gif} set!: cannot set undefined identifier: x") (test-expression "(set! x 1)" "{bug09.png} set!: cannot set undefined identifier: x")
(test-expression "(define qqq 2) (set! qqq 1)" "") (test-expression "(define qqq 2) (set! qqq 1)" "")
(test-expression "(cond ((= 1 2) 3))" "") (test-expression "(cond ((= 1 2) 3))" "")
(test-expression "(cons 1 2)" "(1 . 2)") (test-expression "(cons 1 2)" "(1 . 2)")
@ -317,9 +317,9 @@ the settings above should match r5rs
(test-expression "(list 1)" "(1)") (test-expression "(list 1)" "(1)")
(test-expression "(car (list))" (test-expression "(car (list))"
"{bug09.gif} car: expects argument of type <pair>; given ()") "{bug09.png} car: expects argument of type <pair>; given ()")
(test-expression "argv" "{bug09.gif} reference to undefined identifier: argv"))) (test-expression "argv" "{bug09.png} reference to undefined identifier: argv")))
;; ; ;; ;
; ;
@ -336,7 +336,7 @@ the settings above should match r5rs
(define (beginner) (define (beginner)
(parameterize ([language (list "How to Design Programs" "Beginning Student")]) (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")])
(check-top-of-repl) (check-top-of-repl)
(generic-settings #t) (generic-settings #t)
@ -369,7 +369,8 @@ the settings above should match r5rs
"shared: name is not defined, not an argument, and not a primitive name" "shared: name is not defined, not an argument, and not a primitive name"
"reference to undefined identifier: shared") "reference to undefined identifier: shared")
(test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"") (test-expression "(define (. x y) (* x y))"
"read: illegal use of \".\"")
(test-expression "'(1 . 2)" "read: illegal use of \".\"") (test-expression "'(1 . 2)" "read: illegal use of \".\"")
(test-expression "call/cc" (test-expression "call/cc"
@ -458,7 +459,7 @@ the settings above should match r5rs
(define (beginner/abbrev) (define (beginner/abbrev)
(parameterize ([language (list "How to Design Programs" (parameterize ([language (list "How to Design Programs"
"Beginning Student with List Abbreviations")]) #rx"Beginning Student with List Abbreviations(;|$)")])
(check-top-of-repl) (check-top-of-repl)
(generic-settings #t) (generic-settings #t)
@ -579,7 +580,7 @@ the settings above should match r5rs
(define (intermediate) (define (intermediate)
(parameterize ([language (list "How to Design Programs" "Intermediate Student")]) (parameterize ([language (list "How to Design Programs" #rx"Intermediate Student(;|$)")])
(check-top-of-repl) (check-top-of-repl)
(generic-settings #t) (generic-settings #t)
@ -692,7 +693,7 @@ the settings above should match r5rs
(define (intermediate/lambda) (define (intermediate/lambda)
(parameterize ([language (list "How to Design Programs" (parameterize ([language (list "How to Design Programs"
"Intermediate Student with lambda")]) #rx"Intermediate Student with lambda(;|$)")])
(check-top-of-repl) (check-top-of-repl)
(generic-settings #t) (generic-settings #t)
@ -803,7 +804,7 @@ the settings above should match r5rs
(define (advanced) (define (advanced)
(parameterize ([language (list "How to Design Programs" "Advanced Student")]) (parameterize ([language (list "How to Design Programs" #rx"Advanced Student(;|$)")])
(check-top-of-repl) (check-top-of-repl)
(generic-settings #t) (generic-settings #t)
@ -961,7 +962,7 @@ the settings above should match r5rs
[get-line (lambda (n) (send interactions get-text [get-line (lambda (n) (send interactions get-text
(send interactions paragraph-start-position n) (send interactions paragraph-start-position n)
(send interactions paragraph-end-position n)))] (send interactions paragraph-end-position n)))]
[line0-expect (format "Welcome to DrScheme, version ~a." (version:version))] [line0-expect (format "Welcome to DrScheme, version ~a [3m]." (version:version))]
[line1-expect [line1-expect
(if (string? short-lang) (if (string? short-lang)
(format "Language: ~a." short-lang) (format "Language: ~a." short-lang)
@ -1207,7 +1208,7 @@ the settings above should match r5rs
(when (regexp-match re:out-of-sync got) (when (regexp-match re:out-of-sync got)
(error 'text-expression "got out of sync message")) (error 'text-expression "got out of sync message"))
(unless (check-expectation repl-expected got) (unless (check-expectation repl-expected got)
(printf (make-err-msg repl-expected) 'interactions (language) expression defs-expected got)))))])) (printf (make-err-msg repl-expected) 'interactions (language) expression repl-expected got)))))]))
(define-syntax (go stx) (define-syntax (go stx)
@ -1219,14 +1220,10 @@ the settings above should match r5rs
(printf ">> finished ~a\n" (syntax-object->datum #'arg))))])) (printf ">> finished ~a\n" (syntax-object->datum #'arg))))]))
(define (run-test) (define (run-test)
;; clear teachpack ;(go mred)
(let ([drs (wait-for-drscheme-frame)]) ;(go mzscheme)
(fw:test:menu-select "Language" "Clear All Teachpacks")) ;(go beginner) ;; not really done
;(go beginner/abbrev) ;; not really done
(go mred)
(go mzscheme)
(go beginner)
(go beginner/abbrev)
(go intermediate) (go intermediate)
(go intermediate/lambda) (go intermediate/lambda)
(go advanced) (go advanced)

4
collects/web-server/private/servlet-language.ss
View File

@ -52,8 +52,8 @@
(eval '(define raw-servlet->unit/sig (dynamic-require '(lib "servlet-startup.ss" "web-server") 'raw-servlet->unit/sig))) (eval '(define raw-servlet->unit/sig (dynamic-require '(lib "servlet-startup.ss" "web-server") 'raw-servlet->unit/sig)))
(eval '(define create-module-servlet (dynamic-require '(lib "servlet-startup.ss" "web-server") 'create-module-servlet))))))) (eval '(define create-module-servlet (dynamic-require '(lib "servlet-startup.ss" "web-server") 'create-module-servlet)))))))
(define/override (front-end/complete-program input settings teachpack-cache) (define/override (front-end/complete-program input settings)
(let ([super-thunk (super front-end/complete-program input settings teachpack-cache)]) (let ([super-thunk (super front-end/complete-program input settings)])
(unless program-results (unless program-results
(let loop ([continue-with-results (let loop ([continue-with-results
(lambda (rslts) (lambda (rslts)