commit cb3e3770a9cdbbada771432f8be02054a7b89fc8
parent c4bf0cb2aa741f0fcc1997b827a8c293b2f23ad7
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 26 Nov 2008 04:13:45 +0000
macro stepper: added index-based extra navigation
svn: r12595
original commit: fc31124115aeef1049e69b7c30150e3ce4db5cd4
Diffstat:
3 files changed, 118 insertions(+), 73 deletions(-)
diff --git a/collects/macro-debugger/view/cursor.ss b/collects/macro-debugger/view/cursor.ss
@@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/promise)
(provide cursor?
+ cursor-position
cursor:new
cursor:add-to-end!
cursor:remove-current!
@@ -25,107 +26,109 @@
cursor:prefix->list
cursor:suffix->list)
-(define-syntax stream-cons
- (syntax-rules ()
- [(stream-cons x y)
- (delay (cons x y))]))
+(define-struct cursor (vector count position)
+ #:mutable)
-(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
-
-;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
-(define-struct cursor (prefix suffixp) #:mutable)
+(define (cursor:ensure-capacity c capacity)
+ (define v (cursor-vector c))
+ (when (< (vector-length v) capacity)
+ (let* ([new-capacity (ceiling (* capacity 3/2))]
+ [new-v (make-vector new-capacity)])
+ (vector-copy! new-v 0 v 0)
+ (set-cursor-vector! c new-v))))
(define (cursor:new items)
- (make-cursor null items))
+ (define v (list->vector items))
+ (make-cursor v (vector-length v) 0))
(define (cursor:add-to-end! c items)
- (let ([suffix (cursor-suffixp c)])
- (set-cursor-suffixp! c (stream-append suffix items))))
+ (define count0 (cursor-count c))
+ (define items-vector (list->vector items))
+ (cursor:ensure-capacity c (+ (cursor-count c) (length items)))
+ (vector-copy! (cursor-vector c) count0 items-vector)
+ (set-cursor-count! c (+ (cursor-count c) (vector-length items-vector))))
(define (cursor:remove-current! c)
- (when (cursor:has-next? c)
- (set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
+ (cursor:remove-at! c (cursor-position c)))
+
+(define (cursor:remove-at! c p)
+ (define count (cursor-count c))
+ (define v (cursor-vector c))
+ (vector-copy! v p v (add1 p))
+ (vector-set! v (sub1 count) #f)
+ (set-cursor-count! c (sub1 count)))
(define (cursor:next c)
- (let ([suffix (cursor-suffixp c)])
- (if (stream-null? suffix)
- #f
- (stream-car suffix))))
+ (define p (cursor-position c))
+ (define count (cursor-count c))
+ (and (< p count)
+ (vector-ref (cursor-vector c) p)))
(define (cursor:prev c)
- (let ([prefix (cursor-prefix c)])
- (if (pair? prefix)
- (car prefix)
- #f)))
+ (define p (cursor-position c))
+ (define count (cursor-count c))
+ (and (< 0 p)
+ (vector-ref (cursor-vector c) (sub1 p))))
-(define (cursor:move-prev c)
- (when (pair? (cursor-prefix c))
- (let ([old-prefix (cursor-prefix c)])
- (set-cursor-prefix! c (cdr old-prefix))
- (set-cursor-suffixp! c (cons (car old-prefix) (cursor-suffixp c))))))
(define (cursor:move-next c)
- (when (cursor:has-next? c)
- (let* ([old-suffixp (cursor-suffixp c)])
- (set-cursor-prefix! c (cons (stream-car old-suffixp)
- (cursor-prefix c)))
- (set-cursor-suffixp! c (stream-cdr old-suffixp)))))
+ (define p (cursor-position c))
+ (define count (cursor-count c))
+ (when (< p count)
+ (set-cursor-position! c (add1 p))))
+
+(define (cursor:move-prev c)
+ (define p (cursor-position c))
+ (define count (cursor-count c))
+ (when (< 0 p)
+ (set-cursor-position! c (sub1 p))))
(define (cursor:at-start? c)
- (null? (cursor-prefix c)))
+ (= (cursor-position c) 0))
+
(define (cursor:at-end? c)
- (stream-null? (cursor-suffixp c)))
+ (= (cursor-position c) (cursor-count 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)))
+ (set-cursor-position! c 0))
(define (cursor:move-to-end c)
- (when (cursor:has-next? c)
- (cursor:move-next c)
- (cursor:move-to-end c)))
+ (set-cursor-position! c (cursor-count c)))
(define (cursor:skip-to c i)
- (unless (or (eq? (cursor:next c) i) (cursor:at-end? c))
- (cursor:move-next c)
- (cursor:skip-to c i)))
+ (when (<= 0 i (cursor-count c))
+ (set-cursor-position! c i)))
(define (cursor->list c)
- (append (cursor:prefix->list c)
- (cursor:suffix->list c)))
+ (define count (cursor-count c))
+ (define v (cursor-vector c))
+ (let loop ([i 0])
+ (if (< i count)
+ (cons (vector-ref v i)
+ (loop (add1 i)))
+ null)))
(define (cursor:prefix->list c)
- (reverse (cursor-prefix c)))
+ (define position (cursor-position c))
+ (define v (cursor-vector c))
+ (let loop ([i 0])
+ (if (< i position)
+ (cons (vector-ref v i)
+ (loop (add1 i)))
+ null)))
(define (cursor:suffix->list c)
- (stream->list (cursor-suffixp c)))
+ (define position (cursor-position c))
+ (define count (cursor-count c))
+ (define v (cursor-vector c))
+ (let loop ([i position])
+ (if (< i count)
+ (cons (vector-ref v i)
+ (loop (add1 i)))
+ null)))
diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss
@@ -49,6 +49,9 @@
(define (focused-term)
(cursor:next terms))
+ ;; current-step-index : notify of number/#f
+ (field/notify current-step-index (new notify-box% (value #f)))
+
;; add-deriv : Deriv -> void
(define/public (add-deriv d)
(let ([trec (new term-record% (stepper this) (raw-deriv d))])
@@ -173,6 +176,28 @@
(new button% (label "Next term") (parent navigator)
(callback (lambda (b e) (navigate-down)))))
+ (define nav:text
+ (new text-field%
+ (label "Step#")
+ (init-value "00000")
+ (parent extra-navigator)
+ (stretchable-width #f)
+ (stretchable-height #f)
+ (callback
+ (lambda (b e)
+ (when (eq? (send e get-event-type) 'text-field-enter)
+ (let* ([value (send b get-value)]
+ [step (string->number value)])
+ (cond [(exact-positive-integer? step)
+ (navigate-to (sub1 step))]
+ [(equal? value "end")
+ (navigate-to-end)])))))))
+ (send nav:text set-value "")
+ (listen-current-step-index
+ (lambda (n)
+ (send nav:text set-value
+ (if (number? n) (number->string (add1 n)) ""))))
+
(define/private (trim-navigator)
(if (> (length (cursor->list terms)) 1)
(send navigator change-children
@@ -223,6 +248,9 @@
(define/public-final (navigate-next)
(send (focused-term) navigate-next)
(update/save-position))
+ (define/public-final (navigate-to n)
+ (send (focused-term) navigate-to n)
+ (update/save-position))
(define/public-final (navigate-up)
(when (focused-term)
@@ -253,7 +281,7 @@
#f
(send text line-start-position (unbox end-box))
'start))
-
+
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send sbview get-text))
@@ -271,7 +299,7 @@
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence)
(send sbview erase-all)
-
+
(update:show-prefix)
(when multiple-terms? (send sbview add-separator))
(set! position-of-interest (send text last-position))
@@ -284,6 +312,7 @@
#f
(send text last-position)
'start)
+ (update-nav-index)
(enable/disable-buttons))
;; update:show-prefix : -> void
@@ -305,6 +334,12 @@
(send trec display-initial-term))
(cdr suffix0)))))
+ ;; update-nav-index : -> void
+ (define/private (update-nav-index)
+ (define term (focused-term))
+ (set-current-step-index
+ (and term (send term get-step-index))))
+
;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons)
(define term (focused-term))
@@ -312,6 +347,7 @@
(send nav:previous enable (and term (send term has-prev?)))
(send nav:next enable (and term (send term has-next?)))
(send nav:end enable (and term (send term has-next?)))
+ (send nav:text enable (and term #t))
(send nav:up enable (cursor:has-prev? terms))
(send nav:down enable (cursor:has-next? terms)))
diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss
@@ -204,6 +204,9 @@
(define/public-final (has-next?)
(and (get-steps) (not (cursor:at-end? (get-steps)))))
+ (define/public-final (get-step-index)
+ (and (get-steps) (cursor-position (get-steps))))
+
(define/public-final (navigate-to-start)
(cursor:move-to-start (get-steps))
(save-position))
@@ -216,6 +219,9 @@
(define/public-final (navigate-next)
(cursor:move-next (get-steps))
(save-position))
+ (define/public-final (navigate-to n)
+ (cursor:skip-to (get-steps) n)
+ (save-position))
;; save-position : -> void
(define/private (save-position)
