improve lazy stepper recon of unannotated fn apps

remove stepper/private/lazy-highlighting.rkt

in stepper/private/macro-unwind.rkt:
- in fall-through, add lazy-proc to lazy #%app special case

in stepper/private/model.rkt
- in send-step, dont use highlight-table, just match top called fn in mark-list
  instead

in tests/stepper/
- add lazy stepper tests for filter and fold

collects/stepper/private/macro-unwind.rkt

@@ -68,13 +68,13 @@
                   (syntax-e (second (syntax-e #'proc-extract))))
                 procedure-extract-target))
        (unwind #'p settings)]
-      ; lazy #%app special case: force
+      ; lazy #%app special case: force and delay
-      [(#%plain-app force arg)
+      [(#%plain-app f arg)
-       (let ([force-fn (syntax->datum #'force)])
+       (let ([fn (syntax->datum #'f)])
-         (or (eq? force-fn 'force)
+         (or (eq? fn 'lazy-proc)
-             (eq? force-fn '!) (eq? force-fn '!!)
+             (eq? fn 'force) (eq? fn '!) (eq? fn '!!)
-             (eq? force-fn '!list) (eq? force-fn '!!list)
+             (eq? fn '!list) (eq? fn '!!list)
-             (equal? force-fn '(#%plain-app parameter-procedure))))
+             (equal? fn '(#%plain-app parameter-procedure))))
        (unwind #'arg settings)]
       ; general lazy application
       [(#%plain-app 

collects/stepper/private/model.rkt

@@ -54,8 +54,8 @@
          ;; for breakpoint display
          ;; (commented out to allow nightly testing)
          #;"display-break-stuff.ss"
-         (for-syntax scheme/base)
+         (for-syntax scheme/base))
-         "lazy-highlighting.rkt")
+
 
 (define program-expander-contract
   ((-> void?) ; init
@@ -128,31 +128,21 @@
   ; # of skips depends on # of hidden !'s in fn def
   (define highlight-stack null)
   (define (highlight-stack-push mark-list)
-    (let* ([mark (find-first-called mark-list)]
+    (let ([top-called-fn (find-top-called-fn mark-list)])
-           [fn (object-name (lookup-binding (list mark) (get-arg-var 0)))]
-           [skips (hash-ref highlight-table fn)])
       (when DEBUG
-        (printf "skips for ~a = ~a\n" fn skips))
+        (printf "top called fn = ~a\n" top-called-fn))
       (set! highlight-stack
-            (cons (cons lhs-recon-thunk skips) highlight-stack))))
+            (cons (cons top-called-fn lhs-recon-thunk) highlight-stack))))
-  (define (find-first-called mark-list)
+  (define (find-top-called-fn mark-list)
     (if (null? mark-list)
         #f
         (let ([top-mark (car mark-list)])
           (if (eq? 'called (mark-label top-mark))
-              top-mark
+              (object-name (lookup-binding (list top-mark) (get-arg-var 0)))
-              (find-first-called (cdr mark-list))))))
+              (find-top-called-fn (cdr mark-list))))))
   (define (highlight-stack-pop)
     (set! highlight-stack (cdr highlight-stack)))
-  (define (highlight-stack-decrement)
+
-    (let ([new-skips (sub1 (cdar highlight-stack))]
-          [thunk (caar highlight-stack)])
-      (printf 
-       "SKIPPING SKIP (decrementing top of highlight-stack, skips = ~a)\n"
-       new-skips)
-    (set! highlight-stack
-          (cons (cons thunk new-skips)
-                (cdr highlight-stack)))))
   
   
   ;; highlight-mutated-expressions :
@@ -322,20 +312,22 @@
                     (send-it)
                     (when DEBUG
                       (printf "SKIPPING STEP (LHS = ellipses and highlight-stack = null)\n")))]
-               ; if last-rhs != null, send step
+               ; if top-called-fn = top of highlight stack, 
-               ; else if skips = 0, send step
+               ;    then send step with lhs = lhs-thunk on highlight stack
-               ; else skip
+               ; else if last-rhs != null, send it, else skip
                [else
-                (let ([skips (cdar highlight-stack)]
+                (let ([top-called-fn (caar highlight-stack)]
-                      [lhs-thunk (caar highlight-stack)])
+                      [lhs-thunk (cdar highlight-stack)])
-                  (if (or (zero? skips) (not (null? last-rhs-exps)))
+                  (if (and (eq? (find-top-called-fn mark-list) top-called-fn)
+                           (eq? break-kind 'result-value-break))
                       (begin
                         (set! lhs-exps (lhs-thunk))
                         (set! lhs-finished-exps rhs-finished-exps)
                         (when DEBUG (printf "Popping highlight-stack\n"))
                         (highlight-stack-pop)
                         (send-it))
-                      (highlight-stack-decrement)))])]
+                      (when (not (null? last-rhs-exps))
+                        (send-it))))])]
             ; sending step
             [else (send-it)]))
         

collects/stepper/private/reconstruct.rkt

@@ -193,8 +193,6 @@
   ; Purpose: extracts closure from struct procedure, ie lazy-proc in lazy racket
   (define (extract-proc-if-struct f)
     (if (and (procedure? f) (not (annotated-proc? f)))
-        #;(let ([extracted (procedure-extract-target f)])
-            (if extracted extracted f))
         (or (procedure-extract-target f)
             f)
         f))

collects/tests/stepper/automatic-tests.rkt

@@ -17,7 +17,7 @@
     lazy-eq? lazy-eqv? lazy-equal? lazy-list?1 lazy-list?2 lazy-list?3
     lazy-length lazy-list-ref lazy-list-tail lazy-append lazy-reverse lazy-empty? 
     lazy-assoc lazy-assq lazy-assv lazy-cons? lazy-remove lazy-remq lazy-remv
-    lazy-member lazy-memq lazy-memv))
+    lazy-member lazy-memq lazy-memv lazy-filter1 lazy-filter2 lazy-fold))
 
 (let ((outer-namespace (current-namespace)))
   (parameterize ([display-only-errors #t]

collects/tests/stepper/through-tests.rkt

@@ -2075,6 +2075,51 @@
       :: {(memv 1 (list 1 2))} -> {(list 1 2)})
   
    
+   (t 'lazy-filter1 m:lazy
+      (third (filter (lambda (x) (>= x 3)) '(1 2 3 4 5)))
+      :: (third {(filter (lambda (x) (>= x 3)) (list 1 2 3 4 5))})
+      -> (third (... {(>= 1 3)} ...))
+      -> (third (... {false} ...))
+      :: ... -> (third {,(<delay#> 0)})
+      :: ... -> (third {(>= 2 3)}) -> (third {false})
+      :: ... -> (third {(>= 3 3)}) -> (third {true})
+      :: ... -> (third (cons 3 {(>= 4 3)})) -> (third (cons 3 {true}))
+      :: ... -> (third (cons 3 (cons 4 {(>= 5 3)})))
+      -> (third (cons 3 (cons 4 {true})))
+      :: {(third (cons 3 (cons 4 (cons 5 ,(<delay#> 1)))))} -> {5})
+   
+   ; same as lazy-filter1 except forcing of the list itself shows up as a step
+   ; only difference is in lazy-filter1 a quote (') is used while in lazy-filter2
+   ; a list constructor is used
+   (t 'lazy-filter2 m:lazy
+      (third (filter (lambda (x) (>= x 3)) (list 1 2 3 4 5)))
+      :: (third {(filter (lambda (x) (>= x 3)) (list 1 2 3 4 5))})
+      -> (third (... {(list 1 2 3 4 5)} ...))
+      :: ... -> (third (... {(>= 1 3)} ...)) -> (third (... {false} ...))
+      :: ... -> (third {,(<delay#> 0)})
+      :: ... -> (third {(>= 2 3)}) -> (third {false})
+      :: ... -> (third {(>= 3 3)}) -> (third {true})
+      :: ... -> (third (cons 3 {(>= 4 3)})) -> (third (cons 3 {true}))
+      :: ... -> (third (cons 3 (cons 4 {(>= 5 3)})))
+      -> (third (cons 3 (cons 4 {true})))
+      :: {(third (cons 3 (cons 4 (cons 5 ,(<delay#> 1)))))} -> {5})
+   
+   (t 'lazy-fold m:lazy
+      (+ (foldr (lambda (x y) (+ x y)) 0 '(1 2 3)) 1000)
+      :: (+ {(foldr (lambda (x y) (+ x y)) 0 (list 1 2 3))} 1000)
+      -> (+ {,(<delay#> 0)} 1000)
+      :: ... -> (+ {(+ 1 ,(<delay#> 1))} 1000)
+      :: ... -> (+ (+ 1 {(+ 2 ,(<delay#> 2))}) 1000)
+      :: ... -> (+ (+ 1 (+ 2 {(+ 3 ,(<delay#> 3))})) 1000)
+      :: (+ (+ 1 (+ 2 {(+ 3 0)})) 1000)
+      -> (+ (+ 1 (+ 2 {3})) 1000)
+      :: (+ (+ 1 {(+ 2 3)}) 1000)
+      -> (+ (+ 1 {5}) 1000)
+      :: (+ {(+ 1 5)} 1000)
+      -> (+ {6} 1000)
+      :: {(+ 6 1000)} -> {1006})
+    
+    
     
    
   #;