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

prefab structure types (3.99.0.18)

Browse Source 
svn: r8967

original commit: 293ba025bad3b0341715153f8cbfd37f4d871a38
This commit is contained in:
Matthew Flatt 2008-03-13 20:59:22 +00:00
parent 91eee31910
commit 4fe7eea393
1 changed files with 90 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
collects/scribble/scheme.ss
View File

@ -393,10 +393,14 @@
((loop init-line! quote-depth) converted))] ((loop init-line! quote-depth) converted))]
[(or (pair? (syntax-e c)) [(or (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))
(prefab-struct-key (syntax-e c))))
(let* ([sh (or (syntax-property c 'paren-shape) (let* ([sh (or (syntax-property c 'paren-shape)
#\()] #\()]
[quote-depth (if (vector? (syntax-e c)) [quote-depth (if (and (zero? quote-depth)
(or (vector? (syntax-e c))
(struct? (syntax-e c))))
+inf.0 +inf.0
quote-depth)] quote-depth)]
[p-color (if (positive? quote-depth) [p-color (if (positive? quote-depth)
@ -413,6 +417,9 @@
(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))
(out "#s" p-color)
(set! src-col (+ src-col 2)))
(out (case sh (out (case sh
[(#\[ #\?) "["] [(#\[ #\?) "["]
[(#\{) "{"] [(#\{) "{"]
@ -420,9 +427,31 @@
p-color) p-color)
(set! src-col (+ src-col 1)) (set! src-col (+ src-col 1))
(hash-table-put! next-col-map src-col dest-col) (hash-table-put! next-col-map src-col dest-col)
(let lloop ([l (if (vector? (syntax-e c)) (let lloop ([l (cond
(vector->short-list (syntax-e c) syntax-e) [(vector? (syntax-e c))
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:
(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)
(- end 1 (syntax-column key))))
end))
(cdr l)))]
[else c])])
(cond (cond
[(and (syntax? l) [(and (syntax? l)
(pair? (syntax-e l)) (pair? (syntax-e l))
@ -516,6 +545,7 @@
(eq? 'code:blank s) (eq? 'code:blank s)
(pair? s) (pair? s)
(vector? s) (vector? s)
(struct? s)
(box? s) (box? s)
(null? s) (null? s)
(hash-table? s) (hash-table? s)
@ -574,6 +604,11 @@
[(vector? v) `(vector ,@(map [(vector? v) `(vector ,@(map
stx->loc-s-expr stx->loc-s-expr
(vector->list v)))] (vector->list v)))]
[(and (struct? v) (prefab-struct-key v))
`(make-prefab-struct (quote ,(prefab-struct-key v))
,@(map
stx->loc-s-expr
(cdr (vector->list (struct->vector v)))))]
[(box? v) `(box ,(stx->loc-s-expr (unbox v)))] [(box? v) `(box ,(stx->loc-s-expr (unbox v)))]
[(null? v) 'null] [(null? v) 'null]
[else `(quote ,v)])) [else `(quote ,v)]))
@ -623,8 +658,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) (define (syntax-ize v col [line 1])
(do-syntax-ize v col (make-hash-table) #f)) (do-syntax-ize v col line (make-hash-table) #f))
(define (graph-count ht graph?) (define (graph-count ht graph?)
(and graph? (and graph?
@ -632,16 +667,16 @@
(hash-table-put! ht '#%graph-count (add1 n)) (hash-table-put! ht '#%graph-count (add1 n))
n))) n)))
(define (do-syntax-ize v col ht graph?) (define (do-syntax-ize v col line ht graph?)
(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 ht #f) (syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #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 ht #f)]) (let ([s (do-syntax-ize (just-context-val v) col line ht #f)])
(datum->syntax (just-context-ctx v) (datum->syntax (just-context-ctx v)
(syntax-e s) (syntax-e s)
s s
@ -653,7 +688,7 @@
(set-box! m #t)) (set-box! m #t))
(datum->syntax #f (datum->syntax #f
(make-graph-reference m) (make-graph-reference m)
(list #f 1 col (+ 1 col) 1)))] (vector #f line col (+ 1 col) 1)))]
[(and (list? v) [(and (list? v)
(pair? v) (pair? v)
(memq (let ([s (car v)]) (memq (let ([s (car v)])
@ -661,42 +696,52 @@
(just-context-val s) (just-context-val s)
s)) s))
'(quote unquote unquote-splicing))) '(quote unquote unquote-splicing)))
(let ([c (do-syntax-ize (cadr v) (+ col 1) ht #f)]) (let ([c (do-syntax-ize (cadr v) (+ col 1) line ht #f)])
(datum->syntax #f (datum->syntax #f
(list (do-syntax-ize (car v) col ht #f) (list (do-syntax-ize (car v) col line ht #f)
c) c)
(list #f 1 col (+ 1 col) (vector #f line col (+ 1 col)
(+ 1 (syntax-span c)))))] (+ 1 (syntax-span c)))))]
[(or (list? v) [(or (list? v)
(vector? v)) (vector? v)
(and (struct? v)
(prefab-struct-key v)))
(let ([graph-box (box (graph-count ht graph?))]) (let ([graph-box (box (graph-count ht graph?))])
(hash-table-put! ht v graph-box) (hash-table-put! ht v graph-box)
(let ([r (let* ([vec-sz (+ (if graph? (let ([r (let* ([vec-sz (+ (if graph?
(+ 2 (string-length (format "~a" (unbox graph-box)))) (+ 2 (string-length (format "~a" (unbox graph-box))))
0) 0)
(if (vector? v) (cond
(+ 1 #;(string-length (format "~a" (vector-length v)))) [(vector? v)
0))]) (+ 1 #;(string-length (format "~a" (vector-length v))))]
[(struct? v) 2]
[else 0]))])
(let ([l (let loop ([col (+ col 1 vec-sz)] (let ([l (let loop ([col (+ col 1 vec-sz)]
[v (if (vector? v) [v (cond
(vector->short-list v values) [(vector? v)
v)]) (vector->short-list v values)]
[(struct? v)
(cons (prefab-struct-key v)
(cdr (vector->list (struct->vector v))))]
[else v])])
(if (null? v) (if (null? v)
null null
(let ([i (do-syntax-ize (car v) col ht #f)]) (let ([i (do-syntax-ize (car v) col line ht #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
(if (vector? v) (cond
(short-list->vector v l) [(vector? v) (short-list->vector v l)]
l) [(struct? v)
(list #f 1 col (+ 1 col) (apply make-prefab-struct (prefab-struct-key v) (cdr l))]
(+ 2 [else l])
vec-sz (vector #f line col (+ 1 col)
(if (zero? (length l)) (+ 2
0 vec-sz
(sub1 (length l))) (if (zero? (length l))
(apply + (map syntax-span l)))))))]) 0
(sub1 (length l)))
(apply + (map syntax-span l)))))))])
(unless graph? (unless graph?
(hash-table-put! ht v #f)) (hash-table-put! ht v #f))
(cond (cond
@ -705,7 +750,7 @@
r)] r)]
[(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:
(do-syntax-ize v col 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 ([graph-box (box (graph-count ht graph?))])
@ -713,33 +758,33 @@
(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) 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-table-get ht (cdr v) #f))) (not (hash-table-get ht (cdr v) #f)))
0 0
3)] 3)]
[b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) ht #f)]) [b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) line ht #f)])
(let ([r (datum->syntax #f (let ([r (datum->syntax #f
(cons a b) (cons a b)
(list #f 1 (+ 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-table-put! ht v #f)) (hash-table-put! 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)
(list #f 1 col (+ 1 col) (vector #f line col (+ 1 col)
(+ inc (syntax-span r))))] (+ inc (syntax-span r))))]
[(unbox graph-box) [(unbox graph-box)
;; Go again... ;; Go again...
(do-syntax-ize v col ht #t)] (do-syntax-ize v col line ht #t)]
[else r]))))] [else r]))))]
[(box? v) [(box? v)
(let ([a (do-syntax-ize (unbox v) (+ col 2) ht #f)]) (let ([a (do-syntax-ize (unbox v) (+ col 2) line ht #f)])
(datum->syntax #f (datum->syntax #f
(box a) (box a)
(list #f 1 col (+ 1 col) (vector #f line col (+ 1 col)
(+ 2 (syntax-span a)))))] (+ 2 (syntax-span a)))))]
[else [else
(datum->syntax #f v (list #f 1 col (+ 1 col) 1))]))) (datum->syntax #f v (vector #f line col (+ 1 col) 1))])))