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

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
+@defmodule*[(slideshow/code-pict slideshow/code)]{
-provides utilities for typesetting Racket code as a pict.}
+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]

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

collects/slideshow/code.rkt

@@ -1,121 +1,7 @@
-(module code "slideshow.rkt"
+#lang racket/base
-  (require texpict/code
+(require slideshow
-           mzlib/unit)
+         "code-pict.rkt")
-  (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)])))
-
-
 
+(provide (all-from-out "code-pict.rkt"))
 
+(get-current-code-font-size current-font-size)

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)

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
+               (define (default v)
-			   #f
+                 (let ([mk `(datum->syntax
-			   ,(syntax-case v (uncode)
+                             #f
-			      [(uncode e) #'e]
+                             ,(syntax-case v (uncode)
-			      [else (stx->loc-s-expr (syntax-e v))])
+                                [(uncode e) #'e]
-			   (list 'code
+                                 [_ (stx->loc-s-expr (syntax-e v))])
-				 ,(syntax-line v)
+                              (list 'code
-				 ,(syntax-column v)
+                                    ,(syntax-line v)
-				 ,(syntax-position v)
+                                    ,(syntax-column v)
-				 ,(syntax-span v)))])
+                                    ,(syntax-position v)
-		 (let ([prop (syntax-property v 'paren-shape)])
+                                    ,(syntax-span v)))])
-		   (if prop
+                   (let ([prop (syntax-property v 'paren-shape)])
-		       `(syntax-property ,mk 'paren-shape ,prop)
+                     (if prop
-		       mk)))]
+                         `(syntax-property ,mk 'paren-shape ,prop)
-	      [(pair? v) `(cons ,(stx->loc-s-expr (car v))
+                         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