79 lines
3.1 KiB
Scheme
79 lines
3.1 KiB
Scheme
#lang typed-scheme/no-check
|
|
|
|
(require typed/framework/framework
|
|
typed/mred/mred
|
|
scheme/class)
|
|
|
|
(provide pick-new-language looks-like-module?)
|
|
|
|
(: reader-tag String)
|
|
(define reader-tag "#reader")
|
|
|
|
(define-type-alias (Language% Settings)
|
|
(Class () () ([get-reader-module (-> Sexp)]
|
|
[get-metadata-lines (-> Number)]
|
|
[metadata->settings (String -> Settings)])))
|
|
|
|
(: pick-new-language (All (S)
|
|
((Instance Text%)
|
|
(Listof
|
|
(Instance (Language% S)))
|
|
(U #f (Instance (Language% S))) (U #f S) -> (values (U #f (Instance (Language% S))) (U #f S)))))
|
|
(define (pick-new-language text all-languages module-language module-language-settings)
|
|
(with-handlers ([exn:fail:read? (λ (x) (values #f #f))])
|
|
(let: ([found-language? : (U #f (Instance (Language% S))) #f]
|
|
[settings : (U #f S) #f])
|
|
|
|
(for-each
|
|
(λ: ([lang : (Instance (Language% S))])
|
|
(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%) -> Boolean))
|
|
(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)]
|
|
[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%) -> Boolean))
|
|
(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))))
|