From a5119a7b15d5be99393ac9ac1770076fdc265818 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 20 Sep 2016 21:57:42 +0200 Subject: [PATCH] Added mutable-match-element-id-transformer --- main.rkt | 8 +- manual-form.rkt | 2 +- manual-scheme.rkt | 18 +- racket.rkt | 2328 +++++++++++++++++++++++---------------------- 4 files changed, 1187 insertions(+), 1169 deletions(-) diff --git a/main.rkt b/main.rkt index 1fa4f453..a8d2bfbb 100644 --- a/main.rkt +++ b/main.rkt @@ -1,4 +1,4 @@ -#lang racket/base - -(require scribble-enhanced/manual-form) -(provide (all-from-out scribble-enhanced/manual-form)) +#lang reprovide +scribble-enhanced/manual-form +scribble-enhanced/manual-scheme +scribble-enhanced/racket \ No newline at end of file diff --git a/manual-form.rkt b/manual-form.rkt index 445a68f1..aaf796be 100644 --- a/manual-form.rkt +++ b/manual-form.rkt @@ -12,7 +12,7 @@ scribble/private/qsloc scribble/private/manual-utils scribble/private/manual-vars - scribble/private/manual-scheme + "manual-scheme.rkt" scribble/private/manual-bind scheme/list syntax/parse/define diff --git a/manual-scheme.rkt b/manual-scheme.rkt index 3321dcdf..256f691b 100644 --- a/manual-scheme.rkt +++ b/manual-scheme.rkt @@ -1,13 +1,13 @@ #lang racket/base -(require "../decode.rkt" - "../struct.rkt" - "../scheme.rkt" - "../search.rkt" - "../basic.rkt" - (only-in "../core.rkt" style style-properties) - "manual-style.rkt" - "manual-utils.rkt" ;; used via datum->syntax - "on-demand.rkt" +(require scribble/decode + scribble/struct + "racket.rkt";; was: "../scheme.rkt" + scribble/search + scribble/basic + (only-in scribble/core style style-properties) + scribble/private/manual-style + scribble/private/manual-utils ;; used via datum->syntax + scribble/private/on-demand (for-syntax racket/base) (for-label racket/base)) diff --git a/racket.rkt b/racket.rkt index 55351b85..82cc18f1 100644 --- a/racket.rkt +++ b/racket.rkt @@ -1,309 +1,309 @@ -(module racket racket/base - (require "core.rkt" - "basic.rkt" - "search.rkt" - "private/manual-sprop.rkt" - "private/on-demand.rkt" - "html-properties.rkt" - file/convertible - racket/extflonum - (for-syntax racket/base)) +#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 +(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 + 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?)) + (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 (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-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 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 defined-names (make-hasheq)) - (define-struct (sized-element element) (length)) +(define-struct (sized-element element) (length)) - (define-struct (spaces element) (cnt)) +(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))) +;; 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 (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 " ")) +(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. +;; 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 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-struct (cached-delayed-element delayed-element) (cache-key)) +(define-struct (cached-element element) (cache-key)) - (define qq-ellipses (string->uninterned-symbol "...")) +(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-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 (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-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 (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 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 +(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) @@ -314,41 +314,41 @@ meta-color] [it? variable-color] [else symbol-color])] - [else paren-color]) - (string-length s))))))) + [else paren-color]) + (string-length s))))))) - (define omitable (make-style #f '(omitable))) +(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] - [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 +(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] + [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)] @@ -363,9 +363,9 @@ (spaces-cnt v) (sz-loop (caddr (element-content v))))] [else 1])))] - [(v cls len) - (unless (equal? v "") - (cond + [(v cls len) + (unless (equal? v "") + (cond [(spaces? v) (out (car (element-content v)) cls 0) (out (cadr (element-content v)) #f 0) @@ -387,235 +387,235 @@ 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) + (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) (cond - [(eq? s 'rsquo) "'"] - [else s])) - (define (loop init-line! quote-depth expr? no-cons?) - (lambda (c srcless-step) - (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)) - (let ([l (cdr (syntax->list c))]) - (for-each/i (loop init-line! quote-depth expr? #f) - l - #f))] - [(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 (= 2 (length l))) - (error "bad code:redex: ~.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? #t) - ((loop init-line! quote-depth expr? #f) (cadr l) #f) - (set! highlight? h?) - (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 + [(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)) + (let ([l (cdr (syntax->list c))]) + (for-each/i (loop init-line! quote-depth expr? #f) + l + #f))] + [(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 (= 2 (length l))) + (error "bad code:redex: ~.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? #t) + ((loop init-line! quote-depth expr? #f) (cadr l) #f) + (set! highlight? h?) + (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" @@ -631,36 +631,36 @@ (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) - (let lloop ([l (cond + (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) + (let lloop ([l (cond [(vector? (syntax-e c)) (vector->short-list (syntax-e c) syntax-e)] [(struct? (syntax-e c)) @@ -693,13 +693,13 @@ [(mpair? (syntax-e c)) (syntax-e c)] [else c])] - [first-expr? (and expr? - (or (zero? quote-depth) - (not (struct-proxy? (syntax-e c)))) - (not no-cons?))] - [dotted? #f] - [srcless-step #f]) - (cond + [first-expr? (and expr? + (or (zero? quote-depth) + (not (struct-proxy? (syntax-e c)))) + (not no-cons?))] + [dotted? #f] + [srcless-step #f]) + (cond [(and (syntax? l) (pair? (syntax-e l)) (not dotted?) @@ -734,494 +734,512 @@ ((loop init-line! quote-depth first-expr? #f) l (if (and expr? (zero? quote-depth)) srcless-step #f))])) - (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)))) + (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 (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 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-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 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)) +(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 + (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)))) - (define-syntax (define-code stx) - (syntax-case stx () - [(_ 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 - [(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))] - [(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 +(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 () + [(_ 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 + [(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)])) + (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 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 (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 (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 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-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 (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 (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-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 (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 +(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) @@ -1230,15 +1248,15 @@ 2 0)] [else 0])] - [delta (if (and qq (zero? qq)) - (cond + [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 + 1)] + [r (let ([l (let loop ([col (+ col delta vec-sz graph-sz)] + [v (cond [(vector? v) (vector->short-list v values)] [(struct? v) @@ -1248,13 +1266,13 @@ (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 + (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)]) @@ -1262,19 +1280,19 @@ (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 + (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) @@ -1286,46 +1304,46 @@ (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 + [(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) @@ -1335,48 +1353,48 @@ (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 + [(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 + [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))]))) + (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))])) \ No newline at end of file