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

Make path manipulation in contract-profile more robust.

Browse Source
This commit is contained in:
Vincent St-Amour 2014-02-20 16:08:32 -05:00
parent 229e0c8097
commit 6561bf706f
3 changed files with 45 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
pkgs/contract-profile/main.rkt
View File

@ -183,8 +183,10 @@
(with-handlers
([(lambda (e)
(and (exn:fail:contract? e)
(regexp-match "^dynamic-require: unknown module"
(exn-message e))))
(or (regexp-match "^dynamic-require: unknown module"
(exn-message e))
(regexp-match "^path->string"
(exn-message e)))))
(lambda _ #f)])
(dynamic-require
(append (list 'submod (list 'file (path->string filename)))
@ -199,12 +201,11 @@
module-graph-dot-file
(printf "digraph {\n")
(define nodes->names (for/hash ([n nodes]) (values n (gensym))))
(define node-labels (shorten-paths nodes))
(for ([n nodes]
[l node-labels])
(define node->labels (make-shortener nodes))
(for ([n nodes])
(printf "~a[label=\"~a\"][color=\"~a\"]\n"
(hash-ref nodes->names n)
l
(node->labels n)
(if (hash-ref nodes->typed? n #f) "green" "red")))
(for ([(k v) (in-hash edge-samples)])
(match-define (cons pos neg) k)

12
pkgs/contract-profile/tests.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require contract-profile (only-in contract-profile/utils dry-run?))
(require contract-profile
(only-in contract-profile/utils dry-run? make-shortener))
(module+ test
(require rackunit)
@ -17,4 +18,13 @@
(define big2 (build-matrix dim dim (lambda (i j) (random))))
(define (main) (matrix* big1 big2))
(check-true (matrix? (contract-profile (main)))))
;; test path shortening
(define paths '("a/b/c.rkt" "a/b/d.rkt" ("a/b/e.rkt" f) (something else)))
(define shortener (make-shortener paths))
(check-equal? (map shortener paths)
(list (build-path "c.rkt")
(build-path "d.rkt")
(list (build-path "e.rkt") 'f)
'(something else)))
)

32
pkgs/contract-profile/utils.rkt
View File

@ -2,7 +2,7 @@
(require racket/port racket/contract racket/list setup/collects)
(provide (all-defined-out))
(provide (except-out (all-defined-out) shorten-paths))
(struct contract-profile
(total-time
@ -44,10 +44,16 @@
(blame-positive b) (blame-negative b)
(blame-contract b) (blame-value b) (blame-source b)))
;; (sequenceof (U path-string? submodule-path #f)) -> same
;; (listof (U path-string? submodule-path #f)) -> same
(define (shorten-paths ps*)
(define ps (for/list ([p ps*] #:when p) p)) ; remove non-paths
;; zeroth pass, chop off submodule parts, to put back later
(define ps ; remove non-paths
(for/list ([p (in-list ps*)]
#:when (or (path-string? p)
(and (list? p) ; submodule
(not (empty? p))
(path-string? (first p)))))
p))
(define submodules ; (listof (U submodule-part #f))
(for/list ([p ps])
(and (list? p) (rest p))))
@ -76,11 +82,27 @@
[m (in-list (append collect-paths relative-paths))])
(if s (cons m s) m)))
(define (make-shortener ps [extract-path values])
(define table
;; (sequenceof A) (A -> (U path-string? submodule-path #f)) -> (A -> (U ...))
(define (make-shortener ps* [extract-path values])
;; special-case things shorten-paths can't deal with
;; these should just map to themselves
(define-values (ps bad)
(partition (lambda (p)
(or (path-string? p)
(and (list? p) ; submodule path
(not (empty? p))
(path-string? (first p)))))
;; can be any kind of sequence, turn into a list
(for/list ([p ps*]) p)))
(define init-table
(for/hash ([p ps]
[s (shorten-paths (map extract-path ps))])
(values p s)))
;; add bad "paths", mapping to themselves
(define table
(for/fold ([table init-table])
([b (in-list bad)])
(hash-set table b b)))
(lambda (p)
(or (hash-ref table p #f)
(extract-path p))))