diff options
| -rw-r--r-- | scripts/all-modules.scm | 33 | ||||
| -rwxr-xr-x | scripts/use2dot/gen-use.scm | 32 | ||||
| -rwxr-xr-x | tests/run-tests.scm | 36 |
3 files changed, 70 insertions, 31 deletions
diff --git a/scripts/all-modules.scm b/scripts/all-modules.scm new file mode 100644 index 00000000..41f35393 --- /dev/null +++ b/scripts/all-modules.scm @@ -0,0 +1,33 @@ +(define-module (all-modules) + :use-module (ice-9 regex) + :use-module (srfi srfi-1) + :use-module (ice-9 ftw) + :use-module (ice-9 match) + :export (all-modules-under-directory)) + +(define (all-modules-under-directory dir) + "Returns two values, all scm files in dir, and all top +level modules in those files" + + (define re (make-regexp "\\.scm$")) + + (define files '()) + + (ftw dir (lambda (filename statinfo flag) + (cond ((and (eq? flag 'regular) + (regexp-exec re filename)) + => (lambda (m) + (set! files (cons filename files)) + #t + )) + (else #t)))) + + + (values files + (filter identity + (map (lambda (file) + (match (call-with-input-file file read) + (('define-module (module ...) _ ...) + module) + (_ #f))) + files)))) diff --git a/scripts/use2dot/gen-use.scm b/scripts/use2dot/gen-use.scm index e02be9bd..6c621fdd 100755 --- a/scripts/use2dot/gen-use.scm +++ b/scripts/use2dot/gen-use.scm @@ -2,43 +2,19 @@ !# (add-to-load-path (dirname (current-filename))) +(add-to-load-path (dirname (dirname (current-filename)))) (use-modules ((scripts frisk) :select (make-frisker edge-type edge-up edge-down)) (srfi srfi-1) - (ice-9 ftw) - (ice-9 regex) - (ice-9 match) ((graphviz) :prefix gv.) + (all-modules) ) (define scan (make-frisker `(default-module . (calp main)))) -(define re (make-regexp "\\.scm$")) - -(define lst '()) - -(ftw "module" (lambda (filename statinfo flag) - (cond ((and (eq? flag 'regular) - (regexp-exec re filename)) - => (lambda (m) - (set! lst (cons filename lst)) - #t - )) - (else #t)))) - - - -(define files lst) - -(define our-modules - (filter identity - (map (lambda (file) - (match (call-with-input-file file read) - (('define-module (module ...) _ ...) - module) - (_ #f))) - files))) +(define-values (files our-modules) + (all-modules-under-directory "module")) (define graph (gv.digraph "G")) (gv.setv graph "color" "blue") diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 43f3ccf8..ee0b596e 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -118,7 +118,8 @@ exec $GUILE --debug -s "$0" "$@" ((hnh util) :select (for awhen)) ;; datetime introduces the reader extensions for datetimes, ;; which leaks into the sandboxes below. - (datetime)) + (datetime) + ((srfi srfi-1) :select (take-while drop))) (define files (scandir here @@ -206,10 +207,39 @@ exec $GUILE --debug -s "$0" "$@" (format (current-error-port) "Test unexpectedly crashed [~a]: ~s~%" err args))) ))))))) +(use-modules (hnh util path)) +(add-to-load-path (path-append (dirname here) "scripts")) + +(define-values (module-files module-names) + ((@ (all-modules) all-modules-under-directory) + (path-append (dirname here) "module"))) + (call-with-values run-with-coverage (lambda (data _) - (call-with-output-file "lcov.info" - (lambda (port) (coverage-data->lcov data port))))) + + (define to-drop + (1+ (length + (take-while (lambda (p) (not (string=? p "module"))) + (path-split (car module-files)))))) + + (define (drop-components path-list) + (drop path-list to-drop)) + + (define target-ht (make-hash-table)) + (define source-ht ((@@ (system vm coverage) data-file->line-counts) data)) + (for-each (lambda (path) + (cond ((hash-ref source-ht path #f) + => (lambda (value) (hash-set! target-ht path value))))) + (map (compose path-join drop-components path-split) module-files)) + + (let ((better-data + ((@@ (system vm coverage) %make-coverage-data) + ((@@ (system vm coverage) data-ip-counts) data) + ((@@ (system vm coverage) data-sources) data) + ((@@ (system vm coverage) data-file->procedures) data) + target-ht))) + (call-with-output-file "lcov.info" + (lambda (port) (coverage-data->lcov better-data port)))))) (test-end "tests") |