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

fix Scribble rendering of S-expression graphs

Browse Source 
svn: r14886
This commit is contained in:
Matthew Flatt 2009-05-20 22:05:09 +00:00
parent f23ee1965e
commit f1d4fe02ea
1 changed files with 58 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
collects/scribble/scheme.ss
View File

@ -529,13 +529,15 @@
(+ (syntax-column c) delta))) (+ (syntax-column 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!)
(out (format "#~a#" (unbox (graph-reference-bx (syntax-e c)))) (out (format "#~a#" (unbox (graph-reference-bx (syntax-e c))))
(if (positive? quote-depth) (if (positive? quote-depth)
value-color value-color
paren-color))] paren-color))
(set! src-col (+ src-col (syntax-span c)))]
[(graph-defn? (syntax-e c)) [(graph-defn? (syntax-e c))
(advance c init-line!)
(let ([bx (graph-defn-bx (syntax-e c))]) (let ([bx (graph-defn-bx (syntax-e c))])
(set-box! bx 0)
(out (format "#~a=" (unbox bx)) (out (format "#~a=" (unbox bx))
(if (positive? quote-depth) (if (positive? quote-depth)
value-color value-color
@ -723,12 +725,12 @@
(define-struct graph-defn (r bx)) (define-struct graph-defn (r bx))
(define (syntax-ize v col [line 1]) (define (syntax-ize v col [line 1])
(do-syntax-ize v col line (make-hasheq) #f)) (do-syntax-ize v col line (box #hasheq()) #f))
(define (graph-count ht graph?) (define (graph-count ht graph?)
(and graph? (and graph?
(let ([n (hash-ref ht '#%graph-count 0)]) (let ([n (hash-ref (unbox ht) '#%graph-count 0)])
(hash-set! ht '#%graph-count (add1 n)) (set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n)))
n))) n)))
(define (do-syntax-ize v col line ht graph?) (define (do-syntax-ize v col line ht graph?)
@ -746,7 +748,7 @@
s s
s s
(just-context-ctx v)))] (just-context-ctx v)))]
[(hash-ref ht v #f) [(hash-ref (unbox ht) v #f)
=> (lambda (m) => (lambda (m)
(unless (unbox m) (unless (unbox m)
(set-box! m #t)) (set-box! m #t))
@ -770,62 +772,70 @@
(vector? v) (vector? v)
(and (struct? v) (and (struct? v)
(prefab-struct-key v))) (prefab-struct-key v)))
(let ([graph-box (box (graph-count ht graph?))]) (let ([orig-ht (unbox ht)]
(hash-set! ht v graph-box) [graph-box (box (graph-count ht graph?))])
(let ([r (let* ([vec-sz (+ (if graph? (set-box! ht (hash-set (unbox ht) v graph-box))
(+ 2 (string-length (format "~a" (unbox graph-box)))) (let* ([graph-sz (if graph?
0) (+ 2 (string-length (format "~a" (unbox graph-box))))
0)]
[vec-sz (cond
[(vector? v)
(+ 1 #;(string-length (format "~a" (vector-length v))))]
[(struct? v) 2]
[else 0])]
[r (let ([l (let loop ([col (+ col 1 vec-sz graph-sz)]
[v (cond
[(vector? v)
(vector->short-list v values)]
[(struct? v)
(cons (prefab-struct-key v)
(cdr (vector->list (struct->vector v))))]
[else v])])
(if (null? v)
null
(let ([i (do-syntax-ize (car v) col line ht #f)])
(cons i
(loop (+ col 1 (syntax-span i)) (cdr v))))))])
(datum->syntax #f
(cond (cond
[(vector? v) [(vector? v) (short-list->vector v l)]
(+ 1 #;(string-length (format "~a" (vector-length v))))] [(struct? v)
[(struct? v) 2] (apply make-prefab-struct (prefab-struct-key v) (cdr l))]
[else 0]))]) [else l])
(let ([l (let loop ([col (+ col 1 vec-sz)] (vector #f line
[v (cond (+ graph-sz col)
[(vector? v) (+ 1 graph-sz col)
(vector->short-list v values)] (+ 2
[(struct? v) vec-sz
(cons (prefab-struct-key v) (if (zero? (length l))
(cdr (vector->list (struct->vector v))))] 0
[else v])]) (sub1 (length l)))
(if (null? v) (apply + (map syntax-span l))))))])
null
(let ([i (do-syntax-ize (car v) col line ht #f)])
(cons i
(loop (+ col 1 (syntax-span i)) (cdr v))))))])
(datum->syntax #f
(cond
[(vector? v) (short-list->vector v l)]
[(struct? v)
(apply make-prefab-struct (prefab-struct-key v) (cdr l))]
[else l])
(vector #f line col (+ 1 col)
(+ 2
vec-sz
(if (zero? (length l))
0
(sub1 (length l)))
(apply + (map syntax-span l)))))))])
(unless graph? (unless graph?
(hash-set! 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)
r)] (vector #f (syntax-line r)
(- (syntax-column r) graph-sz)
(- (syntax-position r) graph-sz)
(+ (syntax-span r) graph-sz)))]
[(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)
(do-syntax-ize v col line ht #t)] (do-syntax-ize v col line ht #t)]
[else r])))] [else r])))]
[(pair? v) [(pair? v)
(let ([graph-box (box (graph-count ht graph?))]) (let ([orig-ht (unbox ht)]
(hash-set! ht v graph-box) [graph-box (box (graph-count ht graph?))])
(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)] [a (do-syntax-ize (car v) (+ col 1 inc) line ht #f)]
[sep (if (and (pair? (cdr v)) [sep (if (and (pair? (cdr v))
;; 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 ht (cdr v) #f))) (not (hash-ref (unbox ht) (cdr v) #f)))
0 0
3)] 3)]
[b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) line ht #f)]) [b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) line ht #f)])
@ -834,7 +844,7 @@
(vector #f line (+ col inc) (+ 1 col inc) (vector #f line (+ col inc) (+ 1 col inc)
(+ 2 sep (syntax-span a) (syntax-span b))))]) (+ 2 sep (syntax-span a) (syntax-span b))))])
(unless graph? (unless graph?
(hash-set! 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)
@ -842,6 +852,7 @@
(+ inc (syntax-span r))))] (+ inc (syntax-span r))))]
[(unbox graph-box) [(unbox graph-box)
;; Go again... ;; Go again...
(set-box! ht orig-ht)
(do-syntax-ize v col line ht #t)] (do-syntax-ize v col line ht #t)]
[else r]))))] [else r]))))]
[(box? v) [(box? v)