From 6561bf706f405c7d7cc6661bbd8a7ee9930ab4f3 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 20 Feb 2014 16:08:32 -0500
Subject: [PATCH] Make path manipulation in contract-profile more robust.

---
 pkgs/contract-profile/main.rkt  | 13 +++++++------
 pkgs/contract-profile/tests.rkt | 12 +++++++++++-
 pkgs/contract-profile/utils.rkt | 32 +++++++++++++++++++++++++++-----
 3 files changed, 45 insertions(+), 12 deletions(-)

diff --git a/pkgs/contract-profile/main.rkt b/pkgs/contract-profile/main.rkt
index 77050a773a..5d1fc995ed 100644
--- a/pkgs/contract-profile/main.rkt
+++ b/pkgs/contract-profile/main.rkt
@@ -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)
diff --git a/pkgs/contract-profile/tests.rkt b/pkgs/contract-profile/tests.rkt
index 90618add3e..fba151d086 100644
--- a/pkgs/contract-profile/tests.rkt
+++ b/pkgs/contract-profile/tests.rkt
@@ -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)))
   )
diff --git a/pkgs/contract-profile/utils.rkt b/pkgs/contract-profile/utils.rkt
index 014a8e644c..bcf87ff29a 100644
--- a/pkgs/contract-profile/utils.rkt
+++ b/pkgs/contract-profile/utils.rkt
@@ -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))))