b7afb3cf8f
For example, if you make a multi-column table with a `racketblock' in each column, then the columns size to fit the code --- instead of forcing the table width to match the page width and forcing each column to take an equal share width.
244 lines
11 KiB
Racket
244 lines
11 KiB
Racket
#lang racket/base
|
|
(require syntax/strip-context
|
|
syntax-color/module-lexer
|
|
"../racket.rkt"
|
|
"../core.rkt"
|
|
"../base.rkt"
|
|
"manual-scheme.rkt"
|
|
"manual-style.rkt"
|
|
scribble/core
|
|
(for-syntax racket/base
|
|
syntax/parse))
|
|
|
|
(provide codeblock
|
|
codeblock0
|
|
typeset-code)
|
|
|
|
(define-for-syntax (do-codeblock stx)
|
|
(syntax-parse stx
|
|
[(_ (~seq (~or (~optional (~seq #:expand expand-expr:expr)
|
|
#:defaults ([expand-expr #'#f])
|
|
#:name "#:expand keyword")
|
|
(~optional (~seq #:indent indent-expr:expr)
|
|
#:defaults ([indent-expr #'0])
|
|
#:name "#:expand keyword")
|
|
(~optional (~seq #:keep-lang-line? keep-lang-line?-expr:expr)
|
|
#:defaults ([keep-lang-line?-expr #'#t])
|
|
#:name "#:keep-lang-line? keyword")
|
|
(~optional (~seq #:context context-expr:expr)
|
|
#:name "#:context keyword")
|
|
(~optional (~seq #:line-numbers line-numbers:expr)
|
|
#:defaults ([line-numbers #'#f])
|
|
#:name "#:line-numbers keyword"))
|
|
...)
|
|
str ...)
|
|
#`(typeset-code str ...
|
|
#:expand expand-expr
|
|
#:keep-lang-line? keep-lang-line?-expr
|
|
#:indent indent-expr
|
|
#:context #,(if (attribute context-expr)
|
|
#'context-expr
|
|
(or
|
|
(let ([v #'(str ...)])
|
|
(and (pair? (syntax-e v))
|
|
#`#'#,(car (syntax-e v))))
|
|
#'#f))
|
|
#:line-numbers line-numbers)]))
|
|
|
|
(define-syntax (codeblock stx) #`(code-inset #,(do-codeblock stx)))
|
|
(define-syntax (codeblock0 stx) (do-codeblock stx))
|
|
|
|
(define (typeset-code #:context [context #f]
|
|
#:expand [expand #f]
|
|
#:indent [indent 2]
|
|
#:keep-lang-line? [keep-lang-line? #t]
|
|
#:line-numbers [line-numbers #f]
|
|
. strs)
|
|
(let* ([str (apply string-append strs)]
|
|
[bstr (string->bytes/utf-8 (regexp-replace* #rx"(?m:^$)" str "\xA0"))]
|
|
[in (open-input-bytes bstr)])
|
|
(let* ([tokens
|
|
(let loop ([mode #f])
|
|
(let-values ([(lexeme type data start end backup-delta mode)
|
|
(module-lexer in 0 mode)])
|
|
(if (eof-object? lexeme)
|
|
null
|
|
(cons (list type (sub1 start) (sub1 end) 0)
|
|
(loop mode)))))]
|
|
[substring* (lambda (bstr start [end (bytes-length bstr)])
|
|
(bytes->string/utf-8 (subbytes bstr start end)))]
|
|
[e (parameterize ([read-accept-reader #t])
|
|
((or expand
|
|
(lambda (stx)
|
|
(if context
|
|
(replace-context context stx)
|
|
stx)))
|
|
(let ([p (open-input-bytes bstr)])
|
|
(let loop ()
|
|
(let ([v (read-syntax 'prog p)])
|
|
(cond
|
|
[expand v]
|
|
[(eof-object? v) null]
|
|
[else (datum->syntax #f (cons v (loop)) v v)]))))))]
|
|
[ids (let loop ([e e])
|
|
(cond
|
|
[(and (identifier? e)
|
|
(syntax-original? e))
|
|
(let ([pos (sub1 (syntax-position e))])
|
|
(list (list (lambda (str)
|
|
(to-element (syntax-property
|
|
e
|
|
'display-string
|
|
str)))
|
|
pos
|
|
(+ pos (syntax-span e))
|
|
1)))]
|
|
[(syntax? e) (append (loop (syntax-e e))
|
|
(loop (or (syntax-property e 'origin)
|
|
null))
|
|
(loop (or (syntax-property e 'disappeared-use)
|
|
null)))]
|
|
[(pair? e) (append (loop (car e)) (loop (cdr e)))]
|
|
[else null]))]
|
|
[link-mod (lambda (mp-stx priority #:orig? [always-orig? #f])
|
|
(if (or always-orig?
|
|
(syntax-original? mp-stx))
|
|
(let ([mp (syntax->datum mp-stx)]
|
|
[pos (sub1 (syntax-position mp-stx))])
|
|
(list (list (racketmodname #,mp)
|
|
pos
|
|
(+ pos (syntax-span mp-stx))
|
|
priority)))
|
|
null))]
|
|
;; This makes sense when `expand' actually expands, and
|
|
;; probably not otherwise:
|
|
[mods (let loop ([e e])
|
|
(syntax-case e (module #%require begin)
|
|
[(module name lang (mod-beg form ...))
|
|
(apply append
|
|
(link-mod #'lang 2)
|
|
(map loop (syntax->list #'(form ...))))]
|
|
[(#%require spec ...)
|
|
(apply append
|
|
(map (lambda (spec)
|
|
;; Need to add support for renaming forms, etc.:
|
|
(if (module-path? (syntax->datum spec))
|
|
(link-mod spec 2)
|
|
null))
|
|
(syntax->list #'(spec ...))))]
|
|
[(begin form ...)
|
|
(apply append
|
|
(map loop (syntax->list #'(form ...))))]
|
|
[else null]))]
|
|
[has-hash-lang? (regexp-match? #rx"^#lang " bstr)]
|
|
[language (if has-hash-lang?
|
|
(let ([m (regexp-match #rx"^#lang ([-0-9a-zA-Z/._+]+)" bstr)])
|
|
(if m
|
|
(link-mod
|
|
#:orig? #t
|
|
(datum->syntax #f
|
|
(string->symbol (bytes->string/utf-8 (cadr m)))
|
|
(vector 'in 1 6 7 (bytes-length (cadr m))))
|
|
3)
|
|
null))
|
|
null)]
|
|
[tokens (sort (append ids
|
|
mods
|
|
language
|
|
(filter (lambda (x) (not (eq? (car x) 'symbol)))
|
|
(if has-hash-lang?
|
|
;; Drop #lang entry:
|
|
(cdr tokens)
|
|
tokens)))
|
|
(lambda (a b)
|
|
(or (< (cadr a) (cadr b))
|
|
(and (= (cadr a) (cadr b))
|
|
(> (cadddr a) (cadddr b))))))]
|
|
[default-color meta-color])
|
|
(table
|
|
block-color
|
|
((if keep-lang-line? values cdr) ; FIXME: #lang can span lines
|
|
(list->lines
|
|
indent
|
|
#:line-numbers line-numbers
|
|
(let loop ([pos 0]
|
|
[tokens tokens])
|
|
(cond
|
|
[(null? tokens) (split-lines default-color (substring* bstr pos))]
|
|
[(eq? (caar tokens) 'white-space) (loop pos (cdr tokens))]
|
|
[(= pos (cadar tokens))
|
|
(append (let ([style (caar tokens)]
|
|
[get-str (lambda ()
|
|
(substring* bstr (cadar tokens) (caddar tokens)))])
|
|
(cond
|
|
[(symbol? style)
|
|
(let ([scribble-style
|
|
(case style
|
|
[(symbol) symbol-color]
|
|
[(parenthesis) paren-color]
|
|
[(constant string) value-color]
|
|
[(comment) comment-color]
|
|
[else default-color])])
|
|
(split-lines scribble-style (get-str)))]
|
|
[(procedure? style)
|
|
(list (style (get-str)))]
|
|
[else (list style)]))
|
|
(loop (caddar tokens) (cdr tokens)))]
|
|
[(> pos (cadar tokens))
|
|
(loop pos (cdr tokens))]
|
|
[else (append
|
|
(split-lines default-color (substring* bstr pos (cadar tokens)))
|
|
(loop (cadar tokens) tokens))]))))))))
|
|
|
|
|
|
(define (split-lines style s)
|
|
(cond
|
|
[(regexp-match-positions #rx"(?:\r\n|\r|\n)" s)
|
|
=> (lambda (m)
|
|
(append (split-lines style (substring s 0 (caar m)))
|
|
(list 'newline)
|
|
(split-lines style (substring s (cdar m)))))]
|
|
[(regexp-match-positions #rx" +" s)
|
|
=> (lambda (m)
|
|
(append (split-lines style (substring s 0 (caar m)))
|
|
(list (hspace (- (cdar m) (caar m))))
|
|
(split-lines style (substring s (cdar m)))))]
|
|
[else (list (element style s))]))
|
|
|
|
(define omitable (make-style #f '(omitable)))
|
|
|
|
(define (list->lines indent-amt l #:line-numbers [line-numbers #f])
|
|
(define indent-elem (if (zero? indent-amt)
|
|
""
|
|
(hspace indent-amt)))
|
|
;(list of any) delim -> (list of (list of any))
|
|
(define (break-list lst delim)
|
|
(let loop ([l lst] [n null] [c null])
|
|
(cond
|
|
[(null? l) (reverse (if (null? c) n (cons (reverse c) n)))]
|
|
[(eq? delim (car l)) (loop (cdr l) (cons (reverse c) n) null)]
|
|
[else (loop (cdr l) n (cons (car l) c) )])))
|
|
|
|
(define lines (break-list l 'newline))
|
|
(define line-cnt (length lines))
|
|
(define line-cntl (string-length (format "~a" (+ line-cnt (or line-numbers 0)))))
|
|
|
|
(define (prepend-line-number n r)
|
|
(define ln (format "~a" n))
|
|
(define lnl (string-length ln))
|
|
(define diff (- line-cntl lnl))
|
|
(define l1 (list (tt ln) (hspace 1)))
|
|
(cons (make-element 'smaller (make-element 'smaller
|
|
(if (not (zero? diff)) (cons (hspace diff) l1) l1))) r))
|
|
|
|
(define (make-line accum-line line-number)
|
|
(define rest (cons indent-elem accum-line))
|
|
(list (paragraph omitable (if line-numbers
|
|
(prepend-line-number line-number rest)
|
|
rest))))
|
|
|
|
(for/list ([l (break-list l 'newline)]
|
|
[i (in-naturals (or line-numbers 1))])
|
|
(make-line l i)))
|
|
|