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

Typed version of the auto-language module.

Browse Source 
svn: r13535
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-12 19:53:58 +00:00
commit d169b427d6
1 changed files with 75 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,62 +1,76 @@
#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)
#lang typed-scheme
(require typed/framework/framework
typed/mred/mred
scheme/class)
(provide pick-new-language looks-like-module?)
(: reader-tag String)
(define reader-tag "#reader")
(: 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) #f)))
(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))))
[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) 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))))