1447 lines
68 KiB
Racket
1447 lines
68 KiB
Racket
#lang racket/base
|
|
(require scribble/core
|
|
scribble/basic
|
|
scribble/search
|
|
scribble/private/manual-sprop
|
|
scribble/private/on-demand
|
|
scribble/html-properties
|
|
file/convertible
|
|
racket/extflonum
|
|
(for-syntax racket/base))
|
|
|
|
(provide define-code
|
|
to-element
|
|
to-element/no-color
|
|
to-paragraph
|
|
to-paragraph/prefix
|
|
syntax-ize
|
|
syntax-ize-hook
|
|
current-keyword-list
|
|
current-variable-list
|
|
current-meta-list
|
|
|
|
input-color
|
|
output-color
|
|
input-background-color
|
|
no-color
|
|
reader-color
|
|
result-color
|
|
keyword-color
|
|
comment-color
|
|
paren-color
|
|
meta-color
|
|
value-color
|
|
symbol-color
|
|
variable-color
|
|
opt-color
|
|
error-color
|
|
syntax-link-color
|
|
value-link-color
|
|
syntax-def-color
|
|
value-def-color
|
|
module-color
|
|
module-link-color
|
|
block-color
|
|
highlighted-color
|
|
|
|
(struct-out var-id)
|
|
(struct-out shaped-parens)
|
|
(struct-out long-boolean)
|
|
(struct-out just-context)
|
|
(struct-out alternate-display)
|
|
(struct-out literal-syntax)
|
|
(for-syntax make-variable-id
|
|
variable-id?
|
|
make-element-id-transformer
|
|
element-id-transformer?))
|
|
|
|
(define (make-racket-style s
|
|
#:tt? [tt? #t]
|
|
#:extras [extras null])
|
|
(make-style s (if tt?
|
|
(cons 'tt-chars
|
|
(append extras
|
|
scheme-properties))
|
|
(append extras
|
|
scheme-properties))))
|
|
|
|
(define-on-demand output-color (make-racket-style "RktOut"))
|
|
(define-on-demand input-color (make-racket-style "RktIn"))
|
|
(define-on-demand input-background-color (make-racket-style "RktInBG"))
|
|
(define-on-demand no-color (make-racket-style "RktPlain"))
|
|
(define-on-demand reader-color (make-racket-style "RktRdr"))
|
|
(define-on-demand result-color (make-racket-style "RktRes"))
|
|
(define-on-demand keyword-color (make-racket-style "RktKw"))
|
|
(define-on-demand comment-color (make-racket-style "RktCmt"))
|
|
(define-on-demand paren-color (make-racket-style "RktPn"))
|
|
(define-on-demand meta-color (make-racket-style "RktMeta"))
|
|
(define-on-demand value-color (make-racket-style "RktVal"))
|
|
(define-on-demand symbol-color (make-racket-style "RktSym"))
|
|
(define-on-demand symbol-def-color (make-racket-style "RktSymDef"
|
|
#:extras (list (attributes '((class . "RktSym"))))))
|
|
(define-on-demand variable-color (make-racket-style "RktVar"))
|
|
(define-on-demand opt-color (make-racket-style "RktOpt"))
|
|
(define-on-demand error-color (make-racket-style "RktErr" #:tt? #f))
|
|
(define-on-demand syntax-link-color (make-racket-style "RktStxLink"))
|
|
(define-on-demand value-link-color (make-racket-style "RktValLink"))
|
|
(define-on-demand syntax-def-color (make-racket-style "RktStxDef"
|
|
#:extras (list (attributes '((class . "RktStxLink"))))))
|
|
(define-on-demand value-def-color (make-racket-style "RktValDef"
|
|
#:extras (list (attributes '((class . "RktValLink"))))))
|
|
(define-on-demand module-color (make-racket-style "RktMod"))
|
|
(define-on-demand module-link-color (make-racket-style "RktModLink"))
|
|
(define-on-demand block-color (make-racket-style "RktBlk"))
|
|
(define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f))
|
|
|
|
(define current-keyword-list
|
|
(make-parameter null))
|
|
(define current-variable-list
|
|
(make-parameter null))
|
|
(define current-meta-list
|
|
(make-parameter null))
|
|
|
|
(define defined-names (make-hasheq))
|
|
|
|
(define-struct (sized-element element) (length))
|
|
|
|
(define-struct (spaces element) (cnt))
|
|
|
|
;; We really don't want leading hypens (or minus signs) to
|
|
;; create a line break after the hyphen. For interior hyphens,
|
|
;; line breaking is usually fine.
|
|
(define (nonbreak-leading-hyphens s)
|
|
(let ([m (regexp-match-positions #rx"^-+" s)])
|
|
(if m
|
|
(if (= (cdar m) (string-length s))
|
|
(make-element 'no-break s)
|
|
(let ([len (add1 (cdar m))])
|
|
(make-element #f (list (make-element 'no-break (substring s 0 len))
|
|
(substring s len)))))
|
|
s)))
|
|
|
|
(define (literalize-spaces i [leading? #f])
|
|
(let ([m (regexp-match-positions #rx" +" i)])
|
|
(if m
|
|
(let ([cnt (- (cdar m) (caar m))])
|
|
(make-spaces #f
|
|
(list
|
|
(literalize-spaces (substring i 0 (caar m)) #t)
|
|
(hspace cnt)
|
|
(literalize-spaces (substring i (cdar m))))
|
|
cnt))
|
|
(if leading?
|
|
(nonbreak-leading-hyphens i)
|
|
i))))
|
|
|
|
|
|
(define line-breakable-space (make-element 'tt " "))
|
|
|
|
;; These caches intentionally record a key with the value.
|
|
;; That way, when the value is no longer used, the key
|
|
;; goes away, and the entry is gone.
|
|
|
|
(define id-element-cache (make-weak-hash))
|
|
(define element-cache (make-weak-hash))
|
|
|
|
(define-struct (cached-delayed-element delayed-element) (cache-key))
|
|
(define-struct (cached-element element) (cache-key))
|
|
|
|
(define qq-ellipses (string->uninterned-symbol "..."))
|
|
|
|
(define (make-id-element c s defn?)
|
|
(let* ([key (and id-element-cache
|
|
(let ([b (identifier-label-binding c)])
|
|
(vector (syntax-e c)
|
|
(module-path-index->taglet (caddr b))
|
|
(cadddr b)
|
|
(list-ref b 5)
|
|
(syntax-property c 'display-string)
|
|
defn?)))])
|
|
(or (and key
|
|
(let ([b (hash-ref id-element-cache key #f)])
|
|
(and b
|
|
(weak-box-value b))))
|
|
(let ([e (make-cached-delayed-element
|
|
(lambda (renderer sec ri)
|
|
(let* ([tag (find-racket-tag sec ri c #f)])
|
|
(if tag
|
|
(let ([tag (intern-taglet tag)])
|
|
(list
|
|
(case (car tag)
|
|
[(form)
|
|
(make-link-element (if defn?
|
|
syntax-def-color
|
|
syntax-link-color)
|
|
(nonbreak-leading-hyphens s)
|
|
tag)]
|
|
[else
|
|
(make-link-element (if defn?
|
|
value-def-color
|
|
value-link-color)
|
|
(nonbreak-leading-hyphens s)
|
|
tag)])))
|
|
(list
|
|
(make-element "badlink"
|
|
(make-element value-link-color s))))))
|
|
(lambda () s)
|
|
(lambda () s)
|
|
(intern-taglet key))])
|
|
(when key
|
|
(hash-set! id-element-cache key (make-weak-box e)))
|
|
e))))
|
|
|
|
(define (make-element/cache style content)
|
|
(if (and element-cache
|
|
(string? content))
|
|
(let ([key (vector style content)])
|
|
(let ([b (hash-ref element-cache key #f)])
|
|
(or (and b (weak-box-value b))
|
|
(let ([e (make-cached-element style content key)])
|
|
(hash-set! element-cache key (make-weak-box e))
|
|
e))))
|
|
(make-element style content)))
|
|
|
|
(define (to-quoted obj expr? quote-depth out color? inc!)
|
|
(if (and expr?
|
|
(zero? quote-depth)
|
|
(quotable? obj))
|
|
(begin
|
|
(out "'" (and color? value-color))
|
|
(inc!)
|
|
(add1 quote-depth))
|
|
quote-depth))
|
|
|
|
(define (to-unquoted expr? quote-depth out color? inc!)
|
|
(if (or (not expr?) (zero? quote-depth))
|
|
quote-depth
|
|
(begin
|
|
(out "," (and color? meta-color))
|
|
(inc!)
|
|
(to-unquoted expr? (sub1 quote-depth) out color? inc!))))
|
|
|
|
(define iformat
|
|
(case-lambda
|
|
[(str val) (datum-intern-literal (format str val))]
|
|
[(str . vals) (datum-intern-literal (apply format str vals))]))
|
|
|
|
(define (typeset-atom c out color? quote-depth expr? escapes? defn?)
|
|
(if (and (var-id? (syntax-e c))
|
|
(zero? quote-depth))
|
|
(out (iformat "~s" (let ([v (var-id-sym (syntax-e c))])
|
|
(if (syntax? v)
|
|
(syntax-e v)
|
|
v)))
|
|
variable-color)
|
|
(let*-values ([(is-var?) (and (identifier? c)
|
|
(memq (syntax-e c) (current-variable-list)))]
|
|
[(s it? sub?)
|
|
(let ([sc (syntax-e c)])
|
|
(let ([s (cond
|
|
[(syntax-property c 'display-string) => values]
|
|
[(literal-syntax? sc) (iformat "~s" (literal-syntax-stx sc))]
|
|
[(var-id? sc) (iformat "~s" (var-id-sym sc))]
|
|
[(eq? sc #t)
|
|
(if (equal? (syntax-span c) 5)
|
|
"#true"
|
|
"#t")]
|
|
[(eq? sc #f)
|
|
(if (equal? (syntax-span c) 6)
|
|
"#false"
|
|
"#f")]
|
|
[(and (number? sc)
|
|
(inexact? sc))
|
|
(define s (iformat "~s" sc))
|
|
(if (= (string-length s)
|
|
(- (syntax-span c) 2))
|
|
;; There's no way to know whether the source used #i,
|
|
;; but it should be ok to include it:
|
|
(string-append "#i" s)
|
|
s)]
|
|
[else (iformat "~s" sc)])])
|
|
(if (and escapes?
|
|
(symbol? sc)
|
|
((string-length s) . > . 1)
|
|
(char=? (string-ref s 0) #\_)
|
|
(not (or (identifier-label-binding c)
|
|
is-var?)))
|
|
(values (substring s 1) #t #f)
|
|
(values s #f #f))))])
|
|
(let ([quote-depth (if (and expr? (identifier? c) (not (eq? qq-ellipses (syntax-e c))))
|
|
(let ([quote-depth
|
|
(if (and (quote-depth . < . 2)
|
|
(memq (syntax-e c) '(unquote unquote-splicing)))
|
|
(to-unquoted expr? quote-depth out color? void)
|
|
quote-depth)])
|
|
(to-quoted c expr? quote-depth out color? void))
|
|
quote-depth)])
|
|
(if (or (element? (syntax-e c))
|
|
(delayed-element? (syntax-e c))
|
|
(part-relative-element? (syntax-e c))
|
|
(convertible? (syntax-e c)))
|
|
(out (syntax-e c) #f)
|
|
(out (if (and (identifier? c)
|
|
color?
|
|
(quote-depth . <= . 0)
|
|
(not (or it? is-var?)))
|
|
(if (pair? (identifier-label-binding c))
|
|
(make-id-element c s defn?)
|
|
(let ([c (nonbreak-leading-hyphens s)])
|
|
(if defn?
|
|
(make-element symbol-def-color c)
|
|
c)))
|
|
(literalize-spaces s #t))
|
|
(cond
|
|
[(positive? quote-depth) value-color]
|
|
[(let ([v (syntax-e c)])
|
|
(or (number? v)
|
|
(string? v)
|
|
(bytes? v)
|
|
(char? v)
|
|
(regexp? v)
|
|
(byte-regexp? v)
|
|
(boolean? v)
|
|
(extflonum? v)))
|
|
value-color]
|
|
[(identifier? c)
|
|
(cond
|
|
[is-var?
|
|
variable-color]
|
|
[(and (identifier? c)
|
|
(memq (syntax-e c) (current-keyword-list)))
|
|
keyword-color]
|
|
[(and (identifier? c)
|
|
(memq (syntax-e c) (current-meta-list)))
|
|
meta-color]
|
|
[it? variable-color]
|
|
[else symbol-color])]
|
|
[else paren-color])
|
|
(string-length s)))))))
|
|
|
|
(define omitable (make-style #f '(omitable)))
|
|
|
|
(define (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
|
|
(let* ([c (syntax-ize c 0 #:expr? expr?)]
|
|
[content null]
|
|
[docs null]
|
|
[first (if escapes?
|
|
(syntax-case c (code:line)
|
|
[(code:line e . rest) #'e]
|
|
[(code:line . rest) #'rest]
|
|
[else c])
|
|
c)]
|
|
[init-col (or (syntax-column first) 0)]
|
|
[src-col init-col]
|
|
[inc-src-col (lambda () (set! src-col (add1 src-col)))]
|
|
[dest-col 0]
|
|
[highlight? #f]
|
|
[col-map (make-hash)]
|
|
[next-col-map (make-hash)]
|
|
[line (or (syntax-line first) 0)])
|
|
(define (finish-line!)
|
|
(when multi-line?
|
|
(set! docs (cons (make-paragraph omitable
|
|
(if (null? content)
|
|
(list (hspace 1))
|
|
(reverse content)))
|
|
docs))
|
|
(set! content null)))
|
|
(define out
|
|
(case-lambda
|
|
[(v cls)
|
|
(out v cls (let sz-loop ([v v])
|
|
(cond
|
|
[(string? v) (string-length v)]
|
|
[(list? v) (for/fold ([s 0]) ([v (in-list v)]) (+ s (sz-loop v)))]
|
|
[(sized-element? v) (sized-element-length v)]
|
|
[(element? v)
|
|
(sz-loop (element-content v))]
|
|
[(delayed-element? v)
|
|
(content-width v)]
|
|
[(part-relative-element? v)
|
|
(content-width v)]
|
|
[(spaces? v)
|
|
(+ (sz-loop (car (element-content v)))
|
|
(spaces-cnt v)
|
|
(sz-loop (caddr (element-content v))))]
|
|
[else 1])))]
|
|
[(v cls len)
|
|
(unless (equal? v "")
|
|
(cond
|
|
[(spaces? v)
|
|
(out (car (element-content v)) cls 0)
|
|
(out (cadr (element-content v)) #f 0)
|
|
(out (caddr (element-content v)) cls len)]
|
|
[(equal? v "\n")
|
|
(if multi-line?
|
|
(begin
|
|
(finish-line!)
|
|
(out prefix cls))
|
|
(out " " cls))]
|
|
[else
|
|
(set! content (cons (elem-wrap
|
|
((if highlight?
|
|
(lambda (c)
|
|
(make-element highlight? c))
|
|
values)
|
|
(if (and color? cls)
|
|
(make-element/cache cls v)
|
|
v)))
|
|
content))
|
|
(set! dest-col (+ dest-col len))]))]))
|
|
(define advance
|
|
(case-lambda
|
|
[(c init-line! srcless-step delta)
|
|
(let ([c (+ delta (or (syntax-column c)
|
|
(if srcless-step
|
|
(+ src-col srcless-step)
|
|
0)))]
|
|
[l (syntax-line c)])
|
|
(let ([new-line? (and l (l . > . line))])
|
|
(when new-line?
|
|
(for ([i (in-range (- l line))])
|
|
(out "\n" #f))
|
|
(set! line l)
|
|
(set! col-map next-col-map)
|
|
(set! next-col-map (make-hash))
|
|
(init-line!))
|
|
(let ([d-col (let ([def-val (+ dest-col (- c src-col))])
|
|
(if new-line?
|
|
(hash-ref col-map c def-val)
|
|
def-val))])
|
|
(let ([amt (- d-col dest-col)])
|
|
(when (positive? amt)
|
|
(let ([old-dest-col dest-col])
|
|
(out (if (and (= 1 amt) (not multi-line?))
|
|
line-breakable-space ; allows a line break to replace the space
|
|
(hspace amt))
|
|
#f)
|
|
(set! dest-col (+ old-dest-col amt))))))
|
|
(set! src-col c)
|
|
(hash-set! next-col-map src-col dest-col)))]
|
|
[(c init-line! srcless-step) (advance c init-line! srcless-step 0)]
|
|
[(c init-line!) (advance c init-line! #f 0)]))
|
|
(define (for-each/i f l v)
|
|
(unless (null? l)
|
|
(f (car l) v)
|
|
(for-each/i f (cdr l) 1)))
|
|
(define (convert-infix c quote-depth expr?)
|
|
(let ([l (syntax->list c)])
|
|
(and l
|
|
((length l) . >= . 3)
|
|
((or (syntax-position (car l)) -inf.0)
|
|
. > .
|
|
(or (syntax-position (cadr l)) +inf.0))
|
|
(let ([a (car l)])
|
|
(let loop ([l (cdr l)]
|
|
[prev null])
|
|
(cond
|
|
[(null? l) #f] ; couldn't unwind
|
|
[else (let ([p2 (syntax-position (car l))])
|
|
(if (and p2
|
|
(p2 . > . (syntax-position a)))
|
|
(datum->syntax c
|
|
(append
|
|
(reverse prev)
|
|
(list
|
|
(datum->syntax
|
|
a
|
|
(let ([val? (positive? quote-depth)])
|
|
(make-sized-element
|
|
(if val? value-color #f)
|
|
(list
|
|
(make-element/cache (if val? value-color paren-color) '". ")
|
|
(typeset a #f "" "" "" (not val?) expr? escapes? defn? elem-wrap)
|
|
(make-element/cache (if val? value-color paren-color) '" ."))
|
|
(+ (syntax-span a) 4)))
|
|
(list (syntax-source a)
|
|
(syntax-line a)
|
|
(- (syntax-column a) 2)
|
|
(- (syntax-position a) 2)
|
|
(+ (syntax-span a) 4))
|
|
a))
|
|
l)
|
|
c
|
|
c)
|
|
(loop (cdr l)
|
|
(cons (car l) prev))))]))))))
|
|
(define (no-fancy-chars s)
|
|
(cond
|
|
[(eq? s 'rsquo) "'"]
|
|
[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)]
|
|
[(and escapes?
|
|
(pair? (syntax-e c))
|
|
(eq? (syntax-e (car (syntax-e c))) 'code:comment))
|
|
(let ([l (syntax->list c)])
|
|
(unless (and l (= 2 (length l)))
|
|
(raise-syntax-error
|
|
#f
|
|
"does not have a single sub-form"
|
|
c)))
|
|
(advance c init-line! srcless-step)
|
|
(out ";" comment-color)
|
|
;(out 'nbsp comment-color)
|
|
(let ([v (syntax->datum (cadr (syntax->list c)))])
|
|
(if (paragraph? v)
|
|
(map (lambda (v)
|
|
(let ([v (no-fancy-chars v)])
|
|
(if (or (string? v) (symbol? v))
|
|
(out v comment-color)
|
|
(out v #f))))
|
|
(paragraph-content v))
|
|
(out (no-fancy-chars v) comment-color)))]
|
|
[(and escapes?
|
|
(pair? (syntax-e c))
|
|
(eq? (syntax-e (car (syntax-e c))) 'code:contract))
|
|
(advance c init-line! srcless-step)
|
|
(out "; " comment-color)
|
|
(let* ([l (cdr (syntax->list c))]
|
|
[s-col (or (syntax-column (car l)) src-col)])
|
|
(set! src-col s-col)
|
|
(for-each/i (loop (lambda ()
|
|
(set! src-col s-col)
|
|
(set! dest-col 0)
|
|
(out "; " comment-color))
|
|
0
|
|
expr?
|
|
#f)
|
|
l
|
|
#f))]
|
|
[(and escapes?
|
|
(pair? (syntax-e c))
|
|
(eq? (syntax-e (car (syntax-e c))) 'code:line))
|
|
(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 (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? (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?)
|
|
(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))
|
|
(advance c init-line! srcless-step)
|
|
(let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
|
|
(out "(" (if (positive? quote-depth) value-color paren-color))
|
|
(set! src-col (+ src-col 1))
|
|
(hash-set! next-col-map src-col dest-col)
|
|
((loop init-line! quote-depth expr? #f)
|
|
(datum->syntax #'here 'quote (car (syntax-e c)))
|
|
#f)
|
|
(for-each/i (loop init-line! (add1 quote-depth) expr? #f)
|
|
(cdr (syntax->list c))
|
|
1)
|
|
(out ")" (if (positive? quote-depth) value-color paren-color))
|
|
(set! src-col (+ src-col 1))
|
|
#;
|
|
(hash-set! next-col-map src-col dest-col))]
|
|
[(and (pair? (syntax-e c))
|
|
(memq (syntax-e (car (syntax-e c)))
|
|
'(quote quasiquote unquote unquote-splicing
|
|
quasisyntax syntax unsyntax unsyntax-splicing))
|
|
(let ([v (syntax->list c)])
|
|
(and v (= 2 (length v))))
|
|
(or (not expr?)
|
|
(positive? quote-depth)
|
|
(quotable? c)))
|
|
(advance c init-line! srcless-step)
|
|
(let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
|
|
(let-values ([(str quote-delta)
|
|
(case (syntax-e (car (syntax-e c)))
|
|
[(quote) (values "'" +inf.0)]
|
|
[(unquote) (values "," -1)]
|
|
[(unquote-splicing) (values ",@" -1)]
|
|
[(quasiquote) (values "`" +1)]
|
|
[(syntax) (values "#'" 0)]
|
|
[(quasisyntax) (values "#`" 0)]
|
|
[(unsyntax) (values "#," 0)]
|
|
[(unsyntax-splicing) (values "#,@" 0)])])
|
|
(out str (if (positive? (+ quote-depth quote-delta))
|
|
value-color
|
|
reader-color))
|
|
(let ([i (cadr (syntax->list c))])
|
|
(set! src-col (or (syntax-column i) src-col))
|
|
(hash-set! next-col-map src-col dest-col)
|
|
((loop init-line! (max 0 (+ quote-depth quote-delta)) expr? #f) i #f))))]
|
|
[(and (pair? (syntax-e c))
|
|
(or (not expr?)
|
|
(positive? quote-depth)
|
|
(quotable? c))
|
|
(convert-infix c quote-depth expr?))
|
|
=> (lambda (converted)
|
|
((loop init-line! quote-depth expr? #f) converted srcless-step))]
|
|
[(or (pair? (syntax-e c))
|
|
(mpair? (syntax-e c))
|
|
(forced-pair? (syntax-e c))
|
|
(null? (syntax-e c))
|
|
(vector? (syntax-e c))
|
|
(and (struct? (syntax-e c))
|
|
(prefab-struct-key (syntax-e c)))
|
|
(struct-proxy? (syntax-e c)))
|
|
(let* ([sh (or (syntax-property c 'paren-shape)
|
|
(if (and (mpair? (syntax-e c))
|
|
(not (and expr? (zero? quote-depth))))
|
|
#\{
|
|
#\())]
|
|
[quote-depth (if (and (not expr?)
|
|
(zero? quote-depth)
|
|
(or (vector? (syntax-e c))
|
|
(struct? (syntax-e c))))
|
|
1
|
|
quote-depth)]
|
|
[p-color (if (positive? quote-depth)
|
|
value-color
|
|
(if (eq? sh #\?)
|
|
opt-color
|
|
paren-color))])
|
|
(advance c init-line! srcless-step)
|
|
(let ([quote-depth (if (struct-proxy? (syntax-e c))
|
|
quote-depth
|
|
(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 (iformat "~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 (if (struct-proxy? (syntax-e c))
|
|
1
|
|
(string-length s))))
|
|
s)
|
|
symbol-color)
|
|
(unless (and (struct-proxy? (syntax-e c))
|
|
(null? (struct-proxy-content (syntax-e c))))
|
|
(out " " #f))))
|
|
(when (vector? (syntax-e c))
|
|
(unless (and expr? (zero? quote-depth))
|
|
(let ([vec (syntax-e c)])
|
|
(out "#" p-color)
|
|
(if (zero? (vector-length vec))
|
|
(set! src-col (+ src-col (- (syntax-span c) 2)))
|
|
(set! src-col (+ src-col (- (syntax-column (vector-ref vec 0))
|
|
(syntax-column c)
|
|
1)))))))
|
|
(when (struct? (syntax-e c))
|
|
(unless (and expr? (zero? quote-depth))
|
|
(out "#s" p-color)
|
|
(set! src-col (+ src-col 2))))
|
|
(unless (and expr? (zero? quote-depth))
|
|
(out (case sh
|
|
[(#\[ #\?) "["]
|
|
[(#\{) "{"]
|
|
[else "("])
|
|
p-color))
|
|
(set! src-col (+ src-col 1))
|
|
(hash-set! next-col-map src-col dest-col)
|
|
(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
|
|
[(#\[ #\?) "]"]
|
|
[(#\{) "}"]
|
|
[else ")"])
|
|
p-color)
|
|
(set! src-col (+ src-col 1))))]
|
|
[(box? (syntax-e c))
|
|
(advance c init-line! srcless-step)
|
|
(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 " " #f)
|
|
(set! src-col (+ src-col 5)))
|
|
(begin
|
|
(out "#&" value-color)
|
|
(set! src-col (+ src-col 2))))
|
|
(hash-set! next-col-map src-col dest-col)
|
|
((loop init-line! (if expr? quote-depth +inf.0) expr? #f) (unbox (syntax-e c)) #f)
|
|
(when (and expr? (zero? quote-depth))
|
|
(out ")" paren-color)))]
|
|
[(hash? (syntax-e c))
|
|
(advance c init-line! srcless-step)
|
|
(let ([equal-table? (hash-equal? (syntax-e c))]
|
|
[eqv-table? (hash-eqv? (syntax-e c))]
|
|
[quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
|
|
(unless (and expr? (zero? quote-depth))
|
|
(out (if equal-table?
|
|
"#hash"
|
|
(if eqv-table?
|
|
"#hasheqv"
|
|
"#hasheq"))
|
|
value-color))
|
|
(let ([delta (+ 5 (if equal-table? 0 (if eqv-table? 3 2))
|
|
(if (and expr? (zero? quote-depth)) 1 0))]
|
|
[orig-col src-col])
|
|
(set! src-col (+ src-col delta))
|
|
(hash-set! next-col-map src-col dest-col)
|
|
((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)
|
|
(lambda (a b)
|
|
(< (or (syntax-position (cdr a)) -inf.0)
|
|
(or (syntax-position (cdr b)) -inf.0))))]
|
|
[(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)])
|
|
([p (in-list l)])
|
|
(let* ([tentative (syntax-ize (car p) 0
|
|
#:expr? (and expr? (zero? quote-depth)))]
|
|
[width (syntax-span tentative)]
|
|
[col (if (= line (syntax-line (cdr p)))
|
|
col
|
|
col0)])
|
|
(let ([key
|
|
(let ([e (syntax-ize (car p)
|
|
(max 0 (- (syntax-column (cdr p))
|
|
width
|
|
sep))
|
|
(syntax-line (cdr p))
|
|
#:expr? (and expr? (zero? quote-depth)))])
|
|
(if ((syntax-column e) . <= . col)
|
|
e
|
|
(datum->syntax #f
|
|
(syntax-e e)
|
|
(vector (syntax-source e)
|
|
(syntax-line e)
|
|
col
|
|
(syntax-position e)
|
|
(+ (syntax-span e) (- (syntax-column e) col))))))])
|
|
(let ([elem
|
|
(datum->syntax
|
|
#f
|
|
(make-forced-pair key (cdr p))
|
|
(vector 'here
|
|
(syntax-line (cdr p))
|
|
(max 0 (- (syntax-column key) cap))
|
|
(max 1 (- (syntax-position key) cap))
|
|
(+ (syntax-span (cdr p)) (syntax-span key) sep cap cap)))])
|
|
(values (cons elem l2)
|
|
(+ (syntax-column elem) (syntax-span elem) 2)
|
|
(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)
|
|
(syntax-line c)
|
|
(+ (syntax-column c) delta)
|
|
(+ (syntax-position c) delta)
|
|
(max 1 (- (syntax-span c) delta))))))
|
|
#f)
|
|
(set! src-col (+ orig-col (syntax-span c)))))]
|
|
[(graph-reference? (syntax-e c))
|
|
(advance c init-line! srcless-step)
|
|
(out (iformat "#~a#" (unbox (graph-reference-bx (syntax-e c))))
|
|
(if (positive? quote-depth)
|
|
value-color
|
|
paren-color))
|
|
(set! src-col (+ src-col (syntax-span c)))]
|
|
[(graph-defn? (syntax-e c))
|
|
(advance c init-line! srcless-step)
|
|
(let ([bx (graph-defn-bx (syntax-e c))])
|
|
(out (iformat "#~a=" (unbox bx))
|
|
(if (positive? quote-depth)
|
|
value-color
|
|
paren-color))
|
|
(set! src-col (+ src-col 3))
|
|
((loop init-line! quote-depth expr? #f) (graph-defn-r (syntax-e c)) #f))]
|
|
[(and (keyword? (syntax-e c)) expr?)
|
|
(advance c init-line! srcless-step)
|
|
(let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
|
|
(typeset-atom c out color? quote-depth expr? escapes? defn?)
|
|
(set! src-col (+ src-col (or (syntax-span c) 1))))]
|
|
[else
|
|
(advance c init-line! srcless-step)
|
|
(typeset-atom c out color? quote-depth expr? escapes? defn?)
|
|
(set! src-col (+ src-col (or (syntax-span c) 1)))
|
|
#;
|
|
(hash-set! next-col-map src-col dest-col)])))
|
|
(out prefix1 #f)
|
|
(set! dest-col 0)
|
|
(hash-set! next-col-map init-col dest-col)
|
|
((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0 expr? #f) c #f)
|
|
(if (list? suffix)
|
|
(map (lambda (sfx)
|
|
(finish-line!)
|
|
(out sfx #f))
|
|
suffix)
|
|
(out suffix #f))
|
|
(unless (null? content)
|
|
(finish-line!))
|
|
(if multi-line?
|
|
(if (= 1 (length docs))
|
|
(car docs)
|
|
(make-table block-color (map list (reverse docs))))
|
|
(make-sized-element #f (reverse content) dest-col))))
|
|
|
|
(define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
|
|
(let* ([c (syntax-ize c 0 #:expr? expr?)]
|
|
[s (syntax-e c)])
|
|
(if (or multi-line?
|
|
(and escapes? (eq? 'code:blank s))
|
|
(pair? s)
|
|
(mpair? s)
|
|
(vector? s)
|
|
(struct? s)
|
|
(box? s)
|
|
(null? s)
|
|
(hash? s)
|
|
(graph-defn? s)
|
|
(graph-reference? s)
|
|
(struct-proxy? s)
|
|
(and expr? (or (identifier? c)
|
|
(keyword? (syntax-e c)))))
|
|
(gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
|
|
(typeset-atom c
|
|
(letrec ([mk
|
|
(case-lambda
|
|
[(elem color)
|
|
(mk elem color (or (syntax-span c) 1))]
|
|
[(elem color len)
|
|
(elem-wrap
|
|
(if (and (string? elem)
|
|
(= len (string-length elem)))
|
|
(make-element/cache (and color? color) elem)
|
|
(make-sized-element (and color? color) elem len)))])])
|
|
mk)
|
|
color? 0 expr? escapes? defn?))))
|
|
|
|
(define (to-element c
|
|
#:expr? [expr? #f]
|
|
#:escapes? [escapes? #t]
|
|
#:defn? [defn? #f])
|
|
(typeset c #f "" "" "" #t expr? escapes? defn? values))
|
|
|
|
(define (to-element/no-color c
|
|
#:expr? [expr? #f]
|
|
#:escapes? [escapes? #t])
|
|
(typeset c #f "" "" "" #f expr? escapes? #f values))
|
|
|
|
(define (to-paragraph c
|
|
#:expr? [expr? #f]
|
|
#:escapes? [escapes? #t]
|
|
#:color? [color? #t]
|
|
#:wrap-elem [elem-wrap (lambda (e) e)])
|
|
(typeset c #t "" "" "" color? expr? escapes? #f elem-wrap))
|
|
|
|
(define ((to-paragraph/prefix pfx1 pfx sfx) c
|
|
#:expr? [expr? #f]
|
|
#:escapes? [escapes? #t]
|
|
#:color? [color? #t]
|
|
#:wrap-elem [elem-wrap (lambda (e) e)])
|
|
(typeset c #t pfx1 pfx sfx color? expr? escapes? #f elem-wrap))
|
|
|
|
(begin-for-syntax
|
|
(define-struct variable-id (sym)
|
|
#:omit-define-syntaxes
|
|
#:property prop:procedure (lambda (self stx)
|
|
(raise-syntax-error
|
|
#f
|
|
(string-append
|
|
"misuse of an identifier (not in `racket', etc.) that is"
|
|
" bound as a code-typesetting variable")
|
|
stx)))
|
|
(define-struct element-id-transformer (proc)
|
|
#:omit-define-syntaxes
|
|
#:property prop:procedure (lambda (self stx)
|
|
(raise-syntax-error
|
|
#f
|
|
(string-append
|
|
"misuse of an identifier (not in `racket', etc.) that is"
|
|
" bound as an code-typesetting element transformer")
|
|
stx))))
|
|
|
|
(begin-for-syntax
|
|
(require mutable-match-lambda)
|
|
|
|
(define mutable-match-element-id-transformer
|
|
(make-mutable-match-lambda/infer-name))
|
|
|
|
(define (try-mutable-match-element-id-transformer . vs)
|
|
(apply (apply make-mutable-match-lambda
|
|
(append (mutable-match-lambda-procedure-procs
|
|
mutable-match-element-id-transformer)
|
|
(list (clause->proc #:match-lambda [_ #f]))))
|
|
vs))
|
|
|
|
(provide mutable-match-element-id-transformer))
|
|
|
|
(define-syntax (define-code stx)
|
|
(syntax-case stx ()
|
|
[(the-id code typeset-code uncode d->s stx-prop)
|
|
(syntax/loc stx
|
|
(define-syntax (code stx)
|
|
(define (wrap-loc v ctx e)
|
|
`(,#'d->s ,ctx
|
|
,e
|
|
#(code
|
|
,(syntax-line v)
|
|
,(syntax-column v)
|
|
,(syntax-position v)
|
|
,(syntax-span v))))
|
|
(define (stx->loc-s-expr/esc v uncode-id)
|
|
(define (stx->loc-s-expr v)
|
|
(let ([slv (and (identifier? v)
|
|
(syntax-local-value v (lambda () #f)))])
|
|
(cond
|
|
[(and (syntax? v) (syntax-property v 'scribble-render))
|
|
=> (λ (renderer)
|
|
(wrap-loc v #f (renderer v)))]
|
|
[(and (syntax? v) (syntax-property v 'scribble-render-as))
|
|
=> (λ (renderer)
|
|
(stx->loc-s-expr
|
|
(with-syntax ([splice
|
|
(renderer v
|
|
(quote-syntax the-id)
|
|
(quote-syntax code)
|
|
(quote-syntax typeset-code)
|
|
(quote-syntax uncode)
|
|
(quote-syntax d->s)
|
|
(quote-syntax stx-prop))])
|
|
(syntax/loc #'splice
|
|
(code:line . splice)))))]
|
|
[(variable-id? slv)
|
|
(wrap-loc v #f `(,#'make-var-id ',(variable-id-sym slv)))]
|
|
[(element-id-transformer? slv)
|
|
(wrap-loc v #f ((element-id-transformer-proc slv) v))]
|
|
[(try-mutable-match-element-id-transformer v)
|
|
=> (λ (transformed)
|
|
(wrap-loc v #f transformed))]
|
|
[(syntax? v)
|
|
(let ([mk (wrap-loc
|
|
v
|
|
`(quote-syntax ,(datum->syntax v 'defcode))
|
|
(syntax-case v ()
|
|
[(esc e)
|
|
(and (identifier? #'esc)
|
|
(free-identifier=? #'esc uncode-id))
|
|
#'e]
|
|
[else (stx->loc-s-expr (syntax-e v))]))])
|
|
(let ([prop (syntax-property v 'paren-shape)])
|
|
(if prop
|
|
`(,#'stx-prop ,mk 'paren-shape ,prop)
|
|
mk)))]
|
|
[(null? v) 'null]
|
|
[(list? v) `(list . ,(map stx->loc-s-expr v))]
|
|
[(pair? v) `(cons ,(stx->loc-s-expr (car v))
|
|
,(stx->loc-s-expr (cdr v)))]
|
|
[(vector? v) `(vector ,@(map
|
|
stx->loc-s-expr
|
|
(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)))]
|
|
[(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)])))
|
|
(stx->loc-s-expr v))
|
|
(define (cvt s uncode-id)
|
|
(datum->syntax #'here (stx->loc-s-expr/esc s uncode-id) #f))
|
|
(if (eq? (syntax-local-context) 'expression)
|
|
(syntax-case stx ()
|
|
[(_ #:escape uncode-id expr) #`(typeset-code #,(cvt #'expr #'uncode-id))]
|
|
[(_ expr) #`(typeset-code #,(cvt #'expr #'uncode))]
|
|
[(_ #:escape uncode-id expr (... ...))
|
|
#`(typeset-code #,(cvt #'(code:line expr (... ...)) #'uncode-id))]
|
|
[(_ expr (... ...))
|
|
#`(typeset-code #,(cvt #'(code:line expr (... ...)) #'uncode))])
|
|
(quasisyntax/loc stx
|
|
(#%expression #,stx)))))]
|
|
[(_ code typeset-code uncode d->s)
|
|
#'(define-code code typeset-code uncode d->s syntax-property)]
|
|
[(_ code typeset-code uncode)
|
|
#'(define-code code typeset-code uncode datum->syntax syntax-property)]
|
|
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
|
|
|
|
|
|
(define syntax-ize-hook (make-parameter (lambda (v col) #f)))
|
|
|
|
(define (vector->short-list v extract)
|
|
(vector->list v)
|
|
#;
|
|
(let ([l (vector->list v)])
|
|
(reverse (list-tail
|
|
(reverse l)
|
|
(- (vector-length v)
|
|
(let loop ([i (sub1 (vector-length v))])
|
|
(cond
|
|
[(zero? i) 1]
|
|
[(eq? (extract (vector-ref v i))
|
|
(extract (vector-ref v (sub1 i))))
|
|
(loop (sub1 i))]
|
|
[else (add1 i)])))))))
|
|
|
|
(define (short-list->vector v l)
|
|
(list->vector
|
|
(let ([n (length l)])
|
|
(if (n . < . (vector-length v))
|
|
(reverse (let loop ([r (reverse l)][i (- (vector-length v) n)])
|
|
(if (zero? i)
|
|
r
|
|
(loop (cons (car r) r) (sub1 i)))))
|
|
l))))
|
|
|
|
(define-struct var-id (sym))
|
|
(define-struct shaped-parens (val shape))
|
|
(define-struct long-boolean (val))
|
|
(define-struct just-context (val ctx))
|
|
(define-struct alternate-display (id string))
|
|
(define-struct literal-syntax (stx))
|
|
(define-struct struct-proxy (name content))
|
|
|
|
(define-struct graph-reference (bx))
|
|
(define-struct graph-defn (r bx))
|
|
|
|
(define (syntax-ize v col [line 1] #:expr? [expr? #f])
|
|
(do-syntax-ize v col line (box #hasheq()) #f (and expr? 0) #f))
|
|
|
|
(define (graph-count ht graph?)
|
|
(and graph?
|
|
(let ([n (hash-ref (unbox ht) '#%graph-count 0)])
|
|
(set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n)))
|
|
n)))
|
|
|
|
(define-struct forced-pair (car cdr))
|
|
|
|
(define (quotable? v)
|
|
(define graph (make-hasheq))
|
|
(let quotable? ([v v])
|
|
(if (hash-ref graph v #f)
|
|
#t
|
|
(begin
|
|
(hash-set! graph v #t)
|
|
(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)
|
|
(case (or (and (custom-print-quotable? v)
|
|
(custom-print-quotable-accessor v))
|
|
'self)
|
|
[(self always) #t]
|
|
[(never) #f]
|
|
[(maybe)
|
|
(andmap quotable? (vector->list (struct->vector v)))])
|
|
#f)]
|
|
[(struct-proxy? v) #f]
|
|
[(mpair? v) #f]
|
|
[else #t])))))
|
|
|
|
(define (do-syntax-ize v col line ht graph? qq no-cons?)
|
|
(cond
|
|
[((syntax-ize-hook) v col)
|
|
=> (lambda (r) r)]
|
|
[(shaped-parens? v)
|
|
(syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f qq #f)
|
|
'paren-shape
|
|
(shaped-parens-shape v))]
|
|
[(long-boolean? v)
|
|
(datum->syntax #f
|
|
(and (long-boolean-val v) #t)
|
|
(vector #f line col (+ 1 col) (if (long-boolean-val v) 5 6)))]
|
|
[(just-context? v)
|
|
(let ([s (do-syntax-ize (just-context-val v) col line ht #f qq #f)])
|
|
(datum->syntax (just-context-ctx v)
|
|
(syntax-e s)
|
|
s
|
|
s
|
|
(just-context-ctx v)))]
|
|
[(alternate-display? v)
|
|
(let ([s (do-syntax-ize (alternate-display-id v) col line ht #f qq #f)])
|
|
(syntax-property s
|
|
'display-string
|
|
(alternate-display-string v)))]
|
|
[(hash-ref (unbox ht) v #f)
|
|
=> (lambda (m)
|
|
(unless (unbox m)
|
|
(set-box! m #t))
|
|
(datum->syntax #f
|
|
(make-graph-reference m)
|
|
(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)
|
|
(pair? v)
|
|
(or (not qq)
|
|
(positive? qq)
|
|
(quotable? v))
|
|
(let ([s (let ([s (car v)])
|
|
(if (just-context? s)
|
|
(just-context-val s)
|
|
s))])
|
|
(memq s '(quote unquote unquote-splicing)))
|
|
(not no-cons?))
|
|
=> (lambda (s)
|
|
(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
|
|
(list (do-syntax-ize (car v) col line ht #f qq #f)
|
|
c)
|
|
(vector #f line col (+ 1 col)
|
|
(+ delta
|
|
(syntax-span c))))))]
|
|
[(or (list? v)
|
|
(vector? v)
|
|
(and (struct? v)
|
|
(or (and qq
|
|
;; Watch out for partially transparent subtypes of `element'
|
|
;; or convertible values:
|
|
(not (convertible? v))
|
|
(not (element? v)))
|
|
(prefab-struct-key v))))
|
|
(let ([orig-ht (unbox ht)]
|
|
[graph-box (box (graph-count ht graph?))])
|
|
(set-box! ht (hash-set (unbox ht) v graph-box))
|
|
(let* ([graph-sz (if graph?
|
|
(+ 2 (string-length (format "~a" (unbox graph-box))))
|
|
0)]
|
|
[vec-sz (cond
|
|
[(vector? v)
|
|
(if (and qq (zero? qq)) 0 1)]
|
|
[(struct? v)
|
|
(if (and (prefab-struct-key v)
|
|
(or (not qq) (positive? qq)))
|
|
2
|
|
0)]
|
|
[else 0])]
|
|
[delta (if (and qq (zero? qq))
|
|
(cond
|
|
[(vector? v) 8] ; `(vector '
|
|
[(struct? v) 1] ; '('
|
|
[no-cons? 1] ; '('
|
|
[else 6]) ; `(list '
|
|
1)]
|
|
[r (let ([l (let loop ([col (+ col delta vec-sz graph-sz)]
|
|
[v (cond
|
|
[(vector? v)
|
|
(vector->short-list v values)]
|
|
[(struct? v)
|
|
(cons (let ([pf (prefab-struct-key v)])
|
|
(if pf
|
|
(prefab-struct-key v)
|
|
(object-name v)))
|
|
(cdr (vector->list (struct->vector v qq-ellipses))))]
|
|
[else v])])
|
|
(if (null? v)
|
|
null
|
|
(let ([i (do-syntax-ize (car v) col line ht #f qq #f)])
|
|
(cons i
|
|
(loop (+ col 1 (syntax-span i)) (cdr v))))))])
|
|
(datum->syntax #f
|
|
(cond
|
|
[(vector? v) (short-list->vector v l)]
|
|
[(struct? v)
|
|
(let ([pf (prefab-struct-key v)])
|
|
(if pf
|
|
(apply make-prefab-struct (prefab-struct-key v) (cdr l))
|
|
(make-struct-proxy (car l) (cdr l))))]
|
|
[else l])
|
|
(vector #f line
|
|
(+ graph-sz col)
|
|
(+ 1 graph-sz col)
|
|
(+ 1
|
|
vec-sz
|
|
delta
|
|
(if (zero? (length l))
|
|
0
|
|
(sub1 (length l)))
|
|
(apply + (map syntax-span l))))))])
|
|
(unless graph?
|
|
(set-box! ht (hash-set (unbox ht) v #f)))
|
|
(cond
|
|
[graph? (datum->syntax #f
|
|
(make-graph-defn r graph-box)
|
|
(vector #f (syntax-line r)
|
|
(- (syntax-column r) graph-sz)
|
|
(- (syntax-position r) graph-sz)
|
|
(+ (syntax-span r) graph-sz)))]
|
|
[(unbox graph-box)
|
|
;; Go again, this time knowing that there will be a graph:
|
|
(set-box! ht orig-ht)
|
|
(do-syntax-ize v col line ht #t qq #f)]
|
|
[else r])))]
|
|
[(or (pair? v)
|
|
(mpair? v)
|
|
(forced-pair? v))
|
|
(let ([carv (if (pair? v) (car v) (if (mpair? v) (mcar v) (forced-pair-car v)))]
|
|
[cdrv (if (pair? v) (cdr v) (if (mpair? v) (mcdr v) (forced-pair-cdr v)))]
|
|
[orig-ht (unbox ht)]
|
|
[graph-box (box (graph-count ht graph?))])
|
|
(set-box! ht (hash-set (unbox ht) v graph-box))
|
|
(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))))
|
|
0)]
|
|
[a (do-syntax-ize carv (+ col delta inc) line ht #f qq #f)]
|
|
[sep (if (and (pair? v)
|
|
(pair? cdrv)
|
|
;; FIXME: what if it turns out to be a graph reference?
|
|
(not (hash-ref (unbox ht) cdrv #f)))
|
|
0
|
|
(if (and qq (zero? 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
|
|
(if (mpair? v)
|
|
(mcons a 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?
|
|
(set-box! ht (hash-set (unbox ht) v #f)))
|
|
(cond
|
|
[graph? (datum->syntax #f
|
|
(make-graph-defn r graph-box)
|
|
(vector #f line col (+ delta col)
|
|
(+ inc (syntax-span r))))]
|
|
[(unbox graph-box)
|
|
;; Go again...
|
|
(set-box! ht orig-ht)
|
|
(do-syntax-ize v col line ht #t qq #f)]
|
|
[else r]))))]
|
|
[(box? v)
|
|
(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
|
|
(box a)
|
|
(vector #f line col (+ 1 col)
|
|
(+ delta (if (and qq (zero? qq)) 1 0) (syntax-span a)))))]
|
|
[(hash? v)
|
|
(let* ([delta (cond
|
|
[(hash-eq? v) 7]
|
|
[(hash-eqv? v) 8]
|
|
[else 6])]
|
|
[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
|
|
((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)))
|
|
(vector (syntax-source pairs)
|
|
(syntax-line pairs)
|
|
(max 0 (- (syntax-column pairs) undelta))
|
|
(max 1 (- (syntax-position pairs) undelta))
|
|
(+ (syntax-span pairs) undelta))))]
|
|
[else
|
|
(datum->syntax #f v (vector #f line col (+ 1 col) 1))])) |