#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))]))