suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

change typeset-code to conform to text:color<%>'s interface

Browse Source 
The `typeset-code` function assumed that a lexeme must be `eof` on an
end-of-file, but `test:color<%>` allows it to be anything. Instead,
the check should be on type as 'eof.

original commit: d81f09d11e14a98a17a038881eb257f3b0363498
This commit is contained in:
Spencer Florence 2014-09-22 16:36:49 -05:00 committed by Matthew Flatt
parent 2a4d132559
commit ffa98a1c11
2 changed files with 101 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/scribble-pkgs/scribble-lib/info.rkt
View File

@ -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"))

138
pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-code.rkt
View File

@ -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)))))