From b6ba03fd182b5861b27a0f7020d550bcd260ce7a Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 6 Sep 2005 15:40:00 +0000
Subject: [PATCH] code macro improvements

svn: r775
---
 collects/slideshow/doc.txt |   3 +-
 collects/texpict/code.ss   | 263 ++++++++++++++++++++++++++-----------
 collects/texpict/doc.txt   |  41 ++++--
 3 files changed, 218 insertions(+), 89 deletions(-)

diff --git a/collects/slideshow/doc.txt b/collects/slideshow/doc.txt
index cea02a1cfc..362b6b35f5 100644
--- a/collects/slideshow/doc.txt
+++ b/collects/slideshow/doc.txt
@@ -563,7 +563,8 @@ The "code.ss" module also exports a `code' macro generated by
 
 > (code datum ...) - typesets the `datum' sequence to produce a pict;
                      see `define-code' from "code.s"" in the "texpict"
-                     collection for more information.
+                     collection for more information; `unsyntax' is
+                     the escape identifier.
 
 See documentation for "code.ss" in the "texpict" collection for more
 information.
diff --git a/collects/texpict/code.ss b/collects/texpict/code.ss
index 3c264b0f3c..338ca5826f 100644
--- a/collects/texpict/code.ss
+++ b/collects/texpict/code.ss
@@ -1,6 +1,7 @@
 (module code mzscheme
   (require "mrpict.ss"
 	   (lib "class.ss")
+	   (lib "list.ss")
            (lib "mred.ss" "mred")
 	   (lib "unitsig.ss"))
 
@@ -8,22 +9,26 @@
 
   (define-syntax (define-code stx)
     (syntax-case stx ()
-      [(_ code typeset-code)
+      [(_ code typeset-code uncode)
        (syntax/loc stx
 	 (define-syntax (code stx)
 	   (define (stx->loc-s-expr v)
 	     (cond
 	      [(syntax? v)
-	       `(datum->syntax-object
-		 #f
-		 ,(syntax-case v (unsyntax)
-		    [(unsyntax 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 ([mk `(datum->syntax-object
+			   #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))
 				,(stx->loc-s-expr (cdr v)))]
 	      [(vector? v) `(vector ,@(map
@@ -37,16 +42,19 @@
 	   (syntax-case stx ()
 	     [(_ expr) #`(typeset-code #,(cvt #'expr))]
 	     [(_ expr (... ...))
-	      #`(typeset-code #,(cvt #'(code:line expr (... ...))))])))]))
+	      #`(typeset-code #,(cvt #'(code:line expr (... ...))))])))]
+      [(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
   
   (define-signature code^
     (typeset-code 
-     comment-color keyword-color id-color literal-color
+     comment-color keyword-color id-color const-color literal-color
      code-align current-code-tt
-     current-keyword-list current-const-list code-colorize-enabled
+     current-keyword-list current-const-list current-literal-list 
+     code-colorize-enabled code-colorize-quote-enabled
      current-comment-color current-keyword-color 
      current-base-color current-id-color current-literal-color
-     current-open-paren current-close-paren))
+     current-reader-forms
+     mzscheme-const-list))
 
   (define-signature code-params^
     (current-font-size 
@@ -61,7 +69,7 @@
 	     (syntax-id-rules (set!)
 	       [(x (... ...)) ,illegal-use-of-once]
 	       [x (get-val)])))]))
-
+  
   (define code@
     (unit/sig code^
       (import code-params^)
@@ -77,17 +85,41 @@
       (define (code-align p)
 	(lift (inset p 0 (pict-height p) 0 0) (pict-height p)))
       
+      (define mzscheme-ns (let ([n (make-namespace 'empty)]
+				[orig (current-namespace)])
+			    (parameterize ([current-namespace n])
+			      (namespace-attach-module orig 'mzscheme)
+			      (namespace-require/copy 'mzscheme))
+			    n))
+      (define mzscheme-bindings (namespace-mapped-symbols mzscheme-ns))
+      (define mzscheme-vars (filter (lambda (n)
+				      (not (eq? 'nope
+						(namespace-variable-value n #f (lambda () 'nope) mzscheme-ns))))
+				    mzscheme-bindings))
+      
       (define current-keyword-list 
-	(make-parameter '("define" "cond" "define-struct" "and" "or" "else"
-			  "lambda" "require" "provide"  "require-for-syntax"
-			  "define-syntax" "let" "letrec" "let*" "syntax-rules"
-			  "syntax-case" "set!" "begin" "quote-syntax" "module")))
+	(make-parameter 
+	 (let ([ht (make-hash-table)])
+	   (for-each (lambda (n) (hash-table-put! ht n #f))
+		     mzscheme-vars)
+	   (map symbol->string
+		(filter (lambda (n)
+			  (hash-table-get ht n (lambda () #t)))
+			mzscheme-bindings)))))
       (define current-const-list 
-	(make-parameter '("null")))
+	(make-parameter '()))
+      (define current-literal-list 
+	(make-parameter '()))
+
+      (define mzscheme-const-list
+	(map symbol->string mzscheme-vars))
 
       (define code-colorize-enabled
 	(make-parameter #t))
 
+      (define code-colorize-quote-enabled
+	(make-parameter #t))
+
       (define (maybe-colorize p c)
 	(if (code-colorize-enabled)
 	    (colorize p c)
@@ -100,49 +132,80 @@
       (define current-id-color (make-parameter id-color))
       (define literal-color (make-object color% 51 135 39))
       (define current-literal-color (make-parameter literal-color))
+      (define const-color (make-object color% #x99 0 0))
+      (define current-const-color (make-parameter const-color))
       (define comment-color (current-base-color))
       (define current-comment-color (make-parameter comment-color))
-      (define current-open-paren (make-parameter #f))
-      (define current-close-paren (make-parameter #f))
+      (define current-reader-forms (make-parameter '(quote
+						     quasiquote 
+						     unquote unquote-splicing
+						     syntax
+						     quasisyntax
+						     unsyntax unsyntax-splicing)))
       
-      (define-computed open-paren-p (colorize (tt "(") (current-base-color)))
-      (define-computed close-paren-p (colorize (tt ")") (current-base-color)))
-      (define-computed open-sq-p (colorize (tt "[") (current-base-color)))
-      (define-computed close-sq-p (colorize (tt "]") (current-base-color)))
-      (define-computed quote-p (colorize (tt "'") (current-literal-color)))
-      (define-computed syntax-p (colorize (tt "#'") (current-keyword-color)))
-      (define-computed semi-p (colorize (tt "; ") (current-comment-color)))
-      (define-computed open-paren/lit-p (colorize (tt "(") (current-literal-color)))
-      (define-computed close-paren/lit-p (colorize (tt ")") (current-literal-color)))
-      (define-computed open-paren/tmpl-p (colorize (tt "(") (current-comment-color)))
-      (define-computed close-paren/tmpl-p (colorize (tt ")") (current-comment-color)))
+      (define-computed open-paren-p (tt "("))
+      (define-computed close-paren-p (tt ")"))
+      (define-computed open-sq-p (tt "["))
+      (define-computed close-sq-p (tt "]"))
+      (define-computed open-curly-p (tt "{"))
+      (define-computed close-curly-p (tt "}"))
 
-      (define-computed dot-p (colorize (tt " . ") (current-base-color)))
+      (define-computed quote-p (tt "'"))
+      (define-computed unquote-p (tt ","))
+      (define-computed unquote-splicing-p (tt ",@"))
+      (define-computed quasiquote-p (tt "`"))
+      (define-computed syntax-p (tt "#'"))
+      (define-computed unsyntax-p (tt "#,"))
+      (define-computed unsyntax-splicing-p (tt "#,@"))
+      (define-computed quasisyntax-p (tt "#`"))
+      (define-computed semi-p (tt "; "))
 
-      (define (get-close mode)
-	(case mode
-	  [(literal) close-paren/lit-p]
-	  [(template comment) close-paren/tmpl-p]
-	  [(cond template-cond local) close-sq-p]
-	  [else (or (current-close-paren)
-		    close-paren-p)]))
+      (define (comment-mode? mode)
+	(eq? mode 'comment))
+      
+      (define-computed dot-p (tt " . "))
 
-      (define (get-open mode)
-	(case mode
-	  [(literal) open-paren/lit-p]
-	  [(template comment) open-paren/tmpl-p]
-	  [(contract line) (blank)]
-	  [(cond template-cond local) open-sq-p]
-	  [else (or (current-open-paren)
-		    open-paren-p)]))
+      (define (mode-colorize mode type p)
+	(maybe-colorize
+	 p
+	 (case mode
+	   [(literal) (current-literal-color)]
+	   [(comment) (current-comment-color)]
+	   [else (cond
+		  [(number? mode) (current-literal-color)]
+		  [(eq? type 'keyword) (current-keyword-color)]
+		  [(eq? type 'literal) (current-literal-color)]
+		  [(eq? type 'const) (current-const-color)]
+		  [(eq? type 'id) (current-id-color)]
+		  [else (current-base-color)])])))
+	
+      (define (get-open mode stx)
+	(if (memq mode '(contract line))
+	    (blank)
+	    (mode-colorize 
+	     mode #f
+	     (case (syntax-property stx 'paren-shape)
+	       [(#\[) open-sq-p]
+	       [(#\{) open-curly-p]
+	       [else open-paren-p]))))
+	
+      (define (get-close mode stx)
+	(if (memq mode '(contract line))
+	    (blank)
+	    (mode-colorize
+	     mode #f
+	     (case (syntax-property stx 'paren-shape)
+	       [(#\[) close-sq-p]
+	       [(#\{) close-curly-p]
+	       [else close-paren-p]))))
       
       (define (add-close p closes)
 	(cond
 	 [(null? closes) p]
-	 [(memq (car closes) '(contract line))
+	 [(memq (caar closes) '(contract line))
 	  (add-close p (cdr closes))]
 	 [else
-	  (add-close (hbl-append p (get-close (car closes)))
+	  (add-close (hbl-append p (get-close (caar closes) (cdar closes)))
 		     (cdr closes))]))
 
       (define (pad-left space p)
@@ -160,8 +223,9 @@
 	 [(and ((string-length str) . > . 1)
 	       (char=? #\_ (string-ref str 0))
 	       (not (char=? #\_ (string-ref str 1))))
-	  (maybe-colorize (text (substring str 1) `(bold italic . modern) (current-font-size))
-			  (current-id-color))]
+	  (mode-colorize
+	   mode 'id
+	   (text (substring str 1) `(bold italic . modern) (current-font-size)))]
 	 [(regexp-match #rx"^(.+)_([0-9a-z]+)\\^([0-9a-z]+)$" str)
 	  => (lambda (m)
 	       (hbl-append (colorize-id (cadr m) mode)
@@ -183,14 +247,14 @@
 	       (hbl-append (colorize-id (cadr m) mode)
 			   (text (caddr m) `(subscript bold . modern) (current-font-size))))]
 	 [else
-	  (maybe-colorize
-	   (tt str)
+	  (mode-colorize
+	   mode 
 	   (cond
-	    [(eq? mode 'literal) (current-literal-color)]
-	    [(memq mode '(comment template)) (current-comment-color)]
-	    [(member str (current-keyword-list)) (current-keyword-color)]
-	    [(member str (current-const-list)) (current-literal-color)]
-	    [else (current-id-color)]))]))
+	    [(member str (current-keyword-list)) 'keyword]
+	    [(member str (current-const-list)) 'const]
+	    [(member str (current-literal-list)) 'literal]
+	    [else 'id])
+	   (tt str))]))
 
       (define (sub-mode mode)
 	(case mode
@@ -210,26 +274,73 @@
           [code:blank 1]
           [_ (or (syntax-span stx) 1)]))
       
+      (define (color-semi-p)
+	(mode-colorize 'comment #f semi-p))
+
       (define (add-semis p)
-	(let loop ([p p] [semis semi-p])
+	(let loop ([p p] [semis (color-semi-p)])
 	  (if ((pict-height p) . > . (+ (pict-height semis) 1))
-	      (loop p (vl-append line-sep semi-p semis))
+	      (loop p (vl-append line-sep (color-semi-p) semis))
 	      (htl-append semis p))))
 
+      (define (add-unquote unquote-p loop x closes mode)
+	(let ([mode (cond
+		     [(number? mode) (if (zero? mode)
+					 #f
+					 (sub1 mode))]
+		     [else mode])])
+	  (htl-append (mode-colorize mode 'keyword unquote-p) 
+		      (loop x closes mode))))
+
       (define (typeset-code stx)
 	(let loop ([stx stx][closes null][mode #f])
-	  (syntax-case* stx (quote syntax-unquote syntax
+	  (syntax-case* stx (quote unquote unquote-splicing quasiquote
+				   syntax-unquote syntax unsyntax
+				   unsyntax-splicing quasisyntax
 				   code:contract code:comment code:line
 				   code:template code:blank $)
 			(lambda (a b) (eq? (syntax-e a) (syntax-e b)))
-	    [() (add-close (htl-append (get-open mode) (get-close mode))
+	    [() (add-close (htl-append (get-open mode stx) (get-close mode stx))
 			   closes)]
 	    [code:blank (tt " ")]
 	    [$ (colorize-id "|" closes)]
 	    [(quote x)
-	     (htl-append quote-p (loop #'x closes 'literal))]
+	     (memq 'quote (current-reader-forms))
+	     (htl-append (mode-colorize mode 'literal quote-p) 
+			 (loop #'x closes (if (or (not (code-colorize-quote-enabled))
+						  (comment-mode? mode))
+					      mode
+					      'literal)))]
+	    [(unquote x)
+	     (memq 'unquote (current-reader-forms))
+	     (add-unquote unquote-p loop #'x closes mode)]
+	    [(unquote-splicing x)
+	     (memq 'unquote-splicing (current-reader-forms))
+	     (add-unquote unquote-splicing-p loop #'x closes mode)]
+	    [(quasiquote x)
+	     (memq 'quasiquote (current-reader-forms))
+	     (htl-append (mode-colorize mode 'keyword quasiquote-p) 
+			 (loop #'x closes (cond
+					   [(not (code-colorize-quote-enabled)) mode]
+					   [(comment-mode? mode) mode]
+					   [(number? mode) (add1 mode)]
+					   [else 0])))]
 	    [(syntax x)
-	     (htl-append syntax-p (loop #'x closes mode))]
+	     (memq 'syntax (current-reader-forms))
+	     (htl-append (mode-colorize mode 'literal syntax-p) 
+			 (loop #'x closes mode))]
+	    [(unsyntax x)
+	     (memq 'unsyntax (current-reader-forms))
+	     (htl-append (mode-colorize mode 'literal unsyntax-p) 
+			 (loop #'x closes mode))]
+	    [(unsyntax-splicing x)
+	     (memq 'unsyntax-splicing (current-reader-forms))
+	     (htl-append (mode-colorize mode 'literal unsyntax-splicing-p) 
+			 (loop #'x closes mode))]
+	    [(quasisyntax x)
+	     (memq 'unsyntax-splicing (current-reader-forms))
+	     (htl-append (mode-colorize mode 'literal quasisyntax-p) 
+			 (loop #'x closes mode))]
 	    [(code:contract i ...)
 	     (add-semis (loop (datum->syntax-object #f (syntax->list #'(i ...)))
 			      closes 'contract))]
@@ -238,20 +349,20 @@
 		   closes 'line)]
 	    [(code:comment s ...)
 	     (apply htl-append 
-		    semi-p 
+		    (color-semi-p)
 		    (map (lambda (s)
 			   (if (pict? (syntax-e s))
 			       (syntax-e s)
 			       (maybe-colorize (tt (syntax-e s)) (current-comment-color))))
 			 (syntax->list #'(s ...))))]
-	    [(code:template i)
-	     (add-semis (loop #'i closes 'template))]
+	    [(code:template i ...)
+	     (add-semis (loop #'(code:line i ...) closes 'template))]
 	    [(i ...)
 	     (let ([is (syntax->list #'(i ...))])
 	       ;; Convert each i to a picture, include close paren in last item:
 	       (let ([ips (let iloop ([is is][sub-mode (sub-mode mode)])
 			    (cond
-			     [(null? (cdr is)) (list (loop (car is) (cons mode closes) sub-mode))]
+			     [(null? (cdr is)) (list (loop (car is) (cons (cons mode stx) closes) sub-mode))]
 			     [else (cons (loop (car is) null sub-mode)
 					 (iloop (cdr is) (cond
 							  [(cond? (car is))
@@ -268,7 +379,7 @@
 		 (let ([left (or (syntax-column stx) +inf.0)])
 		   (let loop ([stxs is]
 			      [ps ips]
-			      [line-so-far (get-open mode)]
+			      [line-so-far (get-open mode stx)]
 			      [col (+ left 1)]
 			      [line (syntax-line stx)]
 			      [always-space? #f]
@@ -326,12 +437,14 @@
 	     (identifier? stx)
 	     (add-close (colorize-id (symbol->string (syntax-e stx)) mode) closes)]
 	    [(a . b)
-	     (hbl-append open-paren-p (loop #'a null mode)
-			 dot-p (loop #'b (cons mode closes) mode))]
+	     (hbl-append (mode-colorize mode #f open-paren-p) (loop #'a null mode)
+			 (mode-colorize mode #f dot-p)
+			 (loop #'b (cons (cons mode stx) closes) mode))]
 	    [else
 	     (add-close (if (pict? (syntax-e stx))
 			    (syntax-e stx)
-			    (maybe-colorize (tt (format "~s" (syntax-e stx))) (current-literal-color)))
+			    (mode-colorize mode 'literal
+					   (tt (format "~s" (syntax-e stx))) ))
 			closes)])))
       
       )))
diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt
index 85dd79711e..1e4cc721e0 100644
--- a/collects/texpict/doc.txt
+++ b/collects/texpict/doc.txt
@@ -1120,9 +1120,15 @@ The _code^_ unit supplies the following
 > current-keyword-color - parameter for a string or color% for keywords
 > current-id-color - parameter for a string or color% for identifiers
 > current-literal-color - parameter for a string or color% for literals
+> current-const-color - parameter for a string or color% for constants
 > current-base-color - parameter for a string or color% for everything else
-> current-open-paren - #f or a pict to use for plain open parens
-> current-close-paren - #f or a pict to use for plain close parens
+
+> current-reader-forms - parameter for a list of symbols indicating
+                         which built-in reader forms should be used;
+                         the default is '(quote quasiquote unquote
+			 unquote-splicing syntax  quasisyntax unsyntax
+			 unsyntax-splicing); remove a symbol to suppress
+			 the corresponding reader output
 
 For backward compatibility:
 > comment-color - default string/color% for comments
@@ -1137,18 +1143,26 @@ For backward compatibility:
 > current-keyword-list - a list of identifiers to color as keywords; the
   default includes the MzScheme syntactic form names
 
-> current-const-list - a list of identifiers to color ad literals; the
-  default is 'empty
+> current-const-list - a list of identifiers to color as constants; the
+  default is empty
+
+> current-literal-list - a list of identifiers to color as literals; the
+  default is empty
 
 > code-colorize-enabled - a parameter to enable or disable all code
-  coloring
+  coloring; the default is #t
+> code-colorize-quote-enabled - a parameter to control whether everything
+  under a quote is colorized as a literal (like DrScheme's Check Syntax,
+  and unlike DrScheme's interactive text coloring); the default is #t
 
 In addition to the `code@' unit, the "code.ss" module exports a
 `define-code' macro for defining other macros:
 
-> (define-code code-id typeset-code-id) - defines `code-id' as a macro
-  that uses `typeset-code-id', which is a function with the same input
-  as `typeset-code'.
+> (define-code code-id typeset-code-id) 
+> (define-code code-id typeset-code-id escape-id)
+  - defines `code-id' as a macro that uses `typeset-code-id', which is
+  a function with the same input as `typeset-code'. The `escape-id'
+  form defaults to `unsyntax'.
 
   The `code-id' syntactic form takes a sequence of `datum's:
 
@@ -1156,12 +1170,13 @@ In addition to the `code@' unit, the "code.ss" module exports a
 
   It produces a pict that typesets the sequence. Source-location
   information for the `datum' determine the layout of code in the
-  resulting pict.
+  resulting pict. A pict datum is drawn as itself.
 
-  If a `datum' contains `(unsyntax expr)' (perhaps as #,expr), then
-  the `expr' is evaluated and the result datum is spliced in place of
-  the `unsyntax' form in `datum'. If the result is not a syntax object,
-  it is given the source location of the `(unsyntax expr)'.
+  If a `datum' contains `(escape-id expr)' (perhaps as #,expr when
+  `escape-id' is `unsyntax'), then the `expr' is evaluated and the
+  result datum is spliced in place of the `unsyntax' form in
+  `datum'. If the result is not a syntax object, it is given the
+  source location of the `(unsyntax expr)'.
 
   The `code' syntactic form expands to a use of `typeset-code'. The
   `datum's are not merely syntax-quoted, because then the compiled