suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Added mutable-match-element-id-transformer

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-20 21:57:42 +02:00
parent 49de4c776a
commit a5119a7b15
4 changed files with 1187 additions and 1169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
main.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base #lang reprovide
scribble-enhanced/manual-form
(require scribble-enhanced/manual-form) scribble-enhanced/manual-scheme
(provide (all-from-out scribble-enhanced/manual-form)) scribble-enhanced/racket

2
manual-form.rkt
View File

@ -12,7 +12,7 @@
scribble/private/qsloc scribble/private/qsloc
scribble/private/manual-utils scribble/private/manual-utils
scribble/private/manual-vars scribble/private/manual-vars
scribble/private/manual-scheme "manual-scheme.rkt"
scribble/private/manual-bind scribble/private/manual-bind
scheme/list scheme/list
syntax/parse/define syntax/parse/define

18
manual-scheme.rkt
View File

@ -1,13 +1,13 @@
#lang racket/base #lang racket/base
(require "../decode.rkt" (require scribble/decode
"../struct.rkt" scribble/struct
"../scheme.rkt" "racket.rkt";; was: "../scheme.rkt"
"../search.rkt" scribble/search
"../basic.rkt" scribble/basic
(only-in "../core.rkt" style style-properties) (only-in scribble/core style style-properties)
"manual-style.rkt" scribble/private/manual-style
"manual-utils.rkt" ;; used via datum->syntax scribble/private/manual-utils ;; used via datum->syntax
"on-demand.rkt" scribble/private/on-demand
(for-syntax racket/base) (for-syntax racket/base)
(for-label racket/base)) (for-label racket/base))

190
racket.rkt
View File

