added support for the stepper button appearing automatically in the teaching languages (in the module language with #lang htdp/* prefix)

svn: r18771

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^))))

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

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

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 ...)}.})
+  
+ 
  ;                           
  ;                           
  ;                           

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)

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")

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[]

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

collects/stepper/stepper-tool.ss

@@ -12,7 +12,8 @@
          "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^)
@@ -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,13 +215,8 @@
              [stretchable-width #f]
              [stretchable-height #f]))
       
-      (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)
+      ;; 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
@@ -233,7 +231,15 @@
                   (message-box
                    (string-constant stepper-name)
                    (format (string-constant stepper-language-level-message)
-                                            language-level-name))))))]))
+                           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) (stepper-button-callback))]))
       
       (register-toolbar-button stepper-button)