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

added the not-a-language-language and some bug fixes elsewhere

Browse Source 
svn: r1129
This commit is contained in:
Robby Findler 2005-10-22 17:03:13 +00:00
parent 6a0f96188f
commit 8861cff087
17 changed files with 347 additions and 534 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/drscheme/info.ss
View File

@ -1,23 +1,7 @@
(module info (lib "infotab.ss" "setup") (module info (lib "infotab.ss" "setup")
(require (lib "string-constant.ss" "string-constants"))
;; added a comment, in windows ...
(define name "DrScheme") (define name "DrScheme")
(define tools (list "syncheck.ss")) (define tools (list "syncheck.ss"))
(define tool-names (list "Check Syntax")) (define tool-names (list "Check Syntax"))
(define splash-questions
(list (list (string-constant use-with-htdp)
(string-constant teaching-languages)
(string-constant how-to-design-programs)
(string-constant beginning-student))
(list (string-constant use-seasoned)
(string-constant professional-languages)
"(module ...)")
(list (string-constant use-other)
(string-constant professional-languages)
(string-constant plt)
(string-constant pretty-big-scheme))))
(define mred-launcher-names (list "DrScheme")) (define mred-launcher-names (list "DrScheme"))
(define mred-launcher-libraries (list "drscheme.ss")) (define mred-launcher-libraries (list "drscheme.ss"))
(define mred-launcher-flags (list (list "-ZmvqL" "drscheme.ss" "drscheme")))) (define mred-launcher-flags (list (list "-ZmvqL" "drscheme.ss" "drscheme"))))

441
collects/drscheme/private/app.ss
View File

