From 32b274dee15e5c6068655ac21e429fda82b3de4d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 19 Feb 2018 06:42:57 -0700
Subject: [PATCH] make `syntax/moddep` more useful

This tool seems misplaced, but improve it a little to be practical for
larger module hierarchies.
---
 .../syntax/scribblings/moddep.scrbl           | 17 ++++-
 racket/collects/syntax/moddep.rkt             | 67 +++++++++++++------
 2 files changed, 61 insertions(+), 23 deletions(-)

diff --git a/pkgs/racket-doc/syntax/scribblings/moddep.scrbl b/pkgs/racket-doc/syntax/scribblings/moddep.scrbl
index 27e7748fd8..4c62fdf9e1 100644
--- a/pkgs/racket-doc/syntax/scribblings/moddep.scrbl
+++ b/pkgs/racket-doc/syntax/scribblings/moddep.scrbl
@@ -9,7 +9,20 @@ Re-exports @racketmodname[syntax/modread],
 @racketmodname[syntax/modcode], @racketmodname[syntax/modcollapse],
 and @racketmodname[syntax/modresolve], in addition to the following:
 
-@defproc[(show-import-tree [module-path-v module-path?]) void?]{
+@defproc[(show-import-tree [module-path-v module-path?]
+                           [#:dag? dag? any/c #f]
+                           [#:path-to path-to-module-path-v (or/c #f module-path?) #f])
+         void?]{
 
 A debugging aid that prints the import hierarchy starting from a given
-module path.}
+module path.
+
+If @racket[dag?] is true, then a module is printed only the first time
+is encountered in the hierarchy.
+
+If @racket[path-to-module-path-v] is a module path, then only the
+spines of the tree that reach @racket[path-to-module-path-v] are
+shown.
+
+@history[#:changed "6.12.0.4" @elem{Added the @racket[#:dag?] and
+                                    @racket[#:path-to] arguments.}]}
diff --git a/racket/collects/syntax/moddep.rkt b/racket/collects/syntax/moddep.rkt
index c0f3fe4fb1..037020d2d0 100644
--- a/racket/collects/syntax/moddep.rkt
+++ b/racket/collects/syntax/moddep.rkt
@@ -10,24 +10,49 @@
            (all-from-out "modresolve.rkt")
            show-import-tree)
 
-  (define (show-import-tree module-path)
-    (let loop ([path (resolve-module-path module-path #f)][indent ""][fs ""])
-      (printf "~a~a~a\n" indent path fs)
-      (let ([code (get-module-code path)])
-        (let ([imports (module-compiled-imports code)])
-          (define ((mk-loop fs) i)
-            (let ([p (resolve-module-path-index i path)])
-              (unless (symbol? p)
-                (loop p
-                      (format " ~a" indent)
-                      fs))))
-          (for-each (lambda (i)
-                      (for-each
-                       (mk-loop (case (car i)
-                                  [(0) ""]
-                                  [(1) " [for-syntax]"]
-                                  [(-1) " [for-syntax]"]
-                                  [(#f) " [for-label]"]
-                                  [else (format " [for-meta ~a]" (car i))]))
-                       (cdr i)))
-                    imports))))))
+  (define (show-import-tree module-path
+                            #:dag? [dag? #f]
+                            #:path-to [given-path-to #f])
+    (define path-to (and given-path-to (simplify-path (resolve-module-path given-path-to #f))))
+    (define seen (and dag? (make-hash)))
+    (let loop ([path (resolve-module-path module-path #f)] [indent ""] [fs ""] [phase 0] [accum '()])
+      (unless path-to
+        (printf "~a~a~a ~a\n" indent path fs phase))
+      (when (equal? path-to path)
+        (let ([accum (let loop ([accum (cons (list indent path fs phase) accum)])
+                       (cond
+                         [(null? accum) null]
+                         [(hash-ref seen accum #f) null]
+                         [else
+                          (hash-set! seen accum #t)
+                          (cons (car accum) (loop (cdr accum)))]))])
+          (for ([i (in-list (reverse accum))])
+            (apply printf "~a~a~a ~a\n" i))))
+      (unless (and seen (hash-ref seen (cons path phase) #f))
+        (when seen (hash-set! seen (cons path phase) #t))
+        (define plain-path (if (pair? path) (cadr path) path))
+        (let ([code (get-module-code plain-path
+                                     #:submodule-path (if (pair? path) (cddr path) '()))])
+          (let ([imports (module-compiled-imports code)]
+                [accum (cons (list indent path fs phase) accum)])
+            (define ((mk-loop phase-shift fs) i)
+              (let ([p (resolve-module-path-index i plain-path)])
+                (unless (symbol? p)
+                  (loop (if (path? p)
+                            (simplify-path p)
+                            (list* 'submod (simplify-path (cadr p)) (cddr p)))
+                        (format " ~a" indent)
+                        fs
+                        (and phase phase-shift (+ phase phase-shift))
+                        accum))))
+            (for-each (lambda (i)
+                        (for-each
+                         (mk-loop (car i)
+                                  (case (car i)
+                                    [(0) ""]
+                                    [(1) " [for-syntax]"]
+                                    [(-1) " [for-template]"]
+                                    [(#f) " [for-label]"]
+                                    [else (format " [for-meta ~a]" (car i))]))
+                         (cdr i)))
+                      imports)))))))