added the not-a-language-language and some bug fixes elsewhere
svn: r1129
This commit is contained in:
Robby Findler
parent
6a0f96188f
commit
8861cff087
|
|
@ -1,23 +1,7 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(require (lib "string-constant.ss" "string-constants"))
|
||||
|
||||
;; added a comment, in windows ...
|
||||
(define name "DrScheme")
|
||||
(define tools (list "syncheck.ss"))
|
||||
(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-libraries (list "drscheme.ss"))
|
||||
(define mred-launcher-flags (list (list "-ZmvqL" "drscheme.ss" "drscheme"))))
|
||||
|
|
|
|||
|
|
@ -39,447 +39,6 @@
|
|||
(super-new
|
||||
(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))))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
|
|
@ -179,8 +179,7 @@
|
|||
context<%>))
|
||||
|
||||
(define-signature drscheme:app^
|
||||
(check-new-version
|
||||
about-drscheme
|
||||
(about-drscheme
|
||||
invite-tour
|
||||
add-language-items-to-help-menu
|
||||
add-important-urls-to-help-menu
|
||||
|
|
|
|||
|
|
@ -46,9 +46,8 @@
|
|||
;; if a language is registered with this position, it is
|
||||
;; considered the default language
|
||||
(define default-language-position
|
||||
(list (string-constant teaching-languages)
|
||||
(string-constant how-to-design-programs)
|
||||
(string-constant beginning-student)))
|
||||
(list (string-constant not-really-languages)
|
||||
(string-constant choose-a-language-language)))
|
||||
|
||||
;; languages : (listof (instanceof language<%>))
|
||||
;; all of the languages supported in DrScheme
|
||||
|
|
@ -1328,4 +1327,204 @@
|
|||
(list -1000 -1000)
|
||||
#f
|
||||
(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)))))))))
|
||||
|
|
|
|||
|
|
@ -334,10 +334,6 @@
|
|||
[else
|
||||
(preferences:set 'framework:exit-when-no-frames #t)])
|
||||
|
||||
|
||||
(drscheme:app:check-new-version)
|
||||
|
||||
;;
|
||||
;; Check for any files lost last time.
|
||||
;; Ignore the framework's empty frames test, since
|
||||
;; the autosave information window may appear and then
|
||||
|
|
|
|||
|
|
@ -727,6 +727,7 @@ TODO
|
|||
;;
|
||||
|
||||
(define/override (after-io-insertion)
|
||||
(super after-io-insertion)
|
||||
(let ([canvas (get-active-canvas)])
|
||||
(when canvas
|
||||
(let ([frame (send canvas get-top-level-window)])
|
||||
|
|
|
|||
|
|
@ -943,12 +943,28 @@ If the namespace does not, they are colored the unbound color.
|
|||
[user-directory #f]
|
||||
[user-custodian #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
|
||||
(λ () ; =drs=
|
||||
(send the-tab set-breakables old-break-thread old-custodian)
|
||||
(send the-tab enable-evaluation)
|
||||
(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
|
||||
(λ ()
|
||||
(unless normal-termination?
|
||||
|
|
@ -974,23 +990,21 @@ If the namespace does not, they are colored the unbound color.
|
|||
(λ () ; =user=
|
||||
(send the-tab set-breakables (current-thread) (current-custodian))
|
||||
(set-directory definitions-text)
|
||||
(current-error-port error-port)
|
||||
(error-display-handler
|
||||
(λ (msg exn) ;; =user=
|
||||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(λ () ;; =drs=
|
||||
(send the-tab turn-on-error-report)
|
||||
(when (eq? (get-current-tab) the-tab)
|
||||
(show-error-report)))))
|
||||
(show-error-report/tab))))
|
||||
|
||||
(parameterize ([current-error-port error-port])
|
||||
(drscheme:debug:show-error-and-highlight
|
||||
msg exn
|
||||
(λ (src-to-display cms) ;; =user=
|
||||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(λ () ;; =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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(require (lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(define name "EoPL")
|
||||
(define doc.txt "doc.txt")
|
||||
(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-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.)"))))
|
||||
|
|
|
|||
|
|
@ -1256,7 +1256,7 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
str/snp)
|
||||
old-insertion-point
|
||||
old-insertion-point
|
||||
#f)
|
||||
#t)
|
||||
|
||||
;; the idea here is that if you made a string snip, 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))
|
||||
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
|
||||
[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))
|
||||
|
||||
(let* ([add-standard
|
||||
|
|
|
|||
|
|
@ -11,12 +11,13 @@
|
|||
|
||||
;; Define an order on the standard docs.
|
||||
(define (standard-html-doc-position d)
|
||||
(if (equal? d (string->path "help"))
|
||||
(let ([str (path->string d)])
|
||||
(if (equal? str "help")
|
||||
-1
|
||||
(let ([line (assoc d docs-and-positions)])
|
||||
(let ([line (assoc str docs-and-positions)])
|
||||
(if line
|
||||
(caddr line)
|
||||
100))))
|
||||
100)))))
|
||||
|
||||
(define user-doc-positions '())
|
||||
|
||||
|
|
@ -71,9 +72,9 @@
|
|||
("tools" "PLT Tools: DrScheme Extension Manual" 30)
|
||||
("insidemz" "Inside PLT MzScheme" 50)
|
||||
|
||||
("swindle" "Swindle Manual" 60)
|
||||
("plot" "PLoT Manual" 61)
|
||||
("web-server" "Web Server Manual" 62)
|
||||
("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)))
|
||||
|
|
|
|||
|
|
@ -41,7 +41,9 @@
|
|||
;; 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)" '())
|
||||
(list (make-sec "Getting started"
|
||||
#rx"(Tour)|(Teach Yourself)"
|
||||
'())
|
||||
(make-sec "Languages"
|
||||
#rx"Language|MrEd"
|
||||
'(#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 (find-manuals)
|
||||
(let* ([sys-type (system-type)]
|
||||
[docs (let loop ([l (find-doc-directories)])
|
||||
(let* ([docs (let loop ([l (find-doc-directories)])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(get-index-file (car l))
|
||||
(cons (car l) (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)]
|
||||
[names (map get-doc-name docs)]
|
||||
[names+paths (map cons names docs)])
|
||||
|
|
@ -384,11 +377,7 @@
|
|||
manual-name)]
|
||||
[index-file (get-index-file doc-path)])
|
||||
(format "<LI> <A HREF=\"~a\">~a</A>~a"
|
||||
#;manual-name
|
||||
#;(path->string index-file)
|
||||
(get-help-url (build-path doc-path index-file))
|
||||
|
||||
|
||||
name
|
||||
(if (and (repos-or-nightly-build?)
|
||||
(file-exists? (build-path doc-path index-file)))
|
||||
|
|
@ -490,7 +479,18 @@
|
|||
(let-values ([(base name dir?) (split-path doc)])
|
||||
(hash-table-remove! ht name)))
|
||||
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)
|
||||
;; returns the name of the main file, if one can be found
|
||||
|
|
|
|||
|
|
@ -78,23 +78,26 @@
|
|||
|
||||
(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)
|
||||
(apply string-append
|
||||
(map (lambda (c)
|
||||
(if (can-keep? c)
|
||||
(string c)
|
||||
(format "%~X" (char->integer c))))
|
||||
(string->list s))))
|
||||
(map (λ (b)
|
||||
(cond
|
||||
[(can-keep? b) (string (integer->char b))]
|
||||
[else (format "%~X" b)]))
|
||||
(bytes->list (string->bytes/utf-8 s)))))
|
||||
|
||||
;; can-keep? : char -> boolean
|
||||
;; can-keep? : byte -> boolean
|
||||
;; source rfc 2396
|
||||
(define (can-keep? c)
|
||||
(let ([i (char->integer c)])
|
||||
(define (can-keep? i)
|
||||
(or (<= (char->integer #\a) i (char->integer #\z))
|
||||
(<= (char->integer #\A) i (char->integer #\Z))
|
||||
(<= (char->integer #\0) i (char->integer #\9))
|
||||
(memq c '(#\- #\_ #\; #\. #\! #\~ #\* #\' #\( #\))))))
|
||||
(memq i (map char->integer
|
||||
'(#\- #\_ #\; #\. #\! #\~ #\* #\' #\( #\))))))
|
||||
|
||||
; string string -> xexpr
|
||||
(define (collection-doc-link coll txt)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,16 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(require (lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(define name "HtDP Languages")
|
||||
(define doc.txt "doc.txt")
|
||||
(define tools (list "htdp-langs.ss"))
|
||||
(define tool-icons (list '("htdp-icon.gif" "icons")))
|
||||
(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)))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,15 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(require (lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(define name "PLAI")
|
||||
(define doc.txt "doc.txt")
|
||||
(define tools (list "plai-tool.ss"))
|
||||
(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
BIN
collects/plai/plai-icon.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1018 B |
|
|
@ -972,7 +972,7 @@ please adhere to these guidelines:
|
|||
(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...
|
||||
(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")
|
||||
(r5rs-lang-name "Standard (R5RS)")
|
||||
(r5rs-one-line-summary "R5RS, with no frills")
|
||||
|
|
@ -981,9 +981,31 @@ please adhere to these guidelines:
|
|||
(professional-languages "Professional Languages")
|
||||
(teaching-languages "Teaching 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")
|
||||
|
||||
;;; 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
|
||||
(unknown-debug-frame "[unknown]")
|
||||
|
|
|
|||
|
|
@ -621,6 +621,17 @@ There shouldn't be any error (but add in a bug that triggers one to be sure!)
|
|||
void
|
||||
void)
|
||||
|
||||
(make-test "(write-special 1)"
|
||||
"1"
|
||||
"1"
|
||||
#f
|
||||
'interactions
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
void
|
||||
void)
|
||||
|
||||
(make-test
|
||||
;; the begin/void combo is to make sure that no value printout
|
||||
;; comes and messes up the source location for the error.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user