From 7bb15bbbebc38ab583966551cafe5b09d92aa3fb Mon Sep 17 00:00:00 2001 From: John Clements Date: Sun, 13 Sep 2009 18:35:21 +0000 Subject: [PATCH] fixed #i printing svn: r15993 --- collects/stepper/private/mred-extensions.ss | 1090 ++++++++++--------- collects/stepper/stepper-tool.ss | 202 ++-- collects/stepper/view-controller.ss | 72 +- 3 files changed, 692 insertions(+), 672 deletions(-) diff --git a/collects/stepper/private/mred-extensions.ss b/collects/stepper/private/mred-extensions.ss index b3249003cc..28f7edbcb4 100644 --- a/collects/stepper/private/mred-extensions.ss +++ b/collects/stepper/private/mred-extensions.ss @@ -1,557 +1,563 @@ -(module mred-extensions mzscheme - (require mzlib/class - mred - (prefix f: framework) - mzlib/pretty - #;"testing-shared.ss" - "shared.ss") +#lang scheme - (provide - foot-img/horizontal - foot-img/vertical - stepper-canvas% - stepper-text% - snip? - stepper-warning% - finished-text - vertical-separator-snip-class%) - - (define test-dc (make-object bitmap-dc% (make-object bitmap% 1 1))) - (define reduct-highlight-color (make-object color% 255 255 255)) - (define redex-highlight-color (make-object color% 255 255 255)) - (send test-dc try-color (make-object color% 212 159 245) reduct-highlight-color) - (send test-dc try-color (make-object color% 193 251 181) redex-highlight-color) - - (define error-delta (make-object style-delta% 'change-style 'italic)) - (send error-delta set-delta-foreground "RED") - - (define snip-delta (make-object style-delta% 'change-alignment 'top)) - +(require mzlib/class + mred + (prefix-in f: framework) + mzlib/pretty + #;"testing-shared.ss" + "shared.ss") + +(provide + foot-img/horizontal + foot-img/vertical + stepper-canvas% + stepper-text% + snip? + stepper-warning% + finished-text + vertical-separator-snip-class%) + +(define test-dc (make-object bitmap-dc% (make-object bitmap% 1 1))) +(define reduct-highlight-color (make-object color% 255 255 255)) +(define redex-highlight-color (make-object color% 255 255 255)) +(send test-dc try-color (make-object color% 212 159 245) reduct-highlight-color) +(send test-dc try-color (make-object color% 193 251 181) redex-highlight-color) + +(define error-delta (make-object style-delta% 'change-style 'italic)) +(send error-delta set-delta-foreground "RED") + +(define snip-delta (make-object style-delta% 'change-alignment 'top)) - ;;;; VERTICAL-SEPARATOR : the red arrow that separates the left half of the display from the right half. - - (define red-arrow-bitmap - (make-object bitmap% (build-path (collection-path "icons") "red-arrow.bmp") 'bmp)) - (unless (send red-arrow-bitmap ok?) - (error 'red-arrow-bitmap "unable to load red-arrow bitmap")) - - (define vertical-separator-snip-class% - (class snip-class% () - (override read) - - (define (read s) - (let ([size-box (box 0)]) - (send s get size-box) - (make-object vertical-separator-snip% 100))) - - (super-instantiate ()))) - - (define vertical-separator-snipclass - (make-object vertical-separator-snip-class%)) - - - (send* vertical-separator-snipclass - (set-version 1) - (set-classname (format "~s" `(lib "vertical-separator-snip.ss" "stepper" "private")))) - - (send (get-the-snip-class-list) add vertical-separator-snipclass) - - (define vertical-separator-snip% - (class snip% () - (inherit get-style set-snipclass set-flags get-flags get-admin) - (public set-height!) - (override write copy get-extent draw) - - (init-field height) - +;;;; VERTICAL-SEPARATOR : the red arrow that separates the left half of the display from the right half. - (define bitmap-width 15.0) - (define left-white 0.0) - (define right-white 3.0) - (define bitmap-height 10.0) - - (define (set-height! x) - (set! height (max x bitmap-height))) - - (define (write s) - (send s put (char->integer #\r))) ; this can't be right...? - - (define (copy) - (let ([s (make-object vertical-separator-snip% height)]) - (send s set-style (get-style)) - s)) - - (define (get-extent dc x y w-box h-box descent-box space-box lspace-box rspace-box) - (for-each (lambda (box) (unless (not box) (set-box! box 0))) - (list descent-box space-box lspace-box rspace-box)) - (unless (not w-box) - (set-box! w-box (+ left-white right-white bitmap-width))) - (unless (not h-box) - (set-box! h-box height))) - - (define (draw dc x y left top right bottom dx dy draw-caret) - (let ([y-offset (round (/ (- height bitmap-height) 2))] - [x-offset left-white]) - (send dc draw-bitmap red-arrow-bitmap (+ x x-offset) (+ y y-offset)))) - - (super-instantiate ()) - (set-snipclass vertical-separator-snipclass))) - - - ;;;; end of vertical snip-stuff - - (define stepper-editor-snip% - (class editor-snip% () - (inherit get-editor set-min-width set-max-width) - (public* - [set-new-width - (lambda (width canvas) - (set-min-width width) - (set-max-width width) - (let ([editor (get-editor)]) - (when editor - (send editor reset-pretty-print-width width canvas))))]) - (super-instantiate (#f #f 0 0 0 0 0 0 0 0)))) - - ; ;; ; - ; ; ; ; ; ; ; - ;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;; ; ; ; ;;; ;;;; ;;; ; ; ;;;;; ; ; - ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; - ;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; - ; ; ; ;; ; ;; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; - ;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;; ; ; ;;; ;; ;;;; ; ; ;;; ;; - ; ; - ; ; - - ; the stepper-sub-text% class is used to hold an individual list of sexps, with one or more highlights. - ; there are four of them (* NB: now only two! 2005-08) in the stepper window. - - (define stepper-sub-text% - (class f:text:standard-style-list% () - - (init-field exps highlight-color) +(define red-arrow-bitmap + (make-object bitmap% (build-path (collection-path "icons") "red-arrow.bmp") 'bmp)) - (inherit insert get-style-list set-style-list change-style highlight-range last-position lock erase - begin-edit-sequence end-edit-sequence get-start-position select-all clear) - - (public* [reset-pretty-print-width - (lambda (inner-width canvas) - (begin-edit-sequence) - (let* ([style (send (get-style-list) find-named-style "Standard")] - [char-width (send style get-text-width (send canvas get-dc))] - [width (floor (/ (- inner-width 18) char-width))]) - (reformat-sexp width) - (end-edit-sequence)))]) - - (define highlight-table (make-hash-table 'weak)) - - (define stripped-exps - (map (lambda (exp) (strip-to-sexp exp highlight-table)) exps)) - - (define pretty-printed-width #f) - (define clear-highlight-thunks null) - (define/private (reset-style) - (change-style (send (get-style-list) find-named-style "Standard"))) - (define/private (set-last-style) - (change-style (send (get-style-list) find-named-style "Standard") - (sub1 (last-position)) - (last-position))) - - (define/private (reformat-sexp width) - (when (not (eq? pretty-printed-width width)) - (set! pretty-printed-width width) - (format-whole-step))) - - (define highlight-begin #f) - - (inherit get-dc) - - (define/private (format-sexp sexp) - (define text-port (open-output-text-editor this)) +(unless (send red-arrow-bitmap ok?) + (error 'red-arrow-bitmap "unable to load red-arrow bitmap")) - (parameterize - ([pretty-print-columns pretty-printed-width] - - ; the pretty-print-size-hook decides whether this object should be printed by the new pretty-print-hook - [pretty-print-size-hook - (lambda (value display? port) - (when (not highlight-table) - (fprintf (current-error-port) "hey! the highlight-table doesn't exist! (1)")) - (let ([looked-up (hash-table-get highlight-table value (lambda () #f))]) - (cond - [(is-a? value snip%) - ;; Calculate the effective width of the snip, so that - ;; too-long lines (as a result of large snips) are broken - ;; correctly. When the snip is actusally inserted, its width - ;; will be determined by `(send snip get-count)', but the number - ;; returned here triggers line breaking in the pretty printer. - (let ([dc (get-dc)] - [wbox (box 0)]) - (send value get-extent dc 0 0 wbox #f #f #f #f #f) - (let-values ([(xw dc dc2 dc3) (send dc get-text-extent "x")]) - (max 1 (inexact->exact (ceiling (/ (unbox wbox) xw))))))] - [(and looked-up (not (eq? looked-up 'non-confusable))) - (string-length (format "~s" (car looked-up)))] - [else #f])))] - - [pretty-print-print-hook - ; this print-hook is called for confusable highlights and for images. - (lambda (value display? port) - (when (not highlight-table) - (fprintf (current-error-port) "hey! the highlight-table doesn't exist! (2)")) - (let ([to-display (cond - [(hash-table-get highlight-table value (lambda () #f)) => car] - [else value])]) - (cond - [(is-a? to-display snip%) - (write-special (send to-display copy) port) (set-last-style)] - [else - (write-string (format "~s" to-display) port)])))] - [pretty-print-print-line - (lambda (number port old-length dest-columns) - (when (and number (not (eq? number 0))) - (newline port)) - 0)] - [pretty-print-pre-print-hook - (lambda (value p) - (when (not highlight-table) - (fprintf (current-error-port) "hey! the highlight-table doesn't exist! (3)")) - (when (hash-table-get highlight-table value (lambda () #f)) - (set! highlight-begin (get-start-position))))] - [pretty-print-post-print-hook - (lambda (value p) - (when (not highlight-table) - (fprintf (current-error-port) "hey! the highlight-table doesn't exist! (4)")) - (when (hash-table-get highlight-table value (lambda () #f)) - (let ([highlight-end (get-start-position)]) - (unless highlight-begin - (error 'format-whole-step "no highlight-begin to match highlight-end")) - (set! clear-highlight-thunks - (cons (highlight-range highlight-begin highlight-end highlight-color) - clear-highlight-thunks)) - (set! highlight-begin #f))))] - ;; mflatt: MAJOR HACK - this setting needs to come from the language - ;; somehow - [read-case-sensitive #t]) - (pretty-print sexp text-port))) - - (define/public (format-whole-step) - (lock #f) - (begin-edit-sequence) - (for-each (lambda (fun) (fun)) clear-highlight-thunks) - (set! clear-highlight-thunks null) - (select-all) - (clear) - (reset-style) - (let loop ([remaining stripped-exps] [first #t]) - (unless (null? remaining) - (unless first (insert #\newline)) - (format-sexp (car remaining)) - (loop (cdr remaining) #f))) - (end-edit-sequence) - (lock #t)) - - (super-instantiate ()))) - - - ; ;; ; - ; ; ; ; ; ; ; - ;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;; ; ; ; ;;; ;;; ; ;; ; ;; ;;; ; ;; ;;;; ;;; ; ; ;;;;; ; ; - ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;; ; ; ; ;; ;; ; ; ;; ; ; ; ; ; ; ;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; - ;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ; ; ;;;;; ;;;;; ; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; - ; ; ; ;; ; ;; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;; ; ; ;;; ;;;; ; ; ;;; ; ;; ;;;; ; ; ;;; ;; - ; ; - ; ; - - ; the stepper-sub-error-text%, like stepper-sub-text%, fits in one of the four^H^H^H^Htwo stepper "text" spots. - ; it is used for error messages. - - (define stepper-sub-error-text% - (class f:text:standard-style-list% () - - (init-field error-msg) - - (inherit get-style-list last-position set-style-list insert change-style auto-wrap - set-max-width) - - (public* [reset-pretty-print-width - (lambda (inner-width canvas) - (set-max-width inner-width))]) - - (super-instantiate ()) - (let ([before-error-msg (last-position)]) - (change-style (send (get-style-list) find-named-style "Standard")) - (auto-wrap #t) - (insert error-msg) - (change-style error-delta before-error-msg (last-position))))) - - ;; ; - ; ; ; ; - ;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;; ;;; ; ;; ; ; ;;; ;;; ; ; ; - ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ; ;;;; ; ; ; ; ;;;; ;; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; - ;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;;;;; ; ; ; ;;;;; ;;; ; ;; - ; ; - ; ; - - ;; the stepper-canvas% overrides the editor-canvas simply so that on-size messages get passed to - ;; the enclosed editor. - - (define stepper-canvas% - (class editor-canvas% () - (inherit get-editor) - (override* - [on-size - (lambda (width height) - (super on-size width height) - (let ([editor (get-editor)]) - (when editor - (send editor reset-width this))))]) - - (super-instantiate ()))) - - ;; ; - ; ; ; ; ; ; - ;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;;; ;;; ; ; ;;;;; ; ; - ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ; ; ; ;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; - ;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ; ;;;;; ;; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; - ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; - ;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;; ;;;; ; ; ;;; ;; - ; ; - ; ; +(define vertical-separator-snip-class% + (class snip-class% + (override read) - ; the stepper-text% is the principal inhabitant of the stepper window. It keeps - ; track of all of the sexps & error messages in a given step, reformatting as necessary. - - ;; constructor : ((union (listof sexp) string) (union (listof sexp) string) -> ) - - (define stepper-text% - (class f:text:standard-style-list% () - - (init-field left-side right-side) - - (inherit find-snip insert change-style highlight-range last-position lock erase auto-wrap - begin-edit-sequence end-edit-sequence get-start-position get-style-list set-style-list - get-admin get-snip-location get-dc needs-update hide-caret) - (public* [reset-width - (lambda (canvas) - (lock #f) - (begin-edit-sequence) - (let* ([width-box (box 0)] - [canvas-width (begin (send (get-admin) get-view #f #f width-box #f) (unbox width-box))] - [dc (send canvas get-dc)]) - (unless (and old-width (= canvas-width old-width)) - (let* ([minus-cursor-margin (- canvas-width 2)] - [vert-separator-width-box (box 0)] - [_ (send vert-separator get-extent dc 0 0 vert-separator-width-box - #f #f #f #f #f)] - [vert-separator-width (unbox vert-separator-width-box)] - [minus-center-bar (- minus-cursor-margin vert-separator-width)] - [l-r-box-widths (floor (/ minus-center-bar 2))]) - (send before-snip set-new-width l-r-box-widths canvas) - (send after-snip set-new-width l-r-box-widths canvas) - (coordinate-snip-sizes)) - (set! old-width canvas-width)) - (end-edit-sequence) - (lock #t)))]) - - (define old-width #f) - (define before-snip (make-object stepper-editor-snip%)) - (define vert-separator (make-object vertical-separator-snip% 10)) - (define after-snip (make-object stepper-editor-snip%)) - - ;; coordinate-snip-sizes : make the vertical separator snip the right size, then notify the administrator. - (define/private (coordinate-snip-sizes) - (let* ([get-snip-height - (lambda (snip) - (let* ([top-box (box 0)] - [bottom-box (box 0)]) - (get-snip-location snip #f top-box #f) - (get-snip-location snip #f bottom-box #t) - (- (unbox bottom-box) (unbox top-box))))] - [max-height (max (get-snip-height before-snip) (get-snip-height after-snip))]) - (send vert-separator set-height! (- max-height 4)) - (let ([w-box (box 0)] - [h-box (box 0)]) - (send vert-separator get-extent #f 0 0 w-box h-box #f #f #f #f) - (send (send vert-separator get-admin) resized vert-separator #t)))) - - - - (super-instantiate ()) - (hide-caret #t) - - ;; insert the editor-snips & separator-snip, and change the style. - (let ([before-position (last-position)]) - (for-each (lambda (x) (insert x)) ;; NB: eta-expansion necessary because insert is a method, not a procedure. - (list before-snip vert-separator after-snip)) - (change-style snip-delta before-position (last-position))) - - ;; attach the editors to the snips, and populate those editors. - - (define (setup-editor-snip snip error-or-exps highlight-color) - (send snip set-editor - (cond [(string? error-or-exps) - (make-object stepper-sub-error-text% error-or-exps)] - [else - (make-object stepper-sub-text% error-or-exps highlight-color)]))) - - (setup-editor-snip before-snip left-side redex-highlight-color) - (setup-editor-snip after-snip right-side reduct-highlight-color) - - - - - (lock #t))) - - (define finished-text - (instantiate (class text% () - (define/public (reset-width arg) - (void)) - - (super-instantiate ()) - - (inherit insert lock) - (insert "All of the definitions have been successfully evaluated.") - (lock #t)) - ())) - - (define (snip? val) - (is-a? val snip%)) - - (define warning-color "yellow") - (define warning-font (send the-font-list find-or-create-font 18 'decorative 'normal 'bold #f)) - - (define stepper-warning% - (class canvas% - - (init-field warning-str) - - (inherit get-dc get-client-size) - (define/override (on-paint) - (let ([dc (get-dc)]) - (send dc set-font warning-font) - (let-values ([(cw ch) (get-client-size)] - [(tw th dont-care dont-care2) (send dc get-text-extent warning-str)]) - (send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid)) - (send dc draw-rectangle 0 0 cw ch) - (send dc draw-text - warning-str - (- (/ cw 2) (/ tw 2)) - (- (/ ch 2) (/ th 2)))))) - - (super-instantiate ()) - (inherit min-width min-height stretchable-height) - (let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning-str warning-font)]) - (min-width (+ 2 (inexact->exact (ceiling tw)))) - (min-height (+ 2 (inexact->exact (ceiling th))))) - - (stretchable-height #f))) - - - ; - ; - ; - ; ; - ; - ; ; ; - ; ;;; ;;;; ; ; ; ; ;; ;;;; ;;; ;;; ;;; ; ; ; ;; - ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ;; ; - ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; - ; ;; ; ; ; ; ; ;;;;;; ; ; ; ;;;;;; ;; ;;;;;; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; - ; ;;; ;; ; ; ; ;; ;; ;;; ;;; ;;;; ; ; ; ;; - ; ; ; - ; ; ; - ; ; ; - - - ; strip-to-sexp transforms a syntax-object to an s-expression. The reason we can't - ; just use syntax-object->datum for this is that certain syntax-objects must be - ; represented by a gensym'ed pointer into a table. - - (define (strip-to-sexp stx highlight-table) - (define (strip-regular stx) - (let* ([it (if (and (syntax? stx) - (eq? (stepper-syntax-property stx 'stepper-hint) 'from-xml)) - (strip-xml stx) - stx)] - [it - (cond [(pair? it) - (cons (strip-regular (car it)) - (strip-regular (cdr it)))] - [(syntax? it) - (strip-regular (syntax-e it))] - [else it])] - [it - (if (and (syntax? stx) - (stepper-syntax-property stx 'stepper-highlight)) - (if (pair? it) - (begin - (hash-table-put! highlight-table it 'non-confusable) - it) - (let ([new-sym (gensym "-placeholder")]) - (hash-table-put! highlight-table new-sym (list it)) - new-sym)) - it)]) - it)) + (define (read s) + (let ([size-box (box 0)]) + (send s get size-box) + (make-object vertical-separator-snip% 100))) - ; strip-xml attempts to undo the expansion of quasiquote. - (define (strip-xml stx) - ; we'll work on this later. - "" - ;(instantiate xml-snip% () [eliminate-whitespace-in-tags? #t]) - ) - - (strip-regular stx)) - - ;; the bitmap to use in a horizontal toolbar: - (define foot-img/horizontal (make-object bitmap% (build-path (collection-path - "icons") "foot.png") 'png/mask)) - - ;; the bitmap to use in a vertical toolbar: - (define foot-img/vertical (make-object bitmap% (build-path (collection-path - "icons") "foot-up.png") 'png/mask)) - + (super-instantiate ()))) - ;; testing code +(define vertical-separator-snipclass + (make-object vertical-separator-snip-class%)) + + +(send* vertical-separator-snipclass + (set-version 1) + (set-classname (format "~s" `(lib "vertical-separator-snip.ss" "stepper" "private")))) + +(send (get-the-snip-class-list) add vertical-separator-snipclass) + +(define vertical-separator-snip% + (class snip% + (inherit get-style set-snipclass set-flags get-flags get-admin) + (public set-height!) + (override write copy get-extent draw) + + (init-field height) + + + (define bitmap-width 15.0) + (define left-white 0.0) + (define right-white 3.0) + (define bitmap-height 10.0) + + (define (set-height! x) + (set! height (max x bitmap-height))) + + (define (write s) + (send s put (char->integer #\r))) ; this can't be right...? + + (define (copy) + (let ([s (make-object vertical-separator-snip% height)]) + (send s set-style (get-style)) + s)) + + (define (get-extent dc x y w-box h-box descent-box space-box lspace-box rspace-box) + (for-each (lambda (box) (unless (not box) (set-box! box 0))) + (list descent-box space-box lspace-box rspace-box)) + (unless (not w-box) + (set-box! w-box (+ left-white right-white bitmap-width))) + (unless (not h-box) + (set-box! h-box height))) + + (define (draw dc x y left top right bottom dx dy draw-caret) + (let ([y-offset (round (/ (- height bitmap-height) 2))] + [x-offset left-white]) + (send dc draw-bitmap red-arrow-bitmap (+ x x-offset) (+ y y-offset)))) + + (super-instantiate ()) + (set-snipclass vertical-separator-snipclass))) + + +;;;; end of vertical snip-stuff + +(define stepper-editor-snip% + (class editor-snip% + (inherit get-editor set-min-width set-max-width) + (public* + [set-new-width + (lambda (width canvas) + (set-min-width width) + (set-max-width width) + (let ([editor (get-editor)]) + (when editor + (send editor reset-pretty-print-width width canvas))))]) + (super-instantiate (#f #f 0 0 0 0 0 0 0 0)))) + +; ;; ; +; ; ; ; ; ; ; +;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;; ; ; ; ;;; ;;;; ;;; ; ; ;;;;; ; ; +; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; +;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +; ; ; ;; ; ;; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; +;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;; ; ; ;;; ;; ;;;; ; ; ;;; ;; +; ; +; ; + +; the stepper-sub-text% class is used to hold an individual list of sexps, with one or more highlights. +; there are four of them (* NB: now only two! 2005-08) in the stepper window. + +(define stepper-sub-text% + (class f:text:standard-style-list% + + (init-field exps highlight-color show-inexactness?) + + (inherit insert get-style-list set-style-list change-style highlight-range last-position lock erase + begin-edit-sequence end-edit-sequence get-start-position select-all clear) + + (public* [reset-pretty-print-width + (lambda (inner-width canvas) + (begin-edit-sequence) + (let* ([style (send (get-style-list) find-named-style "Standard")] + [char-width (send style get-text-width (send canvas get-dc))] + [width (floor (/ (- inner-width 18) char-width))]) + (reformat-sexp width) + (end-edit-sequence)))]) + + (define highlight-table (make-weak-hash)) + + (define stripped-exps + (map (lambda (exp) (strip-to-sexp exp highlight-table)) exps)) + + (define pretty-printed-width #f) + (define clear-highlight-thunks null) + (define/private (reset-style) + (change-style (send (get-style-list) find-named-style "Standard"))) + (define/private (set-last-style) + (change-style (send (get-style-list) find-named-style "Standard") + (sub1 (last-position)) + (last-position))) + + (define/private (reformat-sexp width) + (when (not (eq? pretty-printed-width width)) + (set! pretty-printed-width width) + (format-whole-step))) + + (define highlight-begin #f) + + (inherit get-dc) + + (define/private (format-sexp sexp) + (define text-port (open-output-text-editor this)) + + (parameterize + ([pretty-print-show-inexactness show-inexactness?] + [pretty-print-columns pretty-printed-width] + + ; the pretty-print-size-hook decides whether this object should be printed by the new pretty-print-hook + [pretty-print-size-hook + (lambda (value display? port) + (when (not highlight-table) + (fprintf (current-error-port) "hey! the highlight-table doesn't exist! (1)")) + (let ([looked-up (hash-ref highlight-table value (lambda () #f))]) + (cond + [(is-a? value snip%) + ;; Calculate the effective width of the snip, so that + ;; too-long lines (as a result of large snips) are broken + ;; correctly. When the snip is actusally inserted, its width + ;; will be determined by `(send snip get-count)', but the number + ;; returned here triggers line breaking in the pretty printer. + (let ([dc (get-dc)] + [wbox (box 0)]) + (send value get-extent dc 0 0 wbox #f #f #f #f #f) + (let-values ([(xw dc dc2 dc3) (send dc get-text-extent "x")]) + (max 1 (inexact->exact (ceiling (/ (unbox wbox) xw))))))] + [(and looked-up (not (eq? looked-up 'non-confusable))) + (string-length (format "~s" (car looked-up)))] + [else #f])))] + + [pretty-print-print-hook + ; this print-hook is called for confusable highlights and for images. + (lambda (value display? port) + (when (not highlight-table) + (fprintf (current-error-port) "hey! the highlight-table doesn't exist! (2)")) + (let ([to-display (cond + [(hash-ref highlight-table value (lambda () #f)) => car] + [else value])]) + (cond + [(is-a? to-display snip%) + (write-special (send to-display copy) port) (set-last-style)] + [else + ;; there's already code somewhere else to handle this; this seems like a bit of a hack. + (when (and (number? to-display) (inexact? to-display) (pretty-print-show-inexactness)) + (write-string "#i" port)) + (write-string (format "~s" to-display) port)])))] + [pretty-print-print-line + (lambda (number port old-length dest-columns) + (when (and number (not (eq? number 0))) + (newline port)) + 0)] + [pretty-print-pre-print-hook + (lambda (value p) + (when (not highlight-table) + (fprintf (current-error-port) "hey! the highlight-table doesn't exist! (3)")) + (when (hash-ref highlight-table value (lambda () #f)) + (set! highlight-begin (get-start-position))))] + [pretty-print-post-print-hook + (lambda (value p) + (when (not highlight-table) + (fprintf (current-error-port) "hey! the highlight-table doesn't exist! (4)")) + (when (hash-ref highlight-table value (lambda () #f)) + (let ([highlight-end (get-start-position)]) + (unless highlight-begin + (error 'format-whole-step "no highlight-begin to match highlight-end")) + (set! clear-highlight-thunks + (cons (highlight-range highlight-begin highlight-end highlight-color) + clear-highlight-thunks)) + (set! highlight-begin #f))))] + ;; mflatt: MAJOR HACK - this setting needs to come from the language + ;; somehow + [read-case-sensitive #t] + ) + (pretty-print sexp text-port))) + + (define/public (format-whole-step) + (lock #f) + (begin-edit-sequence) + (for-each (lambda (fun) (fun)) clear-highlight-thunks) + (set! clear-highlight-thunks null) + (select-all) + (clear) + (reset-style) + (let loop ([remaining stripped-exps] [first #t]) + (unless (null? remaining) + (unless first (insert #\newline)) + (format-sexp (car remaining)) + (loop (cdr remaining) #f))) + (end-edit-sequence) + (lock #t)) + + (super-instantiate ()))) + + +; ;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;; ; ; ; ;;; ;;; ; ;; ; ;; ;;; ; ;; ;;;; ;;; ; ; ;;;;; ; ; +; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;; ; ; ; ;; ;; ; ; ;; ; ; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; +; ;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ; ; ;;;;; ;;;;; ; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +; ; ; ; ;; ; ;; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;; ; ; ;;; ;;;; ; ; ;;; ; ;; ;;;; ; ; ;;; ;; +; ; ; +; ; ; + +; the stepper-sub-error-text%, like stepper-sub-text%, fits in one of the four^H^H^H^Htwo stepper "text" spots. +; it is used for error messages. + +(define stepper-sub-error-text% + (class f:text:standard-style-list% + + (init-field error-msg) + + (inherit get-style-list last-position set-style-list insert change-style auto-wrap + set-max-width) + + (public* [reset-pretty-print-width + (lambda (inner-width canvas) + (set-max-width inner-width))]) + + (super-instantiate ()) + (let ([before-error-msg (last-position)]) + (change-style (send (get-style-list) find-named-style "Standard")) + (auto-wrap #t) + (insert error-msg) + (change-style error-delta before-error-msg (last-position))))) + +;; ; +; ; ; ; +;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;; ;;; ; ;; ; ; ;;; ;;; ; ; ; +; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ; ;;;; ; ; ; ; ;;;; ;; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; +;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;;;;; ; ; ; ;;;;; ;;; ; ;; +; ; +; ; + +;; the stepper-canvas% overrides the editor-canvas simply so that on-size messages get passed to +;; the enclosed editor. + +(define stepper-canvas% + (class editor-canvas% + (inherit get-editor) + (override* + [on-size + (lambda (width height) + (super on-size width height) + (let ([editor (get-editor)]) + (when editor + (send editor reset-width this))))]) + + (super-instantiate ()))) + +;; ; +; ; ; ; ; ; +;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;;; ;;; ; ; ;;;;; ; ; +; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; +;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ; ;;;;; ;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; +; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; +;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;; ;;;; ; ; ;;; ;; +; ; +; ; + +; the stepper-text% is the principal inhabitant of the stepper window. It keeps +; track of all of the sexps & error messages in a given step, reformatting as necessary. + +;; constructor : ((union (listof sexp) string) (union (listof sexp) string) -> ) + +(define stepper-text% + (class f:text:standard-style-list% + + (init-field left-side right-side show-inexactness?) + + (inherit find-snip insert change-style highlight-range last-position lock erase auto-wrap + begin-edit-sequence end-edit-sequence get-start-position get-style-list set-style-list + get-admin get-snip-location get-dc needs-update hide-caret) + (public* [reset-width + (lambda (canvas) + (lock #f) + (begin-edit-sequence) + (let* ([width-box (box 0)] + [canvas-width (begin (send (get-admin) get-view #f #f width-box #f) (unbox width-box))] + [dc (send canvas get-dc)]) + (unless (and old-width (= canvas-width old-width)) + (let* ([minus-cursor-margin (- canvas-width 2)] + [vert-separator-width-box (box 0)] + [_ (send vert-separator get-extent dc 0 0 vert-separator-width-box + #f #f #f #f #f)] + [vert-separator-width (unbox vert-separator-width-box)] + [minus-center-bar (- minus-cursor-margin vert-separator-width)] + [l-r-box-widths (floor (/ minus-center-bar 2))]) + (send before-snip set-new-width l-r-box-widths canvas) + (send after-snip set-new-width l-r-box-widths canvas) + (coordinate-snip-sizes)) + (set! old-width canvas-width)) + (end-edit-sequence) + (lock #t)))]) + + (define old-width #f) + (define before-snip (make-object stepper-editor-snip%)) + (define vert-separator (make-object vertical-separator-snip% 10)) + (define after-snip (make-object stepper-editor-snip%)) + + ;; coordinate-snip-sizes : make the vertical separator snip the right size, then notify the administrator. + (define/private (coordinate-snip-sizes) + (let* ([get-snip-height + (lambda (snip) + (let* ([top-box (box 0)] + [bottom-box (box 0)]) + (get-snip-location snip #f top-box #f) + (get-snip-location snip #f bottom-box #t) + (- (unbox bottom-box) (unbox top-box))))] + [max-height (max (get-snip-height before-snip) (get-snip-height after-snip))]) + (send vert-separator set-height! (- max-height 4)) + (let ([w-box (box 0)] + [h-box (box 0)]) + (send vert-separator get-extent #f 0 0 w-box h-box #f #f #f #f) + (send (send vert-separator get-admin) resized vert-separator #t)))) + + + + (super-instantiate ()) + (hide-caret #t) + + ;; insert the editor-snips & separator-snip, and change the style. + (let ([before-position (last-position)]) + (for-each (lambda (x) (insert x)) ;; NB: eta-expansion necessary because insert is a method, not a procedure. + (list before-snip vert-separator after-snip)) + (change-style snip-delta before-position (last-position))) + + ;; attach the editors to the snips, and populate those editors. + + (define (setup-editor-snip snip error-or-exps highlight-color) + (send snip set-editor + (cond [(string? error-or-exps) + (make-object stepper-sub-error-text% error-or-exps)] + [else + (make-object stepper-sub-text% error-or-exps highlight-color show-inexactness?)]))) + + (setup-editor-snip before-snip left-side redex-highlight-color) + (setup-editor-snip after-snip right-side reduct-highlight-color) + + + + + (lock #t))) + +(define finished-text + (instantiate (class text% + (define/public (reset-width arg) + (void)) + + (super-instantiate ()) + + (inherit insert lock) + (insert "All of the definitions have been successfully evaluated.") + (lock #t)) + ())) + +(define (snip? val) + (is-a? val snip%)) + +(define warning-color "yellow") +(define warning-font (send the-font-list find-or-create-font 18 'decorative 'normal 'bold #f)) + +(define stepper-warning% + (class canvas% + + (init-field warning-str) + + (inherit get-dc get-client-size) + (define/override (on-paint) + (let ([dc (get-dc)]) + (send dc set-font warning-font) + (let-values ([(cw ch) (get-client-size)] + [(tw th dont-care dont-care2) (send dc get-text-extent warning-str)]) + (send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid)) + (send dc draw-rectangle 0 0 cw ch) + (send dc draw-text + warning-str + (- (/ cw 2) (/ tw 2)) + (- (/ ch 2) (/ th 2)))))) + + (super-instantiate ()) + (inherit min-width min-height stretchable-height) + (let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning-str warning-font)]) + (min-width (+ 2 (inexact->exact (ceiling tw)))) + (min-height (+ 2 (inexact->exact (ceiling th))))) + + (stretchable-height #f))) + + +; +; +; +; ; +; +; ; ; +; ;;; ;;;; ; ; ; ; ;; ;;;; ;;; ;;; ;;; ; ; ; ;; +; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ;; ; +; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; +; ;; ; ; ; ; ; ;;;;;; ; ; ; ;;;;;; ;; ;;;;;; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; +; ;;; ;; ; ; ; ;; ;; ;;; ;;; ;;;; ; ; ; ;; +; ; ; +; ; ; +; ; ; + + +; strip-to-sexp transforms a syntax-object to an s-expression. The reason we can't +; just use syntax-object->datum for this is that certain syntax-objects must be +; represented by a gensym'ed pointer into a table. + +(define (strip-to-sexp stx highlight-table) + (define (strip-regular stx) + (let* ([it (if (and (syntax? stx) + (eq? (stepper-syntax-property stx 'stepper-hint) 'from-xml)) + (strip-xml stx) + stx)] + [it + (cond [(pair? it) + (cons (strip-regular (car it)) + (strip-regular (cdr it)))] + [(syntax? it) + (strip-regular (syntax-e it))] + [else it])] + [it + (if (and (syntax? stx) + (stepper-syntax-property stx 'stepper-highlight)) + (if (pair? it) + (begin + (hash-set! highlight-table it 'non-confusable) + it) + (let ([new-sym (gensym "-placeholder")]) + (hash-set! highlight-table new-sym (list it)) + new-sym)) + it)]) + it)) - (define (stepper-text-test . args) - (let* ([new-frame (make-object frame% "test-frame")] - [new-text (apply make-object stepper-text% args)] - [new-canvas (make-object stepper-canvas% new-frame new-text)]) - (send new-canvas min-width 200) - (send new-canvas min-height 200) - (send new-frame show #t) - (send new-text reset-width new-canvas) - new-canvas)) + ; strip-xml attempts to undo the expansion of quasiquote. + (define (strip-xml stx) + ; we'll work on this later. + "" + ;(instantiate xml-snip% () [eliminate-whitespace-in-tags? #t]) + ) - - #;(define a + (strip-regular stx)) + +;; the bitmap to use in a horizontal toolbar: +(define foot-img/horizontal (make-object bitmap% (build-path (collection-path + "icons") "foot.png") 'png/mask)) + +;; the bitmap to use in a vertical toolbar: +(define foot-img/vertical (make-object bitmap% (build-path (collection-path + "icons") "foot-up.png") 'png/mask)) + + +;; testing code + +(define (stepper-text-test . args) + (let* ([new-frame (make-object frame% "test-frame")] + [new-text (apply make-object stepper-text% args)] + [new-canvas (make-object stepper-canvas% new-frame new-text)]) + (send new-canvas min-width 200) + (send new-canvas min-height 200) + (send new-frame show #t) + (send new-text reset-width new-canvas) + new-canvas)) + + +#;(define a (stepper-text-test (build-stx-with-highlight `((* 13 (hilite (* 15 16))))) (build-stx-with-highlight `((hilite (+ 3 4)) (define y 4) 13 14 (+ (hilite 13) (hilite #f)) 13 - 298 1 1 (+ (x 398 (hilite (+ x 398))) (hilite (x 398 (+ x 398)))) (hilite #f))))) - - ;; test out scroll bars - #;(stepper-text-test (build-stx-with-highlight `(1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8)) - (build-stx-with-highlight `(free!))) - - #;(stepper-text-test `() "This is an error message" ) - - #;(stepper-text-test "This is another error message" `(poomp)) - ) + 298 1 1 (+ (x 398 (hilite (+ x 398))) (hilite (x 398 (+ x 398)))) (hilite #f))) + #t)) + +;; test out scroll bars +#;(stepper-text-test (build-stx-with-highlight `(1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8)) + (build-stx-with-highlight `(free!)) + #t) + +#;(stepper-text-test `() "This is an error message" #t) + +#;(stepper-text-test "This is another error message" `(poomp) #t) + diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 8c8672de2e..123c256716 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -11,6 +11,7 @@ (prefix-in x: "private/mred-extensions.ss") "private/shared.ss" lang/stepper-language-interface + scheme/pretty "xml-sig.ss") (import drscheme:tool^ xml^ view-controller^) @@ -18,7 +19,6 @@ ;; tool magic here: (define (phase1) - ;; experiment with extending the language... parameter-like fields for stepper parameters (drscheme:language:extend-language-interface stepper-language<%> @@ -26,21 +26,27 @@ (class* superclass (stepper-language<%>) (public stepper:supported?) (define (stepper:supported?) #f) + (public stepper:enable-let-lifting?) (define (stepper:enable-let-lifting?) #f) + (public stepper:show-lambdas-as-lambdas?) (define (stepper:show-lambdas-as-lambdas?) #t) + + (public stepper:show-inexactness?) + (define (stepper:show-inexactness?) #t) + (public stepper:render-to-sexp) (define (stepper:render-to-sexp val settings language-level) - (parameterize ([current-print-convert-hook stepper-print-convert-hook]) + (parameterize ([pretty-print-show-inexactness (stepper:show-inexactness?)] + [current-print-convert-hook stepper-print-convert-hook]) (set-print-settings language-level settings (lambda () (simple-module-based-language-convert-value val - (drscheme:language:simple-settings-printing-style settings) - (drscheme:language:simple-settings-show-sharing settings)))))) + settings))))) (super-instantiate ()))))) @@ -65,82 +71,82 @@ ;; the stepper's frame: - (define stepper-frame% - (class (drscheme:frame:basics-mixin - (frame:frame:standard-menus-mixin frame:frame:basic%)) - - (init-field drscheme-frame) - - ;; PRINTING-PROC - ;; I frankly don't think that printing (i.e., to a printer) works - ;; correctly. 2005-07-01, JBC - (public set-printing-proc) - - (define (set-printing-proc proc) - (set! printing-proc proc)) - - (define (printing-proc item evt) - (message-box "error?" "shouldn't be called")) - - (define/private (file-menu:print a b) (printing-proc a b)) - - ;; MENUS - - (define/override (edit-menu:between-find-and-preferences edit-menu) - (void)) - (define/override (edit-menu:between-select-all-and-find edit-menu) - (void)) - (define/override (file-menu:between-save-as-and-print file-menu) - (void)) - - ;; CUSTODIANS - ;; The custodian is used to halt the stepped computation when the - ;; stepper window closes. The custodian is captured when the stepped - ;; computation starts. - - (define custodian #f) - (define/public (set-custodian! cust) - (set! custodian cust)) - (define/augment (on-close) - (when custodian - (custodian-shutdown-all custodian)) - (send drscheme-frame on-stepper-close) - (inner (void) on-close)) - - ;; WARNING BOXES: - - (define program-changed-warning-str - (string-constant stepper-program-has-changed)) - (define window-closed-warning-str - (string-constant stepper-program-window-closed)) - - (define warning-message-visible-already #f) - (define/private (add-warning-message warning-str) - (let ([warning-msg (new x:stepper-warning% - [warning-str warning-str] - [parent (get-area-container)])]) - (send (get-area-container) - change-children - (if warning-message-visible-already - (lambda (l) - (list (car l) warning-msg (caddr l))) - (lambda (l) - (list (car l) warning-msg (cadr l))))) - (set! warning-message-visible-already #t))) - - (inherit get-area-container) - (define program-change-already-warned? #f) - (define/public (original-program-changed) - (unless program-change-already-warned? - (set! program-change-already-warned? #t) - (add-warning-message program-changed-warning-str))) - - (define/public (original-program-gone) - (add-warning-message window-closed-warning-str)) - - (super-new [label "Stepper"] [parent #f] - [width stepper-initial-width] - [height stepper-initial-height]))) +(define stepper-frame% + (class (drscheme:frame:basics-mixin + (frame:frame:standard-menus-mixin frame:frame:basic%)) + + (init-field drscheme-frame) + + ;; PRINTING-PROC + ;; I frankly don't think that printing (i.e., to a printer) works + ;; correctly. 2005-07-01, JBC + (public set-printing-proc) + + (define (set-printing-proc proc) + (set! printing-proc proc)) + + (define (printing-proc item evt) + (message-box "error?" "shouldn't be called")) + + (define/private (file-menu:print a b) (printing-proc a b)) + + ;; MENUS + + (define/override (edit-menu:between-find-and-preferences edit-menu) + (void)) + (define/override (edit-menu:between-select-all-and-find edit-menu) + (void)) + (define/override (file-menu:between-save-as-and-print file-menu) + (void)) + + ;; CUSTODIANS + ;; The custodian is used to halt the stepped computation when the + ;; stepper window closes. The custodian is captured when the stepped + ;; computation starts. + + (define custodian #f) + (define/public (set-custodian! cust) + (set! custodian cust)) + (define/augment (on-close) + (when custodian + (custodian-shutdown-all custodian)) + (send drscheme-frame on-stepper-close) + (inner (void) on-close)) + + ;; WARNING BOXES: + + (define program-changed-warning-str + (string-constant stepper-program-has-changed)) + (define window-closed-warning-str + (string-constant stepper-program-window-closed)) + + (define warning-message-visible-already #f) + (define/private (add-warning-message warning-str) + (let ([warning-msg (new x:stepper-warning% + [warning-str warning-str] + [parent (get-area-container)])]) + (send (get-area-container) + change-children + (if warning-message-visible-already + (lambda (l) + (list (car l) warning-msg (caddr l))) + (lambda (l) + (list (car l) warning-msg (cadr l))))) + (set! warning-message-visible-already #t))) + + (inherit get-area-container) + (define program-change-already-warned? #f) + (define/public (original-program-changed) + (unless program-change-already-warned? + (set! program-change-already-warned? #t) + (add-warning-message program-changed-warning-str))) + + (define/public (original-program-gone) + (add-warning-message window-closed-warning-str)) + + (super-new [label "Stepper"] [parent #f] + [width stepper-initial-width] + [height stepper-initial-height]))) ;; stepper-unit-frame<%> : the interface that the extended drscheme frame @@ -314,44 +320,46 @@ ;; COPIED FROM drscheme/private/language.ss ;; simple-module-based-language-convert-value : TST STYLE boolean -> TST -(define (simple-module-based-language-convert-value value style show-sharing?) - (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) - (if (or (is-a? expr snip%) - ;; FIXME: internal in language.ss (to-snip-value? expr) - ) - expr - (sh expr basic-convert sub-convert))) - ;; mflatt: MINOR HACK - work around temporary - ;; print-convert problems - (define (stepper-print-convert v) - (or (and (procedure? v) (object-name v)) - (print-convert v))) - - (case style +(define (simple-module-based-language-convert-value value settings) + (case (drscheme:language:simple-settings-printing-style settings) [(write) value] - [(current-print) value] [(constructor) (parameterize ([constructor-style-printing #t] - [show-sharing show-sharing?] + [show-sharing (drscheme:language:simple-settings-show-sharing settings)] [current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))]) (stepper-print-convert value))] [(quasiquote) (parameterize ([constructor-style-printing #f] - [show-sharing show-sharing?] + [show-sharing (drscheme:language:simple-settings-show-sharing settings)] [current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))]) (stepper-print-convert value))] [else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")])) +(define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) + (if (or (is-a? expr snip%) + ;; FIXME: internal in language.ss (to-snip-value? expr) + ) + expr + (sh expr basic-convert sub-convert))) + +;; mflatt: MINOR HACK - work around temporary +;; print-convert problems +(define (stepper-print-convert v) + (or (and (procedure? v) (object-name v)) + (print-convert v))) + + ;; set-print-settings ; settings ( -> TST) -> TST (define (set-print-settings language simple-settings thunk) (if (method-in-interface? 'set-printing-parameters (object-interface language)) (send language set-printing-parameters simple-settings thunk) ;; assume that the current print-convert context is fine ;; (error 'stepper-tool "language object does not contain set-printing-parameters method") + ;; 2009-09-11, JBC : Gee Whiz, why the heck is it okay to assume that !? (thunk))) ;; WE REALLY WANT TO GET RID OF THIS STUFF (2005-07-01, JBC) diff --git a/collects/stepper/view-controller.ss b/collects/stepper/view-controller.ss index f44e990a39..d88b9f4473 100644 --- a/collects/stepper/view-controller.ss +++ b/collects/stepper/view-controller.ss @@ -11,7 +11,9 @@ (prefix-in x: "private/mred-extensions.ss") "private/shared.ss" "private/model-settings.ss" - "xml-sig.ss") + "xml-sig.ss" + (only-in scheme/pretty pretty-print-show-inexactness)) + (import drscheme:tool^ xml^ stepper-frame^) (export view-controller^) @@ -20,26 +22,19 @@ (define (definitions-text->settings definitions-text) (send definitions-text get-next-settings)) - -(define (settings->language-level settings) - (drscheme:language-configuration:language-settings-language settings)) ;; the stored representation of a step (define-struct step (text kind posns) #:transparent) (define (go drscheme-frame program-expander selection-start selection-end) - ;; get the language-level name: + ;; get the language-level: (define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text))) - (define language-level - (settings->language-level language-settings)) + (define language-level (drscheme:language-configuration:language-settings-language language-settings)) + (define simple-settings (drscheme:language-configuration:language-settings-settings language-settings)) ;; VALUE CONVERSION CODE: - (define simple-settings - (drscheme:language-configuration:language-settings-settings - language-settings)) - ;; render-to-string : TST -> string (define (render-to-string val) (let ([string-port (open-output-string)]) @@ -99,8 +94,8 @@ [else ;; nope, keep running: (begin (if (finished-stepping-step? new-step) - (begin (message-box "Ran out of steps" - "Reached the end of evaluation before finding the kind of step you were looking for.") + (begin (message-box (string-constant stepper-no-such-step/title) + (string-constant stepper-out-of-steps)) (update-view/existing (- (length view-history) 1))) (semaphore-post semaphore)))])])]))) (semaphore-wait new-semaphore))) @@ -210,8 +205,8 @@ (wait-for-it))] [#f (wait-for-it)])))] ['nomatch/seen-final - (message-box "Step Not Found" - "Couldn't find a step matching that criterion.") + (message-box (string-constant stepper-no-such-step/title) + (string-constant stepper-no-such-step)) (update-view/existing (- (length view-history) 1))])) ;; prior-of-specified-kind: if the desired step is already in the list, display @@ -222,8 +217,8 @@ (if found-step (update-view/existing found-step) (begin - (message-box "Step Not Found" - "Couldn't find an earlier step matching that criterion.") + (message-box (string-constant stepper-no-such-step/title) + (string-constant stepper-no-such-step/earlier)) (update-view/existing 0))))) ;; BUTTON/CHOICE BOX PROCEDURES @@ -275,15 +270,15 @@ (define (add-button name fun) (make-object button% name button-panel (lambda (_1 _2) (fun)))) (define (add-choice-box name fun) - (new choice% [label "Jump..."] + (new choice% [label name] [choices (map first pulldown-choices)] [parent button-panel] [callback fun])) (define pulldown-choices - `(("to beginning" ,jump-to-beginning) - ("to end" ,jump-to-end) - ("to beginning of selected" ,jump-to-selected))) + `((,(string-constant stepper-jump-to-beginning) ,jump-to-beginning) + (,(string-constant stepper-jump-to-end) ,jump-to-end) + (,(string-constant stepper-jump-to-selected) ,jump-to-selected))) (define previous-application-button (add-button (string-constant stepper-previous-application) previous-application)) (define previous-button (add-button (string-constant stepper-previous) previous)) @@ -347,18 +342,29 @@ ;; on-screen. Runs on the user thread. ;; : (step-result -> void) (define (receive-result result) - (match-let* - ([(list step-text step-kind posns) - (match result - [(struct before-after-result (pre-exps post-exps kind pre-src post-src)) - (list (new x:stepper-text% [left-side pre-exps] [right-side post-exps]) kind (list pre-src post-src))] - [(struct before-error-result (pre-exps err-msg pre-src)) - (list (new x:stepper-text% [left-side pre-exps] [right-side err-msg]) 'finished-or-error (list pre-src))] - [(struct error-result (err-msg)) - (list (new x:stepper-text% [left-side null] [right-side err-msg]) 'finished-or-error (list))] - [(struct finished-stepping ()) - (list x:finished-text 'finished-or-error (list))])]) - (hand-off-and-block step-text step-kind posns))) + ;; let's make sure this works: + (parameterize ([pretty-print-show-inexactness #t]) + (match-let* + ([(list step-text step-kind posns) + (match result + [(struct before-after-result (pre-exps post-exps kind pre-src post-src)) + (list (new x:stepper-text% + [left-side pre-exps] + [right-side post-exps] + ;; get this from the language level + [show-inexactness? (send language-level stepper:show-inexactness?)]) + kind (list pre-src post-src))] + [(struct before-error-result (pre-exps err-msg pre-src)) + (list (new x:stepper-text% + [left-side pre-exps] + [right-side err-msg] + [show-inexactness? (send language-level stepper:show-inexactness?)]) + 'finished-or-error (list pre-src))] + [(struct error-result (err-msg)) + (list (new x:stepper-text% [left-side null] [right-side err-msg]) 'finished-or-error (list))] + [(struct finished-stepping ()) + (list x:finished-text 'finished-or-error (list))])]) + (hand-off-and-block step-text step-kind posns)))) ;; program-expander-prime : wrap the program-expander for a couple of reasons: ;; 1) we need to capture the custodian as the thread starts up: