moved tracing support from the htdp tool into drscheme proper
svn: r14054
This commit is contained in:
Robby Findler
parent
d647999705
commit
53af4d6a9a
|
|
@ -46,11 +46,6 @@
|
|||
|
||||
(provide tool@)
|
||||
|
||||
(define sc-tracing (string-constant tracing-enable-tracing))
|
||||
(define sc-show-tracing-window (string-constant tracing-show-tracing-window))
|
||||
(define sc-hide-tracing-window (string-constant tracing-hide-tracing-window))
|
||||
(define sc-tracing-nothing-to-show (string-constant tracing-tracing-nothing-to-show))
|
||||
|
||||
(define ellipses-cutoff 200)
|
||||
|
||||
(define o (current-output-port))
|
||||
|
|
@ -76,18 +71,6 @@
|
|||
(unit
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
(define-local-member-name
|
||||
get-tracing-text
|
||||
show-tracing
|
||||
tracing:add-line
|
||||
tracing:rest)
|
||||
(define tab-tracing<%>
|
||||
(interface ()
|
||||
get-tracing-text
|
||||
get-any-results?
|
||||
tracing:add-line
|
||||
tracing:reset))
|
||||
|
||||
|
||||
(define drs-eventspace (current-eventspace))
|
||||
|
||||
|
|
@ -502,10 +485,10 @@
|
|||
(string-constant use-pretty-printer-label)
|
||||
output-panel
|
||||
void)]
|
||||
#;
|
||||
|
||||
[tracing (new check-box%
|
||||
(parent output-panel)
|
||||
(label sc-tracing)
|
||||
(label (string-constant tracing-enable-tracing))
|
||||
(callback void))]
|
||||
|
||||
[tps '()])
|
||||
|
|
@ -544,8 +527,8 @@
|
|||
(case (send writing-style get-selection)
|
||||
[(0) 'explicit]
|
||||
[(1) 'datum])
|
||||
#f ;; (send tracing get-value) -- disabled tracing
|
||||
tps)]
|
||||
(send tracing get-value)
|
||||
tps)]
|
||||
[(settings)
|
||||
(send case-sensitive set-value (drscheme:language:simple-settings-case-sensitive settings))
|
||||
(send output-style set-selection
|
||||
|
|
@ -583,8 +566,7 @@
|
|||
[parent tp-panel]
|
||||
[label (format "~s" tp)]))
|
||||
tps))
|
||||
;; disabled tracing
|
||||
#; (send tracing set-value (htdp-lang-settings-tracing? settings))
|
||||
(send tracing set-value (deinprogramm-lang-settings-tracing? settings))
|
||||
(void)])))
|
||||
|
||||
(define simple-deinprogramm-language%
|
||||
|
|
@ -1278,60 +1260,6 @@
|
|||
(define-values/invoke-unit et:stacktrace@
|
||||
(import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))
|
||||
|
||||
(define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key)))
|
||||
|
||||
(define (print-call-trace inferred-name original? src args improper? depth)
|
||||
(when inferred-name
|
||||
(let ([name (cond
|
||||
[(identifier? inferred-name) (syntax-e inferred-name)]
|
||||
[else (object-name inferred-name)])]
|
||||
[rep (drscheme:rep:current-rep)])
|
||||
(when (and name rep)
|
||||
(let ([canvas (send rep get-canvas)])
|
||||
(when canvas
|
||||
(let* ([frame (send canvas get-top-level-window)]
|
||||
[tab (send frame get-current-tab)])
|
||||
(when (is-a? tab tab-tracing<%>)
|
||||
(let ([sp (open-output-string)])
|
||||
(let loop ([i depth])
|
||||
(unless (zero? i)
|
||||
(display " " sp)
|
||||
(loop (- i 1))))
|
||||
(fprintf sp "(")
|
||||
(fprintf sp "~a" name)
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args) (void)]
|
||||
[(and (null? (cdr args)) improper?)
|
||||
(fprintf sp " . ")
|
||||
(fprintf sp "~v" (car args))]
|
||||
[else
|
||||
(let ([arg (car args)])
|
||||
(fprintf sp " ")
|
||||
(fprintf sp "~v" arg))
|
||||
(loop (cdr args))]))
|
||||
(fprintf sp ")")
|
||||
(let ([sema (make-semaphore)])
|
||||
;; Disable breaks, so an exn handler can't
|
||||
;; grab the DrScheme eventspacae:
|
||||
(parameterize-break #f
|
||||
;; Queue callback to write trace line ---
|
||||
;; low priority, so that infinite loops don't stop the user
|
||||
;; from clicking "Break"
|
||||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(send tab tracing:add-line (get-output-string sp))
|
||||
(semaphore-post sema))
|
||||
#f)))
|
||||
;; Wait for the line to get written, so that the
|
||||
;; trace output doesn't get too far behind (which
|
||||
;; matters, again, for infinite loops)
|
||||
(semaphore-wait sema)))))))))))
|
||||
|
||||
(define-values/invoke-unit tr:stacktrace@
|
||||
(import tr:stacktrace-imports^) (export (prefix tr: tr:stacktrace^)))
|
||||
|
||||
;; add-annotation : boolean (sexp -> value) -> sexp -> value
|
||||
;; adds debugging and test coverage information to `sexp' and calls `oe'
|
||||
(define (add-annotation tracing? oe)
|
||||
|
|
@ -1345,146 +1273,12 @@
|
|||
(namespace-base-phase))]
|
||||
[tr-annotated
|
||||
(if tracing?
|
||||
(tr:annotate (expand et-annotated))
|
||||
(drscheme:tracing:annotate (expand et-annotated))
|
||||
et-annotated)])
|
||||
tr-annotated))])
|
||||
(oe annotated)))])
|
||||
teaching-language-eval-handler))
|
||||
|
||||
(define tab-tracing-mixin
|
||||
(mixin (drscheme:unit:tab<%> drscheme:rep:context<%>) (tab-tracing<%>)
|
||||
(inherit get-frame)
|
||||
|
||||
(define tracing-visible? #f)
|
||||
(define/public (set-tracing-visible? v?) (set! tracing-visible? v?))
|
||||
(define/public (get-tracing-visible?) tracing-visible?)
|
||||
|
||||
(define/augment (clear-annotations)
|
||||
(tracing:reset)
|
||||
(inner (void) clear-annotations))
|
||||
|
||||
(define any-results? #f)
|
||||
(define/public (get-any-results?) any-results?)
|
||||
(define/public (tracing:reset)
|
||||
(set! any-results? #f)
|
||||
(send show-tracing-text lock #f)
|
||||
(send show-tracing-text erase)
|
||||
(send show-tracing-text auto-wrap #t)
|
||||
(send show-tracing-text insert sc-tracing-nothing-to-show)
|
||||
(send show-tracing-text lock #t))
|
||||
|
||||
(define show-tracing-text (new text:hide-caret/selection%))
|
||||
(define/public (get-tracing-text) show-tracing-text)
|
||||
(send show-tracing-text lock #t)
|
||||
|
||||
(define/public (tracing:add-line s)
|
||||
(let ([old-any? any-results?])
|
||||
(set! any-results? #t)
|
||||
(unless old-any?
|
||||
(send (get-frame) show-tracing))
|
||||
(send show-tracing-text begin-edit-sequence)
|
||||
(send show-tracing-text lock #f)
|
||||
(unless old-any?
|
||||
(send show-tracing-text erase)
|
||||
(send show-tracing-text auto-wrap #f))
|
||||
(let ([insert
|
||||
(lambda (s)
|
||||
(send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))])
|
||||
(cond
|
||||
[(<= (string-length s) ellipses-cutoff)
|
||||
(insert s)
|
||||
(insert "\n")]
|
||||
[else
|
||||
(insert (substring s 0 ellipses-cutoff))
|
||||
(insert " ")
|
||||
(let ([ell-start (send show-tracing-text last-position)])
|
||||
(insert "...")
|
||||
(let ([ell-end (send show-tracing-text last-position)])
|
||||
(let ([para (send show-tracing-text last-paragraph)])
|
||||
(insert "\n")
|
||||
(send show-tracing-text change-style clickback-delta ell-start ell-end)
|
||||
(send show-tracing-text set-clickback ell-start ell-end
|
||||
(lambda (t x y)
|
||||
(send show-tracing-text begin-edit-sequence)
|
||||
(send show-tracing-text lock #f)
|
||||
(let ([line-start (send show-tracing-text paragraph-start-position para)]
|
||||
[line-end (send show-tracing-text paragraph-end-position para)])
|
||||
(send show-tracing-text delete line-start line-end #f)
|
||||
(send show-tracing-text insert s line-start 'same #f))
|
||||
(send show-tracing-text lock #t)
|
||||
(send show-tracing-text end-edit-sequence))))))]))
|
||||
(send show-tracing-text lock #t)
|
||||
(send show-tracing-text end-edit-sequence)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
|
||||
(define frame-tracing-mixin
|
||||
(mixin (drscheme:frame:<%> drscheme:unit:frame<%>) ()
|
||||
(inherit get-current-tab)
|
||||
(define show-tracing-menu-item #f)
|
||||
(define tracing-visible? #f)
|
||||
|
||||
(define/augment (on-tab-change old new)
|
||||
(inner (void) on-tab-change old new)
|
||||
(send show-tracing-canvas set-editor (send new get-tracing-text))
|
||||
(cond
|
||||
[(eq? tracing-visible? (send new get-tracing-visible?))
|
||||
(void)]
|
||||
[(send new get-tracing-visible?)
|
||||
(show-tracing)]
|
||||
[else
|
||||
(hide-tracing)]))
|
||||
|
||||
(define/override (add-show-menu-items show-menu)
|
||||
(super add-show-menu-items show-menu)
|
||||
(set! show-tracing-menu-item
|
||||
(new menu-item%
|
||||
(parent show-menu)
|
||||
(label sc-show-tracing-window)
|
||||
(callback (lambda (x y) (toggle-tracing))))))
|
||||
|
||||
(define/public (show-tracing)
|
||||
(set! tracing-visible? #t)
|
||||
(send show-tracing-menu-item set-label sc-hide-tracing-window)
|
||||
(send dragable-parent begin-container-sequence)
|
||||
(send dragable-parent change-children
|
||||
(lambda (l)
|
||||
(let ([without (remq show-tracing-canvas l)])
|
||||
(append without (list show-tracing-canvas)))))
|
||||
(send dragable-parent set-percentages '(3/4 1/4))
|
||||
(send dragable-parent end-container-sequence))
|
||||
|
||||
(define/private (hide-tracing)
|
||||
(set! tracing-visible? #f)
|
||||
(send show-tracing-menu-item set-label sc-show-tracing-window)
|
||||
(send dragable-parent change-children
|
||||
(lambda (l)
|
||||
(remq show-tracing-canvas l))))
|
||||
|
||||
(define/private (toggle-tracing)
|
||||
(if tracing-visible?
|
||||
(hide-tracing)
|
||||
(show-tracing)))
|
||||
|
||||
(define dragable-parent #f)
|
||||
(define show-tracing-parent-panel #f)
|
||||
(define show-tracing-canvas #f)
|
||||
|
||||
(define/override (make-root-area-container cls parent)
|
||||
(set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent))
|
||||
(let ([root (make-object cls dragable-parent)])
|
||||
(set! show-tracing-canvas (new editor-canvas%
|
||||
(parent dragable-parent)
|
||||
(editor (send (get-current-tab) get-tracing-text))))
|
||||
(send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l)))
|
||||
root))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define clickback-delta (make-object style-delta%))
|
||||
(send clickback-delta set-delta-foreground "BLUE")
|
||||
(send clickback-delta set-delta 'change-underline #t)
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -1584,9 +1378,4 @@
|
|||
(allow-sharing? #t)
|
||||
(reader-module '(lib "DMdA-advanced-reader.ss" "deinprogramm"))
|
||||
(stepper:supported #f)
|
||||
(debugger:supported #t)))
|
||||
|
||||
;; #### these bomb:
|
||||
;(drscheme:get/extend:extend-unit-frame frame-tracing-mixin)
|
||||
;(drscheme:get/extend:extend-tab tab-tracing-mixin)
|
||||
)))
|
||||
(debugger:supported #t))))))
|
||||
|
|
|
|||
|
|
@ -1,320 +1,329 @@
|
|||
#lang scheme/base
|
||||
(require scheme/unit)
|
||||
|
||||
(provide drscheme:eval^
|
||||
drscheme:debug^
|
||||
drscheme:module-language^
|
||||
drscheme:get-collection^
|
||||
drscheme:main^
|
||||
drscheme:init^
|
||||
drscheme:language-configuration^
|
||||
drscheme:language-configuration/internal^
|
||||
drscheme:tools^
|
||||
drscheme:get/extend^
|
||||
drscheme:unit^
|
||||
drscheme:frame^
|
||||
drscheme:program^
|
||||
drscheme:text^
|
||||
drscheme:rep^
|
||||
drscheme:app^
|
||||
drscheme:draw-arrow^
|
||||
drscheme:help-desk^
|
||||
drscheme:language^
|
||||
drscheme:multi-file-search^
|
||||
drscheme:module-overview^
|
||||
drscheme:font^
|
||||
drscheme:modes^
|
||||
drscheme:tool-exports^
|
||||
drscheme:tool^
|
||||
drscheme:tool-cm^)
|
||||
|
||||
(define-signature drscheme:modes-cm^
|
||||
())
|
||||
(define-signature drscheme:modes^ extends drscheme:modes-cm^
|
||||
(add-mode
|
||||
get-modes
|
||||
add-initial-modes
|
||||
(struct mode (name surrogate repl-submit matches-language)
|
||||
#:omit-constructor)))
|
||||
|
||||
(define-signature drscheme:font-cm^
|
||||
())
|
||||
(define-signature drscheme:font^ extends drscheme:font-cm^
|
||||
(setup-preferences))
|
||||
|
||||
(define-signature drscheme:debug-cm^
|
||||
(profile-definitions-text-mixin
|
||||
profile-tab-mixin
|
||||
profile-unit-frame-mixin
|
||||
test-coverage-interactions-text-mixin
|
||||
test-coverage-definitions-text-mixin
|
||||
test-coverage-tab-mixin))
|
||||
(define-signature drscheme:debug^ extends drscheme:debug-cm^
|
||||
(make-debug-error-display-handler
|
||||
make-debug-eval-handler
|
||||
error-display-handler/stacktrace
|
||||
bug-info->ticket-url
|
||||
test-coverage-enabled
|
||||
profiling-enabled
|
||||
(require scheme/unit)
|
||||
|
||||
add-prefs-panel
|
||||
|
||||
get-error-color
|
||||
|
||||
hide-backtrace-window
|
||||
show-backtrace-window
|
||||
open-and-highlight-in-file
|
||||
get-cm-key
|
||||
|
||||
small-planet-bitmap
|
||||
|
||||
;show-error-and-highlight
|
||||
;print-bug-to-stderr
|
||||
;display-srclocs-in-error
|
||||
;show-syntax-error-context
|
||||
))
|
||||
(provide drscheme:eval^
|
||||
drscheme:debug^
|
||||
drscheme:module-language^
|
||||
drscheme:get-collection^
|
||||
drscheme:main^
|
||||
drscheme:init^
|
||||
drscheme:language-configuration^
|
||||
drscheme:language-configuration/internal^
|
||||
drscheme:tools^
|
||||
drscheme:get/extend^
|
||||
drscheme:unit^
|
||||
drscheme:frame^
|
||||
drscheme:program^
|
||||
drscheme:text^
|
||||
drscheme:rep^
|
||||
drscheme:app^
|
||||
drscheme:draw-arrow^
|
||||
drscheme:help-desk^
|
||||
drscheme:language^
|
||||
drscheme:multi-file-search^
|
||||
drscheme:module-overview^
|
||||
drscheme:font^
|
||||
drscheme:modes^
|
||||
drscheme:tracing^
|
||||
drscheme:tool-exports^
|
||||
drscheme:tool^
|
||||
drscheme:tool-cm^)
|
||||
|
||||
(define-signature drscheme:module-langauge-cm^
|
||||
(module-language<%>))
|
||||
(define-signature drscheme:module-language^ extends drscheme:module-langauge-cm^
|
||||
(add-module-language
|
||||
module-language-put-file-mixin))
|
||||
|
||||
(define-signature drscheme:get-collection-cm^ ())
|
||||
(define-signature drscheme:get-collection^ extends drscheme:get-collection-cm^
|
||||
(get-file/collection))
|
||||
|
||||
(define-signature drscheme:main-cm^ ())
|
||||
(define-signature drscheme:main^ extends drscheme:main-cm^ ())
|
||||
|
||||
(define-signature drscheme:init-cm^
|
||||
())
|
||||
(define-signature drscheme:init^ extends drscheme:init-cm^
|
||||
(original-output-port
|
||||
original-error-port
|
||||
original-error-display-handler
|
||||
primitive-eval
|
||||
primitive-load
|
||||
error-display-handler-message-box-title
|
||||
system-logger
|
||||
system-custodian
|
||||
system-eventspace
|
||||
system-namespace
|
||||
first-dir))
|
||||
|
||||
(define-signature drscheme:language-configuration-cm^
|
||||
())
|
||||
(define-signature drscheme:language-configuration^ extends drscheme:language-configuration-cm^
|
||||
(add-language
|
||||
get-languages
|
||||
(struct language-settings (language settings))
|
||||
get-settings-preferences-symbol
|
||||
language-dialog
|
||||
fill-language-dialog))
|
||||
|
||||
(define-signature drscheme:language-configuration/internal^ extends drscheme:language-configuration^
|
||||
(add-info-specified-languages
|
||||
get-default-language-settings
|
||||
settings-preferences-symbol
|
||||
get-all-scheme-manual-keywords
|
||||
get-all-manual-keywords
|
||||
add-built-in-languages
|
||||
not-a-language-language<%>))
|
||||
|
||||
(define-signature drscheme:tools-cm^
|
||||
())
|
||||
(define-signature drscheme:tools^ extends drscheme:tools-cm^
|
||||
((struct successful-tool (spec bitmap name url))
|
||||
get-successful-tools
|
||||
only-in-phase
|
||||
load/invoke-all-tools
|
||||
add-prefs-panel))
|
||||
|
||||
(define-signature drscheme:get/extend-cm^
|
||||
())
|
||||
(define-signature drscheme:get/extend^ extends drscheme:get/extend-cm^
|
||||
(extend-tab
|
||||
extend-interactions-text
|
||||
extend-definitions-text
|
||||
extend-interactions-canvas
|
||||
extend-definitions-canvas
|
||||
extend-unit-frame
|
||||
get-tab
|
||||
get-interactions-text
|
||||
get-definitions-text
|
||||
get-interactions-canvas
|
||||
get-definitions-canvas
|
||||
get-unit-frame))
|
||||
|
||||
(define-signature drscheme:unit-cm^
|
||||
(tab%
|
||||
tab<%>
|
||||
frame%
|
||||
frame<%>
|
||||
definitions-canvas%
|
||||
get-definitions-text%
|
||||
definitions-text<%>
|
||||
interactions-canvas%))
|
||||
(define-signature drscheme:unit^ extends drscheme:unit-cm^
|
||||
(open-drscheme-window
|
||||
find-symbol
|
||||
get-program-editor-mixin
|
||||
add-to-program-editor-mixin
|
||||
forget-saved-bug-report
|
||||
record-saved-bug-report
|
||||
(struct teachpack-callbacks (get-names remove add))))
|
||||
|
||||
(define-signature drscheme:frame-cm^
|
||||
(<%>
|
||||
mixin
|
||||
basics-mixin
|
||||
basics<%>))
|
||||
(define-signature drscheme:frame^ extends drscheme:frame-cm^
|
||||
(create-root-menubar
|
||||
add-keybindings-item
|
||||
planet-spec?))
|
||||
|
||||
(define-signature drscheme:program-cm^
|
||||
(frame%))
|
||||
(define-signature drscheme:program^ extends drscheme:program-cm^
|
||||
())
|
||||
|
||||
(define-signature drscheme:eval-cm^
|
||||
())
|
||||
(define-signature drscheme:eval^ extends drscheme:eval-cm^
|
||||
(expand-program
|
||||
expand-program/multiple
|
||||
traverse-program/multiple
|
||||
build-user-eventspace/custodian
|
||||
set-basic-parameters
|
||||
get-snip-classes))
|
||||
|
||||
(define-signature drscheme:text-cm^
|
||||
(text<%>
|
||||
text%))
|
||||
(define-signature drscheme:text^ extends drscheme:text-cm^
|
||||
())
|
||||
|
||||
(define-signature drscheme:setup-cm^
|
||||
())
|
||||
(define-signature drscheme:setup^ extends drscheme:setup-cm^
|
||||
(do-setup))
|
||||
|
||||
(define-signature drscheme:rep-cm^
|
||||
(drs-bindings-keymap-mixin
|
||||
text%
|
||||
text<%>
|
||||
context<%>))
|
||||
(define-signature drscheme:rep^ extends drscheme:rep-cm^
|
||||
(current-rep
|
||||
current-language-settings
|
||||
current-value-port
|
||||
get-drs-bindings-keymap
|
||||
error-delta
|
||||
get-welcome-delta
|
||||
get-dark-green-delta
|
||||
drs-autocomplete-mixin))
|
||||
|
||||
(define-signature drscheme:app-cm^
|
||||
())
|
||||
(define-signature drscheme:app^ extends drscheme:app-cm^
|
||||
(about-drscheme
|
||||
add-language-items-to-help-menu
|
||||
add-important-urls-to-help-menu
|
||||
switch-language-to))
|
||||
|
||||
(define-signature drscheme:draw-arrow-cm^
|
||||
())
|
||||
(define-signature drscheme:draw-arrow^ extends drscheme:draw-arrow-cm^
|
||||
(draw-arrow))
|
||||
|
||||
(define-signature drscheme:help-desk-cm^
|
||||
())
|
||||
(define-signature drscheme:help-desk^ extends drscheme:help-desk-cm^
|
||||
(help-desk
|
||||
goto-plt-license
|
||||
get-docs))
|
||||
|
||||
(define-signature drscheme:language-cm^
|
||||
(language<%>
|
||||
module-based-language<%>
|
||||
simple-module-based-language<%>
|
||||
simple-module-based-language%
|
||||
simple-module-based-language->module-based-language-mixin
|
||||
module-based-language->language-mixin))
|
||||
(define-signature drscheme:language^ extends drscheme:language-cm^
|
||||
(get-default-mixin
|
||||
extend-language-interface
|
||||
get-language-extensions
|
||||
|
||||
create-module-based-launcher
|
||||
create-module-based-stand-alone-executable
|
||||
create-module-based-distribution
|
||||
|
||||
create-distribution-for-executable
|
||||
|
||||
create-executable-gui
|
||||
put-executable
|
||||
|
||||
;(struct loc (source position line column span))
|
||||
|
||||
(struct text/pos (text start end))
|
||||
(struct simple-settings (case-sensitive
|
||||
printing-style
|
||||
fraction-style
|
||||
show-sharing
|
||||
insert-newlines
|
||||
annotations))
|
||||
simple-settings->vector
|
||||
|
||||
simple-module-based-language-config-panel
|
||||
|
||||
add-snip-value
|
||||
setup-setup-values
|
||||
|
||||
register-capability
|
||||
capability-registered?
|
||||
get-capability-default
|
||||
get-capability-contract))
|
||||
|
||||
(define-signature drscheme:multi-file-search-cm^
|
||||
())
|
||||
(define-signature drscheme:multi-file-search^ extends drscheme:multi-file-search-cm^
|
||||
(multi-file-search))
|
||||
|
||||
(define-signature drscheme:module-overview-cm^
|
||||
())
|
||||
(define-signature drscheme:module-overview^ extends drscheme:module-overview-cm^
|
||||
(module-overview
|
||||
make-module-overview-pasteboard
|
||||
fill-pasteboard))
|
||||
|
||||
(define-signature drscheme:tool-exports-cm^
|
||||
())
|
||||
(define-signature drscheme:tool-exports^ extends drscheme:tool-exports-cm^
|
||||
(phase1
|
||||
phase2))
|
||||
|
||||
(define-signature drscheme:tool-cm^
|
||||
((open (prefix drscheme:debug: drscheme:debug-cm^))
|
||||
(open (prefix drscheme:unit: drscheme:unit-cm^))
|
||||
(open (prefix drscheme:rep: drscheme:rep-cm^))
|
||||
(open (prefix drscheme:frame: drscheme:frame-cm^))
|
||||
(open (prefix drscheme:get/extend: drscheme:get/extend-cm^))
|
||||
(open (prefix drscheme:language-configuration: drscheme:language-configuration-cm^))
|
||||
(open (prefix drscheme:language: drscheme:language-cm^))
|
||||
(open (prefix drscheme:help-desk: drscheme:help-desk-cm^))
|
||||
(open (prefix drscheme:eval: drscheme:eval-cm^))
|
||||
(open (prefix drscheme:modes: drscheme:modes-cm^))))
|
||||
(define-signature drscheme:modes-cm^
|
||||
())
|
||||
(define-signature drscheme:modes^ extends drscheme:modes-cm^
|
||||
(add-mode
|
||||
get-modes
|
||||
add-initial-modes
|
||||
(struct mode (name surrogate repl-submit matches-language)
|
||||
#:omit-constructor)))
|
||||
|
||||
(define-signature drscheme:tool^
|
||||
((open (prefix drscheme:debug: drscheme:debug^))
|
||||
(open (prefix drscheme:unit: drscheme:unit^))
|
||||
(open (prefix drscheme:rep: drscheme:rep^))
|
||||
(open (prefix drscheme:frame: drscheme:frame^))
|
||||
(open (prefix drscheme:get/extend: drscheme:get/extend^))
|
||||
(open (prefix drscheme:language-configuration: drscheme:language-configuration^))
|
||||
(open (prefix drscheme:language: drscheme:language^))
|
||||
(open (prefix drscheme:help-desk: drscheme:help-desk^))
|
||||
(open (prefix drscheme:eval: drscheme:eval^))
|
||||
(open (prefix drscheme:modes: drscheme:modes^))))
|
||||
(define-signature drscheme:font-cm^
|
||||
())
|
||||
(define-signature drscheme:font^ extends drscheme:font-cm^
|
||||
(setup-preferences))
|
||||
|
||||
(define-signature drscheme:debug-cm^
|
||||
(profile-definitions-text-mixin
|
||||
profile-tab-mixin
|
||||
profile-unit-frame-mixin
|
||||
test-coverage-interactions-text-mixin
|
||||
test-coverage-definitions-text-mixin
|
||||
test-coverage-tab-mixin))
|
||||
(define-signature drscheme:debug^ extends drscheme:debug-cm^
|
||||
(make-debug-error-display-handler
|
||||
make-debug-eval-handler
|
||||
error-display-handler/stacktrace
|
||||
bug-info->ticket-url
|
||||
test-coverage-enabled
|
||||
profiling-enabled
|
||||
|
||||
add-prefs-panel
|
||||
|
||||
get-error-color
|
||||
|
||||
hide-backtrace-window
|
||||
show-backtrace-window
|
||||
open-and-highlight-in-file
|
||||
get-cm-key
|
||||
|
||||
small-planet-bitmap
|
||||
|
||||
;show-error-and-highlight
|
||||
;print-bug-to-stderr
|
||||
;display-srclocs-in-error
|
||||
;show-syntax-error-context
|
||||
))
|
||||
|
||||
(define-signature drscheme:module-langauge-cm^
|
||||
(module-language<%>))
|
||||
(define-signature drscheme:module-language^ extends drscheme:module-langauge-cm^
|
||||
(add-module-language
|
||||
module-language-put-file-mixin))
|
||||
|
||||
(define-signature drscheme:get-collection-cm^ ())
|
||||
(define-signature drscheme:get-collection^ extends drscheme:get-collection-cm^
|
||||
(get-file/collection))
|
||||
|
||||
(define-signature drscheme:main-cm^ ())
|
||||
(define-signature drscheme:main^ extends drscheme:main-cm^ ())
|
||||
|
||||
(define-signature drscheme:init-cm^
|
||||
())
|
||||
(define-signature drscheme:init^ extends drscheme:init-cm^
|
||||
(original-output-port
|
||||
original-error-port
|
||||
original-error-display-handler
|
||||
primitive-eval
|
||||
primitive-load
|
||||
error-display-handler-message-box-title
|
||||
system-logger
|
||||
system-custodian
|
||||
system-eventspace
|
||||
system-namespace
|
||||
first-dir))
|
||||
|
||||
(define-signature drscheme:language-configuration-cm^
|
||||
())
|
||||
(define-signature drscheme:language-configuration^ extends drscheme:language-configuration-cm^
|
||||
(add-language
|
||||
get-languages
|
||||
(struct language-settings (language settings))
|
||||
get-settings-preferences-symbol
|
||||
language-dialog
|
||||
fill-language-dialog))
|
||||
|
||||
(define-signature drscheme:language-configuration/internal^ extends drscheme:language-configuration^
|
||||
(add-info-specified-languages
|
||||
get-default-language-settings
|
||||
settings-preferences-symbol
|
||||
get-all-scheme-manual-keywords
|
||||
get-all-manual-keywords
|
||||
add-built-in-languages
|
||||
not-a-language-language<%>))
|
||||
|
||||
(define-signature drscheme:tools-cm^
|
||||
())
|
||||
(define-signature drscheme:tools^ extends drscheme:tools-cm^
|
||||
((struct successful-tool (spec bitmap name url))
|
||||
get-successful-tools
|
||||
only-in-phase
|
||||
load/invoke-all-tools
|
||||
add-prefs-panel))
|
||||
|
||||
(define-signature drscheme:get/extend-cm^
|
||||
())
|
||||
(define-signature drscheme:get/extend^ extends drscheme:get/extend-cm^
|
||||
(extend-tab
|
||||
extend-interactions-text
|
||||
extend-definitions-text
|
||||
extend-interactions-canvas
|
||||
extend-definitions-canvas
|
||||
extend-unit-frame
|
||||
get-tab
|
||||
get-interactions-text
|
||||
get-definitions-text
|
||||
get-interactions-canvas
|
||||
get-definitions-canvas
|
||||
get-unit-frame))
|
||||
|
||||
(define-signature drscheme:unit-cm^
|
||||
(tab%
|
||||
tab<%>
|
||||
frame%
|
||||
frame<%>
|
||||
definitions-canvas%
|
||||
get-definitions-text%
|
||||
definitions-text<%>
|
||||
interactions-canvas%))
|
||||
(define-signature drscheme:unit^ extends drscheme:unit-cm^
|
||||
(open-drscheme-window
|
||||
find-symbol
|
||||
get-program-editor-mixin
|
||||
add-to-program-editor-mixin
|
||||
forget-saved-bug-report
|
||||
record-saved-bug-report
|
||||
(struct teachpack-callbacks (get-names remove add))))
|
||||
|
||||
(define-signature drscheme:frame-cm^
|
||||
(<%>
|
||||
mixin
|
||||
basics-mixin
|
||||
basics<%>))
|
||||
(define-signature drscheme:frame^ extends drscheme:frame-cm^
|
||||
(create-root-menubar
|
||||
add-keybindings-item
|
||||
planet-spec?))
|
||||
|
||||
(define-signature drscheme:program-cm^
|
||||
(frame%))
|
||||
(define-signature drscheme:program^ extends drscheme:program-cm^
|
||||
())
|
||||
|
||||
(define-signature drscheme:eval-cm^
|
||||
())
|
||||
(define-signature drscheme:eval^ extends drscheme:eval-cm^
|
||||
(expand-program
|
||||
expand-program/multiple
|
||||
traverse-program/multiple
|
||||
build-user-eventspace/custodian
|
||||
set-basic-parameters
|
||||
get-snip-classes))
|
||||
|
||||
(define-signature drscheme:text-cm^
|
||||
(text<%>
|
||||
text%))
|
||||
(define-signature drscheme:text^ extends drscheme:text-cm^
|
||||
())
|
||||
|
||||
(define-signature drscheme:setup-cm^
|
||||
())
|
||||
(define-signature drscheme:setup^ extends drscheme:setup-cm^
|
||||
(do-setup))
|
||||
|
||||
(define-signature drscheme:rep-cm^
|
||||
(drs-bindings-keymap-mixin
|
||||
text%
|
||||
text<%>
|
||||
context<%>))
|
||||
(define-signature drscheme:rep^ extends drscheme:rep-cm^
|
||||
(current-rep
|
||||
current-language-settings
|
||||
current-value-port
|
||||
get-drs-bindings-keymap
|
||||
error-delta
|
||||
get-welcome-delta
|
||||
get-dark-green-delta
|
||||
drs-autocomplete-mixin))
|
||||
|
||||
(define-signature drscheme:app-cm^
|
||||
())
|
||||
(define-signature drscheme:app^ extends drscheme:app-cm^
|
||||
(about-drscheme
|
||||
add-language-items-to-help-menu
|
||||
add-important-urls-to-help-menu
|
||||
switch-language-to))
|
||||
|
||||
(define-signature drscheme:draw-arrow-cm^
|
||||
())
|
||||
(define-signature drscheme:draw-arrow^ extends drscheme:draw-arrow-cm^
|
||||
(draw-arrow))
|
||||
|
||||
(define-signature drscheme:help-desk-cm^
|
||||
())
|
||||
(define-signature drscheme:help-desk^ extends drscheme:help-desk-cm^
|
||||
(help-desk
|
||||
goto-plt-license
|
||||
get-docs))
|
||||
|
||||
(define-signature drscheme:language-cm^
|
||||
(language<%>
|
||||
module-based-language<%>
|
||||
simple-module-based-language<%>
|
||||
simple-module-based-language%
|
||||
simple-module-based-language->module-based-language-mixin
|
||||
module-based-language->language-mixin))
|
||||
(define-signature drscheme:language^ extends drscheme:language-cm^
|
||||
(get-default-mixin
|
||||
extend-language-interface
|
||||
get-language-extensions
|
||||
|
||||
create-module-based-launcher
|
||||
create-module-based-stand-alone-executable
|
||||
create-module-based-distribution
|
||||
|
||||
create-distribution-for-executable
|
||||
|
||||
create-executable-gui
|
||||
put-executable
|
||||
|
||||
;(struct loc (source position line column span))
|
||||
|
||||
(struct text/pos (text start end))
|
||||
(struct simple-settings (case-sensitive
|
||||
printing-style
|
||||
fraction-style
|
||||
show-sharing
|
||||
insert-newlines
|
||||
annotations))
|
||||
simple-settings->vector
|
||||
|
||||
simple-module-based-language-config-panel
|
||||
|
||||
add-snip-value
|
||||
setup-setup-values
|
||||
|
||||
register-capability
|
||||
capability-registered?
|
||||
get-capability-default
|
||||
get-capability-contract))
|
||||
|
||||
(define-signature drscheme:multi-file-search-cm^
|
||||
())
|
||||
(define-signature drscheme:multi-file-search^ extends drscheme:multi-file-search-cm^
|
||||
(multi-file-search))
|
||||
|
||||
(define-signature drscheme:module-overview-cm^
|
||||
())
|
||||
(define-signature drscheme:module-overview^ extends drscheme:module-overview-cm^
|
||||
(module-overview
|
||||
make-module-overview-pasteboard
|
||||
fill-pasteboard))
|
||||
|
||||
(define-signature drscheme:tracing-cm^
|
||||
(tab-mixin
|
||||
frame-mixin))
|
||||
(define-signature drscheme:tracing^ extends drscheme:tracing-cm^
|
||||
(annotate))
|
||||
|
||||
(define-signature drscheme:tool-exports-cm^
|
||||
())
|
||||
(define-signature drscheme:tool-exports^ extends drscheme:tool-exports-cm^
|
||||
(phase1
|
||||
phase2))
|
||||
|
||||
(define-signature drscheme:tool-cm^
|
||||
((open (prefix drscheme:debug: drscheme:debug-cm^))
|
||||
(open (prefix drscheme:unit: drscheme:unit-cm^))
|
||||
(open (prefix drscheme:rep: drscheme:rep-cm^))
|
||||
(open (prefix drscheme:frame: drscheme:frame-cm^))
|
||||
(open (prefix drscheme:get/extend: drscheme:get/extend-cm^))
|
||||
(open (prefix drscheme:language-configuration: drscheme:language-configuration-cm^))
|
||||
(open (prefix drscheme:language: drscheme:language-cm^))
|
||||
(open (prefix drscheme:help-desk: drscheme:help-desk-cm^))
|
||||
(open (prefix drscheme:eval: drscheme:eval-cm^))
|
||||
(open (prefix drscheme:modes: drscheme:modes-cm^))
|
||||
(open (prefix drscheme:tracing: drscheme:tracing-cm^))))
|
||||
|
||||
(define-signature drscheme:tool^
|
||||
((open (prefix drscheme:debug: drscheme:debug^))
|
||||
(open (prefix drscheme:unit: drscheme:unit^))
|
||||
(open (prefix drscheme:rep: drscheme:rep^))
|
||||
(open (prefix drscheme:frame: drscheme:frame^))
|
||||
(open (prefix drscheme:get/extend: drscheme:get/extend^))
|
||||
(open (prefix drscheme:language-configuration: drscheme:language-configuration^))
|
||||
(open (prefix drscheme:language: drscheme:language^))
|
||||
(open (prefix drscheme:help-desk: drscheme:help-desk^))
|
||||
(open (prefix drscheme:eval: drscheme:eval^))
|
||||
(open (prefix drscheme:modes: drscheme:modes^))
|
||||
(open (prefix drscheme:tracing: drscheme:tracing^))))
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
(import [prefix drscheme:unit: drscheme:unit^]
|
||||
[prefix drscheme:frame: drscheme:frame^]
|
||||
[prefix drscheme:rep: drscheme:rep^]
|
||||
[prefix drscheme:debug: drscheme:debug^])
|
||||
[prefix drscheme:debug: drscheme:debug^]
|
||||
[prefix drscheme:tracing: drscheme:tracing^])
|
||||
(export drscheme:get/extend^)
|
||||
|
||||
(define make-extender
|
||||
|
|
@ -43,9 +44,10 @@
|
|||
built)))))
|
||||
|
||||
(define (get-base-tab%)
|
||||
(drscheme:debug:test-coverage-tab-mixin
|
||||
(drscheme:debug:profile-tab-mixin
|
||||
drscheme:unit:tab%)))
|
||||
(drscheme:tracing:tab-mixin
|
||||
(drscheme:debug:test-coverage-tab-mixin
|
||||
(drscheme:debug:profile-tab-mixin
|
||||
drscheme:unit:tab%))))
|
||||
|
||||
(define-values (extend-tab get-tab) (make-extender get-base-tab% 'tab%))
|
||||
|
||||
|
|
@ -62,8 +64,9 @@
|
|||
(make-extender get-base-definitions-canvas% 'definitions-canvas%))
|
||||
|
||||
(define (get-base-unit-frame%)
|
||||
(drscheme:debug:profile-unit-frame-mixin
|
||||
drscheme:unit:frame%))
|
||||
(drscheme:tracing:frame-mixin
|
||||
(drscheme:debug:profile-unit-frame-mixin
|
||||
drscheme:unit:frame%)))
|
||||
|
||||
(define-values (extend-unit-frame get-unit-frame)
|
||||
(make-extender get-base-unit-frame% 'drscheme:unit:frame))
|
||||
|
|
|
|||
|
|
@ -1,55 +1,60 @@
|
|||
#lang mzscheme
|
||||
(require "modes.ss"
|
||||
"font.ss"
|
||||
"eval.ss"
|
||||
"module-browser.ss"
|
||||
"multi-file-search.ss"
|
||||
"debug.ss"
|
||||
"module-language.ss"
|
||||
"tools.ss"
|
||||
mzlib/unit
|
||||
"language.ss"
|
||||
"language-configuration.ss"
|
||||
"drsig.ss"
|
||||
"init.ss"
|
||||
"text.ss"
|
||||
"app.ss"
|
||||
"main.ss"
|
||||
"rep.ss"
|
||||
"frame.ss"
|
||||
"unit.ss"
|
||||
"get-extend.ss"
|
||||
"help-desk.ss")
|
||||
(provide drscheme@)
|
||||
|
||||
|
||||
(define-compound-unit/infer drscheme-unit@
|
||||
(import)
|
||||
(export drscheme:debug^
|
||||
drscheme:unit^
|
||||
drscheme:rep^
|
||||
drscheme:frame^
|
||||
drscheme:get/extend^
|
||||
drscheme:language-configuration^
|
||||
drscheme:language^
|
||||
drscheme:help-desk^
|
||||
drscheme:eval^
|
||||
drscheme:modes^)
|
||||
(link init@ tools@ modes@ text@ eval@ frame@ rep@ language@
|
||||
module-overview@ unit@ debug@ multi-file-search@ get-extend@
|
||||
language-configuration@ font@ module-language@ help-desk@ app@ main@))
|
||||
|
||||
(define-unit/new-import-export drscheme@
|
||||
(import) (export drscheme:tool^)
|
||||
(((prefix drscheme:debug: drscheme:debug^)
|
||||
(prefix drscheme:unit: drscheme:unit^)
|
||||
(prefix drscheme:rep: drscheme:rep^)
|
||||
(prefix drscheme:frame: drscheme:frame^)
|
||||
(prefix drscheme:get/extend: drscheme:get/extend^)
|
||||
(prefix drscheme:language-configuration: drscheme:language-configuration^)
|
||||
(prefix drscheme:language: drscheme:language^)
|
||||
(prefix drscheme:help-desk: drscheme:help-desk^)
|
||||
(prefix drscheme:eval: drscheme:eval^)
|
||||
(prefix drscheme:modes: drscheme:modes^))
|
||||
drscheme-unit@))
|
||||
#lang scheme/base
|
||||
(require scheme/unit
|
||||
"modes.ss"
|
||||
"font.ss"
|
||||
"eval.ss"
|
||||
"module-browser.ss"
|
||||
"multi-file-search.ss"
|
||||
"debug.ss"
|
||||
"module-language.ss"
|
||||
"tools.ss"
|
||||
"language.ss"
|
||||
"language-configuration.ss"
|
||||
"drsig.ss"
|
||||
"init.ss"
|
||||
"text.ss"
|
||||
"app.ss"
|
||||
"main.ss"
|
||||
"rep.ss"
|
||||
"frame.ss"
|
||||
"unit.ss"
|
||||
"tracing.ss"
|
||||
"get-extend.ss"
|
||||
"help-desk.ss")
|
||||
|
||||
(provide drscheme@)
|
||||
|
||||
(define-compound-unit/infer drscheme-unit@
|
||||
(import)
|
||||
(export drscheme:debug^
|
||||
drscheme:unit^
|
||||
drscheme:rep^
|
||||
drscheme:frame^
|
||||
drscheme:get/extend^
|
||||
drscheme:language-configuration^
|
||||
drscheme:language^
|
||||
drscheme:help-desk^
|
||||
drscheme:eval^
|
||||
drscheme:modes^
|
||||
drscheme:tracing^)
|
||||
(link init@ tools@ modes@ text@ eval@ frame@ rep@ language@
|
||||
module-overview@ unit@ debug@ multi-file-search@ get-extend@
|
||||
language-configuration@ font@ module-language@ help-desk@
|
||||
tracing@ app@
|
||||
main@))
|
||||
|
||||
(define-unit/new-import-export drscheme@
|
||||
(import) (export drscheme:tool^)
|
||||
(((prefix drscheme:debug: drscheme:debug^)
|
||||
(prefix drscheme:unit: drscheme:unit^)
|
||||
(prefix drscheme:rep: drscheme:rep^)
|
||||
(prefix drscheme:frame: drscheme:frame^)
|
||||
(prefix drscheme:get/extend: drscheme:get/extend^)
|
||||
(prefix drscheme:language-configuration: drscheme:language-configuration^)
|
||||
(prefix drscheme:language: drscheme:language^)
|
||||
(prefix drscheme:help-desk: drscheme:help-desk^)
|
||||
(prefix drscheme:eval: drscheme:eval^)
|
||||
(prefix drscheme:modes: drscheme:modes^)
|
||||
(prefix drscheme:tracing: drscheme:tracing^))
|
||||
drscheme-unit@))
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,8 @@
|
|||
[prefix drscheme:init: drscheme:init^]
|
||||
[prefix drscheme:debug: drscheme:debug^]
|
||||
[prefix drscheme:eval: drscheme:eval^]
|
||||
[prefix drscheme:modes: drscheme:modes^])
|
||||
[prefix drscheme:modes: drscheme:modes^]
|
||||
[prefix drscheme:tracing: drscheme:tracing^])
|
||||
(export drscheme:tools^)
|
||||
|
||||
;; An installed-tool is
|
||||
|
|
|
|||
223
collects/drscheme/private/tracing.ss
Normal file
223
collects/drscheme/private/tracing.ss
Normal file
|
|
@ -0,0 +1,223 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/contract
|
||||
scheme/unit
|
||||
scheme/class
|
||||
scheme/path
|
||||
scheme/port
|
||||
scheme/list
|
||||
scheme/gui/base
|
||||
string-constants
|
||||
framework
|
||||
(prefix-in tr: trace/stacktrace)
|
||||
"drsig.ss")
|
||||
|
||||
(provide tracing@)
|
||||
|
||||
(define-unit tracing@
|
||||
(import [prefix drscheme:frame: drscheme:frame^]
|
||||
[prefix drscheme:rep: drscheme:rep^]
|
||||
[prefix drscheme:init: drscheme:init^]
|
||||
[prefix drscheme:unit: drscheme:unit^])
|
||||
(export drscheme:tracing^)
|
||||
|
||||
(define-local-member-name
|
||||
get-tracing-text
|
||||
show-tracing
|
||||
tracing:add-line
|
||||
tracing:rest)
|
||||
(define tab-tracing<%>
|
||||
(interface ()
|
||||
get-tracing-text
|
||||
get-any-results?
|
||||
tracing:add-line
|
||||
tracing:reset))
|
||||
|
||||
(define ellipses-cutoff 200)
|
||||
(define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key)))
|
||||
|
||||
(define (print-call-trace inferred-name original? src args improper? depth)
|
||||
(when inferred-name
|
||||
(let ([name (cond
|
||||
[(identifier? inferred-name) (syntax-e inferred-name)]
|
||||
[else (object-name inferred-name)])]
|
||||
[rep (drscheme:rep:current-rep)])
|
||||
(when (and name rep)
|
||||
(let ([canvas (send rep get-canvas)])
|
||||
(when canvas
|
||||
(let* ([frame (send canvas get-top-level-window)]
|
||||
[tab (send frame get-current-tab)])
|
||||
(when (is-a? tab tab-tracing<%>)
|
||||
(let ([sp (open-output-string)])
|
||||
(let loop ([i depth])
|
||||
(unless (zero? i)
|
||||
(display " " sp)
|
||||
(loop (- i 1))))
|
||||
(fprintf sp "(")
|
||||
(fprintf sp "~a" name)
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args) (void)]
|
||||
[(and (null? (cdr args)) improper?)
|
||||
(fprintf sp " . ")
|
||||
(fprintf sp "~v" (car args))]
|
||||
[else
|
||||
(let ([arg (car args)])
|
||||
(fprintf sp " ")
|
||||
(fprintf sp "~v" arg))
|
||||
(loop (cdr args))]))
|
||||
(fprintf sp ")")
|
||||
(let ([sema (make-semaphore)])
|
||||
;; Disable breaks, so an exn handler can't
|
||||
;; grab the DrScheme eventspacae:
|
||||
(parameterize-break #f
|
||||
;; Queue callback to write trace line ---
|
||||
;; low priority, so that infinite loops don't stop the user
|
||||
;; from clicking "Break"
|
||||
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(send tab tracing:add-line (get-output-string sp))
|
||||
(semaphore-post sema))
|
||||
#f)))
|
||||
;; Wait for the line to get written, so that the
|
||||
;; trace output doesn't get too far behind (which
|
||||
;; matters, again, for infinite loops)
|
||||
(semaphore-wait sema)))))))))))
|
||||
|
||||
(define-values/invoke-unit tr:stacktrace@
|
||||
(import tr:stacktrace-imports^) (export tr:stacktrace^))
|
||||
|
||||
(define tab-mixin
|
||||
(mixin (drscheme:unit:tab<%> drscheme:rep:context<%>) (tab-tracing<%>)
|
||||
(inherit get-frame)
|
||||
|
||||
(define tracing-visible? #f)
|
||||
(define/public (set-tracing-visible? v?) (set! tracing-visible? v?))
|
||||
(define/public (get-tracing-visible?) tracing-visible?)
|
||||
|
||||
(define/augment (clear-annotations)
|
||||
(tracing:reset)
|
||||
(inner (void) clear-annotations))
|
||||
|
||||
(define any-results? #f)
|
||||
(define/public (get-any-results?) any-results?)
|
||||
(define/public (tracing:reset)
|
||||
(set! any-results? #f)
|
||||
(send show-tracing-text lock #f)
|
||||
(send show-tracing-text erase)
|
||||
(send show-tracing-text auto-wrap #t)
|
||||
(send show-tracing-text insert (string-constant tracing-tracing-nothing-to-show))
|
||||
(send show-tracing-text lock #t))
|
||||
|
||||
(define show-tracing-text (new text:hide-caret/selection%))
|
||||
(define/public (get-tracing-text) show-tracing-text)
|
||||
(send show-tracing-text lock #t)
|
||||
|
||||
(define/public (tracing:add-line s)
|
||||
(let ([old-any? any-results?])
|
||||
(set! any-results? #t)
|
||||
(unless old-any?
|
||||
(send (get-frame) show-tracing))
|
||||
(send show-tracing-text begin-edit-sequence)
|
||||
(send show-tracing-text lock #f)
|
||||
(unless old-any?
|
||||
(send show-tracing-text erase)
|
||||
(send show-tracing-text auto-wrap #f))
|
||||
(let ([insert
|
||||
(lambda (s)
|
||||
(send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))])
|
||||
(cond
|
||||
[(<= (string-length s) ellipses-cutoff)
|
||||
(insert s)
|
||||
(insert "\n")]
|
||||
[else
|
||||
(insert (substring s 0 ellipses-cutoff))
|
||||
(insert " ")
|
||||
(let ([ell-start (send show-tracing-text last-position)])
|
||||
(insert "...")
|
||||
(let ([ell-end (send show-tracing-text last-position)])
|
||||
(let ([para (send show-tracing-text last-paragraph)])
|
||||
(insert "\n")
|
||||
(send show-tracing-text change-style clickback-delta ell-start ell-end)
|
||||
(send show-tracing-text set-clickback ell-start ell-end
|
||||
(lambda (t x y)
|
||||
(send show-tracing-text begin-edit-sequence)
|
||||
(send show-tracing-text lock #f)
|
||||
(let ([line-start (send show-tracing-text paragraph-start-position para)]
|
||||
[line-end (send show-tracing-text paragraph-end-position para)])
|
||||
(send show-tracing-text delete line-start line-end #f)
|
||||
(send show-tracing-text insert s line-start 'same #f))
|
||||
(send show-tracing-text lock #t)
|
||||
(send show-tracing-text end-edit-sequence))))))]))
|
||||
(send show-tracing-text lock #t)
|
||||
(send show-tracing-text end-edit-sequence)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define clickback-delta (make-object style-delta%))
|
||||
(send clickback-delta set-delta-foreground "BLUE")
|
||||
(send clickback-delta set-delta 'change-underline #t)
|
||||
|
||||
(define frame-mixin
|
||||
(mixin (drscheme:frame:<%> drscheme:unit:frame<%>) ()
|
||||
(inherit get-current-tab)
|
||||
(define show-tracing-menu-item #f)
|
||||
(define tracing-visible? #f)
|
||||
|
||||
(define/augment (on-tab-change old new)
|
||||
(inner (void) on-tab-change old new)
|
||||
(send show-tracing-canvas set-editor (send new get-tracing-text))
|
||||
(cond
|
||||
[(eq? tracing-visible? (send new get-tracing-visible?))
|
||||
(void)]
|
||||
[(send new get-tracing-visible?)
|
||||
(show-tracing)]
|
||||
[else
|
||||
(hide-tracing)]))
|
||||
|
||||
(define/override (add-show-menu-items show-menu)
|
||||
(super add-show-menu-items show-menu)
|
||||
(set! show-tracing-menu-item
|
||||
(new menu-item%
|
||||
(parent show-menu)
|
||||
(label (string-constant tracing-show-tracing-window))
|
||||
(callback (lambda (x y) (toggle-tracing))))))
|
||||
|
||||
(define/public (show-tracing)
|
||||
(set! tracing-visible? #t)
|
||||
(send show-tracing-menu-item set-label (string-constant tracing-hide-tracing-window))
|
||||
(send dragable-parent begin-container-sequence)
|
||||
(send dragable-parent change-children
|
||||
(lambda (l)
|
||||
(let ([without (remq show-tracing-canvas l)])
|
||||
(append without (list show-tracing-canvas)))))
|
||||
(send dragable-parent set-percentages '(3/4 1/4))
|
||||
(send dragable-parent end-container-sequence))
|
||||
|
||||
(define/private (hide-tracing)
|
||||
(set! tracing-visible? #f)
|
||||
(send show-tracing-menu-item set-label (string-constant tracing-show-tracing-window))
|
||||
(send dragable-parent change-children
|
||||
(lambda (l)
|
||||
(remq show-tracing-canvas l))))
|
||||
|
||||
(define/private (toggle-tracing)
|
||||
(if tracing-visible?
|
||||
(hide-tracing)
|
||||
(show-tracing)))
|
||||
|
||||
(define dragable-parent #f)
|
||||
(define show-tracing-parent-panel #f)
|
||||
(define show-tracing-canvas #f)
|
||||
|
||||
(define/override (make-root-area-container cls parent)
|
||||
(set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent))
|
||||
(let ([root (make-object cls dragable-parent)])
|
||||
(set! show-tracing-canvas (new editor-canvas%
|
||||
(parent dragable-parent)
|
||||
(editor (send (get-current-tab) get-tracing-text))))
|
||||
(send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l)))
|
||||
root))
|
||||
|
||||
(super-new))))
|
||||
|
|
@ -17,15 +17,11 @@ module browser threading seems wrong.
|
|||
scheme/path
|
||||
scheme/port
|
||||
scheme/list
|
||||
(only-in mzlib/etc compose)
|
||||
string-constants
|
||||
framework
|
||||
mrlib/name-message
|
||||
mrlib/bitmap-label
|
||||
mrlib/include-bitmap
|
||||
"drsig.ss"
|
||||
"auto-language.ss"
|
||||
"insert-large-letters.ss"
|
||||
mrlib/switchable-button
|
||||
mrlib/cache-image-snip
|
||||
mrlib/include-bitmap
|
||||
|
|
@ -33,6 +29,9 @@ module browser threading seems wrong.
|
|||
net/sendurl
|
||||
net/url
|
||||
|
||||
"drsig.ss"
|
||||
"auto-language.ss"
|
||||
"insert-large-letters.ss"
|
||||
(prefix-in drscheme:arrow: "../arrow.ss")
|
||||
|
||||
mred
|
||||
|
|
@ -372,6 +371,8 @@ module browser threading seems wrong.
|
|||
(reset-highlighting)
|
||||
(inner (void) after-delete x y))
|
||||
|
||||
(printf "creating a program editor mixin\n") (flush-output)
|
||||
|
||||
(apply super-make-object args))]
|
||||
[get-program-editor-mixin
|
||||
(λ ()
|
||||
|
|
@ -380,11 +381,11 @@ module browser threading seems wrong.
|
|||
[add-to-program-editor-mixin
|
||||
(λ (mixin)
|
||||
(drscheme:tools:only-in-phase 'drscheme:unit:add-to-program-editor-mixin 'phase1)
|
||||
(set! program-editor-mixin (compose mixin program-editor-mixin)))])
|
||||
(let ([old program-editor-mixin])
|
||||
(set! program-editor-mixin (λ (x) (mixin (old x))))))])
|
||||
(values get-program-editor-mixin
|
||||
add-to-program-editor-mixin)))
|
||||
|
||||
|
||||
;; this sends a message to it's frame when it gets the focus
|
||||
(define make-searchable-canvas%
|
||||
(λ (%)
|
||||
|
|
|
|||
|
|
@ -1,50 +1,42 @@
|
|||
#lang scheme
|
||||
(require string-constants
|
||||
framework
|
||||
(prefix-in et: errortrace/stacktrace)
|
||||
(prefix-in tr: trace/stacktrace)
|
||||
mzlib/pretty
|
||||
(prefix-in pc: mzlib/pconvert)
|
||||
mzlib/file
|
||||
mzlib/unit
|
||||
mzlib/class
|
||||
mzlib/list
|
||||
mzlib/struct
|
||||
mzlib/compile
|
||||
mzlib/struct
|
||||
drscheme/tool
|
||||
mred
|
||||
framework/private/bday
|
||||
syntax/moddep
|
||||
mrlib/cache-image-snip
|
||||
compiler/embed
|
||||
wxme/wxme
|
||||
setup/dirs
|
||||
|
||||
;; this module is shared between the drscheme's namespace (so loaded here)
|
||||
;; and the user's namespace in the teaching languages
|
||||
"private/set-result.ss"
|
||||
|
||||
"stepper-language-interface.ss"
|
||||
"debugger-language-interface.ss"
|
||||
"run-teaching-program.ss"
|
||||
stepper/private/shared
|
||||
|
||||
(only-in test-engine/scheme-gui make-formatter)
|
||||
(only-in test-engine/scheme-tests scheme-test-data error-handler test-format test-execute)
|
||||
(lib "test-engine/test-display.scm")
|
||||
)
|
||||
framework
|
||||
(prefix-in et: errortrace/stacktrace)
|
||||
mzlib/pretty
|
||||
(prefix-in pc: mzlib/pconvert)
|
||||
mzlib/file
|
||||
mzlib/unit
|
||||
mzlib/class
|
||||
mzlib/list
|
||||
mzlib/struct
|
||||
mzlib/compile
|
||||
mzlib/struct
|
||||
drscheme/tool
|
||||
mred
|
||||
framework/private/bday
|
||||
syntax/moddep
|
||||
mrlib/cache-image-snip
|
||||
compiler/embed
|
||||
wxme/wxme
|
||||
setup/dirs
|
||||
|
||||
;; this module is shared between the drscheme's namespace (so loaded here)
|
||||
;; and the user's namespace in the teaching languages
|
||||
"private/set-result.ss"
|
||||
|
||||
"stepper-language-interface.ss"
|
||||
"debugger-language-interface.ss"
|
||||
"run-teaching-program.ss"
|
||||
stepper/private/shared
|
||||
|
||||
(only-in test-engine/scheme-gui make-formatter)
|
||||
(only-in test-engine/scheme-tests scheme-test-data error-handler test-format test-execute)
|
||||
(lib "test-engine/test-display.scm")
|
||||
)
|
||||
|
||||
|
||||
(provide tool@)
|
||||
|
||||
(define sc-tracing (string-constant tracing-enable-tracing))
|
||||
(define sc-show-tracing-window (string-constant tracing-show-tracing-window))
|
||||
(define sc-hide-tracing-window (string-constant tracing-hide-tracing-window))
|
||||
(define sc-tracing-nothing-to-show (string-constant tracing-tracing-nothing-to-show))
|
||||
|
||||
(define ellipses-cutoff 200)
|
||||
|
||||
(define o (current-output-port))
|
||||
(define (oprintf . args) (apply fprintf o args))
|
||||
|
||||
|
|
@ -55,18 +47,6 @@
|
|||
(unit
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
(define-local-member-name
|
||||
get-tracing-text
|
||||
show-tracing
|
||||
tracing:add-line
|
||||
tracing:rest)
|
||||
(define tab-tracing<%>
|
||||
(interface ()
|
||||
get-tracing-text
|
||||
get-any-results?
|
||||
tracing:add-line
|
||||
tracing:reset))
|
||||
|
||||
|
||||
(define drs-eventspace (current-eventspace))
|
||||
|
||||
|
|
@ -269,7 +249,7 @@
|
|||
void)]
|
||||
[tracing (new check-box%
|
||||
(parent output-panel)
|
||||
(label sc-tracing)
|
||||
(label (string-constant tracing-enable-tracing))
|
||||
(callback void))]
|
||||
|
||||
[tps '()])
|
||||
|
|
@ -1127,61 +1107,7 @@
|
|||
|
||||
(define-values/invoke-unit et:stacktrace@
|
||||
(import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))
|
||||
|
||||
(define calltrace-key #`(quote #,(gensym 'drscheme-calltrace-key)))
|
||||
|
||||
(define (print-call-trace inferred-name original? src args improper? depth)
|
||||
(when inferred-name
|
||||
(let ([name (cond
|
||||
[(identifier? inferred-name) (syntax-e inferred-name)]
|
||||
[else (object-name inferred-name)])]
|
||||
[rep (drscheme:rep:current-rep)])
|
||||
(when (and name rep)
|
||||
(let ([canvas (send rep get-canvas)])
|
||||
(when canvas
|
||||
(let* ([frame (send canvas get-top-level-window)]
|
||||
[tab (send frame get-current-tab)])
|
||||
(when (is-a? tab tab-tracing<%>)
|
||||
(let ([sp (open-output-string)])
|
||||
(let loop ([i depth])
|
||||
(unless (zero? i)
|
||||
(display " " sp)
|
||||
(loop (- i 1))))
|
||||
(fprintf sp "(")
|
||||
(fprintf sp "~a" name)
|
||||
(let loop ([args args])
|
||||
(cond
|
||||
[(null? args) (void)]
|
||||
[(and (null? (cdr args)) improper?)
|
||||
(fprintf sp " . ")
|
||||
(fprintf sp "~v" (car args))]
|
||||
[else
|
||||
(let ([arg (car args)])
|
||||
(fprintf sp " ")
|
||||
(fprintf sp "~v" arg))
|
||||
(loop (cdr args))]))
|
||||
(fprintf sp ")")
|
||||
(let ([sema (make-semaphore)])
|
||||
;; Disable breaks, so an exn handler can't
|
||||
;; grab the DrScheme eventspacae:
|
||||
(parameterize-break #f
|
||||
;; Queue callback to write trace line ---
|
||||
;; low priority, so that infinite loops don't stop the user
|
||||
;; from clicking "Break"
|
||||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(send tab tracing:add-line (get-output-string sp))
|
||||
(semaphore-post sema))
|
||||
#f)))
|
||||
;; Wait for the line to get written, so that the
|
||||
;; trace output doesn't get too far behind (which
|
||||
;; matters, again, for infinite loops)
|
||||
(semaphore-wait sema)))))))))))
|
||||
|
||||
(define-values/invoke-unit tr:stacktrace@
|
||||
(import tr:stacktrace-imports^) (export (prefix tr: tr:stacktrace^)))
|
||||
|
||||
|
||||
;; add-annotation : boolean (sexp -> value) -> sexp -> value
|
||||
;; adds debugging and test coverage information to `sexp' and calls `oe'
|
||||
(define (add-annotation tracing? oe)
|
||||
|
|
@ -1195,147 +1121,13 @@
|
|||
(namespace-base-phase))]
|
||||
[tr-annotated
|
||||
(if tracing?
|
||||
(tr:annotate (expand et-annotated))
|
||||
(drscheme:tracing:annotate (expand et-annotated))
|
||||
et-annotated)])
|
||||
tr-annotated))])
|
||||
(oe annotated)))])
|
||||
teaching-language-eval-handler))
|
||||
|
||||
(define tab-tracing-mixin
|
||||
(mixin (drscheme:unit:tab<%> drscheme:rep:context<%>) (tab-tracing<%>)
|
||||
(inherit get-frame)
|
||||
|
||||
(define tracing-visible? #f)
|
||||
(define/public (set-tracing-visible? v?) (set! tracing-visible? v?))
|
||||
(define/public (get-tracing-visible?) tracing-visible?)
|
||||
|
||||
(define/augment (clear-annotations)
|
||||
(tracing:reset)
|
||||
(inner (void) clear-annotations))
|
||||
|
||||
(define any-results? #f)
|
||||
(define/public (get-any-results?) any-results?)
|
||||
(define/public (tracing:reset)
|
||||
(set! any-results? #f)
|
||||
(send show-tracing-text lock #f)
|
||||
(send show-tracing-text erase)
|
||||
(send show-tracing-text auto-wrap #t)
|
||||
(send show-tracing-text insert sc-tracing-nothing-to-show)
|
||||
(send show-tracing-text lock #t))
|
||||
|
||||
(define show-tracing-text (new text:hide-caret/selection%))
|
||||
(define/public (get-tracing-text) show-tracing-text)
|
||||
(send show-tracing-text lock #t)
|
||||
|
||||
(define/public (tracing:add-line s)
|
||||
(let ([old-any? any-results?])
|
||||
(set! any-results? #t)
|
||||
(unless old-any?
|
||||
(send (get-frame) show-tracing))
|
||||
(send show-tracing-text begin-edit-sequence)
|
||||
(send show-tracing-text lock #f)
|
||||
(unless old-any?
|
||||
(send show-tracing-text erase)
|
||||
(send show-tracing-text auto-wrap #f))
|
||||
(let ([insert
|
||||
(lambda (s)
|
||||
(send show-tracing-text insert s (send show-tracing-text last-position) 'same #f))])
|
||||
(cond
|
||||
[(<= (string-length s) ellipses-cutoff)
|
||||
(insert s)
|
||||
(insert "\n")]
|
||||
[else
|
||||
(insert (substring s 0 ellipses-cutoff))
|
||||
(insert " ")
|
||||
(let ([ell-start (send show-tracing-text last-position)])
|
||||
(insert "...")
|
||||
(let ([ell-end (send show-tracing-text last-position)])
|
||||
(let ([para (send show-tracing-text last-paragraph)])
|
||||
(insert "\n")
|
||||
(send show-tracing-text change-style clickback-delta ell-start ell-end)
|
||||
(send show-tracing-text set-clickback ell-start ell-end
|
||||
(lambda (t x y)
|
||||
(send show-tracing-text begin-edit-sequence)
|
||||
(send show-tracing-text lock #f)
|
||||
(let ([line-start (send show-tracing-text paragraph-start-position para)]
|
||||
[line-end (send show-tracing-text paragraph-end-position para)])
|
||||
(send show-tracing-text delete line-start line-end #f)
|
||||
(send show-tracing-text insert s line-start 'same #f))
|
||||
(send show-tracing-text lock #t)
|
||||
(send show-tracing-text end-edit-sequence))))))]))
|
||||
(send show-tracing-text lock #t)
|
||||
(send show-tracing-text end-edit-sequence)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
|
||||
(define frame-tracing-mixin
|
||||
(mixin (drscheme:frame:<%> drscheme:unit:frame<%>) ()
|
||||
(inherit get-current-tab)
|
||||
(define show-tracing-menu-item #f)
|
||||
(define tracing-visible? #f)
|
||||
|
||||
(define/augment (on-tab-change old new)
|
||||
(inner (void) on-tab-change old new)
|
||||
(send show-tracing-canvas set-editor (send new get-tracing-text))
|
||||
(cond
|
||||
[(eq? tracing-visible? (send new get-tracing-visible?))
|
||||
(void)]
|
||||
[(send new get-tracing-visible?)
|
||||
(show-tracing)]
|
||||
[else
|
||||
(hide-tracing)]))
|
||||
|
||||
(define/override (add-show-menu-items show-menu)
|
||||
(super add-show-menu-items show-menu)
|
||||
(set! show-tracing-menu-item
|
||||
(new menu-item%
|
||||
(parent show-menu)
|
||||
(label sc-show-tracing-window)
|
||||
(callback (lambda (x y) (toggle-tracing))))))
|
||||
|
||||
(define/public (show-tracing)
|
||||
(set! tracing-visible? #t)
|
||||
(send show-tracing-menu-item set-label sc-hide-tracing-window)
|
||||
(send dragable-parent begin-container-sequence)
|
||||
(send dragable-parent change-children
|
||||
(lambda (l)
|
||||
(let ([without (remq show-tracing-canvas l)])
|
||||
(append without (list show-tracing-canvas)))))
|
||||
(send dragable-parent set-percentages '(3/4 1/4))
|
||||
(send dragable-parent end-container-sequence))
|
||||
|
||||
(define/private (hide-tracing)
|
||||
(set! tracing-visible? #f)
|
||||
(send show-tracing-menu-item set-label sc-show-tracing-window)
|
||||
(send dragable-parent change-children
|
||||
(lambda (l)
|
||||
(remq show-tracing-canvas l))))
|
||||
|
||||
(define/private (toggle-tracing)
|
||||
(if tracing-visible?
|
||||
(hide-tracing)
|
||||
(show-tracing)))
|
||||
|
||||
(define dragable-parent #f)
|
||||
(define show-tracing-parent-panel #f)
|
||||
(define show-tracing-canvas #f)
|
||||
|
||||
(define/override (make-root-area-container cls parent)
|
||||
(set! dragable-parent (super make-root-area-container panel:horizontal-dragable% parent))
|
||||
(let ([root (make-object cls dragable-parent)])
|
||||
(set! show-tracing-canvas (new editor-canvas%
|
||||
(parent dragable-parent)
|
||||
(editor (send (get-current-tab) get-tracing-text))))
|
||||
(send dragable-parent change-children (lambda (l) (remq show-tracing-canvas l)))
|
||||
root))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define clickback-delta (make-object style-delta%))
|
||||
(send clickback-delta set-delta-foreground "BLUE")
|
||||
(send clickback-delta set-delta 'change-underline #t)
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
@ -1478,7 +1270,4 @@
|
|||
(reader-module '(lib "htdp-beginner-reader.ss" "lang"))
|
||||
(stepper:supported #t)
|
||||
(stepper:enable-let-lifting #t)
|
||||
(stepper:show-lambdas-as-lambdas #f)))
|
||||
|
||||
(drscheme:get/extend:extend-unit-frame frame-tracing-mixin)
|
||||
(drscheme:get/extend:extend-tab tab-tracing-mixin))))
|
||||
(stepper:show-lambdas-as-lambdas #f))))))
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ the settings above should match r5rs
|
|||
(check-top-of-repl)
|
||||
|
||||
(generic-settings #f)
|
||||
(generic-output #t #t #t)
|
||||
(generic-output #t #t #t #t)
|
||||
|
||||
(test-hash-bang)
|
||||
(test-error-after-definition)
|
||||
|
|
@ -150,7 +150,7 @@ the settings above should match r5rs
|
|||
(check-top-of-repl)
|
||||
|
||||
(generic-settings #f)
|
||||
(generic-output #t #t #t)
|
||||
(generic-output #t #t #t #t)
|
||||
|
||||
(test-hash-bang)
|
||||
(test-error-after-definition)
|
||||
|
|
@ -250,7 +250,7 @@ the settings above should match r5rs
|
|||
(check-top-of-repl)
|
||||
|
||||
(generic-settings #t)
|
||||
(generic-output #f #f #f)
|
||||
(generic-output #f #f #f #f)
|
||||
(teaching-language-fraction-output)
|
||||
|
||||
(test-hash-bang)
|
||||
|
|
@ -415,7 +415,7 @@ the settings above should match r5rs
|
|||
(check-top-of-repl)
|
||||
|
||||
(generic-settings #t)
|
||||
(generic-output #t #f #f)
|
||||
(generic-output #t #f #f #f)
|
||||
(teaching-language-fraction-output)
|
||||
|
||||
(test-hash-bang)
|
||||
|
|
@ -578,7 +578,7 @@ the settings above should match r5rs
|
|||
(check-top-of-repl)
|
||||
|
||||
(generic-settings #t)
|
||||
(generic-output #t #f #f)
|
||||
(generic-output #t #f #f #f)
|
||||
(teaching-language-fraction-output)
|
||||
|
||||
(test-hash-bang)
|
||||
|
|
@ -738,7 +738,7 @@ the settings above should match r5rs
|
|||
(check-top-of-repl)
|
||||
|
||||
(generic-settings #t)
|
||||
(generic-output #t #f #f)
|
||||
(generic-output #t #f #f #f)
|
||||
(teaching-language-fraction-output)
|
||||
|
||||
(test-hash-bang)
|
||||
|
|
@ -892,7 +892,7 @@ the settings above should match r5rs
|
|||
(check-top-of-repl)
|
||||
|
||||
(generic-settings #t)
|
||||
(generic-output #t #t #t)
|
||||
(generic-output #t #t #t #f)
|
||||
(teaching-language-fraction-output)
|
||||
|
||||
(test-hash-bang)
|
||||
|
|
@ -1150,8 +1150,9 @@ the settings above should match r5rs
|
|||
"(eq? 'g 'G)"
|
||||
(if false/true? "true" "#t")))
|
||||
|
||||
(define (generic-output list? quasi-quote? has-sharing?)
|
||||
(let* ([drs (wait-for-drscheme-frame)]
|
||||
(define (generic-output list? quasi-quote? has-sharing? has-print-printing?)
|
||||
(let* ([plain-print-style (if has-print-printing? "print" "write")]
|
||||
[drs (wait-for-drscheme-frame)]
|
||||
[expression (format "(define x (list 2))~n(list x x)")]
|
||||
[set-output-choice
|
||||
(lambda (option show-sharing pretty?)
|
||||
|
|
@ -1193,9 +1194,9 @@ the settings above should match r5rs
|
|||
(clear-definitions drs)
|
||||
(type-in-definitions drs expression)
|
||||
|
||||
(test "print" 'off #t "((2) (2))")
|
||||
(test plain-print-style 'off #t "((2) (2))")
|
||||
(when has-sharing?
|
||||
(test "print" 'on #t "(#0=(2) #0#)"))
|
||||
(test plain-print-style 'on #t "(#0=(2) #0#)"))
|
||||
(when quasi-quote?
|
||||
(test "Quasiquote" 'off #t "`((2) (2))")
|
||||
(when has-sharing?
|
||||
|
|
@ -1224,11 +1225,11 @@ the settings above should match r5rs
|
|||
(case-lambda
|
||||
[(x) (member #\newline (string->list x))]
|
||||
[() "newlines in result (may need to make the window smaller)"]))
|
||||
(test "print" #f #f
|
||||
(test plain-print-style #f #f
|
||||
(case-lambda
|
||||
[(x) (not (member #\newline (string->list x)))]
|
||||
[() "no newlines in result"]))
|
||||
(test "print" #f #t
|
||||
(test plain-print-style #f #t
|
||||
(case-lambda
|
||||
[(x) (member #\newline (string->list x))]
|
||||
[() "newlines in result (may need to make the window smaller)"]))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user