Skip to content

Commit

Permalink
profile: fix destination for annotated files
Browse files Browse the repository at this point in the history 
If a source file does (include "../../aux/file.ss"), then swish-test
could end up trying to write an annotated file.ss.html outside the
target directory containing the specified coverage summary report.

To fix this we determine a common prefix based on the real paths of the
profiled source files and use the distinct suffix as the path within the
target directory.

The appearance of the coverage report changes slightly since we:
 - sort entries based on the real path of the file,
 - use natural-string<? for this sort, and
 - strip the common prefix from filenames.

 The result is often more concise than the original and helps to avoid
 broken hyperlinks in the summary report.
  • Loading branch information
@owaddell-beckman
owaddell-beckman committed Dec 21, 2023
1 parent 0af77e2 commit 8489697
Show file tree
Hide file tree
Showing 2 changed files with 46 additions and 19 deletions.
38 changes: 32 additions & 6 deletions src/swish/profile.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -345,15 +345,40 @@
inputs))
(let-values ([(keys vals) (hashtable-entries table)])
(vector->list
(vector-sort (lambda (a b) (string<? (car a) (car b)))
(vector-map (lambda (k v) (cons (sfd-source-path k values) v))
keys vals)))))
(vector-sort (lambda (a b) (natural-string<? (car a) (car b)))
(vector-map
(lambda (sfd v)
(match (sfd-sig sfd)
[(,checksum . ,source-path) (cons source-path v)]))
keys vals)))))
(unless (list-of-strings? inputs) (bad-arg 'profile:dump-html profile-in))
(unless (string? output-fn) (bad-arg 'profile:dump-html output-fn))
(unless (list-of-strings? include-globs) (bad-arg 'profile:dump-html include-globs))
(unless (list-of-strings? exclude-globs) (bad-arg 'profile:dump-html exclude-globs))
(let ([results (load-profiles)]
[op (open-file-to-replace (make-directory-path output-fn))])
(define common-prefix
(fold-left
(lambda (pfx entry)
(match entry
[(,source-path . #f) pfx] ;; file skipped
[(,source-path . ,_) ;; absolute path if not skipped
(let ([dir (path-parent source-path)])
(let loop ([pfx (or pfx dir)])
(if (starts-with? dir pfx)
pfx
(loop (path-parent pfx)))))]))
#f
results))
(define strip-prefix
(if (not common-prefix)
values
(let* ([prefix-length (string-length common-prefix)]
[n (if (ends-with? common-prefix (string (directory-separator)))
prefix-length
(+ prefix-length 1))])
(lambda (src)
(substring src n (string-length src))))))
(fprintf op "<!DOCTYPE html>\n")
(fprintf op "<html lang=\"en\">\n")
(html->string op
Expand All @@ -376,14 +401,15 @@
(let ([root (path-parent (get-real-path output-fn))])
(for-each
(lambda (entry)
;; entry = (sfd . skiplist | #f)
;; entry = (source-path . skiplist | #f)
(match entry
[(,name . ,sl)
[(,source-path . ,sl)
(match (and sl (sl))
[,data
(guard (pair? data))
;; non-blocking i/o OK: profile:dump-html runs from dedicated OS process, not interested in concurrency
(let* ([ip (open-input-file name)]
(let* ([ip (open-input-file source-path)]
[name (strip-prefix source-path)]
[file-op (open-file-to-replace (make-directory-path (path-combine root (string-append name ".html"))))])
(on-exit (close-port file-op)
(annotate (pregexp-replace* "\\\\" name "/") ip data op file-op)))]
Expand Down
27 changes: 14 additions & 13 deletions src/swish/swish-test.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1418,8 +1418,9 @@
e0 e1 ...))]))

(isolate-mat profile ()
(define src-file "profile-code.ss")
(define source-file
(write-test-file "profile-code.ss"
(write-test-file src-file
(lambda ()
(display "#!chezscheme\n")
(display "(define (fac n)\n")
Expand Down Expand Up @@ -1472,8 +1473,8 @@
([#t (file-regular? coverage-file)]
[,cov (utf8->string (read-file coverage-file))]
[(,_) (pregexp-match "Overall 74% coverage with 17 of 23 sites covered" cov)]
[(,_) (pregexp-match (summary-row source-file-rel 17 23 74 12) cov)]
[,ss.html (path-combine (path-parent coverage-file) (string-append source-file-rel ".html"))]
[(,_) (pregexp-match (summary-row src-file 17 23 74 12) cov)]
[,ss.html (path-combine (path-parent coverage-file) (string-append src-file ".html"))]
[#t (file-regular? ss.html)]
[,ss (utf8->string (read-file ss.html))]
[(,_) (check-count 2 "1" ss)] ;; base case
Expand All @@ -1491,8 +1492,8 @@
([#t (file-regular? coverage1-file)]
[,cov1 (utf8->string (read-file coverage1-file))]
[(,_) (pregexp-match "Overall 45% coverage with 18 of 40 sites covered" cov1)]
[(,_) (pregexp-match (summary-row source-file-rel 18 40 45 1) cov1)]
[,ss.html (path-combine (path-parent coverage1-file) (string-append source-file-rel ".html"))]
[(,_) (pregexp-match (summary-row src-file 18 40 45 1) cov1)]
[,ss.html (path-combine (path-parent coverage1-file) (string-append src-file ".html"))]
[#t (file-regular? ss.html)]
[,ss (utf8->string (read-file ss.html))]
[(,_) (check-count 1 "1" ss)] ;; base case
Expand All @@ -1519,8 +1520,8 @@
([#t (file-regular? coverage1-file)]
[,cov1 (utf8->string (read-file coverage1-file))]
[(,_) (pregexp-match "Overall 70% coverage with 28 of 40 sites covered" cov1)]
[(,_) (pregexp-match (summary-row source-file-rel 28 40 70 6) cov1)]
[,ss.html (path-combine (path-parent coverage1-file) (string-append source-file-rel ".html"))]
[(,_) (pregexp-match (summary-row src-file 28 40 70 6) cov1)]
[,ss.html (path-combine (path-parent coverage1-file) (string-append src-file ".html"))]
[#t (file-regular? ss.html)]
[,ss (utf8->string (read-file ss.html))]
[(,_) (check-count 1 "1" ss)] ;; base case
Expand All @@ -1540,8 +1541,8 @@
([#t (file-regular? coverage1-file)]
[,cov1 (utf8->string (read-file coverage1-file))]
[(,_) (pregexp-match "Overall 85% coverage with 34 of 40 sites covered" cov1)]
[(,_) (pregexp-match (summary-row source-file-rel 34 40 85 7) cov1)]
[,ss.html (path-combine (path-parent coverage1-file) (string-append source-file-rel ".html"))]
[(,_) (pregexp-match (summary-row src-file 34 40 85 7) cov1)]
[,ss.html (path-combine (path-parent coverage1-file) (string-append src-file ".html"))]
[#t (file-regular? ss.html)]
[,ss (utf8->string (read-file ss.html))]
[(,_) (check-count 2 "1" ss)] ;; base case
Expand Down Expand Up @@ -1575,8 +1576,8 @@
([#t (file-regular? coverage-file)]
[,cov (utf8->string (read-file coverage-file))]
[(,_) (pregexp-match "Overall 85% coverage with 34 of 40 sites covered" cov)]
[(,_) (pregexp-match (summary-row source-file-rel 34 40 85 31) cov)]
[,ss.html (path-combine (path-parent coverage-file) (string-append source-file-rel ".html"))]
[(,_) (pregexp-match (summary-row src-file 34 40 85 31) cov)]
[,ss.html (path-combine (path-parent coverage-file) (string-append src-file ".html"))]
[#t (file-regular? ss.html)]
[,ss (utf8->string (read-file ss.html))]
[(,_) (check-count (+ (* 2 2) 2) "1" ss)] ;; base case
Expand All @@ -1597,8 +1598,8 @@
([#t (file-regular? coverage-file)]
[,cov (utf8->string (read-file coverage-file))]
[(,_) (pregexp-match "Overall 85% coverage with 34 of 40 sites covered" cov)]
[(,_) (pregexp-match (summary-row source-file-rel 34 40 85 (+ 31 7)) cov)]
[,ss.html (path-combine (path-parent coverage-file) (string-append source-file-rel ".html"))]
[(,_) (pregexp-match (summary-row src-file 34 40 85 (+ 31 7)) cov)]
[,ss.html (path-combine (path-parent coverage-file) (string-append src-file ".html"))]
[#t (file-regular? ss.html)]
[,ss (utf8->string (read-file ss.html))]
[(,_) (check-count (+ (* 2 2) (* 2 2)) "1" ss)] ;; base case
Expand Down

0 comments on commit 8489697

Please sign in to comment.