Macro stepper: refactored display code

svn: r5775

original commit: ac983b32a64be9cf57638f3fe32796539115923d

collects/macro-debugger/view/cursor.ss

@@ -1,98 +1,124 @@
 
 (module cursor mzscheme
-  (provide (all-defined))
+  (provide cursor?
+           cursor:new
+           cursor:add-to-end!
+
+           cursor:next
+           cursor:prev
+
+           cursor:at-start?
+           cursor:at-end?
+
+           cursor:has-next?
+           cursor:has-prev?
+
+           cursor:move-next
+           cursor:move-prev
+           cursor:move-to-start
+           cursor:move-to-end
+
+           cursor->list
+           cursor:prefix->list
+           cursor:suffix->list)
+
+  (define-syntax stream-cons
+    (syntax-rules ()
+      [(stream-cons x y)
+       (delay (cons x y))]))
+
+  (define (stream-car x)
+    (if (promise? x)
+        (car (force x))
+        (car x)))
+
+  (define (stream-cdr x)
+    (if (promise? x)
+        (cdr (force x))
+        (cdr x)))
+  
+  (define (stream-null? x)
+    (or (null? x)
+        (and (promise? x) (null? (force x)))))
+
+  (define (stream-append x y)
+    (if (stream-null? x)
+        y
+        (stream-cons (stream-car x) 
+                     (stream-append (stream-cdr x) y))))
+
+  (define (stream->list s)
+    (if (stream-null? s)
+        null
+        (cons (stream-car s) (stream->list (stream-cdr s)))))
 
   ;; Cursors
   
-;;  (define-struct cursor (v n))
-;;  
-;;  (define (cursor:new items)
-;;    (if (pair? items)
-;;        (make-cursor (list->vector items) 0)
-;;        (make-cursor #f #f)))
-;;
-;;  (define (cursor:current c)
-;;    (when (cursor-n c)
-;;      (vector-ref (cursor-v c) (cursor-n c))))
-;;  (define (cursor:move-next c)
-;;    (when (cursor:can-move-next? c)
-;;      (set-cursor-n! c (add1 (cursor-n c)))))
-;;  (define (cursor:move-previous c)
-;;    (when (cursor:can-move-previous? c)
-;;      (set-cursor-n! c (sub1 (cursor-n c)))))
-;;  (define (cursor:move-to-start c)
-;;    (when (cursor-n c)
-;;      (set-cursor-n! c 0)))
-;;  (define (cursor:move-to-end c)
-;;    (when (cursor-n c)
-;;      (set-cursor-n! c (sub1 (vector-length (cursor-v c))))))
-;;  
-;;  (define (cursor:can-move-next? c)
-;;    (and (cursor-n c) (< (cursor-n c) (sub1 (vector-length (cursor-v c))))))
-;;
-;;  (define (cursor:can-move-previous? c)
-;;    (and (cursor-n c) (> (cursor-n c) 0)))
-  
-  
+  ;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
   (define-struct cursor (prefix suffixp))
   
-  (define (cursor-suffix c)
-    (if (promise? (cursor-suffixp c))
-        (force (cursor-suffixp c))
-        (cursor-suffixp c)))
-  (define set-cursor-suffix! set-cursor-suffixp!)
-  
   (define (cursor:new items)
     (make-cursor null items))
 
-  (define (cursor:current c)
-    (cursor:next c))
+  (define (cursor:add-to-end! c items)
+    (let ([suffix (cursor-suffixp c)])
+      (set-cursor-suffixp! c (stream-append suffix items))))
 
   (define (cursor:next c)
-    (let ([suffix (cursor-suffix c)])
-      (if (pair? suffix)
-          (car suffix)
-          #f)))
+    (let ([suffix (cursor-suffixp c)])
+      (if (stream-null? suffix)
+          #f
+          (stream-car suffix))))
+
   (define (cursor:prev c)
     (let ([prefix (cursor-prefix c)])
       (if (pair? prefix)
           (car prefix)
           #f)))
 
-  (define (cursor:move-to-start c)
-    (when (cursor:can-move-previous? c)
-      (cursor:move-previous c)
-      (cursor:move-to-start c)))
-  
-  (define (cursor:move-to-end c)
-    (when (cursor:can-move-next? c)
-      (cursor:move-next c)
-      (cursor:move-to-end c)))
-  
-  (define (cursor:move-previous c)
+  (define (cursor:move-prev c)
     (when (pair? (cursor-prefix c))
       (let ([old-prefix-cell (cursor-prefix c)])
         (set-cursor-prefix! c (cdr old-prefix-cell))
-        (set-cdr! old-prefix-cell (cursor-suffix c))
-        (set-cursor-suffix! c old-prefix-cell))))
+        (set-cdr! old-prefix-cell (cursor-suffixp c))
+        (set-cursor-suffixp! c old-prefix-cell))))
   
   (define (cursor:move-next c)
-    (when (cursor:can-move-next? c)
-      (let ([old-suffix-cell (cursor-suffix c)])
-        (set-cursor-suffix! c (cdr old-suffix-cell))
-        (set-cdr! old-suffix-cell (cursor-prefix c))
-        (set-cursor-prefix! c old-suffix-cell))))
+    (when (cursor:has-next? c)
+      (let* ([old-suffixp (cursor-suffixp c)]
+             [old-suffix-pair
+              (if (pair? old-suffixp) old-suffixp (force old-suffixp))])
+        (set-cursor-suffixp! c (cdr old-suffix-pair))
+        (set-cdr! old-suffix-pair (cursor-prefix c))
+        (set-cursor-prefix! c old-suffix-pair))))
 
-  (define (cursor:can-move-next? c)
-    (pair? (cursor-suffix c)))
+  (define (cursor:at-start? c)
+    (null? (cursor-prefix c)))
+  (define (cursor:at-end? c)
+    (stream-null? (cursor-suffixp c)))
+  (define (cursor:has-next? c)
+    (not (cursor:at-end? c)))
+  (define (cursor:has-prev? c)
+    (not (cursor:at-start? c)))
   
-  (define (cursor:can-move-previous? c)
-    (pair? (cursor-prefix c)))
+  (define (cursor:move-to-start c)
+    (when (cursor:has-prev? c)
+      (cursor:move-prev c)
+      (cursor:move-to-start c)))
+  
+  (define (cursor:move-to-end c)
+    (when (cursor:has-next? c)
+      (cursor:move-next c)
+      (cursor:move-to-end c)))
 
   (define (cursor->list c)
-    (append (reverse (cursor-prefix c))
-            (cursor-suffix->list c)))
+    (append (cursor:prefix->list c)
+            (cursor:suffix->list c)))
 
-  (define (cursor-suffix->list c) (cursor-suffix c))
+  (define (cursor:prefix->list c)
+    (reverse (cursor-prefix c)))
+
+  (define (cursor:suffix->list c)
+    (stream->list (cursor-suffixp c)))
   
   )

collects/macro-debugger/view/hiding-panel.ss

@@ -103,11 +103,11 @@
       ;; refresh
       (define/public (refresh)
         (when (send config get-macro-hiding?)
-          (send stepper refresh/resynth-prefix)))
+          (send stepper refresh/resynth)))
 
       ;; force-refresh
       (define/private (force-refresh)
-        (send stepper refresh/resynth-prefix))
+        (send stepper refresh/resynth))
 
       ;; set-syntax : syntax/#f -> void
       (define/public (set-syntax lstx)

collects/macro-debugger/view/interfaces.ss

@@ -30,6 +30,7 @@
      pref:suppress-warnings?
      pref:one-by-one?
      pref:extra-navigation?
+     pref:debug-catch-errors?
      ))
 
   ;; macro-stepper-config%

collects/macro-debugger/view/prefs.ss

@@ -32,6 +32,7 @@
       (preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?)
       (preferences:set-default 'MacroStepper:OneByOne? #f boolean?)
       (preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?)
+      (preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?)
       
       (pref:get/set pref:width MacroStepper:Frame:Width)
       (pref:get/set pref:height MacroStepper:Frame:Height)
@@ -47,6 +48,7 @@
       (pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
       (pref:get/set pref:one-by-one? MacroStepper:OneByOne?)
       (pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
+      (pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
       
       ))
   )