diff --git a/collects/algol60/tool.ss b/collects/algol60/tool.ss index d1e87ed1c0..df87a954e3 100644 --- a/collects/algol60/tool.ss +++ b/collects/algol60/tool.ss @@ -49,7 +49,12 @@ (define lang% (class* object% (drscheme:language:language<%>) - (define/public (get-save-module) #f) + (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)) (define/public (first-opened) (void)) (define/public (config-panel parent) diff --git a/collects/drscheme/private/auto-language.ss b/collects/drscheme/private/auto-language.ss index ce35d82b7e..23b5307dfe 100644 --- a/collects/drscheme/private/auto-language.ss +++ b/collects/drscheme/private/auto-language.ss @@ -4,31 +4,31 @@ (provide pick-new-language) - (define (pick-new-language text module-spec->language module-language) - (with-handlers ((exn:fail:read? (λ (x) #f))) - (let ([found-language? #f]) - (let* ([tp (open-input-text-editor text)] - [l (with-handlers ([exn:fail:contract? (λ (x) eof)]) - ;; catch exceptions that occur with GUI syntax in the beginning of the buffer - (read-line tp))]) - (unless (eof-object? l) - (unless (regexp-match #rx"[;#]" l) ;; no comments on the first line - (when (equal? #\) (send text get-character (- (send text last-position) 1))) - (let ([sp (open-input-string l)]) - (when (regexp-match #rx"[(]" sp) - (let-values ([(mod name module-spec) - (values (parameterize ([read-accept-reader #f]) (read sp)) - (parameterize ([read-accept-reader #f]) (read sp)) - (parameterize ([read-accept-reader #f]) (read sp)))]) - (when (eq? mod 'module) - (let ([matching-language (module-spec->language module-spec)]) - (when matching-language - (send text delete (- (send text last-position) 1) (send text last-position)) - (send text delete - (send text paragraph-start-position 0) - (send text paragraph-start-position 1)) - (set! found-language? matching-language) - (send text set-modified #f))))))))))) + (define reader-tag "#reader") + + (define (pick-new-language text all-languages module-language) + (with-handlers ([exn:fail:read? (λ (x) (values #f #f))]) + (let ([found-language? #f] + [settings #f]) + + (for-each + (λ (lang) + (let ([lang-spec (send lang get-reader-module)]) + (when lang-spec + (let* ([lines (send lang get-metadata-lines)] + [str (send text get-text + 0 + (send text paragraph-end-position (- lines 1)))] + [sp (open-input-string str)]) + (when (regexp-match #rx"#reader" sp) + (let ([spec-in-file (read sp)]) + (when (equal? lang-spec spec-in-file) + (set! found-language? lang) + (set! settings (send lang metadata->settings str)) + (send text delete 0 (send text paragraph-start-position lines))))))))) + all-languages) + + ;; check to see if it looks like the module language. (unless found-language? (when module-language (let* ([tp (open-input-text-editor text 0 'end (lambda (s) s) text #t)] @@ -38,6 +38,7 @@ (pair? r1) (eq? (car r1) 'module)) (set! found-language? module-language) - (send text set-modified #f))))) + (set! settings (send module-language default-settings)))))) - found-language?)))) + (values found-language? + settings))))) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 0211535fb5..d51703e9dd 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -55,7 +55,11 @@ create-executable - get-save-module + get-reader-module + get-metadata + metadata->settings + get-metadata-lines + get-language-position get-language-name get-style-delta @@ -508,9 +512,7 @@ (mixin (module-based-language<%>) (language<%>) (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)) @@ -543,7 +545,12 @@ (get-init-code setting teachpacks) (use-mred-launcher) (use-namespace-require/copy?))) - (super-instantiate ()))) + (define/public (get-reader-module) #f) + (define/public (get-metadata a b c) #f) + (define/public (metadata->settings m) #f) + (define/public (get-metadata-lines) #f) + + (super-new))) ;; create-module-based-language-executable : ;; (is-a?/c area-container<%>) string module-spec module-spec sexp (union boolean? 'ask) boolean? @@ -908,18 +915,17 @@ (map (λ (x) (list #f x)) pre-to-be-embedded-module-specs4)]) - (make-embedding-executable + (create-embedding-executable executable-filename - gui? - #f ;; verbose? - to-be-embedded-module-specs - (list - bootstrap-tmp-filename - program-filename) - #f - (if gui? - (list "-mvqZ") - (list "-mvq")))) + #:mred gui? + #:verbose? #f ;; verbose? + #:modules to-be-embedded-module-specs + #:literal-files (list + bootstrap-tmp-filename + program-filename) + #:cmdline (if gui? + (list "-mvqZ") + (list "-mvq")))) (delete-file init-code-tmp-filename) (delete-file bootstrap-tmp-filename) (void))) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 968fba43d6..ca523a0e64 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -423,20 +423,24 @@ module browser threading seems wrong. (inherit begin-edit-sequence end-edit-sequence delete insert last-position paragraph-start-position get-character) + + (define save-file-metadata #f) (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))))) + (let* ([lang (drscheme:language-configuration:language-settings-language next-settings)] + [settings (drscheme:language-configuration:language-settings-settings next-settings)] + [name-mod (send lang get-reader-module)]) + (when name-mod ;; the reader-module method's result is used a test of whether or not the get-metadata method is used for this language + (let ([metadata (send lang get-metadata (filename->modname filename) settings)]) + (begin-edit-sequence) + (set! save-file-metadata metadata) + (insert metadata 0 0))))) + (define/private (filename->modname filename) + (let-values ([(base name dir) (split-path filename)]) + (string->symbol (regexp-replace #rx"\\.[^.]*$" + (path->string name) + "")))) + (define/augment (after-save-file success?) (when success? (let ([filename (get-filename)]) @@ -446,15 +450,13 @@ 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))) + (when save-file-metadata + (delete 0 (string-length save-file-metadata)) + (set! save-file-metadata #f) + (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)) @@ -466,26 +468,20 @@ module browser threading seems wrong. (λ (lang) (and (is-a? lang drscheme:module-language:module-language<%>) lang)) - (drscheme:language-configuration:get-languages)))] - [matching-language (pick-new-language - this - (λ (module-spec) - (ormap - (λ (lang) - (and (equal? module-spec (send lang get-save-module)) - lang)) - (drscheme:language-configuration:get-languages))) - module-language)]) - (when matching-language - (unless (eq? (drscheme:language-configuration:language-settings-language - next-settings) - matching-language) + (drscheme:language-configuration:get-languages)))]) + (let-values ([(matching-language settings) + (pick-new-language + this + (drscheme:language-configuration:get-languages) + module-language)]) + (when matching-language (set-next-settings (drscheme:language-configuration:make-language-settings matching-language - (send matching-language default-settings)) - #f))))) - + settings) + #f)))) + (set-modified #f)) + (end-edit-sequence) (inner (void) after-load-file success?)) @@ -514,13 +510,14 @@ module browser threading seems wrong. [execute-settings (preferences:get drscheme:language-configuration:settings-preferences-symbol)] [next-settings execute-settings]) + (define/pubment (get-next-settings) next-settings) (define/pubment set-next-settings (opt-lambda (_next-settings [update-prefs? #t]) (when (or (send (drscheme:language-configuration:language-settings-language _next-settings) - get-save-module) + get-reader-module) (send (drscheme:language-configuration:language-settings-language next-settings) - get-save-module)) + get-reader-module)) (set-modified #t)) (set! next-settings _next-settings) (change-mode-to-match) diff --git a/collects/lang/htdp-advanced-reader.ss b/collects/lang/htdp-advanced-reader.ss new file mode 100644 index 0000000000..f70e7bc8ca --- /dev/null +++ b/collects/lang/htdp-advanced-reader.ss @@ -0,0 +1,7 @@ +(module htdp-advanced-reader mzscheme + (require "htdp-reader.ss") + (provide (rename -read-syntax read-syntax) + (rename -read read)) + (define -read-syntax (make-read-syntax '(lib "htdp-advanced.ss" "lang"))) + (define -read (make-read '(lib "htdp-advanced.ss" "lang")))) + diff --git a/collects/lang/htdp-beginner-abbr-reader.ss b/collects/lang/htdp-beginner-abbr-reader.ss new file mode 100644 index 0000000000..ea80a7bddb --- /dev/null +++ b/collects/lang/htdp-beginner-abbr-reader.ss @@ -0,0 +1,7 @@ +(module htdp-beginner-abbr-reader mzscheme + (require "htdp-reader.ss") + (provide (rename -read-syntax read-syntax) + (rename -read read)) + (define -read-syntax (make-read-syntax '(lib "htdp-beginner-abbr.ss" "lang"))) + (define -read (make-read '(lib "htdp-beginner-abbr.ss" "lang")))) + diff --git a/collects/lang/htdp-beginner-reader.ss b/collects/lang/htdp-beginner-reader.ss new file mode 100644 index 0000000000..79c9dd9fd2 --- /dev/null +++ b/collects/lang/htdp-beginner-reader.ss @@ -0,0 +1,7 @@ +(module htdp-beginner-reader mzscheme + (require "htdp-reader.ss") + (provide (rename -read-syntax read-syntax) + (rename -read read)) + (define -read-syntax (make-read-syntax '(lib "htdp-beginner.ss" "lang"))) + (define -read (make-read '(lib "htdp-beginner.ss" "lang")))) + diff --git a/collects/lang/htdp-intermediate-lambda-reader.ss b/collects/lang/htdp-intermediate-lambda-reader.ss new file mode 100644 index 0000000000..cbc47bc039 --- /dev/null +++ b/collects/lang/htdp-intermediate-lambda-reader.ss @@ -0,0 +1,7 @@ +(module htdp-intermediate-lambda-reader mzscheme + (require "htdp-reader.ss") + (provide (rename -read-syntax read-syntax) + (rename -read read)) + (define -read-syntax (make-read-syntax '(lib "htdp-intermediate-lambda.ss" "lang"))) + (define -read (make-read '(lib "htdp-intermediate-lambda.ss" "lang")))) + diff --git a/collects/lang/htdp-intermediate-reader.ss b/collects/lang/htdp-intermediate-reader.ss new file mode 100644 index 0000000000..11d65ac66c --- /dev/null +++ b/collects/lang/htdp-intermediate-reader.ss @@ -0,0 +1,7 @@ +(module htdp-intermediate-reader mzscheme + (require "htdp-reader.ss") + (provide (rename -read-syntax read-syntax) + (rename -read read)) + (define -read-syntax (make-read-syntax '(lib "htdp-intermediate.ss" "lang"))) + (define -read (make-read '(lib "htdp-intermediate.ss" "lang")))) + diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 30962bf69c..40c00ea169 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -19,13 +19,14 @@ tracing todo: (lib "unit.ss") (lib "class.ss") (lib "list.ss") - (lib "file.ss") - (lib "port.ss") + (lib "struct.ss") (lib "tool.ss" "drscheme") (lib "mred.ss" "mred") (lib "bday.ss" "framework" "private") (lib "moddep.ss" "syntax") (lib "cache-image-snip.ss" "mrlib") + (lib "embed.ss" "compiler") + ;; this module is shared between the drscheme's namespace (so loaded here) ;; and the user's namespace in the teaching languages @@ -67,6 +68,7 @@ tracing todo: (define drs-eventspace (current-eventspace)) (define-struct (htdp-lang-settings drscheme:language:simple-settings) (tracing?)) + (define htdp-lang-settings->vector (make-->vector htdp-lang-settings)) (define image-string "") @@ -289,6 +291,7 @@ tracing todo: abbreviate-cons-as-list allow-sharing? manual + reader-module (use-function-output-syntax? #f) (accept-quasiquote? #t) (read-accept-dot #f) @@ -323,40 +326,22 @@ tracing todo: #t (string-constant save-a-mred-distribution))]) (when dist-filename - (let ([wrapper-filename (make-temporary-file "drs-htdp-lang-executable~a.ss")] - [teachpack-specs - (map (lambda (x) `(file ,(path->string x))) - (drscheme:teachpack:teachpack-cache-filenames teachpack-cache))]) - (call-with-output-file wrapper-filename - (lambda (outp) - (write - `(module #%htdp-lang-language mzscheme - (require (prefix #%htdp: ,(get-module))) - (provide ,@(map (lambda (x) `(rename ,(symbol-append '#%htdp: x) ,x)) - (get-export-names (get-module)))) - (require ,@teachpack-specs) - ,@(map (lambda (x) `(provide ,@(get-export-names x))) - teachpack-specs)) - outp) - (newline outp) - (newline outp) - (fprintf outp "(module #%htdp-lang-executable #%htdp-lang-language\n") - (call-with-input-file program-filename - (lambda (inp) - (copy-port inp outp))) - (fprintf outp "\n)\n\n") - (write `(require #%htdp-lang-executable) outp) - (newline outp)) - 'truncate) - (drscheme:language:create-module-based-distribution - wrapper-filename - dist-filename - (get-module) - (get-transformer-module) - (get-init-code setting teachpack-cache) - #t - (use-namespace-require/copy?)) - (delete-file wrapper-filename))))) + (drscheme:language:create-distribution-for-executable + dist-filename + #t + (λ (exe-name) + (create-embedding-executable + exe-name + #:modules `((#f ,program-filename)) + #:literal-expression `(require ,(filename->require-symbol program-filename)) + #:cmdline '("-Zmvq") + #:mred? #t)))))) + + (define/private (filename->require-symbol fn) + (let-values ([(base name dir) (split-path fn)]) + (string->symbol + (path->string + (path-replace-suffix name #""))))) (define/private (get-export-names sexp) (let* ([sym-name ((current-module-name-resolver) sexp #f #f)] @@ -450,9 +435,35 @@ tracing todo: [else (inner (drscheme:language:get-capability-default key) capability-value key)])) - - (define/override (get-save-module) (get-module)) + (inherit-field reader-module) + (define/override (get-reader-module) reader-module) + (define/override (get-metadata modname settings) + (string-append + ";; The first three lines of this file were inserted by DrScheme. They record metadata\n" + ";; about the language level of this file in a form that our tools can easily process.\n" + (format "#reader~s~s\n" + reader-module + `((modname ,modname) + (read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings)) + (htdp-settings ,(htdp-lang-settings->vector settings)))))) + + (inherit default-settings) + (define/override (metadata->settings metadata) + (let* ([table (metadata->table metadata)] ;; extract the table + [ssv (assoc 'htdp-settings table)]) + (if ssv + (apply make-htdp-lang-settings (vector->list (cadr ssv))) + (default-settings)))) + + (define/private (metadata->table metadata) + (let ([p (open-input-string metadata)]) + (regexp-match #rx"\n#reader" p) ;; skip to reader + (read p) ;; skip module + (read p))) + + (define/override (get-metadata-lines) 3) + (super-new))) (define (stepper-settings-language %) @@ -955,6 +966,7 @@ tracing todo: (sharing-printing #t) (abbreviate-cons-as-list #t) (allow-sharing? #t) + (reader-module '(lib "htdp-advanced-reader.ss" "lang")) (stepper:enable-let-lifting #t))) (add-htdp-language @@ -980,6 +992,7 @@ tracing todo: (sharing-printing #f) (abbreviate-cons-as-list #t) (allow-sharing? #f) + (reader-module '(lib "htdp-intermediate-lambda-reader.ss" "lang")) (stepper:enable-let-lifting #t))) (add-htdp-language @@ -997,6 +1010,7 @@ tracing todo: (abbreviate-cons-as-list #t) (allow-sharing? #f) (use-function-output-syntax? #t) + (reader-module '(lib "htdp-intermediate-reader.ss" "lang")) (stepper:enable-let-lifting #t))) (add-htdp-language @@ -1013,6 +1027,7 @@ tracing todo: (sharing-printing #f) (abbreviate-cons-as-list #t) (allow-sharing? #f) + (reader-module '(lib "htdp-beginner-abbr-reader.ss" "lang")) (stepper:enable-let-lifting #t))) (add-htdp-language @@ -1030,6 +1045,7 @@ tracing todo: (abbreviate-cons-as-list #f) (allow-sharing? #f) (accept-quasiquote? #f) + (reader-module '(lib "htdp-beginner-reader.ss" "lang")) (stepper:enable-let-lifting #t))) (drscheme:get/extend:extend-unit-frame frame-tracing-mixin) diff --git a/collects/lang/htdp-reader.ss b/collects/lang/htdp-reader.ss new file mode 100644 index 0000000000..67029ba613 --- /dev/null +++ b/collects/lang/htdp-reader.ss @@ -0,0 +1,34 @@ +(module htdp-reader mzscheme + (require (lib "etc.ss")) + (provide make-read-syntax + make-read) + + (define (make-read spec) + (let ([read + (opt-lambda ([port (current-input-port)]) + (syntax-object->datum ((make-read-syntax spec) 'whatever port)))]) + read)) + + (define (get-all-exps source-name port) + (let loop () + (let ([exp (read-syntax source-name port)]) + (cond + [(eof-object? exp) null] + [else (cons exp (loop))])))) + + (define (lookup key table) + (let ([ans (assoc key table)]) + (unless ans + (error 'special-reader "couldn't find ~s in table ~s" + key table)) + (cadr ans))) + + (define (make-read-syntax spec) + (let ([read-syntax + (opt-lambda ([source-name #f] + [port (current-input-port)]) + (let ([table (read port)]) + `(module ,(lookup 'modname table) ,spec + ,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)]) + (get-all-exps source-name port)))))]) + read-syntax))) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 2bf46acb63..cd5f73f9c5 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -150,7 +150,11 @@ (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 (get-reader-module) #f) + (define/public (get-metadata a b) #f) + (define/public (metadata->settings m) #f) + (define/public (get-metadata-lines) #f) + (define/public (capability-value s) (cond [(eq? s 'drscheme:language-menu-title) (string-constant profj-java)] diff --git a/doc/release-notes/drscheme/HISTORY b/doc/release-notes/drscheme/HISTORY index f144784ebd..5964787948 100644 --- a/doc/release-notes/drscheme/HISTORY +++ b/doc/release-notes/drscheme/HISTORY @@ -31,14 +31,16 @@ . added a new, optional, argument to the initializer of name-message%. - . The teaching languages now add a `module' wrapper to + . The teaching languages now add a #reader wrapper to saved files. Although the content of the file, when viewed in drscheme, does not change, this does mean that drscheme "remembers" which language was used for each file, even if you change languages when editing other files. - . added get-name-module to language<%> interface + . added get-reader-module, get-metadata, + metadata->settings, and get-metadata-lines methods to + the drscheme:language:language<%> interface . the framework preferences library now saves prefs each time any one of them is changed, and works better when