diff --git a/pkgs/scribble-pkgs/scribble-lib/info.rkt b/pkgs/scribble-pkgs/scribble-lib/info.rkt index 52b15a80..e53a3145 100644 --- a/pkgs/scribble-pkgs/scribble-lib/info.rkt +++ b/pkgs/scribble-pkgs/scribble-lib/info.rkt @@ -13,7 +13,8 @@ "draw-lib" "syntax-color-lib" "sandbox-lib")) -(define build-deps '("rackunit-lib")) +(define build-deps '("rackunit-lib" + "eli-tester")) (define implies '("scribble-html-lib")) diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-code.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-code.rkt index f6409fec..82ebccb2 100644 --- a/pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-code.rkt +++ b/pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-code.rkt @@ -61,6 +61,55 @@ #:line-number-sep [line-number-sep 1] #:block? [block? #t] . strs) + (define-values (tokens bstr) (get-tokens strs context expand)) + (define default-color meta-color) + ((if block? table (lambda (style lines) (make-element #f lines))) + block-color + ((if keep-lang-line? values cdr) ; FIXME: #lang can span lines + (list->lines + indent + #:line-numbers line-numbers + #:line-number-sep line-number-sep + #:block? block? + (let loop ([pos 0] + [tokens tokens]) + (cond + [(null? tokens) (split-lines default-color (substring bstr pos))] + [(eq? (caar tokens) 'white-space) (loop pos (cdr tokens))] + [(= pos (cadar tokens)) + (append (let ([style (caar tokens)] + [get-str (lambda () + (substring bstr (cadar tokens) (caddar tokens)))]) + (cond + [(symbol? style) + (let ([scribble-style + (case style + [(symbol) symbol-color] + [(parenthesis hash-colon-keyword) paren-color] + [(constant string) value-color] + [(comment) comment-color] + [else default-color])]) + (split-lines scribble-style (get-str)))] + [(procedure? style) + (list (style (get-str)))] + [else (list style)])) + (loop (caddar tokens) (cdr tokens)))] + [(> pos (cadar tokens)) + (loop pos (cdr tokens))] + [else (append + (split-lines default-color (substring bstr pos (cadar tokens))) + (loop (cadar tokens) tokens))])))))) + +;; (listof string) boolean boolean -> tokens string +;; tokens is a +;; (cons metadata (listof (list T natural natural natural))) +;; T being a symbol returned as a token type from the languages lexer +;; OR a function created by get-tokens +;; the first number being the start position +;; the second being the end position +;; the third 0 if T is a symbol, and 1 if its a function +;; the tokens are sorted by the start end end positions +(define (get-tokens strs context expand) (let* ([xstr (apply string-append strs)] [bstr (regexp-replace* #rx"(?m:^$)" xstr "\xA0")] [in (open-input-string bstr)]) @@ -69,7 +118,7 @@ (let loop ([mode #f]) (let-values ([(lexeme type data start end backup-delta mode) (module-lexer in 0 mode)]) - (if (eof-object? lexeme) + (if (equal? type 'eof) null (cons (list type (sub1 start) (sub1 end) 0) (loop (if (dont-stop? mode) @@ -163,44 +212,8 @@ (lambda (a b) (or (< (cadr a) (cadr b)) (and (= (cadr a) (cadr b)) - (> (cadddr a) (cadddr b))))))] - [default-color meta-color]) - ((if block? table (lambda (style lines) (make-element #f lines))) - block-color - ((if keep-lang-line? values cdr) ; FIXME: #lang can span lines - (list->lines - indent - #:line-numbers line-numbers - #:line-number-sep line-number-sep - #:block? block? - (let loop ([pos 0] - [tokens tokens]) - (cond - [(null? tokens) (split-lines default-color (substring bstr pos))] - [(eq? (caar tokens) 'white-space) (loop pos (cdr tokens))] - [(= pos (cadar tokens)) - (append (let ([style (caar tokens)] - [get-str (lambda () - (substring bstr (cadar tokens) (caddar tokens)))]) - (cond - [(symbol? style) - (let ([scribble-style - (case style - [(symbol) symbol-color] - [(parenthesis hash-colon-keyword) paren-color] - [(constant string) value-color] - [(comment) comment-color] - [else default-color])]) - (split-lines scribble-style (get-str)))] - [(procedure? style) - (list (style (get-str)))] - [else (list style)])) - (loop (caddar tokens) (cdr tokens)))] - [(> pos (cadar tokens)) - (loop pos (cdr tokens))] - [else (append - (split-lines default-color (substring bstr pos (cadar tokens))) - (loop (cadar tokens) tokens))])))))))) + (> (cadddr a) (cadddr b))))))]) + (values tokens bstr)))) (define (typeset-code-line context expand lang-line . strs) (typeset-code @@ -295,3 +308,50 @@ (for/list ([l (break-list l 'newline)] [i (in-naturals (or line-numbers 1))]) (make-line l i))) + + +;; ---------------------------------------- + +(module+ test + (require racket/list + racket/match + tests/eli-tester) + + (define (tokens strs) + (define-values (toks _) (get-tokens strs #f #f)) + (for/list ([tok (rest toks)]) + (match tok + [(list _ start end 1) + (list 'function start end 1)] + [_ tok]))) + + (define (make-test-result lst) + (define-values (res _) + (for/fold ([result null] [count 12]) + ([p lst]) + (define next (+ count (second p))) + (define r (if (eq? (first p) 'function) 1 0)) + (values + (cons (list (first p) count next r) result) + next))) + (cons `(function 6 12 1) (reverse res))) + + (test + (tokens (list "#lang racket\n1")) + => `((function 6 12 1) (white-space 12 13 0) (constant 13 14 0)) + (tokens (list "#lang racket\n" "(+ 1 2)")) + => (make-test-result + '((white-space 1) + (parenthesis 1) (function 1) + (white-space 1) (constant 1) (white-space 1) (constant 1) + (parenthesis 1))) + (tokens (list "#lang racket\n(apply x (list y))")) + => (make-test-result + '((white-space 1) + (parenthesis 1) + (function 5) (white-space 1);apply + (function 1) (white-space 1);x + (parenthesis 1) + (function 4) (white-space 1) (function 1);list y + (parenthesis 1) + (parenthesis 1)))))