From d0a3a0b255fdba3758c031f9f1149dac3e600ef0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 11 May 2017 23:38:46 +0200 Subject: [PATCH] Allow the last expresion of the lang-line to span multiple lines. Stop providing #%top-interaction, so that one from the user's language is used instead (still can't access the bindings without providing them + (require (submod .)), but it's a step forward) --- lang.rkt | 2 +- lang/first-line-utils.rkt | 35 +++++++++++++++++++++++++++++------ lang/reader.rkt | 24 ++++++++++++++++-------- private/common.rkt | 3 +-- private/lp.rkt | 13 +++++++++---- 5 files changed, 56 insertions(+), 21 deletions(-) diff --git a/lang.rkt b/lang.rkt index 8458b4f8..d00c8c19 100644 --- a/lang.rkt +++ b/lang.rkt @@ -5,4 +5,4 @@ (provide (rename-out [module-begin/doc #%module-begin]) ;; TODO: this is the #%top-interaction from racket/base, not from the ;; user-specified language. - #%top-interaction) + #;#%top-interaction) diff --git a/lang/first-line-utils.rkt b/lang/first-line-utils.rkt index f0baf298..626d31c9 100644 --- a/lang/first-line-utils.rkt +++ b/lang/first-line-utils.rkt @@ -18,12 +18,35 @@ (make-limited-input-port port (read-line-length port))) (define (read-*-whole-first-line rec-read in) - (define in1 (narrow-to-one-line in)) - (let loop ([res '()]) - (define res+ (rec-read in1)) - (if (eof-object? res+) - (reverse res) - (loop (cons res+ res))))) + (define in1 (peeking-input-port (narrow-to-one-line in))) + + (define start-pos (file-position in1)) + + (let loop ([last-good-pos start-pos]) + (define res+ + ;; Try to read (may fail if the last object to read spills onto the next + ;; lines. We read from the peeking-input-port, so that we can retry the + ;; last read on the full, non-narrowed port. + (with-handlers ([exn:fail:read? (λ (_) 'read-error)]) + (list (rec-read in1)))) + (cond + [(eq? res+ 'read-error) + ;; Last read was unsuccessful, only consume the bytes from the original + ;; input port up to the last successful read. Then, re-try one last read + ;; on the whole file (i.e. the last read object may span several lines). + (read-bytes (- last-good-pos start-pos) in) + (list (rec-read in))] + [(eof-object? (car res+)) + ;; Last successful read, actually consume the bytes from the original + ;; input port. Technically, last-good-pos and (file-position pk) should + ;; be the same, since the last read returned # (and therefore did + ;; not advance the read pointer. + (read-bytes (- (file-position in1) start-pos) in) + '()] + [else + ;; One successful read. Prepend it, and continue reading some more. + (cons (car res+) + (loop (file-position in1)))]))) (define (read-whole-first-line in) (read-*-whole-first-line (λ (in1) (read in1)) in)) diff --git a/lang/reader.rkt b/lang/reader.rkt index b5d05038..759dfa04 100644 --- a/lang/reader.rkt +++ b/lang/reader.rkt @@ -38,14 +38,23 @@ hyper-literate/lang (make-scribble-inside-lexer #:command-char (or command-char #\@))) (define (read/options in offset x-mode) - (define-values (line column position) (port-next-location in)) - (define-values (mode2 command-char) + (define-values (mode2 command-char depth) (apply values x-mode)) - (define-values (txt type paren start end) (racket-lexer in)) + (define-values (txt type paren start end status) (racket-lexer/status in)) + (define new-depth (case status + [(open) (add1 depth)] + [(close) (sub1 depth)] + [else depth])) ;; TODO: limit the number of newlines to a single newline. - (if (and (eq? type 'white-space) - (regexp-match #px"\n" txt)) + (if (or + ;; Fallback to scribble mode fast if we get a close-paren too many. + ;; This could be because the text starts right after the last "config" + ;; expression (which would start on the first line, then continue). + (< new-depth 0) + (and (= new-depth 0) + (and (eq? type 'white-space) + (regexp-match #px"\n" txt)))) (values txt type paren start end 0 (list 'main (make-lexr command-char) command-char #f)) (let () @@ -61,16 +70,15 @@ hyper-literate/lang #\@)) #\@)))) (values txt type paren start end - 0 (list 'options new-command-char))))) + 0 (list 'options new-command-char new-depth))))) (lambda (key defval default) (case key [(color-lexer) (λ (in offset x-mode) - (define-values (line column position) (port-next-location in)) (cond [(eq? x-mode #f) - (read/options in offset (list 'options #f))] + (read/options in offset (list 'options #f 0))] [(eq? (car x-mode) 'options) (read/options in offset x-mode)] [else diff --git a/private/common.rkt b/private/common.rkt index 5f766263..d723cfb8 100644 --- a/private/common.rkt +++ b/private/common.rkt @@ -179,8 +179,7 @@ [(_modbeg {~or (lang:id {~optional (~and no-require-lang #:no-require-lang)} {~optional (~and no-auto-require #:no-auto-require)}) - ({~optional (~and no-require-lang #:no-require-lang)} - {~optional (~and no-auto-require #:no-auto-require)} + ({~optional (~and no-auto-require #:no-auto-require)} (lang:id . chain₊))} body0 . body) diff --git a/private/lp.rkt b/private/lp.rkt index 349875e9..ad5b428a 100644 --- a/private/lp.rkt +++ b/private/lp.rkt @@ -128,6 +128,9 @@ ;; TODO: hash tables [else e])) +(define-for-syntax (prettify-chunk-name str) + (regexp-replace #px"^<(.*)>$" str "«\\1»")) + (define-for-syntax ((make-chunk-display racketblock unsyntax-id) stx) (syntax-parse stx ;; no need for more error checking, using chunk for the code will do that @@ -145,6 +148,7 @@ (define n-repeat (get+increment-repeat-chunk-number! original-name:n)) (define str (symbol->string (syntax-e #'name))) + (define str-display (prettify-chunk-name str)) (define/with-syntax tag (format "chunk:~a:~a:~a" str n n-repeat)) (define/with-syntax (rest ...) ;; if the would-be-next number for this chunk name is "2", then there is @@ -178,11 +182,12 @@ (list (elemtag '(prefixable tag) (bold (italic (elemref '(prefixable tag) #:underline? #f - #,str rest ...)) + #,str-display rest ...)) " ::="))) (list (smaller (make-link-element "plainlink" - (decode-content (list #,str rest ...)) + (decode-content + (list #,str-display rest ...)) `(elem (prefixable ,@(chunks-toc-prefix) tag)))))) @@ -274,8 +279,8 @@ [(_ id) (identifier? #'id) (with-syntax ([tag (format "chunk:~a:1:1" (syntax-e #'id))] - [str (format "~a" (syntax-e #'id))]) - #'(elemref '(prefixable tag) #:underline? #f str))])) + [pretty (prettify-chunk-name (format "~a" (syntax-e #'id)))]) + #'(elemref '(prefixable tag) #:underline? #f pretty))])) (provide (all-from-out scheme/base