got it mostly working ... problems with require/annotations
svn: r117
This commit is contained in:
Jono Spiro
parent
fc52c29f5d
commit
8223b03b3b
84
collects/mztake/debugger-model.ss
Normal file
84
collects/mztake/debugger-model.ss
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
#|
|
||||
(let* ([breakpoint-origin (debug-file-filename client)]
|
||||
[breakpoints (hash-keys (debug-file-tracepoints client))]
|
||||
[program-expander (program-expander breakpoint-origin)])
|
||||
|#
|
||||
|
||||
(module debugger-model mzscheme
|
||||
(require (lib "unit.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "debugger-annotate.ss" "stepper/private")
|
||||
(lib "marks.ss" "stepper/private")
|
||||
(lib "list.ss")
|
||||
"mztake-structs.ss"
|
||||
"private/load-annotator.ss"
|
||||
"private/more-useful-code.ss")
|
||||
|
||||
(provide debugger-model@)
|
||||
|
||||
(define (send-to-eventspace eventspace thunk)
|
||||
(parameterize ([current-eventspace eventspace])
|
||||
(queue-callback thunk)))
|
||||
|
||||
(define debugger-model@
|
||||
(unit
|
||||
(import receive-result
|
||||
process)
|
||||
(export run)
|
||||
|
||||
(define (run-semaphore) (debug-process-run-semaphore process))
|
||||
|
||||
(define (queue-result result)
|
||||
(send-to-eventspace (debug-process-eventspace process)
|
||||
(lambda () (receive-result result))))
|
||||
|
||||
(define basic-eval (current-eval))
|
||||
|
||||
(define ((break client) mark-set kind final-mark)
|
||||
(let ([mark-list (continuation-mark-set->list mark-set debug-key)])
|
||||
(queue-result (make-normal-breakpoint-info (cons final-mark mark-list) client))
|
||||
(queue-result (make-breakpoint-halt))
|
||||
(semaphore-wait (run-semaphore))))
|
||||
|
||||
(define ((err-display-handler source) message exn)
|
||||
(queue-result (make-error-breakpoint-info (list source exn))))
|
||||
|
||||
|
||||
(define (annotate-module-with-error-handler stx err-hndlr)
|
||||
(syntax-case stx (module #%plain-module-begin)
|
||||
[(module name req (#%plain-module-begin body ...))
|
||||
#`(module name req (#%plain-module-begin
|
||||
(error-display-handler #,err-hndlr)
|
||||
body ...))]))
|
||||
|
||||
|
||||
; Return run functions
|
||||
(define (run)
|
||||
(parameterize ([error-display-handler (err-display-handler "Trying to load client code...")])
|
||||
(let* ([clients (debug-process-clients process)]
|
||||
|
||||
[all-used-module-paths (map (lambda (c) (debug-client-modpath c))
|
||||
clients)]
|
||||
|
||||
[path->client (lambda (path)
|
||||
(car (filter (lambda (c) (equal? (debug-client-modpath c) path))
|
||||
clients)))]
|
||||
|
||||
[annotate-module? (lambda (fn m)
|
||||
(memf (lambda (sym) (eq? sym fn))
|
||||
all-used-module-paths))]
|
||||
|
||||
[annotator (lambda (fn m stx)
|
||||
(printf "annotating: ~a~n~n" fn)
|
||||
(let* ([client (path->client fn)]
|
||||
[breakpoints (hash-keys (debug-client-tracepoints client))]
|
||||
[stx (annotate (expand stx) breakpoints fn (break client))])
|
||||
; add an error handler so anything that goes wrong points to the correct module
|
||||
(annotate-module-with-error-handler stx (err-display-handler fn))))]
|
||||
|
||||
;TODO hack
|
||||
[_ (print "hack -- main-mod problem")]
|
||||
[main-mod (first all-used-module-paths)])
|
||||
|
||||
(parameterize ([error-display-handler (err-display-handler (format "Loading module ~a..." main-mod))])
|
||||
(require/annotations `(file ,main-mod) annotate-module? annotator))))))))
|
||||
|
|
@ -25,7 +25,6 @@
|
|||
(variable-to-bind)) ; symbol
|
||||
|
||||
(define-struct debug-client (modpath ; complete-path of the module
|
||||
modsymbol ; symbol returned from the module-name-resolver
|
||||
tracepoints ; hash-table of traces
|
||||
line-col->pos ; memoized O(n) function to map line/col -> byte offset
|
||||
process)) ; parent debug-process
|
||||
|
|
@ -79,7 +78,6 @@
|
|||
|
||||
(define (create-empty-debug-client)
|
||||
(make-debug-client null ; modpath
|
||||
null ; modsymbol
|
||||
(make-hash) ; tracepoints
|
||||
null ; line-col->pos function
|
||||
null)) ; process
|
||||
|
|
|
|||
|
|
@ -131,6 +131,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
(require (lib "match.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "marks.ss" "stepper/private")
|
||||
(prefix frp: (lib "frp.ss" "frtime"))
|
||||
"private/useful-code.ss"
|
||||
|
|
@ -171,7 +172,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ;
|
||||
; ;;;;;; ; ;;;; ;;;;;; ;;;; ; ; ; ;;;; ; ; ;;;;
|
||||
|
||||
|
||||
|
||||
;Keeps track of all debugging processes
|
||||
(define all-debug-processes null)
|
||||
|
||||
|
|
@ -199,13 +200,9 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
(define ((receive-result process) result)
|
||||
(match result
|
||||
; regular breakpoint
|
||||
[($ normal-breakpoint-info (top-mark rest-mark ...) kind)
|
||||
(print-debug "breakpoint hit")
|
||||
(void)]
|
||||
#|
|
||||
[($ normal-breakpoint-info (top-mark rest-mark ...) client)
|
||||
(let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))]
|
||||
[trace-hash (debug-file-tracepoints client)]
|
||||
[traces (hash-get trace-hash byte-offset)])
|
||||
[traces (hash-get (debug-client-tracepoints client) byte-offset)])
|
||||
|
||||
(assert (not (empty? traces))
|
||||
(format "There are no traces at offset ~a, but a breakpoint is defined!~n"
|
||||
|
|
@ -213,7 +210,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
|
||||
; Run all traces at this breakpoint
|
||||
(let ([to-send (map (lambda (t) (trace->frp-event client result t)) traces)])
|
||||
(frp:send-synchronous-events to-send)))|#
|
||||
(frp:send-synchronous-events to-send)))]
|
||||
; now, breakpoint-halt message should be sent by the debugger model
|
||||
|
||||
;TODO eventually remove this from debugger-model.ss
|
||||
|
|
@ -221,9 +218,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
; all errors and raises from the TARGET program will be caught here
|
||||
; FrTime errors from the script have their own eventstream
|
||||
(frp:send-event (debug-process-exceptions process) exn)
|
||||
(client-error (if (exn? exn)
|
||||
(format "source: ~a | exception: ~a" source (exn-message exn))
|
||||
exn))]
|
||||
(client-error (format "source: ~a | exception: ~a" source (if (exn? exn) (exn-message exn) exn)))]
|
||||
|
||||
;end of a statement
|
||||
[($ breakpoint-halt)
|
||||
|
|
@ -259,7 +254,9 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
|
||||
(define (kill-all)
|
||||
(for-each (lambda (p) (kill p)) all-debug-processes)
|
||||
(display "All debug processes have been killed."))
|
||||
(unless (empty? all-debug-processes)
|
||||
(display "All debug processes have been killed."))
|
||||
(set! all-debug-processes empty))
|
||||
|
||||
|
||||
; wrapper for errors related to the script only
|
||||
|
|
@ -356,7 +353,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
(cond
|
||||
; none is found
|
||||
[(empty? lst)
|
||||
(script-error (format "No syntax found for trace at line/column ~a:~a in ~a" line col filename))]
|
||||
(raise (format "No syntax found for trace at line/column ~a:~a in ~a" line col filename))]
|
||||
|
||||
; if first is correct line and correct column
|
||||
[(and (= line (caar lst))
|
||||
|
|
@ -385,19 +382,22 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;;
|
||||
|
||||
(define (start-debug-process process)
|
||||
(let* ([receive-result (receive-result process)]
|
||||
; connect to the debugger-model@ unit
|
||||
[run (invoke-unit debugger-model@ receive-result process)])
|
||||
(let* ([receive-result (receive-result process)])
|
||||
|
||||
; initialize the semaphore
|
||||
(set-debug-process-run-semaphore! process (make-semaphore))
|
||||
; set initial state of exit predicate
|
||||
(frp:set-cell! (debug-process-exited? process) #f)
|
||||
|
||||
; run the process
|
||||
(let ([evaluation-thread (thread (lambda () (run)))])
|
||||
(parameterize ([current-custodian (debug-process-custodian process)]
|
||||
[current-namespace (debug-process-namespace process)])
|
||||
|
||||
; connect to the debugger-model@ unit
|
||||
(define-values/invoke-unit (run) debugger-model@ #f receive-result process)
|
||||
|
||||
(thread (lambda ()
|
||||
(thread-wait evaluation-thread)
|
||||
; run the process
|
||||
(thread-wait (thread (lambda () (run))))
|
||||
; program terminates
|
||||
(kill process))))))
|
||||
|
||||
|
|
@ -453,6 +453,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
(define (create-debug-process)
|
||||
(let ([p (create-empty-debug-process)])
|
||||
(set-debug-process-runtime! p (runtime p))
|
||||
(set! all-debug-processes (cons p all-debug-processes))
|
||||
p))
|
||||
|
||||
|
||||
|
|
@ -527,9 +528,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
(and (file-exists? tst) tst)))])
|
||||
(or (try ".ss") (try ".scm") (try "") str)))]
|
||||
|
||||
[modsymbol ((current-module-name-resolver) filename #f #f)]
|
||||
|
||||
[modpath (symbol->string modsymbol)]
|
||||
[modpath (symbol->string ((current-module-name-resolver) filename #f #f))]
|
||||
[modpath (build-module-filename
|
||||
(if (regexp-match #rx"^," modpath)
|
||||
(substring modpath 1 (string-length modpath))
|
||||
|
|
@ -541,7 +540,6 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
(print-debug (format "'~a' -> '~a'" filename modpath))
|
||||
|
||||
(set-debug-client-modpath! client modpath)
|
||||
(set-debug-client-modsymbol! client modsymbol)
|
||||
(set-debug-client-process! client process)
|
||||
(set-debug-client-line-col->pos! client (line-col->pos filename))
|
||||
(set-debug-process-clients! process
|
||||
|
|
@ -552,15 +550,19 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
|
|||
|
||||
; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver)
|
||||
; (debug-client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?)
|
||||
(define (trace/bind client line col binding-symbol)
|
||||
(let ([trace-hash (debug-client-tracepoints client)]
|
||||
[trace (create-bind-trace binding-symbol)]
|
||||
[pos ((debug-client-line-col->pos client) line col)])
|
||||
; add the trace to the list of traces for that byte-offset
|
||||
(hash-put! trace-hash pos
|
||||
(cons trace
|
||||
(hash-get trace-hash pos (lambda () '()))))
|
||||
(trace-struct-evnt-rcvr trace)))
|
||||
(define-syntax trace/bind
|
||||
(syntax-rules ()
|
||||
[(_ client line col binding-symbol)
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn) (raise-syntax-error 'trace/bind exn ))])
|
||||
(let ([trace-hash (debug-client-tracepoints client)]
|
||||
[trace (create-bind-trace binding-symbol)]
|
||||
[pos ((debug-client-line-col->pos client) line col)])
|
||||
; add the trace to the list of traces for that byte-offset
|
||||
(hash-put! trace-hash pos
|
||||
(cons trace
|
||||
(hash-get trace-hash pos (lambda () '()))))
|
||||
(trace-struct-evnt-rcvr trace)))]))
|
||||
|
||||
|
||||
;(debug-file? number? number? . -> . frp:event?)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@
|
|||
(lib "class.ss" "mzlib")
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(provide load-with-annotations)
|
||||
(provide require/annotations
|
||||
load/annotate)
|
||||
|
||||
#|load-with-annotations :
|
||||
|
||||
|
|
@ -26,7 +27,7 @@
|
|||
|
||||
>annotator : (string? symbol? syntax? . -> . syntax?)
|
||||
|#
|
||||
(define (load-with-annotations initial-module annotate-module? annotator)
|
||||
(define (require/annotations initial-module annotate-module? annotator)
|
||||
(parameterize
|
||||
([current-load/use-compiled
|
||||
(let ([ocload/use-compiled (current-load/use-compiled)])
|
||||
|
|
@ -34,71 +35,71 @@
|
|||
(with-handlers
|
||||
([exn:module?
|
||||
(lambda (exn)
|
||||
(raise (format "mztake:not-a-module: file:`~a' module:`~a'" fn m)))])
|
||||
(raise (format "mztake:client:not-a-module: file:`~a' module:`~a'" fn m)))])
|
||||
|
||||
(cond [(annotate-module? fn m)
|
||||
(load/annotate annotator fn m)]
|
||||
[else
|
||||
(ocload/use-compiled fn m)]))))])
|
||||
(eval #`(require #,initial-module))))
|
||||
|
||||
(define (load/annotate annotator fn m)
|
||||
(let-values ([(base _ __) (split-path fn)]
|
||||
[(in-port src) (build-input-port fn)])
|
||||
(dynamic-wind
|
||||
(lambda () (void))
|
||||
|
||||
(lambda ()
|
||||
(parameterize ([read-accept-compiled #f]
|
||||
[current-load-relative-directory base])
|
||||
(unless m (raise 'module-name-not-passed-to-load/annotate))
|
||||
(with-module-reading-parameterization
|
||||
(lambda ()
|
||||
(let* ([first (expand (read-syntax src in-port))]
|
||||
[module-ized-exp (annotator fn m (check-module-form first m fn))]
|
||||
[second (read in-port)])
|
||||
(unless (eof-object? second)
|
||||
(raise-syntax-error
|
||||
'load/annotate
|
||||
(format "expected only a `module' declaration for `~s', but found an extra expression" m)
|
||||
second))
|
||||
(eval module-ized-exp))))))
|
||||
|
||||
(lambda () (close-input-port in-port)))))
|
||||
|
||||
|
||||
|
||||
; taken directly from mred.ss -- it's not exported...
|
||||
(define (build-input-port filename)
|
||||
(let ([p (open-input-file filename)])
|
||||
(port-count-lines! p)
|
||||
(let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p)
|
||||
(let ([t (make-object text%)])
|
||||
(send t insert-file p 'standard)
|
||||
(close-input-port p)
|
||||
(open-input-text-editor t))]
|
||||
[else p])])
|
||||
(port-count-lines! p)
|
||||
(let loop ()
|
||||
(when (with-handlers ([not-break-exn? (lambda (x) #f)])
|
||||
(regexp-match-peek "^#!" p))
|
||||
(let lloop ([prev #f])
|
||||
(let ([c (read-char-or-special p)])
|
||||
(if (or (eof-object? c)
|
||||
(eq? c #\return)
|
||||
(eq? c #\newline))
|
||||
(when (eq? prev #\\)
|
||||
(loop))
|
||||
(lloop c))))))
|
||||
(eval #`(require #,initial-module))))
|
||||
|
||||
(define (load/annotate annotator fn m)
|
||||
(let-values ([(base _ __) (split-path fn)]
|
||||
[(in-port src) (build-input-port fn)])
|
||||
(dynamic-wind
|
||||
(lambda () (void))
|
||||
|
||||
(lambda ()
|
||||
(parameterize ([read-accept-compiled #f]
|
||||
[current-load-relative-directory base])
|
||||
(unless m (raise 'module-name-not-passed-to-load/annotate))
|
||||
(with-module-reading-parameterization
|
||||
(lambda ()
|
||||
(let* ([first (expand (read-syntax src in-port))]
|
||||
[module-ized-exp (annotator fn m (check-module-form first m fn))]
|
||||
[second (read in-port)])
|
||||
(unless (eof-object? second)
|
||||
(raise-syntax-error
|
||||
'load/annotate
|
||||
(format "expected only a `module' declaration for `~s', but found an extra expression" m)
|
||||
second))
|
||||
(eval module-ized-exp))))))
|
||||
|
||||
(lambda () (close-input-port in-port)))))
|
||||
|
||||
|
||||
|
||||
; taken directly from mred.ss -- it's not exported...
|
||||
(define (build-input-port filename)
|
||||
(let ([p (open-input-file filename)])
|
||||
(port-count-lines! p)
|
||||
(let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p)
|
||||
(let ([t (make-object text%)])
|
||||
(send t insert-file p 'standard)
|
||||
(close-input-port p)
|
||||
(open-input-text-editor t))]
|
||||
[else p])])
|
||||
(port-count-lines! p)
|
||||
(let loop ()
|
||||
(when (with-handlers ([not-break-exn? (lambda (x) #f)])
|
||||
(regexp-match-peek "^#!" p))
|
||||
(let lloop ([prev #f])
|
||||
(let ([c (read-char-or-special p)])
|
||||
(if (or (eof-object? c)
|
||||
(eq? c #\return)
|
||||
(eq? c #\newline))
|
||||
(when (eq? prev #\\)
|
||||
(loop))
|
||||
(lloop c))))))
|
||||
(values p filename))))
|
||||
|
||||
|
||||
(define (test annotate-all?)
|
||||
(load-with-annotations '(lib "mztake.ss" "mztake")
|
||||
(lambda (fn m)
|
||||
(printf "~a ~a~n" fn m)
|
||||
annotate-all?)
|
||||
(lambda (fn m stx) stx)))
|
||||
(require/annotations '(lib "mztake.ss" "mztake")
|
||||
(lambda (fn m)
|
||||
(printf "~a ~a~n" fn m)
|
||||
annotate-all?)
|
||||
(lambda (fn m stx) stx)))
|
||||
;(test #t) ; slow
|
||||
;(test #f) ; fast
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user