Update all my elpa files
This commit is contained in:
Mateus Pinto Rodrigues
229
elpa/racket-mode-20180401.1803/instrument.rkt
Normal file
229
elpa/racket-mode-20180401.1803/instrument.rkt
Normal file
@@ -0,0 +1,229 @@
|
||||
#lang at-exp racket/base
|
||||
|
||||
(require (only-in errortrace/errortrace-key
|
||||
errortrace-key)
|
||||
(only-in errortrace/errortrace-lib
|
||||
print-error-trace
|
||||
error-context-display-depth)
|
||||
(only-in errortrace/stacktrace
|
||||
stacktrace^
|
||||
stacktrace@
|
||||
stacktrace-imports^)
|
||||
racket/format
|
||||
racket/match
|
||||
racket/unit
|
||||
syntax/parse
|
||||
"util.rkt")
|
||||
|
||||
(provide make-instrumented-eval-handler
|
||||
error-context-display-depth
|
||||
print-error-trace
|
||||
instrumenting-enabled
|
||||
test-coverage-enabled
|
||||
clear-test-coverage-info!
|
||||
get-test-coverage-info
|
||||
profiling-enabled
|
||||
clear-profile-info!
|
||||
get-profile-info)
|
||||
|
||||
;;; Core instrumenting
|
||||
|
||||
(define instrumenting-enabled (make-parameter #f))
|
||||
|
||||
;; These two parameters added to errortrace/stacktrace circa 6.0. They
|
||||
;; help make-st-mark capture the original, unexpanded syntax, which is
|
||||
;; nicer to report in a stack trace. Lacking that in older Rackets,
|
||||
;; the srcloc is still correct and Emacs next-error will work.
|
||||
(define original-stx (with-handlers ([exn:fail? (λ _ (make-parameter #f))])
|
||||
(dynamic-require 'errortrace/stacktrace 'original-stx)))
|
||||
(define expanded-stx (with-handlers ([exn:fail? (λ _ (make-parameter #f))])
|
||||
(dynamic-require 'errortrace/stacktrace 'expanded-stx)))
|
||||
|
||||
(define ((make-instrumented-eval-handler orig-eval) orig-exp)
|
||||
;; This is modeled after the one in DrRacket.
|
||||
(cond
|
||||
[(or (not (instrumenting-enabled))
|
||||
(compiled-expression? (if (syntax? orig-exp)
|
||||
(syntax-e orig-exp)
|
||||
orig-exp)))
|
||||
(orig-eval orig-exp)]
|
||||
[else
|
||||
(let loop ([exp (if (syntax? orig-exp)
|
||||
orig-exp
|
||||
(namespace-syntax-introduce (datum->syntax #f orig-exp)))])
|
||||
(let ([top-e (expand-syntax-to-top-form exp)])
|
||||
(syntax-case top-e (begin)
|
||||
[(begin expr ...)
|
||||
;; Found a `begin', so expand/eval each contained
|
||||
;; expression one at a time
|
||||
(let i-loop ([exprs (syntax->list #'(expr ...))]
|
||||
[last-one (list (void))])
|
||||
(cond
|
||||
[(null? exprs)
|
||||
(apply values last-one)]
|
||||
[else
|
||||
(i-loop (cdr exprs)
|
||||
(call-with-values
|
||||
(λ ()
|
||||
(call-with-continuation-prompt
|
||||
(λ () (loop (car exprs)))
|
||||
(default-continuation-prompt-tag)
|
||||
(λ args
|
||||
(apply
|
||||
abort-current-continuation
|
||||
(default-continuation-prompt-tag)
|
||||
args))))
|
||||
list))]))]
|
||||
[_else
|
||||
;; Not `begin', so proceed with normal expand and eval
|
||||
(let* ([expanded-e (expand-syntax top-e)]
|
||||
;; For make-st-mark to work correctly we need to
|
||||
;; parameterize original-stx and expanded-stx.
|
||||
[annotated (parameterize ([original-stx top-e]
|
||||
[expanded-stx expanded-e])
|
||||
(annotate-top expanded-e
|
||||
(namespace-base-phase)))])
|
||||
(warn-about-time-apply expanded-e)
|
||||
(orig-eval annotated))])))]))
|
||||
|
||||
(define (warn-about-time-apply stx)
|
||||
(syntax-parse stx
|
||||
#:datum-literals (#%app time-apply)
|
||||
[(#%app time-apply . _)
|
||||
(display-commented
|
||||
@~a{Warning: time or time-apply used in errortrace annotated code.
|
||||
For meaningful timings, use command-line racket instead!})
|
||||
#t]
|
||||
[(ss ...) (for/or ([stx (in-list (syntax->list #'(ss ...)))])
|
||||
(warn-about-time-apply stx))]
|
||||
[_ #f]))
|
||||
|
||||
|
||||
;;; Better stack traces ("basic errortrace")
|
||||
|
||||
(define base-phase
|
||||
(variable-reference->module-base-phase (#%variable-reference)))
|
||||
|
||||
(define (with-mark mark expr phase)
|
||||
;; This is modeled after the one in errortrace-lib. Specifically,
|
||||
;; use `make-st-mark' for its capture of the original syntax to show
|
||||
;; in the stack trace error message.
|
||||
(match (make-st-mark mark phase)
|
||||
[#f expr]
|
||||
[loc (define phase-shift (- phase base-phase))
|
||||
(with-syntax ([expr expr]
|
||||
[loc loc]
|
||||
[errortrace-key errortrace-key]
|
||||
[qte (syntax-shift-phase-level #'quote phase-shift)]
|
||||
[wcm (syntax-shift-phase-level #'with-continuation-mark
|
||||
phase-shift)])
|
||||
(syntax (wcm (qte errortrace-key)
|
||||
loc
|
||||
expr)))]))
|
||||
|
||||
;; print-error-trace
|
||||
;;
|
||||
;; Just re-provide the one from errortrace-lib because (a) it works
|
||||
;; and (b) the `make-st-mark' representation is intentionally not
|
||||
;; documented.
|
||||
|
||||
|
||||
;;; Test coverage
|
||||
|
||||
(define test-coverage-enabled (make-parameter #f)) ;stacktrace-imports^
|
||||
|
||||
(define test-coverage-info (make-hasheq)) ;(hash/c syntax? mpair?).
|
||||
;; This approach taken from DrR. Presumably set-mcar! is faster than a
|
||||
;; box, which in turn is faster than hash-set!. The cdr cell is
|
||||
;; ignored.
|
||||
|
||||
(define (clear-test-coverage-info!)
|
||||
(hash-clear! test-coverage-info))
|
||||
|
||||
(define (initialize-test-coverage-point expr) ;stacktrace-imports^
|
||||
(hash-set! test-coverage-info expr (mcons #f #f)))
|
||||
|
||||
(define (test-covered expr) ;stacktrace-imports^
|
||||
(define v (hash-ref test-coverage-info expr #f))
|
||||
(and v (with-syntax ([v v])
|
||||
#'(#%plain-app set-mcar! v #t))))
|
||||
|
||||
(define (get-test-coverage-info)
|
||||
;; Due to macro expansion (e.g. to an `if` form), there may be
|
||||
;; multiple data points for the exact same source location. We want
|
||||
;; to logically OR them: If any are true, the source location is
|
||||
;; covered.
|
||||
(define ht (make-hash)) ;; (list src pos span) => cover?
|
||||
(for* ([(stx v) (in-hash test-coverage-info)]
|
||||
[cover? (in-value (mcar v))]
|
||||
[loc (in-value (list (syntax-source stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))])
|
||||
(match (hash-ref ht loc 'none)
|
||||
['none (hash-set! ht loc cover?)]
|
||||
[#f (when cover? (hash-set! ht loc #t))]
|
||||
[#t (void)]))
|
||||
(for/list ([(loc cover?) (in-hash ht)])
|
||||
(cons cover? loc)))
|
||||
|
||||
;;; Profiling
|
||||
|
||||
(define profile-key (gensym)) ;stacktrace-imports^
|
||||
|
||||
(define profiling-enabled (make-parameter #f)) ;stacktrace-imports^
|
||||
|
||||
(define profile-info (make-hasheq)) ;(hash/c any/c prof?)
|
||||
|
||||
|
||||
(define (clear-profile-info!)
|
||||
(hash-clear! profile-info))
|
||||
|
||||
(struct prof
|
||||
(nest? ;guard nested calls
|
||||
num ;exact-nonnegative-integer?
|
||||
time ;exact-nonnegative-integer?
|
||||
name ;(or/c #f symbol?)
|
||||
expr) ;syntax?
|
||||
#:mutable
|
||||
#:transparent)
|
||||
|
||||
(define (initialize-profile-point key name expr) ;stacktrace-imports^
|
||||
(hash-set! profile-info
|
||||
key
|
||||
(prof #f 0 0 (and (syntax? name) (syntax-e name)) expr)))
|
||||
|
||||
(define (register-profile-start key) ;stacktrace-imports^
|
||||
(define p (hash-ref profile-info key))
|
||||
(set-prof-num! p (add1 (prof-num p)))
|
||||
(cond [(prof-nest? p) #f]
|
||||
[else (set-prof-nest?! p #t)
|
||||
(current-process-milliseconds)]))
|
||||
|
||||
(define (register-profile-done key start) ;stacktrace-imports^
|
||||
(void
|
||||
(when start
|
||||
(define p (hash-ref profile-info key))
|
||||
(set-prof-nest?! p #f)
|
||||
(set-prof-time! p (+ (- (current-process-milliseconds) start)
|
||||
(prof-time p))))))
|
||||
|
||||
(define (get-profile-info)
|
||||
(for/list ([x (in-list (hash-values profile-info))])
|
||||
(match-define (prof nest? count msec name stx) x)
|
||||
(list count msec name stx)))
|
||||
|
||||
|
||||
;;; Finally, invoke the unit
|
||||
(define-values/invoke-unit/infer stacktrace@)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; example
|
||||
|
||||
;; (parameterize ([instrumenting-enabled #t]
|
||||
;; [test-coverage-enabled #t]
|
||||
;; [profiling-enabled #f]
|
||||
;; [current-eval (make-instrumented-eval-handler (current-eval))])
|
||||
;; (namespace-require (string->path "/tmp/simple.rkt")))
|
||||
;; (get-test-coverage-info)
|
||||
;; (get-profile-info)
|
||||
Reference in New Issue
Block a user