diff --git a/collects/drscheme/private/auto-language.ss b/collects/drscheme/private/auto-language.ss index 8a6b05d6d1..409eb916da 100644 --- a/collects/drscheme/private/auto-language.ss +++ b/collects/drscheme/private/auto-language.ss @@ -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)))) diff --git a/collects/drscheme/private/mred-typed.ss b/collects/drscheme/private/mred-typed.ss index 3d1c8cc405..098e43e87a 100644 --- a/collects/drscheme/private/mred-typed.ss +++ b/collects/drscheme/private/mred-typed.ss @@ -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)]