Partly revert d53a197 & 36fc539 to workaround #233 (#238)

* Partly revert d53a197 & 36fc539 to workaround #233

  To workaround #233, this partly reverts commits

  - "highlight universe when set-up fails at run-time".
     d53a197
  - "fix resource administration in run and launch-many-worlds".
     36fc539

  Otherwise, when the object `[((new-world (if #,rec? aworld% world%)) w #,@Args)]`
  and `[((new-universe universe%) u #,@Args)]` are created in the main thread, the
  continuation marks of the stepper are somehow broken.

  A more appropriate fix should be applied in the future.

* Forward `check-with` errors to the main thread and
  report initial check-with error w/ big-bang stack

* Test stepper with `big-bang`

  In `big-bang` tests, if the tick frequency is too high, some `to-draw`
  steps (e.g. the one immediately following the launch of big-bang) can
  be absent in stepper because no such calls were made.

  This commit adds the `(quasiquote (repetition ,lo ,hi ,steps))` form to
  stepper tests to account for skippable steps.

htdp-lib/2htdp/universe.rkt

@@ -276,7 +276,7 @@
          [else
           (syntax-property 
            (stepper-syntax-property
-            (quasisyntax/loc stx (send [((new-world (if #,rec? aworld% world%)) w #,@args)] last))
+            (quasisyntax/loc stx (run-it ((new-world (if #,rec? aworld% world%)) w #,@args)))
             'stepper-skip-completely #t)
            'disappeared-use (map (lambda (x) (car (syntax->list x))) dom))]))]))
 
@@ -411,7 +411,7 @@
           (raise-syntax-error #f "expects a on-msg clause, but found none" stx)]
          [else ; (and (memq #'on-new dom) (memq #'on-msg dom))
           (syntax-property 
-           (quasisyntax/loc stx (send [((new-universe universe%) u #,@args)] last))
+           (quasisyntax/loc stx (run-it ((new-universe universe%) u #,@args)))
            'disappeared-use (map (lambda (x) (car (syntax->list x))) dom))]))]))
 
 ;                                          
@@ -430,12 +430,23 @@
 ;                                          
 ;                                          
 
-#;
+;; (-> Object) -> Any
 (define (run-it o)
   (define esp (make-eventspace))
   (define thd (eventspace-handler-thread esp))
   (with-handlers ((exn:break? (lambda (x) (break-thread thd))))
-    (define obj:ch (make-channel))
+    (define obj-or-exn:ch (make-channel))
     (parameterize ([current-eventspace esp])
-      (queue-callback (lambda () (channel-put obj:ch (o)))))
-    (send (channel-get obj:ch) last)))
+      (queue-callback
+       (lambda ()
+         (with-handlers ([exn:fail? (lambda (e) (channel-put obj-or-exn:ch e))])
+           (channel-put obj-or-exn:ch (o))))))
+    (match (channel-get obj-or-exn:ch)
+      [(? exn:fail? e)
+       (raise (if (regexp-match? #rx"check-with" (exn-message e))
+                  ;; Report big-bang check-with errors using the big-bang's stack frames
+                  ;; instead of esp/thd's stacks
+                  (make-exn:fail:contract (exn-message e)
+                                          (current-continuation-marks))
+                  e))]
+      [obj (send obj last)])))

htdp-test/info.rkt

@@ -10,7 +10,6 @@
                      "redex-lib"
                      "racket-index"
                      "scheme-lib"
-                     "srfi-lite-lib"
                      "compatibility-lib"
                      "gui-lib"
                      "racket-test"

htdp-test/tests/stepper/automatic-tests.rkt

@@ -33,8 +33,7 @@
   '(local-struct/ilam
     local-struct/i
     begin-let-bug
-    qq-splice
-    big-bang))
+    qq-splice))
 
 ;; this test anticipates the implementation of the stepper
 ;; for check-random, which is not yet implemented

htdp-test/tests/stepper/test-abbrev.rkt

@@ -1,6 +1,6 @@
 #lang racket
 
-(require (for-syntax scheme/mpair))
+(require (for-syntax scheme/mpair racket/list))
 
 (provide t)
 
@@ -49,25 +49,43 @@
   (define (process stx)
     (split (map (lambda (s)
                   (if (and (identifier? s)
-                           (memq (syntax-e s) '(:: -> error:)))
+                           (memq (syntax-e s) '(:: ::* -> error:)))
                       (syntax-e s)
                       (process-hilites s)))
                 (syntax->list stx))))
+  (define (parse-:: rest)
+    (syntax-case rest (:: ::* -> error:)
+      [(error: (err)) (list #'(error err))]
+      [() (list #'(finished-stepping))]
+      [(x -> y) (list #'(before-after x y) #'(finished-stepping))]
+      [(x -> error: (err)) (list #'(before-error x err))]
+      [(x -> y :: . rest)
+       (cons #'(before-after x y) (parse-:: #'rest))]
+      [(x -> y ::*([lo hi] . snd) . rest)
+       (cons #'(before-after x y) (parse-::* #'lo #'hi #'(snd . rest)))]
+      [(x -> y -> . rest)
+       (cons #'(before-after x y) (parse-:: #'(y -> . rest)))]))
+  (define (parse-::* lo hi curr)
+    (define-values (prefix suffix)
+      (let rep-scan-loop ([prevs '()] [curr curr])
+        (syntax-case curr (:: ::*)
+          [()           (values (reverse prevs) curr)]
+          [(:: . rest)  (values (reverse prevs) curr)]
+          [(::* . rest) (values (reverse prevs) curr)]
+          [(fst . rest) (rep-scan-loop (cons #'fst prevs) #'rest)])))
+    (cons #`(repetition #,lo #,hi #,(drop-right (parse-:: prefix) 1))
+          ;; ^ drop-right to remove the trailing (finished-stepping) in repetition steps
+          (syntax-case suffix (:: ::*)
+            [()                                (parse-:: suffix)]
+            [(:: rest ...)                     (parse-:: #'(rest ...))]
+            [(::* ([lo hi] snd ...) rest ...)  (parse-::* #'lo #'hi #'((snd ...) rest ...))])))
   (define (parse l)
-    (syntax-case l (::)
+    (syntax-case l (:: ::*)
       [(fst :: rest ...)
-       (cons #'fst
-             (let loop ([rest #'(rest ...)])
-               (syntax-case rest (:: -> error:)
-                 [(error: (err)) (list #'(error err))]
-                 [() (list #'(finished-stepping))]
-                 [(x -> y) (list #'(before-after x y) #'(finished-stepping))]
-                 [(x -> error: (err)) (list #'(before-error x err))]
-                 [(x -> y :: . rest)
-                  (cons #'(before-after x y) (loop #'rest))]
-                 [(x -> y -> . rest)
-                  (cons #'(before-after x y) (loop #'(y -> . rest)))])))]))
-  (syntax-case stx (::)
+       (cons #'fst (parse-:: #'(rest ...)))]
+      [(fst ::* ([lo hi] snd ...) rest ...)
+       (cons #'fst (parse-::* #'lo #'hi #'((snd ...) rest ...)))]))
+  (syntax-case stx (:: ::*)
     [(_ name ll-models . rest)
      (with-syntax ([(exprs arg ...) (parse (process #'rest))])
        (quasisyntax/loc stx

htdp-test/tests/stepper/test-cases.rkt

@@ -36,7 +36,12 @@
 ;; (before-after exps exps)
 ;; (before-error exps str)
 ;; (error str)
-;; (finished)
+;; (repetition lo hi (non-empty-listof step)) steps are repeated for [lo,hi] times (inclusive)
+;; (finished-stepping)
+;;
+;; The repetition form matches the steps greedily---it is not a regular expression form.
+;; It will try to match as many steps as possible.
+;;
 ;; an exps is a list of s-expressions with certain non-hygienic extensions:
 ;;  - (hilite X) denotes the s-expression X, only highlighted
 ;;  - any        denotes any s-expression (matches everything)
@@ -50,6 +55,10 @@
 ;;    expr1 ... :: expr2 ... -> expr3 ...)
 ;; means that `expr1 ...' is the original, the first step is
 ;;   (before-after (expr2 ...) (expr3 ...))
+;; to express repetitions, write
+;;    ::*[lo hi] expr2 ... -> expr3 ... -> expr4 ...
+;; where the range of ::* extends until the next :: or the next ::*
+;;
 ;; Cute stuff:
 ;; * use `::' to mark a new step that doesn't continue the previous one
 ;;     e1 :: e2 -> e3 -> e4
@@ -1241,6 +1250,59 @@
                       (9 false (check-expect (hilite 4) 4)))
         (finished-stepping)))
 
+  ;; NOTE: a straight-line big-bang test would not work because
+  ;; it will hang indefinitely, waiting for big-bang to terminate
+  (let ([defs '((require 2htdp/universe)
+                (require 2htdp/image)
+                (define (draw t) (empty-scene 50 50)))]
+        [img '(instantiate (class ...) ...)]) ;; #<image>; somehow `any` did not work?
+    ;; Somehow, we could not start big-bang with 2 or below to run only one or two steps
+    ;; because to-draw won't always get a chance to properly run.
+    ;;
+    ;; When the initial world is only 2 or 1, there will be extra steps after
+    ;; "finished-stepping" which also shows up in the actual Stepper GUI as two extra steps
+    ;; after "all of the definitions  have been successfully evaluated" is displayed.
+    ;;
+    ;; The (empty-scene 50 50) also shows up only after the final world 0 like:
+    ;;   :: ... -> ,@defs 0 {(empty-scene 50 50)} -> ,@defs 0 {,img}
+    ;;
+    ;; It seems as if `big-bang` has terminated too quickly, possibly due to high ticking
+    ;; frequency, causing out-of-ordered to-draw steps
+    (t 'big-bang m:upto-int/lam
+       ,@defs
+       (big-bang 4 [stop-when zero?] [close-on-stop #true]
+         [to-draw draw]
+         [on-tick sub1 1/8])
+       ;; The initial `draw` before the clock starts ticking
+       :: ,@defs {(empty-scene 50 50)} -> ,@defs {,img}
+       ::*[3 99] ... -> ,@defs {(empty-scene 50 50)} -> ,@defs {,img})) ;; `draw` for w=3..1
+  ;;       ^ ^~~ the additional repetition count is for potentially extra `draw` steps
+  ;;       |     provided `draw` is called more than once in one tick
+  ;;       +~~ if the tick frequency is too high, reduce the lower bound.
+
+  ;; Testing the current big-bang stepping behavior
+  ;; functions defined in user code are stepped, but lambdas in big-bang are not
+  ;; so: in to-draw: (first w), empty-scene, and overlay are invisible
+  (let ([defs '((require 2htdp/universe)
+                (require 2htdp/image)
+                (define (drawobj r) (circle r "solid" "red"))
+                (define (next w) (rest w)))]
+        [img '(instantiate (class ...) ...)]) ;; #<image>; somehow `any` did not work?
+    (t 'big-bang-lambda m:intermediate-lambda/both
+       ,@defs
+       (big-bang (list 25 18 11) [stop-when empty?] [close-on-stop #true]
+         [to-draw (lambda (w)
+                    (overlay (drawobj (first w))
+                             (empty-scene 60 60)))]
+         [on-tick next 1/8])
+       :: ,@defs {(circle 25 "solid" "red")} -> ,@defs {,img}
+       ::*[0 99] ... -> ,@defs {(circle 25 "solid" "red")}  ->  ,@defs {,img}  ;; drawobj
+       :: ... -> ,@defs {(rest (list 25 18 11))}     ->  ,@defs {(list 18 11)} ;; next
+       ::*[1 99] ... -> ,@defs {(circle 18 "solid" "red")}  ->  ,@defs {,img}  ;; drawobj
+       :: ... -> ,@defs {(rest (list 18 11))}        ->  ,@defs {(list 11)}    ;; next
+       ::*[1 99] ... -> ,@defs {(circle 11 "solid" "red")}  ->  ,@defs {,img}  ;; drawobj
+       :: ... -> ,@defs {(rest (list 11))}           ->  ,@defs {empty}))      ;; next
+
   ;;;;;;;;;;;;
   ;;
   ;;    SdP TESTS
@@ -1254,14 +1316,6 @@
     (lambda (s)
       (if s s s)))"
       '((finished-stepping)))
-
-  (t1 'big-bang
-      m:beginner
-      "(require 2htdp/image)
-(require 2htdp/universe)
-(define (f2 w) (text \"hi\" 30 \"red\"))
-(big-bang \"dummy\" [to-draw f2])"
-      '((finished-stepping)))
 
 
   ;  ;;;;;;;;;;;;;