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
(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

2
manual-form.rkt
View File

@ -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

18
manual-scheme.rkt
View File

@ -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))

190
racket.rkt
View File

@ -1,15 +1,15 @@
(module racket racket/base
(require "core.rkt"
"basic.rkt"
"search.rkt"
"private/manual-sprop.rkt"
"private/on-demand.rkt"
"html-properties.rkt"
#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
(provide define-code
to-element
to-element/no-color
to-paragraph
@ -55,7 +55,7 @@
make-element-id-transformer
element-id-transformer?))
(define (make-racket-style s
(define (make-racket-style s
#:tt? [tt? #t]
#:extras [extras null])
(make-style s (if tt?
@ -65,51 +65,51 @@
(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"
(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"
(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"
(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 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
(define current-keyword-list
(make-parameter null))
(define current-variable-list
(define current-variable-list
(make-parameter null))
(define current-meta-list
(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)
;; 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))
@ -119,7 +119,7 @@
(substring s len)))))
s)))
(define (literalize-spaces i [leading? #f])
(define (literalize-spaces i [leading? #f])
(let ([m (regexp-match-positions #rx" +" i)])
(if m
(let ([cnt (- (cdar m) (caar m))])
@ -134,21 +134,21 @@
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?)
(define (make-id-element c s defn?)
(let* ([key (and id-element-cache
(let ([b (identifier-label-binding c)])
(vector (syntax-e c)
@ -190,7 +190,7 @@
(hash-set! id-element-cache key (make-weak-box e)))
e))))
(define (make-element/cache style content)
(define (make-element/cache style content)
(if (and element-cache
(string? content))
(let ([key (vector style content)])
@ -201,7 +201,7 @@
e))))
(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?
(zero? quote-depth)
(quotable? obj))
@ -211,7 +211,7 @@
(add1 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))
quote-depth
(begin
@ -219,12 +219,12 @@
(inc!)
(to-unquoted expr? (sub1 quote-depth) out color? inc!))))
(define iformat
(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?)
(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))])
@ -317,9 +317,9 @@
[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)
(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]
@ -895,7 +895,7 @@
(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)
(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?
@ -927,32 +927,32 @@
mk)
color? 0 expr? escapes? defn?))))
(define (to-element c
(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
(define (to-element/no-color c
#:expr? [expr? #f]
#:escapes? [escapes? #t])
(typeset c #f "" "" "" #f expr? escapes? #f values))
(define (to-paragraph c
(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
(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
(begin-for-syntax
(define-struct variable-id (sym)
#:omit-define-syntaxes
#:property prop:procedure (lambda (self stx)
@ -972,7 +972,22 @@
" bound as an code-typesetting element transformer")
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 ()
[(_ code typeset-code uncode d->s stx-prop)
(syntax/loc stx
@ -994,6 +1009,9 @@
(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
@ -1052,9 +1070,9 @@
[(_ 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)
#;
(let ([l (vector->list v)])
@ -1069,7 +1087,7 @@
(loop (sub1 i))]
[else (add1 i)])))))))
(define (short-list->vector v l)
(define (short-list->vector v l)
(list->vector
(let ([n (length l)])
(if (n . < . (vector-length v))
@ -1079,29 +1097,29 @@
(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])
(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?)
(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 (quotable? v)
(define graph (make-hasheq))
(let quotable? ([v v])
(if (hash-ref graph v #f)
@ -1133,7 +1151,7 @@
[(mpair? v) #f]
[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
[((syntax-ize-hook) v col)
=> (lambda (r) r)]
@ -1379,4 +1397,4 @@
(max 1 (- (syntax-position pairs) undelta))
(+ (syntax-span pairs) undelta))))]
[else
(datum->syntax #f v (vector #f line col (+ 1 col) 1))])))
(datum->syntax #f v (vector #f line col (+ 1 col) 1))]))