From cb3e3770a9cdbbada771432f8be02054a7b89fc8 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 26 Nov 2008 04:13:45 +0000 Subject: [PATCH] macro stepper: added index-based extra navigation svn: r12595 original commit: fc31124115aeef1049e69b7c30150e3ce4db5cd4 --- collects/macro-debugger/view/cursor.ss | 145 ++++++++++---------- collects/macro-debugger/view/stepper.ss | 40 +++++- collects/macro-debugger/view/term-record.ss | 6 + 3 files changed, 118 insertions(+), 73 deletions(-) diff --git a/collects/macro-debugger/view/cursor.ss b/collects/macro-debugger/view/cursor.ss index c6bcce1..a83a8ab 100644 --- 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 index 7bf2df0..3d12e06 100644 --- 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 index 85e9042..c6e5d1a 100644 --- 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)