misc improvements around read-language (uses and docs)

- make a logger for drracket-related #lang problems
- change read-language's docs to indicate that it can return #f
- adjust a bunch of calls to read-language for the case that it returns #f
  with the goal of making that be the same as a get-info function that
  always returns the given default
- mention `read-language` in the guide section entitled
 "Source-Handling Configuration"

pkgs/drracket-pkgs/drracket/drracket/private/auto-language.rkt

@@ -60,9 +60,10 @@
   (or (looks-like-new-module-style? text)
       (looks-like-old-module-style? text)
       (with-handlers ((exn:fail? (λ (x) #f)))
-        (procedure?
+        (begin
          (read-language (open-input-text-editor text 0 'end (λ (x) x) text #f) 
-                        (λ () #f)))))) 
+                        (λ () #f))
+         #t))))
 
 (: looks-like-old-module-style? ((Instance Text%) -> Boolean))
 (define (looks-like-old-module-style? text)

pkgs/drracket-pkgs/drracket/drracket/private/language-configuration.rkt

@@ -1483,7 +1483,8 @@
       (define prt (open-input-text-editor definitions-text))
       (port-count-lines! prt)
       (define l (with-handlers ((exn:fail? (λ (x) #f)))
-                  (read-language prt)))
+                  (read-language prt)
+                  #t))
       (cond
         [l
          (define-values (line col pos) (port-next-location prt))

pkgs/drracket-pkgs/drracket/drracket/private/module-language-tools.rkt

@@ -104,6 +104,8 @@
           (when (send defs get-in-module-language?)
             (send defs move-to-new-language))))))
   
+  (define-logger drracket-language)
+  
   (define definitions-text-mixin
     (mixin (text:basic<%> 
             drracket:unit:definitions-text<%>
@@ -168,94 +170,98 @@
              (clear-things-out)])))
       
       (define/public (move-to-new-language)
-        (let* ([port (open-input-text-editor this)]
+        (define port (open-input-text-editor this))
-               ;; info-result : 
+        
-               ;;  (or/c #f   [#lang without a known language]
+        (define (fallback)
-               ;;        (vector <get-info-proc>) 
+          ;; fall back to whatever #lang racket does if
-               ;;                [no #lang line, so we use the '#lang racket' info proc]
+          ;; we don't have a #lang line present in the file
-               ;;        <get-info-proc>) [the get-info proc for the program in the definitions]
+          (log-drracket-language-debug "falling back to using #lang racket's read-language for ~a"
-               [info-result 
+                                       (or (send this get-filename) "<<unsaved file>>"))
-                (with-handlers ([exn:fail? 
+          (vector (read-language (open-input-string "#lang racket"))))
-                                 (λ (x)
+        
-                                   (log-debug
+        ;; info-result : 
-                                    (format 
+        ;;  (or/c #f   [#lang without a known language]
-                                     "DrRacket: error duing call to read-language for ~a:\n  ~a"
+        ;;        (vector <get-info-proc>) 
-                                     (or (send this get-filename) "<<unsaved file>>")
+        ;;                [no #lang line, so we use the '#lang racket' info proc]
-                                     (regexp-replace* #rx"\n(.)" (exn-message x) "\n\\1  ")))
+        ;;        <get-info-proc>) [the get-info proc for the program in the definitions]
-                                   #f)])
+        (define info-result 
-                  (read-language 
+          (with-handlers ([exn:fail? 
-                   port
+                           (λ (x)
-                   (lambda () 
+                             (log-drracket-language-debug
-                     ;; fall back to whatever #lang racket does if
+                              (format
-                     ;; we don't have a #lang line present in the file
+                               "DrRacket: error duing call to read-language for ~a:\n  ~a"
-                     (vector (read-language (open-input-string "#lang racket"))))))])
+                               (or (send this get-filename) "<<unsaved file>>")
+                               (regexp-replace* #rx"\n(.)" (exn-message x) "\n\\1  ")))
+                             #f)])
+            (or (read-language port fallback)
+                (fallback))))
+        
+        ; sometimes I get eof here, but I don't know why and can't seem to 
+        ;; make it happen outside of DrRacket
+        (when (eof-object? info-result)
+          (eprintf "file ~s produces eof from read-language\n"
+                   (send this get-filename))
+          (eprintf "  port-next-location ~s\n"
+                   (call-with-values (λ () (port-next-location port)) list))
+          (eprintf "  str ~s\n"
+                   (let ([s (send this get-text)])
+                     (substring s 0 (min 100 (string-length s)))))
+          (set! info-result #f))
+        (define-values (line col pos) (port-next-location port))
+        (unless (equal? (get-text 0 pos) hash-lang-language)
+          (set! hash-lang-language (get-text 0 pos))
+          (set! hash-lang-last-location pos)
+          (clear-things-out)
+          (define info-proc 
+            (if (vector? info-result)
+                (vector-ref info-result 0)
+                info-result))
+          (define (ctc-on-info-proc-result ctc res)
+            (contract ctc 
+                      res
+                      (if (vector? info-result)
+                          'hash-lang-racket
+                          (get-lang-name pos))
+                      'drracket/private/module-language-tools))
           
-          ; sometimes I get eof here, but I don't know why and can't seem to 
+          (define lang-wants-big-defs/ints-labels?
-          ;; make it happen outside of DrRacket
+            (and info-proc (info-proc 'drracket:show-big-defs/ints-labels #f)))
-          (when (eof-object? info-result)
+          (set-lang-wants-big-defs/ints-labels? lang-wants-big-defs/ints-labels?)
-            (eprintf "file ~s produces eof from read-language\n"
+          (send (send (get-tab) get-ints) set-lang-wants-big-defs/ints-labels?
-                     (send this get-filename))
+                lang-wants-big-defs/ints-labels?)
-            (eprintf "  port-next-location ~s\n"
+          
-                     (call-with-values (λ () (port-next-location port)) list))
+          (set! extra-default-filters
-            (eprintf "  str ~s\n"
+                (if info-result
-                     (let ([s (send this get-text)])
+                    (or (ctc-on-info-proc-result
-                       (substring s 0 (min 100 (string-length s)))))
+                         (or/c #f (listof (list/c string? string?)))
-            (set! info-result #f))
+                         (info-proc 'drracket:default-filters #f))
-          (let-values ([(line col pos) (port-next-location port)])
+                        '())
-            (unless (equal? (get-text 0 pos) hash-lang-language)
+                    '()))
-              (set! hash-lang-language (get-text 0 pos))
+          
-              (set! hash-lang-last-location pos)
+          (set! default-extension
-              (clear-things-out)
+                (if info-result
-              (define info-proc 
+                    (or (ctc-on-info-proc-result
-                (if (vector? info-result)
+                         (or/c #f (and/c string? (not/c #rx"[.]")))
-                    (vector-ref info-result 0)
+                         (info-proc 'drracket:default-extension #f))
-                    info-result))
+                        "")
-              (define (ctc-on-info-proc-result ctc res)
+                    ""))
-                (contract ctc 
+          
-                          res
+          (when info-result
-                          (if (vector? info-result)
+            (register-new-buttons
-                              'hash-lang-racket
+             (ctc-on-info-proc-result 
-                              (get-lang-name pos))
+              (or/c #f (listof (or/c (list/c string?
-                          'drracket/private/module-language-tools))
+                                             (is-a?/c bitmap%)
-              
+                                             (-> (is-a?/c drracket:unit:frame<%>) any))
-              (define lang-wants-big-defs/ints-labels?
+                                     (list/c string?
-                (and info-proc (info-proc 'drracket:show-big-defs/ints-labels #f)))
+                                             (is-a?/c bitmap%)
-              (set-lang-wants-big-defs/ints-labels? lang-wants-big-defs/ints-labels?)
+                                             (-> (is-a?/c drracket:unit:frame<%>) any)
-              (send (send (get-tab) get-ints) set-lang-wants-big-defs/ints-labels?
+                                             (or/c real? #f)))))
-                    lang-wants-big-defs/ints-labels?)
+              (or (info-proc 'drracket:toolbar-buttons #f)
-              
+                  (info-proc 'drscheme:toolbar-buttons #f)))
-              (set! extra-default-filters
+             (ctc-on-info-proc-result 
-               (if info-result
+              (or/c #f (listof symbol?))
-                   (or (ctc-on-info-proc-result
+              (or (info-proc 'drracket:opt-out-toolbar-buttons '())
-                        (or/c #f (listof (list/c string? string?)))
+                  (info-proc 'drscheme:opt-out-toolbar-buttons '())))))))
-                        (info-proc 'drracket:default-filters #f))
-                       '())
-                   '()))
-              
-              (set! default-extension
-               (if info-result
-                   (or (ctc-on-info-proc-result
-                        (or/c #f (and/c string? (not/c #rx"[.]")))
-                        (info-proc 'drracket:default-extension #f))
-                       "")
-                   ""))
-              
-              (when info-result
-                (register-new-buttons
-                 (ctc-on-info-proc-result 
-                  (or/c #f (listof (or/c (list/c string?
-                                                 (is-a?/c bitmap%)
-                                                 (-> (is-a?/c drracket:unit:frame<%>) any))
-                                         (list/c string?
-                                                 (is-a?/c bitmap%)
-                                                 (-> (is-a?/c drracket:unit:frame<%>) any)
-                                                 (or/c real? #f)))))
-                  (or (info-proc 'drracket:toolbar-buttons #f)
-                      (info-proc 'drscheme:toolbar-buttons #f)))
-                 (ctc-on-info-proc-result 
-                  (or/c #f (listof symbol?))
-                  (or (info-proc 'drracket:opt-out-toolbar-buttons '())
-                      (info-proc 'drscheme:opt-out-toolbar-buttons '())))))))))
       
       
       (define/private (register-new-buttons buttons opt-out-ids)

pkgs/drracket-pkgs/drracket/scribblings/tools/tools.scrbl

@@ -244,7 +244,10 @@ as the @racket[_key] argument to the @racket[_get-info] function to do so:
           @item{@language-info-ref[color-lexer]}]
 
 If the call to @racket[read-language] raises an error, DrRacket logs the
-error via @racket[log-debug].
+error at the @racket[_debug] level to a logger with the name 
+@racket['drracket-language] (see 
+@secref["logging" #:doc '(lib "scribblings/reference/reference.scrbl")] for more
+about how to follow specific loggers).
 
 @language-info-def[color-lexer]{
   When a language's @racket[_get-info] procedure responds to @racket['color-lexer], it

pkgs/racket-pkgs/racket-doc/scribblings/guide/hash-languages.scrbl

@@ -312,7 +312,8 @@ racket
 
 This revised @racket[literal] implementation provides a
 @racketidfont{get-info} function. The @racketidfont{get-info} function
-will be applied to the source input stream and location information,
+is called by @racket[read-language] (which DrRacket calls) with the 
+source input stream and location information,
 in case query results should depend on the content of the module after
 the language name (which is not the case for @racket[literal]). The
 result of @racketidfont{get-info} is a function of two arguments. The

pkgs/racket-pkgs/racket-doc/scribblings/reference/read.scrbl

@@ -107,7 +107,7 @@ See @secref["readtables"] for an extended example that uses
 
 @defproc[(read-language [in input-port? (current-input-port)]
                         [fail-thunk (-> any) (lambda () (error ...))])
-         (any/c any/c . -> . any)]{
+         (or/c (any/c any/c . -> . any) #f)]{
 
 Reads from @racket[in] in the same way as @racket[read], but stopping as
 soon as a @tech{reader language} (or its absence) is determined.
@@ -125,12 +125,13 @@ or @litchar{#!}.
 When it finds a @litchar{#lang} or @litchar{#!} specification, instead
 of dispatching to a @racketidfont{read} or @racketidfont{read-syntax}
 function as @racket[read] and @racket[read-syntax] do,
-@racket[read-language] dispatches to a @racketidfont{get-info}
+@racket[read-language] dispatches to the @racketidfont{get-info}
 function (if any) exported by the same module. The result of the
 @racketidfont{get-info} function is the result of
 @racket[read-language] if it is a function of two arguments; if
 @racketidfont{get-info} produces any other kind of result, the
-@exnraise[exn:fail:contract].
+@exnraise[exn:fail:contract]. If no @racketidfont{get-info} function is
+exported, @racket[read-language] returns @racket[#f].
 
 The function produced by @racketidfont{get-info} reflects information
 about the expected syntax of the input stream. The first argument to the

pkgs/syntax-color-pkgs/syntax-color-lib/syntax-color/module-lexer.rkt

@@ -54,7 +54,9 @@ to delegate to the scheme-lexer (in the 'no-lang-line mode).
         (set-port-next-location-from in p)
         (set-port-next-location-from in name-p)
         (define-values (_1 _2 start-pos) (port-next-location p))
-        (define get-info (with-handlers ([exn:fail? values]) (read-language p (λ () 'fail))))
+        (define get-info (with-handlers ([exn:fail? values]) 
+                           (or (read-language p (λ () 'fail))
+                               (λ (x y)  y))))
         (define-values (_3 _4 end-pos) (port-next-location p))
         (cond
           [(procedure? get-info)

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt

@@ -1978,7 +1978,7 @@
 [read-syntax (->opt [Univ -Input-Port] (Un (-Syntax Univ) (-val eof)))]
 [read/recursive (->opt [-Input-Port (-opt -Char) (-opt -Read-Table) Univ] Univ)]
 [read-syntax/recursive (->opt [Univ -Input-Port (-opt -Char) (-opt -Read-Table) Univ] Univ)]
-[read-language (->opt [-Input-Port (-> ManyUniv)] (-> Univ Univ ManyUniv))]
+[read-language (->opt [-Input-Port (-> ManyUniv)] (-opt (-> Univ Univ ManyUniv)))]
 
 [read-case-sensitive (-Param Univ B)]
 [read-square-bracket-as-paren (-Param Univ B)]