what DrRacket is doing to get test coverage in #lang

drr-test-coverage.rkt

#lang racket

(require errortrace/stacktrace racket/unit racket/gui/base
         drracket/private/drracket-errortrace-key)
(define key-module-name 'drracket/private/drracket-errortrace-key)

(define (should-annotate? s phase)
  (and (syntax-source s)
       (syntax-property s 'errortrace:annotate)))

;; make-with-mark : (any/c -> any/c) -> mark-stx syntax natural -> syntax
;; the result of the first application should be bound to `with-mark`,
;; a member of stacktrace-imports^
(define (with-mark src-stx expr phase)
  (cond
    [(should-annotate? expr phase)
     (define source
       (cond
         [(path? (syntax-source src-stx))
          (syntax-source src-stx)]
         [else #f]))
     (define position (or (syntax-position src-stx) 0))
     (define span (or (syntax-span src-stx) 0))
     (define line (or (syntax-line src-stx) 0))
     (define column (or (syntax-column src-stx) 0))
     (with-syntax ([expr expr]
                   [mark (vector source line column position span)]
                   [et-key (syntax-shift-phase-level #'drracket-errortrace-key phase)]
                   [wcm (syntax-shift-phase-level #'with-continuation-mark phase)]
                   [qte (syntax-shift-phase-level #'quote phase)])
       (syntax
        (wcm et-key
             (qte mark)
             expr)))]
    [else expr]))

(define test-coverage-enabled (make-parameter #t))
  
(define current-test-coverage-info (make-thread-cell #f))

(define (test-coverage-point body expr phase)
  (cond
    [(and (test-coverage-enabled)
          (zero? phase)
          (should-annotate? expr phase))
     ;; initialize the hash holding test coverage results
     (unless (hash? (thread-cell-ref current-test-coverage-info))
       (define ut (eventspace-handler-thread (current-eventspace)))
       (when (eq? ut (current-thread))
         (define ht (make-hasheq))
         (thread-cell-set! current-test-coverage-info ht)))
     (define ht (thread-cell-ref current-test-coverage-info))
     (cond
       [(hash? ht) ;; the initialization may have failed, give up in that case
        (define v (mcons #f #f))
        (hash-set! ht expr v) ;; record as point that might get executed
        (define update-coverage #`(#%plain-app set-mcar! #,v #t))
        (syntax-case expr (#%plain-module-begin)
          [(_mod _name _init-import (#%plain-module-begin . _body))
           (drop-in-sequence body '(tl tl tl hd tl) update-coverage)]
          [_else
           #`(begin #,update-coverage #,body)])]
       [else body])]
    [else body]))

(define (drop-in-sequence stx path to-add)
  (let loop ([stx stx]
             [path path])
    (cond
      [(null? path)
       (cons to-add stx)]
      [(syntax? stx)
       (define dstx (disarm stx))
       (syntax-rearm
        (datum->syntax
         dstx
         (loop (syntax-e dstx) path)
         dstx
         dstx)
        stx)]
      [(pair? stx)
       (case (car path)
         [(hd) (cons (loop (car stx) (cdr path)) (cdr stx))]
         [(tl) (cons (car stx) (loop (cdr stx) (cdr path)))])])))

(define drracket:init:system-inspector (current-inspector))

(define (disarm orig) (syntax-disarm orig drracket:init:system-inspector))

(define profile-key (gensym))
(define profiling-enabled (make-parameter #f))
(define (initialize-profile-point key name expr) (void))
(define (register-profile-start key) (void))
(define (register-profile-done key start) (void))

(define-values/invoke-unit/infer stacktrace/errortrace-annotate/key-module-name@)

(define the-program
  "#lang racket (require (prefix-in t: lang/private/teach)) (t:beginner-define-struct S (pred))"
  ;"#lang htdp/bsl (define-struct S (pred)) (check-expect (S-pred (make-S #t)) #t)"
  )
(when (regexp-match #rx"[\n\r]" the-program)
  (error 'no-newlines-please))

(define input
  (open-input-string
   (string-append
    the-program)))

(define ns (make-base-namespace))

(define the-made-up-filename "x.rkt")

(port-count-lines! input)
(define unexpanded
  (parameterize ([read-accept-reader #t])
    (read-syntax the-made-up-filename input)))
(parameterize ([current-namespace ns]
               [current-module-declare-name (make-resolved-module-path 'x)])
  (namespace-require key-module-name)
  (eval
   (errortrace-annotate
    (namespace-syntax-introduce unexpanded)))
  (namespace-require ''x)
  (when (module-declared? `(submod 'x test))
    (namespace-require `(submod 'x test))))

(define can-annotate
  (let ([ht (thread-cell-ref current-test-coverage-info)])
    (filter values
            (hash-map ht
                      (λ (stx covered?)
                        (and (syntax? stx)
                             (let ([src (syntax-source stx)]
                                   [pos (syntax-position stx)]
                                   [span (syntax-span stx)])
                               (and pos
                                    span
                                    src
                                    (list (mcar covered?)
                                          (make-srcloc src #f #f pos span))))))))))

(define filtered
  (let (;; actions-ht : (list src number number) -> (list boolean syntax)
        [actions-ht (make-hash)])
    (for-each
     (λ (pr)
       (let* ([on? (list-ref pr 0)]
              [key (list-ref pr 1)]
              [old (hash-ref actions-ht key 'nothing)])
         (cond
           [(eq? old 'nothing) (hash-set! actions-ht key on?)]
           [old ;; recorded as executed
            (void)]
           [(not old) ;; recorded as unexected
            (when on?
              (hash-set! actions-ht key #t))])))
     can-annotate)
    (hash-map actions-ht (λ (k v) (list v k)))))

(define sorted
  (sort
   filtered
   (λ (x y)
     (let* ([x-on (list-ref x 0)]
            [y-on (list-ref y 0)]
            [x-srcloc (list-ref x 1)]
            [y-srcloc (list-ref y 1)]
            [x-pos (srcloc-position x-srcloc)]
            [y-pos (srcloc-position y-srcloc)]
            [x-span (srcloc-span x-srcloc)]
            [y-span (srcloc-span y-srcloc)])
       (cond
         [(and (= x-pos y-pos)
               (= x-span x-span))
          (or y-on
              (not x-on))]
         [else (>= x-span y-span)])))))

(define biggest
  (for/fold ([biggest 0])
            ([on+srcloc (in-list sorted)]
             #:when (equal? (srcloc-source (list-ref on+srcloc 1)) the-made-up-filename))
    (max biggest
         (+ (srcloc-position (list-ref on+srcloc 1))
            (srcloc-span (list-ref on+srcloc 1))))))

(define coverage (make-string biggest #\space))
(for ([on+srcloc (in-list sorted)])
  (define srcloc (list-ref on+srcloc 1))
  (define on? (list-ref on+srcloc 0))
  (when (equal? the-made-up-filename (srcloc-source srcloc))
    (for ([i (in-range (srcloc-span srcloc))])
      (define p (+ -1 i (srcloc-position srcloc)))
      (string-set! coverage p (if on? #\. #\!)))))

(display the-program)
(newline)
(display coverage)
(newline)