suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

changed language interface to cope with new metadata save file format; also make executables work (better) in the teaching languages

Browse Source 
svn: r6019
This commit is contained in:
Robby Findler 2007-04-23 04:10:00 +00:00
parent b4bc493d51
commit e350fae8cc
13 changed files with 224 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/algol60/tool.ss
View File

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

55
collects/drscheme/private/auto-language.ss
View File

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

38
collects/drscheme/private/language.ss
View File

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

75
collects/drscheme/private/unit.ss
View File

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

7
collects/lang/htdp-advanced-reader.ss Normal file
View File

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

7
collects/lang/htdp-beginner-abbr-reader.ss Normal file
View File

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

7
collects/lang/htdp-beginner-reader.ss Normal file
View File

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

7
collects/lang/htdp-intermediate-lambda-reader.ss Normal file
View File

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

7
collects/lang/htdp-intermediate-reader.ss Normal file
View File

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

92
collects/lang/htdp-langs.ss
View File

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

34
collects/lang/htdp-reader.ss Normal file
View File

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

6
collects/profj/tool.ss
View File

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

6
doc/release-notes/drscheme/HISTORY
View File

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