fixed #i printing
svn: r15993
This commit is contained in:
John Clements
parent
4510c0339f
commit
7bb15bbbeb
|
|
@ -1,12 +1,13 @@
|
|||
(module mred-extensions mzscheme
|
||||
(require mzlib/class
|
||||
#lang scheme
|
||||
|
||||
(require mzlib/class
|
||||
mred
|
||||
(prefix f: framework)
|
||||
(prefix-in f: framework)
|
||||
mzlib/pretty
|
||||
#;"testing-shared.ss"
|
||||
"shared.ss")
|
||||
|
||||
(provide
|
||||
(provide
|
||||
foot-img/horizontal
|
||||
foot-img/vertical
|
||||
stepper-canvas%
|
||||
|
|
@ -16,29 +17,29 @@
|
|||
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 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 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))
|
||||
(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.
|
||||
;;;; VERTICAL-SEPARATOR : the red arrow that separates the left half of the display from the right half.
|
||||
|
||||
(define red-arrow-bitmap
|
||||
(define red-arrow-bitmap
|
||||
(make-object bitmap% (build-path (collection-path "icons") "red-arrow.bmp") 'bmp))
|
||||
|
||||
(unless (send red-arrow-bitmap ok?)
|
||||
(unless (send red-arrow-bitmap ok?)
|
||||
(error 'red-arrow-bitmap "unable to load red-arrow bitmap"))
|
||||
|
||||
(define vertical-separator-snip-class%
|
||||
(class snip-class% ()
|
||||
(define vertical-separator-snip-class%
|
||||
(class snip-class%
|
||||
(override read)
|
||||
|
||||
(define (read s)
|
||||
|
|
@ -48,18 +49,18 @@
|
|||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define vertical-separator-snipclass
|
||||
(define vertical-separator-snipclass
|
||||
(make-object vertical-separator-snip-class%))
|
||||
|
||||
|
||||
(send* vertical-separator-snipclass
|
||||
(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)
|
||||
(send (get-the-snip-class-list) add vertical-separator-snipclass)
|
||||
|
||||
(define vertical-separator-snip%
|
||||
(class snip% ()
|
||||
(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)
|
||||
|
|
@ -100,10 +101,10 @@
|
|||
(set-snipclass vertical-separator-snipclass)))
|
||||
|
||||
|
||||
;;;; end of vertical snip-stuff
|
||||
;;;; end of vertical snip-stuff
|
||||
|
||||
(define stepper-editor-snip%
|
||||
(class editor-snip% ()
|
||||
(define stepper-editor-snip%
|
||||
(class editor-snip%
|
||||
(inherit get-editor set-min-width set-max-width)
|
||||
(public*
|
||||
[set-new-width
|
||||
|
|
@ -115,25 +116,25 @@
|
|||
(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.
|
||||
; 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% ()
|
||||
(define stepper-sub-text%
|
||||
(class f:text:standard-style-list%
|
||||
|
||||
(init-field exps highlight-color)
|
||||
(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)
|
||||
|
|
@ -147,7 +148,7 @@
|
|||
(reformat-sexp width)
|
||||
(end-edit-sequence)))])
|
||||
|
||||
(define highlight-table (make-hash-table 'weak))
|
||||
(define highlight-table (make-weak-hash))
|
||||
|
||||
(define stripped-exps
|
||||
(map (lambda (exp) (strip-to-sexp exp highlight-table)) exps))
|
||||
|
|
@ -174,14 +175,15 @@
|
|||
(define text-port (open-output-text-editor this))
|
||||
|
||||
(parameterize
|
||||
([pretty-print-columns pretty-printed-width]
|
||||
([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-table-get highlight-table value (lambda () #f))])
|
||||
(let ([looked-up (hash-ref highlight-table value (lambda () #f))])
|
||||
(cond
|
||||
[(is-a? value snip%)
|
||||
;; Calculate the effective width of the snip, so that
|
||||
|
|
@ -204,12 +206,15 @@
|
|||
(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]
|
||||
[(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)
|
||||
|
|
@ -220,13 +225,13 @@
|
|||
(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))
|
||||
(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-table-get highlight-table value (lambda () #f))
|
||||
(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"))
|
||||
|
|
@ -236,7 +241,8 @@
|
|||
(set! highlight-begin #f))))]
|
||||
;; mflatt: MAJOR HACK - this setting needs to come from the language
|
||||
;; somehow
|
||||
[read-case-sensitive #t])
|
||||
[read-case-sensitive #t]
|
||||
)
|
||||
(pretty-print sexp text-port)))
|
||||
|
||||
(define/public (format-whole-step)
|
||||
|
|
@ -258,23 +264,21 @@
|
|||
(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.
|
||||
; 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% ()
|
||||
(define stepper-sub-error-text%
|
||||
(class f:text:standard-style-list%
|
||||
|
||||
(init-field error-msg)
|
||||
|
||||
|
|
@ -292,23 +296,23 @@
|
|||
(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.
|
||||
;; 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% ()
|
||||
(define stepper-canvas%
|
||||
(class editor-canvas%
|
||||
(inherit get-editor)
|
||||
(override*
|
||||
[on-size
|
||||
|
|
@ -320,27 +324,27 @@
|
|||
|
||||
(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.
|
||||
; 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) -> )
|
||||
;; constructor : ((union (listof sexp) string) (union (listof sexp) string) -> )
|
||||
|
||||
(define stepper-text%
|
||||
(class f:text:standard-style-list% ()
|
||||
(define stepper-text%
|
||||
(class f:text:standard-style-list%
|
||||
|
||||
(init-field left-side right-side)
|
||||
(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
|
||||
|
|
@ -406,7 +410,7 @@
|
|||
(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)])))
|
||||
(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)
|
||||
|
|
@ -416,8 +420,8 @@
|
|||
|
||||
(lock #t)))
|
||||
|
||||
(define finished-text
|
||||
(instantiate (class text% ()
|
||||
(define finished-text
|
||||
(instantiate (class text%
|
||||
(define/public (reset-width arg)
|
||||
(void))
|
||||
|
||||
|
|
@ -428,13 +432,13 @@
|
|||
(lock #t))
|
||||
()))
|
||||
|
||||
(define (snip? val)
|
||||
(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 warning-color "yellow")
|
||||
(define warning-font (send the-font-list find-or-create-font 18 'decorative 'normal 'bold #f))
|
||||
|
||||
(define stepper-warning%
|
||||
(define stepper-warning%
|
||||
(class canvas%
|
||||
|
||||
(init-field warning-str)
|
||||
|
|
@ -462,29 +466,29 @@
|
|||
(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.
|
||||
; 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-to-sexp stx highlight-table)
|
||||
(define (strip-regular stx)
|
||||
(let* ([it (if (and (syntax? stx)
|
||||
(eq? (stepper-syntax-property stx 'stepper-hint) 'from-xml))
|
||||
|
|
@ -502,10 +506,10 @@
|
|||
(stepper-syntax-property stx 'stepper-highlight))
|
||||
(if (pair? it)
|
||||
(begin
|
||||
(hash-table-put! highlight-table it 'non-confusable)
|
||||
(hash-set! highlight-table it 'non-confusable)
|
||||
it)
|
||||
(let ([new-sym (gensym "-placeholder")])
|
||||
(hash-table-put! highlight-table new-sym (list it))
|
||||
(hash-set! highlight-table new-sym (list it))
|
||||
new-sym))
|
||||
it)])
|
||||
it))
|
||||
|
|
@ -519,18 +523,18 @@
|
|||
|
||||
(strip-regular stx))
|
||||
|
||||
;; the bitmap to use in a horizontal toolbar:
|
||||
(define foot-img/horizontal (make-object bitmap% (build-path (collection-path
|
||||
;; 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
|
||||
;; 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
|
||||
;; testing code
|
||||
|
||||
(define (stepper-text-test . args)
|
||||
(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)])
|
||||
|
|
@ -541,17 +545,19 @@
|
|||
new-canvas))
|
||||
|
||||
|
||||
#;(define a
|
||||
#;(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)))))
|
||||
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!)))
|
||||
;; 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" )
|
||||
#;(stepper-text-test `() "This is an error message" #t)
|
||||
|
||||
#;(stepper-text-test "This is another error message" `(poomp) #t)
|
||||
|
||||
#;(stepper-text-test "This is another error message" `(poomp))
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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,7 +71,7 @@
|
|||
|
||||
;; the stepper's frame:
|
||||
|
||||
(define stepper-frame%
|
||||
(define stepper-frame%
|
||||
(class (drscheme:frame:basics-mixin
|
||||
(frame:frame:standard-menus-mixin frame:frame:basic%))
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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^)
|
||||
|
|
@ -21,25 +23,18 @@
|
|||
(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)
|
||||
;; 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]) kind (list 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]) 'finished-or-error (list 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)))
|
||||
(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:
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user