suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Changed unstable/debug to use error printing instead of logger output.

Browse Source
This commit is contained in:
Carl Eastlund 2010-06-01 00:09:36 -04:00
parent ddc889532e
commit a915d7c053
3 changed files with 98 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/tests/unstable/debug.rkt
View File

@ -7,15 +7,8 @@
(test-suite "dprintf"
(test
(let ()
(define logger (make-logger))
(define receiver (make-log-receiver logger 'debug))
(parameterize ([current-logger logger])
(dprintf "Danger, ~a!" "Will Robinson"))
(check-not-false
(member
"Danger, Will Robinson!"
(let loop ()
(match (sync/timeout 0 receiver)
[(vector 'debug (? string? message) _)
(cons message (loop))]
[_ null])))))))))
(parameterize ([current-error-port (open-output-string)])
(dprintf "Danger, ~a!" "Will Robinson")
(check-equal?
(get-output-string (current-error-port))
"Danger, Will Robinson!\n")))))))

112
collects/unstable/debug.rkt
View File

@ -17,10 +17,11 @@
letrec-values/debug
with-syntax/debug
with-syntax*/debug
parameterize/debug
with-debugging)
parameterize/debug)
(require unstable/srcloc
(require racket/block
unstable/pretty
unstable/srcloc
unstable/location
unstable/syntax
(for-syntax racket/match syntax/parse unstable/syntax))
@ -28,11 +29,11 @@
(define-syntax (let/debug stx)
(syntax-parse stx
[(_ (~optional loop:id) ([lhs:id rhs:expr] ...) body:expr ...+)
#`(with-debugging
#`(debug
#:name '#,(if (attribute loop) #'loop #'let/debug)
#:source (quote-srcloc #,stx)
(let #,@(if (attribute loop) (list #'loop) null)
([lhs (with-debugging #:name 'lhs rhs)] ...)
([lhs (debug #:name 'lhs rhs)] ...)
(debug body) ...))]))
(define-syntaxes
@ -51,11 +52,11 @@
(with-syntax ([binder binder-id])
(syntax-parse stx
[(binder/debug:id ([lhs rhs:expr] ...) body:expr ...+)
#`(with-debugging
#`(debug
#:name 'binder/debug
#:source (quote-srcloc #,stx)
(binder
([lhs (with-debugging #:name 'lhs rhs)] ...)
([lhs (debug #:name 'lhs rhs)] ...)
(debug body) ...))])))
(values (expander #'let*)
@ -86,13 +87,13 @@
(syntax-parse stx
[(definer/debug:id name:id body:expr)
#`(definer name
(with-debugging
(debug
#:name 'name
#:source (quote-srcloc #,stx)
body))]
[(definer/debug:id spec:header body:expr ...+)
#`(definer spec
(with-debugging
(debug
#:name 'spec.name
#:source (quote-srcloc #,stx)
(let () body ...)))])))
@ -106,31 +107,28 @@
(define-syntax (begin/debug stx)
(syntax-parse stx
[(_ term:expr ...)
#`(with-debugging
#`(debug
#:name 'begin/debug
#:source (quote-srcloc #,stx)
(begin (debug term) ...))]))
(define-syntax (debug stx)
(syntax-parse stx
[(_ term:expr)
(syntax (with-debugging term))]))
(define-syntax (call/debug stx)
(define-splicing-syntax-class argument
#:attributes ([debug 1])
(pattern arg:expr #:attr [debug 1] #'[(debug arg)])
(pattern (~seq kw:keyword arg:expr) #:attr [debug 1] #'[kw (debug arg)]))
#:attributes ([debugged 1])
(pattern arg:expr
#:attr [debugged 1] (list #'(debug arg)))
(pattern (~seq kw:keyword arg:expr)
#:attr [debugged 1] (list #'kw #'(debug arg))))
(syntax-parse stx
[(_ f:expr arg:argument ...)
#`(with-debugging
#`(debug
#:name 'call/debug
#:source (quote-srcloc #,stx)
(#%app (debug f) arg.debug ... ...))]))
(#%app (debug f) arg.debugged ... ...))]))
(define-syntax (with-debugging stx)
(define-syntax (debug stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:name name:expr))
(~optional (~seq #:source source:expr)))
@ -138,39 +136,59 @@
body:expr)
(with-syntax* ([name (or (attribute name) #'(quote body))]
[source (or (attribute source) #'(quote-srcloc body))])
#'(with-debugging/proc
#'(debug/proc
name
source
(quote body)
(lambda () (#%expression body))))]))
(define (with-debugging/proc name source term thunk)
(let* ([src (source-location->prefix source)])
(begin
(dprintf ">> ~a~s" src name)
(begin0
(parameterize ([current-debug-depth
(add1 (current-debug-depth))])
(define (debug/proc name source thunk)
(define src (source-location->prefix source))
(define (err e)
(if (exn? e)
(dprintf "raised exception: ~a" (exn-message e))
(dprintf "raised non-exception: ~a" (pretty-format/print e)))
(raise e))
(define depth (current-debug-depth))
(dynamic-wind
(lambda ()
(parameterize ([current-debug-depth depth])
(dprintf ">> ~a~a" src (pretty-format/write name 'infinity))))
(lambda ()
(parameterize ([current-debug-depth (add1 depth)])
(with-handlers ([exn:fail? err])
(call-with-values thunk
(lambda results
(match results
[(list v) (dprintf "~s" v)]
[(list vs ...)
(dprintf "(values~a)"
(apply string-append
(for/list ([v (in-list vs)])
(format " ~s" v))))])
(apply values results))))
(dprintf "<< ~a~s" src name)))))
(match-lambda*
[(list v)
(dprintf "result: ~a"
(pretty-format/print v 'infinity))
v]
[(list vs ...)
(dprintf "results: (values~a)"
(apply string-append
(for/list ([v (in-list vs)])
(string-append " " (pretty-format/print v 'infinity)))))
(apply values vs)])))))
(lambda ()
(parameterize ([current-debug-depth depth])
(dprintf "<< ~a~a" src (pretty-format/write name 'infinity))))))
(define (dprintf fmt . args)
(let* ([message (apply format fmt args)]
[prefix (make-string (* debug-indent (current-debug-depth)) #\space)]
[indented
(string-append
prefix
(regexp-replace* "\n" message (string-append "\n" prefix)))])
(log-debug indented)))
(define message (apply format fmt args))
(define terminated
(if (regexp-match? "\n$" message) message (string-append message "\n")))
(define prefix
(make-string (* debug-indent (current-debug-depth)) #\space))
(define indented
(regexp-replace* "(?m:.+)" terminated (string-append prefix "&")))
(write-string indented (current-error-port))
(void))
(define current-debug-depth (make-parameter 0))
(define debug-indent 2)

42
collects/unstable/scribblings/debug.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/manual
@(require "utils.rkt" (for-label racket unstable/debug unstable/syntax))
@(require scribble/eval "utils.rkt"
(for-label racket unstable/debug unstable/syntax))
@title{Debugging}
@ -10,28 +11,37 @@
This module provides macros and functions for printing out debugging
information.
@defform[(debug expr)]{
Logs debugging information before and after the evaluation of expression
@scheme[expr].
}
@defform/subs[
(with-debugging options ... expr)
(debug options ... expr)
([options (code:line #:name name-expr)
(code:line #:source srcloc-expr)])
]{
Logs debugging information like @scheme[debug], with the option of explicitly
overriding the name and source location information for the expression.
Writes debugging information about the evaluation of @scheme[expr] to the
current error port. The name and source location of the expression may be
overridden by keyword options; their defaults are the syntactic form of the
expression and its syntactic source location, respectively.
@examples[#:eval (eval/require 'unstable/debug)
(debug 0)
(debug #:name "one, two, three" (values 1 2 3))
(debug #:source (make-srcloc 'here 1 2 3 4)
(error 'function "something went wrong"))
]
}
@defproc[(dprintf [fmt string?] [arg any/c] ...) void?]{
Constructs a message in the same manner as @scheme[format], and logs it at the
debugging priority (like @scheme[log-debug]).
Constructs a message in the same manner as @scheme[format] and writes it to
@scheme[(current-error-port)], with indentation reflecting the number of nested
@scheme[debug] forms.
@examples[#:eval (eval/require 'unstable/debug)
(dprintf "level: ~a" 0)
(debug (dprintf "level: ~a" 1))
(debug (debug (dprintf "level: ~a" 2)))
]
}
@ -43,6 +53,10 @@ debugging priority (like @scheme[log-debug]).
Logs debugging information for @scheme[(#%app function-expr argument ...)],
including the evaluation and results of the function and each argument.
@examples[#:eval (eval/require 'unstable/debug)
(call/debug + 1 2 3)
]
}
@deftogether[(
@ -69,7 +83,7 @@ including the evaluation and results of the function and each argument.
@defform[(parameterize/debug ([param-expr value-expr] ...) body ...+)]
)]{
These macros add logging based on @scheme[with-debugging] to the evaluation of
These macros add logging based on @scheme[debug] to the evaluation of
expressions in @scheme[begin], @scheme[define], @scheme[define/private],
@scheme[define/public], @scheme[define/override], @scheme[define/augment],
@scheme[let], @scheme[let*], @scheme[letrec], @scheme[let-values],