From f923ad7f6d5a921aa8c6bbd9b53f341feba18f78 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 14 Mar 2007 21:33:59 +0000 Subject: [PATCH] Macro stepper: refactored display code svn: r5775 original commit: ac983b32a64be9cf57638f3fe32796539115923d --- collects/macro-debugger/view/cursor.ss | 170 +++++++++++-------- collects/macro-debugger/view/hiding-panel.ss | 8 +- collects/macro-debugger/view/interfaces.ss | 1 + collects/macro-debugger/view/prefs.ss | 2 + 4 files changed, 105 insertions(+), 76 deletions(-) diff --git a/collects/macro-debugger/view/cursor.ss b/collects/macro-debugger/view/cursor.ss index 0aadc87..78d0069 100644 --- 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))) - - (define (cursor:can-move-previous? c) - (pair? (cursor-prefix c))) - - (define (cursor->list c) - (append (reverse (cursor-prefix c)) - (cursor-suffix->list 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-suffix->list c) (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: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 (cursor:prefix->list c) + (cursor:suffix->list c))) + + (define (cursor:prefix->list c) + (reverse (cursor-prefix 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 index 3cd4c94..cd47c4d 100644 --- 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 index 3d7346d..ed114cf 100644 --- 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 index 3384145..a6d5115 100644 --- 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?) )) )