added 'module' wrapper for saved files in the teaching languages (and support for that in the drscheme:language:language<%> interface)

svn: r5602

collects/algol60/tool.ss

@@ -49,6 +49,7 @@
 
       (define lang%
         (class* object% (drscheme:language:language<%>)
+          (define/public (get-save-module) #f)
           (define/public (capability-value s) (drscheme:language:get-capability-default s))
           (define/public (first-opened) (void))
           (define/public (config-panel parent)

collects/drscheme/private/language-configuration.ss

@@ -1379,10 +1379,9 @@
         (let* ([extras-mixin
                 (λ (mred-launcher? one-line-summary)
                   (λ (%)
-                    (class %
+                    (class* % (drscheme:language:language<%>)
                       (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)
                         (let ([executable-fn
@@ -1403,7 +1402,7 @@
                              (get-init-code setting teachpacks)
                              mred-launcher?
                              (use-namespace-require/copy?)))))
-                      (super-instantiate ()))))]
+                      (super-new))))]
                [make-simple
                 (λ (module id position numbers mred-launcher? one-line-summary extra-mixin)
                   (let ([%

collects/drscheme/private/language.ss

@@ -55,6 +55,7 @@
       
       create-executable
       
+      get-save-module
       get-language-position
       get-language-name
       get-style-delta
@@ -508,6 +509,8 @@
 	  (inherit get-module get-transformer-module use-namespace-require/copy?
                    get-init-code use-mred-launcher get-reader)
           
+          (define/public (get-save-module) #f)
+          
           (define/pubment (capability-value s) 
             (inner (get-capability-default s) capability-value s))
           

collects/drscheme/private/module-language.ss

@@ -45,7 +45,7 @@
       ;; module-mixin : (implements drscheme:language:language<%>)
       ;;             -> (implements drscheme:language:language<%>)
       (define (module-mixin %)
-        (class* % (module-language<%>)
+        (class* % (drscheme:language:language<%> module-language<%>)
           (define/override (use-namespace-require/copy?) #t)
           (field [iteration-number 0])
           

collects/drscheme/private/unit.ss

@@ -420,6 +420,23 @@ module browser threading seems wrong.
                                   (set-current-mode mode))
                                 (loop (cdr modes))))]))))
             
+            (inherit begin-edit-sequence end-edit-sequence
+                     delete insert last-position paragraph-start-position
+                     get-character)
+            (define/augment (on-save-file filename fmt)
+              (inner (void) on-save-file filename fmt)
+              (let ([name-mod (send (drscheme:language-configuration:language-settings-language next-settings)
+                                    get-save-module)])
+                (when name-mod
+                  (begin-edit-sequence)
+                  (let-values ([(base name dir) (split-path filename)])
+                    (insert (format "(module ~s ~s\n" 
+                                    (string->symbol (regexp-replace #rx"\\.[^.]*$"
+                                                                    (path->string name)
+                                                                    ""))
+                                    name-mod)
+                            0 0))
+                  (insert ")" (last-position) (last-position)))))
             (define/augment (after-save-file success?)
               (when success?
                 (let ([filename (get-filename)])
@@ -429,7 +446,55 @@ module browser threading seems wrong.
                     (with-handlers ([exn:fail:filesystem? void])
                       (let-values ([(creator type) (file-creator-and-type filename)])
                         (file-creator-and-type filename #"DrSc" type))))))
+              (let ([name-mod (send (drscheme:language-configuration:language-settings-language next-settings)
+                                    get-save-module)])
+                (when name-mod
+                  (delete (- (last-position) 1) (last-position))
+                  (delete (paragraph-start-position 0)
+                          (paragraph-start-position 1))
+                  (end-edit-sequence)
+                  (set-modified #f)))
               (inner (void) after-save-file success?))
+            (define/augment (on-load-file filename format)
+              (inner (void) on-load-file filename format)
+              (begin-edit-sequence))
+            (define/augment (after-load-file success?)
+              (when success?
+                (let* ([tp (open-input-text-editor this)]
+                       [l (read-line tp)])
+                  (unless (eof-object? l)
+                    (unless (regexp-match #rx"[;#]" l) ;; no comments on the first line
+                      (when (equal? #\) (get-character (- (last-position) 1)))
+                        (let ([sp (open-input-string l)])
+                          (when (regexp-match #rx"[(]" sp)
+                            (let/ec k
+                              (let-values ([(mod name module-spec)
+                                            (with-handlers ([exn:fail:read? (λ (x) (k (void)))])
+                                              (values (read sp)
+                                                      (read sp)
+                                                      (read sp)))])
+                                (when (eq? mod 'module)
+                                  (let ([matching-language
+                                         (ormap 
+                                          (λ (lang)
+                                            (and (equal? module-spec (send lang get-save-module))
+                                                 lang))
+                                          (drscheme:language-configuration:get-languages))])
+                                    (delete (- (last-position) 1) (last-position))
+                                    (delete (paragraph-start-position 0)
+                                            (paragraph-start-position 1))
+                                    (when matching-language
+                                      (unless (eq? (drscheme:language-configuration:language-settings-language 
+                                                    next-settings)
+                                                   matching-language)
+                                        (set-next-settings
+                                         (drscheme:language-configuration:make-language-settings 
+                                          matching-language
+                                          (send matching-language default-settings)))))
+                                    (set-modified #f))))))))))))
+
+              (end-edit-sequence)
+              (inner (void) after-load-file success?))
                               
             (inherit is-modified? run-after-edit-sequence)
             (define/override (set-modified mod?)
@@ -458,6 +523,11 @@ module browser threading seems wrong.
             
             (define/pubment (get-next-settings) next-settings)
             (define/pubment (set-next-settings _next-settings)
+              (when (or (send (drscheme:language-configuration:language-settings-language _next-settings)
+                              get-save-module)
+                        (send (drscheme:language-configuration:language-settings-language next-settings)
+                              get-save-module))
+                (set-modified #t))
               (set! next-settings _next-settings)
               (change-mode-to-match)
 	      (after-set-next-settings _next-settings))

collects/lang/htdp-langs.ss

@@ -451,6 +451,8 @@ tracing todo:
                            capability-value
                            key)]))
           
+          (define/override (get-save-module) (get-module))
+        
           (super-new)))
       
       (define (stepper-settings-language %)

collects/macro-debugger/tool.ss

@@ -101,7 +101,9 @@
         (class %
           (inherit get-top-level-window)
           (define/augment (after-set-next-settings s)
-	    (send (get-top-level-window) check-language)
+            (let ([tlw (get-top-level-window)])
+              (when tlw
+                (send tlw check-language)))
 	    (inner (void) after-set-next-settings s))
           (super-new)))
 

collects/mztake/debug-tool.ss

@@ -436,7 +436,9 @@
                         (loop start-pos (rest marks)))))))))
 
 	  (define/augment (after-set-next-settings s)
-	    (send (get-top-level-window) check-current-language-for-debugger)
+            (let ([tlw (get-top-level-window)])
+              (when tlw
+                (send tlw check-current-language-for-debugger)))
 	    (inner (void) after-set-next-settings s))))
       
       (define (debug-interactions-text-mixin super%)

collects/profj/tool.ss

@@ -150,7 +150,7 @@
       (define (java-lang-mixin level name number one-line dyn?)
         (when dyn? (dynamic? #t))
         (class* object% (drscheme:language:language<%>)
-
+          (define/public (get-save-module) #f)
           (define/public (capability-value s) 
             (cond
               [(eq? s 'drscheme:language-menu-title) (string-constant profj-java)]

collects/stepper/stepper-tool.ss

@@ -635,7 +635,9 @@
             (inner (void) on-delete x y))
 
           (define/augment (after-set-next-settings s)
-            (send (get-top-level-window) check-current-language-for-stepper)
+            (let ([tlw (get-top-level-window)])
+              (when tlw
+                (send tlw check-current-language-for-stepper)))
             (inner (void) after-set-next-settings s))
 
           (super-new)))