Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[WIP] Extended support for highlighting #109

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

[WIP] Extended support for highlighting #109

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
197 changes: 114 additions & 83 deletions scribble-lib/scribble/racket.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -326,6 +326,7 @@
[first (if escapes?
(syntax-case c (code:line)
[(code:line e . rest) #'e]
[(code:line . rest) #'rest]
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think this case only matches (code:line), so it shouldn't hurt but also shouldn't change how anything looks.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

With the patch which I added, you can now write (code:line . foo) which renders as . foo (but previously it was not possible).

Also, technically, we could have a first element which is (code:line (code:line something)), should the code above be called recursively as long as code:line is the first element? (I can amend the patch to include that, if you think it's the right thing to do).

[else c])
c)]
[init-col (or (syntax-column first) 0)]
Expand Down Expand Up @@ -380,7 +381,7 @@
(set! content (cons (elem-wrap
((if highlight?
(lambda (c)
(make-element highlighted-color c))
(make-element highlight? c))
values)
(if (and color? cls)
(make-element/cache cls v)
Expand Down Expand Up @@ -469,6 +470,70 @@
[else s]))
(define (loop init-line! quote-depth expr? no-cons?)
(lambda (c srcless-step)
(define (lloop quote-depth l)
(let inner-lloop ([first-element? #t]
[l l]
[first-expr? (and expr?
(or (zero? quote-depth)
(not (struct-proxy? (syntax-e c))))
(not no-cons?))]
[dotted? #f]
[srcless-step #f])
(define (print-dot-separator l)
(unless (and expr? (zero? quote-depth))
(advance l init-line! (and srcless-step (+ srcless-step 3)) -2)
(out ". " (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 3)))
(hash-set! next-col-map src-col dest-col))
(cond
[(let ([el (if (syntax? l) (syntax-e l) l)])
(and (pair? el)
(eq? (if (syntax? (car el))
(syntax-e (car el))
(car el))
'code:hilite)))
(define l-stx
(if (syntax? l)
l
(datum->syntax #f l (list #f #f #f #f 0))))
(print-dot-separator l-stx)
((loop init-line! quote-depth first-expr? #f) l-stx (if (and expr? (zero? quote-depth))
srcless-step
#f))]
[(and (syntax? l)
(pair? (syntax-e l))
(not dotted?)
(not (and (memq (syntax-e (car (syntax-e l)))
'(quote unquote syntax unsyntax quasiquote quasiunsyntax))
(let ([v (syntax->list l)])
(and v (= 2 (length v))))
(or (not expr?)
(quote-depth . > . 1)
(not (memq (syntax-e (car (syntax-e l)))
'(unquote unquote-splicing)))))))
(if first-element?
(inner-lloop #f (syntax-e l) first-expr? #f srcless-step)
(begin
(print-dot-separator l)
((loop init-line! quote-depth first-expr? #f) l srcless-step)))]
[(and (or (null? l)
(and (syntax? l)
(null? (syntax-e l)))))
(void)]
[(and (pair? l) (not dotted?))
((loop init-line! quote-depth first-expr? #f) (car l) srcless-step)
(inner-lloop #f (cdr l) expr? #f 1)]
[(forced-pair? l)
((loop init-line! quote-depth first-expr? #f) (forced-pair-car l) srcless-step)
(inner-lloop #f (forced-pair-cdr l) expr? #t 1)]
[(mpair? l)
((loop init-line! quote-depth first-expr? #f) (mcar l) srcless-step)
(inner-lloop #f (mcdr l) expr? #t 1)]
[else
(print-dot-separator l)
((loop init-line! quote-depth first-expr? #f) l (if (and expr? (zero? quote-depth))
srcless-step
#f))])))
(cond
[(and escapes? (eq? 'code:blank (syntax-e c)))
(advance c init-line! srcless-step)]
Expand Down Expand Up @@ -513,24 +578,30 @@
[(and escapes?
(pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:line))
(let ([l (cdr (syntax->list c))])
(for-each/i (loop init-line! quote-depth expr? #f)
l
#f))]
(lloop quote-depth
(cdr (syntax-e c)))]
[(and escapes?
(pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:hilite))
(let ([l (syntax->list c)]
[h? highlight?])
(unless (and l (= 2 (length l)))
(error "bad code:redex: ~.s" (syntax->datum c)))
(unless (and l (or (= 2 (length l)) (= 3 (length l))))
(error "bad code:hilite: ~.s" (syntax->datum c)))

(advance c init-line! srcless-step)
(set! src-col (syntax-column (cadr l)))
(hash-set! next-col-map src-col dest-col)
(set! highlight? #t)

(set! highlight? (if (= 3 (length l))
(let ([the-style (syntax-e (caddr l))])
(if (syntax? the-style)
(syntax->datum the-style)
the-style))
highlighted-color))
((loop init-line! quote-depth expr? #f) (cadr l) #f)
(set! highlight? h?)
(set! src-col (add1 src-col)))]
(unless (= (syntax-span c) 0)
(set! src-col (add1 src-col))))]
[(and escapes?
(pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:quote))
Expand Down Expand Up @@ -660,80 +731,40 @@
p-color))
(set! src-col (+ src-col 1))
(hash-set! next-col-map src-col dest-col)
(let lloop ([l (cond
[(vector? (syntax-e c))
(vector->short-list (syntax-e c) syntax-e)]
[(struct? (syntax-e c))
(let ([l (vector->list (struct->vector (syntax-e c)))])
;; Need to build key datum, syntax-ize it internally, and
;; set the overall width to fit right:
(if (and expr? (zero? quote-depth))
(cdr l)
(cons (let ([key (syntax-ize (prefab-struct-key (syntax-e c))
(+ 3 (or (syntax-column c) 0))
(or (syntax-line c) 1))]
[end (if (pair? (cdr l))
(and (equal? (syntax-line c) (syntax-line (cadr l)))
(syntax-column (cadr l)))
(and (syntax-column c)
(+ (syntax-column c) (syntax-span c))))])
(if end
(datum->syntax #f
(syntax-e key)
(vector #f (syntax-line key)
(syntax-column key)
(syntax-position key)
(max 1 (- end 1 (syntax-column key)))))
end))
(cdr l))))]
[(struct-proxy? (syntax-e c))
(struct-proxy-content (syntax-e c))]
[(forced-pair? (syntax-e c))
(syntax-e c)]
[(mpair? (syntax-e c))
(syntax-e c)]
[else c])]
[first-expr? (and expr?
(or (zero? quote-depth)
(not (struct-proxy? (syntax-e c))))
(not no-cons?))]
[dotted? #f]
[srcless-step #f])
(cond
[(and (syntax? l)
(pair? (syntax-e l))
(not dotted?)
(not (and (memq (syntax-e (car (syntax-e l)))
'(quote unquote syntax unsyntax quasiquote quasiunsyntax))
(let ([v (syntax->list l)])
(and v (= 2 (length v))))
(or (not expr?)
(quote-depth . > . 1)
(not (memq (syntax-e (car (syntax-e l)))
'(unquote unquote-splicing)))))))
(lloop (syntax-e l) first-expr? #f srcless-step)]
[(and (or (null? l)
(and (syntax? l)
(null? (syntax-e l)))))
(void)]
[(and (pair? l) (not dotted?))
((loop init-line! quote-depth first-expr? #f) (car l) srcless-step)
(lloop (cdr l) expr? #f 1)]
[(forced-pair? l)
((loop init-line! quote-depth first-expr? #f) (forced-pair-car l) srcless-step)
(lloop (forced-pair-cdr l) expr? #t 1)]
[(mpair? l)
((loop init-line! quote-depth first-expr? #f) (mcar l) srcless-step)
(lloop (mcdr l) expr? #t 1)]
[else
(unless (and expr? (zero? quote-depth))
(advance l init-line! (and srcless-step (+ srcless-step 3)) -2)
(out ". " (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 3)))
(hash-set! next-col-map src-col dest-col)
((loop init-line! quote-depth first-expr? #f) l (if (and expr? (zero? quote-depth))
srcless-step
#f))]))
(lloop quote-depth
(cond
[(vector? (syntax-e c))
(vector->short-list (syntax-e c) syntax-e)]
[(struct? (syntax-e c))
(let ([l (vector->list (struct->vector (syntax-e c)))])
;; Need to build key datum, syntax-ize it internally, and
;; set the overall width to fit right:
(if (and expr? (zero? quote-depth))
(cdr l)
(cons (let ([key (syntax-ize (prefab-struct-key (syntax-e c))
(+ 3 (or (syntax-column c) 0))
(or (syntax-line c) 1))]
[end (if (pair? (cdr l))
(and (equal? (syntax-line c) (syntax-line (cadr l)))
(syntax-column (cadr l)))
(and (syntax-column c)
(+ (syntax-column c) (syntax-span c))))])
(if end
(datum->syntax #f
(syntax-e key)
(vector #f (syntax-line key)
(syntax-column key)
(syntax-position key)
(max 1 (- end 1 (syntax-column key)))))
end))
(cdr l))))]
[(struct-proxy? (syntax-e c))
(struct-proxy-content (syntax-e c))]
[(forced-pair? (syntax-e c))
(syntax-e c)]
[(mpair? (syntax-e c))
(syntax-e c)]
[else c]))
(out (case sh
[(#\[ #\?) "]"]
[(#\{) "}"]
Expand Down