b972a0940d
being edited in DrRacket (via places) Added an API to let tools have access to that information (and compute more stuff) Used that to make an online version of Check Syntax which led to a separately callable Check Syntax API.
225 lines
9.3 KiB
Racket
225 lines
9.3 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/contract
|
|
racket/unit
|
|
racket/class
|
|
racket/path
|
|
racket/port
|
|
racket/list
|
|
racket/gui/base
|
|
string-constants
|
|
framework
|
|
(prefix-in tr: trace/stacktrace)
|
|
"drsig.rkt")
|
|
|
|
(provide tracing@)
|
|
|
|
(define-unit tracing@
|
|
(import [prefix drracket:frame: drracket:frame^]
|
|
[prefix drracket:rep: drracket:rep^]
|
|
[prefix drracket:init: drracket:init^]
|
|
[prefix drracket:unit: drracket:unit^]
|
|
[prefix drracket: drracket:interface^])
|
|
(export drracket: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 (drracket: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 DrRacket 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 drracket: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 (drracket:unit:tab<%> drracket: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 (drracket:frame:<%> drracket: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))))
|