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

fixed much of PR 8094 and extended the module browser to also hide planet requires PR 7932

Browse Source 
svn: r3290
This commit is contained in:
Robby Findler 2006-06-08 21:59:41 +00:00
parent 1105d9b404
commit 90581cc4f6
8 changed files with 138 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

138
collects/drscheme/private/module-overview.ss
View File

@ -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))))))))

39
collects/drscheme/private/unit.ss
View File

@ -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))))

33
collects/help/private/finddoc.ss
View File

@ -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

7
collects/help/private/manuals.ss
View File

@ -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)

4
collects/help/private/standard-urls.ss
View File

@ -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")))

6
collects/help/servlets/home.ss
View File

@ -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?") ", "
"...")))

2
collects/help/servlets/howtodrscheme.ss
View File

@ -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"))

7
collects/help/servlets/howtoprogram.ss
View File

@ -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?"))