add `slideshow/code-pict' and code transformers
The `slideshow/code-pict' library is the same as `slideshow/code', but it works in non-GUI settings. Only the `slideshow/code' library connects the code font size to `current-font-size', though. The `code' macro, `define-code', etc., now support "code transformers", which are syntax bindings that trigger otherwise-unescaped transformations in the code to typeset (which can make the code easier to read and friendlier to auto-indentation).
This commit is contained in:
Matthew Flatt
parent
59915409a5
commit
e81cd0d8d7
|
|
@ -1,13 +1,28 @@
|
|||
#lang scribble/doc
|
||||
@(require "ss.rkt" (for-label slideshow/code racket/gui/base))
|
||||
@(require "ss.rkt"
|
||||
scribble/eval
|
||||
(for-label slideshow/code
|
||||
racket/gui/base))
|
||||
|
||||
@(define stx-obj
|
||||
(tech #:doc '(lib "scribblings/reference/reference.scrbl") "syntax object"))
|
||||
|
||||
@(define ss-eval (make-base-eval))
|
||||
@(interaction-eval #:eval ss-eval
|
||||
(begin
|
||||
(require slideshow/code-pict
|
||||
slideshow/pict
|
||||
(for-syntax racket/base))
|
||||
(current-code-tt (lambda (s) (text s "monospace" 14)))
|
||||
(define-code code typeset-code)))
|
||||
|
||||
@title{Typesetting Racket Code}
|
||||
|
||||
@defmodule[slideshow/code]{The @racket[slideshow/code] library
|
||||
provides utilities for typesetting Racket code as a pict.}
|
||||
@defmodule*[(slideshow/code-pict slideshow/code)]{
|
||||
The @racketmodname[slideshow/code-pict] library
|
||||
provides utilities for typesetting Racket code as a pict.
|
||||
The @racketmodname[slideshow/code] library initializes
|
||||
@racket[get-current-code-font-size] to @racket[current-font-size].}
|
||||
|
||||
@defproc[(typeset-code [stx syntax?]) pict?]{
|
||||
|
||||
|
|
@ -80,7 +95,9 @@ specially:
|
|||
@defform[(code datum ...)]{
|
||||
|
||||
The macro form of @racket[typeset-code]. Within a @racket[datum],
|
||||
@racket[unsyntax] can be used to escape to an expression.
|
||||
@racket[unsyntax] can be used to escape to an expression, and
|
||||
identifiers bound as syntax to @tech{code transformer}s trigger
|
||||
transformations.
|
||||
|
||||
For more information, see @racket[typeset-code] and
|
||||
@racket[define-code], since @racket[code] is defined as
|
||||
|
|
@ -103,7 +120,7 @@ Parameter for a one-argument procedure to turn a
|
|||
string into a pict, used to typeset text. The default is
|
||||
|
||||
@racketblock[
|
||||
(lambda (s) (text s (current-code-font) (current-font-size)))
|
||||
(lambda (s) (text s (current-code-font) ((get-current-code-font-size))))
|
||||
]
|
||||
|
||||
This procedure is not used to typeset subscripts or other items that
|
||||
|
|
@ -111,6 +128,13 @@ require font changes, where @racket[current-code-font] is used
|
|||
directly.}
|
||||
|
||||
|
||||
@defparam[get-current-code-font-size proc (-> exact-nonnegative-integer?)]{
|
||||
|
||||
A parameter used to access the default font size. The
|
||||
@racketmodname[slideshow/code] library initializes this parameter to
|
||||
@racket[current-font-size].}
|
||||
|
||||
|
||||
@defparam[current-code-line-sep amt real?]{
|
||||
|
||||
A parameter that determines the spacing between lines of typeset code.
|
||||
|
|
@ -244,7 +268,69 @@ the @racket[_expr] is evaluated and the result datum is spliced in
|
|||
place of the @racket[escape-id] form in @racket[_datum]. If the result
|
||||
is not a syntax object, it is given the source location of the
|
||||
@racket[escape-id] form. A pict value intected this way as a
|
||||
@racket[_datum] is rendered as itself.}
|
||||
@racket[_datum] is rendered as itself.
|
||||
|
||||
If a @racket[_datum] contains @racket[(transform-id _datum ...)] or
|
||||
@racket[transform-id] for a @racket[transform-id] that is bound as syntax to a
|
||||
@tech{code transformer}, then the @racket[(transform-id _datum ...)]
|
||||
or @racket[transform-id] may be replaced with an escaped expression,
|
||||
depending on the @tech{code transformer}'s result.}
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(make-code-transformer [proc-or-stx (or/c (syntax? . -> . (or/c syntax? #f))
|
||||
syntax?)])
|
||||
code-transformer?]
|
||||
@defthing[prop:code-transformer struct-type-property?]
|
||||
@defproc[(code-transformer? [v any/c]) boolean?]
|
||||
)]{
|
||||
|
||||
Exported @racket[for-syntax] for creating @deftech{code transformers}.
|
||||
|
||||
For @tech{code transformer} created with
|
||||
@racket[(make-code-transformer _proc)], @racket[proc] takes a syntax
|
||||
object representing the use of an identifier bound to the transformer,
|
||||
and it produces an expression whose value replaces the identifier use
|
||||
within a @racket[code] form or a form defined via
|
||||
@racket[define-code]. Like a macro transformer, a code transformer is
|
||||
triggered either by a use of the bound identifier in an
|
||||
``application'' position, in which case the transformer receives the
|
||||
entire ``application'' form, or the identifier by itself can also
|
||||
trigger the transformer. The @tech{code transformer}'s @racket[_proc]
|
||||
can return @racket[#f], in which case the use of the identifier is
|
||||
left untransformed; if the identifier was used in an ``application''
|
||||
position, the transformer @racket[_proc] will be called again for the
|
||||
identifier use by itself.
|
||||
|
||||
A @tech{code transformer} produced by @racket[(make-code-transformer _stx)]
|
||||
is equivalent to
|
||||
|
||||
@racketblock[
|
||||
(make-code-transformer (lambda (use-stx)
|
||||
(if (identifier? use-stx)
|
||||
_stx
|
||||
#f)))
|
||||
]
|
||||
|
||||
A structure type with the @racket[prop:code-transformer] property
|
||||
implements a @tech{code transformer}. The property value must be a
|
||||
procedure of one argument, which receives the structure and returns a
|
||||
procedure that is like a @racket[_proc] passed to
|
||||
@racket[make-code-transformer], except that the property value takes
|
||||
the structure instance as an argument before the syntax object to
|
||||
transform.
|
||||
|
||||
The @racket[code-transformer?] predicate returns @racket[#t] for a
|
||||
value produced by @racket[make-code-transformer] or for an instance of
|
||||
a structure type with the @racket[prop:code-transformer] property,
|
||||
@racket[#f] otherwise.
|
||||
|
||||
@examples[
|
||||
#:eval ss-eval
|
||||
(let-syntax ([bag (make-code-transformer #'(code hat))]
|
||||
[copy (make-code-transformer (syntax-rules ()
|
||||
[(_ c) (code (* 2 c))]))])
|
||||
(inset (frame (code ((copy cat) in the bag))) 2))
|
||||
]}
|
||||
|
||||
|
||||
@defform[(define-exec-code (pict-id runnable-id string-id)
|
||||
|
|
@ -294,3 +380,7 @@ The same as @racket[pict-last], provided for backward compatibility.}
|
|||
|
||||
Mainly for backward compatibility: returns @racket[(if bl-pict
|
||||
(use-last pict (or (pict-last bl-pict) bl-pict)))].}
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@close-eval[ss-eval]
|
||||
|
|
|
|||
126
collects/slideshow/code-pict.rkt
Normal file
126
collects/slideshow/code-pict.rkt
Normal file
|
|
@ -0,0 +1,126 @@
|
|||
#lang racket/base
|
||||
(require slideshow/pict
|
||||
texpict/code
|
||||
mzlib/unit
|
||||
(for-syntax racket/base
|
||||
syntax/to-string
|
||||
mzlib/list))
|
||||
|
||||
(define get-current-code-font-size (make-parameter (lambda () 12)))
|
||||
|
||||
(define current-code-line-sep (make-parameter 2))
|
||||
(define (current-font-size) ((get-current-code-font-size)))
|
||||
|
||||
(define-values/invoke-unit/infer code@)
|
||||
|
||||
(define-code code typeset-code)
|
||||
|
||||
(provide code
|
||||
current-code-line-sep
|
||||
get-current-code-font-size
|
||||
define-code
|
||||
(for-syntax prop:code-transformer
|
||||
code-transformer?
|
||||
make-code-transformer))
|
||||
(provide-signature-elements code^)
|
||||
|
||||
(provide define-exec-code/scale
|
||||
define-exec-code)
|
||||
(define-syntax (define-exec-code/scale stx)
|
||||
(define (drop-to-run l)
|
||||
(map (lambda (x)
|
||||
(cond
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'local (syntax-e (car (syntax-e x)))))
|
||||
(let ([l (syntax->list x)])
|
||||
(list* 'local
|
||||
(drop-to-run (syntax->list (cadr l)))
|
||||
(cddr l)))]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'define (syntax-e (car (syntax-e x)))))
|
||||
(let ([l (syntax->list x)])
|
||||
(list* 'define
|
||||
(cadr l)
|
||||
(drop-to-run (cddr l))))]
|
||||
[else x]))
|
||||
(filter (lambda (x)
|
||||
(cond
|
||||
[(eq? '_ (syntax-e x))
|
||||
#f]
|
||||
[(eq? '... (syntax-e x))
|
||||
#f]
|
||||
[(eq? 'code:blank (syntax-e x))
|
||||
#f]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'code:comment (syntax-e (car (syntax-e x)))))
|
||||
#f]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'code:contract (syntax-e (car (syntax-e x)))))
|
||||
#f]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'unsyntax (syntax-e (car (syntax-e x)))))
|
||||
#f]
|
||||
[else #t]))
|
||||
l)))
|
||||
(define (drop-to-show l)
|
||||
(foldr (lambda (x r)
|
||||
(cond
|
||||
[(and (identifier? x) (eq? '_ (syntax-e x)))
|
||||
(cdr r)]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'local (syntax-e (car (syntax-e x)))))
|
||||
(cons
|
||||
(let ([l (syntax->list x)])
|
||||
(datum->syntax
|
||||
x
|
||||
(list* (car l)
|
||||
(datum->syntax
|
||||
(cadr l)
|
||||
(drop-to-show (syntax->list (cadr l)))
|
||||
(cadr l))
|
||||
(cddr l))
|
||||
x))
|
||||
r)]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'cond (syntax-e (car (syntax-e x)))))
|
||||
(cons
|
||||
(let ([l (syntax->list x)])
|
||||
(datum->syntax
|
||||
x
|
||||
(list* (car l)
|
||||
(drop-to-show (cdr l)))
|
||||
x))
|
||||
r)]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'define (syntax-e (car (syntax-e x)))))
|
||||
(cons (let ([l (syntax->list x)])
|
||||
(datum->syntax
|
||||
x
|
||||
(list* (car l)
|
||||
(cadr l)
|
||||
(drop-to-show (cddr l)))
|
||||
x))
|
||||
r)]
|
||||
[else (cons x r)]))
|
||||
empty
|
||||
l))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ s (showable-name runnable-name string-name) . c)
|
||||
#`(begin
|
||||
(define runnable-name
|
||||
(quote-syntax
|
||||
(begin
|
||||
#,@(drop-to-run (syntax->list #'c)))))
|
||||
(define showable-name
|
||||
(scale/improve-new-text
|
||||
(code
|
||||
#,@(drop-to-show (syntax->list #'c)))
|
||||
s))
|
||||
(define string-name
|
||||
#,(syntax->string #'c)))]))
|
||||
|
||||
(define-syntax define-exec-code
|
||||
(syntax-rules ()
|
||||
[(_ (a b c) . r)
|
||||
(define-exec-code/scale 1 (a b c) . r)]))
|
||||
|
|
@ -1,121 +1,7 @@
|
|||
(module code "slideshow.rkt"
|
||||
(require texpict/code
|
||||
mzlib/unit)
|
||||
(require-for-syntax syntax/to-string
|
||||
mzlib/list)
|
||||
|
||||
(define current-code-line-sep (make-parameter line-sep))
|
||||
|
||||
(define-values/invoke-unit/infer code@)
|
||||
|
||||
(define-code code typeset-code)
|
||||
|
||||
(provide code
|
||||
current-code-line-sep
|
||||
define-code)
|
||||
(provide-signature-elements code^)
|
||||
|
||||
(provide define-exec-code/scale
|
||||
define-exec-code)
|
||||
(define-syntax (define-exec-code/scale stx)
|
||||
(define (drop-to-run l)
|
||||
(map (lambda (x)
|
||||
(cond
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'local (syntax-e (car (syntax-e x)))))
|
||||
(let ([l (syntax->list x)])
|
||||
(list* 'local
|
||||
(drop-to-run (syntax->list (cadr l)))
|
||||
(cddr l)))]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'define (syntax-e (car (syntax-e x)))))
|
||||
(let ([l (syntax->list x)])
|
||||
(list* 'define
|
||||
(cadr l)
|
||||
(drop-to-run (cddr l))))]
|
||||
[else x]))
|
||||
(filter (lambda (x)
|
||||
(cond
|
||||
[(eq? '_ (syntax-e x))
|
||||
#f]
|
||||
[(eq? '... (syntax-e x))
|
||||
#f]
|
||||
[(eq? 'code:blank (syntax-e x))
|
||||
#f]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'code:comment (syntax-e (car (syntax-e x)))))
|
||||
#f]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'code:contract (syntax-e (car (syntax-e x)))))
|
||||
#f]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'unsyntax (syntax-e (car (syntax-e x)))))
|
||||
#f]
|
||||
[else #t]))
|
||||
l)))
|
||||
(define (drop-to-show l)
|
||||
(foldr (lambda (x r)
|
||||
(cond
|
||||
[(and (identifier? x) (eq? '_ (syntax-e x)))
|
||||
(cdr r)]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'local (syntax-e (car (syntax-e x)))))
|
||||
(cons
|
||||
(let ([l (syntax->list x)])
|
||||
(datum->syntax-object
|
||||
x
|
||||
(list* (car l)
|
||||
(datum->syntax-object
|
||||
(cadr l)
|
||||
(drop-to-show (syntax->list (cadr l)))
|
||||
(cadr l))
|
||||
(cddr l))
|
||||
x))
|
||||
r)]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'cond (syntax-e (car (syntax-e x)))))
|
||||
(cons
|
||||
(let ([l (syntax->list x)])
|
||||
(datum->syntax-object
|
||||
x
|
||||
(list* (car l)
|
||||
(drop-to-show (cdr l)))
|
||||
x))
|
||||
r)]
|
||||
[(and (pair? (syntax-e x))
|
||||
(eq? 'define (syntax-e (car (syntax-e x)))))
|
||||
(cons (let ([l (syntax->list x)])
|
||||
(datum->syntax-object
|
||||
x
|
||||
(list* (car l)
|
||||
(cadr l)
|
||||
(drop-to-show (cddr l)))
|
||||
x))
|
||||
r)]
|
||||
[else (cons x r)]))
|
||||
empty
|
||||
l))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ s (showable-name runnable-name string-name) . c)
|
||||
#`(begin
|
||||
(define runnable-name
|
||||
(quote-syntax
|
||||
(begin
|
||||
#,@(drop-to-run (syntax->list #'c)))))
|
||||
(define showable-name
|
||||
(scale/improve-new-text
|
||||
(code
|
||||
#,@(drop-to-show (syntax->list #'c)))
|
||||
s))
|
||||
(define string-name
|
||||
#,(syntax->string #'c)))]))
|
||||
|
||||
(define-syntax define-exec-code
|
||||
(syntax-rules ()
|
||||
[(_ (a b c) . r)
|
||||
(define-exec-code/scale 1 (a b c) . r)])))
|
||||
|
||||
|
||||
#lang racket/base
|
||||
(require slideshow
|
||||
"code-pict.rkt")
|
||||
|
||||
(provide (all-from-out "code-pict.rkt"))
|
||||
|
||||
(get-current-code-font-size current-font-size)
|
||||
|
|
|
|||
|
|
@ -879,4 +879,23 @@
|
|||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(test 5
|
||||
'm->n
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval '(module m racket/base (define x 5) (provide (protect-out x))))
|
||||
(eval '(module n racket/base (require 'm)))
|
||||
(eval '(require 'n))
|
||||
(parameterize ([current-namespace (module->namespace ''n)])
|
||||
(eval 'x))))
|
||||
|
||||
(test #t
|
||||
'ffi/unsafe->n
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval '(module n racket/base (require ffi/unsafe)))
|
||||
(eval '(require 'n))
|
||||
(parameterize ([current-namespace (module->namespace ''n)])
|
||||
(eval '(procedure? ptr-set!)))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,10 @@
|
|||
(for-syntax racket/base)
|
||||
(only-in mzscheme make-namespace))
|
||||
|
||||
(provide define-code code^ code-params^ code@)
|
||||
(provide define-code code^ code-params^ code@
|
||||
(for-syntax prop:code-transformer
|
||||
code-transformer?
|
||||
make-code-transformer))
|
||||
|
||||
(define (to-code-pict p extension)
|
||||
(use-last* p extension))
|
||||
|
|
@ -60,6 +63,46 @@
|
|||
[(sep a . rest)
|
||||
(code-vl-append sep a (apply code-vl-append sep rest))]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-values (prop:code-transformer code-transformer? code-transformer-ref)
|
||||
(make-struct-type-property 'code-transformer
|
||||
(lambda (proc info)
|
||||
(unless (and (procedure? proc)
|
||||
(procedure-arity-includes? proc 2))
|
||||
(raise-argument-error 'guard-for-code-transformer
|
||||
"(procedure-arity-includes/c 2)"
|
||||
proc))
|
||||
proc)))
|
||||
|
||||
(define make-code-transformer
|
||||
(let ()
|
||||
(define-struct code-transformer (proc)
|
||||
#:property prop:code-transformer (lambda (r stx)
|
||||
(let ([proc (code-transformer-proc r)])
|
||||
(if (syntax? proc)
|
||||
(if (identifier? stx)
|
||||
proc
|
||||
#f) ; => render normally
|
||||
(proc stx)))))
|
||||
(lambda (proc)
|
||||
(unless (or (syntax? proc)
|
||||
(and (procedure? proc)
|
||||
(procedure-arity-includes? proc 1)))
|
||||
(raise-argument-error 'make-code-transformer
|
||||
"(or/c syntax? (procedure-arity-includes/c 1))"
|
||||
proc))
|
||||
(make-code-transformer proc))))
|
||||
|
||||
(define (transform id stx uncode-stx recur default)
|
||||
(define r (syntax-local-value id (lambda () #f)))
|
||||
(define t ((code-transformer-ref r) r stx))
|
||||
(if t
|
||||
(recur (datum->syntax stx
|
||||
(list uncode-stx t)
|
||||
stx
|
||||
stx))
|
||||
(default stx))))
|
||||
|
||||
(define-syntax (define-code stx)
|
||||
(syntax-case stx ()
|
||||
[(_ code typeset-code uncode)
|
||||
|
|
@ -68,21 +111,32 @@
|
|||
(define (stx->loc-s-expr v)
|
||||
(cond
|
||||
[(syntax? v)
|
||||
(let ([mk `(datum->syntax
|
||||
#f
|
||||
,(syntax-case v (uncode)
|
||||
[(uncode e) #'e]
|
||||
[else (stx->loc-s-expr (syntax-e v))])
|
||||
(list 'code
|
||||
,(syntax-line v)
|
||||
,(syntax-column v)
|
||||
,(syntax-position v)
|
||||
,(syntax-span v)))])
|
||||
(let ([prop (syntax-property v 'paren-shape)])
|
||||
(if prop
|
||||
`(syntax-property ,mk 'paren-shape ,prop)
|
||||
mk)))]
|
||||
[(pair? v) `(cons ,(stx->loc-s-expr (car v))
|
||||
(define (default v)
|
||||
(let ([mk `(datum->syntax
|
||||
#f
|
||||
,(syntax-case v (uncode)
|
||||
[(uncode e) #'e]
|
||||
[_ (stx->loc-s-expr (syntax-e v))])
|
||||
(list 'code
|
||||
,(syntax-line v)
|
||||
,(syntax-column v)
|
||||
,(syntax-position v)
|
||||
,(syntax-span v)))])
|
||||
(let ([prop (syntax-property v 'paren-shape)])
|
||||
(if prop
|
||||
`(syntax-property ,mk 'paren-shape ,prop)
|
||||
mk))))
|
||||
(syntax-case v ()
|
||||
[(id e (... ...))
|
||||
(and (identifier? #'id)
|
||||
(code-transformer? (syntax-local-value #'id (lambda () #f))))
|
||||
(transform #'id v (quote-syntax uncode) stx->loc-s-expr default)]
|
||||
[id
|
||||
(and (identifier? #'id)
|
||||
(code-transformer? (syntax-local-value #'id (lambda () #f))))
|
||||
(transform #'id v (quote-syntax uncode) stx->loc-s-expr default)]
|
||||
[_ (default v)])]
|
||||
[(pair? v) `(cons ,(stx->loc-s-expr (car v))
|
||||
,(stx->loc-s-expr (cdr v)))]
|
||||
[(vector? v) `(vector ,@(map
|
||||
stx->loc-s-expr
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user