bkyk8rc3zvpnsf5inmcqq4n3k98cv6hj-my-site-hyper-literate-git.test.suzanne.soy-0.0.1

commit 5caf386a47cdf2ea7ddad1f8f0fad5fa4d08e863
parent 877a2eb2f8e3b92188fd2219400fdc7acdae40b9
Author: Matthew Flatt <mflatt@racket-lang.org>
Date:   Wed, 12 Dec 2007 14:54:46 +0000

new defn-finding support in scribble-index

svn: r7967

original commit: 6b2be05771029921d8e6d9a91cf7a2bdab716f57

Diffstat:
M
collects/scribble/html-render.ss
 | 
12
++++++++++++
M
collects/setup/scribble-index.ss
 | 
53
++++++++++++++++++++++++++++++++++++++++++++++++++++-

2 files changed, 64 insertions(+), 1 deletion(-)
diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
@@ -108,6 +108,18 @@
       
       ;; ----------------------------------------
 
+      (define/public (tag->path+anchor ri tag)
+        (let ([dest (resolve-get #f ri tag)])
+          (if dest
+              (values
+               (relative->path (car dest))
+               (if (caddr dest)
+                   #f
+                   (anchor-name (cadddr dest))))
+              (values #f #f))))
+
+      ;; ----------------------------------------
+
       (define/private (reveal-subparts? p)
         (part-style? p 'reveal))
     
diff --git a/collects/setup/scribble-index.ss b/collects/setup/scribble-index.ss
@@ -9,11 +9,14 @@
          setup/getinfo
          setup/dirs
          mzlib/serialize
-         scheme/path)
+         scheme/path
+         setup/main-collects)
 
 (provide load-xref
          xref-render
          xref-index
+         xref-binding->definition-tag
+         xref-tag->path+anchor
          (struct-out entry))
 
 (define-struct entry (words    ; list of strings: main term, sub-term, etc.
@@ -97,3 +100,51 @@
     (let ([ri (send renderer resolve (list doc) (list dest-file) ci)])
       (send renderer render (list doc) (list dest-file) ri)
       (void))))
+
+;; Returns (values <tag-or-#f> <form?>)
+(define (xref-binding-tag xrefs src id)
+  (let ([search
+         (lambda (src)
+           (let ([base (format ":~a:~a" 
+                               (if (path? src)
+                                   (path->main-collects-relative src)
+                                   src)
+                               id)]
+                 [ht (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))])
+             (let ([form-tag `(form ,base)]
+                   [val-tag `(def ,base)])
+               (if (hash-table-get ht form-tag #f)
+                   (values form-tag #t)
+                   (if (hash-table-get ht val-tag #f)
+                       (values val-tag #f)
+                       (values #f #f))))))])
+    (let loop ([src src])
+      (cond
+       [(path? src)
+        (if (complete-path? src)
+            (search src)
+            (loop (path->complete-path src)))]
+       [(path-string? src)
+        (loop (path->complete-path src))]
+       [(resolved-module-path? src)
+        (let ([n (resolved-module-path-name src)])
+          (if (pair? n)
+              (loop n)
+              (search n)))]
+       [(module-path-index? src)
+        (loop (module-path-index-resolve src))]
+       [(module-path? src)
+        (loop (module-path-index-join src #f))]
+       [else
+        (raise-type-error 'xref-binding-definition->tag
+                          "module path, resolved module path, module path index, path, or string"
+                          src)]))))
+
+(define (xref-binding->definition-tag xrefs src id)
+  (let-values ([(tag form?) (xref-binding-tag xrefs src id)])
+    tag))
+
+(define (xref-tag->path+anchor xrefs tag)
+  (let ([renderer (new (html:render-mixin render%) 
+                       [dest-dir (find-system-path 'temp-dir)])])
+    (send renderer tag->path+anchor (xrefs-ri xrefs) tag)))