commit f923ad7f6d5a921aa8c6bbd9b53f341feba18f78
parent b272f333d65a6fc41854be7a337220eba908ee50
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 14 Mar 2007 21:33:59 +0000
Macro stepper: refactored display code
svn: r5775
original commit: ac983b32a64be9cf57638f3fe32796539115923d
Diffstat:
4 files changed, 102 insertions(+), 73 deletions(-)
diff --git a/collects/macro-debugger/view/cursor.ss b/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))))
-
- (define (cursor:can-move-next? c)
- (pair? (cursor-suffix c)))
+ (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: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:prefix->list c)
+ (reverse (cursor-prefix c)))
- (define (cursor-suffix->list c) (cursor-suffix c))
+ (define (cursor:suffix->list c)
+ (stream->list (cursor-suffixp c)))
)
diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss
@@ -94,7 +94,7 @@
(new grow-box-spacer-pane% (parent add-pane))
(send add-editor lock #t)
-
+
;; Methods
(define/public (get-show-macro?)
@@ -103,12 +103,12 @@
;; 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)
(set! stx lstx)
diff --git a/collects/macro-debugger/view/interfaces.ss b/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%
diff --git a/collects/macro-debugger/view/prefs.ss b/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?)
))
)
