oops. Added things back so that drscheme works
svn: r7780
This commit is contained in:
Robby Findler
parent
351937e933
commit
0e5aa22a9d
|
|
@ -200,9 +200,7 @@
|
||||||
goto-release-notes
|
goto-release-notes
|
||||||
goto-plt-license
|
goto-plt-license
|
||||||
help-desk
|
help-desk
|
||||||
get-docs
|
get-docs))
|
||||||
open-url
|
|
||||||
add-help-desk-font-prefs))
|
|
||||||
|
|
||||||
(define-signature drscheme:language^
|
(define-signature drscheme:language^
|
||||||
(get-default-mixin
|
(get-default-mixin
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,8 @@
|
||||||
(require (lib "string-constant.ss" "string-constants")
|
(require (lib "string-constant.ss" "string-constants")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "external.ss" "browser")
|
(lib "external.ss" "browser")
|
||||||
(lib "help-desk.ss" "help")
|
(lib "bug-report.ss" "help")
|
||||||
|
(lib "buginfo.ss" "help" "private")
|
||||||
(lib "framework.ss" "framework")
|
(lib "framework.ss" "framework")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
|
|
@ -13,10 +14,9 @@
|
||||||
|
|
||||||
(import [prefix drscheme:frame: drscheme:frame^]
|
(import [prefix drscheme:frame: drscheme:frame^]
|
||||||
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^])
|
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^])
|
||||||
(export (rename drscheme:help-desk^
|
(export drscheme:help-desk^)
|
||||||
[-add-help-desk-font-prefs add-help-desk-font-prefs]))
|
|
||||||
|
|
||||||
(define (-add-help-desk-font-prefs b) (add-help-desk-font-prefs b))
|
(define (-add-help-desk-font-prefs b) '(add-help-desk-font-prefs b))
|
||||||
|
|
||||||
;; : -> string
|
;; : -> string
|
||||||
(define (get-computer-language-info)
|
(define (get-computer-language-info)
|
||||||
|
|
@ -32,88 +32,8 @@
|
||||||
(send language get-language-position)
|
(send language get-language-position)
|
||||||
(send language marshall-settings settings)))))
|
(send language marshall-settings settings)))))
|
||||||
|
|
||||||
;; get-docs : (listof (cons path[short-dir-name] string[doc full name]))
|
|
||||||
(define (get-docs)
|
|
||||||
(let ([dirs (find-doc-names)])
|
|
||||||
(map (λ (pr)
|
|
||||||
(let-values ([(base name dir?) (split-path (car pr))])
|
|
||||||
(cons name (cdr pr))))
|
|
||||||
dirs)))
|
|
||||||
|
|
||||||
(set-bug-report-info! "Computer Language" get-computer-language-info)
|
(set-bug-report-info! "Computer Language" get-computer-language-info)
|
||||||
|
|
||||||
(define drscheme-help-desk-mixin
|
|
||||||
(mixin (help-desk-frame<%> frame:standard-menus<%>) ()
|
|
||||||
(define/override (file-menu:create-open-recent?) #t)
|
|
||||||
|
|
||||||
(define/override (file-menu:new-callback x y)
|
|
||||||
(handler:edit-file #f)
|
|
||||||
#t)
|
|
||||||
(define/override (file-menu:between-save-as-and-print menu)
|
|
||||||
(new separator-menu-item% (parent menu)))
|
|
||||||
|
|
||||||
(define current-language
|
|
||||||
(preferences:get drscheme:language-configuration:settings-preferences-symbol))
|
|
||||||
(define/public (set-current-language cl)
|
|
||||||
(set! current-language cl))
|
|
||||||
|
|
||||||
(define/override (order-manuals x)
|
|
||||||
(send (drscheme:language-configuration:language-settings-language current-language)
|
|
||||||
order-manuals
|
|
||||||
x))
|
|
||||||
(define/override (get-language-name)
|
|
||||||
(send (drscheme:language-configuration:language-settings-language current-language)
|
|
||||||
get-language-name))
|
|
||||||
|
|
||||||
(define/override (file-menu:between-new-and-open file-menu)
|
|
||||||
(instantiate menu:can-restore-menu-item% ()
|
|
||||||
(label (string-constant plt:hd:new-help-desk))
|
|
||||||
(parent file-menu)
|
|
||||||
(callback (λ (x y) (new-help-desk))))
|
|
||||||
(super file-menu:between-new-and-open file-menu))
|
|
||||||
|
|
||||||
(super-new)
|
|
||||||
|
|
||||||
(inherit get-menu-bar)
|
|
||||||
(inherit-field choices-panel)
|
|
||||||
(letrec ([language-menu (new menu%
|
|
||||||
(parent (get-menu-bar))
|
|
||||||
(label (string-constant language-menu-name)))]
|
|
||||||
[change-language-callback
|
|
||||||
(λ ()
|
|
||||||
(let ([new-settings (drscheme:language-configuration:language-dialog
|
|
||||||
#f
|
|
||||||
current-language
|
|
||||||
this
|
|
||||||
#t)])
|
|
||||||
(when new-settings
|
|
||||||
(set! current-language new-settings)
|
|
||||||
(send lang-message set-msg (get-language-name))
|
|
||||||
(preferences:set
|
|
||||||
drscheme:language-configuration:settings-preferences-symbol
|
|
||||||
new-settings))))]
|
|
||||||
[lang-message
|
|
||||||
(new lang-message%
|
|
||||||
(button-release (λ () (change-language-callback)))
|
|
||||||
(parent choices-panel)
|
|
||||||
(font normal-control-font))]
|
|
||||||
[language-item (new menu-item%
|
|
||||||
(label (string-constant choose-language-menu-item-label))
|
|
||||||
(parent language-menu)
|
|
||||||
(shortcut #\l)
|
|
||||||
(callback
|
|
||||||
(λ (x y)
|
|
||||||
(change-language-callback))))])
|
|
||||||
(frame:reorder-menus this)
|
|
||||||
(send lang-message set-msg (get-language-name))
|
|
||||||
|
|
||||||
;; move the grow box spacer pane to the end
|
|
||||||
(send choices-panel change-children
|
|
||||||
(λ (l)
|
|
||||||
(append
|
|
||||||
(filter (λ (x) (not (is-a? x grow-box-spacer-pane%))) l)
|
|
||||||
(list (car (filter (λ (x) (is-a? x grow-box-spacer-pane%)) l)))))))))
|
|
||||||
|
|
||||||
(define lang-message%
|
(define lang-message%
|
||||||
(class canvas%
|
(class canvas%
|
||||||
(init-field button-release font)
|
(init-field button-release font)
|
||||||
|
|
@ -145,40 +65,22 @@
|
||||||
(send dc draw-text dots (- cw dw) (- (/ ch 2) (/ th 2)))]))))
|
(send dc draw-text dots (- cw dw) (- (/ ch 2) (/ th 2)))]))))
|
||||||
(super-new)))
|
(super-new)))
|
||||||
|
|
||||||
|
(define (goto-manual-link a b) (error 'goto-maual-link "~s ~s" a b))
|
||||||
|
(define (goto-hd-location b) (error 'goto-hd-location "~s" b))
|
||||||
|
|
||||||
(define (goto-help manual link) (goto-manual-link manual link))
|
(define (goto-help manual link) (goto-manual-link manual link))
|
||||||
(define (goto-tour) (goto-hd-location 'hd-tour))
|
(define (goto-tour) (goto-hd-location 'hd-tour))
|
||||||
(define (goto-release-notes) (goto-hd-location 'release-notes))
|
(define (goto-release-notes) (goto-hd-location 'release-notes))
|
||||||
(define (goto-plt-license) (goto-hd-location 'plt-license))
|
(define (goto-plt-license) (goto-hd-location 'plt-license))
|
||||||
|
|
||||||
|
(define (get-docs) (error 'help-desk.ss "get-docs"))
|
||||||
|
|
||||||
(define help-desk
|
(define help-desk
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[() (show-help-desk)]
|
[() (void)]
|
||||||
[(key) (help-desk key #f)]
|
[(key) (help-desk key #f)]
|
||||||
[(key lucky?) (help-desk key lucky? 'keyword+index)]
|
[(key lucky?) (help-desk key lucky? 'keyword+index)]
|
||||||
[(key lucky? type) (help-desk key lucky? type 'contains)]
|
[(key lucky? type) (help-desk key lucky? type 'contains)]
|
||||||
[(key lucky? type mode) (help-desk key lucky? type mode #f)]
|
[(key lucky? type mode) (help-desk key lucky? type mode #f)]
|
||||||
[(key lucky? type mode language)
|
[(key lucky? type mode language)
|
||||||
(let ([frame (or (find-help-desk-frame)
|
(void)]))
|
||||||
(new-help-desk))])
|
|
||||||
(when language
|
|
||||||
(send frame set-current-language language))
|
|
||||||
(search-for-docs/in-frame
|
|
||||||
frame
|
|
||||||
key
|
|
||||||
(case type
|
|
||||||
[(keyword) "keyword"]
|
|
||||||
[(keyword+index) "keyword-index"]
|
|
||||||
[(keyword+index+text) "keyword-index-text"]
|
|
||||||
[else (error 'drscheme:help-desk:help-desk "unknown type argument: ~s" type)])
|
|
||||||
(case mode
|
|
||||||
[(exact) "exact-match"]
|
|
||||||
[(contains) "containing-match"]
|
|
||||||
[(regexp) "regexp-match"]
|
|
||||||
[else (error 'drscheme:help-desk:help-desk "unknown mode argument: ~s" mode)])
|
|
||||||
lucky?
|
|
||||||
(map car (get-docs))))]))
|
|
||||||
|
|
||||||
;; open-url : string -> void
|
|
||||||
(define (open-url x) (send-url x))
|
|
||||||
|
|
||||||
(add-help-desk-mixin drscheme-help-desk-mixin)
|
|
||||||
|
|
|
||||||
|
|
@ -204,7 +204,6 @@
|
||||||
list?)
|
list?)
|
||||||
|
|
||||||
(drscheme:font:setup-preferences)
|
(drscheme:font:setup-preferences)
|
||||||
(drscheme:help-desk:add-help-desk-font-prefs #t)
|
|
||||||
(color-prefs:add-background-preferences-panel)
|
(color-prefs:add-background-preferences-panel)
|
||||||
(scheme:add-preferences-panel)
|
(scheme:add-preferences-panel)
|
||||||
(scheme:add-coloring-preferences-panel)
|
(scheme:add-coloring-preferences-panel)
|
||||||
|
|
|
||||||
|
|
@ -1325,12 +1325,6 @@
|
||||||
; ;
|
; ;
|
||||||
; ;
|
; ;
|
||||||
|
|
||||||
(drscheme:help-desk:open-url
|
|
||||||
(string? . -> . void?)
|
|
||||||
(url)
|
|
||||||
|
|
||||||
"Opens \\var{url} in a new help desk window.")
|
|
||||||
|
|
||||||
(drscheme:help-desk:help-desk
|
(drscheme:help-desk:help-desk
|
||||||
(case->
|
(case->
|
||||||
(-> void?)
|
(-> void?)
|
||||||
|
|
|
||||||
542
collects/help/bug-report.ss
Normal file
542
collects/help/bug-report.ss
Normal file
|
|
@ -0,0 +1,542 @@
|
||||||
|
|
||||||
|
(module bug-report mzscheme
|
||||||
|
(require (lib "string-constant.ss" "string-constants")
|
||||||
|
(lib "head.ss" "net")
|
||||||
|
(lib "mred.ss" "mred")
|
||||||
|
(lib "framework.ss" "framework")
|
||||||
|
(lib "class.ss")
|
||||||
|
(lib "etc.ss")
|
||||||
|
(lib "list.ss")
|
||||||
|
(lib "url.ss" "net")
|
||||||
|
(lib "uri-codec.ss" "net")
|
||||||
|
(lib "htmltext.ss" "browser")
|
||||||
|
(lib "dirs.ss" "setup")
|
||||||
|
"private/buginfo.ss"
|
||||||
|
"private/manuals.ss")
|
||||||
|
|
||||||
|
(provide help-desk:report-bug)
|
||||||
|
|
||||||
|
(define bug-www-server "bugs.plt-scheme.org")
|
||||||
|
(define bug-www-server-port 80)
|
||||||
|
|
||||||
|
;; this one should be defined by help desk.
|
||||||
|
(define frame-mixin
|
||||||
|
(namespace-variable-value 'help-desk:frame-mixin #f (lambda () (lambda (x) x))))
|
||||||
|
|
||||||
|
(preferences:set-default 'drscheme:email "" string?)
|
||||||
|
(preferences:set-default 'drscheme:full-name "" string?)
|
||||||
|
|
||||||
|
(define bug-frame%
|
||||||
|
(class (frame-mixin (frame:standard-menus-mixin frame:basic%))
|
||||||
|
(init title)
|
||||||
|
|
||||||
|
;; a bunch of stuff we don't want
|
||||||
|
(define/override (file-menu:between-print-and-close menu) (void))
|
||||||
|
(define/override (edit-menu:between-find-and-preferences menu) (void))
|
||||||
|
(define/override (file-menu:create-open?) #f)
|
||||||
|
(define/override (file-menu:create-open-recent?) #f)
|
||||||
|
(define/override (file-menu:create-new?) #f)
|
||||||
|
(define/override (file-menu:create-save?) #f)
|
||||||
|
(define/override (file-menu:create-revert?) #f)
|
||||||
|
|
||||||
|
(field (ok-to-close? #f))
|
||||||
|
(public set-ok-to-close)
|
||||||
|
(define (set-ok-to-close ok?) (set! ok-to-close? #t))
|
||||||
|
(define/augment (can-close?)
|
||||||
|
(or ok-to-close?
|
||||||
|
(ask-yes-or-no (string-constant cancel-bug-report?)
|
||||||
|
(string-constant are-you-sure-cancel-bug-report?)
|
||||||
|
this)))
|
||||||
|
|
||||||
|
(super-make-object title)))
|
||||||
|
|
||||||
|
|
||||||
|
(define (help-desk:report-bug)
|
||||||
|
(define bug-frame (instantiate bug-frame% () (title (string-constant bug-report-form))))
|
||||||
|
(define single (new panel:single% (parent (send bug-frame get-area-container))))
|
||||||
|
(define outermost-panel (make-object vertical-panel% single))
|
||||||
|
|
||||||
|
(define response-panel (new vertical-panel% (parent single)))
|
||||||
|
(define response-text (new (html-text-mixin text%) (auto-wrap #t)))
|
||||||
|
(define response-ec (new editor-canvas% (parent response-panel) (editor response-text)))
|
||||||
|
(define response-button-panel (new horizontal-panel%
|
||||||
|
(stretchable-height #f)
|
||||||
|
(parent response-panel)
|
||||||
|
(alignment '(right center))))
|
||||||
|
(define cancel-kill-thread #f)
|
||||||
|
(define response-reset (new button%
|
||||||
|
(parent response-button-panel)
|
||||||
|
(enabled #f)
|
||||||
|
(label (string-constant dialog-back))
|
||||||
|
(callback
|
||||||
|
(lambda (x y)
|
||||||
|
(switch-to-compose-view)))))
|
||||||
|
(define response-abort (new button%
|
||||||
|
(parent response-button-panel)
|
||||||
|
(enabled #f)
|
||||||
|
(callback
|
||||||
|
(lambda (x y)
|
||||||
|
(kill-thread cancel-kill-thread)
|
||||||
|
(switch-to-compose-view)))
|
||||||
|
(label (string-constant abort))))
|
||||||
|
(define response-close (new button%
|
||||||
|
(parent response-button-panel)
|
||||||
|
(enabled #f)
|
||||||
|
(callback (lambda (x y) (cleanup-frame)))
|
||||||
|
(label (string-constant close))))
|
||||||
|
(define stupid-internal-define-syntax1
|
||||||
|
(new grow-box-spacer-pane% (parent response-button-panel)))
|
||||||
|
|
||||||
|
(define top-panel (make-object vertical-panel% outermost-panel))
|
||||||
|
|
||||||
|
(define (switch-to-response-view)
|
||||||
|
(send response-text lock #f)
|
||||||
|
(send response-text erase)
|
||||||
|
(render-html-to-text ; hack to get nice text in
|
||||||
|
(open-input-string
|
||||||
|
" <br><br><br><br><br><div align=\"center\"><h2><b>Submitting bug report...</b></h2></div>")
|
||||||
|
response-text #t #f)
|
||||||
|
(send response-text lock #t)
|
||||||
|
(send single active-child response-panel))
|
||||||
|
(define (switch-to-compose-view)
|
||||||
|
(send single active-child outermost-panel)
|
||||||
|
(send (if (string=? "" (preferences:get 'drscheme:full-name))
|
||||||
|
name
|
||||||
|
summary)
|
||||||
|
focus))
|
||||||
|
|
||||||
|
(define lps null)
|
||||||
|
|
||||||
|
; build/label : ((union string (list-of string))
|
||||||
|
; (area-container<%> -> item<%>)
|
||||||
|
; boolean
|
||||||
|
; area-container<%>
|
||||||
|
; -> item<%>)
|
||||||
|
; constructs and arranges the gui objects for the bug report form
|
||||||
|
; effect: updates lps with the new label panel, for future alignment
|
||||||
|
(define build/label
|
||||||
|
(opt-lambda (text make-item top? [stretch? #f] [top-panel top-panel] [vertical? #f])
|
||||||
|
(let*-values ([(hp) (make-object (if vertical?
|
||||||
|
vertical-panel%
|
||||||
|
horizontal-panel%)
|
||||||
|
top-panel)]
|
||||||
|
[(lp) (make-object vertical-panel% hp)]
|
||||||
|
[(ip) (make-object vertical-panel% hp)]
|
||||||
|
[(label/s) (if (string? text)
|
||||||
|
(make-object message% text lp)
|
||||||
|
(map (lambda (s)
|
||||||
|
(make-object message% s lp))
|
||||||
|
text))]
|
||||||
|
[(item) (make-item ip)])
|
||||||
|
(set! lps (cons lp lps))
|
||||||
|
(unless stretch?
|
||||||
|
(send hp stretchable-height #f)
|
||||||
|
(send lp stretchable-height #f)
|
||||||
|
(send ip stretchable-height #f))
|
||||||
|
(send lp stretchable-width #f)
|
||||||
|
(send lp stretchable-height #f)
|
||||||
|
(send lp set-alignment (if vertical? 'left 'right) (if top? 'top 'center))
|
||||||
|
(send ip set-alignment 'left 'top)
|
||||||
|
item)))
|
||||||
|
|
||||||
|
(define (align-labels)
|
||||||
|
(let ([width (apply max (map (lambda (x) (send (car (send x get-children)) min-width))
|
||||||
|
lps))])
|
||||||
|
(for-each (lambda (x) (send x min-width width)) lps)))
|
||||||
|
|
||||||
|
(define name
|
||||||
|
(build/label
|
||||||
|
(string-constant bug-report-field-name)
|
||||||
|
(lambda (panel)
|
||||||
|
(keymap:call/text-keymap-initializer
|
||||||
|
(lambda ()
|
||||||
|
(make-object text-field% #f panel
|
||||||
|
(lambda (text event)
|
||||||
|
(preferences:set 'drscheme:full-name (send text get-value)))
|
||||||
|
(preferences:get 'drscheme:full-name)))))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define email
|
||||||
|
(build/label
|
||||||
|
(string-constant bug-report-field-email)
|
||||||
|
(lambda (panel)
|
||||||
|
(keymap:call/text-keymap-initializer
|
||||||
|
(lambda ()
|
||||||
|
(make-object text-field% #f panel
|
||||||
|
(lambda (text event)
|
||||||
|
(preferences:set 'drscheme:email (send text get-value)))
|
||||||
|
(preferences:get 'drscheme:email)))))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define summary
|
||||||
|
(build/label
|
||||||
|
(string-constant bug-report-field-summary)
|
||||||
|
(lambda (panel)
|
||||||
|
(keymap:call/text-keymap-initializer
|
||||||
|
(lambda ()
|
||||||
|
(make-object text-field% #f panel void))))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define severity
|
||||||
|
(build/label
|
||||||
|
(string-constant bug-report-field-severity)
|
||||||
|
(lambda (panel)
|
||||||
|
(make-object choice%
|
||||||
|
#f
|
||||||
|
(list "critical" "serious" "non-critical")
|
||||||
|
panel
|
||||||
|
void))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define bug-classes '(("software bug" "sw-bug")
|
||||||
|
("documentation bug" "doc-bug")
|
||||||
|
("change request" "change-request")
|
||||||
|
("support" "support")))
|
||||||
|
|
||||||
|
(define bug-class
|
||||||
|
(build/label
|
||||||
|
(string-constant bug-report-field-class)
|
||||||
|
(lambda (panel)
|
||||||
|
(make-object choice%
|
||||||
|
#f
|
||||||
|
(map car bug-classes)
|
||||||
|
panel
|
||||||
|
void))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define (translate-class class)
|
||||||
|
(cadr (assoc class bug-classes)))
|
||||||
|
|
||||||
|
(define (make-big-text label . args)
|
||||||
|
(let ([canvas
|
||||||
|
(apply
|
||||||
|
build/label
|
||||||
|
label
|
||||||
|
(lambda (panel)
|
||||||
|
(let* ([text (new (editor:standard-style-list-mixin
|
||||||
|
(editor:keymap-mixin
|
||||||
|
text:basic%)))]
|
||||||
|
[canvas (new canvas:basic%
|
||||||
|
(style '(hide-hscroll))
|
||||||
|
(parent panel)
|
||||||
|
(editor text))])
|
||||||
|
(send text set-paste-text-only #t)
|
||||||
|
(send text auto-wrap #t)
|
||||||
|
(send text set-styles-fixed #t)
|
||||||
|
canvas))
|
||||||
|
#t
|
||||||
|
args)])
|
||||||
|
(send canvas min-width 500)
|
||||||
|
(send canvas min-height 130)
|
||||||
|
(send canvas get-editor)
|
||||||
|
(send canvas allow-tab-exit #t)
|
||||||
|
canvas))
|
||||||
|
|
||||||
|
(define description (make-big-text (string-constant bug-report-field-description) #t))
|
||||||
|
(define reproduce (make-big-text (list (string-constant bug-report-field-reproduce1)
|
||||||
|
(string-constant bug-report-field-reproduce2))
|
||||||
|
#t))
|
||||||
|
|
||||||
|
(define synthesized-dialog (make-object dialog% (string-constant bug-report-synthesized-information)))
|
||||||
|
(define synthesized-panel (make-object vertical-panel% synthesized-dialog))
|
||||||
|
(define synthesized-button-panel
|
||||||
|
(new horizontal-panel% [parent synthesized-dialog]
|
||||||
|
[alignment '(right center)] [stretchable-height #f]))
|
||||||
|
(define synthesized-ok-button (make-object button% (string-constant ok) synthesized-button-panel
|
||||||
|
(lambda (x y)
|
||||||
|
(send synthesized-dialog show #f))))
|
||||||
|
(define synthesized-info-shown? #t)
|
||||||
|
(define (show-synthesized-info)
|
||||||
|
(send synthesized-dialog show #t))
|
||||||
|
|
||||||
|
(define version
|
||||||
|
(build/label
|
||||||
|
(string-constant bug-report-field-version)
|
||||||
|
(lambda (panel)
|
||||||
|
(keymap:call/text-keymap-initializer
|
||||||
|
(lambda ()
|
||||||
|
(make-object text-field% #f panel void ""))))
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
synthesized-panel
|
||||||
|
#f))
|
||||||
|
(define environment
|
||||||
|
(build/label
|
||||||
|
(string-constant bug-report-field-environment)
|
||||||
|
(lambda (panel)
|
||||||
|
(keymap:call/text-keymap-initializer
|
||||||
|
(lambda ()
|
||||||
|
(make-object text-field% #f panel void ""))))
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
synthesized-panel
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define human-language
|
||||||
|
(build/label
|
||||||
|
(string-constant bug-report-field-human-language)
|
||||||
|
(lambda (panel)
|
||||||
|
(keymap:call/text-keymap-initializer
|
||||||
|
(lambda ()
|
||||||
|
(make-object text-field% #f panel void ""))))
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
synthesized-panel))
|
||||||
|
|
||||||
|
(define memory-use
|
||||||
|
(build/label
|
||||||
|
(string-constant bug-report-field-memory-use)
|
||||||
|
(lambda (panel)
|
||||||
|
(keymap:call/text-keymap-initializer
|
||||||
|
(lambda ()
|
||||||
|
(make-object text-field% #f panel void ""))))
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
synthesized-panel))
|
||||||
|
|
||||||
|
(define docs-installed
|
||||||
|
(make-big-text
|
||||||
|
(string-constant bug-report-field-docs-installed)
|
||||||
|
#t
|
||||||
|
synthesized-panel))
|
||||||
|
|
||||||
|
(define collections
|
||||||
|
(make-big-text
|
||||||
|
(string-constant bug-report-field-collections)
|
||||||
|
#t
|
||||||
|
synthesized-panel))
|
||||||
|
|
||||||
|
(define extras
|
||||||
|
(map (lambda (bri)
|
||||||
|
(let ([label (bri-label bri)])
|
||||||
|
(cons
|
||||||
|
label
|
||||||
|
(build/label
|
||||||
|
label
|
||||||
|
(lambda (panel)
|
||||||
|
(let ([field
|
||||||
|
(keymap:call/text-keymap-initializer
|
||||||
|
(lambda ()
|
||||||
|
(make-object text-field% #f panel void "")))])
|
||||||
|
(send field set-value (bri-value bri))
|
||||||
|
field))
|
||||||
|
#f
|
||||||
|
#f
|
||||||
|
synthesized-panel))))
|
||||||
|
(get-bug-report-infos)))
|
||||||
|
|
||||||
|
(define button-panel
|
||||||
|
(new horizontal-panel% [parent outermost-panel]
|
||||||
|
[alignment '(right center)] [stretchable-height #f]))
|
||||||
|
(define synthesized-button (make-object button%
|
||||||
|
(string-constant bug-report-show-synthesized-info)
|
||||||
|
button-panel (lambda x (show-synthesized-info))))
|
||||||
|
(define _spacer (new horizontal-pane% (parent button-panel)))
|
||||||
|
(define cancel-button (make-object button% (string-constant cancel) button-panel (lambda x (cancel))))
|
||||||
|
(define ok-button (make-object button% (string-constant bug-report-submit) button-panel (lambda x (ok))))
|
||||||
|
(define _grow-box
|
||||||
|
(new grow-box-spacer-pane% [parent button-panel]))
|
||||||
|
|
||||||
|
(define (get-query)
|
||||||
|
(list (cons 'help-desk "true")
|
||||||
|
(cons 'replyto (preferences:get 'drscheme:email))
|
||||||
|
(cons 'originator (preferences:get 'drscheme:full-name))
|
||||||
|
(cons 'subject (send summary get-value))
|
||||||
|
(cons 'severity (send severity get-string-selection))
|
||||||
|
(cons 'class (translate-class (send bug-class get-string-selection)))
|
||||||
|
(cons 'release (send version get-value))
|
||||||
|
(cons 'description (apply string-append (map (lambda (x) (string-append x "\n"))
|
||||||
|
(get-strings description))))
|
||||||
|
(cons 'how-to-repeat (apply string-append
|
||||||
|
(map (lambda (x) (string-append x "\n"))
|
||||||
|
(get-strings reproduce))))
|
||||||
|
(cons 'platform (get-environment))))
|
||||||
|
|
||||||
|
(define (get-environment)
|
||||||
|
(string-append (send environment get-value)
|
||||||
|
"\n"
|
||||||
|
"Docs Installed:\n"
|
||||||
|
(format "~a" (send (send docs-installed get-editor) get-text))
|
||||||
|
"\n"
|
||||||
|
(format "Human Language: ~a\n" (send human-language get-value))
|
||||||
|
(format "(current-memory-use) ~a\n" (send memory-use get-value))
|
||||||
|
"\nCollections:\n"
|
||||||
|
(format "~a" (send (send collections get-editor) get-text))
|
||||||
|
"\n"
|
||||||
|
(apply
|
||||||
|
string-append
|
||||||
|
(map (lambda (extra)
|
||||||
|
(format "~a: ~a\n"
|
||||||
|
(car extra)
|
||||||
|
(send (cdr extra) get-value)))
|
||||||
|
extras))))
|
||||||
|
|
||||||
|
; send-bug-report : (-> void)
|
||||||
|
;; initiates sending the bug report and switches the GUI's mode
|
||||||
|
(define (send-bug-report)
|
||||||
|
(letrec ([query (get-query)]
|
||||||
|
[url
|
||||||
|
(string->url (format "http://~a:~a/cgi-bin/bug-report"
|
||||||
|
bug-www-server
|
||||||
|
bug-www-server-port))]
|
||||||
|
[post-data
|
||||||
|
(parameterize ([current-alist-separator-mode 'amp])
|
||||||
|
(string->bytes/utf-8 (alist->form-urlencoded query)))]
|
||||||
|
[http-thread
|
||||||
|
(parameterize ([current-custodian (make-custodian)])
|
||||||
|
(thread
|
||||||
|
(lambda ()
|
||||||
|
(with-handlers ([(lambda (x) (exn:break? x))
|
||||||
|
(lambda (x) (void))]
|
||||||
|
[(lambda (x) (not (exn:break? x)))
|
||||||
|
(lambda (x)
|
||||||
|
(queue-callback
|
||||||
|
(lambda ()
|
||||||
|
(switch-to-compose-view)
|
||||||
|
(message-box
|
||||||
|
(string-constant error-sending-bug-report)
|
||||||
|
(format (string-constant error-sending-bug-report-expln)
|
||||||
|
(if (exn? x)
|
||||||
|
(exn-message x)
|
||||||
|
(format "~s" x)))))))])
|
||||||
|
(parameterize ([current-alist-separator-mode 'amp])
|
||||||
|
(call/input-url
|
||||||
|
url
|
||||||
|
(case-lambda
|
||||||
|
[(x) (post-pure-port x post-data)]
|
||||||
|
[(x y) (post-pure-port x post-data y)])
|
||||||
|
(lambda (port)
|
||||||
|
(send response-text lock #f)
|
||||||
|
(send response-text erase)
|
||||||
|
(render-html-to-text port response-text #t #f)
|
||||||
|
(send response-text lock #t))))
|
||||||
|
(queue-callback
|
||||||
|
(lambda ()
|
||||||
|
(send response-abort enable #f)
|
||||||
|
(send response-reset enable #t)
|
||||||
|
(send response-close enable #t)
|
||||||
|
(set! cancel-kill-thread #f)
|
||||||
|
(send bug-frame set-ok-to-close #t)
|
||||||
|
(send response-close focus)))))))])
|
||||||
|
(set! cancel-kill-thread http-thread)
|
||||||
|
(send response-abort enable #t)
|
||||||
|
(switch-to-response-view)))
|
||||||
|
|
||||||
|
(define (get-strings canvas)
|
||||||
|
(let ([t (send canvas get-editor)])
|
||||||
|
(let loop ([n 0])
|
||||||
|
(cond
|
||||||
|
[(> n (send t last-paragraph)) null]
|
||||||
|
[else (cons (send t get-text
|
||||||
|
(send t paragraph-start-position n)
|
||||||
|
(send t paragraph-end-position n))
|
||||||
|
(loop (+ n 1)))]))))
|
||||||
|
|
||||||
|
(define (sanity-checking)
|
||||||
|
(let ([no-value?
|
||||||
|
(lambda (f)
|
||||||
|
(cond
|
||||||
|
[(is-a? f editor-canvas%)
|
||||||
|
(= 0 (send (send f get-editor) last-position))]
|
||||||
|
[else (string=? "" (send f get-value))]))])
|
||||||
|
(let/ec done-checking
|
||||||
|
(for-each
|
||||||
|
(lambda (field field-name)
|
||||||
|
(when (no-value? field)
|
||||||
|
(message-box (string-constant illegal-bug-report)
|
||||||
|
(format (string-constant pls-fill-in-field) field-name))
|
||||||
|
(done-checking #f)))
|
||||||
|
(list name summary)
|
||||||
|
(list (string-constant bug-report-field-name)
|
||||||
|
(string-constant bug-report-field-summary)))
|
||||||
|
|
||||||
|
(when (and (no-value? description)
|
||||||
|
(no-value? reproduce))
|
||||||
|
(message-box (string-constant illegal-bug-report)
|
||||||
|
(string-constant pls-fill-in-either-description-or-reproduce))
|
||||||
|
(done-checking #f))
|
||||||
|
|
||||||
|
(unless (regexp-match #rx"@" (or (preferences:get 'drscheme:email) ""))
|
||||||
|
(message-box (string-constant illegal-bug-report)
|
||||||
|
(string-constant malformed-email-address))
|
||||||
|
(done-checking #f))
|
||||||
|
(done-checking #t))))
|
||||||
|
|
||||||
|
(define (ok)
|
||||||
|
(when (sanity-checking)
|
||||||
|
(send-bug-report)))
|
||||||
|
|
||||||
|
(define (cancel)
|
||||||
|
(cleanup-frame))
|
||||||
|
|
||||||
|
(define (cleanup-frame)
|
||||||
|
(send bug-frame close))
|
||||||
|
|
||||||
|
(define (directories-contents dirs)
|
||||||
|
(map (lambda (d)
|
||||||
|
(cons (path->string d)
|
||||||
|
(if (directory-exists? d)
|
||||||
|
(map path->string (directory-list d))
|
||||||
|
'(non-existent-path))))
|
||||||
|
dirs))
|
||||||
|
|
||||||
|
(define (split-by-directories dirs split-by)
|
||||||
|
(let ([res (append (map list (map path->string split-by)) '((*)))]
|
||||||
|
[dirs (map path->string dirs)])
|
||||||
|
(for-each
|
||||||
|
(lambda (d)
|
||||||
|
(let* ([l (string-length d)]
|
||||||
|
[x (assf
|
||||||
|
(lambda (d2)
|
||||||
|
(or (eq? d2 '*)
|
||||||
|
(let ([l2 (string-length d2)])
|
||||||
|
(and (< l2 l) (equal? d2 (substring d 0 l2))
|
||||||
|
(member (string-ref d l2) '(#\/ #\\))))))
|
||||||
|
res)])
|
||||||
|
(append x (list (if (string? (car x))
|
||||||
|
(substring d (add1 (string-length (car x))))
|
||||||
|
d)))))
|
||||||
|
dirs)
|
||||||
|
(filter (lambda (x) (pair? (cdr x))) res)))
|
||||||
|
|
||||||
|
(send response-ec allow-tab-exit #t)
|
||||||
|
|
||||||
|
(send severity set-selection 1)
|
||||||
|
(send version set-value (format "~a" (version:version)))
|
||||||
|
|
||||||
|
(send environment set-value
|
||||||
|
(format "~a ~s (~a) (get-display-depth) = ~a"
|
||||||
|
(system-type)
|
||||||
|
(system-type 'machine)
|
||||||
|
(system-library-subpath)
|
||||||
|
(get-display-depth)))
|
||||||
|
|
||||||
|
(send (send collections get-editor)
|
||||||
|
insert
|
||||||
|
(format "~s" (directories-contents (get-collects-search-dirs))))
|
||||||
|
|
||||||
|
(send human-language set-value (format "~a" (this-language)))
|
||||||
|
(send memory-use set-value (format "~a" (current-memory-use)))
|
||||||
|
|
||||||
|
(send (send collections get-editor) auto-wrap #t)
|
||||||
|
(send (send docs-installed get-editor) auto-wrap #t)
|
||||||
|
|
||||||
|
;; Currently, the help-menu is left empty
|
||||||
|
(frame:remove-empty-menus bug-frame)
|
||||||
|
|
||||||
|
(align-labels)
|
||||||
|
(switch-to-compose-view)
|
||||||
|
|
||||||
|
(send (send docs-installed get-editor) insert
|
||||||
|
(format "~s" (split-by-directories (find-doc-directories)
|
||||||
|
(get-doc-search-dirs))))
|
||||||
|
|
||||||
|
(send bug-frame show #t))
|
||||||
|
|
||||||
|
(define (ask-yes-or-no title msg parent)
|
||||||
|
(gui-utils:get-choice msg
|
||||||
|
(string-constant yes)
|
||||||
|
(string-constant no)
|
||||||
|
title
|
||||||
|
#f
|
||||||
|
parent)))
|
||||||
3
collects/help/help-desk-urls.ss
Normal file
3
collects/help/help-desk-urls.ss
Normal file
|
|
@ -0,0 +1,3 @@
|
||||||
|
(module help-desk-urls mzscheme
|
||||||
|
(require "servlets/private/url.ss")
|
||||||
|
(provide (all-from "servlets/private/url.ss")))
|
||||||
21
collects/help/private/buginfo.ss
Normal file
21
collects/help/private/buginfo.ss
Normal file
|
|
@ -0,0 +1,21 @@
|
||||||
|
(module buginfo mzscheme
|
||||||
|
|
||||||
|
(provide set-bug-report-info!
|
||||||
|
get-bug-report-infos
|
||||||
|
bri-label
|
||||||
|
bri-value)
|
||||||
|
|
||||||
|
(define-struct bri (label get-value))
|
||||||
|
(define (bri-value bri) ((bri-get-value bri)))
|
||||||
|
|
||||||
|
; update with symbol/string assoc list
|
||||||
|
(define bug-report-infos null)
|
||||||
|
|
||||||
|
(define (set-bug-report-info! str thunk)
|
||||||
|
(set! bug-report-infos (cons (make-bri str thunk) bug-report-infos)))
|
||||||
|
|
||||||
|
(define (get-bug-report-infos) bug-report-infos))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
65
collects/help/private/colldocs.ss
Normal file
65
collects/help/private/colldocs.ss
Normal file
|
|
@ -0,0 +1,65 @@
|
||||||
|
(module colldocs mzscheme
|
||||||
|
(require (lib "list.ss")
|
||||||
|
(lib "getinfo.ss" "setup")
|
||||||
|
(lib "contract.ss"))
|
||||||
|
|
||||||
|
;; find-doc-directory-records : -> (list-of directory-record)
|
||||||
|
;; Returns directory records containing doc.txt files, sorted first
|
||||||
|
;; by lib/planet, then by path.
|
||||||
|
(define (find-doc-directory-records)
|
||||||
|
(define allrecs
|
||||||
|
(find-relevant-directory-records '(doc.txt) 'all-available))
|
||||||
|
(define (rec<? a b)
|
||||||
|
(bytes<? (path->bytes (directory-record-path a))
|
||||||
|
(path->bytes (directory-record-path b))))
|
||||||
|
(define (librec? dirrec)
|
||||||
|
(let ([spec (directory-record-spec dirrec)])
|
||||||
|
(and (pair? spec) (eq? (car spec) 'lib))))
|
||||||
|
(append (sort (filter librec? allrecs) rec<?)
|
||||||
|
(sort (filter (lambda (x) (not (librec? x))) allrecs) rec<?)))
|
||||||
|
|
||||||
|
;; colldocs : -> (values (list-of (list string path)) (list-of string))
|
||||||
|
;; Returns two lists having equal length. Each item in the first list
|
||||||
|
;; contains a list containing a string (the directory) and a path (to
|
||||||
|
;; the doc.txt file). The second list contains the corresponding descriptive
|
||||||
|
;; names.
|
||||||
|
(define (colldocs)
|
||||||
|
(let loop ([dirrecs (find-doc-directory-records)]
|
||||||
|
[docs null]
|
||||||
|
[names null])
|
||||||
|
(cond
|
||||||
|
[(null? dirrecs) (values (reverse docs) (reverse names))]
|
||||||
|
[else
|
||||||
|
(let* ([dirrec (car dirrecs)]
|
||||||
|
[dir (directory-record-path dirrec)]
|
||||||
|
[info-proc (get-info/full dir)])
|
||||||
|
(if info-proc
|
||||||
|
(let ([doc.txt-path (info-proc 'doc.txt (lambda () #f))]
|
||||||
|
[name (info-proc 'name (lambda () #f))])
|
||||||
|
(if (and (path-string? doc.txt-path)
|
||||||
|
(string? name))
|
||||||
|
(loop (cdr dirrecs)
|
||||||
|
(cons (list dir (string->path doc.txt-path))
|
||||||
|
docs)
|
||||||
|
(cons (pleasant-name name dirrec)
|
||||||
|
names))
|
||||||
|
(loop (cdr dirrecs) docs names)))
|
||||||
|
(loop (cdr dirrecs) docs names)))])))
|
||||||
|
|
||||||
|
;; pleasant-name : string directory-record -> string
|
||||||
|
;; Generates a descriptive name for the collection/package.
|
||||||
|
(define (pleasant-name name dirrec)
|
||||||
|
(let ([spec (directory-record-spec dirrec)])
|
||||||
|
(if (and (pair? spec) (list? spec))
|
||||||
|
(case (car spec)
|
||||||
|
((lib) (format "~a collection" name))
|
||||||
|
((planet) (format "~a package ~s"
|
||||||
|
name
|
||||||
|
`(,@(cdr spec)
|
||||||
|
,(directory-record-maj dirrec)
|
||||||
|
,(directory-record-min dirrec)))))
|
||||||
|
name)))
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[colldocs (-> (values (listof (list/c path? path?))
|
||||||
|
(listof string?)))]))
|
||||||
65
collects/help/private/docpos.ss
Normal file
65
collects/help/private/docpos.ss
Normal file
|
|
@ -0,0 +1,65 @@
|
||||||
|
(module docpos mzscheme
|
||||||
|
(require (lib "list.ss")
|
||||||
|
(lib "contract.ss"))
|
||||||
|
|
||||||
|
;; Define an order on the standard docs.
|
||||||
|
(define (standard-html-doc-position d)
|
||||||
|
(let ([str (path->string d)])
|
||||||
|
(if (equal? str "help")
|
||||||
|
-1
|
||||||
|
(let ([line (assoc str docs-and-positions)])
|
||||||
|
(if line
|
||||||
|
(caddr line)
|
||||||
|
100)))))
|
||||||
|
|
||||||
|
|
||||||
|
;; (listof (list string string number))
|
||||||
|
;; the first string is the collection name
|
||||||
|
;; the second string is the title of the the manual
|
||||||
|
;; the number determines the sorting order for the manuals in the manuals page
|
||||||
|
(define docs-and-positions
|
||||||
|
`(("r5rs" "Revised^5 Report on the Algorithmic Language Scheme" -50)
|
||||||
|
("mzscheme" "PLT MzScheme: Language Manual" -49)
|
||||||
|
("mred" "PLT MrEd: Graphical Toolbox Manual" -48)
|
||||||
|
|
||||||
|
("tour" "A Brief Tour of DrScheme" 0)
|
||||||
|
("drscheme" "PLT DrScheme: Programming Environment Manual" 1)
|
||||||
|
|
||||||
|
("srfi" "SRFI documents inside PLT" 3)
|
||||||
|
|
||||||
|
("mzlib" "PLT MzLib: Libraries Manual" 5)
|
||||||
|
("misclib" "PLT Miscellaneous Libraries: Reference Manual" 6)
|
||||||
|
("mrlib" "PLT MrLib: Graphical Libraries Manual" 7)
|
||||||
|
("framework" "PLT Framework: GUI Application Framework" 8)
|
||||||
|
|
||||||
|
("mzc" "PLT mzc: MzScheme Compiler Manual" 10)
|
||||||
|
("foreign" "PLT Foreign Interface Manual" 10)
|
||||||
|
|
||||||
|
("tools" "PLT Tools: DrScheme Extension Manual" 30)
|
||||||
|
("insidemz" "Inside PLT MzScheme" 50)
|
||||||
|
|
||||||
|
("web-server" "Web Server Manual" 60)
|
||||||
|
("swindle" "Swindle Manual" 61)
|
||||||
|
("plot" "PLoT Manual" 62)
|
||||||
|
|
||||||
|
("t-y-scheme" "Teach Yourself Scheme in Fixnum Days" 100)
|
||||||
|
("tex2page" "TeX2page" 101)
|
||||||
|
|
||||||
|
("beginning" "Beginning Student Language" 200)
|
||||||
|
("beginning-abbr" "Beginning Student with List Abbreviations Language" 201)
|
||||||
|
("intermediate" "Intermediate Student Language" 202)
|
||||||
|
("intermediate-lambda" "Intermediate Student with Lambda Language" 203)
|
||||||
|
("advanced" "Advanced Student Language" 204)
|
||||||
|
("teachpack" "Teachpacks for How to Design Programs" 205)
|
||||||
|
("teachpack-htdc" "Teachpacks for How to Design Classes" 206)
|
||||||
|
|
||||||
|
("profj-beginner" "ProfessorJ Beginner Language" 210)
|
||||||
|
("profj-intermediate" "ProfessorJ Intermediate Language" 211)
|
||||||
|
("profj-intermediate-access" "ProfessorJ Intermediate + access Language" 212)
|
||||||
|
("profj-advanced" "ProfessorJ Advanced Language" 213)))
|
||||||
|
|
||||||
|
(define known-docs (map (lambda (x) (cons (string->path (car x)) (cadr x))) docs-and-positions))
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[standard-html-doc-position (path? . -> . number?)]
|
||||||
|
[known-docs (listof (cons/c path? string?))]))
|
||||||
79
collects/help/private/finddoc.ss
Normal file
79
collects/help/private/finddoc.ss
Normal file
|
|
@ -0,0 +1,79 @@
|
||||||
|
(module finddoc mzscheme
|
||||||
|
(require (lib "dirs.ss" "setup")
|
||||||
|
(lib "match.ss")
|
||||||
|
"path.ss"
|
||||||
|
"get-help-url.ss")
|
||||||
|
|
||||||
|
(provide finddoc
|
||||||
|
finddoc-page
|
||||||
|
finddoc-page-anchor
|
||||||
|
find-doc-directory)
|
||||||
|
|
||||||
|
;; Creates a "file:" link into the indicated manual.
|
||||||
|
;; The link doesn't go to a particular anchor,
|
||||||
|
;; because "file:" does not support that.
|
||||||
|
(define (finddoc manual index-key label)
|
||||||
|
(match (lookup manual index-key label)
|
||||||
|
[(docdir index-key filename anchor title)
|
||||||
|
`(a ((href ,(string-append
|
||||||
|
"file:" (build-path docdir filename))))
|
||||||
|
,label)]
|
||||||
|
[m m]))
|
||||||
|
|
||||||
|
; finddoc-page-help : string string boolean -> string
|
||||||
|
; return url to the page where index-key is in manual,
|
||||||
|
; optionally append an anchor
|
||||||
|
(define (finddoc-page-help manual index-key anchor?)
|
||||||
|
(match (lookup manual index-key "dummy")
|
||||||
|
[(docdir index-key filename anchor title)
|
||||||
|
(cond
|
||||||
|
[(servlet-path? (string->path filename))
|
||||||
|
(string-append
|
||||||
|
filename (if anchor? (string-append "#" anchor) ""))]
|
||||||
|
[else
|
||||||
|
(get-help-url (build-path docdir filename) anchor)])]
|
||||||
|
[_ (error (format "Error finding index \"~a\" in manual \"~a\""
|
||||||
|
index-key manual))]))
|
||||||
|
|
||||||
|
; finddoc-page : string string -> string
|
||||||
|
; returns path for use by PLT Web server
|
||||||
|
; path is of form /doc/manual/page, or
|
||||||
|
; /servlet/<rest-of-path>
|
||||||
|
(define (finddoc-page manual index-key)
|
||||||
|
(finddoc-page-help manual index-key #f))
|
||||||
|
|
||||||
|
; finddoc-page-anchor : string string -> string
|
||||||
|
; returns path (with anchor) for use by PLT Web server
|
||||||
|
; path is of form /doc/manual/page#anchor, or
|
||||||
|
; /servlet/<rest-of-path>#anchor
|
||||||
|
(define (finddoc-page-anchor manual index-key)
|
||||||
|
(finddoc-page-help manual index-key #t))
|
||||||
|
|
||||||
|
(define ht (make-hash-table))
|
||||||
|
|
||||||
|
;; returns (list docdir index-key filename anchor title)
|
||||||
|
;; or throws an error
|
||||||
|
(define (lookup manual index-key label)
|
||||||
|
(let* ([key (string->symbol manual)]
|
||||||
|
[docdir (find-doc-directory manual)]
|
||||||
|
[l (hash-table-get ht key
|
||||||
|
(lambda ()
|
||||||
|
(let ([f (and docdir (build-path docdir "hdindex"))])
|
||||||
|
(if (and f (file-exists? f))
|
||||||
|
(let ([l (with-input-from-file f read)])
|
||||||
|
(hash-table-put! ht key l)
|
||||||
|
l)
|
||||||
|
(error 'finddoc "manual index ~s not installed" manual)))))]
|
||||||
|
[m (assoc index-key l)])
|
||||||
|
(if m
|
||||||
|
(cons docdir m)
|
||||||
|
(error 'finddoc "index key ~s not found in manual ~s" index-key manual))))
|
||||||
|
|
||||||
|
;; finds the full path of the doc directory, if one exists
|
||||||
|
;; input is just the short name of the directory (as a path)
|
||||||
|
(define (find-doc-directory doc)
|
||||||
|
(ormap (lambda (d)
|
||||||
|
(let ([p (build-path d doc)])
|
||||||
|
(and (directory-exists? p)
|
||||||
|
p)))
|
||||||
|
(get-doc-search-dirs))))
|
||||||
68
collects/help/private/get-help-url.ss
Normal file
68
collects/help/private/get-help-url.ss
Normal file
|
|
@ -0,0 +1,68 @@
|
||||||
|
(module get-help-url mzscheme
|
||||||
|
|
||||||
|
#| Library responsible for turning a path on disk into a URL the help desk can use |#
|
||||||
|
(require (lib "file.ss")
|
||||||
|
"internal-hp.ss"
|
||||||
|
(lib "contract.ss")
|
||||||
|
(lib "etc.ss")
|
||||||
|
(lib "config.ss" "planet")
|
||||||
|
(lib "dirs.ss" "setup"))
|
||||||
|
|
||||||
|
; given a manual path, convert to absolute Web path
|
||||||
|
; manual path is an anchored path to a doc manual, never a servlet
|
||||||
|
(define get-help-url
|
||||||
|
(opt-lambda (manual-path [anchor #f])
|
||||||
|
(let ([segments (explode-path (normalize-path manual-path))])
|
||||||
|
(let loop ([candidates manual-path-candidates])
|
||||||
|
(cond
|
||||||
|
;; shouldn't happen, unless documentation is outside
|
||||||
|
;; the set of doc dirs:
|
||||||
|
[(null? candidates) "/cannot-find-docs.html"]
|
||||||
|
[else
|
||||||
|
(let ([candidate (car candidates)])
|
||||||
|
(cond
|
||||||
|
[(subpath/tail (car candidate) segments)
|
||||||
|
=>
|
||||||
|
(λ (l-o-path)
|
||||||
|
((cadr candidate) l-o-path anchor))]
|
||||||
|
[else
|
||||||
|
(loop (cdr candidates))]))])))))
|
||||||
|
|
||||||
|
(define manual-path-candidates '())
|
||||||
|
(define (maybe-add-candidate candidate host)
|
||||||
|
(with-handlers ([exn:fail? void])
|
||||||
|
(set! manual-path-candidates
|
||||||
|
(cons (list (explode-path (normalize-path candidate))
|
||||||
|
(λ (segments anchor)
|
||||||
|
(format "http://~a:~a/servlets/static.ss/~a~a~a"
|
||||||
|
internal-host
|
||||||
|
(internal-port)
|
||||||
|
host
|
||||||
|
(apply string-append (map (λ (x) (format "/~a" (path->string x)))
|
||||||
|
segments))
|
||||||
|
(if anchor
|
||||||
|
(string-append "#" anchor)
|
||||||
|
""))))
|
||||||
|
manual-path-candidates))))
|
||||||
|
|
||||||
|
;; Add doc dirs later, so that they take precedence:
|
||||||
|
(maybe-add-candidate (PLANET-DIR) planet-host)
|
||||||
|
(for-each (λ (dir host) (maybe-add-candidate dir host))
|
||||||
|
(append collects-dirs doc-dirs)
|
||||||
|
(append collects-hosts doc-hosts))
|
||||||
|
|
||||||
|
(define (subpath/tail short long)
|
||||||
|
(let loop ([short short]
|
||||||
|
[long long])
|
||||||
|
(cond
|
||||||
|
[(null? short) long]
|
||||||
|
[(null? long) #f]
|
||||||
|
[(equal? (car short) (car long))
|
||||||
|
(loop (cdr short) (cdr long))]
|
||||||
|
[else #f])))
|
||||||
|
|
||||||
|
(provide/contract (get-help-url
|
||||||
|
(opt->
|
||||||
|
((or/c path? path-string?))
|
||||||
|
(string?)
|
||||||
|
string?))))
|
||||||
54
collects/help/private/internal-hp.ss
Normal file
54
collects/help/private/internal-hp.ss
Normal file
|
|
@ -0,0 +1,54 @@
|
||||||
|
(module internal-hp mzscheme
|
||||||
|
(require (lib "dirs.ss" "setup")
|
||||||
|
(lib "config.ss" "planet")
|
||||||
|
"options.ss")
|
||||||
|
(provide internal-port
|
||||||
|
is-internal-host? internal-host
|
||||||
|
collects-hosts collects-dirs
|
||||||
|
doc-hosts doc-dirs
|
||||||
|
planet-host)
|
||||||
|
|
||||||
|
;; Hostnames defined here should not exist as real machines
|
||||||
|
|
||||||
|
;; The general idea is that there's one "virtual" host for
|
||||||
|
;; every filesystem tree that we need to access.
|
||||||
|
;; (now we use static.ss/host/yadayda instead of the virtual
|
||||||
|
;; host docX.localhost, but we still need to keep track of
|
||||||
|
;; the file system roots)
|
||||||
|
;; The "get-help-url.ss" library provides a function to
|
||||||
|
;; convert a path into a suitable URL (i.e., a URL using
|
||||||
|
;; the right virtual host).
|
||||||
|
;; The "gui.ss" library performs a bit of extra URL
|
||||||
|
;; processing at the last minute, sometimes switching
|
||||||
|
;; a URL for a manual to a different host. (That's needed
|
||||||
|
;; when cross-manual references are implemented as relative
|
||||||
|
;; URLs.)
|
||||||
|
|
||||||
|
(define internal-host "localhost")
|
||||||
|
|
||||||
|
(define (is-internal-host? str)
|
||||||
|
(member str all-internal-hosts))
|
||||||
|
|
||||||
|
(define (generate-hosts prefix dirs)
|
||||||
|
(let loop ([dirs dirs][n 0])
|
||||||
|
(if (null? dirs)
|
||||||
|
null
|
||||||
|
(cons (format "~a~a" prefix n)
|
||||||
|
(loop (cdr dirs) (add1 n))))))
|
||||||
|
|
||||||
|
(define planet-host "planet")
|
||||||
|
|
||||||
|
(define collects-dirs
|
||||||
|
(get-collects-search-dirs))
|
||||||
|
(define collects-hosts
|
||||||
|
(generate-hosts "collects" collects-dirs))
|
||||||
|
|
||||||
|
(define doc-dirs
|
||||||
|
(get-doc-search-dirs))
|
||||||
|
(define doc-hosts
|
||||||
|
(generate-hosts "doc" doc-dirs))
|
||||||
|
|
||||||
|
(define all-internal-hosts
|
||||||
|
(append (list internal-host planet-host)
|
||||||
|
collects-hosts
|
||||||
|
doc-hosts)))
|
||||||
380
collects/help/private/manuals.ss
Normal file
380
collects/help/private/manuals.ss
Normal file
|
|
@ -0,0 +1,380 @@
|
||||||
|
(module manuals mzscheme
|
||||||
|
(require (lib "list.ss")
|
||||||
|
(lib "date.ss")
|
||||||
|
(lib "string-constant.ss" "string-constants")
|
||||||
|
(lib "xml.ss" "xml")
|
||||||
|
(lib "contract.ss")
|
||||||
|
(lib "getinfo.ss" "setup")
|
||||||
|
(lib "uri-codec.ss" "net")
|
||||||
|
(lib "dirs.ss" "setup")
|
||||||
|
(lib "match.ss")
|
||||||
|
"finddoc.ss"
|
||||||
|
"colldocs.ss"
|
||||||
|
"docpos.ss"
|
||||||
|
"standard-urls.ss"
|
||||||
|
"get-help-url.ss"
|
||||||
|
"../servlets/private/util.ss")
|
||||||
|
|
||||||
|
;; type sec = (make-sec name regexp (listof regexp))
|
||||||
|
(define-struct sec (name reg seps))
|
||||||
|
|
||||||
|
;; sections : (listof sec)
|
||||||
|
;; determines the section breakdown for the manuals
|
||||||
|
;; elements in the outer list:
|
||||||
|
;; string : name of section
|
||||||
|
;; predicate : determines if a manual is in the section (based on its title)
|
||||||
|
;; breaks -- where to insert newlines
|
||||||
|
(define sections
|
||||||
|
(list (make-sec "Getting started"
|
||||||
|
#rx"(Tour)|(Teach Yourself)"
|
||||||
|
'())
|
||||||
|
(make-sec "Languages"
|
||||||
|
#rx"Language|MrEd"
|
||||||
|
'(#rx"Beginning Student" #rx"ProfessorJ Beginner"))
|
||||||
|
(make-sec "Tools" #rx"PLT DrScheme|PLT mzc|TeX2page|Web Server|PLoT" '())
|
||||||
|
(make-sec "Libraries" #rx"SRFI|MzLib|Framework|PLT Miscellaneous|Teachpack|Swindle" '())
|
||||||
|
(make-sec "Writing extensions" #rx"Tools|Inside|Foreign" '())
|
||||||
|
(make-sec "Other" #rx"" '())))
|
||||||
|
|
||||||
|
; main-manual-page : string -> xexpr
|
||||||
|
; return link to main manual page of a doc collection, like "mred"
|
||||||
|
(define (main-manual-page manual)
|
||||||
|
(let* ([entry (assoc (string->path manual) known-docs)]
|
||||||
|
[name (or (and entry (cdr entry))
|
||||||
|
manual)]
|
||||||
|
[doc-dir (find-doc-directory manual)])
|
||||||
|
(if doc-dir
|
||||||
|
(let ([href (get-help-url doc-dir)])
|
||||||
|
`(A ((HREF ,href)) ,name))
|
||||||
|
name)))
|
||||||
|
|
||||||
|
; manual-entry: string string string -> xexpr
|
||||||
|
; man is manual name
|
||||||
|
; ndx is index into the manual
|
||||||
|
; txt is the link text
|
||||||
|
(define (manual-entry man ndx txt)
|
||||||
|
(with-handlers ([exn:fail?
|
||||||
|
;; warning: if the index file isn't present, this page
|
||||||
|
(lambda (x)
|
||||||
|
`(font ((color "red")) ,txt " [" ,(exn-message x) "]"))])
|
||||||
|
`(A ((HREF ,(finddoc-page man ndx))) ,txt)))
|
||||||
|
|
||||||
|
(define (basename path)
|
||||||
|
(let-values ([(dir name dir?) (split-path path)]) name))
|
||||||
|
|
||||||
|
(define (find-doc-names)
|
||||||
|
(let* ([dirs (find-doc-directories)]
|
||||||
|
[installed (map basename dirs)]
|
||||||
|
[uninstalled (filter (lambda (x) (not (member (car x) installed)))
|
||||||
|
known-docs)])
|
||||||
|
(append (map (lambda (short-name long-name)
|
||||||
|
(cons short-name (get-doc-name long-name)))
|
||||||
|
installed dirs)
|
||||||
|
uninstalled)))
|
||||||
|
|
||||||
|
;; find-doc-directories : -> (listof path)
|
||||||
|
;; constructs a sorted list of directories where documentation may reside.
|
||||||
|
(define (find-doc-directories)
|
||||||
|
(let ([unsorted (append (find-info.ss-doc-directories)
|
||||||
|
(find-doc-directories-in-toplevel-docs))])
|
||||||
|
(sort unsorted compare-docs)))
|
||||||
|
|
||||||
|
(define (find-info.ss-doc-directories)
|
||||||
|
(let ([dirs (find-relevant-directories '(html-docs) 'all-available)])
|
||||||
|
(let loop ([dirs dirs])
|
||||||
|
(cond
|
||||||
|
[(null? dirs) null]
|
||||||
|
[else (let* ([dir (car dirs)]
|
||||||
|
[info (get-info/full dir)])
|
||||||
|
(cond
|
||||||
|
[info
|
||||||
|
(let ([html-doc-paths (info 'html-docs (lambda () #f))])
|
||||||
|
(cond
|
||||||
|
[(and (list? html-doc-paths)
|
||||||
|
(andmap path-string? html-doc-paths))
|
||||||
|
(let ([candidates (map (lambda (x) (build-path dir x)) html-doc-paths)])
|
||||||
|
(for-each (λ (c)
|
||||||
|
(unless (directory-exists? c)
|
||||||
|
(fprintf (current-error-port)
|
||||||
|
"found reference to ~a in html-docs for ~a, but it is not a directory\n"
|
||||||
|
(path->string c)
|
||||||
|
(path->string dir))))
|
||||||
|
candidates)
|
||||||
|
(append (filter directory-exists? candidates)
|
||||||
|
(loop (cdr dirs))))]
|
||||||
|
[else
|
||||||
|
(loop (cdr dirs))]))]
|
||||||
|
[else (loop (cdr dirs))]))]))))
|
||||||
|
|
||||||
|
(define (find-doc-directories-in-toplevel-docs)
|
||||||
|
(apply append
|
||||||
|
(map (lambda (docs-path)
|
||||||
|
(filter directory-exists?
|
||||||
|
(map (lambda (doc-path)
|
||||||
|
(build-path docs-path doc-path))
|
||||||
|
(if (directory-exists? docs-path)
|
||||||
|
(filter (lambda (x)
|
||||||
|
(not (member (path->string x)
|
||||||
|
'(".svn" "CVS"))))
|
||||||
|
(directory-list docs-path))
|
||||||
|
'()))))
|
||||||
|
(get-doc-search-dirs))))
|
||||||
|
|
||||||
|
(define (find-manuals)
|
||||||
|
(let* ([docs (sort (filter get-index-file (find-doc-directories))
|
||||||
|
compare-docs)]
|
||||||
|
[names (map get-doc-name docs)]
|
||||||
|
[names+paths (map cons names docs)])
|
||||||
|
(let-values ([(collections-doc-files collection-names) (colldocs)])
|
||||||
|
`((H1 "Installed Manuals")
|
||||||
|
,@(if (repos-or-nightly-build?)
|
||||||
|
(list
|
||||||
|
'(b "Subversion: ")
|
||||||
|
`(a ((mzscheme
|
||||||
|
,(to-string/escape-quotes
|
||||||
|
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)))))
|
||||||
|
,(string-constant plt:hd:refresh-all-manuals))
|
||||||
|
'nbsp 'nbsp
|
||||||
|
`(a ((href ,flush-manuals-url)) "flush index and keyword cache")
|
||||||
|
'(br))
|
||||||
|
(list))
|
||||||
|
,@(build-known-manuals names+paths)
|
||||||
|
(h3 "Doc.txt")
|
||||||
|
(ul ,@(map
|
||||||
|
(lambda (collection-doc-file name)
|
||||||
|
(let ([path (build-path (car collection-doc-file) (cadr collection-doc-file))])
|
||||||
|
`(li ,(cond
|
||||||
|
[(file-exists? path)
|
||||||
|
`(a ((href ,(format "/servlets/doc-anchor.ss?file=~a&name=~a&caption=~a"
|
||||||
|
;; escape colons and other junk
|
||||||
|
(uri-encode (path->string path))
|
||||||
|
(uri-encode name)
|
||||||
|
(format "Documentation for ~a " name))))
|
||||||
|
,(format "~a " name))]
|
||||||
|
[else
|
||||||
|
`(font ((color "red"))
|
||||||
|
,(format "~a: specified doc.txt file (~a) not found"
|
||||||
|
name path))]))))
|
||||||
|
collections-doc-files
|
||||||
|
collection-names))
|
||||||
|
|
||||||
|
,@(let ([uninstalled (get-uninstalled docs)])
|
||||||
|
(if (null? uninstalled)
|
||||||
|
'()
|
||||||
|
`((h3 "Uninstalled Manuals")
|
||||||
|
(ul ,@(map
|
||||||
|
(lambda (doc-pair)
|
||||||
|
(let* ([manual (car doc-pair)]
|
||||||
|
[name (cdr doc-pair)]
|
||||||
|
[manual-path (find-doc-directory manual)])
|
||||||
|
`(li "Download and install "
|
||||||
|
(a ((mzscheme
|
||||||
|
,(to-string/escape-quotes
|
||||||
|
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
|
||||||
|
(list (cons ((dynamic-require '(lib "refresh-manuals.ss" "help") 'bytes-to-path)
|
||||||
|
,(path->bytes manual))
|
||||||
|
,name))))))
|
||||||
|
,name)
|
||||||
|
,(if (and manual-path
|
||||||
|
(or (file-exists? (build-path manual-path "hdindex"))
|
||||||
|
(file-exists? (build-path manual-path "keywords"))))
|
||||||
|
" (index installed)"
|
||||||
|
""))))
|
||||||
|
uninstalled)))))))))
|
||||||
|
|
||||||
|
|
||||||
|
;; build-known-manuals : (listof (cons string[title] string[path])) -> (listof xexpr)
|
||||||
|
(define (build-known-manuals names+paths)
|
||||||
|
(let loop ([sections sections]
|
||||||
|
[manuals names+paths])
|
||||||
|
(cond
|
||||||
|
[(null? sections) null]
|
||||||
|
[else
|
||||||
|
(let* ([section (car sections)]
|
||||||
|
[in (filter (lambda (x) (regexp-match (sec-reg section)
|
||||||
|
(car x)))
|
||||||
|
manuals)]
|
||||||
|
[out (filter (lambda (x) (not (regexp-match (sec-reg section)
|
||||||
|
(car x))))
|
||||||
|
manuals)])
|
||||||
|
(append (build-known-section section in)
|
||||||
|
(loop (cdr sections) out)))])))
|
||||||
|
|
||||||
|
;; build-known-section : sec (listof (cons string[title] string[path]))) -> (listof xexpr)
|
||||||
|
(define (build-known-section sec names+paths)
|
||||||
|
(if (null? names+paths)
|
||||||
|
'()
|
||||||
|
`((h3 ,(sec-name sec))
|
||||||
|
(ul ,@(map (match-lambda
|
||||||
|
["<p>" '(p)]
|
||||||
|
[(title . path) (mk-link path title)])
|
||||||
|
(let loop ([breaks (sec-seps sec)]
|
||||||
|
[names+paths names+paths])
|
||||||
|
(cond
|
||||||
|
[(null? breaks) names+paths]
|
||||||
|
[else
|
||||||
|
(let ([break (car breaks)])
|
||||||
|
(loop (cdr breaks)
|
||||||
|
(break-between (car breaks) names+paths)))])))))))
|
||||||
|
|
||||||
|
;; break-between : regexp
|
||||||
|
;; (listof (union string (cons string string)))
|
||||||
|
;; -> (listof (union string (cons string string)))
|
||||||
|
;; adds the para-mark string into the list at the first place
|
||||||
|
;; that the regexp fails to match (not counting other para-marks
|
||||||
|
;; in the list)
|
||||||
|
(define (break-between re l)
|
||||||
|
(let ([para-mark "<p>"])
|
||||||
|
(let loop ([l l])
|
||||||
|
(cond
|
||||||
|
[(null? l) null]
|
||||||
|
[else
|
||||||
|
(let ([fst (car l)])
|
||||||
|
(cond
|
||||||
|
[(pair? fst)
|
||||||
|
(let ([name (car fst)])
|
||||||
|
(if (regexp-match re name)
|
||||||
|
(cons para-mark l)
|
||||||
|
(cons fst (loop (cdr l)))))]
|
||||||
|
[else (cons fst (loop (cdr l)))]))]))))
|
||||||
|
|
||||||
|
|
||||||
|
;; mk-link : string string -> xexpr
|
||||||
|
(define (mk-link doc-path name)
|
||||||
|
(let* ([manual-name (basename doc-path)]
|
||||||
|
[index-file (get-index-file doc-path)])
|
||||||
|
`(li (a ((href ,(get-help-url (build-path doc-path index-file))))
|
||||||
|
,name)
|
||||||
|
,@(cond
|
||||||
|
[(and (repos-or-nightly-build?)
|
||||||
|
(file-exists? (build-path doc-path index-file)))
|
||||||
|
`((br)
|
||||||
|
'nbsp
|
||||||
|
'nbsp
|
||||||
|
(font ((size "-1"))
|
||||||
|
,@(if (is-known-doc? doc-path)
|
||||||
|
(list
|
||||||
|
"["
|
||||||
|
`(a ((mzscheme
|
||||||
|
,(to-string/escape-quotes
|
||||||
|
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
|
||||||
|
(list (cons ((dynamic-require '(lib "refresh-manuals.ss" "help") 'bytes-to-path)
|
||||||
|
,(path->bytes manual-name))
|
||||||
|
,name))))))
|
||||||
|
,(string-constant plt:hd:refresh))
|
||||||
|
"]" 'nbsp)
|
||||||
|
(list))))]
|
||||||
|
[else
|
||||||
|
(list
|
||||||
|
(format (string-constant plt:hd:manual-installed-date)
|
||||||
|
(date->string
|
||||||
|
(seconds->date
|
||||||
|
(file-or-directory-modify-seconds
|
||||||
|
(build-path doc-path index-file))))))]))))
|
||||||
|
|
||||||
|
(define (to-string/escape-quotes exp)
|
||||||
|
(regexp-replace* #rx"\"" (format "~s" exp) "|"))
|
||||||
|
|
||||||
|
;; get-doc-name : path -> string
|
||||||
|
(define cached-doc-names (make-hash-table 'equal))
|
||||||
|
(define (get-doc-name doc-dir)
|
||||||
|
(hash-table-get cached-doc-names doc-dir
|
||||||
|
(lambda ()
|
||||||
|
(let ([res (compute-doc-name doc-dir)])
|
||||||
|
(hash-table-put! cached-doc-names doc-dir res)
|
||||||
|
res))))
|
||||||
|
|
||||||
|
;; compute-doc-name : path -> string[title of manual]
|
||||||
|
;; gets the title either from the known docs list, by parsing the
|
||||||
|
;; html, or if both those fail, by using the name of the directory
|
||||||
|
;; Special-cases the help collection. It's not a known doc directory
|
||||||
|
;; per se, so it won't appear in known-docs, but its name is always
|
||||||
|
;; the same.
|
||||||
|
(define (compute-doc-name doc-dir)
|
||||||
|
(let ([doc-short-dir-name (basename doc-dir)])
|
||||||
|
(cond
|
||||||
|
[(equal? (string->path "help") doc-short-dir-name) "PLT Help Desk"]
|
||||||
|
[(get-known-doc-name doc-dir) => values]
|
||||||
|
[else (let* ([main-file (get-index-file doc-dir)]
|
||||||
|
[m (and main-file
|
||||||
|
(call-with-input-file (build-path doc-dir main-file)
|
||||||
|
(lambda (inp) (regexp-match re:title inp))))])
|
||||||
|
(if m
|
||||||
|
(bytes->string/utf-8 (cadr m))
|
||||||
|
(path->string doc-short-dir-name)))])))
|
||||||
|
(define re:title
|
||||||
|
#rx"<[tT][iI][tT][lL][eE]>[ \t\r\n]*(.*?)[ \t\r\n]*</[tT][iI][tT][lL][eE]>")
|
||||||
|
|
||||||
|
;; is-known-doc? : string[path] -> boolean
|
||||||
|
(define (is-known-doc? doc-path)
|
||||||
|
(and (assoc (basename doc-path) known-docs) #t))
|
||||||
|
|
||||||
|
;; get-known-doc-name : string[full-path] -> (union string #f)
|
||||||
|
(define (get-known-doc-name doc-path)
|
||||||
|
(cond [(assoc (basename doc-path) known-docs) => cdr] [else #f]))
|
||||||
|
|
||||||
|
;; get-uninstalled : (listof path) -> (listof (cons path string[docs-name]))
|
||||||
|
(define (get-uninstalled docs)
|
||||||
|
(let ([ht (make-hash-table 'equal)])
|
||||||
|
(for-each (lambda (known-doc)
|
||||||
|
(hash-table-put! ht
|
||||||
|
(car known-doc)
|
||||||
|
(cdr known-doc)))
|
||||||
|
known-docs)
|
||||||
|
(for-each (lambda (doc) (hash-table-remove! ht (basename doc))) docs)
|
||||||
|
(sort (hash-table-map ht cons)
|
||||||
|
(λ (a b) (compare-docs (car a) (car b))))))
|
||||||
|
|
||||||
|
(define (compare-docs a b)
|
||||||
|
(let ([ap (standard-html-doc-position (basename a))]
|
||||||
|
[bp (standard-html-doc-position (basename b))])
|
||||||
|
(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)
|
||||||
|
(cond
|
||||||
|
[(file-exists? (build-path doc-dir "index.htm"))
|
||||||
|
(build-path "index.htm")]
|
||||||
|
[(file-exists? (build-path doc-dir "index.html"))
|
||||||
|
(build-path "index.html")]
|
||||||
|
[(tex2page-detected doc-dir)
|
||||||
|
=>
|
||||||
|
(lambda (x) x)]
|
||||||
|
[else #f]))
|
||||||
|
|
||||||
|
;; tex2page-detected : string -> (union #f string)
|
||||||
|
(define (tex2page-detected dir)
|
||||||
|
(let loop ([contents (directory-list dir)])
|
||||||
|
(cond
|
||||||
|
[(null? contents) #f]
|
||||||
|
[else (let* ([file (car contents)]
|
||||||
|
[m (regexp-match #rx#"(.*)-Z-H-1.html" (path->bytes file))])
|
||||||
|
(or (and m
|
||||||
|
(file-exists? (build-path dir file))
|
||||||
|
(let ([index-file
|
||||||
|
(bytes->path
|
||||||
|
(bytes-append (cadr m) #".html"))])
|
||||||
|
(if (file-exists? (build-path dir index-file))
|
||||||
|
index-file
|
||||||
|
#f)))
|
||||||
|
(loop (cdr contents))))])))
|
||||||
|
|
||||||
|
|
||||||
|
(provide find-manuals
|
||||||
|
main-manual-page
|
||||||
|
finddoc
|
||||||
|
finddoc-page-anchor)
|
||||||
|
|
||||||
|
(provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)]
|
||||||
|
[finddoc-page (string? string? . -> . string?)]
|
||||||
|
[get-doc-name (path? . -> . string?)]
|
||||||
|
[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?))]))
|
||||||
22
collects/help/private/options.ss
Normal file
22
collects/help/private/options.ss
Normal file
|
|
@ -0,0 +1,22 @@
|
||||||
|
(module options mzscheme
|
||||||
|
|
||||||
|
;; This module provides configuration options that are shared
|
||||||
|
;; between servlets and the web-server. (Mostly to allow
|
||||||
|
;; configuration as an application or as a standalone server.)
|
||||||
|
|
||||||
|
(provide helpdesk-platform internal-port)
|
||||||
|
|
||||||
|
;; internal browser or external browser?
|
||||||
|
;; (used to produce simpler html for the internal browser)
|
||||||
|
(define helpdesk-platform
|
||||||
|
(make-parameter
|
||||||
|
'internal-browser-simple ; main page only
|
||||||
|
;; 'internal-browser ; menu + main page
|
||||||
|
;; 'external-browser
|
||||||
|
))
|
||||||
|
|
||||||
|
;; Port for the server to listen on
|
||||||
|
;; (relevant only for a standalone server)
|
||||||
|
(define internal-port (make-parameter 8012))
|
||||||
|
|
||||||
|
)
|
||||||
10
collects/help/private/path.ss
Normal file
10
collects/help/private/path.ss
Normal file
|
|
@ -0,0 +1,10 @@
|
||||||
|
(module path mzscheme
|
||||||
|
(require (lib "contract.ss"))
|
||||||
|
(define (servlet-path? path)
|
||||||
|
(if (regexp-match #rx#"^/servlets/"
|
||||||
|
(path->bytes path))
|
||||||
|
#t
|
||||||
|
#f))
|
||||||
|
(provide/contract
|
||||||
|
[servlet-path? (path? . -> . boolean?)]))
|
||||||
|
|
||||||
134
collects/help/private/standard-urls.ss
Normal file
134
collects/help/private/standard-urls.ss
Normal file
|
|
@ -0,0 +1,134 @@
|
||||||
|
(module standard-urls mzscheme
|
||||||
|
(require (lib "uri-codec.ss" "net")
|
||||||
|
(lib "dirs.ss" "setup")
|
||||||
|
(lib "contract.ss")
|
||||||
|
(lib "config.ss" "planet")
|
||||||
|
(lib "help-desk-urls.ss" "help")
|
||||||
|
"../servlets/private/util.ss"
|
||||||
|
"internal-hp.ss"
|
||||||
|
"get-help-url.ss")
|
||||||
|
|
||||||
|
(provide home-page-url host+dirs)
|
||||||
|
|
||||||
|
(define (search-type? x)
|
||||||
|
(member x '("keyword" "keyword-index" "keyword-index-text")))
|
||||||
|
|
||||||
|
(define (search-how? x)
|
||||||
|
(member x '("exact-match" "containing-match" "regexp-match")))
|
||||||
|
|
||||||
|
(define (base-docs-url)
|
||||||
|
(if (repos-or-nightly-build?)
|
||||||
|
"http://pre.plt-scheme.org/docs"
|
||||||
|
(string-append "http://download.plt-scheme.org/doc/" (version))))
|
||||||
|
|
||||||
|
(define (make-docs-plt-url manual-name)
|
||||||
|
(format "~a/bundles/~a-doc.plt" (base-docs-url) manual-name))
|
||||||
|
|
||||||
|
(define (make-docs-html-url manual-name)
|
||||||
|
(format "~a/html/~a/index.htm" (base-docs-url) manual-name))
|
||||||
|
|
||||||
|
(define (prefix-with-server suffix)
|
||||||
|
(format "http://~a:~a~a" internal-host (internal-port) suffix))
|
||||||
|
|
||||||
|
(define results-url-prefix (format "http://~a:~a/servlets/results.ss?" internal-host (internal-port)))
|
||||||
|
(define flush-manuals-path "/servlets/results.ss?flush=yes")
|
||||||
|
(define flush-manuals-url (format "http://~a:~a~a" internal-host (internal-port) flush-manuals-path))
|
||||||
|
|
||||||
|
|
||||||
|
(define relative-results-url-prefix "/servlets/results.ss?")
|
||||||
|
|
||||||
|
(define home-page-url (format "http://~a:~a/servlets/home.ss" internal-host (internal-port)))
|
||||||
|
|
||||||
|
(define (make-missing-manual-url coll name link)
|
||||||
|
(format "http://~a:~a/servlets/missing-manual.ss?manual=~a&name=~a&link=~a"
|
||||||
|
internal-host
|
||||||
|
(internal-port)
|
||||||
|
coll
|
||||||
|
(uri-encode name)
|
||||||
|
(uri-encode link)))
|
||||||
|
|
||||||
|
(define (make-relative-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name)
|
||||||
|
(string-append
|
||||||
|
relative-results-url-prefix
|
||||||
|
(make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name)))
|
||||||
|
|
||||||
|
(define (make-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name)
|
||||||
|
(string-append
|
||||||
|
results-url-prefix
|
||||||
|
(make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name)))
|
||||||
|
|
||||||
|
(define (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? language-name)
|
||||||
|
(let ([start
|
||||||
|
(format
|
||||||
|
(string-append "search-string=~a&"
|
||||||
|
"search-type=~a&"
|
||||||
|
"match-type=~a&"
|
||||||
|
"lucky=~a&"
|
||||||
|
"manuals=~a&"
|
||||||
|
"doctxt=~a")
|
||||||
|
(uri-encode search-string)
|
||||||
|
search-type
|
||||||
|
match-type
|
||||||
|
(if lucky? "true" "false")
|
||||||
|
(uri-encode (format "~s" (map path->bytes manuals)))
|
||||||
|
(if doc.txt? "true" "false"))])
|
||||||
|
(if language-name
|
||||||
|
(string-append start (format "&langname=~a" (uri-encode language-name)))
|
||||||
|
start)))
|
||||||
|
|
||||||
|
; sym, string assoc list
|
||||||
|
(define hd-locations
|
||||||
|
`((hd-tour ,(format "~a/index.html" (get-help-url (build-path (find-doc-dir) "tour"))))
|
||||||
|
(release-notes ,url-helpdesk-release-notes)
|
||||||
|
(plt-license ,url-helpdesk-license)
|
||||||
|
(front-page ,url-helpdesk-home)))
|
||||||
|
|
||||||
|
(define hd-location-syms (map car hd-locations))
|
||||||
|
|
||||||
|
(define (get-hd-location sym)
|
||||||
|
; the assq is guarded by the contract
|
||||||
|
(cadr (assq sym hd-locations)))
|
||||||
|
|
||||||
|
; host+dirs : (list (cons host-string dir-path))
|
||||||
|
; association between internal (in normal Helpdesk also virtual)
|
||||||
|
; hosts and their corresponding file root.
|
||||||
|
(define host+dirs
|
||||||
|
(map cons
|
||||||
|
(append collects-hosts doc-hosts)
|
||||||
|
(append collects-dirs doc-dirs)))
|
||||||
|
|
||||||
|
(define (host+file->path host file-path)
|
||||||
|
(cond [(assoc host host+dirs)
|
||||||
|
=> (lambda (internal-host+path)
|
||||||
|
(let ([path (cdr internal-host+path)])
|
||||||
|
(build-path path file-path)))]
|
||||||
|
[(equal? host "planet")
|
||||||
|
(build-path (PLANET-DIR) file-path)]
|
||||||
|
[else #f]))
|
||||||
|
|
||||||
|
(provide host+file->path)
|
||||||
|
(provide search-type? search-how?)
|
||||||
|
(provide/contract
|
||||||
|
(make-relative-results-url (string?
|
||||||
|
search-type?
|
||||||
|
search-how?
|
||||||
|
any/c
|
||||||
|
(listof path?)
|
||||||
|
any/c
|
||||||
|
(or/c false/c string?) . -> . string?))
|
||||||
|
(make-results-url (string?
|
||||||
|
search-type? search-how? any/c
|
||||||
|
(listof path?)
|
||||||
|
any/c
|
||||||
|
(or/c false/c string?)
|
||||||
|
. -> .
|
||||||
|
string?))
|
||||||
|
(flush-manuals-url string?)
|
||||||
|
(flush-manuals-path string?)
|
||||||
|
(make-missing-manual-url (string? string? string? . -> . string?))
|
||||||
|
(get-hd-location ((lambda (sym) (memq sym hd-location-syms))
|
||||||
|
. -> .
|
||||||
|
string?))
|
||||||
|
[prefix-with-server (string? . -> . string?)]
|
||||||
|
[make-docs-plt-url (string? . -> . string?)]
|
||||||
|
[make-docs-html-url (string? . -> . string?)]))
|
||||||
83
collects/help/servlets/private/url.ss
Normal file
83
collects/help/servlets/private/url.ss
Normal file
|
|
@ -0,0 +1,83 @@
|
||||||
|
(module url mzscheme
|
||||||
|
(require "../../private/internal-hp.ss")
|
||||||
|
|
||||||
|
(provide (all-defined))
|
||||||
|
|
||||||
|
(define url-helpdesk-root
|
||||||
|
(format "http://~a:~a/servlets/" internal-host (internal-port)))
|
||||||
|
|
||||||
|
(define url-helpdesk-home (string-append url-helpdesk-root "home.ss"))
|
||||||
|
(define url-helpdesk-results (string-append url-helpdesk-root "results.ss"))
|
||||||
|
(define url-helpdesk-master-index (string-append url-helpdesk-root "master-index.ss"))
|
||||||
|
|
||||||
|
|
||||||
|
(define (url-home-subpage subpage-str)
|
||||||
|
(string-append url-helpdesk-home "?subpage=" subpage-str))
|
||||||
|
|
||||||
|
(define (version-major)
|
||||||
|
; TODO: Fix this
|
||||||
|
(cond [(regexp-match #px"^(\\d+).*$" (version))
|
||||||
|
=> cadr]
|
||||||
|
[else "352"]))
|
||||||
|
|
||||||
|
(define (url-manual-on-doc-server manual)
|
||||||
|
(format "http://download.plt-scheme.org/doc/~a/html/~a/"
|
||||||
|
(version-major) manual))
|
||||||
|
|
||||||
|
(define (url-static doc manual path)
|
||||||
|
(format "~astatic.ss/~a/~a/~a"
|
||||||
|
url-helpdesk-root doc manual path))
|
||||||
|
|
||||||
|
(define url-external-announcement-list-archive "http://list.cs.brown.edu/pipermail/plt-announce/")
|
||||||
|
(define url-external-discussion-list-archive "http://list.cs.brown.edu/pipermail/plt-scheme/")
|
||||||
|
(define url-external-discussion-list-archive-old "http://www.cs.utah.edu/plt/mailarch/")
|
||||||
|
(define url-external-mailing-list-subscription "http://www.plt-scheme.org/maillist/")
|
||||||
|
(define url-external-mrflow "http://www.plt-scheme.org/software/mrflow/")
|
||||||
|
(define url-external-mrspidey "http://www.plt-scheme.org/software/mrspidey/")
|
||||||
|
(define url-external-mysterx "http://www.plt-scheme.org/software/mysterx/")
|
||||||
|
(define url-external-mzcom "http://www.plt-scheme.org/software/mzcom/")
|
||||||
|
(define url-external-send-bug-report "http://bugs.plt-scheme.org/")
|
||||||
|
(define url-external-tour-of-drscheme "http://www.plt-scheme.org/software/drscheme/tour/")
|
||||||
|
(define url-external-planet "http://planet.plt-scheme.org/")
|
||||||
|
(define url-external-srpersist "http://www.plt-scheme.org/software/srpersist/")
|
||||||
|
|
||||||
|
(define url-helpdesk-acknowledge (url-home-subpage "acknowledge"))
|
||||||
|
(define url-helpdesk-batch (url-home-subpage "batch"))
|
||||||
|
(define url-helpdesk-books (url-home-subpage "books"))
|
||||||
|
(define url-helpdesk-cgi (url-home-subpage "cgi"))
|
||||||
|
(define url-helpdesk-databases (url-home-subpage "databases"))
|
||||||
|
(define url-helpdesk-documentation (url-home-subpage "documentation"))
|
||||||
|
(define url-helpdesk-drscheme (url-home-subpage "drscheme"))
|
||||||
|
(define url-helpdesk-drscheme-faq (url-static "doc1" "drscheme" "drscheme-Z-H-5.html#node_chap_5"))
|
||||||
|
(define url-helpdesk-drscheme-manual (url-static "doc1" "drscheme" "index.htm"))
|
||||||
|
(define url-helpdesk-faq (url-home-subpage "faq"))
|
||||||
|
(define url-helpdesk-graphics (url-home-subpage "graphics"))
|
||||||
|
(define url-helpdesk-help (url-home-subpage "help"))
|
||||||
|
(define url-helpdesk-how-to-search (url-home-subpage "how-to-search"))
|
||||||
|
(define url-helpdesk-interface-essentials (url-static "doc1" "drscheme" "drscheme-Z-H-2.html#node_chap_2"))
|
||||||
|
(define url-helpdesk-known-bugs (url-home-subpage "known-bugs"))
|
||||||
|
(define url-helpdesk-languages (url-home-subpage "languages"))
|
||||||
|
(define url-helpdesk-libraries (url-home-subpage "libraries"))
|
||||||
|
(define url-helpdesk-license (url-home-subpage "license"))
|
||||||
|
(define url-helpdesk-manuals (url-home-subpage "manuals"))
|
||||||
|
(define url-helpdesk-mailing-lists (url-home-subpage "mailing-lists"))
|
||||||
|
(define url-helpdesk-mzlib (url-static "doc1" "mzlib" "mzlib.html"))
|
||||||
|
(define url-helpdesk-patches (url-home-subpage "patches"))
|
||||||
|
(define url-helpdesk-program-design (url-home-subpage "program-design"))
|
||||||
|
(define url-helpdesk-release (url-home-subpage "release"))
|
||||||
|
(define url-helpdesk-release-notes (url-home-subpage "release-notes"))
|
||||||
|
(define url-helpdesk-script (url-home-subpage "script"))
|
||||||
|
(define url-helpdesk-search (url-home-subpage "search"))
|
||||||
|
(define url-helpdesk-software (url-home-subpage "software"))
|
||||||
|
(define url-helpdesk-srpersist (url-home-subpage "srpersist"))
|
||||||
|
(define url-helpdesk-stand-alone (url-home-subpage "stand-alone"))
|
||||||
|
(define url-helpdesk-system (url-home-subpage "system"))
|
||||||
|
(define url-helpdesk-teachpacks (url-home-subpage "teachpacks"))
|
||||||
|
(define url-helpdesk-teachscheme (url-home-subpage "teachscheme"))
|
||||||
|
(define url-helpdesk-teachpacks-for-htdp (url-static "doc1" "teachpack" "index.html#HtDP"))
|
||||||
|
(define url-helpdesk-teachpacks-for-htdc (url-static "doc1" "teachpack-htdc" "index.html#HtDC"))
|
||||||
|
(define url-helpdesk-teach-yourself (url-static "doc1" "t-y-scheme" "index.htm"))
|
||||||
|
(define url-helpdesk-tour (url-home-subpage "tour"))
|
||||||
|
(define url-helpdesk-why-drscheme (url-home-subpage "why-drscheme"))
|
||||||
|
|
||||||
|
)
|
||||||
114
collects/help/servlets/private/util.ss
Normal file
114
collects/help/servlets/private/util.ss
Normal file
|
|
@ -0,0 +1,114 @@
|
||||||
|
(module util mzscheme
|
||||||
|
(require (lib "file.ss")
|
||||||
|
(lib "list.ss")
|
||||||
|
(lib "xml.ss" "xml")
|
||||||
|
(lib "uri-codec.ss" "net")
|
||||||
|
(lib "string-constant.ss" "string-constants")
|
||||||
|
(lib "contract.ss"))
|
||||||
|
|
||||||
|
;; would be nice if this could use version:version from the framework.
|
||||||
|
(define (plt-version)
|
||||||
|
(let ([mz-version (version)]
|
||||||
|
[stamp-collection
|
||||||
|
(with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
|
||||||
|
(collection-path "repos-time-stamp"))])
|
||||||
|
(if (and stamp-collection
|
||||||
|
(file-exists? (build-path stamp-collection "stamp.ss")))
|
||||||
|
(format "~a-svn~a" mz-version
|
||||||
|
(dynamic-require '(lib "repos-time-stamp/stamp.ss") 'stamp))
|
||||||
|
mz-version)))
|
||||||
|
|
||||||
|
(define home-page
|
||||||
|
`(a ([href "/servlets/home.ss"] [target "_top"])
|
||||||
|
,(string-constant plt:hd:home)))
|
||||||
|
|
||||||
|
(define (get-pref/default pref default)
|
||||||
|
(get-preference pref (lambda () default)))
|
||||||
|
|
||||||
|
(define (get-bool-pref/default pref default)
|
||||||
|
(let ([raw-pref (get-pref/default pref default)])
|
||||||
|
(if (string=? raw-pref "false") #f #t)))
|
||||||
|
|
||||||
|
(define (put-prefs names vals)
|
||||||
|
(put-preferences names vals))
|
||||||
|
|
||||||
|
(define search-height-default "85")
|
||||||
|
(define search-bg-default "lightsteelblue")
|
||||||
|
(define search-text-default "black")
|
||||||
|
(define search-link-default "darkblue")
|
||||||
|
|
||||||
|
(define *the-highlight-color* "forestgreen")
|
||||||
|
|
||||||
|
;; string xexpr ... -> xexpr
|
||||||
|
(define (with-color color . s)
|
||||||
|
`(font ([color ,color]) ,@s))
|
||||||
|
|
||||||
|
;; xexpr ... -> xexpr
|
||||||
|
(define (color-highlight . s)
|
||||||
|
(apply with-color *the-highlight-color* s))
|
||||||
|
|
||||||
|
(define repos-or-nightly-build?
|
||||||
|
(let ([helpdir (collection-path "help")])
|
||||||
|
(lambda ()
|
||||||
|
(or (directory-exists? (build-path helpdir ".svn"))
|
||||||
|
(directory-exists? (build-path helpdir "CVS"))
|
||||||
|
(with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
||||||
|
(collection-path "repos-time-stamp"))))))
|
||||||
|
|
||||||
|
; string string -> xexpr
|
||||||
|
(define (collection-doc-link coll txt)
|
||||||
|
(let ([coll-file (build-path (collection-path coll) "doc.txt")])
|
||||||
|
(if (file-exists? coll-file)
|
||||||
|
`(a ((href
|
||||||
|
,(format
|
||||||
|
"~a?file=~a&name=~a&caption=Documentation for the ~a collection"
|
||||||
|
"/servlets/doc-anchor.ss"
|
||||||
|
(uri-encode (path->string coll-file))
|
||||||
|
coll
|
||||||
|
coll)))
|
||||||
|
,txt)
|
||||||
|
"")))
|
||||||
|
|
||||||
|
;; (listof string) -> string
|
||||||
|
;; result is forward-slashed web path
|
||||||
|
;; e.g. ("foo" "bar") -> "foo/bar"
|
||||||
|
(define (fold-into-web-path lst)
|
||||||
|
(foldr (lambda (s a) (if a (string-append s "/" a) s)) #f lst))
|
||||||
|
|
||||||
|
(define (format-collection-message s)
|
||||||
|
`(b ((style "color:green")) ,s))
|
||||||
|
|
||||||
|
(define (make-javascript . ss)
|
||||||
|
`(script ([language "Javascript"])
|
||||||
|
,(make-comment (apply string-append "\n"
|
||||||
|
(map (lambda (s) (string-append s "\n")) ss)))))
|
||||||
|
|
||||||
|
(define (redir-javascript k-url)
|
||||||
|
(make-javascript "function redir() {"
|
||||||
|
(string-append " document.location.href=\"" k-url "\"")
|
||||||
|
"}"))
|
||||||
|
|
||||||
|
(define (onload-redir secs)
|
||||||
|
(string-append "setTimeout(\"redir()\","
|
||||||
|
(number->string (* secs 1000)) ")"))
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[fold-into-web-path ((listof string?) . -> . string?)])
|
||||||
|
|
||||||
|
(provide get-pref/default
|
||||||
|
get-bool-pref/default
|
||||||
|
put-prefs
|
||||||
|
repos-or-nightly-build?
|
||||||
|
search-height-default
|
||||||
|
search-bg-default
|
||||||
|
search-text-default
|
||||||
|
search-link-default
|
||||||
|
color-highlight
|
||||||
|
with-color
|
||||||
|
collection-doc-link
|
||||||
|
home-page
|
||||||
|
format-collection-message
|
||||||
|
plt-version
|
||||||
|
make-javascript
|
||||||
|
redir-javascript
|
||||||
|
onload-redir))
|
||||||
Loading…
Reference in New Issue
Block a user