support several keywords per clause

collects/2htdp/private/syn-aux.ss

@@ -1,6 +1,10 @@
 #lang scheme
 
-(provide define-keywords function-with-arity expr-with-check except err 
+(provide define-keywords 
+         ;; (define-keywords (name1:identifier ... spec:expr) ...)
+         ;; constraint: the first name is the original name
+         ;; and it is also the name of the field in the class
+         function-with-arity expr-with-check except err 
          ->args
          ->kwds-in
          clauses-use-kwd)
@@ -10,6 +14,41 @@
                scheme
                (rename-in lang/prim (first-order->higher-order f2h))))
 
+(require (for-syntax syntax/parse))
+(define-syntax (define-keywords stx)
+  (syntax-parse stx 
+    [(define-keywords the-list (kw:identifier ... coerce:expr) ...)
+     #'(begin
+         (provide kw ...) ...
+         (define-syntaxes (kw ...)
+           (values (lambda (x)
+                     (raise-syntax-error 'kw "used out of context" x))
+                   ...))
+         ...
+         (define-for-syntax the-list
+           (apply append 
+                  (list 
+                   (let* ([x (list (list #'kw ''kw) ...)]
+                          [f (caar x)])
+                     (map (lambda (x) 
+                            (define clause-name (car x))
+                            (define clause-spec (cadr x))
+                            (list clause-name f (coerce clause-spec)))
+                          x))
+                   ...))))]))
+
+#;
+(define-syntax-rule
+  (define-keywords the-list (kw coerce) ...)
+  (begin
+    (provide kw ...) 
+    (define-syntax kw
+      (lambda (x)
+        (raise-syntax-error 'kw "used out of context" x)))
+    ...
+    (define-for-syntax the-list
+      (list (list #'kw (coerce ''kw)) ...))))
+
 #|
   transform the clauses into the initial arguments specification 
   for a new expression that instantiates the appropriate class
@@ -32,7 +71,9 @@
          (define-values (key coercion)
            (let loop ([kwds kwds][Spec Spec])
              (if (free-identifier=? (car kwds) kw)
-                 (values (car kwds) (cadar Spec))
+                 ;; -- the original keyword, which is also the init-field name
+                 ;; -- the coercion that comes with it 
+                 (values (cadar Spec) (caddar Spec))
                  (loop (cdr kwds) (cdr Spec)))))
          (list key (coercion (cdr x))))
        spec))
@@ -71,14 +112,6 @@
   (lambda (k)
     (and (identifier? k) (for/or ([n kwds]) (free-identifier=? k n)))))
 
-(define-syntax-rule (define-keywords the-list (kw coerce) ...)
-  (begin
-    (provide kw ...)
-    (define-syntax (kw x)
-      (raise-syntax-error 'kw "used out of context" x))
-    ...
-    (define-for-syntax the-list (list (list #'kw (coerce ''kw)) ...))))
-
 (define-syntax (expr-with-check stx)
   (syntax-case stx ()
     [(_ check> msg)

collects/2htdp/universe.ss

@@ -137,13 +137,14 @@
 
 (define-keywords WldSpec 
   ;; -- on-draw must specify a rendering function; it may specify dimensions
-  [on-draw (function-with-arity 
+  [on-draw to-draw
+           (function-with-arity 
             1 
             except
-            [(_ f width height) 
-             #'(list (proc> 'on-draw (f2h f) 1) 
-                     (nat> 'on-draw width "width")
-                     (nat> 'on-draw height "height"))])]
+            [(_ f width height)
+             #'(list (proc> 'to-draw (f2h f) 1) 
+                     (nat> 'to-draw width "width")
+                     (nat> 'to-draw height "height"))])]
   ;; -- on-mouse must specify a mouse event handler 
   [on-mouse (function-with-arity 4)]
   ;; -- on-key must specify a key event handler 
@@ -188,7 +189,7 @@
 
 (define (run-simulation f)
   (check-proc 'run-simulation f 1 "first" "one argument")
-  (big-bang 1 (on-tick add1) (on-draw f)))
+  (big-bang 1 (on-draw f) (on-tick add1)))
 
 (define animate run-simulation)