diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index b0e17eba38..15be7f74c6 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -329,7 +329,8 @@ (open (prefix drscheme:help-desk: drscheme:help-desk-cm^)) (open (prefix drscheme:eval: drscheme:eval-cm^)) (open (prefix drscheme:modes: drscheme:modes-cm^)) - (open (prefix drscheme:tracing: drscheme:tracing-cm^)))) + (open (prefix drscheme:tracing: drscheme:tracing-cm^)) + (open (prefix drscheme:module-language: drscheme:module-language-cm^)))) (define-signature drscheme:tool^ ((open (prefix drscheme:debug: drscheme:debug^)) @@ -342,4 +343,5 @@ (open (prefix drscheme:help-desk: drscheme:help-desk^)) (open (prefix drscheme:eval: drscheme:eval^)) (open (prefix drscheme:modes: drscheme:modes^)) - (open (prefix drscheme:tracing: drscheme:tracing^)))) + (open (prefix drscheme:tracing: drscheme:tracing^)) + (open (prefix drscheme:module-language: drscheme:module-language^)))) diff --git a/collects/drscheme/private/link.ss b/collects/drscheme/private/link.ss index 6bcc1ac41d..90c35064ed 100644 --- a/collects/drscheme/private/link.ss +++ b/collects/drscheme/private/link.ss @@ -37,7 +37,8 @@ drscheme:help-desk^ drscheme:eval^ drscheme:modes^ - drscheme:tracing^) + drscheme:tracing^ + drscheme:module-language^) (link init@ tools@ modes@ text@ eval@ frame@ rep@ language@ module-overview@ unit@ debug@ multi-file-search@ get-extend@ language-configuration@ font@ module-language@ module-language-tools@ @@ -56,5 +57,6 @@ (prefix drscheme:help-desk: drscheme:help-desk^) (prefix drscheme:eval: drscheme:eval^) (prefix drscheme:modes: drscheme:modes^) - (prefix drscheme:tracing: drscheme:tracing^)) + (prefix drscheme:tracing: drscheme:tracing^) + (prefix drscheme:module-language: drscheme:module-language^)) drscheme-unit@)) diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss index c8c49f9300..316a587e0d 100644 --- a/collects/drscheme/private/tools.ss +++ b/collects/drscheme/private/tools.ss @@ -25,7 +25,8 @@ [prefix drscheme:debug: drscheme:debug^] [prefix drscheme:eval: drscheme:eval^] [prefix drscheme:modes: drscheme:modes^] - [prefix drscheme:tracing: drscheme:tracing^]) + [prefix drscheme:tracing: drscheme:tracing^] + [prefix drscheme:module-language: drscheme:module-language^]) (export drscheme:tools^) ;; An installed-tool is diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index 307edf367c..d3a0121232 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -44,6 +44,21 @@ all of the names in the tools library, for use defining keybindings (provide/doc + (proc-doc/names + drscheme:module-language:add-module-language + (-> any) + () + @{Adds the module language to DrScheme. This is called during DrScheme's startup.}) + + (proc-doc/names + drscheme:module-language:module-language-put-file-mixin + (-> (implementation?/c text:basic<%>) (implementation?/c text:basic<%>)) + (super%) + @{Extends @scheme[super%] by overriding the @method[editor<%> put-file] method + to use a default name from the buffer, if the buffer contains something like + @tt{(module name ...)}.}) + + ; ; ; diff --git a/collects/htdp/bsl/reader.ss b/collects/htdp/bsl/reader.ss index 1b9f896e23..124365ac77 100644 --- a/collects/htdp/bsl/reader.ss +++ b/collects/htdp/bsl/reader.ss @@ -25,6 +25,8 @@ (define ((make-info options) key default use-default) (case key + [(drscheme:toolbar-buttons) + (dynamic-require 'stepper/drscheme-button 'stepper-drscheme-button)] [else (use-default key default)])) (define (make-module-info options) diff --git a/collects/scribblings/tools/module-language.scrbl b/collects/scribblings/tools/module-language.scrbl new file mode 100644 index 0000000000..0b396e042d --- /dev/null +++ b/collects/scribblings/tools/module-language.scrbl @@ -0,0 +1,15 @@ +#lang scribble/doc +@(require "common.ss") +@(tools-title "module-language") + +@definterface[drscheme:language:module-language<%> ()]{ + +The only language that implements this interface is DrScheme's ``Use the language declared in the source'' language, +i.e., the ``Module'' language. + + @defmethod[(get-users-language-name) string]{ + Returns the name of the language that is declared in the source, as a string. + } +} + +@(tools-include "module-language") diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index 3a85850222..3aaf0363da 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -504,5 +504,6 @@ for a list of the capabilities registered by default. @include-section["help-desk.scrbl"] @include-section["eval.scrbl"] @include-section["modes.scrbl"] +@include-section["module-language.scrbl"] @index-section[] diff --git a/collects/stepper/drscheme-button.ss b/collects/stepper/drscheme-button.ss new file mode 100644 index 0000000000..fb5fcb89a7 --- /dev/null +++ b/collects/stepper/drscheme-button.ss @@ -0,0 +1,11 @@ +#lang scheme/base +(require scheme/class string-constants/string-constant + (prefix-in x: "private/mred-extensions.ss")) +(provide stepper-button-callback stepper-drscheme-button) +(define-local-member-name stepper-button-callback) + +(define stepper-drscheme-button + (list (list + (string-constant stepper-button-label) + x:foot-img/horizontal + (λ (drs-frame) (send drs-frame stepper-button-callback))))) \ No newline at end of file diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index ed58805344..d3376aba80 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -12,11 +12,12 @@ "private/shared.ss" lang/stepper-language-interface scheme/pretty - "xml-sig.ss") + "xml-sig.ss" + "drscheme-button.ss") ;; get the stepper-button-callback private-member-name (import drscheme:tool^ xml^ view-controller^) (export drscheme:tool-exports^ stepper-frame^) - + ;; tool magic here: (define (phase1) ;; experiment with extending the language... parameter-like fields for stepper parameters @@ -69,7 +70,9 @@ (drscheme:language-configuration:language-settings-language settings)) (define (stepper-works-for? language-level) + (printf "~s\n" language-level) (or (send language-level stepper:supported?) + (is-a? language-level drscheme:module-language:module-language<%>) (getenv "PLTSTEPPERUNSAFE"))) ;; the stepper's frame: @@ -212,28 +215,31 @@ [stretchable-width #f] [stretchable-height #f])) + ;; called from drscheme-button.ss, installed via the #lang htdp/bsl (& co) reader into drscheme + (define/public (stepper-button-callback) + (if stepper-frame + (send stepper-frame show #t) + (let* ([language-level + (extract-language-level (get-definitions-text))] + [language-level-name (language-level->name language-level)]) + (if (stepper-works-for? language-level) + (set! stepper-frame + (go this + program-expander + (+ 1 (send (get-definitions-text) get-start-position)) + (+ 1 (send (get-definitions-text) get-end-position)))) + (message-box + (string-constant stepper-name) + (format (string-constant stepper-language-level-message) + language-level-name)))))) + (define stepper-button (new switchable-button% [parent stepper-button-parent-panel] [label (string-constant stepper-button-label)] [bitmap x:foot-img/horizontal] [alternate-bitmap x:foot-img/vertical] - [callback (lambda (dont-care) - (if stepper-frame - (send stepper-frame show #t) - (let* ([language-level - (extract-language-level (get-definitions-text))] - [language-level-name (language-level->name language-level)]) - (if (stepper-works-for? language-level) - (set! stepper-frame - (go this - program-expander - (+ 1 (send (get-definitions-text) get-start-position)) - (+ 1 (send (get-definitions-text) get-end-position)))) - (message-box - (string-constant stepper-name) - (format (string-constant stepper-language-level-message) - language-level-name))))))])) + [callback (lambda (dont-care) (stepper-button-callback))])) (register-toolbar-button stepper-button)