making the stepper (mostly) happy

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

@@ -22,19 +22,14 @@
   (syntax-parse stx #:literals (DEFAULT) 
     [(_ the-list super-list define-create
         (kw:identifier 
-         (~optional kw-alt:identifier 
+         (~optional kw-alt:identifier #:defaults ((kw-alt #'kw)))
-                    #:defaults ((kw-alt #'kw #;(datum->syntax stx (gensym)))))
          (~optional (~seq DEFAULT default:expr))
          coerce:expr) ...)
      (let* ([defs (attribute default)])
        #`(begin
            ;; define and create list of keywords and associated values 
            (define-for-syntax the-list
-             (append super-list
+             (list* (list #'kw #'kw-alt (coerce ''kw) default) ... super-list))
-                     (list (list #'kw     #'kw-alt (coerce ''kw) default)
-                           #;
-                           (list #'kw-alt #'kw (coerce ''kw-alt) default))
-                     ...))
            ;; define and provide keywords
            (provide (rename-out (kw  kw-alt) ...))
            (provide kw ...) 
@@ -43,11 +38,15 @@
                        (raise-syntax-error 'kw "used out of context" x))
                      ...))
            
+           ;; a macro for creating functions that instantiate the proper object
+           ;; (define-create para ...) :: additional parameters for the new func
            (define-syntax (define-create stx)
              (syntax-case stx ()
                [(_ para (... ...))
                 (let*-values
                     ([(kwds defs)
+                      (values (map car the-list) '())
+                      #;
                       (let L ([the-list the-list][kwds '()][defs '()])
                         (if (null? the-list)
                             (values kwds defs)
@@ -61,32 +60,16 @@
                                   (L (cdr the-list)
                                      (list* kw0 kw1 kwds)
                                      (list* def def defs))))))]
+                     ;; the defaults list defs is no longer needed
                      [(args) (lambda (para*)
-                               (append 
+                               (append para* (foldr cons '() kwds)))]
-                                para*
-                                (foldr (lambda (x d rst)
-                                         (define k (string->keyword 
-                                                    (symbol->string
-                                                     (syntax-e x))))
-                                         ;; This 'if' doesn't work because 
-                                         ;; I don't know how to use 'attribute'
-                                         ;; properly here and have default values
-                                         ;; for everything. big-bang and universe
-                                         ;; check already that defaults are provided. 
-                                         (if d
-                                             (append (list k `(,x ,d)) rst)
-                                             (append (list k x) rst)))
-                                       '() 
-                                       kwds
-                                       defs)))]
                      [(body) (lambda (para*)
                                (map (lambda (x) `(,x ,x)) (append para* kwds)))])
                   (let ([para* (syntax->list #'(para (... ...)))])
                     #`(lambda (%)
-                        (lambda #,(args  para*)
+                        (lambda #,(args para*)
                           (lambda ()
-                            (define o (new % #,@(body para*)))
+                            (new % #,@(body para*)))))))]))))]))
-                            o)))))]))))]))
 
 #|
   transform the clauses into the initial arguments specification 
@@ -107,6 +90,20 @@
   (define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds))
   (duplicates? tag spec)
   (not-a-clause tag stx state0 kwds)
+  (map (lambda (s) 
+         (define kw (first s))
+         (define kw-alt (second s))
+         (define r
+           (let loop ([spec spec])
+             (cond
+               [(null? spec) #false]
+               [(or (free-identifier=? (caar spec) kw)
+                    (free-identifier=? (caar spec) kw-alt))
+                (syntax->list (cdar spec))]
+               [else (loop (cdr spec))])))
+         (if r ((third s) r) (fourth s)))
+       Spec)
+  #;
   (apply append
          (map (lambda (x) 
                 (define kw (car x))
@@ -186,14 +183,14 @@
        (lambda (p)
          (syntax-case p ()
            [(_ x) #`(proc> #,tag (f2h x) arity)]
-           [_ (err tag p)])))]
+           [_ (displayln p) (err tag p)])))]
     [(_ arity except extra)
      (lambda (tag)
        (lambda (p)
          (syntax-case p ()
            [(_ x) #`(proc> #,tag (f2h x) arity)]
            extra
-           [_ (err tag p)])))]))
+           [_ (displayln p) (err tag p)])))]))
 
 (define (err spec p . xtras)
   (raise-syntax-error (cadr spec)

collects/2htdp/private/world.rkt

@@ -64,13 +64,13 @@
        (on-release K)    ;; World KeyEvent -> World 
        (on-mouse K)      ;; World Nat Nat MouseEvent -> World 
        (on-receive #f)   ;; (U #f (World S-expression -> World))
-       (on-draw #f)
+       (on-draw #f)      ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
-       (to-draw #f)      ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
        (stop-when False) ;; World -> Boolean 
        (record? #f))     ;; Boolean 
       
       ;; -----------------------------------------------------------------------
       (field
+       [to-draw on-draw]
        [world
         (new checked-cell% [msg "World"] [value0 world0] [ok? check-with]
              [display (and state (or name "your world program's state"))])])

collects/2htdp/universe.rkt

@@ -311,19 +311,15 @@
     [(universe) (raise-syntax-error #f "not a legal universe description" stx)]
     [(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
     [(universe u bind ...)
-     (let*
+     (let* ([args
-         ([args (->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
+             (->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
-          [domain (map (lambda (x)
+            [dom (map (compose car syntax->datum) (syntax->list #'(bind ...)))])
-                         (if (keyword? x)
-                             (string->symbol (keyword->string x))
-                             x))
-                       args)])
        (cond
-         [(not (memq 'on-new domain))
+         [(not (memq 'on-new dom))
           (raise-syntax-error #f "missing on-new clause" stx)]
-         [(not (memq 'on-msg domain))
+         [(not (memq 'on-msg dom))
           (raise-syntax-error #f "missing on-msg clause" stx)]
-         [else ; (and (memq #'on-new domain) (memq #'on-msg domain))
+         [else ; (and (memq #'on-new dom) (memq #'on-msg dom))
           #`(run-it ((new-universe universe%) u #,@args))]))]))
 
 ;