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

decent Scribble rendering of hash tables

Browse Source
This commit is contained in:
Matthew Flatt 2010-04-23 08:11:56 -06:00
parent 909f43f9a2
commit 12b95ece4c
1 changed files with 147 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

229
collects/scribble/racket.ss
View File

@ -489,6 +489,7 @@
=> (lambda (converted) => (lambda (converted)
((loop init-line! quote-depth qq?) converted))] ((loop init-line! quote-depth qq?) converted))]
[(or (pair? (syntax-e c)) [(or (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))
(and (struct? (syntax-e c)) (and (struct? (syntax-e c))
@ -513,85 +514,92 @@
(to-quoted "`" qq? quote-depth out color? inc-src-col))]) (to-quoted "`" qq? quote-depth out color? inc-src-col))])
(when (vector? (syntax-e c)) (when (vector? (syntax-e c))
(let ([vec (syntax-e c)]) (let ([vec (syntax-e c)])
(out "#" #;(format "#~a" (vector-length vec)) p-color) (out "#" #; (format "#~a" (vector-length vec)) 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))
(out "#s" p-color) (out "#s" p-color)
(set! src-col (+ src-col 2))) (set! src-col (+ src-col 2)))
(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
[(vector? (syntax-e c)) [(vector? (syntax-e c))
(vector->short-list (syntax-e c) syntax-e)] (vector->short-list (syntax-e c) syntax-e)]
[(struct? (syntax-e c)) [(struct? (syntax-e c))
(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:
(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))]
[end (if (pair? (cdr l)) [end (if (pair? (cdr l))
(and (equal? (syntax-line c) (syntax-line (cadr l))) (and (equal? (syntax-line c) (syntax-line (cadr l)))
(syntax-column (cadr l))) (syntax-column (cadr l)))
(and (syntax-column c) (and (syntax-column c)
(+ (syntax-column c) (syntax-span c))))]) (+ (syntax-column c) (syntax-span c))))])
(if end (if end
(datum->syntax #f (datum->syntax #f
(syntax-e key) (syntax-e key)
(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)))) (- end 1 (syntax-column key))))
end)) end))
(cdr l)))] (cdr l)))]
[(struct-proxy? (syntax-e c)) [(struct-proxy? (syntax-e c))
(cons (cons
(struct-proxy-name (syntax-e c)) (struct-proxy-name (syntax-e c))
(struct-proxy-content (syntax-e c)))] (struct-proxy-content (syntax-e c)))]
[else c])] [(forced-pair? (syntax-e c))
[first-qq? (and qq? (not (struct-proxy? (syntax-e c))))]) (syntax-e c)]
(cond [else c])]
[(and (syntax? l) [first-qq? (and qq? (not (struct-proxy? (syntax-e c))))]
(pair? (syntax-e l)) [dotted? #f])
(not (and (memq (syntax-e (car (syntax-e l))) (cond
'(quote unquote syntax unsyntax quasiquote quasiunsyntax)) [(and (syntax? l)
(let ([v (syntax->list l)]) (pair? (syntax-e l))
(and v (= 2 (length v)))) (not dotted?)
(or (not qq?) (not (and (memq (syntax-e (car (syntax-e l)))
(quote-depth . > . 1) '(quote unquote syntax unsyntax quasiquote quasiunsyntax))
(not (memq (syntax-e (car (syntax-e l))) (let ([v (syntax->list l)])
'(unquote unquote-splicing))))))) (and v (= 2 (length v))))
(lloop (syntax-e l) first-qq?)] (or (not qq?)
[(or (null? l) (quote-depth . > . 1)
(and (syntax? l) (not (memq (syntax-e (car (syntax-e l)))
(null? (syntax-e l)))) '(unquote unquote-splicing)))))))
(void)] (lloop (syntax-e l) first-qq? #f)]
[(pair? l) [(or (null? l)
((loop init-line! quote-depth first-qq?) (car l)) (and (syntax? l)
(lloop (cdr l) qq?)] (null? (syntax-e l))))
[else (void)]
(advance l init-line! -2) [(and (pair? l) (not dotted?))
(out ". " (if (positive? quote-depth) value-color paren-color)) ((loop init-line! quote-depth first-qq?) (car l))
(set! src-col (+ src-col 3)) (lloop (cdr l) qq? #f)]
(hash-set! next-col-map src-col dest-col) [(forced-pair? l)
((loop init-line! quote-depth first-qq?) l)])) ((loop init-line! quote-depth first-qq?) (forced-pair-car l))
(out (case sh (lloop (forced-pair-cdr l) qq? #t)]
[(#\[ #\?) "]"] [else
[(#\{) "}"] (advance l init-line! -2)
[else ")"]) (out ". " (if (positive? quote-depth) value-color paren-color))
p-color) (set! src-col (+ src-col 3))
(set! src-col (+ src-col 1)) (hash-set! next-col-map src-col dest-col)
#; ((loop init-line! quote-depth first-qq?) l)]))
(hash-set! next-col-map src-col dest-col)))] (out (case sh
[(#\[ #\?) "]"]
[(#\{) "}"]
[else ")"])
p-color)
(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 "`" qq? quote-depth out color? inc-src-col)])
@ -612,8 +620,32 @@
(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 qq? quote-depth +inf.0) qq?)
(syntax-ize (hash-map (syntax-e c) cons) (let* ([l (sort (hash-map (syntax-e c) cons)
(+ (syntax-column c) delta))) (lambda (a b)
(< (or (syntax-position (cdr a)) -inf.0)
(or (syntax-position (cdr b)) -inf.0))))]
[l2 (for/list ([p (in-list l)])
(let* ([tentative (syntax-ize (car p) 0)]
[width (syntax-span tentative)])
(datum->syntax
#f
(make-forced-pair
(syntax-ize (car p)
(max 0 (- (syntax-column (cdr p))
width
3))
(syntax-line (cdr p)))
(cdr p))
(vector 'here
(syntax-line (cdr p))
(max 0 (- (syntax-column (cdr p)) width 4))
(max 1 (- (syntax-position (cdr p)) width 4))
(+ (syntax-span (cdr p)) width 5)))))])
(datum->syntax #f l2 (vector (syntax-source c)
(syntax-line c)
(+ (syntax-column c) delta)
(+ (syntax-position 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!)
@ -760,6 +792,16 @@
stx->loc-s-expr stx->loc-s-expr
(cdr (vector->list (struct->vector v)))))] (cdr (vector->list (struct->vector v)))))]
[(box? v) `(box ,(stx->loc-s-expr (unbox v)))] [(box? v) `(box ,(stx->loc-s-expr (unbox v)))]
[(hash? v) `(,(cond
[(hash-eq? v) 'make-immutable-hasheq]
[(hash-eqv? v) 'make-immutable-hasheqv]
[else 'make-immutable-hash])
(list
,@(hash-map
v
(lambda (k v)
`(cons (quote ,k)
,(stx->loc-s-expr v))))))]
[else `(quote ,v)]))) [else `(quote ,v)])))
(define (cvt s) (define (cvt s)
(datum->syntax #'here (stx->loc-s-expr s) #f)) (datum->syntax #'here (stx->loc-s-expr s) #f))
@ -823,6 +865,8 @@
(set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n))) (set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n)))
n))) n)))
(define-struct forced-pair (car cdr))
(define (do-syntax-ize v col line ht graph? qq) (define (do-syntax-ize v col line ht graph? qq)
(cond (cond
[((syntax-ize-hook) v col) [((syntax-ize-hook) v col)
@ -944,21 +988,25 @@
(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)]
[else r])))] [else r])))]
[(pair? v) [(or (pair? v)
(let ([orig-ht (unbox ht)] (forced-pair? v))
(let ([carv (if (pair? v) (car v) (forced-pair-car v))]
[cdrv (if (pair? v) (cdr v) (forced-pair-cdr v))]
[orig-ht (unbox ht)]
[graph-box (box (graph-count ht graph?))] [graph-box (box (graph-count ht graph?))]
[qq (and qq (max 1 qq))]) [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* ([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 (car v) (+ col 1 inc) line ht #f qq)] [a (do-syntax-ize carv (+ col 1 inc) line ht #f qq)]
[sep (if (and (pair? (cdr v)) [sep (if (and (pair? v)
(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) (cdr v) #f))) (not (hash-ref (unbox ht) cdrv #f)))
0 0
3)] 3)]
[b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) line ht #f qq)]) [b (do-syntax-ize cdrv (+ col 1 inc (syntax-span a) sep) line ht #f qq)])
(let ([r (datum->syntax #f (let ([r (datum->syntax #f
(cons a b) (cons a b)
(vector #f line (+ col inc) (+ 1 col inc) (vector #f line (+ col inc) (+ 1 col inc)
@ -981,5 +1029,22 @@
(box a) (box a)
(vector #f line col (+ 1 col) (vector #f line col (+ 1 col)
(+ 2 (syntax-span a)))))] (+ 2 (syntax-span a)))))]
[(hash? v)
(let* ([delta (cond
[(hash-eq? v) 7]
[(hash-eqv? v) 8]
[else 6])]
[pairs (do-syntax-ize (hash-map v make-forced-pair) (+ col delta) line ht #f (and qq (max 1 qq)))])
(datum->syntax #f
((cond
[(hash-eq? v) make-immutable-hasheq]
[(hash-eqv? v) make-immutable-hasheqv]
[else make-immutable-hash])
(map (lambda (p)
(let ([p (syntax-e p)])
(cons (syntax->datum (car p))
(cdr p))))
(syntax->list pairs)))
pairs))]
[else [else
(datum->syntax #f v (vector #f line col (+ 1 col) 1))]))) (datum->syntax #f v (vector #f line col (+ 1 col) 1))])))