@ -39,447 +39,6 @@
(super-new (super-new
(label (string-constant about-drscheme-frame-title))))) (label (string-constant about-drscheme-frame-title)))))
;; check-new-version : -> void
(define (check-new-version)
(let ([this-version (version)]
[last-version (preferences:get 'drscheme:last-version)]
[last-language (preferences:get 'drscheme:last-language)])
(when (or (and (getenv "PLTDRWIZARD")
(printf "PLTDRWIZARD: showing wizard\n"))
(not last-version)
(not last-language)
(not (equal? last-version this-version))
(not (equal? last-language (this-language))))
(preferences:set 'drscheme:last-version this-version)
(preferences:set 'drscheme:last-language (this-language))
(show-wizard))))
;; show-welcome-dialog : -> void
(define (show-v200-welcome-dialog)
(let ([new-settings (drscheme:language-configuration:language-dialog
#t
(preferences:get
drscheme:language-configuration:settings-preferences-symbol)
#f)])
(when new-settings
(preferences:set
drscheme:language-configuration:settings-preferences-symbol
new-settings))))
;
;
;
; ; ;
; ;
; ;
; ; ; ; ; ;;;;;; ;;; ; ;; ;;; ;
; ; ; ; ; ; ; ; ;; ; ;;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ;;;; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ;;
; ; ; ; ;;;;;; ;;;;; ; ;;; ;
;
;
;
(define (show-wizard)
(define wizard-image-bitmap
(make-object bitmap% (build-path (collection-path "icons") "wizard-image.jpg")))
(define bkg-color (make-object color% 0 0 0))
(define stupid-internal-define-syntax1
(let ([bdc (make-object bitmap-dc% wizard-image-bitmap)])
(send bdc get-pixel 0 0 bkg-color)
(send bdc set-bitmap #f)))
(define bkg-brush (send the-brush-list find-or-create-brush bkg-color 'solid))
(define bkg-pen (send the-pen-list find-or-create-pen bkg-color 1 'solid))
(define wizard-image-canvas%
(class canvas%
(inherit get-dc get-client-size)
(define/override (on-paint)
(let ([dc (get-dc)])
(let-values ([(w h) (get-client-size)])
(send dc set-pen bkg-pen)
(send dc set-brush bkg-brush)
(send dc draw-rectangle 0 0 w h)
(send dc draw-bitmap
wizard-image-bitmap
0
(- h (send wizard-image-bitmap get-height))))))
(super-new)
(inherit stretchable-width min-width min-height)
(stretchable-width #f)
(min-width (send wizard-image-bitmap get-width))
(min-height (send wizard-image-bitmap get-height))))
(define dlg (instantiate dialog% ()
(label (string-constant welcome-to-drscheme))))
(define hp (make-object horizontal-panel% dlg))
(define c (make-object wizard-image-canvas% hp))
(define vp (make-object vertical-panel% hp))
(define sp (make-object panel:single% vp))
(define bp (instantiate horizontal-panel% ()
(parent vp)
(stretchable-height #f)
(alignment '(right center))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; State Machine ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; type state = (union 'natural-language 'check-updates 'programming-language)
;; state : state
(define state 'natural-language)
;; set-state : state -> void
;; moves the state to `new-state'
(define (set-state new-state)
(set! state new-state)
(cond
[(first-state?) (send back-button enable #f)]
[else (send back-button enable #t)])
(cond
[(last-state?) (send next-button set-label
(string-constant wizard-finish))]
[else (send next-button set-label (string-constant wizard-next))])
(case state
[(natural-language) (send sp active-child natural-language-state-panel)]
[(check-updates) (send sp active-child check-updates-state-panel)]
[(programming-language) (send sp active-child programming-language-state-panel)]))
;; next-state : -> void
(define (next-state)
(case state
[(natural-language)
(when (okay-to-leave-nl-state?)
(set-state 'programming-language))]
[(programming-language)
(cond
[(get-selected-language)
(set-state 'check-updates)]
[else
(message-box (string-constant drscheme)
(string-constant please-select-a-language))])]
[(check-updates)
(send dlg show #f)]))
;; prev-state : -> void
;; pre: state != 'natural-language
(define (prev-state)
(case state
[(programming-language) (set-state 'natural-language)]
[(check-updates) (set-state 'programming-language)]
[else (error 'prev-state "no prev state from: ~s" state)]))
;; first-state?, last-state? : -> boolean
(define (first-state?) (eq? state 'natural-language))
(define (last-state?) (eq? state 'check-updates))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; State 1 GUI ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define natural-language-state-panel (make-object vertical-panel% sp))
(define nl-space-above (make-object horizontal-panel% natural-language-state-panel))
(define nl-welcome-panel (instantiate horizontal-panel% ()
(parent natural-language-state-panel)
(stretchable-height #f)
(alignment '(center center))))
(define nl-welcome-msg (instantiate message% ()
(label (string-constant welcome-to-drscheme))
(parent nl-welcome-panel)
(font (send the-font-list find-or-create-font 24 'default 'normal 'normal #f))))
(define nl-lang-msg (instantiate message% ()
(label (format (string-constant version/language)
(version)
(this-language)))
(parent natural-language-state-panel)))
(define nl-radio-box
(instantiate radio-box% ()
(label #f)
(choices good-interact-strings)
(parent natural-language-state-panel)
(callback (λ (x y) (void)))))
(define stupid-internal-define-syntax3
(let loop ([languages languages-with-good-labels]
[n 0])
(cond
[(null? languages) (void)]
[else (let ([language (car languages)])
(if (eq? (this-language) language)
(send nl-radio-box set-selection n)
(loop (cdr languages) (+ n 1))))])))
(define nl-space-below (make-object horizontal-panel% natural-language-state-panel))
;; okay-to-leave-nl-state? : -> boolean
;; returns #t if next is okay to proceed, #f if not.
(define (okay-to-leave-nl-state?)
(let loop ([languages (all-languages)]
[n 0])
(cond
[(null? languages) (error 'wizard "lost language.2")]
[else (let ([language (car languages)])
(if (= n (send nl-radio-box get-selection))
(if (eq? (this-language) language)
#t
(begin (switch-language-to dlg language)
#f))
(loop (cdr languages) (+ n 1))))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; State 3 GUI ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define check-updates-state-panel (instantiate vertical-panel% ()
(parent sp)
(alignment '(center center))))
(define check-updates-msgs-panel (instantiate vertical-panel% ()
(parent check-updates-state-panel)
(stretchable-width #f)
(stretchable-height #f)
(alignment '(left center))))
;; note that `cu-message' is bound to the last message% object,
;; but it is not used anyway.
(define cu-message
(let ([add (λ (str)
(instantiate message% ()
(label str)
(parent check-updates-msgs-panel)))])
(let loop ([message (format (string-constant vc-wizard-check-note))])
(cond [(regexp-match #rx"^(.+?)\n(.+)$" message) =>
(λ (m) (add (cadr m)) (loop (caddr m)))]
[else (add message)]))))
(define cu-space
(instantiate horizontal-panel% ()
(parent check-updates-state-panel)
(min-height 20)
(stretchable-height #f)))
(define cu-button
(instantiate button% ()
(label (string-constant vc-wizard-check-button))
(parent check-updates-state-panel)
(callback (λ (x y) (check-version dlg)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; State 2 GUI ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; need to sort these somehow ...
(define question/answer-table
(let* ([get-qa
(λ (info-filename)
(let ([proc (get-info/full info-filename)])
(if proc
(let ([qs (proc 'splash-questions)])
(unless (list? qs)
(error 'splash-questions "expected a list, got ~e" qs))
(for-each
(lambda (pr)
(unless (and (pair? pr)
(pair? (cdr pr))
(andmap string? pr))
(error
'splash-questions
"expected a list of lists of strings, with each inner list being at least two elements long, got ~e"
pr)))
qs)
qs)
'())))]
[all-qas
(apply
append
(map get-qa (find-relevant-directories '(splash-questions))))]
[item->index
(lambda (x)
(let loop ([lst all-qas]
[i 0])
(cond
[(equal? (car lst) x) i]
[else (loop (cdr lst)
(+ i 1))])))]
[drs-qas (get-qa (collection-path "drscheme"))]
[in-order
(lambda (s1 s2)
(cond
[(equal? s1 (car drs-qas)) #t]
[(equal? s2 (car (last-pair drs-qas))) #t]
[else
(<= (item->index s1) (item->index s2))]))])
(quicksort all-qas in-order)))
(define programming-language-state-panel (instantiate vertical-panel% ()
(parent sp)
(alignment '(center center))))
(define pl-outer-panel (new vertical-panel%
(parent programming-language-state-panel)))
(define pl-single-panel (new panel:single%
(parent pl-outer-panel)))
(define pl-button-panel (new horizontal-panel%
(parent pl-outer-panel)
(stretchable-height #f)))
(define pl-show-all-languages? #f)
(define pl-simple-lang-choice (cdr (car question/answer-table)))
(define pl-show-lang-btn
(new button%
(parent pl-button-panel)
(stretchable-width #t)
(label (string-constant show-all-languages))
(callback
(lambda (a b)
(set! pl-show-all-languages? (not pl-show-all-languages?))
(send pl-single-panel active-child
(if pl-show-all-languages?
pl-all-languages-panel
pl-questions-panel))
(send pl-show-lang-btn set-label
(if pl-show-all-languages?
(string-constant show-drscheme-usage-questions)
(string-constant show-all-languages)))))))
(define pl-questions-panel (new vertical-panel%
(parent pl-single-panel)))
(define pl-msg-rb-parent1
(new vertical-panel%
(parent pl-questions-panel)
(alignment '(center center))))
(define pl-msg-rb-parent2
(new vertical-panel%
(parent pl-msg-rb-parent1)
(alignment '(left center))))
(define pl-are-you-message
(new message%
(label (string-constant are-you...-kind-of-drscheme-user))
(parent pl-msg-rb-parent2)))
(define pl-radio-box
(new radio-box%
(label #f)
(choices (map car question/answer-table))
(parent pl-msg-rb-parent2)
(callback
(lambda (a b)
(let* ([i (send pl-radio-box get-selection)]
[q/a (list-ref question/answer-table i)])
(send pl-lang-message set-label
(format
(string-constant pl-lang-choice-format)
(car (last-pair q/a))))
(set! pl-simple-lang-choice (cdr q/a)))))))
(define pl-lang-message (new message%
(stretchable-width #t)
(label (format
(string-constant pl-lang-choice-format)
(car (last-pair (car question/answer-table)))))
(parent pl-questions-panel)))
(define pl-all-languages-panel
(instantiate vertical-panel% ()
(parent pl-single-panel)
(stretchable-width #t)
(stretchable-height #t)))
(define pl-choose-language-message
(instantiate message% ()
(parent pl-all-languages-panel)
(label (string-constant please-select-a-language))))
(define language-config-panel (make-object vertical-panel% pl-all-languages-panel))
(define language-config-button-panel (instantiate horizontal-panel% ()
(parent pl-all-languages-panel)
(stretchable-height #f)))
(define-values (get-all-lang-selected-language get-all-lang-selected-language-settings)
(drscheme:language-configuration:fill-language-dialog
language-config-panel
language-config-button-panel
(preferences:get
drscheme:language-configuration:settings-preferences-symbol)
dlg))
(define (get-selected-language)
(cond
[pl-show-all-languages? (get-all-lang-selected-language)]
[else
(let ([langs (drscheme:language-configuration:get-languages)])
(or (ormap (λ (lang)
(and (equal? pl-simple-lang-choice
(send lang get-language-position))
lang))
langs)
(car langs)))]))
(define (get-selected-language-settings)
(cond
[pl-show-all-languages? (get-all-lang-selected-language-settings)]
[else (send (get-selected-language) default-settings)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; GO ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define back-button (instantiate button% ()
(label (string-constant wizard-back))
(parent bp)
(callback (λ (x y) (prev-state)))))
(define next-button (instantiate button% ()
(label (if (< (string-length (string-constant wizard-next))
(string-length (string-constant wizard-finish)))
(string-constant wizard-finish)
(string-constant wizard-next)))
(parent bp)
(style '(border))
(callback (λ (x y) (next-state)))))
(send next-button focus)
(set-state 'natural-language)
(send dlg center 'both)
(send dlg show #t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; Put in Wizard Choices ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(preferences:set
(drscheme:language-configuration:get-settings-preferences-symbol)
(drscheme:language-configuration:make-language-settings
(get-selected-language)
(get-selected-language-settings))))
; ;
; ;

3
collects/drscheme/private/drsig.ss
View File

@ -179,8 +179,7 @@
context<%>)) context<%>))
(define-signature drscheme:app^ (define-signature drscheme:app^
(check-new-version (about-drscheme
about-drscheme
invite-tour invite-tour
add-language-items-to-help-menu add-language-items-to-help-menu
add-important-urls-to-help-menu add-important-urls-to-help-menu

211
collects/drscheme/private/language-configuration.ss
View File

@ -46,9 +46,8 @@
;; if a language is registered with this position, it is ;; if a language is registered with this position, it is
;; considered the default language ;; considered the default language
(define default-language-position (define default-language-position
(list (string-constant teaching-languages) (list (string-constant not-really-languages)
(string-constant how-to-design-programs) (string-constant choose-a-language-language)))
(string-constant beginning-student)))
;; languages : (listof (instanceof language<%>)) ;; languages : (listof (instanceof language<%>))
;; all of the languages supported in DrScheme ;; all of the languages supported in DrScheme
@ -135,8 +134,8 @@
(define dialog (instantiate ret-dialog% () (define dialog (instantiate ret-dialog% ()
(label (if show-welcome? (label (if show-welcome?
(string-constant welcome-to-drscheme) (string-constant welcome-to-drscheme)
(string-constant language-dialog-title))) (string-constant language-dialog-title)))
(parent parent) (parent parent)
(style '(resize-border)))) (style '(resize-border))))
(define welcome-before-panel (instantiate horizontal-panel% () (define welcome-before-panel (instantiate horizontal-panel% ()
@ -1328,4 +1327,204 @@
(list -1000 -1000) (list -1000 -1000)
#f #f
(string-constant r5rs-one-line-summary) (string-constant r5rs-one-line-summary)
r5rs-mixin))))))) r5rs-mixin))
(add-language
(make-simple 'mzscheme
(list (string-constant not-really-languages)
(string-constant choose-a-language-language))
(list 10000 1000)
#f
"Helps the user choose an initial language"
not-a-language-extra-mixin))))
(define (not-a-language-extra-mixin %)
(class %
(define/override (front-end/interaction input settings teachpack-cache)
(not-a-language-message)
(λ () eof))
(define/override (front-end/complete-program input settings teachpack-cache)
(not-a-language-message)
(λ () eof))
(super-new)))
(define (not-a-language-message)
(define (main)
(o (string-constant must-choose-language))
(o "\n\n")
(o (string-constant using-a-text-book?))
(o "\n")
(insert-text-pls)
(o "\n")
(o (string-constant seasoned-plt-schemer-before))
(o (lang-link-snip (list (string-constant professional-languages)
"(module ...)")))
(o (string-constant seasoned-plt-schemer-after))
(o "\n\n")
(o (string-constant otherwise-use-before))
(o (lang-link-snip (list (string-constant professional-languages)
(string-constant plt)
(string-constant pretty-big-scheme))))
(o (string-constant otherwise-use-between))
(o (new link-snip%
[words (string-constant otherwise-use-language-dialog)]
[callback
(λ (snip)
(let ([new-lang
(language-dialog #f
(preferences:get settings-preferences-symbol)
(find-parent-from-snip snip))])
(preferences:set settings-preferences-symbol
new-lang)))]))
(o (string-constant otherwise-use-after)))
(define (find-parent-from-snip snip)
(let loop ([snip snip])
(let* ([admin (send snip get-admin)]
[ed (send admin get-editor)])
(cond
[(send ed get-canvas)
=>
(λ (c)
(send c get-top-level-window))]
[else
(let ([admin (send ed get-admin)])
(and (is-a? admin editor-snip-editor-admin<%>)
(loop (send admin get-snip))))]))))
(define o
(case-lambda
[(arg)
(cond
[(string? arg)
(fprintf (current-error-port) arg)]
[(is-a? arg snip%)
(write-special arg (current-error-port))])]
[args (apply fprintf (current-error-port) args)]))
(define (insert-text-pls)
(for-each
display-text-pl
(apply append (map get-text-pls (find-relevant-directories '(textbook-pls))))))
;; get-text-pls : path -> (listof (list* string string (listof string))
;; gets the questions from an info.ss file.
(define (get-text-pls info-filename)
(let ([proc (get-info/full info-filename)])
(if proc
(let ([qs (proc 'textbook-pls)])
(unless (list? qs)
(error 'splash-questions "expected a list, got ~e" qs))
(for-each
(lambda (pr)
(unless (and (pair? pr)
(pair? (cdr pr))
(pair? (cddr pr))
(list? (cdddr pr))
(let ([icon-lst (car pr)])
(and (list? icon-lst)
(not (null? icon-lst))
(andmap string? icon-lst)))
(andmap string? (cdr pr)))
(error
'splash-questions
"expected a list of lists, with each inner list being at least three elements long and the first element of the inner list being a list of strings and the rest of the elements being strings, got ~e"
pr)))
qs)
qs)
'())))
(define (lang-link-snip lang)
(new link-snip%
[words (car (last-pair lang))]
[callback
(λ (snip)
(change-current-lang-to lang))]))
(define link-snip%
(class editor-snip%
(init-field words callback)
(define/override (on-event dc x y editorx editory event)
(when (send event button-up?)
(callback this)))
(define/override (copy)
(new link-snip% [words words] [callback callback]))
(define txt (new text:standard-style-list%))
(super-new [editor txt] [with-border? #f]
[left-margin 0]
[right-margin 0]
[top-margin 0]
[bottom-margin 0])
(inherit get-flags set-flags set-style)
(set-flags (cons 'handles-events (get-flags)))
(send txt insert words)
(send txt change-style link-sd 0 (send txt last-position))))
(define link-sd (make-object style-delta% 'change-underline #t))
(define stupid-internal-define-syntax1
(send link-sd set-delta-foreground "blue"))
(define (display-text-pl lst)
(let* ([outer-txt (new text:standard-style-list%)]
[outer-es (new editor-snip% (editor outer-txt) (with-border? #f)
[left-margin 0]
[right-margin 0]
[top-margin 0]
[bottom-margin 0])]
[inner-txt (new text:standard-style-list%)]
[inner-es (new editor-snip% (editor inner-txt) (with-border? #f)
[top-margin 0] [bottom-margin 0])]
[icon-lst (car lst)]
[icon-path
(build-path (apply collection-path (cdr icon-lst)) (car icon-lst))]
[name (cadr lst)]
[lang (cddr lst)])style-delta%
(send outer-txt insert (make-object image-snip% icon-path))
(send outer-txt insert inner-es)
(send inner-txt insert (format "~a\n~a" name (string-constant start-with-before)))
(send inner-txt change-style err-style-delta 0 (send inner-txt last-position))
(send inner-txt insert (lang-link-snip lang))
(let ([before-pos (send inner-txt last-position)])
(send inner-txt insert (string-constant start-with-after))
(send inner-txt change-style
err-style-delta
before-pos
(send inner-txt last-position)))
(send outer-txt change-style
(make-object style-delta% 'change-alignment 'top)
0
(send outer-txt last-position))
(send inner-txt lock #t)
(send outer-txt lock #t)
(o outer-es)
(o "\n")))
(define err-style-delta
(let ([err-sd (make-object style-delta% 'change-italic)])
(send err-sd set-delta-foreground (make-object color% 255 0 0))
err-sd))
(main))
;; change-current-lang-to : (listof string) -> void
(define (change-current-lang-to lang-strings)
(let ([lang (ormap
(λ (x)
(and (equal? lang-strings (send x get-language-position))
x))
(get-languages))])
(unless lang
(error 'change-current-lang-to "unknown language! ~s" lang-strings))
(preferences:set settings-preferences-symbol
(make-language-settings lang
(send lang default-settings)))
(message-box (string-constant drscheme)
(format
(string-constant drschemes-language-now-set)
(car (last-pair lang-strings)))))))))

4
collects/drscheme/private/main.ss
View File

@ -334,10 +334,6 @@
[else [else
(preferences:set 'framework:exit-when-no-frames #t)]) (preferences:set 'framework:exit-when-no-frames #t)])
(drscheme:app:check-new-version)
;;
;; Check for any files lost last time. ;; Check for any files lost last time.
;; Ignore the framework's empty frames test, since ;; Ignore the framework's empty frames test, since
;; the autosave information window may appear and then ;; the autosave information window may appear and then

1
collects/drscheme/private/rep.ss
View File

@ -727,6 +727,7 @@ TODO
;; ;;
(define/override (after-io-insertion) (define/override (after-io-insertion)
(super after-io-insertion)
(let ([canvas (get-active-canvas)]) (let ([canvas (get-active-canvas)])
(when canvas (when canvas
(let ([frame (send canvas get-top-level-window)]) (let ([frame (send canvas get-top-level-window)])

38
collects/drscheme/syncheck.ss
View File

@ -943,12 +943,28 @@ If the namespace does not, they are colored the unbound color.
[user-directory #f] [user-directory #f]
[user-custodian #f] [user-custodian #f]
[normal-termination? #f] [normal-termination? #f]
[show-error-report/tab
(λ () ; =drs=
(send the-tab turn-on-error-report)
(send (send the-tab get-error-report-text) scroll-to-position 0)
(when (eq? (get-current-tab) the-tab)
(show-error-report)))]
[cleanup [cleanup
(λ () ; =drs= (λ () ; =drs=
(send the-tab set-breakables old-break-thread old-custodian) (send the-tab set-breakables old-break-thread old-custodian)
(send the-tab enable-evaluation) (send the-tab enable-evaluation)
(send definitions-text end-edit-sequence) (send definitions-text end-edit-sequence)
(close-status-line 'drscheme:check-syntax))] (close-status-line 'drscheme:check-syntax)
;; do this with some lag ... not great, but should be okay.
(thread
(λ ()
(flush-output (send (send the-tab get-error-report-text) get-err-port))
(queue-callback
(λ ()
(unless (= 0 (send (send the-tab get-error-report-text) last-position))
(show-error-report/tab)))))))]
[kill-termination [kill-termination
(λ () (λ ()
(unless normal-termination? (unless normal-termination?
@ -974,23 +990,21 @@ If the namespace does not, they are colored the unbound color.
(λ () ; =user= (λ () ; =user=
(send the-tab set-breakables (current-thread) (current-custodian)) (send the-tab set-breakables (current-thread) (current-custodian))
(set-directory definitions-text) (set-directory definitions-text)
(current-error-port error-port)
(error-display-handler (error-display-handler
(λ (msg exn) ;; =user= (λ (msg exn) ;; =user=
(parameterize ([current-eventspace drs-eventspace]) (parameterize ([current-eventspace drs-eventspace])
(queue-callback (queue-callback
(λ () ;; =drs= (λ () ;; =drs=
(send the-tab turn-on-error-report) (show-error-report/tab))))
(when (eq? (get-current-tab) the-tab)
(show-error-report)))))
(parameterize ([current-error-port error-port]) (drscheme:debug:show-error-and-highlight
(drscheme:debug:show-error-and-highlight msg exn
msg exn (λ (src-to-display cms) ;; =user=
(λ (src-to-display cms) ;; =user= (parameterize ([current-eventspace drs-eventspace])
(parameterize ([current-eventspace drs-eventspace]) (queue-callback
(queue-callback (λ () ;; =drs=
(λ () ;; =drs= (send (send the-tab get-ints) highlight-errors src-to-display cms))))))
(send (send the-tab get-ints) highlight-errors src-to-display cms)))))))
(semaphore-post error-display-semaphore))) (semaphore-post error-display-semaphore)))

16
collects/eopl/info.ss
View File

@ -1,15 +1,15 @@
(module info (lib "infotab.ss" "setup") (module info (lib "infotab.ss" "setup")
(require (lib "string-constant.ss" "string-constants")) (require (lib "string-constant.ss" "string-constants"))
(define name "EoPL") (define name "EoPL")
(define doc.txt "doc.txt") (define doc.txt "doc.txt")
(define tools (list "eopl-tool.ss")) (define tools (list "eopl-tool.ss"))
(define splash-questions
(list (list (string-constant use-eopl)
(string-constant teaching-languages)
"Essentials of Programming Languages (2nd ed.)")))
(define tool-icons (list "eopl-small.gif")) (define tool-icons (list "eopl-small.gif"))
(define tool-names (list "Essentials of Programming Languages")) (define tool-names (list "Essentials of Programming Languages"))
(define tool-urls (list "http://www.cs.indiana.edu/eopl/"))) (define tool-urls (list "http://www.cs.indiana.edu/eopl/"))
(define textbook-pls
(list (list '("eopl-small.gif" "eopl")
"Essentials of Programming Languages"
(string-constant teaching-languages)
"Essentials of Programming Languages (2nd ed.)"))))

10
collects/framework/private/text.ss
View File

@ -1256,7 +1256,7 @@ WARNING: printf is rebound in the body of the unit to always
str/snp) str/snp)
old-insertion-point old-insertion-point
old-insertion-point old-insertion-point
#f) #t)
;; the idea here is that if you made a string snip, you ;; the idea here is that if you made a string snip, you
;; could have made a string and gotten the style, so you ;; could have made a string and gotten the style, so you
@ -1361,7 +1361,13 @@ WARNING: printf is rebound in the body of the unit to always
[(eq? (current-thread) (eventspace-handler-thread eventspace)) [(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'write-bytes-proc "cannot write to port on eventspace main thread")] (error 'write-bytes-proc "cannot write to port on eventspace main thread")]
[else [else
(channel-put write-chan (cons special style))]) (let ([str/snp (cond
[(string? special) special]
[(is-a? special snip%) special]
[else (format "~s" special)])])
(channel-put
write-chan
(cons str/snp style)))])
#t)) #t))
(let* ([add-standard (let* ([add-standard

19
collects/help/private/docpos.ss
View File

@ -11,12 +11,13 @@
;; Define an order on the standard docs. ;; Define an order on the standard docs.
(define (standard-html-doc-position d) (define (standard-html-doc-position d)
(if (equal? d (string->path "help")) (let ([str (path->string d)])
-1 (if (equal? str "help")
(let ([line (assoc d docs-and-positions)]) -1
(if line (let ([line (assoc str docs-and-positions)])
(caddr line) (if line
100)))) (caddr line)
100)))))
(define user-doc-positions '()) (define user-doc-positions '())
@ -71,9 +72,9 @@
("tools" "PLT Tools: DrScheme Extension Manual" 30) ("tools" "PLT Tools: DrScheme Extension Manual" 30)
("insidemz" "Inside PLT MzScheme" 50) ("insidemz" "Inside PLT MzScheme" 50)
("swindle" "Swindle Manual" 60) ("web-server" "Web Server Manual" 60)
("plot" "PLoT Manual" 61) ("swindle" "Swindle Manual" 61)
("web-server" "Web Server Manual" 62) ("plot" "PLoT Manual" 62)
("t-y-scheme" "Teach Yourself Scheme in Fixnum Days" 100) ("t-y-scheme" "Teach Yourself Scheme in Fixnum Days" 100)
("tex2page" "TeX2page" 101))) ("tex2page" "TeX2page" 101)))

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

@ -41,7 +41,9 @@
;; predicate : determines if a manual is in the section (based on its title) ;; predicate : determines if a manual is in the section (based on its title)
;; breaks -- where to insert newlines ;; breaks -- where to insert newlines
(define sections (define sections
(list (make-sec "Getting started" #rx"(Tour)|(Teach Yourself)" '()) (list (make-sec "Getting started"
#rx"(Tour)|(Teach Yourself)"
'())
(make-sec "Languages" (make-sec "Languages"
#rx"Language|MrEd" #rx"Language|MrEd"
'(#rx"Beginning Student" #rx"ProfessorJ Beginner")) '(#rx"Beginning Student" #rx"ProfessorJ Beginner"))
@ -226,21 +228,12 @@
(define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>")) (define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>"))
(define (find-manuals) (define (find-manuals)
(let* ([sys-type (system-type)] (let* ([docs (let loop ([l (find-doc-directories)])
[docs (let loop ([l (find-doc-directories)])
(cond (cond
[(null? l) null] [(null? l) null]
[(get-index-file (car l)) [(get-index-file (car l))
(cons (car l) (loop (cdr l)))] (cons (car l) (loop (cdr l)))]
[else (loop (cdr l))]))] [else (loop (cdr l))]))]
[compare-docs (lambda (a b)
(let-values ([(_1 a-short _2) (split-path a)]
[(_3 b-short _4) (split-path b)])
(let ([ap (standard-html-doc-position a-short)]
[bp (standard-html-doc-position b-short)])
(cond
[(= ap bp) (string<? (path->string a) (path->string b))]
[else (< ap bp)]))))]
[docs (quicksort docs compare-docs)] [docs (quicksort docs compare-docs)]
[names (map get-doc-name docs)] [names (map get-doc-name docs)]
[names+paths (map cons names docs)]) [names+paths (map cons names docs)])
@ -384,11 +377,7 @@
manual-name)] manual-name)]
[index-file (get-index-file doc-path)]) [index-file (get-index-file doc-path)])
(format "<LI> <A HREF=\"~a\">~a</A>~a" (format "<LI> <A HREF=\"~a\">~a</A>~a"
#;manual-name (get-help-url (build-path doc-path index-file))
#;(path->string index-file)
(get-help-url (build-path doc-path index-file))
name name
(if (and (repos-or-nightly-build?) (if (and (repos-or-nightly-build?)
(file-exists? (build-path doc-path index-file))) (file-exists? (build-path doc-path index-file)))
@ -490,7 +479,18 @@
(let-values ([(base name dir?) (split-path doc)]) (let-values ([(base name dir?) (split-path doc)])
(hash-table-remove! ht name))) (hash-table-remove! ht name)))
docs) docs)
(hash-table-map ht cons))) (quicksort
(hash-table-map ht cons)
(λ (a b) (compare-docs (car a) (car b))))))
(define (compare-docs a b)
(let-values ([(_1 a-short _2) (split-path a)]
[(_3 b-short _4) (split-path b)])
(let ([ap (standard-html-doc-position a-short)]
[bp (standard-html-doc-position b-short)])
(cond
[(= ap bp) (string<? (path->string a) (path->string b))]
[else (< ap bp)]))))
;; get-index-file : path -> (union #f path) ;; get-index-file : path -> (union #f path)
;; returns the name of the main file, if one can be found ;; returns the name of the main file, if one can be found

29
collects/help/servlets/private/util.ss
View File

@ -78,23 +78,26 @@
(define hexifiable '(#\: #\; #\? #\& #\% #\# #\< #\> #\+)) (define hexifiable '(#\: #\; #\? #\& #\% #\# #\< #\> #\+))
; string -> string ;; hexify-string : string -> string
;; exploits good properties of utf-8 encoding
;; that if can-keep? returns true that the byte is
;; the character index
(define (hexify-string s) (define (hexify-string s)
(apply string-append (apply string-append
(map (lambda (c) (map (λ (b)
(if (can-keep? c) (cond
(string c) [(can-keep? b) (string (integer->char b))]
(format "%~X" (char->integer c)))) [else (format "%~X" b)]))
(string->list s)))) (bytes->list (string->bytes/utf-8 s)))))
;; can-keep? : char -> boolean ;; can-keep? : byte -> boolean
;; source rfc 2396 ;; source rfc 2396
(define (can-keep? c) (define (can-keep? i)
(let ([i (char->integer c)]) (or (<= (char->integer #\a) i (char->integer #\z))
(or (<= (char->integer #\a) i (char->integer #\z)) (<= (char->integer #\A) i (char->integer #\Z))
(<= (char->integer #\A) i (char->integer #\Z)) (<= (char->integer #\0) i (char->integer #\9))
(<= (char->integer #\0) i (char->integer #\9)) (memq i (map char->integer
(memq c '(#\- #\_ #\; #\. #\! #\~ #\* #\' #\( #\)))))) '(#\- #\_ #\; #\. #\! #\~ #\* #\' #\( #\))))))
; string string -> xexpr ; string string -> xexpr
(define (collection-doc-link coll txt) (define (collection-doc-link coll txt)

11
collects/lang/info.ss
View File

@ -1,7 +1,16 @@
(module info (lib "infotab.ss" "setup") (module info (lib "infotab.ss" "setup")
(require (lib "string-constant.ss" "string-constants"))
(define name "HtDP Languages") (define name "HtDP Languages")
(define doc.txt "doc.txt") (define doc.txt "doc.txt")
(define tools (list "htdp-langs.ss")) (define tools (list "htdp-langs.ss"))
(define tool-icons (list '("htdp-icon.gif" "icons"))) (define tool-icons (list '("htdp-icon.gif" "icons")))
(define tool-names (list "How to Design Programs")) (define tool-names (list "How to Design Programs"))
(define tool-urls (list "http://www.htdp.org/"))) (define tool-urls (list "http://www.htdp.org/"))
(define textbook-pls
(list (list '("htdp-icon.gif" "icons")
"How to Design Programs"
(string-constant teaching-languages)
(string-constant how-to-design-programs)
(string-constant beginning-student)))))

11
collects/plai/info.ss
View File

@ -1,6 +1,15 @@
(module info (lib "infotab.ss" "setup") (module info (lib "infotab.ss" "setup")
(require (lib "string-constant.ss" "string-constants"))
(define name "PLAI") (define name "PLAI")
(define doc.txt "doc.txt") (define doc.txt "doc.txt")
(define tools (list "plai-tool.ss")) (define tools (list "plai-tool.ss"))
(define tool-names (list "Programming Languages: Application and Interpretation")) (define tool-names (list "Programming Languages: Application and Interpretation"))
(define tool-urls (list "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/"))) (define tool-urls (list "http://www.cs.brown.edu/~sk/Publications/Books/ProgLangs/"))
(define textbook-pls
(list (list '("plai-icon.png" "plai")
"Programming Languages: Application and Interpretation"
(string-constant teaching-languages)
"Programming Languages: Application and Interpretation"
"PLAI - Beginning Student"))))

BIN
collects/plai/plai-icon.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1018 B

26
collects/string-constants/english-string-constants.ss
View File

@ -972,7 +972,7 @@ please adhere to these guidelines:
(full-language "Full") ;; also in the HtDP languages section (full-language "Full") ;; also in the HtDP languages section
(how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one... (how-to-design-programs "How to Design Programs") ;; should agree with MIT Press on this one...
(r5rs-like-languages "R5RS-like") (r5rs-like-languages "R5RS-like")
(pretty-big-scheme "Pretty Big (includes MrEd and Advanced)") (pretty-big-scheme "Pretty Big (includes MrEd and Advanced Student)")
(pretty-big-scheme-one-line-summary "Adds syntax and functions from the HtDP languages") (pretty-big-scheme-one-line-summary "Adds syntax and functions from the HtDP languages")
(r5rs-lang-name "Standard (R5RS)") (r5rs-lang-name "Standard (R5RS)")
(r5rs-one-line-summary "R5RS, with no frills") (r5rs-one-line-summary "R5RS, with no frills")
@ -981,10 +981,32 @@ please adhere to these guidelines:
(professional-languages "Professional Languages") (professional-languages "Professional Languages")
(teaching-languages "Teaching Languages") (teaching-languages "Teaching Languages")
(experimental-languages "Experimental Languages") (experimental-languages "Experimental Languages")
(not-really-languages "Not really languages")
(choose-a-language-language "Choose a language language")
(module-language-one-line-summary "Run creates a REPL in the context of the module, including the module's declared language") (module-language-one-line-summary "Run creates a REPL in the context of the module, including the module's declared language")
;;; from the `not a language language' used initially in drscheme.
(must-choose-language "DrScheme cannot process programs until you choose a programming language.")
; intro to using a textbook
(using-a-text-book? "Are you using one of the these textbooks?")
; next two are used with each textbook
(start-with-before "Start with ")
(start-with-after ".")
; next ones are the default choices at the end of the list in the not-a-language-language error message
(seasoned-plt-schemer-before "Are you a seasoned PLT Schemer? Try ")
(seasoned-plt-schemer-after ".")
(otherwise-use-before "Otherwise, use ")
(otherwise-use-between ",\nor choose for yourself from the ")
(otherwise-use-language-dialog "language dialog") ; this one will become clickable and will open the language dialog
(otherwise-use-after ".")
; after clicking a language, this tells you that its done. The ~a is filled in with
; the name of the language
(drschemes-language-now-set "DrScheme's Language is now set to:\n ~a")
;;; debug language ;;; debug language
(unknown-debug-frame "[unknown]") (unknown-debug-frame "[unknown]")
(backtrace-window-title "Backtrace - DrScheme") (backtrace-window-title "Backtrace - DrScheme")

11
collects/tests/drscheme/repl-test.ss
View File

@ -621,6 +621,17 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
void void
void) void)
(make-test "(write-special 1)"
"1"
"1"
#f
'interactions
#f
#f
#f
void
void)
(make-test (make-test
;; the begin/void combo is to make sure that no value printout ;; the begin/void combo is to make sure that no value printout
;; comes and messes up the source location for the error. ;; comes and messes up the source location for the error.