From 90581cc4f6f480f17f6d2e564e035146f3c7cb88 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 8 Jun 2006 21:59:41 +0000
Subject: [PATCH] fixed much of PR 8094 and extended the module browser to also
 hide planet requires PR 7932

svn: r3290
---
 collects/drscheme/private/module-overview.ss | 138 +++++++++++--------
 collects/drscheme/private/unit.ss            |  39 ++++--
 collects/help/private/finddoc.ss             |  33 ++---
 collects/help/private/manuals.ss             |   7 +-
 collects/help/private/standard-urls.ss       |   4 +-
 collects/help/servlets/home.ss               |   6 +-
 collects/help/servlets/howtodrscheme.ss      |   2 +-
 collects/help/servlets/howtoprogram.ss       |   7 +-
 8 files changed, 138 insertions(+), 98 deletions(-)

diff --git a/collects/drscheme/private/module-overview.ss b/collects/drscheme/private/module-overview.ss
index c798db934a..183bc95f72 100644
--- a/collects/drscheme/private/module-overview.ss
+++ b/collects/drscheme/private/module-overview.ss
@@ -14,12 +14,12 @@
            (lib "unit.ss")
            (lib "async-channel.ss"))
   
-  (define-struct req (filename lib?))
-  ;; type req = (make-req string[filename] boolean)
+  (define-struct req (filename key))
+  ;; type req = (make-req string[filename] (union symbol #f))
       
   (provide module-overview@
            process-program-unit
-           (struct req (filename lib?)))
+           (struct req (filename key)))
 
   (define adding-file (string-constant module-browser-adding-file))
   (define unknown-module-name "? unknown module name")
@@ -41,7 +41,10 @@
       (preferences:set-default 'drscheme:module-overview:label-font-size 12 number?)
       (preferences:set-default 'drscheme:module-overview:window-height 500 number?)
       (preferences:set-default 'drscheme:module-overview:window-width 500 number?)
-      (preferences:set-default 'drscheme:module-browser:show-lib-paths? #f boolean?)
+      (preferences:set-default 'drscheme:module-browser:hide-paths '(lib)
+                               (λ (x)
+                                 (and (list? x)
+                                      (andmap symbol? x))))
       
       (define (set-box/f b v) (when (box? b) (set-box! b v)))
       
@@ -57,7 +60,8 @@
         (interface ()
           set-label-font-size
           get-label-font-size
-          show-lib-paths
+          show-visible-paths
+          remove-visible-paths
           set-name-length
           get-name-length))
       
@@ -66,8 +70,8 @@
           get-filename
           get-word
           get-lines
-          get-lib-children
-          add-lib-child))
+          is-special-key-child?
+          add-special-key-child))
       
       ;; make-module-overview-pasteboard : boolean
       ;;                                   ((union #f snip) -> void)
@@ -190,9 +194,7 @@
               
               (set! max-lines #f)
               
-              (unless (preferences:get 'drscheme:module-browser:show-lib-paths?)
-                (remove-lib-linked))
-              
+              (remove-specially-linked)
               (render-snips)
               (end-edit-sequence))
               
@@ -200,7 +202,7 @@
             ;; name-original and name-require and the identifiers for those paths and
             ;; original-filename? and require-filename? are booleans indicating if the names
             ;; are filenames.
-            (define/public (add-connection name-original name-require lib-path? require-type)
+            (define/public (add-connection name-original name-require path-key require-type)
               (unless max-lines
                 (error 'add-connection "not in begin-adding-connections/end-adding-connections sequence"))
               (let* ([original-filename? (file-exists? name-original)]
@@ -221,9 +223,10 @@
                   [(require-for-template)
                    (add-links original-snip require-snip
                               dark-template-pen light-template-pen
-                              dark-template-brush light-template-brush)])
-                (when lib-path?
-                  (send original-snip add-lib-child require-snip))
+                              dark-template-brush light-template-brush)]
+                  [else (error 'add-connection "unknown require-type ~s" require-type)])
+                (when path-key
+                  (send original-snip add-special-key-child path-key require-snip))
                 (if (send original-snip get-level)
                     (fix-snip-level require-snip (+ original-level 1))
                     (fix-snip-level original-snip 0))))
@@ -296,36 +299,48 @@
                 (- (unbox bb)
                    (unbox tb))))
             
-            (field [lib-paths-on? (preferences:get 'drscheme:module-browser:show-lib-paths?)])
-            (define/public (show-lib-paths on?)
-              (unless (eq? on? lib-paths-on?)
-                (set! lib-paths-on? on?)
-                (begin-edit-sequence)
-                (re-add-snips)
-                (render-snips)
-                (end-edit-sequence)))
+            (field [hidden-paths (preferences:get 'drscheme:module-browser:hide-paths)])
+            (define/public (remove-visible-paths symbol)
+              (unless (memq symbol hidden-paths)
+                (set! hidden-paths (cons symbol hidden-paths))
+                (refresh-visible-paths)))
+            (define/public (show-visible-paths symbol)
+              (when (memq symbol hidden-paths)
+                (set! hidden-paths (remq symbol hidden-paths))
+                (refresh-visible-paths)))
+            
+            (define/private (refresh-visible-paths)
+              (begin-edit-sequence)
+              (re-add-snips)
+              (render-snips)
+              (end-edit-sequence))
             
             (define/private (re-add-snips)
               (begin-edit-sequence)
-              (remove-currrently-inserted)
-              (if lib-paths-on?
-                  (add-all)
-                  (remove-lib-linked))
+              (remove-specially-linked)
               (end-edit-sequence))
             
-            (define/private (remove-lib-linked)
+            (define/private (remove-specially-linked)
               (remove-currrently-inserted)
-              (for-each
-               (λ (snip)
-                 (insert snip)
-                 (let loop ([snip snip])
+              (cond
+                [(null? hidden-paths)
+                 (add-all)]
+                [else
+                 (let ([ht (make-hash-table)])
                    (for-each
-                    (λ (child)
-                      (unless (memq child (send snip get-lib-children))
-                        (insert child)
-                        (loop child)))
-                    (send snip get-children))))
-               (get-top-most-snips)))
+                    (λ (snip)
+                      (insert snip)
+                      (let loop ([snip snip])
+                        (unless (hash-table-get ht snip (λ () #f))
+                          (hash-table-put! ht snip #t)
+                          (for-each
+                           (λ (child)
+                             (unless (ormap (λ (key) (send snip is-special-key-child? key child))
+                                            hidden-paths)
+                               (insert child)
+                               (loop child)))
+                           (send snip get-children)))))
+                    (get-top-most-snips)))]))
                 
             (define/private (remove-currrently-inserted)
               (let loop ()
@@ -492,11 +507,17 @@
                         lines
                         pb)
             
-            (field [lib-children null])
-            (define/public (get-lib-children) lib-children)
-            (define/public (add-lib-child child)
-              (unless (memq child lib-children)
-                (set! lib-children (cons child lib-children))))
+            (field [special-children (make-hash-table)])
+            (define/public (is-special-key-child? key child)
+              (let ([ht (hash-table-get special-children key (λ () #f))])
+                (and ht
+                     (hash-table-get ht child (λ () #f)))))
+            (define/public (add-special-key-child key child)
+              (let ([ht (hash-table-get special-children key (λ () #f))])
+                (unless ht
+                  (set! ht (make-hash-table))
+                  (hash-table-put! special-children key ht))
+                (hash-table-put! ht child #t)))
             
             (define/public (get-filename) filename)
             (define/public (get-word) word)
@@ -687,11 +708,13 @@
                   (parent vp)
                   (callback
                    (λ (x y)
-                     (send pasteboard show-lib-paths (send lib-paths-checkbox get-value))))))
+                     (if (send lib-paths-checkbox get-value)
+                         (send pasteboard add-visible-path 'lib)
+                         (send pasteboard remove-visible-path 'lib))))))
               
               (define ec (make-object canvas:basic% vp pasteboard))
               
-              (send lib-paths-checkbox set-value (preferences:get 'drscheme:module-browser:show-lib-paths?))
+              (send lib-paths-checkbox set-value (not (memq 'lib (preferences:get 'drscheme:module-browser:hide-paths))))
               (set! update-label
                     (λ (s)
                       (if (and s (not (null? s)))
@@ -804,9 +827,9 @@
                  (unless (eq? val 'done)
                    (let ([name-original (first val)]
                          [name-require (second val)]
-                         [lib-path? (third val)]
+                         [path-key (third val)]
                          [require-type (fourth val)])
-                     (send pasteboard add-connection name-original name-require lib-path? require-type))
+                     (send pasteboard add-connection name-original name-require path-key require-type))
                    (loop))]))))
         (send pasteboard end-adding-connections)
         
@@ -921,21 +944,21 @@
               (for-each (λ (require)
                           (add-connection module-name
                                           (req-filename require)
-                                          (req-lib? require)
+                                          (req-key require)
                                           'require)
                           (add-filename-connections (req-filename require)))
                         requires)
               (for-each (λ (syntax-require)
                           (add-connection module-name 
                                           (req-filename syntax-require)
-                                          (req-lib? syntax-require)
+                                          (req-key syntax-require)
                                           'require-for-syntax)
                           (add-filename-connections (req-filename syntax-require)))
                         syntax-requires)
               (for-each (λ (require)
                           (add-connection module-name
                                           (req-filename require)
-                                          (req-lib? require)
+                                          (req-key require)
                                           'require-for-template)
                           (add-filename-connections (req-filename require)))
                         template-requires)))))
@@ -944,10 +967,10 @@
       ;; name-original and name-require and the identifiers for those paths and
       ;; original-filename? and require-filename? are booleans indicating if the names
       ;; are filenames.
-      (define (add-connection name-original name-require is-lib? require-type)
+      (define (add-connection name-original name-require req-sym require-type)
         (async-channel-put connection-channel (list name-original 
                                                     name-require  
-                                                    is-lib?
+                                                    req-sym
                                                     require-type)))
       
       (define (extract-module-name stx)
@@ -966,13 +989,16 @@
             [(null? direct-requires) null]
             [else (let ([dr (car direct-requires)])
                     (if (module-path-index? dr)
-                        (cons (make-req (simplify-path (expand-path (resolve-module-path-index dr base)))
-                                        (is-lib? dr))
-                              (loop (cdr direct-requires)))
+                        (begin
+                          ;(printf ">> ~s ~s\n" base (collapse-module-path-index dr base))
+                          (cons (make-req (simplify-path (expand-path (resolve-module-path-index dr base)))
+                                          (get-key dr))
+                                (loop (cdr direct-requires))))
                         (loop (cdr direct-requires))))])))
       
-      (define (is-lib? dr)
+      (define (get-key dr)
         (and (module-path-index? dr)
              (let-values ([(a b) (module-path-index-split dr)])
                (and (pair? a)
-                    (eq? 'lib (car a)))))))))
+                    (symbol? (car a))
+                    (car a))))))))
diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss
index 796e8e2bde..71baca5c8d 100644
--- a/collects/drscheme/private/unit.ss
+++ b/collects/drscheme/private/unit.ss
@@ -39,6 +39,7 @@ module browser threading seems wrong.
   (define module-browser-progress-constant (string-constant module-browser-progress))
   (define status-compiling-definitions (string-constant module-browser-compiling-defns))
   (define show-lib-paths (string-constant module-browser-show-lib-paths/short))
+  (define show-planet-paths (string-constant module-browser-show-planet-paths/short))
   (define refresh (string-constant module-browser-refresh))
   
   (define unit@
@@ -2383,6 +2384,7 @@ module browser threading seems wrong.
                  [module-browser-ec #f]
                  [module-browser-button #f]
                  [module-browser-lib-path-check-box #f]
+                 [module-browser-planet-path-check-box #f]
                  [module-browser-name-length-choice #f]
                  [module-browser-pb #f]
                  [module-browser-menu-item 'module-browser-menu-item-unset])
@@ -2430,16 +2432,31 @@ module browser threading seems wrong.
               (set! module-browser-ec (make-object editor-canvas%
                                         module-browser-panel
                                         module-browser-pb))
-              (set! module-browser-lib-path-check-box
-                    (new check-box%
-                      (parent module-browser-panel)
-                      (label show-lib-paths)
-                      (value (preferences:get 'drscheme:module-browser:show-lib-paths?))
-                      (callback 
-                       (λ (x y) 
-                         (let ([val (send module-browser-lib-path-check-box get-value)])
-                           (preferences:set 'drscheme:module-browser:show-lib-paths? val)
-                           (send module-browser-pb show-lib-paths val))))))
+              
+              (let* ([show-callback
+                      (λ (cb key)
+                        (let ([val (send cb get-value)]
+                              [current (preferences:get 'drscheme:module-browser:hide-paths)])
+                          (if val
+                              (begin
+                                (when (memq key current)
+                                  (preferences:set 'drscheme:module-browser:hide-paths (remq key current)))
+                                (send module-browser-pb show-visible-paths key))
+                              (begin
+                                (unless (memq key current)
+                                  (preferences:set 'drscheme:module-browser:hide-paths (cons key current)))
+                                (send module-browser-pb remove-visible-paths key)))))]
+                     [mk-checkbox
+                      (λ (key label)
+                        (new check-box%
+                             (parent module-browser-panel)
+                             (label label)
+                             (value (not (memq key (preferences:get 'drscheme:module-browser:hide-paths))))
+                             (callback 
+                              (λ (cb _) 
+                                (show-callback cb key)))))])
+                (set! module-browser-lib-path-check-box (mk-checkbox 'lib show-lib-paths))
+                (set! module-browser-planet-path-check-box (mk-checkbox 'planet show-planet-paths)))
               
               (set! module-browser-name-length-choice
                     (new choice%
@@ -2500,6 +2517,7 @@ module browser threading seems wrong.
                 (update-status-line 'plt:module-browser status-compiling-definitions)
                 (send module-browser-button enable #f)
                 (send module-browser-lib-path-check-box enable #f)
+                (send module-browser-planet-path-check-box enable #f)
                 (send module-browser-name-length-choice enable #f)
                 (disable-evaluation-in-tab current-tab)
                 (drscheme:module-overview:fill-pasteboard 
@@ -2517,6 +2535,7 @@ module browser threading seems wrong.
                 (send mod-tab enable-evaluation)
                 (send module-browser-button enable #t)
                 (send module-browser-lib-path-check-box enable #t)
+                (send module-browser-planet-path-check-box enable #t)
                 (send module-browser-name-length-choice enable #t)
                 (close-status-line 'plt:module-browser))))
           
diff --git a/collects/help/private/finddoc.ss b/collects/help/private/finddoc.ss
index 14359e228b..bb47d28456 100644
--- a/collects/help/private/finddoc.ss
+++ b/collects/help/private/finddoc.ss
@@ -1,10 +1,10 @@
 (module finddoc mzscheme
   (require "path.ss"
-	   (lib "dirs.ss" "setup"))
+	   "get-help-url.ss"
+           (lib "dirs.ss" "setup"))
 
   (provide finddoc
-	   findreldoc
-           finddoc-page
+	   finddoc-page
 	   finddoc-page-anchor
 	   find-doc-directory)
   
@@ -19,31 +19,18 @@
                   (build-path (car m) (caddr m))
                     label))))
 
-  ;; Given a Unix-style relative path to reach the "doc"
-  ;; collection, creates a link that can go to a
-  ;; particular anchor.
-  (define (findreldoc todocs manual index-key label)
-    (let ([m (lookup manual index-key label)])
-      (if (string? m)
-          m
-          (format "<A href=\"~a/~a/~a#~a\">~a</A>"
-                  todocs
-                  manual
-                  (caddr m)
-                  (cadddr m)
-                  label))))
-
   (define (finddoc-page-help manual index-key anchor?)
     (let ([m (lookup manual index-key "dummy")])
       (if (string? m)
           (error (format "Error finding index \"~a\" in manual \"~a\""
                          index-key manual))
-          (let ([path (if anchor?
-                          (string-append (caddr m) "#" (cadddr m))
-                          (caddr m))])
-            (if (servlet-path? (string->path (caddr m)))
-                path
-                (format "/doc/~a/~a" manual path))))))
+          (if (servlet-path? (string->path (caddr m)))
+              (if anchor?
+                  (string-append (caddr m) "#" (cadddr m))
+                  (caddr m))
+              (get-help-url (build-path (list-ref m 0)
+                                        (list-ref m 2))
+                            (list-ref m 3))))))
   
   ; finddoc-page : string string -> string
   ; returns path for use by PLT Web server
diff --git a/collects/help/private/manuals.ss b/collects/help/private/manuals.ss
index b840512bdc..6a541e9f57 100644
--- a/collects/help/private/manuals.ss
+++ b/collects/help/private/manuals.ss
@@ -19,7 +19,6 @@
 
   (provide main-manual-page)
   (provide finddoc
-	   findreldoc
 	   finddoc-page-anchor)
   
   (provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)]
@@ -28,6 +27,7 @@
                     [find-doc-directories (-> (listof path?))]
                     [find-doc-directory (path? . -> . (or/c false/c path?))]
                     [find-doc-names (-> (listof (cons/c path? string?)))]
+                    [get-manual-index (-> string? string?)]
                     [get-index-file (path? . -> . (or/c false/c path?))])
   
   (provide find-manuals)
@@ -127,7 +127,7 @@
                                          (directory-list docs-path))
                                  '()))))
                 (get-doc-search-dirs))))
-
+  
   (define (find-manuals)
     (let* ([docs (sort (filter get-index-file (find-doc-directories))
                        compare-docs)]
@@ -351,6 +351,9 @@
       (cond [(= ap bp) (string<? (path->string a) (path->string b))]
             [else (< ap bp)])))
 
+  ;; get-manual-index : string -> html
+  (define (get-manual-index manual-dirname) (get-help-url (build-path (find-doc-dir) manual-dirname)))
+  
   ;; get-index-file : path -> (union #f path)
   ;; returns the name of the main file, if one can be found
   (define (get-index-file doc-dir)
diff --git a/collects/help/private/standard-urls.ss b/collects/help/private/standard-urls.ss
index 7f88cf5cdd..b6bd6e198a 100644
--- a/collects/help/private/standard-urls.ss
+++ b/collects/help/private/standard-urls.ss
@@ -2,7 +2,9 @@
 
   (require "../servlets/private/util.ss"
            "internal-hp.ss"
+           "get-help-url.ss"
            (lib "uri-codec.ss" "net")
+           (lib "dirs.ss" "setup")
            (lib "contract.ss"))
   
   (provide home-page-url)
@@ -101,7 +103,7 @@
   
   ; sym, string assoc list
   (define hd-locations
-    '((hd-tour "/doc/tour/")
+    `((hd-tour ,(get-help-url (build-path (find-doc-dir) "tour")))
       (release-notes "/servlets/release/notes.ss")
       (plt-license "/servlets/release/license.ss")
       (front-page "/servlets/home.ss")))
diff --git a/collects/help/servlets/home.ss b/collects/help/servlets/home.ss
index 915afe7f23..f4ce72be64 100644
--- a/collects/help/servlets/home.ss
+++ b/collects/help/servlets/home.ss
@@ -1,5 +1,6 @@
 (module home mzscheme
   (require "private/util.ss"
+           "../private/get-help-url.ss"
            "../private/manuals.ss"
 	   (lib "servlet.ss" "web-server"))
   
@@ -31,7 +32,7 @@
                   (BR)
                   'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp
                   (FONT ((SIZE "-2"))
-                        (A ((HREF "/doc/tour/")) "Tour") ", "
+                        (a ((href ,(get-manual-index "tour"))) "Tour") ", "
                         (A ((HREF "/servlets/scheme/what.ss")) "Languages") ", "
                         (A ((HREF "/servlets/manuals.ss")) "Manuals") ", "
                         (A ((HREF "/servlets/releaseinfo.ss")) "Release") ", "
@@ -46,7 +47,8 @@
                   ": Learning to program in Scheme"             
                   (BR) 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 'nbsp 
                   (FONT ((SIZE "-2"))
-                        (A ((HREF "/doc/teachpack/")) "Teachpacks") ", "
+                        (a ((href ,(get-manual-index "teachpack"))) "Teachpacks")
+                        ", "
                         (A ((HREF "/servlets/research/why.ss")) "Why DrScheme?") ", "
                         "...")))
                 
diff --git a/collects/help/servlets/howtodrscheme.ss b/collects/help/servlets/howtodrscheme.ss
index c076971fe8..87efdd4ad0 100644
--- a/collects/help/servlets/howtodrscheme.ss
+++ b/collects/help/servlets/howtodrscheme.ss
@@ -20,7 +20,7 @@
        "See " (A ((HREF "/servlets/scheme/how.ss")) "Software & Components") 
        " for a guide to the full suite of PLT tools." 
        (UL  
-        (LI  (B  (A ((HREF "/doc/tour/")) "Tour")) ": An introduction to DrScheme")
+        (LI  (B  (A ((HREF ,(get-manual-index "tour")))) "Tour") ": An introduction to DrScheme")
         (LI  (B  ,(manual-entry "drscheme" 
                                 "graphical interface"
                                 "Interface Essentials"))
diff --git a/collects/help/servlets/howtoprogram.ss b/collects/help/servlets/howtoprogram.ss
index aadea4a72e..3b39e96547 100644
--- a/collects/help/servlets/howtoprogram.ss
+++ b/collects/help/servlets/howtoprogram.ss
@@ -1,6 +1,7 @@
 (module howtoprogram mzscheme
   (require "private/util.ss"
            "private/headelts.ss"
+           "../private/manuals.ss"
            (lib "servlet.ss" "web-server"))
   
   (provide interface-version timeout start)
@@ -26,13 +27,13 @@
        (P)
        "Help Desk provides the following interactive support for the textbook:"
        (UL  
-        (LI  (B  (A ((HREF "/doc/teachpack/index.html"))
+        (LI  (B  (A ((HREF ,(get-manual-index "teachpack")))
                     "Teachpack documentation"))))
        (P)
        ,(color-highlight
          `(H2  "For Experienced Programmers"))
-       (UL  (LI  (B  (A ((HREF "/doc/t-y-scheme/index.htm"))
-                        "Teach Yourself Scheme in Fixnum Days")) 
+       (UL  (LI  (B  (A ((HREF ,(get-manual-index "t-y-scheme")))
+                        "Teach Yourself Scheme in Fixnum Days"))
                  ": For programmers with lots of experience in other languages"))
        ,(color-highlight `(H2  "For Teachers and Researchers"))
        (UL  (LI  (B  (A ((HREF "/servlets/research/why.ss")) "Why DrScheme?"))