@ -1,15 +1,15 @@
(module racket racket/base #lang racket/base
(require "core.rkt" (require scribble/core
"basic.rkt" scribble/basic
"search.rkt" scribble/search
"private/manual-sprop.rkt" scribble/private/manual-sprop
"private/on-demand.rkt" scribble/private/on-demand
"html-properties.rkt" scribble/html-properties
file/convertible file/convertible
racket/extflonum racket/extflonum
(for-syntax racket/base)) (for-syntax racket/base))
(provide define-code (provide define-code
to-element to-element
to-element/no-color to-element/no-color
to-paragraph to-paragraph
@ -55,7 +55,7 @@
make-element-id-transformer make-element-id-transformer
element-id-transformer?)) element-id-transformer?))
(define (make-racket-style s (define (make-racket-style s
#:tt? [tt? #t] #:tt? [tt? #t]
#:extras [extras null]) #:extras [extras null])
(make-style s (if tt? (make-style s (if tt?
@ -65,51 +65,51 @@
(append extras (append extras
scheme-properties)))) scheme-properties))))
(define-on-demand output-color (make-racket-style "RktOut")) (define-on-demand output-color (make-racket-style "RktOut"))
(define-on-demand input-color (make-racket-style "RktIn")) (define-on-demand input-color (make-racket-style "RktIn"))
(define-on-demand input-background-color (make-racket-style "RktInBG")) (define-on-demand input-background-color (make-racket-style "RktInBG"))
(define-on-demand no-color (make-racket-style "RktPlain")) (define-on-demand no-color (make-racket-style "RktPlain"))
(define-on-demand reader-color (make-racket-style "RktRdr")) (define-on-demand reader-color (make-racket-style "RktRdr"))
(define-on-demand result-color (make-racket-style "RktRes")) (define-on-demand result-color (make-racket-style "RktRes"))
(define-on-demand keyword-color (make-racket-style "RktKw")) (define-on-demand keyword-color (make-racket-style "RktKw"))
(define-on-demand comment-color (make-racket-style "RktCmt")) (define-on-demand comment-color (make-racket-style "RktCmt"))
(define-on-demand paren-color (make-racket-style "RktPn")) (define-on-demand paren-color (make-racket-style "RktPn"))
(define-on-demand meta-color (make-racket-style "RktMeta")) (define-on-demand meta-color (make-racket-style "RktMeta"))
(define-on-demand value-color (make-racket-style "RktVal")) (define-on-demand value-color (make-racket-style "RktVal"))
(define-on-demand symbol-color (make-racket-style "RktSym")) (define-on-demand symbol-color (make-racket-style "RktSym"))
(define-on-demand symbol-def-color (make-racket-style "RktSymDef" (define-on-demand symbol-def-color (make-racket-style "RktSymDef"
#:extras (list (attributes '((class . "RktSym")))))) #:extras (list (attributes '((class . "RktSym"))))))
(define-on-demand variable-color (make-racket-style "RktVar")) (define-on-demand variable-color (make-racket-style "RktVar"))
(define-on-demand opt-color (make-racket-style "RktOpt")) (define-on-demand opt-color (make-racket-style "RktOpt"))
(define-on-demand error-color (make-racket-style "RktErr" #:tt? #f)) (define-on-demand error-color (make-racket-style "RktErr" #:tt? #f))
(define-on-demand syntax-link-color (make-racket-style "RktStxLink")) (define-on-demand syntax-link-color (make-racket-style "RktStxLink"))
(define-on-demand value-link-color (make-racket-style "RktValLink")) (define-on-demand value-link-color (make-racket-style "RktValLink"))
(define-on-demand syntax-def-color (make-racket-style "RktStxDef" (define-on-demand syntax-def-color (make-racket-style "RktStxDef"
#:extras (list (attributes '((class . "RktStxLink")))))) #:extras (list (attributes '((class . "RktStxLink"))))))
(define-on-demand value-def-color (make-racket-style "RktValDef" (define-on-demand value-def-color (make-racket-style "RktValDef"
#:extras (list (attributes '((class . "RktValLink")))))) #:extras (list (attributes '((class . "RktValLink"))))))
(define-on-demand module-color (make-racket-style "RktMod")) (define-on-demand module-color (make-racket-style "RktMod"))
(define-on-demand module-link-color (make-racket-style "RktModLink")) (define-on-demand module-link-color (make-racket-style "RktModLink"))
(define-on-demand block-color (make-racket-style "RktBlk")) (define-on-demand block-color (make-racket-style "RktBlk"))
(define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f)) (define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f))
(define current-keyword-list (define current-keyword-list
(make-parameter null)) (make-parameter null))
(define current-variable-list (define current-variable-list
(make-parameter null)) (make-parameter null))
(define current-meta-list (define current-meta-list
(make-parameter null)) (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 ;; We really don't want leading hypens (or minus signs) to
;; create a line break after the hyphen. For interior hyphens, ;; create a line break after the hyphen. For interior hyphens,
;; line breaking is usually fine. ;; line breaking is usually fine.
(define (nonbreak-leading-hyphens s) (define (nonbreak-leading-hyphens s)
(let ([m (regexp-match-positions #rx"^-+" s)]) (let ([m (regexp-match-positions #rx"^-+" s)])
(if m (if m
(if (= (cdar m) (string-length s)) (if (= (cdar m) (string-length s))
@ -119,7 +119,7 @@
(substring s len))))) (substring s len)))))
s))) s)))
(define (literalize-spaces i [leading? #f]) (define (literalize-spaces i [leading? #f])
(let ([m (regexp-match-positions #rx" +" i)]) (let ([m (regexp-match-positions #rx" +" i)])
(if m (if m
(let ([cnt (- (cdar m) (caar m))]) (let ([cnt (- (cdar m) (caar m))])
@ -134,21 +134,21 @@
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. ;; These caches intentionally record a key with the value.
;; That way, when the value is no longer used, the key ;; That way, when the value is no longer used, the key
;; goes away, and the entry is gone. ;; goes away, and the entry is gone.
(define id-element-cache (make-weak-hash)) (define id-element-cache (make-weak-hash))
(define element-cache (make-weak-hash)) (define element-cache (make-weak-hash))
(define-struct (cached-delayed-element delayed-element) (cache-key)) (define-struct (cached-delayed-element delayed-element) (cache-key))
(define-struct (cached-element 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?) (define (make-id-element c s defn?)
(let* ([key (and id-element-cache (let* ([key (and id-element-cache
(let ([b (identifier-label-binding c)]) (let ([b (identifier-label-binding c)])
(vector (syntax-e c) (vector (syntax-e c)
@ -190,7 +190,7 @@
(hash-set! id-element-cache key (make-weak-box e))) (hash-set! id-element-cache key (make-weak-box e)))
e)))) e))))
(define (make-element/cache style content) (define (make-element/cache style content)
(if (and element-cache (if (and element-cache
(string? content)) (string? content))
(let ([key (vector style content)]) (let ([key (vector style content)])
@ -201,7 +201,7 @@
e)))) e))))
(make-element style content))) (make-element style content)))
(define (to-quoted obj expr? quote-depth out color? inc!) (define (to-quoted obj expr? quote-depth out color? inc!)
(if (and expr? (if (and expr?
(zero? quote-depth) (zero? quote-depth)
(quotable? obj)) (quotable? obj))
@ -211,7 +211,7 @@
(add1 quote-depth)) (add1 quote-depth))
quote-depth)) quote-depth))
(define (to-unquoted expr? quote-depth out color? inc!) (define (to-unquoted expr? quote-depth out color? inc!)
(if (or (not expr?) (zero? quote-depth)) (if (or (not expr?) (zero? quote-depth))
quote-depth quote-depth
(begin (begin
@ -219,12 +219,12 @@
(inc!) (inc!)
(to-unquoted expr? (sub1 quote-depth) out color? inc!)))) (to-unquoted expr? (sub1 quote-depth) out color? inc!))))
(define iformat (define iformat
(case-lambda (case-lambda
[(str val) (datum-intern-literal (format str val))] [(str val) (datum-intern-literal (format str val))]
[(str . vals) (datum-intern-literal (apply format str vals))])) [(str . vals) (datum-intern-literal (apply format str vals))]))
(define (typeset-atom c out color? quote-depth expr? escapes? defn?) (define (typeset-atom c out color? quote-depth expr? escapes? defn?)
(if (and (var-id? (syntax-e c)) (if (and (var-id? (syntax-e c))
(zero? quote-depth)) (zero? quote-depth))
(out (iformat "~s" (let ([v (var-id-sym (syntax-e c))]) (out (iformat "~s" (let ([v (var-id-sym (syntax-e c))])
@ -317,9 +317,9 @@
[else paren-color]) [else paren-color])
(string-length s))))))) (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) (define (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
(let* ([c (syntax-ize c 0 #:expr? expr?)] (let* ([c (syntax-ize c 0 #:expr? expr?)]
[content null] [content null]
[docs null] [docs null]
@ -895,7 +895,7 @@
(make-table block-color (map list (reverse docs)))) (make-table block-color (map list (reverse docs))))
(make-sized-element #f (reverse content) dest-col)))) (make-sized-element #f (reverse content) dest-col))))
(define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap) (define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
(let* ([c (syntax-ize c 0 #:expr? expr?)] (let* ([c (syntax-ize c 0 #:expr? expr?)]
[s (syntax-e c)]) [s (syntax-e c)])
(if (or multi-line? (if (or multi-line?
@ -927,32 +927,32 @@
mk) mk)
color? 0 expr? escapes? defn?)))) color? 0 expr? escapes? defn?))))
(define (to-element c (define (to-element c
#:expr? [expr? #f] #:expr? [expr? #f]
#:escapes? [escapes? #t] #:escapes? [escapes? #t]
#:defn? [defn? #f]) #:defn? [defn? #f])
(typeset c #f "" "" "" #t expr? escapes? defn? values)) (typeset c #f "" "" "" #t expr? escapes? defn? values))
(define (to-element/no-color c (define (to-element/no-color c
#:expr? [expr? #f] #:expr? [expr? #f]
#:escapes? [escapes? #t]) #:escapes? [escapes? #t])
(typeset c #f "" "" "" #f expr? escapes? #f values)) (typeset c #f "" "" "" #f expr? escapes? #f values))
(define (to-paragraph c (define (to-paragraph c
#:expr? [expr? #f] #:expr? [expr? #f]
#:escapes? [escapes? #t] #:escapes? [escapes? #t]
#:color? [color? #t] #:color? [color? #t]
#:wrap-elem [elem-wrap (lambda (e) e)]) #:wrap-elem [elem-wrap (lambda (e) e)])
(typeset c #t "" "" "" color? expr? escapes? #f elem-wrap)) (typeset c #t "" "" "" color? expr? escapes? #f elem-wrap))
(define ((to-paragraph/prefix pfx1 pfx sfx) c (define ((to-paragraph/prefix pfx1 pfx sfx) c
#:expr? [expr? #f] #:expr? [expr? #f]
#:escapes? [escapes? #t] #:escapes? [escapes? #t]
#:color? [color? #t] #:color? [color? #t]
#:wrap-elem [elem-wrap (lambda (e) e)]) #:wrap-elem [elem-wrap (lambda (e) e)])
(typeset c #t pfx1 pfx sfx color? expr? escapes? #f elem-wrap)) (typeset c #t pfx1 pfx sfx color? expr? escapes? #f elem-wrap))
(begin-for-syntax (begin-for-syntax
(define-struct variable-id (sym) (define-struct variable-id (sym)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:procedure (lambda (self stx) #:property prop:procedure (lambda (self stx)
@ -972,7 +972,22 @@
" bound as an code-typesetting element transformer") " bound as an code-typesetting element transformer")
stx)))) stx))))
(define-syntax (define-code 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 () (syntax-case stx ()
[(_ code typeset-code uncode d->s stx-prop) [(_ code typeset-code uncode d->s stx-prop)
(syntax/loc stx (syntax/loc stx
@ -994,6 +1009,9 @@
(wrap-loc v #f `(,#'make-var-id ',(variable-id-sym slv)))] (wrap-loc v #f `(,#'make-var-id ',(variable-id-sym slv)))]
[(element-id-transformer? slv) [(element-id-transformer? slv)
(wrap-loc v #f ((element-id-transformer-proc slv) v))] (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) [(syntax? v)
(let ([mk (wrap-loc (let ([mk (wrap-loc
v v
@ -1052,9 +1070,9 @@
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)])) [(_ 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) (define (vector->short-list v extract)
(vector->list v) (vector->list v)
#; #;
(let ([l (vector->list v)]) (let ([l (vector->list v)])
@ -1069,7 +1087,7 @@
(loop (sub1 i))] (loop (sub1 i))]
[else (add1 i)]))))))) [else (add1 i)])))))))
(define (short-list->vector v l) (define (short-list->vector v l)
(list->vector (list->vector
(let ([n (length l)]) (let ([n (length l)])
(if (n . < . (vector-length v)) (if (n . < . (vector-length v))
@ -1079,29 +1097,29 @@
(loop (cons (car r) r) (sub1 i))))) (loop (cons (car r) r) (sub1 i)))))
l)))) l))))
(define-struct var-id (sym)) (define-struct var-id (sym))
(define-struct shaped-parens (val shape)) (define-struct shaped-parens (val shape))
(define-struct long-boolean (val)) (define-struct long-boolean (val))
(define-struct just-context (val ctx)) (define-struct just-context (val ctx))
(define-struct alternate-display (id string)) (define-struct alternate-display (id string))
(define-struct literal-syntax (stx)) (define-struct literal-syntax (stx))
(define-struct struct-proxy (name content)) (define-struct struct-proxy (name content))
(define-struct graph-reference (bx)) (define-struct graph-reference (bx))
(define-struct graph-defn (r bx)) (define-struct graph-defn (r bx))
(define (syntax-ize v col [line 1] #:expr? [expr? #f]) (define (syntax-ize v col [line 1] #:expr? [expr? #f])
(do-syntax-ize v col line (box #hasheq()) #f (and expr? 0) #f)) (do-syntax-ize v col line (box #hasheq()) #f (and expr? 0) #f))
(define (graph-count ht graph?) (define (graph-count ht graph?)
(and graph? (and graph?
(let ([n (hash-ref (unbox ht) '#%graph-count 0)]) (let ([n (hash-ref (unbox ht) '#%graph-count 0)])
(set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n))) (set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n)))
n))) n)))
(define-struct forced-pair (car cdr)) (define-struct forced-pair (car cdr))
(define (quotable? v) (define (quotable? v)
(define graph (make-hasheq)) (define graph (make-hasheq))
(let quotable? ([v v]) (let quotable? ([v v])
(if (hash-ref graph v #f) (if (hash-ref graph v #f)
@ -1133,7 +1151,7 @@
[(mpair? v) #f] [(mpair? v) #f]
[else #t]))))) [else #t])))))
(define (do-syntax-ize v col line ht graph? qq no-cons?) (define (do-syntax-ize v col line ht graph? qq no-cons?)
(cond (cond
[((syntax-ize-hook) v col) [((syntax-ize-hook) v col)
=> (lambda (r) r)] => (lambda (r) r)]
@ -1379,4 +1397,4 @@
(max 1 (- (syntax-position pairs) undelta)) (max 1 (- (syntax-position pairs) undelta))
(+ (syntax-span pairs) undelta))))] (+ (syntax-span pairs) undelta))))]
[else [else
(datum->syntax #f v (vector #f line col (+ 1 col) 1))]))) (datum->syntax #f v (vector #f line col (+ 1 col) 1))]))