diff --git a/collects/scribblings/slideshow/code.scrbl b/collects/scribblings/slideshow/code.scrbl index 73b743e6c8..e8af8ddb10 100644 --- a/collects/scribblings/slideshow/code.scrbl +++ b/collects/scribblings/slideshow/code.scrbl @@ -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] diff --git a/collects/slideshow/code-pict.rkt b/collects/slideshow/code-pict.rkt new file mode 100644 index 0000000000..51e2f62c3c --- /dev/null +++ b/collects/slideshow/code-pict.rkt @@ -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)])) diff --git a/collects/slideshow/code.rkt b/collects/slideshow/code.rkt index 816a44fb0a..0bf1b24828 100644 --- a/collects/slideshow/code.rkt +++ b/collects/slideshow/code.rkt @@ -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) diff --git a/collects/tests/racket/module.rktl b/collects/tests/racket/module.rktl index d93cc948d7..4b616d2f8e 100644 --- a/collects/tests/racket/module.rktl +++ b/collects/tests/racket/module.rktl @@ -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) diff --git a/collects/texpict/code.rkt b/collects/texpict/code.rkt index 46a3398198..92452d43ff 100644 --- a/collects/texpict/code.rkt +++ b/collects/texpict/code.rkt @@ -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