e81cd0d8d7
The `slideshow/code-pict' library is the same as `slideshow/code', but it works in non-GUI settings. Only the `slideshow/code' library connects the code font size to `current-font-size', though. The `code' macro, `define-code', etc., now support "code transformers", which are syntax bindings that trigger otherwise-unescaped transformations in the code to typeset (which can make the code easier to read and friendlier to auto-indentation).
707 lines
27 KiB
Racket
707 lines
27 KiB
Racket
(module code racket/base
|
|
(require "mrpict.rkt"
|
|
(prefix-in r: racket/base)
|
|
mzlib/class
|
|
mzlib/list
|
|
(only-in scheme/list last)
|
|
racket/draw
|
|
mzlib/unit
|
|
(for-syntax racket/base)
|
|
(only-in mzscheme make-namespace))
|
|
|
|
(provide define-code code^ code-params^ code@
|
|
(for-syntax prop:code-transformer
|
|
code-transformer?
|
|
make-code-transformer))
|
|
|
|
(define (to-code-pict p extension)
|
|
(use-last* p extension))
|
|
|
|
(define (code-pict? p)
|
|
(and (pict-last p) #t))
|
|
|
|
(define (code-pict-bottom-line p)
|
|
(single-pict (pict-last p)))
|
|
|
|
(define (single-pict p)
|
|
(if (list? p)
|
|
(last p)
|
|
p))
|
|
|
|
(define (make-code-append htl-append)
|
|
(case-lambda
|
|
[(a b) (let ([a-last (pict-last a)])
|
|
(if a-last
|
|
(let* ([a-dup (launder (ghost (single-pict a-last)))]
|
|
[extension (htl-append a-dup b)])
|
|
(let ([p (let-values ([(x y) (lt-find a a-last)]
|
|
[(dx dy) (lt-find extension a-dup)])
|
|
(let ([ex (- x dx)]
|
|
[ey (- y dy)])
|
|
(if (negative? ey)
|
|
(lt-superimpose
|
|
(inset a 0 (- ey) 0 0)
|
|
(inset extension ex 0 0 0))
|
|
(lt-superimpose
|
|
a
|
|
(inset extension ex ey 0 0)))))])
|
|
(use-last* p b)))
|
|
(htl-append a b)))]
|
|
[(a) a]
|
|
[(a . rest)
|
|
((make-code-append htl-append)
|
|
a
|
|
(apply (make-code-append htl-append) rest))]))
|
|
|
|
(define code-htl-append (make-code-append htl-append))
|
|
(define code-hbl-append (make-code-append hbl-append))
|
|
|
|
(define code-vl-append
|
|
(case-lambda
|
|
[(sep a b) (to-code-pict (vl-append sep a b) b)]
|
|
[(sep a) a]
|
|
[(sep a . rest)
|
|
(code-vl-append sep a (apply code-vl-append sep rest))]))
|
|
|
|
(begin-for-syntax
|
|
(define-values (prop:code-transformer code-transformer? code-transformer-ref)
|
|
(make-struct-type-property 'code-transformer
|
|
(lambda (proc info)
|
|
(unless (and (procedure? proc)
|
|
(procedure-arity-includes? proc 2))
|
|
(raise-argument-error 'guard-for-code-transformer
|
|
"(procedure-arity-includes/c 2)"
|
|
proc))
|
|
proc)))
|
|
|
|
(define make-code-transformer
|
|
(let ()
|
|
(define-struct code-transformer (proc)
|
|
#:property prop:code-transformer (lambda (r stx)
|
|
(let ([proc (code-transformer-proc r)])
|
|
(if (syntax? proc)
|
|
(if (identifier? stx)
|
|
proc
|
|
#f) ; => render normally
|
|
(proc stx)))))
|
|
(lambda (proc)
|
|
(unless (or (syntax? proc)
|
|
(and (procedure? proc)
|
|
(procedure-arity-includes? proc 1)))
|
|
(raise-argument-error 'make-code-transformer
|
|
"(or/c syntax? (procedure-arity-includes/c 1))"
|
|
proc))
|
|
(make-code-transformer proc))))
|
|
|
|
(define (transform id stx uncode-stx recur default)
|
|
(define r (syntax-local-value id (lambda () #f)))
|
|
(define t ((code-transformer-ref r) r stx))
|
|
(if t
|
|
(recur (datum->syntax stx
|
|
(list uncode-stx t)
|
|
stx
|
|
stx))
|
|
(default stx))))
|
|
|
|
(define-syntax (define-code stx)
|
|
(syntax-case stx ()
|
|
[(_ code typeset-code uncode)
|
|
(syntax/loc stx
|
|
(define-syntax (code stx)
|
|
(define (stx->loc-s-expr v)
|
|
(cond
|
|
[(syntax? v)
|
|
(define (default v)
|
|
(let ([mk `(datum->syntax
|
|
#f
|
|
,(syntax-case v (uncode)
|
|
[(uncode e) #'e]
|
|
[_ (stx->loc-s-expr (syntax-e v))])
|
|
(list 'code
|
|
,(syntax-line v)
|
|
,(syntax-column v)
|
|
,(syntax-position v)
|
|
,(syntax-span v)))])
|
|
(let ([prop (syntax-property v 'paren-shape)])
|
|
(if prop
|
|
`(syntax-property ,mk 'paren-shape ,prop)
|
|
mk))))
|
|
(syntax-case v ()
|
|
[(id e (... ...))
|
|
(and (identifier? #'id)
|
|
(code-transformer? (syntax-local-value #'id (lambda () #f))))
|
|
(transform #'id v (quote-syntax uncode) stx->loc-s-expr default)]
|
|
[id
|
|
(and (identifier? #'id)
|
|
(code-transformer? (syntax-local-value #'id (lambda () #f))))
|
|
(transform #'id v (quote-syntax uncode) stx->loc-s-expr default)]
|
|
[_ (default 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)))]
|
|
[(box? v) `(box ,(stx->loc-s-expr (unbox v)))]
|
|
[(null? v) 'null]
|
|
[else `(quote ,v)]))
|
|
(define (cvt s)
|
|
(datum->syntax #'here (stx->loc-s-expr s)))
|
|
(syntax-case stx ()
|
|
[(_ expr) #`(typeset-code #,(cvt #'expr))]
|
|
[(_ expr (... ...))
|
|
#`(typeset-code #,(cvt #'(code:line expr (... ...))))])))]
|
|
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
|
|
|
|
(define-signature code^
|
|
(typeset-code code-pict-bottom-line-pict pict->code-pict
|
|
comment-color keyword-color id-color const-color literal-color
|
|
code-align current-code-tt current-code-font
|
|
current-keyword-list current-const-list current-literal-list
|
|
code-colorize-enabled code-colorize-quote-enabled
|
|
code-italic-underscore-enabled code-scripts-enabled
|
|
current-comment-color current-keyword-color
|
|
current-base-color current-id-color current-literal-color current-const-color
|
|
current-reader-forms
|
|
mzscheme-const-list
|
|
racket/base-const-list))
|
|
|
|
(define-signature code-params^
|
|
(current-font-size
|
|
current-code-line-sep))
|
|
|
|
(define-syntax (define-computed stx)
|
|
(syntax-case stx ()
|
|
[(_ id v)
|
|
#'(begin
|
|
(define (get-val) v)
|
|
(define-syntax id
|
|
(syntax-id-rules (set!)
|
|
[(x (... ...)) ,illegal-use-of-once]
|
|
[x (get-val)])))]))
|
|
|
|
;; Find which line `stx' ends on, #f for unknown
|
|
(define (syntax-end-line stx)
|
|
(cond
|
|
[(syntax? stx) (or (syntax-end-line (syntax-e stx))
|
|
(syntax-line stx))]
|
|
[(pair? stx) (or (syntax-end-line (cdr stx))
|
|
(syntax-end-line (car stx)))]
|
|
[(vector? stx) (syntax-end-line (reverse (vector->list stx)))]
|
|
[else #f]))
|
|
|
|
;; Find which column `stx' ends on if it's not on `line'
|
|
(define (syntax-end-column stx line delta)
|
|
(cond
|
|
[(syntax? stx) (or (syntax-end-column (syntax-e stx) line delta)
|
|
(let ([line2 (syntax-line stx)])
|
|
(and line line2
|
|
(not (= line line2))
|
|
(let ([span (syntax-span stx)]
|
|
[col (syntax-column stx)])
|
|
(and span col (+ col span delta))))))]
|
|
[(pair? stx) (or (syntax-end-column (cdr stx) line (+ delta 1))
|
|
(and (or (null? (cdr stx))
|
|
(and (syntax? (cdr stx)) (null? (cdr stx))))
|
|
(syntax-end-column (car stx) line (+ delta 1))))]
|
|
[else #f]))
|
|
|
|
(define-unit code@
|
|
(import code-params^)
|
|
(export code^)
|
|
|
|
(define current-code-font (make-parameter `(bold . modern)))
|
|
|
|
(define (default-tt s)
|
|
(text s (current-code-font) (current-font-size)))
|
|
|
|
(define current-code-tt (make-parameter default-tt))
|
|
|
|
(define (tt s)
|
|
((current-code-tt) s))
|
|
|
|
(define (code-align p)
|
|
(let ([b (dc void
|
|
(pict-width p)
|
|
(pict-height p)
|
|
(pict-height p)
|
|
0)])
|
|
(refocus (cc-superimpose p b) b)))
|
|
|
|
(define (code-pict-bottom-line-pict p)
|
|
(if (code-pict? p)
|
|
(code-pict-bottom-line p)
|
|
#f))
|
|
|
|
(define (pict->code-pict p bottom-line)
|
|
(if bottom-line
|
|
(to-code-pict p bottom-line)
|
|
p))
|
|
|
|
(define (get-vars/bindings ns require-spec)
|
|
(define ns (let ([n (make-namespace)])
|
|
(parameterize ([current-namespace n])
|
|
(namespace-require/copy require-spec))
|
|
n))
|
|
(define bindings (namespace-mapped-symbols ns))
|
|
(define vars (filter (lambda (n)
|
|
(not (eq? 'nope
|
|
(namespace-variable-value n #f (lambda () 'nope) ns))))
|
|
bindings))
|
|
(values vars bindings))
|
|
|
|
(define-values (mzscheme-vars mzscheme-bindings) (get-vars/bindings (make-namespace) 'mzscheme))
|
|
(define-values (racket/base-vars racket/base-bindings) (get-vars/bindings (r:make-base-namespace) 'racket/base))
|
|
|
|
(define current-keyword-list
|
|
(make-parameter
|
|
(let ([ht (make-hasheq)])
|
|
(for-each (lambda (n) (hash-set! ht n #f))
|
|
mzscheme-vars)
|
|
(for-each (lambda (n) (hash-set! ht n #f))
|
|
racket/base-vars)
|
|
(map symbol->string
|
|
(filter (lambda (n)
|
|
(hash-ref ht n #t))
|
|
(append mzscheme-bindings
|
|
racket/base-bindings))))))
|
|
(define current-const-list
|
|
(make-parameter '()))
|
|
(define current-literal-list
|
|
(make-parameter '()))
|
|
|
|
(define mzscheme-const-list
|
|
(map symbol->string mzscheme-vars))
|
|
(define racket/base-const-list
|
|
(map symbol->string racket/base-vars))
|
|
|
|
(define code-colorize-enabled
|
|
(make-parameter #t))
|
|
|
|
(define code-colorize-quote-enabled
|
|
(make-parameter #t))
|
|
|
|
(define code-italic-underscore-enabled (make-parameter #t))
|
|
(define code-scripts-enabled (make-parameter #t))
|
|
|
|
(define (maybe-colorize p c)
|
|
(if (code-colorize-enabled)
|
|
(colorize p c)
|
|
p))
|
|
|
|
(define current-base-color (make-parameter "brown"))
|
|
(define keyword-color "black")
|
|
(define current-keyword-color (make-parameter keyword-color))
|
|
(define id-color "navy")
|
|
(define current-id-color (make-parameter id-color))
|
|
(define literal-color (make-object color% 51 135 39))
|
|
(define current-literal-color (make-parameter literal-color))
|
|
(define const-color (make-object color% #x99 0 0))
|
|
(define current-const-color (make-parameter const-color))
|
|
(define comment-color (current-base-color))
|
|
(define current-comment-color (make-parameter comment-color))
|
|
(define current-reader-forms (make-parameter '(quote
|
|
quasiquote
|
|
unquote unquote-splicing
|
|
syntax
|
|
quasisyntax
|
|
unsyntax unsyntax-splicing)))
|
|
|
|
(define-computed open-paren-p (tt "("))
|
|
(define-computed close-paren-p (tt ")"))
|
|
(define-computed open-sq-p (tt "["))
|
|
(define-computed close-sq-p (tt "]"))
|
|
(define-computed open-curly-p (tt "{"))
|
|
(define-computed close-curly-p (tt "}"))
|
|
|
|
(define-computed quote-p (tt "'"))
|
|
(define-computed unquote-p (tt ","))
|
|
(define-computed unquote-splicing-p (tt ",@"))
|
|
(define-computed quasiquote-p (tt "`"))
|
|
(define-computed syntax-p (tt "#'"))
|
|
(define-computed unsyntax-p (tt "#,"))
|
|
(define-computed unsyntax-splicing-p (tt "#,@"))
|
|
(define-computed quasisyntax-p (tt "#`"))
|
|
(define-computed semi-p (tt "; "))
|
|
|
|
(define (comment-mode? mode)
|
|
(eq? mode 'comment))
|
|
|
|
(define-computed dot-p (tt "."))
|
|
|
|
(define (mode-colorize mode type p)
|
|
(maybe-colorize
|
|
p
|
|
(case mode
|
|
[(literal) (current-literal-color)]
|
|
[(comment) (current-comment-color)]
|
|
[else (cond
|
|
[(number? mode) (current-literal-color)]
|
|
[(eq? type 'keyword) (current-keyword-color)]
|
|
[(eq? type 'literal) (current-literal-color)]
|
|
[(eq? type 'const) (current-const-color)]
|
|
[(eq? type 'id) (current-id-color)]
|
|
[else (current-base-color)])])))
|
|
|
|
(define (get-open mode stx)
|
|
(if (memq mode '(contract line))
|
|
(blank)
|
|
(mode-colorize
|
|
mode #f
|
|
(case (syntax-property stx 'paren-shape)
|
|
[(#\[) open-sq-p]
|
|
[(#\{) open-curly-p]
|
|
[else open-paren-p]))))
|
|
|
|
(define (get-close mode stx)
|
|
(if (memq mode '(contract line))
|
|
(blank)
|
|
(mode-colorize
|
|
mode #f
|
|
(case (syntax-property stx 'paren-shape)
|
|
[(#\[) close-sq-p]
|
|
[(#\{) close-curly-p]
|
|
[else close-paren-p]))))
|
|
|
|
(define (add-close p closes [force-line #f])
|
|
(cond
|
|
[(null? closes) p]
|
|
[(memq (caar closes) '(contract line))
|
|
(add-close p (cdr closes) force-line)]
|
|
[else
|
|
(let ([p (if force-line
|
|
(vl-append p (tt ""))
|
|
p)])
|
|
(add-close (code-hbl-append p (get-close (caar closes) (cdar closes)))
|
|
(cdr closes)
|
|
#f))]))
|
|
|
|
(define (pad-left space p)
|
|
(if (= 0 space)
|
|
p
|
|
(code-htl-append (tt (make-string space #\space)) p)))
|
|
|
|
(define (pad-bottom space p)
|
|
(if (= 0 space)
|
|
p
|
|
(code-vl-append (current-code-line-sep) (tt " ") (pad-bottom (sub1 space) p))))
|
|
|
|
(define (colorize-id str mode)
|
|
(cond
|
|
[(and (code-italic-underscore-enabled)
|
|
((string-length str) . > . 1)
|
|
(char=? #\_ (string-ref str 0))
|
|
(not (char=? #\_ (string-ref str 1))))
|
|
(mode-colorize
|
|
mode 'id
|
|
(text (substring str 1) `(italic . ,(current-code-font)) (current-font-size)))]
|
|
[(and (code-scripts-enabled)
|
|
(regexp-match #rx"^(.+)_([0-9a-z()+-]+)\\^([0-9a-z()+-]+)$" str))
|
|
=> (lambda (m)
|
|
(hbl-append (colorize-id (cadr m) mode)
|
|
(cc-superimpose
|
|
(text (caddr m) `(subscript . ,(current-code-font)) (current-font-size))
|
|
(text (cadddr m) `(superscript . ,(current-code-font)) (current-font-size)))))]
|
|
[(and (code-scripts-enabled)
|
|
(regexp-match #rx"^(.+)\\^([0-9a-z()+-]+)_([0-9a-z()+-]+)$" str))
|
|
=> (lambda (m)
|
|
(hbl-append (colorize-id (cadr m) mode)
|
|
(cc-superimpose
|
|
(text (cadddr m) `(subscript . ,(current-code-font)) (current-font-size))
|
|
(text (caddr m) `(superscript . ,(current-code-font)) (current-font-size)))))]
|
|
[(and (code-scripts-enabled)
|
|
(regexp-match #rx"^(.+)\\^([0-9a-z()+-]+)$" str))
|
|
=> (lambda (m)
|
|
(hbl-append (colorize-id (cadr m) mode)
|
|
(text (caddr m) `(superscript . ,(current-code-font)) (current-font-size))))]
|
|
[(and (code-scripts-enabled)
|
|
(regexp-match #rx"^(.+)_([0-9a-z()+-]+)$" str))
|
|
=> (lambda (m)
|
|
(hbl-append (colorize-id (cadr m) mode)
|
|
(text (caddr m) `(subscript . ,(current-code-font)) (current-font-size))))]
|
|
[else
|
|
(mode-colorize
|
|
mode
|
|
(cond
|
|
[(member str (current-keyword-list)) 'keyword]
|
|
[(member str (current-const-list)) 'const]
|
|
[(member str (current-literal-list)) 'literal]
|
|
[else 'id])
|
|
(tt str))]))
|
|
|
|
(define (sub-mode mode)
|
|
(case mode
|
|
[(line cond local) #f]
|
|
[(template-cond) 'template]
|
|
[(contract) 'comment]
|
|
[else mode]))
|
|
|
|
(define (cond? s)
|
|
(memq (syntax-e s) '(cond))) ; syntax-rules syntax-case)))
|
|
|
|
(define (local? s)
|
|
(memq (syntax-e s) '(local)))
|
|
|
|
(define (get-span stx)
|
|
(syntax-case stx (code:blank)
|
|
[code:blank 1]
|
|
[_ (or (syntax-span stx) 1)]))
|
|
|
|
(define (color-semi-p)
|
|
(mode-colorize 'comment #f semi-p))
|
|
|
|
(define (add-semis p)
|
|
(let loop ([p p] [semis (color-semi-p)])
|
|
(if ((pict-height p) . > . (+ (pict-height semis) 1))
|
|
(loop p (vl-append (current-code-line-sep) (color-semi-p) semis))
|
|
(htl-append semis p))))
|
|
|
|
(define (add-unquote unquote-p loop x closes mode)
|
|
(let ([mode (cond
|
|
[(number? mode) (if (zero? mode)
|
|
#f
|
|
(sub1 mode))]
|
|
[else mode])])
|
|
(code-htl-append (mode-colorize mode 'keyword unquote-p)
|
|
(loop x closes mode))))
|
|
|
|
(define (typeset-code stx)
|
|
(let loop ([stx stx][closes null][mode #f])
|
|
(syntax-case* stx (quote unquote unquote-splicing quasiquote
|
|
syntax-unquote syntax unsyntax
|
|
unsyntax-splicing quasisyntax
|
|
code:contract code:comment code:line
|
|
code:template code:blank $)
|
|
(lambda (a b) (eq? (syntax-e a) (syntax-e b)))
|
|
[() (add-close (htl-append (get-open mode stx) (get-close mode stx))
|
|
closes)]
|
|
[code:blank (add-close (tt " ")
|
|
closes)]
|
|
[$ (colorize-id "|" closes)]
|
|
[(quote x)
|
|
(memq 'quote (current-reader-forms))
|
|
(code-htl-append (mode-colorize mode 'literal quote-p)
|
|
(loop #'x closes (if (or (not (code-colorize-quote-enabled))
|
|
(comment-mode? mode))
|
|
mode
|
|
'literal)))]
|
|
[(unquote x)
|
|
(memq 'unquote (current-reader-forms))
|
|
(add-unquote unquote-p loop #'x closes mode)]
|
|
[(unquote-splicing x)
|
|
(memq 'unquote-splicing (current-reader-forms))
|
|
(add-unquote unquote-splicing-p loop #'x closes mode)]
|
|
[(quasiquote x)
|
|
(memq 'quasiquote (current-reader-forms))
|
|
(code-htl-append (mode-colorize mode 'keyword quasiquote-p)
|
|
(loop #'x closes (cond
|
|
[(not (code-colorize-quote-enabled)) mode]
|
|
[(comment-mode? mode) mode]
|
|
[(number? mode) (add1 mode)]
|
|
[else 0])))]
|
|
[(syntax x)
|
|
(memq 'syntax (current-reader-forms))
|
|
(code-htl-append (mode-colorize mode 'literal syntax-p)
|
|
(loop #'x closes mode))]
|
|
[(unsyntax x)
|
|
(memq 'unsyntax (current-reader-forms))
|
|
(code-htl-append (mode-colorize mode 'literal unsyntax-p)
|
|
(loop #'x closes mode))]
|
|
[(unsyntax-splicing x)
|
|
(memq 'unsyntax-splicing (current-reader-forms))
|
|
(code-htl-append (mode-colorize mode 'literal unsyntax-splicing-p)
|
|
(loop #'x closes mode))]
|
|
[(quasisyntax x)
|
|
(memq 'unsyntax-splicing (current-reader-forms))
|
|
(code-htl-append (mode-colorize mode 'literal quasisyntax-p)
|
|
(loop #'x closes mode))]
|
|
[(code:contract i ...)
|
|
(add-semis (loop (datum->syntax #f (syntax->list #'(i ...)))
|
|
closes 'contract))]
|
|
[(code:line i ...)
|
|
(loop (datum->syntax #f (syntax->list #'(i ...))
|
|
(syntax-case stx ()
|
|
[(_ a . b)
|
|
(let ([src (syntax-source stx)]
|
|
[line (syntax-line stx)]
|
|
[col (syntax-column stx)]
|
|
[pos (syntax-position stx)]
|
|
[span (syntax-span stx)]
|
|
[a-pos (syntax-position #'a)])
|
|
(if (and pos a-pos (a-pos . > . pos))
|
|
(vector src
|
|
line
|
|
(and col (+ col (- a-pos pos)))
|
|
a-pos
|
|
(and span (max 0 (- span (- a-pos pos)))))
|
|
stx))]
|
|
[else stx]))
|
|
closes 'line)]
|
|
[(code:comment s ...)
|
|
(let ([p
|
|
(apply htl-append
|
|
(color-semi-p)
|
|
(map (lambda (s)
|
|
(if (pict? (syntax-e s))
|
|
(syntax-e s)
|
|
(maybe-colorize (tt (syntax-e s)) (current-comment-color))))
|
|
(syntax->list #'(s ...))))])
|
|
;; Ungraceful handling of ungraceful closes by adding a line
|
|
;; --- better than sticking them to the right of the comment, at least
|
|
(add-close p closes 'force-line))]
|
|
[(code:template i ...)
|
|
(add-semis (loop #'(code:line i ...) closes 'template))]
|
|
[(a b i ... c)
|
|
(let ([pos (for/fold ([pos (syntax-position #'b)]) ([i (in-list (syntax->list #'(i ... c)))])
|
|
(and pos
|
|
(syntax-position i)
|
|
((syntax-position i) . > . pos)
|
|
(syntax-position i)))])
|
|
(and pos
|
|
((syntax-position #'a) . > . (syntax-position #'b))
|
|
((syntax-position #'a) . < . (syntax-position #'c))))
|
|
;; position of `a' is after `b', while everything else is in
|
|
;; order, so print as infix-dot notation
|
|
(loop
|
|
(datum->syntax
|
|
stx
|
|
(cons #'b
|
|
(let loop ([l (syntax->list #'(i ... c))])
|
|
(cond
|
|
[((syntax-position #'a) . < . (syntax-position (car l)))
|
|
(let ([src (syntax-source #'a)]
|
|
[pos (syntax-position #'a)]
|
|
[line (syntax-line #'a)]
|
|
[col (syntax-column #'a)]
|
|
[span (syntax-span #'a)])
|
|
(list* (datum->syntax #f '|.|
|
|
(vector src line
|
|
(and col (max 0 (- col 2)))
|
|
(max 1 (- pos 2))
|
|
1))
|
|
#'a
|
|
(datum->syntax #f '|.|
|
|
(vector src line
|
|
(and col (+ col 1 span))
|
|
(+ pos 1 span)
|
|
1))
|
|
l))]
|
|
[else (cons (car l) (loop (cdr l)))])))
|
|
stx)
|
|
closes
|
|
mode)]
|
|
[(i ...)
|
|
(let ([is (syntax->list #'(i ...))])
|
|
;; Convert each i to a picture, include close paren in last item:
|
|
(let ([ips (let iloop ([is is][sub-mode (sub-mode mode)])
|
|
(cond
|
|
[(null? (cdr is)) (list (loop (car is) (cons (cons mode stx) closes) sub-mode))]
|
|
[else (cons (loop (car is) null sub-mode)
|
|
(iloop (cdr is) (cond
|
|
[(cond? (car is))
|
|
(if (eq? mode 'template)
|
|
'template-cond
|
|
'cond)]
|
|
[(local? (car is))
|
|
'local]
|
|
[(eq? sub-mode 'local)
|
|
#f]
|
|
[else
|
|
sub-mode])))]))])
|
|
;; Combine the parts:
|
|
(let ([left (or (syntax-column stx) +inf.0)])
|
|
(let loop ([stxs is]
|
|
[ps ips]
|
|
[line-so-far (get-open mode stx)]
|
|
[col (+ left 1)]
|
|
[line (syntax-line stx)]
|
|
[always-space? #f]
|
|
[col->width (make-hash)])
|
|
(cond
|
|
[(null? ps) (blank)]
|
|
[(or (not line)
|
|
(= line (or (syntax-line (car stxs)) line)))
|
|
(let* ([space (if (syntax-column (car stxs))
|
|
(inexact->exact
|
|
(max (if always-space? 1 0) (- (syntax-column (car stxs)) col)))
|
|
(if always-space? 1 0))]
|
|
[p (code-htl-append
|
|
line-so-far
|
|
(pad-left space (car ps)))])
|
|
(unless (equal? +inf.0 (+ space col))
|
|
(hash-set! col->width
|
|
(+ space col)
|
|
(pict-width (code-htl-append line-so-far (pad-left space (blank))))))
|
|
(if (null? (cdr stxs))
|
|
p
|
|
(loop (cdr stxs)
|
|
(cdr ps)
|
|
p
|
|
(or (syntax-end-column (car stxs) line 0)
|
|
(if (not (syntax-column (car stxs)))
|
|
+inf.0
|
|
(+ col space (get-span (car stxs)))))
|
|
(or (syntax-end-line (car stxs))
|
|
line
|
|
(syntax-line (car stxs)))
|
|
#t
|
|
col->width)))]
|
|
[else
|
|
;; Start on next line:
|
|
(code-vl-append
|
|
(current-code-line-sep)
|
|
line-so-far
|
|
(let* ([space (max 0 (- (or (syntax-column (car stxs)) 0) left))]
|
|
[p
|
|
(let/ec k
|
|
(code-htl-append
|
|
(blank (hash-ref col->width
|
|
(+ space left)
|
|
(lambda ()
|
|
(k (pad-left space (car ps)))))
|
|
0)
|
|
(car ps)))])
|
|
(if (null? (cdr stxs))
|
|
p
|
|
(loop (cdr stxs)
|
|
(cdr ps)
|
|
p
|
|
(+ left space (get-span (car stxs)))
|
|
(or (syntax-line (car stxs)) (add1 line))
|
|
#t
|
|
(let ([ht (make-hash)]
|
|
[v (hash-ref col->width (+ space left) #f)])
|
|
(when v (hash-set! ht (+ space left) v))
|
|
ht)))))])))))]
|
|
[id
|
|
(identifier? stx)
|
|
(add-close (colorize-id (symbol->string (syntax-e stx)) mode) closes)]
|
|
[kw
|
|
(keyword? (syntax-e #'kw))
|
|
(add-close (mode-colorize mode #f (tt (format "~s" (syntax-e stx)))) closes)]
|
|
[(a . b)
|
|
;; Build a list that makes the "." explicit.
|
|
(let ([p (let loop ([a (syntax-e stx)])
|
|
(cond
|
|
[(pair? a) (cons (car a) (loop (cdr a)))]
|
|
[else (list (datum->syntax #f
|
|
(mode-colorize mode #f dot-p)
|
|
(list (syntax-source a)
|
|
(syntax-line a)
|
|
(- (syntax-column a) 2)
|
|
(- (syntax-position a) 2)
|
|
1))
|
|
a)]))])
|
|
(loop (datum->syntax stx
|
|
p
|
|
stx)
|
|
closes
|
|
mode))]
|
|
[else
|
|
(add-close (if (pict? (syntax-e stx))
|
|
(syntax-e stx)
|
|
(mode-colorize mode 'literal
|
|
(tt (format "~s" (syntax-e stx))) ))
|
|
closes)])))
|
|
|
|
))
|