changed teachpacks to be language specific
svn: r6145
This commit is contained in:
Robby Findler
parent
91d0c5e114
commit
41d4b5d28e
|
|
@ -49,10 +49,10 @@
|
|||
|
||||
(define lang%
|
||||
(class* object% (drscheme:language:language<%>)
|
||||
(define/public (extra-repl-information settings port) (void))
|
||||
(define/public (get-reader-module) #f)
|
||||
(define/public (get-metadata a b) #f)
|
||||
(define/public (metadata->settings m) #f)
|
||||
(define/public (metadata->teachpacks m) #f)
|
||||
(define/public (get-metadata-lines) #f)
|
||||
|
||||
(define/public (capability-value s) (drscheme:language:get-capability-default s))
|
||||
|
|
@ -72,8 +72,8 @@
|
|||
(compile-simplified
|
||||
(simplify (parse-a60-port port name) base-importing-stx)
|
||||
base-importing-stx)))))
|
||||
(define/public (front-end/complete-program port settings teachpack-cache) (front-end port settings))
|
||||
(define/public (front-end/interaction 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) (front-end port settings))
|
||||
(define/public (get-style-delta) #f)
|
||||
(define/public (get-language-position)
|
||||
(list (string-constant experimental-languages)
|
||||
|
|
@ -107,7 +107,7 @@
|
|||
(define/public (render-value value settings port) (write value port))
|
||||
(define/public (render-value/format value settings port width) (write value port))
|
||||
(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
|
||||
parent src-file #f #f
|
||||
(string-constant save-a-mzscheme-stand-alone-executable))])
|
||||
|
|
|
|||
|
|
@ -21,7 +21,6 @@
|
|||
drscheme:draw-arrow^
|
||||
drscheme:help-desk^
|
||||
drscheme:language^
|
||||
drscheme:teachpack^
|
||||
drscheme:multi-file-search^
|
||||
drscheme:module-overview^
|
||||
drscheme:font^
|
||||
|
|
@ -104,11 +103,7 @@
|
|||
get-default-language-settings
|
||||
settings-preferences-symbol
|
||||
|
||||
add-built-in-languages
|
||||
|
||||
;; for the language dialog
|
||||
add-new-teachpack
|
||||
clear-all-teachpacks))
|
||||
add-built-in-languages))
|
||||
|
||||
(define-signature drscheme:tools^
|
||||
((struct successful-tool (spec bitmap name url))
|
||||
|
|
@ -142,7 +137,8 @@
|
|||
open-drscheme-window
|
||||
find-symbol
|
||||
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^
|
||||
(<%>
|
||||
|
|
@ -178,6 +174,8 @@
|
|||
current-value-port
|
||||
get-drs-bindings-keymap
|
||||
error-delta
|
||||
get-welcome-delta
|
||||
get-dark-green-delta
|
||||
text%
|
||||
text<%>
|
||||
context<%>))
|
||||
|
|
@ -245,18 +243,6 @@
|
|||
simple-module-based-language->module-based-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^
|
||||
(multi-file-search))
|
||||
|
||||
|
|
@ -279,5 +265,4 @@
|
|||
(open (prefix drscheme:language: drscheme:language^))
|
||||
(open (prefix drscheme:help-desk: drscheme:help-desk^))
|
||||
(open (prefix drscheme:eval: drscheme:eval^))
|
||||
(open (prefix drscheme:teachpack: drscheme:teachpack^))
|
||||
(open (prefix drscheme:modes: drscheme:modes^)))))
|
||||
|
|
|
|||
|
|
@ -19,14 +19,13 @@
|
|||
(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
|
||||
[prefix drscheme:rep: drscheme:rep^]
|
||||
[prefix drscheme:init: drscheme:init^]
|
||||
[prefix drscheme:language: drscheme:language^]
|
||||
[prefix drscheme:teachpack: drscheme:teachpack^])
|
||||
[prefix drscheme:language: drscheme:language^])
|
||||
(export drscheme:eval^)
|
||||
|
||||
(define (traverse-program/multiple language-settings
|
||||
init
|
||||
kill-termination)
|
||||
(let-values ([(eventspace custodian teachpack-cache)
|
||||
(let-values ([(eventspace custodian)
|
||||
(build-user-eventspace/custodian
|
||||
language-settings
|
||||
init
|
||||
|
|
@ -59,8 +58,8 @@
|
|||
(λ ()
|
||||
(let ([read-thnk
|
||||
(if complete-program?
|
||||
(send language front-end/complete-program port settings teachpack-cache)
|
||||
(send language front-end/interaction port settings teachpack-cache))])
|
||||
(send language front-end/complete-program port settings)
|
||||
(send language front-end/interaction port settings))])
|
||||
(let loop ()
|
||||
(let ([in (read-thnk)])
|
||||
(cond
|
||||
|
|
@ -102,9 +101,8 @@
|
|||
#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)]
|
||||
[user-teachpack-cache (preferences:get 'drscheme:teachpacks)]
|
||||
[eventspace (parameterize ([current-custodian user-custodian])
|
||||
(make-eventspace))]
|
||||
[language (drscheme:language-configuration:language-settings-language
|
||||
|
|
@ -138,14 +136,13 @@
|
|||
(run-in-eventspace
|
||||
(λ ()
|
||||
(set! eventspace-main-thread (current-thread))
|
||||
(drscheme:teachpack:install-teachpacks user-teachpack-cache)
|
||||
(init)
|
||||
(break-enabled #t)))
|
||||
(thread
|
||||
(λ ()
|
||||
(thread-wait eventspace-main-thread)
|
||||
(kill-termination)))
|
||||
(values eventspace user-custodian user-teachpack-cache)))
|
||||
(values eventspace user-custodian)))
|
||||
|
||||
;; get-snip-classes : -> (listof snipclass)
|
||||
;; returns a list of the snip classes in the current eventspace
|
||||
|
|
|
|||
|
|
@ -12,8 +12,7 @@
|
|||
|
||||
|
||||
(import [prefix drscheme:frame: drscheme:frame^]
|
||||
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
|
||||
[prefix drscheme:teachpack: drscheme:teachpack^])
|
||||
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^])
|
||||
(export (rename drscheme:help-desk^
|
||||
[-add-help-desk-font-prefs add-help-desk-font-prefs]))
|
||||
|
||||
|
|
@ -41,13 +40,7 @@
|
|||
(cons name (cdr pr))))
|
||||
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! "Teachpack filenames" get-teachpack-filenames)
|
||||
|
||||
(define drscheme-help-desk-mixin
|
||||
(mixin (help-desk-frame<%> frame:standard-menus<%>) ()
|
||||
|
|
|
|||
|
|
@ -24,7 +24,6 @@
|
|||
(define-unit language-configuration@
|
||||
(import [prefix drscheme:unit: drscheme:unit^]
|
||||
[prefix drscheme:rep: drscheme:rep^]
|
||||
[prefix drscheme:teachpack: drscheme:teachpack^]
|
||||
[prefix drscheme:init: drscheme:init^]
|
||||
[prefix drscheme:language: drscheme:language^]
|
||||
[prefix drscheme:app: drscheme:app^]
|
||||
|
|
@ -1068,72 +1067,8 @@
|
|||
(+ 10 ;; upper bound on some platform specific space I don't know how to get.
|
||||
(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
|
||||
(define (add-expand-to-front-end %)
|
||||
(class %
|
||||
(define/override (front-end/complete-program input settings teachpack-cache)
|
||||
(wrap-front-end (super front-end/complete-program input settings teachpack-cache)))
|
||||
(define/override (front-end/interaction input settings teachpack-cache)
|
||||
(wrap-front-end (super front-end/interaction input settings teachpack-cache)))
|
||||
(define/override (front-end/complete-program input settings)
|
||||
(wrap-front-end (super front-end/complete-program input settings)))
|
||||
(define/override (front-end/interaction input settings)
|
||||
(wrap-front-end (super front-end/interaction input settings)))
|
||||
(define/private (wrap-front-end thnk)
|
||||
(λ ()
|
||||
(let ([res (thnk)])
|
||||
|
|
@ -1383,7 +1318,7 @@
|
|||
(define/override (get-one-line-summary) one-line-summary)
|
||||
(define/override (use-namespace-require/copy?) #t)
|
||||
(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
|
||||
(drscheme:language:put-executable
|
||||
parent
|
||||
|
|
@ -1399,7 +1334,7 @@
|
|||
executable-fn
|
||||
(get-module)
|
||||
(get-transformer-module)
|
||||
(get-init-code setting teachpacks)
|
||||
(get-init-code setting)
|
||||
mred-launcher?
|
||||
(use-namespace-require/copy?)))))
|
||||
(super-new))))]
|
||||
|
|
@ -1485,10 +1420,10 @@
|
|||
(not-a-language-message)
|
||||
(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)
|
||||
(λ () eof))
|
||||
(define/override (front-end/complete-program input settings teachpack-cache)
|
||||
(define/override (front-end/complete-program input settings)
|
||||
(not-a-language-message)
|
||||
(λ () eof))
|
||||
|
||||
|
|
|
|||
|
|
@ -22,7 +22,6 @@
|
|||
(lib "bundle-dist.ss" "compiler"))
|
||||
|
||||
(import [prefix drscheme:debug: drscheme:debug^]
|
||||
[prefix drscheme:teachpack: drscheme:teachpack^]
|
||||
[prefix drscheme:tools: drscheme:tools^]
|
||||
[prefix drscheme:help-desk: drscheme:help-desk^])
|
||||
(export drscheme:language^)
|
||||
|
|
@ -47,6 +46,8 @@
|
|||
front-end/interaction
|
||||
config-panel
|
||||
on-execute
|
||||
extra-repl-information
|
||||
|
||||
first-opened
|
||||
render-value/format
|
||||
render-value
|
||||
|
|
@ -196,8 +197,8 @@
|
|||
|
||||
(define/public (on-execute setting run-in-user-thread)
|
||||
(initialize-simple-module-based-language setting run-in-user-thread))
|
||||
(define/public (get-init-code setting teachpacks)
|
||||
(simple-module-based-language-get-init-code setting teachpacks))
|
||||
(define/public (get-init-code setting)
|
||||
(simple-module-based-language-get-init-code setting))
|
||||
|
||||
(define/public (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))
|
||||
(read-case-sensitive (simple-settings-case-sensitive setting)))))
|
||||
|
||||
;; simple-module-based-language-get-init-code : setting teachpack-cache -> sexp[module]
|
||||
(define (simple-module-based-language-get-init-code setting teachpack-cache)
|
||||
;; simple-module-based-language-get-init-code : setting -> sexp[module]
|
||||
(define (simple-module-based-language-get-init-code setting)
|
||||
`(module mod-name mzscheme
|
||||
(require (lib "pconvert.ss")
|
||||
(lib "pretty.ss"))
|
||||
|
|
@ -483,7 +484,6 @@
|
|||
`(void))
|
||||
|
||||
(define (init-code)
|
||||
,(drscheme:teachpack:launcher-init-code teachpack-cache)
|
||||
(current-inspector (make-inspector))
|
||||
(error-value->string-handler executable-error-value->string-handler)
|
||||
(read-case-sensitive ,(simple-settings-case-sensitive setting)))))
|
||||
|
|
@ -533,18 +533,19 @@
|
|||
(get-module)
|
||||
(get-transformer-module)
|
||||
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)))
|
||||
(define/public (front-end/interaction port settings teachpack-cache)
|
||||
(define/public (front-end/interaction port settings)
|
||||
(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
|
||||
program-filename
|
||||
(get-module)
|
||||
(get-transformer-module)
|
||||
(get-init-code setting teachpacks)
|
||||
(get-init-code setting)
|
||||
(use-mred-launcher)
|
||||
(use-namespace-require/copy?)))
|
||||
(define/public (extra-repl-information _1 _2) (void))
|
||||
(define/public (get-reader-module) #f)
|
||||
(define/public (get-metadata a b c) #f)
|
||||
(define/public (metadata->settings m) #f)
|
||||
|
|
@ -905,15 +906,11 @@
|
|||
(cons `(file ,(path->string init-code-tmp-filename))
|
||||
pre-to-be-embedded-module-specs1)]
|
||||
[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)))
|
||||
pre-to-be-embedded-module-specs3)]
|
||||
pre-to-be-embedded-module-specs2)]
|
||||
[to-be-embedded-module-specs
|
||||
(map (λ (x) (list #f x))
|
||||
pre-to-be-embedded-module-specs4)])
|
||||
pre-to-be-embedded-module-specs3)])
|
||||
|
||||
(create-embedding-executable
|
||||
executable-filename
|
||||
|
|
|
|||
|
|
@ -6,8 +6,7 @@
|
|||
"multi-file-search.ss"
|
||||
"debug.ss"
|
||||
"module-language.ss"
|
||||
"teachpack.ss"
|
||||
"tools.ss"
|
||||
"tools.ss"
|
||||
(lib "unit.ss")
|
||||
"language.ss"
|
||||
"language-configuration.ss"
|
||||
|
|
@ -35,9 +34,8 @@
|
|||
drscheme:language^
|
||||
drscheme:help-desk^
|
||||
drscheme:eval^
|
||||
drscheme:teachpack^
|
||||
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@
|
||||
language-configuration@ font@ module-language@ help-desk@ app@ main@))
|
||||
|
||||
|
|
@ -52,7 +50,6 @@
|
|||
(prefix drscheme:language: drscheme:language^)
|
||||
(prefix drscheme:help-desk: drscheme:help-desk^)
|
||||
(prefix drscheme:eval: drscheme:eval^)
|
||||
(prefix drscheme:teachpack: drscheme:teachpack^)
|
||||
(prefix drscheme:modes: drscheme:modes^))
|
||||
drscheme-unit@)))
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@
|
|||
[prefix drscheme:get/extend: drscheme:get/extend^]
|
||||
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
|
||||
[prefix drscheme:language: drscheme:language^]
|
||||
[prefix drscheme:teachpack: drscheme:teachpack^]
|
||||
[prefix drscheme:module-language: drscheme:module-language^]
|
||||
[prefix drscheme:tools: drscheme:tools^]
|
||||
[prefix drscheme:debug: drscheme:debug^]
|
||||
|
|
@ -173,15 +172,6 @@
|
|||
(or (eq? x #t)
|
||||
(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?)
|
||||
|
||||
|
||||
|
|
@ -278,7 +268,11 @@
|
|||
(drscheme:language:register-capability 'drscheme:language-menu-title
|
||||
(flat-contract string?)
|
||||
(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
|
||||
(let ([drscheme-current-create-new-window
|
||||
(λ (filename)
|
||||
|
|
|
|||
|
|
@ -116,7 +116,7 @@
|
|||
(define/override (get-style-delta) module-language-style-delta)
|
||||
|
||||
(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))]
|
||||
[filename (get-filename port)]
|
||||
[module-name #f]
|
||||
|
|
@ -162,7 +162,7 @@
|
|||
[else eof]))))
|
||||
|
||||
;; 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
|
||||
parent
|
||||
program-filename
|
||||
|
|
|
|||
|
|
@ -69,7 +69,6 @@ TODO
|
|||
(prefix drscheme:unit: drscheme:unit^)
|
||||
(prefix drscheme:text: drscheme:text^)
|
||||
(prefix drscheme:help-desk: drscheme:help-desk^)
|
||||
(prefix drscheme:teachpack: drscheme:teachpack^)
|
||||
(prefix drscheme:debug: drscheme:debug^)
|
||||
[prefix drscheme:eval: drscheme:eval^])
|
||||
(export (rename drscheme:rep^
|
||||
|
|
@ -91,8 +90,6 @@ TODO
|
|||
get-user-eventspace
|
||||
get-user-thread
|
||||
get-user-namespace
|
||||
get-user-teachpack-cache
|
||||
set-user-teachpack-cache
|
||||
|
||||
get-definitions-text
|
||||
|
||||
|
|
@ -446,6 +443,8 @@ TODO
|
|||
(send* warning-style-delta
|
||||
(set-delta-foreground "BLACK")
|
||||
(set-delta-background "YELLOW"))
|
||||
(define (get-welcome-delta) welcome-delta)
|
||||
(define (get-dark-green-delta) dark-green-delta)
|
||||
|
||||
;; is-default-settings? : language-settings -> boolean
|
||||
;; determines if the settings in `language-settings'
|
||||
|
|
@ -605,6 +604,7 @@ TODO
|
|||
get-out-port
|
||||
get-snip-position
|
||||
get-start-position
|
||||
get-styles-fixed
|
||||
get-style-list
|
||||
get-text
|
||||
get-top-level-window
|
||||
|
|
@ -635,6 +635,7 @@ TODO
|
|||
set-insertion-point
|
||||
set-position
|
||||
set-styles-sticky
|
||||
set-styles-fixed
|
||||
set-unread-start-point
|
||||
split-snip
|
||||
thaw-colorer)
|
||||
|
|
@ -904,7 +905,6 @@ TODO
|
|||
(thread-running? (get-user-thread)))))
|
||||
|
||||
(field (user-language-settings #f)
|
||||
(user-teachpack-cache (preferences:get 'drscheme:teachpacks))
|
||||
(user-custodian-parent #f)
|
||||
(memory-killed-thread #f)
|
||||
(user-custodian #f)
|
||||
|
|
@ -921,8 +921,6 @@ TODO
|
|||
|
||||
(define/public (get-user-language-settings) user-language-settings)
|
||||
(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-thread) user-eventspace-main-thread)
|
||||
(define/public (get-user-namespace) (weak-box-value user-namespace-box))
|
||||
|
|
@ -1060,8 +1058,8 @@ TODO
|
|||
[dummy-value (box #f)]
|
||||
[get-sexp/syntax/eof
|
||||
(if complete-program?
|
||||
(send lang front-end/complete-program port settings user-teachpack-cache)
|
||||
(send lang front-end/interaction port settings user-teachpack-cache))])
|
||||
(send lang front-end/complete-program port settings)
|
||||
(send lang front-end/interaction port settings))])
|
||||
|
||||
; Evaluate the user's expression. We're careful to turn on
|
||||
; 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")
|
||||
(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])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
|
|
@ -1476,17 +1467,14 @@ TODO
|
|||
dark-green-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! already-warned? #f)
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
@ -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
|
||||
(-> (is-a?/c keymap%))
|
||||
()
|
||||
|
|
@ -1345,46 +1358,7 @@
|
|||
"they default to \\scmc{\\#t} \\Symbol{keyword+index} and \\Symbol{exact},"
|
||||
"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
|
||||
(or/c (is-a?/c dialog%) (is-a?/c frame%))
|
||||
path?
|
||||
drscheme:teachpack:teachpack-cache?
|
||||
. -> .
|
||||
void?))
|
||||
(default-settings (-> any/c))
|
||||
|
|
@ -1422,12 +1395,10 @@
|
|||
(order-manuals ((listof bytes?) . -> . (values (listof bytes?) boolean?)))
|
||||
(front-end/complete-program (input-port?
|
||||
any/c
|
||||
drscheme:teachpack:teachpack-cache?
|
||||
. -> .
|
||||
(-> any/c)))
|
||||
(front-end/interaction (input-port?
|
||||
any/c
|
||||
drscheme:teachpack:teachpack-cache?
|
||||
. -> .
|
||||
(-> any/c)))
|
||||
(get-language-name (-> string?))
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@
|
|||
[prefix drscheme:init: drscheme:init^]
|
||||
[prefix drscheme:debug: drscheme:debug^]
|
||||
[prefix drscheme:eval: drscheme:eval^]
|
||||
[prefix drscheme:teachpack: drscheme:teachpack^]
|
||||
[prefix drscheme:modes: drscheme:modes^])
|
||||
(export drscheme:tools^)
|
||||
|
||||
|
|
|
|||
|
|
@ -52,7 +52,6 @@ module browser threading seems wrong.
|
|||
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
|
||||
[prefix drscheme:language: drscheme:language^]
|
||||
[prefix drscheme:get/extend: drscheme:get/extend^]
|
||||
[prefix drscheme:teachpack: drscheme:teachpack^]
|
||||
[prefix drscheme:module-overview: drscheme:module-overview^]
|
||||
[prefix drscheme:tools: drscheme:tools^]
|
||||
[prefix drscheme:eval: drscheme:eval^]
|
||||
|
|
@ -92,6 +91,15 @@ module browser threading seems wrong.
|
|||
get-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
|
||||
(let ([old (keymap:add-to-right-button-menu)])
|
||||
(λ (menu text event)
|
||||
|
|
@ -269,8 +277,7 @@ module browser threading seems wrong.
|
|||
create-executable
|
||||
(drscheme:language-configuration:language-settings-settings settings)
|
||||
frame
|
||||
program-filename
|
||||
(send (send frame get-interactions-text) get-user-teachpack-cache))))])))
|
||||
program-filename)))])))
|
||||
|
||||
(define make-execute-bitmap
|
||||
(bitmap-label-maker (string-constant execute-button-label)
|
||||
|
|
@ -563,6 +570,8 @@ module browser threading seems wrong.
|
|||
(send execute-lang marshall-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)
|
||||
(set! needs-execution-state (string-constant needs-execute-teachpack-changed)))
|
||||
(define/pubment (just-executed)
|
||||
|
|
@ -2308,28 +2317,6 @@ module browser threading seems wrong.
|
|||
(define/public (get-definitions-text) definitions-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)
|
||||
(get-area-container))
|
||||
|
||||
|
|
@ -2757,11 +2744,54 @@ module browser threading seems wrong.
|
|||
(when 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)
|
||||
(let* ([mb (get-menu-bar)]
|
||||
[language-menu-on-demand
|
||||
(λ (menu-item)
|
||||
(update-teachpack-menu))]
|
||||
[language-menu-on-demand (λ (menu-item) (update-teachpack-menu))]
|
||||
[_ (set! language-menu (make-object (get-menu%)
|
||||
(string-constant language-menu-name)
|
||||
mb
|
||||
|
|
@ -2786,27 +2816,6 @@ module browser threading seems wrong.
|
|||
language-menu
|
||||
(λ (_1 _2) (choose-language-callback))
|
||||
#\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
|
||||
(make-object menu:can-restore-menu-item%
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
#|
|
||||
|
||||
tracing todo:
|
||||
- shorten lines
|
||||
|
||||
;; we don't use the built in debugging, use our own
|
||||
;; version here that has no bug icon and only
|
||||
;; annotates code that comes from editors.
|
||||
|
|
@ -16,6 +13,7 @@ tracing todo:
|
|||
(prefix tr: (lib "stacktrace.ss" "trace"))
|
||||
(lib "pretty.ss")
|
||||
(prefix pc: (lib "pconvert.ss"))
|
||||
(lib "file.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "class.ss")
|
||||
(lib "list.ss")
|
||||
|
|
@ -27,7 +25,8 @@ tracing todo:
|
|||
(lib "cache-image-snip.ss" "mrlib")
|
||||
(lib "embed.ss" "compiler")
|
||||
(lib "wxme.ss" "wxme")
|
||||
|
||||
(lib "struct.ss")
|
||||
(lib "dirs.ss" "setup")
|
||||
|
||||
;; this module is shared between the drscheme's namespace (so loaded here)
|
||||
;; and the user's namespace in the teaching languages
|
||||
|
|
@ -49,6 +48,9 @@ tracing todo:
|
|||
|
||||
(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@
|
||||
(unit
|
||||
(import drscheme:tool^)
|
||||
|
|
@ -68,7 +70,9 @@ tracing todo:
|
|||
|
||||
(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 image-string "<image>")
|
||||
|
|
@ -100,21 +104,24 @@ tracing todo:
|
|||
(get-sharing-printing)
|
||||
#t
|
||||
'none
|
||||
#f))
|
||||
#f
|
||||
'()))
|
||||
|
||||
(define/override (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)
|
||||
(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)
|
||||
(if (and (pair? x)
|
||||
(pair? (cdr x))
|
||||
(null? (cddr x))
|
||||
(boolean? (cadr x)))
|
||||
(if (and (list? x)
|
||||
(= (length x) 3)
|
||||
(boolean? (list-ref x 1))
|
||||
(list-of-require-specs? (list-ref x 2)))
|
||||
(let ([drs-settings (super unmarshall-settings (first x))])
|
||||
(make-htdp-lang-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-insert-newlines drs-settings)
|
||||
(drscheme:language:simple-settings-annotations drs-settings)
|
||||
(cadr x)))
|
||||
(cadr x)
|
||||
(caddr x)))
|
||||
(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?
|
||||
get-accept-quasiquote? get-read-accept-dot)
|
||||
(define/override (config-panel parent)
|
||||
|
|
@ -200,6 +215,16 @@ tracing todo:
|
|||
(label (string-constant output-syntax))
|
||||
(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%
|
||||
(string-constant case-sensitive-label)
|
||||
input-panel
|
||||
|
|
@ -228,7 +253,9 @@ tracing todo:
|
|||
[tracing (new check-box%
|
||||
(parent output-panel)
|
||||
(label sc-tracing)
|
||||
(callback void))])
|
||||
(callback void))]
|
||||
|
||||
[tps '()])
|
||||
|
||||
(when allow-sharing-config?
|
||||
(set! show-sharing
|
||||
|
|
@ -261,7 +288,8 @@ tracing todo:
|
|||
(and allow-sharing-config? (send show-sharing get-value))
|
||||
(send insert-newlines get-value)
|
||||
'none
|
||||
(send tracing get-value))]
|
||||
(send tracing get-value)
|
||||
tps)]
|
||||
[(settings)
|
||||
(send case-sensitive set-value (drscheme:language:simple-settings-case-sensitive settings))
|
||||
(send output-style set-selection
|
||||
|
|
@ -284,6 +312,17 @@ tracing todo:
|
|||
(send show-sharing set-value (drscheme:language:simple-settings-show-sharing settings)))
|
||||
(send insert-newlines set-value
|
||||
(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))])))
|
||||
|
||||
(define simple-htdp-language%
|
||||
|
|
@ -314,12 +353,49 @@ tracing todo:
|
|||
(class %
|
||||
(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)
|
||||
(values (list (get-manual) #"teachpack" #"drscheme" #"help") #f))
|
||||
|
||||
(inherit get-module get-transformer-module get-init-code
|
||||
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
|
||||
(drscheme:language:put-executable
|
||||
parent program-filename
|
||||
|
|
@ -429,7 +505,7 @@ tracing todo:
|
|||
|
||||
(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]
|
||||
;; state : 'init => 'require => 'done
|
||||
[reader (get-reader)])
|
||||
|
|
@ -444,16 +520,23 @@ tracing todo:
|
|||
(if (eof-object? result)
|
||||
null
|
||||
(cons result (loop)))))]
|
||||
[language-module (get-module)]
|
||||
[require-specs
|
||||
(drscheme:teachpack:teachpack-cache-require-specs teachpacks)])
|
||||
(rewrite-module
|
||||
[language-module (get-module)])
|
||||
(for-each
|
||||
(λ (tp)
|
||||
(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
|
||||
(datum->syntax-object
|
||||
#f
|
||||
`(,#'module #%htdp ,language-module
|
||||
(,#'require ,@require-specs)
|
||||
,@body-exps)))))]
|
||||
,@(map (λ (x) `(require ,x))
|
||||
(htdp-lang-settings-teachpacks settings))
|
||||
,@body-exps)))))]
|
||||
[(require)
|
||||
(set! state 'done)
|
||||
(syntax
|
||||
|
|
@ -468,13 +551,73 @@ tracing todo:
|
|||
(set! done-already? #t)
|
||||
(current-namespace (module->namespace '#%htdp)))))))]
|
||||
[(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)
|
||||
(case key
|
||||
[(drscheme:teachpack-menu-items) htdp-teachpack-callbacks]
|
||||
[(drscheme:special:insert-lambda) #f]
|
||||
[else (inner (drscheme:language:get-capability-default key)
|
||||
capability-value
|
||||
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)
|
||||
(define/override (get-reader-module) reader-module)
|
||||
|
|
@ -486,6 +629,7 @@ tracing todo:
|
|||
reader-module
|
||||
`((modname ,modname)
|
||||
(read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings))
|
||||
(teachpacks ,(htdp-lang-settings-teachpacks settings))
|
||||
(htdp-settings ,(htdp-lang-settings->vector settings))))))
|
||||
|
||||
(inherit default-settings)
|
||||
|
|
@ -493,7 +637,11 @@ tracing todo:
|
|||
(let* ([table (metadata->table metadata)] ;; extract the table
|
||||
[ssv (assoc 'htdp-settings table)])
|
||||
(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))))
|
||||
|
||||
(define/private (metadata->table metadata)
|
||||
|
|
@ -506,6 +654,137 @@ tracing todo:
|
|||
|
||||
(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 %)
|
||||
(class* % (stepper-language<%>)
|
||||
(init-field stepper:enable-let-lifting)
|
||||
|
|
@ -513,16 +792,16 @@ tracing todo:
|
|||
(define/override (stepper:enable-let-lifting?) stepper:enable-let-lifting)
|
||||
(super-new)))
|
||||
|
||||
;; rewrite-module : syntax -> syntax
|
||||
;; rewrite-module : settings syntax -> syntax
|
||||
;; 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)
|
||||
[(module name lang (#%plain-module-begin bodies ...))
|
||||
(with-syntax ([(rewritten-bodies ...)
|
||||
(rewrite-bodies (syntax->list (syntax (bodies ...))))])
|
||||
(syntax (module name lang
|
||||
(#%plain-module-begin
|
||||
rewritten-bodies ...))))]
|
||||
#`(module name lang
|
||||
(#%plain-module-begin
|
||||
rewritten-bodies ...)))]
|
||||
[else
|
||||
(raise-syntax-error 'htdp-languages "internal error .1")]))
|
||||
|
||||
|
|
|
|||
|
|
@ -31,6 +31,8 @@
|
|||
(datum->syntax-object
|
||||
#f
|
||||
`(module ,(lookup 'modname table) ,spec
|
||||
,@(map (λ (x) `(require ,x))
|
||||
(lookup 'teachpacks table))
|
||||
,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)])
|
||||
(get-all-exps source-name port))))))])
|
||||
read-syntax)))
|
||||
|
|
|
|||
|
|
@ -150,6 +150,7 @@
|
|||
(define (java-lang-mixin level name number one-line dyn?)
|
||||
(when dyn? (dynamic? #t))
|
||||
(class* object% (drscheme:language:language<%>)
|
||||
(define/public (extra-repl-information settings port) (void))
|
||||
(define/public (get-reader-module) #f)
|
||||
(define/public (get-metadata a b) #f)
|
||||
(define/public (metadata->settings m) #f)
|
||||
|
|
@ -446,7 +447,7 @@
|
|||
;;execute-types: 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))
|
||||
(mred? #t)
|
||||
(let ([name (object-name port)])
|
||||
|
|
@ -457,7 +458,7 @@
|
|||
eof
|
||||
(datum->syntax-object #f `(parse-java-full-program ,(parse port name level)
|
||||
,name) #f)))))))
|
||||
(define/public (front-end/interaction port settings teachpack-cache)
|
||||
(define/public (front-end/interaction port settings)
|
||||
(mred? #t)
|
||||
(let ([name (object-name port)]
|
||||
[executed? #f])
|
||||
|
|
|
|||
|
|
@ -699,15 +699,15 @@ pict snip :
|
|||
|
||||
(define slideshow-mixin
|
||||
(mixin (drscheme:language:language<%>) ()
|
||||
(define/override (front-end/complete-program input settings teachpack-cache)
|
||||
(let ([st (super 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)])
|
||||
(lambda ()
|
||||
(let ([sv (st)])
|
||||
(cond
|
||||
[(syntax? sv) (rewrite-syntax sv)]
|
||||
[else sv])))))
|
||||
(define/override (front-end/interaction input settings teachpack-cache)
|
||||
(let ([st (super front-end/interaction input settings teachpack-cache)])
|
||||
(define/override (front-end/interaction input settings)
|
||||
(let ([st (super front-end/interaction input settings)])
|
||||
(lambda ()
|
||||
(let ([sv (st)])
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -102,6 +102,7 @@
|
|||
(drscheme:language-configuration:get-settings-preferences-symbol))]
|
||||
[lang (drscheme:language-configuration:language-settings-language lang-settings)]
|
||||
[settings (drscheme:language-configuration:language-settings-settings lang-settings)])
|
||||
|
||||
(drscheme:eval:expand-program
|
||||
(drscheme:language:make-text/pos
|
||||
(get-definitions-text)
|
||||
|
|
@ -119,10 +120,7 @@
|
|||
(if ((string-length str) . <= . len)
|
||||
str
|
||||
(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
|
||||
iter)))
|
||||
'program-expander
|
||||
|
|
|
|||
|
|
@ -904,7 +904,12 @@ please adhere to these guidelines:
|
|||
(clear-all-teachpacks-menu-item-label "Clear All Teachpacks")
|
||||
(drscheme-teachpack-message-title "DrScheme 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
|
||||
(introduction-to-language-dialog
|
||||
"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")
|
||||
(dynamic-properties "Dynamic Properties")
|
||||
(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")
|
||||
(debugging "Debugging")
|
||||
(debugging-and-profiling "Debugging and profiling")
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ the settings above should match r5rs
|
|||
(test-expression "(sqrt -1)" "0+1i")
|
||||
|
||||
(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 "'(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 "(error 'a \"~a\" 1)" "{bug09.gif} a: 1")
|
||||
(test-expression "(error \"a\" \"a\")" "{bug09.gif} a \"a\"")
|
||||
(test-expression "(error 'a \"~a\" 1)" "{bug09.png} a: 1")
|
||||
(test-expression "(error \"a\" \"a\")" "{bug09.png} a \"a\"")
|
||||
|
||||
(test-expression "(time 1)"
|
||||
#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 "mred^" "{bug09.gif} reference to undefined identifier: mred^")
|
||||
(test-expression "true" "{bug09.png} reference to undefined identifier: true")
|
||||
(test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^")
|
||||
(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 "(cond [(= 1 2) 3])" "")
|
||||
(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 "(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()")))
|
||||
|
||||
|
|
@ -161,8 +161,8 @@ the settings above should match r5rs
|
|||
|
||||
(test-expression "(sqrt -1)" "0+1i")
|
||||
|
||||
(test-expression "class" "{bug09.gif} reference to undefined identifier: class")
|
||||
(test-expression "shared" "{bug09.gif} reference to undefined identifier: shared")
|
||||
(test-expression "class" "{bug09.png} reference to undefined identifier: class")
|
||||
(test-expression "shared" "{bug09.png} reference to undefined identifier: shared")
|
||||
|
||||
(test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"")
|
||||
(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 "(error 'a \"~a\" 1)" "{bug09.gif} a: 1")
|
||||
(test-expression "(error \"a\" \"a\")" "{bug09.gif} a \"a\"")
|
||||
(test-expression "(error 'a \"~a\" 1)" "{bug09.png} a: 1")
|
||||
(test-expression "(error \"a\" \"a\")" "{bug09.png} a \"a\"")
|
||||
|
||||
(test-expression "(time 1)"
|
||||
#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 "mred^" "{bug09.gif} reference to undefined identifier: mred^")
|
||||
(test-expression "true" "{bug09.png} reference to undefined identifier: true")
|
||||
(test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^")
|
||||
(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 "(cond [(= 1 2) 3])" "")
|
||||
(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 "(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()")))
|
||||
|
||||
|
|
@ -258,12 +258,12 @@ the settings above should match r5rs
|
|||
(test-expression "(define x 1)(define x 2)" "")
|
||||
|
||||
(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 "class" "{bug09.gif} reference to undefined identifier: class")
|
||||
(test-expression "shared" "{bug09.gif} reference to undefined identifier: shared")
|
||||
(test-expression "class" "{bug09.png} reference to undefined identifier: class")
|
||||
(test-expression "shared" "{bug09.png} reference to undefined identifier: shared")
|
||||
|
||||
(test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"")
|
||||
(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 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\")" "{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.png} reference to undefined identifier: error")
|
||||
|
||||
(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 "mred^" "{bug09.gif} reference to undefined identifier: mred^")
|
||||
(test-expression "true" "{bug09.png} reference to undefined identifier: true")
|
||||
(test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^")
|
||||
(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 "(cond ((= 1 2) 3))" "")
|
||||
(test-expression "(cons 1 2)" "(1 . 2)")
|
||||
|
|
@ -317,9 +317,9 @@ the settings above should match r5rs
|
|||
|
||||
(test-expression "(list 1)" "(1)")
|
||||
(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)
|
||||
(parameterize ([language (list "How to Design Programs" "Beginning Student")])
|
||||
(parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")])
|
||||
(check-top-of-repl)
|
||||
|
||||
(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"
|
||||
"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 "call/cc"
|
||||
|
|
@ -458,7 +459,7 @@ the settings above should match r5rs
|
|||
|
||||
(define (beginner/abbrev)
|
||||
(parameterize ([language (list "How to Design Programs"
|
||||
"Beginning Student with List Abbreviations")])
|
||||
#rx"Beginning Student with List Abbreviations(;|$)")])
|
||||
(check-top-of-repl)
|
||||
|
||||
(generic-settings #t)
|
||||
|
|
@ -579,7 +580,7 @@ the settings above should match r5rs
|
|||
|
||||
|
||||
(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)
|
||||
|
||||
(generic-settings #t)
|
||||
|
|
@ -692,7 +693,7 @@ the settings above should match r5rs
|
|||
|
||||
(define (intermediate/lambda)
|
||||
(parameterize ([language (list "How to Design Programs"
|
||||
"Intermediate Student with lambda")])
|
||||
#rx"Intermediate Student with lambda(;|$)")])
|
||||
(check-top-of-repl)
|
||||
|
||||
(generic-settings #t)
|
||||
|
|
@ -803,7 +804,7 @@ the settings above should match r5rs
|
|||
|
||||
|
||||
(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)
|
||||
|
||||
(generic-settings #t)
|
||||
|
|
@ -961,7 +962,7 @@ the settings above should match r5rs
|
|||
[get-line (lambda (n) (send interactions get-text
|
||||
(send interactions paragraph-start-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
|
||||
(if (string? 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)
|
||||
(error 'text-expression "got out of sync message"))
|
||||
(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)
|
||||
|
|
@ -1219,14 +1220,10 @@ the settings above should match r5rs
|
|||
(printf ">> finished ~a\n" (syntax-object->datum #'arg))))]))
|
||||
|
||||
(define (run-test)
|
||||
;; clear teachpack
|
||||
(let ([drs (wait-for-drscheme-frame)])
|
||||
(fw:test:menu-select "Language" "Clear All Teachpacks"))
|
||||
|
||||
(go mred)
|
||||
(go mzscheme)
|
||||
(go beginner)
|
||||
(go beginner/abbrev)
|
||||
;(go mred)
|
||||
;(go mzscheme)
|
||||
;(go beginner) ;; not really done
|
||||
;(go beginner/abbrev) ;; not really done
|
||||
(go intermediate)
|
||||
(go intermediate/lambda)
|
||||
(go advanced)
|
||||
|
|
|
|||
|
|
@ -52,8 +52,8 @@
|
|||
(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)))))))
|
||||
|
||||
(define/override (front-end/complete-program input settings teachpack-cache)
|
||||
(let ([super-thunk (super 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)])
|
||||
(unless program-results
|
||||
(let loop ([continue-with-results
|
||||
(lambda (rslts)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user