suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

convert racket value printer to constructor+quote style; update Guide and Quick

Browse Source 
original commit: 420ea6ee0962cac112853c23e756534cb307ad62
This commit is contained in:
Matthew Flatt 2010-05-06 14:57:15 -06:00
parent 8a38388cd7
commit eeee9df37e
2 changed files with 343 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/scribble/eval.rkt
View File

@ -124,7 +124,7 @@
(list (list
(hspace 2) (hspace 2)
(elem #:style result-color (elem #:style result-color
(to-element/no-color v #:qq? (print-as-expression))))))))) (to-element/no-color v #:expr? (print-as-expression)))))))))
val-list)))) val-list))))
(loop (cdr expr-paras) (loop (cdr expr-paras)
(cdr val-list+outputs) (cdr val-list+outputs)
@ -320,7 +320,7 @@
(define (show-val v) (define (show-val v)
(elem #:style result-color (elem #:style result-color
(to-element/no-color v #:qq? (print-as-expression)))) (to-element/no-color v #:expr? (print-as-expression))))
(define (do-interaction-eval-show ev e) (define (do-interaction-eval-show ev e)
(parameterize ([current-command-line-arguments #()]) (parameterize ([current-command-line-arguments #()])

437
collects/scribble/racket.rkt
View File

@ -162,23 +162,25 @@
e)))) e))))
(make-element style content))) (make-element style content)))
(define (to-quoted qs qq? quote-depth out color? inc!) (define (to-quoted obj expr? quote-depth out color? inc!)
(if (and qq? (zero? quote-depth)) (if (and expr?
(zero? quote-depth)
(quotable? obj))
(begin (begin
(out qs (and color? value-color)) (out "'" (and color? value-color))
(inc!) (inc!)
(add1 quote-depth)) (add1 quote-depth))
quote-depth)) quote-depth))
(define (to-unquoted qq? quote-depth out color? inc!) (define (to-unquoted expr? quote-depth out color? inc!)
(if (or (not qq?) (zero? quote-depth)) (if (or (not expr?) (zero? quote-depth))
quote-depth quote-depth
(begin (begin
(out "," (and color? meta-color)) (out "," (and color? meta-color))
(inc!) (inc!)
(to-unquoted qq? (sub1 quote-depth) out color? inc!)))) (to-unquoted expr? (sub1 quote-depth) out color? inc!))))
(define (typeset-atom c out color? quote-depth qq?) (define (typeset-atom c out color? quote-depth expr?)
(if (and (var-id? (syntax-e c)) (if (and (var-id? (syntax-e c))
(zero? quote-depth)) (zero? quote-depth))
(out (format "~s" (let ([v (var-id-sym (syntax-e c))]) (out (format "~s" (let ([v (var-id-sym (syntax-e c))])
@ -203,13 +205,13 @@
is-var?))) is-var?)))
(values (substring s 1) #t #f) (values (substring s 1) #t #f)
(values s #f #f))))]) (values s #f #f))))])
(let ([quote-depth (if (and qq? (identifier? c) (not (eq? qq-ellipses (syntax-e c)))) (let ([quote-depth (if (and expr? (identifier? c) (not (eq? qq-ellipses (syntax-e c))))
(let ([quote-depth (let ([quote-depth
(if (and (quote-depth . < . 2) (if (and (quote-depth . < . 2)
(memq (syntax-e c) '(unquote unquote-splicing))) (memq (syntax-e c) '(unquote unquote-splicing)))
(to-unquoted qq? quote-depth out color? void) (to-unquoted expr? quote-depth out color? void)
quote-depth)]) quote-depth)])
(to-quoted "'" qq? quote-depth out color? void)) (to-quoted c expr? quote-depth out color? void))
quote-depth)]) quote-depth)])
(if (or (element? (syntax-e c)) (if (or (element? (syntax-e c))
(delayed-element? (syntax-e c)) (delayed-element? (syntax-e c))
@ -251,8 +253,8 @@
(define omitable (make-style #f '(omitable))) (define omitable (make-style #f '(omitable)))
(define (gen-typeset c multi-line? prefix1 prefix suffix color? qq?) (define (gen-typeset c multi-line? prefix1 prefix suffix color? expr?)
(let* ([c (syntax-ize c 0 #:qq? qq?)] (let* ([c (syntax-ize c 0 #:expr? expr?)]
[content null] [content null]
[docs null] [docs null]
[first (syntax-case c (code:line) [first (syntax-case c (code:line)
@ -341,7 +343,7 @@
(set! src-col c) (set! src-col c)
(hash-set! next-col-map src-col dest-col)))] (hash-set! next-col-map src-col dest-col)))]
[(c init-line!) (advance c init-line! 0)])) [(c init-line!) (advance c init-line! 0)]))
(define (convert-infix c quote-depth qq?) (define (convert-infix c quote-depth expr?)
(let ([l (syntax->list c)]) (let ([l (syntax->list c)])
(and l (and l
((length l) . >= . 3) ((length l) . >= . 3)
@ -367,7 +369,7 @@
(if val? value-color #f) (if val? value-color #f)
(list (list
(make-element/cache (if val? value-color paren-color) '". ") (make-element/cache (if val? value-color paren-color) '". ")
(typeset a #f "" "" "" (not val?) qq?) (typeset a #f "" "" "" (not val?) expr?)
(make-element/cache (if val? value-color paren-color) '" .")) (make-element/cache (if val? value-color paren-color) '" ."))
(+ (syntax-span a) 4))) (+ (syntax-span a) 4)))
(list (syntax-source a) (list (syntax-source a)
@ -385,7 +387,7 @@
(cond (cond
[(eq? s 'rsquo) "'"] [(eq? s 'rsquo) "'"]
[else s])) [else s]))
(define (loop init-line! quote-depth qq?) (define (loop init-line! quote-depth expr? no-cons?)
(lambda (c) (lambda (c)
(cond (cond
[(eq? 'code:blank (syntax-e c)) [(eq? 'code:blank (syntax-e c))
@ -422,12 +424,13 @@
(set! dest-col 0) (set! dest-col 0)
(out "; " comment-color)) (out "; " comment-color))
0 0
qq?) expr?
#f)
l))] l))]
[(and (pair? (syntax-e c)) [(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:line)) (eq? (syntax-e (car (syntax-e c))) 'code:line))
(let ([l (cdr (syntax->list c))]) (let ([l (cdr (syntax->list c))])
(for-each (loop init-line! quote-depth qq?) (for-each (loop init-line! quote-depth expr? #f)
l))] l))]
[(and (pair? (syntax-e c)) [(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:hilite)) (eq? (syntax-e (car (syntax-e c))) 'code:hilite))
@ -439,19 +442,19 @@
(set! src-col (syntax-column (cadr l))) (set! src-col (syntax-column (cadr l)))
(hash-set! next-col-map src-col dest-col) (hash-set! next-col-map src-col dest-col)
(set! highlight? #t) (set! highlight? #t)
((loop init-line! quote-depth qq?) (cadr l)) ((loop init-line! quote-depth expr?) (cadr l) #f)
(set! highlight? h?) (set! highlight? h?)
(set! src-col (add1 src-col)))] (set! src-col (add1 src-col)))]
[(and (pair? (syntax-e c)) [(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:quote)) (eq? (syntax-e (car (syntax-e c))) 'code:quote))
(advance c init-line!) (advance c init-line!)
(let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)]) (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
(out "(" (if (positive? quote-depth) value-color paren-color)) (out "(" (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 1)) (set! src-col (+ src-col 1))
(hash-set! next-col-map src-col dest-col) (hash-set! next-col-map src-col dest-col)
((loop init-line! quote-depth qq?) ((loop init-line! quote-depth expr? #f)
(datum->syntax #'here 'quote (car (syntax-e c)))) (datum->syntax #'here 'quote (car (syntax-e c))))
(for-each (loop init-line! (add1 quote-depth) qq?) (for-each (loop init-line! (add1 quote-depth) expr? #f)
(cdr (syntax->list c))) (cdr (syntax->list c)))
(out ")" (if (positive? quote-depth) value-color paren-color)) (out ")" (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 1)) (set! src-col (+ src-col 1))
@ -463,12 +466,11 @@
quasisyntax syntax unsyntax unsyntax-splicing)) quasisyntax syntax unsyntax unsyntax-splicing))
(let ([v (syntax->list c)]) (let ([v (syntax->list c)])
(and v (= 2 (length v)))) (and v (= 2 (length v))))
(or (not qq?) (or (not expr?)
(quote-depth . > . 1) (positive? quote-depth)
(not (memq (syntax-e (car (syntax-e c))) (quotable? c)))
'(unquote unquote-splicing)))))
(advance c init-line!) (advance c init-line!)
(let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)]) (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
(let-values ([(str quote-delta) (let-values ([(str quote-delta)
(case (syntax-e (car (syntax-e c))) (case (syntax-e (car (syntax-e c)))
[(quote) (values "'" +inf.0)] [(quote) (values "'" +inf.0)]
@ -485,12 +487,16 @@
(let ([i (cadr (syntax->list c))]) (let ([i (cadr (syntax->list c))])
(set! src-col (or (syntax-column i) src-col)) (set! src-col (or (syntax-column i) src-col))
(hash-set! next-col-map src-col dest-col) (hash-set! next-col-map src-col dest-col)
((loop init-line! (+ quote-depth quote-delta) qq?) i))))] ((loop init-line! (+ quote-depth quote-delta) expr? #f) i))))]
[(and (pair? (syntax-e c)) [(and (pair? (syntax-e c))
(convert-infix c quote-depth qq?)) (or (not expr?)
(positive? quote-depth)
(quotable? c))
(convert-infix c quote-depth expr?))
=> (lambda (converted) => (lambda (converted)
((loop init-line! quote-depth qq?) converted))] ((loop init-line! quote-depth expr? #f) converted))]
[(or (pair? (syntax-e c)) [(or (pair? (syntax-e c))
(mpair? (syntax-e c))
(forced-pair? (syntax-e c)) (forced-pair? (syntax-e c))
(null? (syntax-e c)) (null? (syntax-e c))
(vector? (syntax-e c)) (vector? (syntax-e c))
@ -498,12 +504,15 @@
(prefab-struct-key (syntax-e c))) (prefab-struct-key (syntax-e c)))
(struct-proxy? (syntax-e c))) (struct-proxy? (syntax-e c)))
(let* ([sh (or (syntax-property c 'paren-shape) (let* ([sh (or (syntax-property c 'paren-shape)
#\()] (if (and (mpair? (syntax-e c))
[quote-depth (if (and (not qq?) (not (and expr? (zero? quote-depth))))
#\{
#\())]
[quote-depth (if (and (not expr?)
(zero? quote-depth) (zero? quote-depth)
(or (vector? (syntax-e c)) (or (vector? (syntax-e c))
(struct? (syntax-e c)))) (struct? (syntax-e c))))
+inf.0 1
quote-depth)] quote-depth)]
[p-color (if (positive? quote-depth) [p-color (if (positive? quote-depth)
value-color value-color
@ -512,24 +521,50 @@
paren-color))]) paren-color))])
(advance c init-line!) (advance c init-line!)
(let ([quote-depth (if (struct-proxy? (syntax-e c)) (let ([quote-depth (if (struct-proxy? (syntax-e c))
(to-unquoted qq? quote-depth out color? inc-src-col) quote-depth
(to-quoted "`" qq? quote-depth out color? inc-src-col))]) (to-quoted c expr? quote-depth out color? inc-src-col))])
(when (and expr? (zero? quote-depth))
(out "(" p-color)
(unless no-cons?
(out (let ([s (cond
[(pair? (syntax-e c))
(if (syntax->list c)
"list"
(if (let ([d (cdr (syntax-e c))])
(or (pair? d)
(and (syntax? d)
(pair? (syntax-e d)))))
"list*"
"cons"))]
[(vector? (syntax-e c)) "vector"]
[(mpair? (syntax-e c)) "mcons"]
[else (format "~a"
(if (struct-proxy? (syntax-e c))
(syntax-e (struct-proxy-name (syntax-e c)))
(object-name (syntax-e c))))])])
(set! src-col (+ src-col (string-length s)))
s)
symbol-color)
(out " " no-color)))
(when (vector? (syntax-e c)) (when (vector? (syntax-e c))
(unless (and expr? (zero? quote-depth))
(let ([vec (syntax-e c)]) (let ([vec (syntax-e c)])
(out "#" #; (format "#~a" (vector-length vec)) p-color) (out "#" p-color)
(if (zero? (vector-length vec)) (if (zero? (vector-length vec))
(set! src-col (+ src-col (- (syntax-span c) 2))) (set! src-col (+ src-col (- (syntax-span c) 2)))
(set! src-col (+ src-col (- (syntax-column (vector-ref vec 0)) (set! src-col (+ src-col (- (syntax-column (vector-ref vec 0))
(syntax-column c) (syntax-column c)
1)))))) 1)))))))
(when (struct? (syntax-e c)) (when (struct? (syntax-e c))
(unless (and expr? (zero? quote-depth))
(out "#s" p-color) (out "#s" p-color)
(set! src-col (+ src-col 2))) (set! src-col (+ src-col 2))))
(unless (and expr? (zero? quote-depth))
(out (case sh (out (case sh
[(#\[ #\?) "["] [(#\[ #\?) "["]
[(#\{) "{"] [(#\{) "{"]
[else "("]) [else "("])
p-color) p-color))
(set! src-col (+ src-col 1)) (set! src-col (+ src-col 1))
(hash-set! next-col-map src-col dest-col) (hash-set! next-col-map src-col dest-col)
(let lloop ([l (cond (let lloop ([l (cond
@ -539,6 +574,8 @@
(let ([l (vector->list (struct->vector (syntax-e c)))]) (let ([l (vector->list (struct->vector (syntax-e c)))])
;; Need to build key datum, syntax-ize it internally, and ;; Need to build key datum, syntax-ize it internally, and
;; set the overall width to fit right: ;; 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)) (cons (let ([key (syntax-ize (prefab-struct-key (syntax-e c))
(+ 3 (or (syntax-column c) 0)) (+ 3 (or (syntax-column c) 0))
(or (syntax-line c) 1))] (or (syntax-line c) 1))]
@ -553,17 +590,17 @@
(vector #f (syntax-line key) (vector #f (syntax-line key)
(syntax-column key) (syntax-column key)
(syntax-position key) (syntax-position key)
(- end 1 (syntax-column key)))) (max 1 (- end 1 (syntax-column key)))))
end)) end))
(cdr l)))] (cdr l))))]
[(struct-proxy? (syntax-e c)) [(struct-proxy? (syntax-e c))
(cons (struct-proxy-content (syntax-e c))]
(struct-proxy-name (syntax-e c))
(struct-proxy-content (syntax-e c)))]
[(forced-pair? (syntax-e c)) [(forced-pair? (syntax-e c))
(syntax-e c)] (syntax-e c)]
[(mpair? (syntax-e c))
(syntax-e c)]
[else c])] [else c])]
[first-qq? (and qq? (not (struct-proxy? (syntax-e c))))] [first-expr? (and expr? (not (struct-proxy? (syntax-e c))) (not no-cons?))]
[dotted? #f]) [dotted? #f])
(cond (cond
[(and (syntax? l) [(and (syntax? l)
@ -573,66 +610,83 @@
'(quote unquote syntax unsyntax quasiquote quasiunsyntax)) '(quote unquote syntax unsyntax quasiquote quasiunsyntax))
(let ([v (syntax->list l)]) (let ([v (syntax->list l)])
(and v (= 2 (length v)))) (and v (= 2 (length v))))
(or (not qq?) (or (not expr?)
(quote-depth . > . 1) (quote-depth . > . 1)
(not (memq (syntax-e (car (syntax-e l))) (not (memq (syntax-e (car (syntax-e l)))
'(unquote unquote-splicing))))))) '(unquote unquote-splicing)))))))
(lloop (syntax-e l) first-qq? #f)] (lloop (syntax-e l) first-expr? #f)]
[(or (null? l) [(and (or (null? l)
(and (syntax? l) (and (syntax? l)
(null? (syntax-e l)))) (null? (syntax-e l)))))
(void)] (void)]
[(and (pair? l) (not dotted?)) [(and (pair? l) (not dotted?))
((loop init-line! quote-depth first-qq?) (car l)) ((loop init-line! quote-depth first-expr? #f) (car l))
(lloop (cdr l) qq? #f)] (lloop (cdr l) expr? #f)]
[(forced-pair? l) [(forced-pair? l)
((loop init-line! quote-depth first-qq?) (forced-pair-car l)) ((loop init-line! quote-depth first-expr? #f) (forced-pair-car l))
(lloop (forced-pair-cdr l) qq? #t)] (lloop (forced-pair-cdr l) expr? #t)]
[(mpair? l)
((loop init-line! quote-depth first-expr? #f) (mcar l))
(lloop (mcdr l) expr? #t)]
[else [else
(unless (and expr? (zero? quote-depth))
(advance l init-line! -2) (advance l init-line! -2)
(out ". " (if (positive? quote-depth) value-color paren-color)) (out ". " (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 3)) (set! src-col (+ src-col 3)))
(hash-set! next-col-map src-col dest-col) (hash-set! next-col-map src-col dest-col)
((loop init-line! quote-depth first-qq?) l)])) ((loop init-line! quote-depth first-expr? #f) l)]))
(out (case sh (out (case sh
[(#\[ #\?) "]"] [(#\[ #\?) "]"]
[(#\{) "}"] [(#\{) "}"]
[else ")"]) [else ")"])
p-color) p-color)
(set! src-col (+ src-col 1)) (set! src-col (+ src-col 1))))]
#;
(hash-set! next-col-map src-col dest-col)))]
[(box? (syntax-e c)) [(box? (syntax-e c))
(advance c init-line!) (advance c init-line!)
(let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)]) (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
(if (and expr? (zero? quote-depth))
(begin
(out "(" paren-color)
(out "box" symbol-color)
(out " " no-color)
(set! src-col (+ src-col 5)))
(begin
(out "#&" value-color) (out "#&" value-color)
(set! src-col (+ src-col 2)) (set! src-col (+ src-col 2))))
(hash-set! next-col-map src-col dest-col) (hash-set! next-col-map src-col dest-col)
((loop init-line! (if qq? quote-depth +inf.0) qq?) (unbox (syntax-e c))))] ((loop init-line! (if expr? quote-depth +inf.0) expr? #f) (unbox (syntax-e c)))
(when (and expr? (zero? quote-depth))
(out ")" paren-color)))]
[(hash? (syntax-e c)) [(hash? (syntax-e c))
(advance c init-line!) (advance c init-line!)
(let ([equal-table? (hash-equal? (syntax-e c))] (let ([equal-table? (hash-equal? (syntax-e c))]
[eqv-table? (hash-eq? (syntax-e c))] [eqv-table? (hash-eq? (syntax-e c))]
[quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)]) [quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
(unless (and expr? (zero? quote-depth))
(out (if equal-table? (out (if equal-table?
"#hash" "#hash"
(if eqv-table? (if eqv-table?
"#hasheqv" "#hasheqv"
"#hasheq")) "#hasheq"))
value-color) value-color))
(let ([delta (+ 5 (if equal-table? 0 (if eqv-table? 3 2)))] (let ([delta (+ 5 (if equal-table? 0 (if eqv-table? 3 2))
(if (and expr? (zero? quote-depth)) 1 0))]
[orig-col src-col]) [orig-col src-col])
(set! src-col (+ src-col delta)) (set! src-col (+ src-col delta))
(hash-set! next-col-map src-col dest-col) (hash-set! next-col-map src-col dest-col)
((loop init-line! (if qq? quote-depth +inf.0) qq?) ((loop init-line! (if expr? quote-depth +inf.0) expr? (and expr? (zero? quote-depth)))
(let*-values ([(l) (sort (hash-map (syntax-e c) cons) (let*-values ([(l) (sort (hash-map (syntax-e c) cons)
(lambda (a b) (lambda (a b)
(< (or (syntax-position (cdr a)) -inf.0) (< (or (syntax-position (cdr a)) -inf.0)
(or (syntax-position (cdr b)) -inf.0))))] (or (syntax-position (cdr b)) -inf.0))))]
[(col0) (+ (syntax-column c) delta 2)] [(sep cap) (if (and expr? (zero? quote-depth))
(values 1 0)
(values 3 1))]
[(col0) (+ (syntax-column c) delta cap 1)]
[(l2 pos line) (for/fold ([l2 null][col col0][line (syntax-line c)]) [(l2 pos line) (for/fold ([l2 null][col col0][line (syntax-line c)])
([p (in-list l)]) ([p (in-list l)])
(let* ([tentative (syntax-ize (car p) 0)] (let* ([tentative (syntax-ize (car p) 0
#:expr? (and expr? (zero? quote-depth)))]
[width (syntax-span tentative)] [width (syntax-span tentative)]
[col (if (= line (syntax-line (cdr p))) [col (if (= line (syntax-line (cdr p)))
col col
@ -641,8 +695,9 @@
(let ([e (syntax-ize (car p) (let ([e (syntax-ize (car p)
(max 0 (- (syntax-column (cdr p)) (max 0 (- (syntax-column (cdr p))
width width
3)) sep))
(syntax-line (cdr p)))]) (syntax-line (cdr p))
#:expr? (and expr? (zero? quote-depth)))])
(if ((syntax-column e) . <= . col) (if ((syntax-column e) . <= . col)
e e
(datum->syntax #f (datum->syntax #f
@ -658,17 +713,42 @@
(make-forced-pair key (cdr p)) (make-forced-pair key (cdr p))
(vector 'here (vector 'here
(syntax-line (cdr p)) (syntax-line (cdr p))
(max 0 (- (syntax-column key) 1)) (max 0 (- (syntax-column key) cap))
(max 1 (- (syntax-position key) 1)) (max 1 (- (syntax-position key) cap))
(+ (syntax-span (cdr p)) (syntax-span key) 5)))]) (+ (syntax-span (cdr p)) (syntax-span key) sep cap cap)))])
(values (cons elem l2) (values (cons elem l2)
(+ (syntax-column elem) (syntax-span elem) 2) (+ (syntax-column elem) (syntax-span elem) 2)
(syntax-line elem))))))]) (syntax-line elem))))))])
(if (and expr? (zero? quote-depth))
;; constructed:
(let ([l (apply append
(map (lambda (p)
(let ([p (syntax-e p)])
(list (forced-pair-car p)
(forced-pair-cdr p))))
(reverse l2)))])
(datum->syntax
#f
(cons (let ([s (if equal-table?
'hash
(if eqv-table?
'hasheqv
'hasheq))])
(datum->syntax #f
s
(vector (syntax-source c)
(syntax-line c)
(+ (syntax-column c) 1)
(+ (syntax-position c) 1)
(string-length (symbol->string s)))))
l)
c))
;; quoted:
(datum->syntax #f (reverse l2) (vector (syntax-source c) (datum->syntax #f (reverse l2) (vector (syntax-source c)
(syntax-line c) (syntax-line c)
(+ (syntax-column c) delta) (+ (syntax-column c) delta)
(+ (syntax-position c) delta) (+ (syntax-position c) delta)
(max 1 (- (syntax-span c) delta)))))) (max 1 (- (syntax-span c) delta)))))))
(set! src-col (+ orig-col (syntax-span c)))))] (set! src-col (+ orig-col (syntax-span c)))))]
[(graph-reference? (syntax-e c)) [(graph-reference? (syntax-e c))
(advance c init-line!) (advance c init-line!)
@ -685,22 +765,22 @@
value-color value-color
paren-color)) paren-color))
(set! src-col (+ src-col 3)) (set! src-col (+ src-col 3))
((loop init-line! quote-depth qq?) (graph-defn-r (syntax-e c))))] ((loop init-line! quote-depth expr? #f) (graph-defn-r (syntax-e c))))]
[(and (keyword? (syntax-e c)) qq?) [(and (keyword? (syntax-e c)) expr?)
(advance c init-line!) (advance c init-line!)
(let ([quote-depth (to-quoted "`" qq? quote-depth out color? inc-src-col)]) (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
(typeset-atom c out color? quote-depth qq?) (typeset-atom c out color? quote-depth expr?)
(set! src-col (+ src-col (or (syntax-span c) 1))))] (set! src-col (+ src-col (or (syntax-span c) 1))))]
[else [else
(advance c init-line!) (advance c init-line!)
(typeset-atom c out color? quote-depth qq?) (typeset-atom c out color? quote-depth expr?)
(set! src-col (+ src-col (or (syntax-span c) 1))) (set! src-col (+ src-col (or (syntax-span c) 1)))
#; #;
(hash-set! next-col-map src-col dest-col)]))) (hash-set! next-col-map src-col dest-col)])))
(out prefix1 #f) (out prefix1 #f)
(set! dest-col 0) (set! dest-col 0)
(hash-set! next-col-map init-col dest-col) (hash-set! next-col-map init-col dest-col)
((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0 qq?) c) ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0 expr? #f) c)
(if (list? suffix) (if (list? suffix)
(map (lambda (sfx) (map (lambda (sfx)
(finish-line!) (finish-line!)
@ -715,12 +795,13 @@
(make-table block-color (map list (reverse docs)))) (make-table block-color (map list (reverse docs))))
(make-sized-element #f (reverse content) dest-col)))) (make-sized-element #f (reverse content) dest-col))))
(define (typeset c multi-line? prefix1 prefix suffix color? qq?) (define (typeset c multi-line? prefix1 prefix suffix color? expr?)
(let* ([c (syntax-ize c 0 #:qq? qq?)] (let* ([c (syntax-ize c 0 #:expr? expr?)]
[s (syntax-e c)]) [s (syntax-e c)])
(if (or multi-line? (if (or multi-line?
(eq? 'code:blank s) (eq? 'code:blank s)
(pair? s) (pair? s)
(mpair? s)
(vector? s) (vector? s)
(struct? s) (struct? s)
(box? s) (box? s)
@ -729,9 +810,9 @@
(graph-defn? s) (graph-defn? s)
(graph-reference? s) (graph-reference? s)
(struct-proxy? s) (struct-proxy? s)
(and qq? (or (identifier? c) (and expr? (or (identifier? c)
(keyword? (syntax-e c))))) (keyword? (syntax-e c)))))
(gen-typeset c multi-line? prefix1 prefix suffix color? qq?) (gen-typeset c multi-line? prefix1 prefix suffix color? expr?)
(typeset-atom c (typeset-atom c
(letrec ([mk (letrec ([mk
(case-lambda (case-lambda
@ -743,19 +824,19 @@
(make-element/cache (and color? color) elem) (make-element/cache (and color? color) elem)
(make-sized-element (and color? color) elem len))])]) (make-sized-element (and color? color) elem len))])])
mk) mk)
color? 0 qq?)))) color? 0 expr?))))
(define (to-element c #:qq? [qq? #f]) (define (to-element c #:expr? [expr? #f])
(typeset c #f "" "" "" #t qq?)) (typeset c #f "" "" "" #t expr?))
(define (to-element/no-color c #:qq? [qq? #f]) (define (to-element/no-color c #:expr? [expr? #f])
(typeset c #f "" "" "" #f qq?)) (typeset c #f "" "" "" #f expr?))
(define (to-paragraph c #:qq? [qq? #f]) (define (to-paragraph c #:expr? [expr? #f])
(typeset c #t "" "" "" #t qq?)) (typeset c #t "" "" "" #t expr?))
(define ((to-paragraph/prefix pfx1 pfx sfx) c #:qq? [qq? #f]) (define ((to-paragraph/prefix pfx1 pfx sfx) c #:expr? [expr? #f])
(typeset c #t pfx1 pfx sfx #t qq?)) (typeset c #t pfx1 pfx sfx #t expr?))
(begin-for-syntax (begin-for-syntax
(define-struct variable-id (sym) (define-struct variable-id (sym)
@ -886,8 +967,8 @@
(define-struct graph-reference (bx)) (define-struct graph-reference (bx))
(define-struct graph-defn (r bx)) (define-struct graph-defn (r bx))
(define (syntax-ize v col [line 1] #:qq? [qq? #f]) (define (syntax-ize v col [line 1] #:expr? [expr? #f])
(do-syntax-ize v col line (box #hasheq()) #f (and qq? 0))) (do-syntax-ize v col line (box #hasheq()) #f (and expr? 0) #f))
(define (graph-count ht graph?) (define (graph-count ht graph?)
(and graph? (and graph?
@ -897,23 +978,46 @@
(define-struct forced-pair (car cdr)) (define-struct forced-pair (car cdr))
(define (do-syntax-ize v col line ht graph? qq) (define (quotable? v)
(cond
[(syntax? v) (quotable? (syntax-e v))]
[(pair? v) (and (quotable? (car v))
(quotable? (cdr v)))]
[(vector? v) (andmap quotable? (vector->list v))]
[(hash? v) (for/and ([(k v) (in-hash v)])
(and (quotable? k)
(quotable? v)))]
[(box? v) (quotable? (unbox v))]
[(and (struct? v)
(prefab-struct-key v))
(andmap quotable? (vector->list (struct->vector v)))]
[(struct? v) (if (custom-write? v)
(if (and (custom-print-as-constructor? v)
(custom-print-as-constructor-accessor v))
#f
#t)
#f)]
[(struct-proxy? v) #f]
[(mpair? v) #f]
[else #t]))
(define (do-syntax-ize v col line ht graph? qq no-cons?)
(cond (cond
[((syntax-ize-hook) v col) [((syntax-ize-hook) v col)
=> (lambda (r) r)] => (lambda (r) r)]
[(shaped-parens? v) [(shaped-parens? v)
(syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f qq) (syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f qq #f)
'paren-shape 'paren-shape
(shaped-parens-shape v))] (shaped-parens-shape v))]
[(just-context? v) [(just-context? v)
(let ([s (do-syntax-ize (just-context-val v) col line ht #f qq)]) (let ([s (do-syntax-ize (just-context-val v) col line ht #f qq #f)])
(datum->syntax (just-context-ctx v) (datum->syntax (just-context-ctx v)
(syntax-e s) (syntax-e s)
s s
s s
(just-context-ctx v)))] (just-context-ctx v)))]
[(alternate-display? v) [(alternate-display? v)
(let ([s (do-syntax-ize (alternate-display-id v) col line ht #f qq)]) (let ([s (do-syntax-ize (alternate-display-id v) col line ht #f qq #f)])
(syntax-property s (syntax-property s
'display-string 'display-string
(alternate-display-string v)))] (alternate-display-string v)))]
@ -924,30 +1028,49 @@
(datum->syntax #f (datum->syntax #f
(make-graph-reference m) (make-graph-reference m)
(vector #f line col (+ 1 col) 1)))] (vector #f line col (+ 1 col) 1)))]
[(and qq
(zero? qq)
(or (pair? v)
(forced-pair? v)
(vector? v)
(hash? v)
(box? v)
(and (struct? v)
(prefab-struct-key v)))
(quotable? v)
(not no-cons?))
;; Add a quote:
(let ([l (do-syntax-ize v (add1 col) line ht #f 1 #f)])
(datum->syntax #f
(syntax-e l)
(vector (syntax-source l)
(syntax-line l)
(sub1 (syntax-column l))
(max 0 (sub1 (syntax-position l)))
(add1 (syntax-span l)))))]
[(and (list? v) [(and (list? v)
(pair? v) (pair? v)
(or (not qq)
(positive? qq)
(quotable? v))
(let ([s (let ([s (car v)]) (let ([s (let ([s (car v)])
(if (just-context? s) (if (just-context? s)
(just-context-val s) (just-context-val s)
s))]) s))])
(and (memq s '(quote unquote unquote-splicing)))
(or (memq s '(quaisquote quote)) (not no-cons?))
(and (memq s '(unquote unquote-splicing))
(or (not qq)
(qq . > . 2))))
s)))
=> (lambda (s) => (lambda (s)
(let ([c (do-syntax-ize (cadr v) (+ col 1) line ht #f qq)]) (let* ([delta (if (and qq (zero? qq))
1
0)]
[c (do-syntax-ize (cadr v) (+ col delta) line ht #f qq #f)])
(datum->syntax #f (datum->syntax #f
(list (do-syntax-ize (car v) col line ht #f (list (do-syntax-ize (car v) col line ht #f qq #f)
(and qq
(case s
[(quaisquote) (add1 qq)]
[(unquote unquote-splicing) (sub1 qq)]
[else qq])))
c) c)
(vector #f line col (+ 1 col) (vector #f line col (+ 1 col)
(+ 1 (syntax-span c))))))] (+ 1
(if (and qq (zero? qq)) 1 0)
(syntax-span c))))))]
[(or (list? v) [(or (list? v)
(vector? v) (vector? v)
(and (struct? v) (and (struct? v)
@ -956,21 +1079,28 @@
(not (element? v))) (not (element? v)))
(prefab-struct-key v)))) (prefab-struct-key v))))
(let ([orig-ht (unbox ht)] (let ([orig-ht (unbox ht)]
[graph-box (box (graph-count ht graph?))] [graph-box (box (graph-count ht graph?))])
[qq (and qq (max 1 qq))])
(set-box! ht (hash-set (unbox ht) v graph-box)) (set-box! ht (hash-set (unbox ht) v graph-box))
(let* ([graph-sz (if graph? (let* ([graph-sz (if graph?
(+ 2 (string-length (format "~a" (unbox graph-box)))) (+ 2 (string-length (format "~a" (unbox graph-box))))
0)] 0)]
[vec-sz (cond [vec-sz (cond
[(vector? v) [(vector? v)
(+ 1 #;(string-length (format "~a" (vector-length v))))] (if (and qq (zero? qq)) 0 1)]
[(struct? v) [(struct? v)
(if (prefab-struct-key v) (if (and (prefab-struct-key v)
(or (not qq) (positive? qq)))
2 2
0)] 0)]
[else 0])] [else 0])]
[r (let ([l (let loop ([col (+ col 1 vec-sz graph-sz)] [delta (if (and qq (zero? qq))
(cond
[(vector? v) 8]
[(struct? v) 1]
[no-cons? 1]
[else 5])
1)]
[r (let ([l (let loop ([col (+ col delta vec-sz graph-sz)]
[v (cond [v (cond
[(vector? v) [(vector? v)
(vector->short-list v values)] (vector->short-list v values)]
@ -983,7 +1113,7 @@
[else v])]) [else v])])
(if (null? v) (if (null? v)
null null
(let ([i (do-syntax-ize (car v) col line ht #f qq)]) (let ([i (do-syntax-ize (car v) col line ht #f qq #f)])
(cons i (cons i
(loop (+ col 1 (syntax-span i)) (cdr v))))))]) (loop (+ col 1 (syntax-span i)) (cdr v))))))])
(datum->syntax #f (datum->syntax #f
@ -998,8 +1128,9 @@
(vector #f line (vector #f line
(+ graph-sz col) (+ graph-sz col)
(+ 1 graph-sz col) (+ 1 graph-sz col)
(+ 2 (+ 1
vec-sz vec-sz
delta
(if (zero? (length l)) (if (zero? (length l))
0 0
(sub1 (length l))) (sub1 (length l)))
@ -1016,55 +1147,85 @@
[(unbox graph-box) [(unbox graph-box)
;; Go again, this time knowing that there will be a graph: ;; Go again, this time knowing that there will be a graph:
(set-box! ht orig-ht) (set-box! ht orig-ht)
(do-syntax-ize v col line ht #t qq)] (do-syntax-ize v col line ht #t qq #f)]
[else r])))] [else r])))]
[(or (pair? v) [(or (pair? v)
(mpair? v)
(forced-pair? v)) (forced-pair? v))
(let ([carv (if (pair? v) (car v) (forced-pair-car v))] (let ([carv (if (pair? v) (car v) (if (mpair? v) (mcar v) (forced-pair-car v)))]
[cdrv (if (pair? v) (cdr v) (forced-pair-cdr v))] [cdrv (if (pair? v) (cdr v) (if (mpair? v) (mcdr v) (forced-pair-cdr v)))]
[orig-ht (unbox ht)] [orig-ht (unbox ht)]
[graph-box (box (graph-count ht graph?))] [graph-box (box (graph-count ht graph?))])
[qq (and qq (max 1 qq))])
(set-box! ht (hash-set (unbox ht) v graph-box)) (set-box! ht (hash-set (unbox ht) v graph-box))
(let* ([inc (if graph? (let* ([delta (if (and qq (zero? qq) (not no-cons?))
(if (mpair? v)
7 ; "(mcons "
(if (or (list? cdrv)
(not (pair? cdrv)))
6 ; "(cons "
7)) ; "(list* "
1)]
[inc (if graph?
(+ 2 (string-length (format "~a" (unbox graph-box)))) (+ 2 (string-length (format "~a" (unbox graph-box))))
0)] 0)]
[a (do-syntax-ize carv (+ col 1 inc) line ht #f qq)] [a (do-syntax-ize carv (+ col delta inc) line ht #f qq #f)]
[sep (if (and (pair? v) [sep (if (and (pair? v)
(pair? cdrv) (pair? cdrv)
;; FIXME: what if it turns out to be a graph reference? ;; FIXME: what if it turns out to be a graph reference?
(not (hash-ref (unbox ht) cdrv #f))) (not (hash-ref (unbox ht) cdrv #f)))
0 0
3)] (if (and qq (zero? qq))
[b (do-syntax-ize cdrv (+ col 1 inc (syntax-span a) sep) line ht #f qq)]) 1
3))]
[b (do-syntax-ize cdrv (+ col delta inc (syntax-span a) sep) line ht #f qq #t)])
(let ([r (datum->syntax #f (let ([r (datum->syntax #f
(cons a b) (if (mpair? v)
(vector #f line (+ col inc) (+ 1 col inc) (mcons a b)
(+ 2 sep (syntax-span a) (syntax-span b))))]) (cons a b))
(vector #f line (+ col inc) (+ delta col inc)
(+ 1 delta
(if (and qq (zero? qq)) 1 0)
sep (syntax-span a) (syntax-span b))))])
(unless graph? (unless graph?
(set-box! ht (hash-set (unbox ht) v #f))) (set-box! ht (hash-set (unbox ht) v #f)))
(cond (cond
[graph? (datum->syntax #f [graph? (datum->syntax #f
(make-graph-defn r graph-box) (make-graph-defn r graph-box)
(vector #f line col (+ 1 col) (vector #f line col (+ delta col)
(+ inc (syntax-span r))))] (+ inc (syntax-span r))))]
[(unbox graph-box) [(unbox graph-box)
;; Go again... ;; Go again...
(set-box! ht orig-ht) (set-box! ht orig-ht)
(do-syntax-ize v col line ht #t qq)] (do-syntax-ize v col line ht #t qq #f)]
[else r]))))] [else r]))))]
[(box? v) [(box? v)
(let ([a (do-syntax-ize (unbox v) (+ col 2) line ht #f (and qq (max 1 qq)))]) (let* ([delta (if (and qq (zero? qq))
5 ; "(box "
2)] ; "#&"
[a (do-syntax-ize (unbox v) (+ col delta) line ht #f qq #f)])
(datum->syntax #f (datum->syntax #f
(box a) (box a)
(vector #f line col (+ 1 col) (vector #f line col (+ 1 col)
(+ 2 (syntax-span a)))))] (+ delta (if (and qq (zero? qq)) 1 0) (syntax-span a)))))]
[(hash? v) [(hash? v)
(let* ([delta (cond (let* ([delta (cond
[(hash-eq? v) 7] [(hash-eq? v) 7]
[(hash-eqv? v) 8] [(hash-eqv? v) 8]
[else 6])] [else 6])]
[pairs (do-syntax-ize (hash-map v make-forced-pair) (+ col delta) line ht #f (and qq (max 1 qq)))]) [undelta (if (and qq (zero? qq))
(- delta 1)
0)]
[pairs (if (and qq (zero? qq))
(let ([ls (do-syntax-ize (apply append (hash-map v (lambda (k v) (list k v))))
(+ col delta -1) line ht #f qq #t)])
(datum->syntax
#f
(let loop ([l (syntax->list ls)])
(if (null? l)
null
(cons (cons (car l) (cadr l)) (loop (cddr l)))))
ls))
(do-syntax-ize (hash-map v make-forced-pair) (+ col delta) line ht #f qq #f))])
(datum->syntax #f (datum->syntax #f
((cond ((cond
[(hash-eq? v) make-immutable-hasheq] [(hash-eq? v) make-immutable-hasheq]
@ -1075,6 +1236,10 @@
(cons (syntax->datum (car p)) (cons (syntax->datum (car p))
(cdr p)))) (cdr p))))
(syntax->list pairs))) (syntax->list pairs)))
pairs))] (vector (syntax-source pairs)
(syntax-line pairs)
(max 0 (- (syntax-column pairs) undelta))
(max 1 (- (syntax-position pairs) undelta))
(+ (syntax-span pairs) undelta))))]
[else [else
(datum->syntax #f v (vector #f line col (+ 1 col) 1))]))) (datum->syntax #f v (vector #f line col (+ 1 col) 1))])))