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

Changes for auto-language.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2008-10-03 15:00:56 -04:00
parent b51e02b81a
commit 7e32802fe0
2 changed files with 97 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,62 +1,77 @@
#lang mzscheme
(require mred
mzlib/class)
(provide pick-new-language looks-like-module?)
(define reader-tag "#reader")
(define (pick-new-language text all-languages module-language module-language-settings)
(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 while-unlocked
(λ ()
(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
(when (looks-like-module? text)
(set! found-language? module-language)
(set! settings module-language-settings))))
(values found-language?
settings))))
(define (looks-like-module? text)
(or (looks-like-new-module-style? text)
(looks-like-old-module-style? text)))
(define (looks-like-old-module-style? text)
(with-handlers ((exn:fail:read? (λ (x) #f)))
(let* ([tp (open-input-text-editor text 0 'end (lambda (s) s) text #t)]
[r1 (parameterize ([read-accept-reader #f]) (read tp))]
[r2 (parameterize ([read-accept-reader #f]) (read tp))])
(and (eof-object? r2)
(pair? r1)
(eq? (car r1) 'module)))))
(define (looks-like-new-module-style? text)
(let* ([tp (open-input-text-editor text 0 'end (lambda (s) s) text #t)]
[l1 (with-handlers ([exn:fail? (lambda (exn) eof)])
;; If tp contains a snip, read-line fails.
(read-line tp))])
(and (string? l1)
(regexp-match #rx"#lang .*$" l1))))
#lang typed-scheme
(require "mred-typed.ss"
scheme/class)
(provide pick-new-language looks-like-module?)
(: reader-tag String)
(define reader-tag "#reader")
(define-type-alias Exn Any)
(: pick-new-language ((Instance Text%)
(Listof
(Instance (Class () () ([get-reader-module (-> Any)]
[get-metadata-lines (-> Number)]
[metadata->settings (String -> Any)]))))
Any Any -> (values Any Any)))
(define (pick-new-language text all-languages module-language module-language-settings)
(with-handlers ([exn:fail:read? (λ (x) (values #f #f))])
(let: ([found-language? : Any #f]
[settings : Any #f])
(for-each
(λ: ([lang : (Instance (Class () () ([get-reader-module (-> Any)]
[get-metadata-lines (-> Number)]
[metadata->settings (String -> Any)])))])
(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 while-unlocked
(λ ()
(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
(when (looks-like-module? text)
(set! found-language? module-language)
(set! settings module-language-settings))))
(values found-language?
settings))))
(: looks-like-module? ((Instance Text%) -> Any))
(define (looks-like-module? text)
(or (looks-like-new-module-style? text)
(looks-like-old-module-style? text)))
(: looks-like-old-module-style? ((Instance Text%) -> Boolean))
(define (looks-like-old-module-style? text)
(with-handlers ((exn:fail:read? (λ: ([x : Exn]) #f)))
(let* ([tp (open-input-text-editor text 0 'end (lambda: ([s : Any]) s) text #t)]
[r1 (parameterize ([read-accept-reader #f]) (read tp))]
[r2 (parameterize ([read-accept-reader #f]) (read tp))])
(and (eof-object? r2)
(pair? r1)
(eq? (car r1) 'module)))))
(: looks-like-new-module-style? ((Instance Text%) -> Any))
(define (looks-like-new-module-style? text)
(let* ([tp (open-input-text-editor text 0 'end (lambda: ([s : Any]) s) text #t)]
[l1 (with-handlers ([exn:fail? (lambda: ([exn : Exn]) eof)])
;; If tp contains a snip, read-line fails.
(read-line tp))])
(and (string? l1)
(regexp-match #rx"#lang .*$" l1))))

21
collects/drscheme/private/mred-typed.ss
View File

@ -64,8 +64,26 @@
[paragraph-start-position (Number -> Number)]
[get-start-position (-> Number)]
[get-end-position (-> Number)]
[get-text (Integer (U Integer 'eof) -> String)]
[insert (String Number Number -> Void)])))
(define-type-alias Text% (Class ()
()
([begin-edit-sequence (-> Void)]
[end-edit-sequence (-> Void)]
[lock (Boolean -> Void)]
[last-position (-> Number)]
[last-paragraph (-> Number)]
[delete (Number Number -> Void)]
[auto-wrap (Any -> Void)]
[paragraph-end-position (Number -> Integer)]
[paragraph-start-position (Number -> Integer)]
[get-start-position (-> Integer)]
[get-end-position (-> Integer)]
[while-unlocked ((-> Any) -> Any)]
[get-text (Integer (U Integer 'eof) -> String)]
[insert (String Number Number -> Void)])))
(require/typed mred/mred
[the-font-list (Instance Font-List%)]
[dialog% Dialog%]
@ -78,7 +96,8 @@
[editor-canvas% Editor-Canvas%]
[bitmap-dc% Bitmap-DC%]
[bitmap% Bitmap%]
[color% Color%])
[color% Color%]
[open-input-text-editor ((Instance Text%) Integer (U 'end Integer) (Any -> Any) Any Any -> Input-Port)])
(require/typed framework/framework
[preferences:set-default (Symbol Any Any -> Void)]