2d4f3e2ac9
The layer is now redundant, since everything left in "pkgs" is in the "racket-pkgs" category.
162 lines
8.3 KiB
Racket
162 lines
8.3 KiB
Racket
|
|
(module reader-example racket/base
|
|
(require scribble/struct
|
|
(only-in scribble/core
|
|
make-style
|
|
make-table-columns)
|
|
scribble/decode
|
|
scribble/manual
|
|
scribble/scheme
|
|
racket/class
|
|
(for-label racket/base))
|
|
|
|
(provide reader-examples
|
|
read-quote-table
|
|
dispatch-table
|
|
dispatch
|
|
metavar
|
|
cilitchar)
|
|
|
|
(define (as-flow i) (make-flow (list (if (block? i)
|
|
i
|
|
(make-paragraph (if (list? i)
|
|
i
|
|
(list i)))))))
|
|
|
|
(define spacer (hspace 1))
|
|
|
|
(define (reader-examples #:symbols? [symbols? #t]
|
|
#:example-note [example-note ""]
|
|
. strs)
|
|
(make-table
|
|
#f
|
|
(list
|
|
(list (as-flow (list "Examples" example-note ":")))
|
|
(list (make-flow
|
|
(list
|
|
(make-table
|
|
(make-style #f (list (make-table-columns
|
|
(list (make-style #f '(baseline))
|
|
(make-style #f '(baseline))
|
|
(make-style #f '(baseline))))))
|
|
(map (lambda (s)
|
|
(list (as-flow (list spacer
|
|
(litchar s)))
|
|
(as-flow (list spacer
|
|
"reads equal to"
|
|
spacer))
|
|
(as-flow (let ([v (read (open-input-string s))])
|
|
(cond
|
|
[(eof-object? v)
|
|
(make-element 'italic '("nothing"))]
|
|
[(string? v)
|
|
(make-element value-color
|
|
(list (racketfont
|
|
(regexp-replace* #rx"[\\]\""
|
|
(regexp-replace*
|
|
#rx"[\\][\\]"
|
|
(format "~s" v)
|
|
"\\\\x5C")
|
|
"\\\\x22"))))]
|
|
[else
|
|
(let ([e (let loop ([v v])
|
|
(cond
|
|
[(memq v '(quasiquote unquote +)) `',v]
|
|
[(symbol? v) (if symbols?
|
|
`(quote ,v)
|
|
`(string->symbol ,(format "~a" v)))]
|
|
[(number? v)
|
|
(let loop ([v v])
|
|
(if (inexact? v)
|
|
`(exact->inexact ,(loop (inexact->exact v)))
|
|
(cond
|
|
[(integer? v) v]
|
|
[(real? v) `(/ ,(numerator v)
|
|
,(denominator v))]
|
|
[(complex? v) `(make-complex ,(loop (real-part v))
|
|
,(loop (imag-part v)))])))]
|
|
[(list? v) `(list ,@(map loop v))]
|
|
[(vector? v) `(vector ,@(map loop (vector->list v)))]
|
|
[(box? v) `(box ,(loop (unbox v)))]
|
|
[(and (pair? v)
|
|
(eq? v (cdr v))
|
|
(eq? 1 (car v)))
|
|
(racketblock0 (let* ([ph (make-placeholder #f)]
|
|
[v (cons 1 ph)])
|
|
(placeholder-set! ph v)
|
|
(make-reader-graph v)))]
|
|
[(pair? v) `(cons ,(loop (car v)) ,(loop (cdr v)))]
|
|
[(bytes? v) `(bytes ,@(map loop (bytes->list v)))]
|
|
[(char? v) `(integer->char ,(char->integer v))]
|
|
[(keyword? v) `(string->keyword ,(keyword->string v))]
|
|
[(or (regexp? v)
|
|
(byte-regexp? v))
|
|
`(,(cond
|
|
[(pregexp? v) 'pregexp]
|
|
[(byte-pregexp? v) 'byte-pregexp]
|
|
[(byte-regexp? v) 'byte-regexp]
|
|
[else 'regexp])
|
|
,(object-name v))]
|
|
[(hash? v)
|
|
`(,(if (hash-eq? v)
|
|
'make-...eq
|
|
'make-...)
|
|
(quote ,(hash-map v cons)))]
|
|
[else v]))])
|
|
(if (block? e)
|
|
e
|
|
(to-element (syntax-ize e 0))))])))))
|
|
strs))))))))
|
|
|
|
(define (read-quote-table . l)
|
|
(make-table
|
|
#f
|
|
(map (lambda (p)
|
|
(list (as-flow spacer)
|
|
(as-flow (car p))
|
|
(as-flow (list spacer "adds" spacer))
|
|
(as-flow (cadr p))))
|
|
l)))
|
|
|
|
|
|
(define (dispatch-table . l)
|
|
(make-table
|
|
'((alignment . (left right left left)))
|
|
(map (lambda (p)
|
|
(list (as-flow spacer)
|
|
(as-flow (car p))
|
|
(as-flow spacer)
|
|
(as-flow (cadr p))))
|
|
l)))
|
|
|
|
(define (dispatch a . b)
|
|
(list a (make-element #f (decode-content b))))
|
|
|
|
(define (metavar . s)
|
|
(make-element 'italic (decode-content s)))
|
|
|
|
(define (cilitchar s)
|
|
(let ([ss (map list->string
|
|
(let loop ([l (string->list s)])
|
|
(if (null? l)
|
|
(list null)
|
|
(let ([r (loop (cdr l))])
|
|
(if (char-alphabetic? (car l))
|
|
(append
|
|
(map (lambda (i) (cons (char-downcase (car l)) i)) r)
|
|
(map (lambda (i) (cons (char-upcase (car l)) i)) r))
|
|
(map (lambda (i) (cons (car l) i)) r))))))])
|
|
(case (length ss)
|
|
[(1) (litchar (car ss))]
|
|
[(2) (make-element #f (list (litchar (car ss)) " or "
|
|
(litchar (cadr ss))))]
|
|
[else
|
|
(make-element #f
|
|
(let loop ([ss ss])
|
|
(if (null? (cdr ss))
|
|
(list " or " (litchar (car ss)))
|
|
(list* (litchar (car ss))
|
|
", "
|
|
(loop (cdr ss))))))]))))
|
|
|