2d2b3bee2f
The code used eq? to check to see if a given language was in an list of allowed-to-create-executables languages. But the language object was passing thru TR and so eq? didn't hold and thus the check was buggy.
2413 lines
115 KiB
Racket
2413 lines
115 KiB
Racket
#lang racket/base
|
|
(require (prefix-in : mred/mred) ;; ensure that this module is always loaded since it is shared below for pretty big
|
|
racket/unit
|
|
mrlib/hierlist
|
|
racket/class
|
|
racket/contract
|
|
racket/string
|
|
racket/list
|
|
racket/gui/base
|
|
"drsig.rkt"
|
|
"tooltip.rkt"
|
|
string-constants
|
|
framework
|
|
setup/getinfo
|
|
setup/xref
|
|
scribble/xref
|
|
scribble/tag
|
|
net/url
|
|
syntax/toplevel
|
|
browser/external
|
|
(only-in mzlib/struct make-->vector))
|
|
|
|
(define original-output (current-output-port))
|
|
(define (oprintf . args) (apply fprintf original-output args))
|
|
|
|
(define-values (sc-use-language-in-source sc-use-teaching-language sc-choose-a-language mouse-event-uses-shortcut-prefix?)
|
|
(let* ([shortcut-prefix (get-default-shortcut-prefix)]
|
|
[menukey-string
|
|
(apply string-append
|
|
(map (λ (x)
|
|
(case x
|
|
[(cmd) "⌘"]
|
|
[else (format "~a-" x)]))
|
|
shortcut-prefix))])
|
|
(define (mouse-event-uses-shortcut-prefix? evt)
|
|
(andmap (λ (prefix)
|
|
(case prefix
|
|
[(alt) (case (system-type)
|
|
[(windows) (send evt get-meta-down)]
|
|
[else (send evt get-alt-down)])]
|
|
[(cmd) (send evt get-meta-down)]
|
|
[(meta) (send evt get-meta-down)]
|
|
[(ctl) (send evt get-control-down)]
|
|
[(shift) (send evt get-shiftdown)]
|
|
[(option) (send evt get-alt-down)]))
|
|
shortcut-prefix))
|
|
(values (string-append (string-constant the-racket-language)
|
|
(format " (~aR)" menukey-string))
|
|
(string-append (string-constant teaching-languages)
|
|
(format " (~aT)" menukey-string))
|
|
(string-append (string-constant other-languages)
|
|
(format " (~aO)" menukey-string))
|
|
mouse-event-uses-shortcut-prefix?)))
|
|
|
|
(provide language-configuration@)
|
|
|
|
(define-unit language-configuration@
|
|
(import [prefix drracket:unit: drracket:unit^]
|
|
[prefix drracket:rep: drracket:rep^]
|
|
[prefix drracket:init: drracket:init^]
|
|
[prefix drracket:language: drracket:language^]
|
|
[prefix drracket:app: drracket:app^]
|
|
[prefix drracket:tools: drracket:tools^]
|
|
[prefix drracket:help-desk: drracket:help-desk^]
|
|
[prefix drracket:module-language: drracket:module-language/int^]
|
|
[prefix drracket: drracket:interface^])
|
|
(export drracket:language-configuration/internal^)
|
|
|
|
;; settings-preferences-symbol : symbol
|
|
;; this pref used to depend on `version', but no longer does.
|
|
(define settings-preferences-symbol 'drracket:language-settings)
|
|
|
|
;; get-settings-preferences-symbol : -> symbol
|
|
(define (get-settings-preferences-symbol) settings-preferences-symbol)
|
|
|
|
;; default-language-position : (listof string)
|
|
;; if a language is registered with this position, it is
|
|
;; considered the default language
|
|
(define initial-language-position
|
|
(list (string-constant initial-language-category)
|
|
(string-constant no-language-chosen)))
|
|
|
|
;; languages : (listof (instanceof language<%>))
|
|
;; all of the languages supported in DrRacket
|
|
(define languages null)
|
|
|
|
(define languages-allowing-executable-creation '())
|
|
(define (language-allows-executable-creation? candidate-lang)
|
|
(define candidates-positions (send candidate-lang get-language-position))
|
|
(for/or ([allowed-lang (in-list languages-allowing-executable-creation)])
|
|
(equal? (send allowed-lang get-language-position)
|
|
candidates-positions)))
|
|
|
|
;; add-language : (instanceof language%) -> void
|
|
;; only allows addition on phase2
|
|
;; effect: updates `languages'
|
|
(define (add-language language [front? #f] #:allow-executable-creation? [allow-executable-creation? #f])
|
|
|
|
(drracket:tools:only-in-phase 'drracket:language:add-language 'phase2)
|
|
(for-each
|
|
(λ (i<%>)
|
|
(unless (is-a? language i<%>)
|
|
(error 'drracket:language:add-language
|
|
"expected language ~e to implement ~e, forgot to use `drracket:language:get-default-mixin'?"
|
|
language i<%>)))
|
|
(drracket:language:get-language-extensions))
|
|
|
|
(ensure-no-duplicate-numbers language languages)
|
|
(when allow-executable-creation?
|
|
(set! languages-allowing-executable-creation
|
|
(cons language languages-allowing-executable-creation)))
|
|
(set! languages
|
|
(if front?
|
|
(cons language languages)
|
|
(append languages (list language)))))
|
|
|
|
(define (ensure-no-duplicate-numbers l1 languages)
|
|
(for-each
|
|
(λ (l2)
|
|
(when (equal? (send l1 get-language-numbers)
|
|
(send l2 get-language-numbers))
|
|
(error 'drracket:language-configuration:add-language
|
|
"found two languages with the same result from get-language-numbers: ~s, ~s and ~s"
|
|
(send l1 get-language-numbers)
|
|
(send l1 get-language-position)
|
|
(send l2 get-language-position))))
|
|
languages))
|
|
|
|
;; get-languages : -> (listof languages)
|
|
(define (get-languages)
|
|
(drracket:tools:only-in-phase
|
|
'drracket:language-configuration:get-languages
|
|
'init-complete)
|
|
languages)
|
|
|
|
;; get-default-language-settings : -> language-settings
|
|
;; uses `default-language-position' to find the default language.
|
|
;; if that language is not available, just takes the first language.
|
|
;; if there are no languages defined yet, signal an error -- drscheme is in trouble.
|
|
(define (get-default-language-settings)
|
|
(when (null? languages)
|
|
(error 'get-default-language-settings "no languages registered!"))
|
|
(let ([lang (or (ormap (λ (x)
|
|
(and (equal? (send x get-language-position)
|
|
initial-language-position)
|
|
x))
|
|
(get-languages))
|
|
(list-ref (get-languages) 0))])
|
|
(language-settings lang (send lang default-settings))))
|
|
|
|
;; type language-settings = (language-settings (instanceof language<%>) settings)
|
|
(define-struct language-settings (language settings))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ; ;
|
|
; ; ; ;
|
|
; ; ; ;
|
|
; ; ;;; ; ;; ;; ; ; ; ;;; ;; ; ;;; ;; ; ; ;;; ; ;;; ;; ;
|
|
; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;;; ; ; ; ;;;; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ;;
|
|
; ; ;;;;; ; ; ;; ; ;; ; ;;;;; ;; ; ;;;; ;; ; ; ;;;;; ; ;;; ;; ;
|
|
; ; ; ;
|
|
; ; ; ; ; ; ;
|
|
; ;;;; ;;;; ;;;;
|
|
|
|
|
|
;; language-dialog : (boolean language-setting -> (union #f language-setting))
|
|
;; (boolean language-setting (union #f (instanceof top-level-window%))
|
|
;; ->
|
|
;; (union #f language-setting))
|
|
;; allows the user to configure their language. The input language-setting is used
|
|
;; as the defaults in the dialog and the output language setting is the user's choice
|
|
;; todo: when button is clicked, ensure language is selected
|
|
(define language-dialog
|
|
(λ (show-welcome? language-settings-to-show [parent #f])
|
|
(define ret-dialog%
|
|
(class (frame:focus-table-mixin dialog%)
|
|
(define/override (on-subwindow-char receiver evt)
|
|
(case (send evt get-key-code)
|
|
[(escape) (cancel-callback)]
|
|
[(#\return numpad-enter) (enter-callback)]
|
|
[else
|
|
(or (key-pressed receiver evt)
|
|
(super on-subwindow-char receiver evt))]))
|
|
(super-new)))
|
|
|
|
(define dialog (instantiate ret-dialog% ()
|
|
(label (if show-welcome?
|
|
(string-constant welcome-to-drscheme)
|
|
(string-constant language-dialog-title)))
|
|
(parent parent)
|
|
(style '(resize-border))))
|
|
(define welcome-before-panel (instantiate horizontal-pane% ()
|
|
(parent dialog)
|
|
(stretchable-height #f)))
|
|
(define language-dialog-meat-panel (make-object vertical-pane% dialog))
|
|
|
|
(define welcome-after-panel (instantiate vertical-pane% ()
|
|
(parent dialog)
|
|
(stretchable-height #f)))
|
|
|
|
(define button-panel (instantiate horizontal-pane% ()
|
|
(parent dialog)
|
|
(stretchable-height #f)))
|
|
|
|
;; initialized below
|
|
(define ok-button #f)
|
|
(define cancel-button #f)
|
|
|
|
;; cancelled? : boolean
|
|
;; flag that indicates if the dialog was cancelled.
|
|
(define cancelled? #t)
|
|
|
|
;; enter-callback : -> bool
|
|
;; returns #f if no language is selected (so the event will be
|
|
;; processed by the hierlist widget, which will toggle subtrees)
|
|
(define (enter-callback)
|
|
(cond [(get-selected-language)
|
|
(set! cancelled? #f)
|
|
(send dialog show #f)]
|
|
[else #f]))
|
|
|
|
;; ok-callback : -> void
|
|
;; similar to the above, but shows an error dialog if no language os
|
|
;; selected
|
|
(define (ok-callback)
|
|
(unless (enter-callback)
|
|
(message-box (string-constant drscheme)
|
|
(string-constant please-select-a-language)
|
|
#:dialog-mixin frame:focus-table-mixin)))
|
|
|
|
;; cancel-callback : -> void
|
|
(define (cancel-callback)
|
|
(send dialog show #f))
|
|
|
|
;; a handler for "ok"-related stuff
|
|
(define ok-handler
|
|
;; this is called before the buttons are made: keep track of state
|
|
;; in that case
|
|
(let ([enabled? #t])
|
|
(define (enable! state)
|
|
(set! enabled? state)
|
|
(when ok-button (send ok-button enable state)))
|
|
(λ (msg)
|
|
(case msg
|
|
[(disable) (enable! #f)]
|
|
[(enable) (enable! #t)]
|
|
[(enable-sync) (enable! enabled?)]
|
|
[(execute) (enter-callback) (void)]
|
|
[else (error 'ok-handler "internal error (~e)" msg)]))))
|
|
|
|
(define-values (get-selected-language get-selected-language-settings key-pressed)
|
|
(fill-language-dialog language-dialog-meat-panel
|
|
button-panel
|
|
language-settings-to-show
|
|
#f
|
|
ok-handler
|
|
(and (is-a? parent drracket:unit:frame<%>)
|
|
(send parent get-definitions-text))))
|
|
|
|
;; create ok/cancel buttons
|
|
(make-object horizontal-pane% button-panel)
|
|
(set!-values (ok-button cancel-button)
|
|
(gui-utils:ok/cancel-buttons button-panel
|
|
(λ (x y) (ok-callback))
|
|
(λ (x y) (cancel-callback))))
|
|
(ok-handler 'enable-sync) ; sync enable status now
|
|
(make-object grow-box-spacer-pane% button-panel)
|
|
|
|
(when show-welcome?
|
|
(add-welcome dialog welcome-before-panel welcome-after-panel))
|
|
|
|
(send dialog stretchable-width #f)
|
|
(send dialog stretchable-height #f)
|
|
|
|
(unless parent
|
|
(send dialog center 'both))
|
|
(send dialog show #t)
|
|
(if cancelled?
|
|
#f
|
|
(language-settings
|
|
(get-selected-language)
|
|
(get-selected-language-settings)))))
|
|
|
|
;; fill-language-dialog : (vertical-panel panel language-setting -> language-setting)
|
|
;; (union dialog #f) [...more stuff...]
|
|
;; -> (-> (union #f language<%>)) (-> settings[corresponding to fst thnk result])
|
|
;; allows the user to configure their language. The input language-setting is used
|
|
;; as the defaults in the dialog and the output language setting is the user's choice
|
|
;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd.
|
|
(define fill-language-dialog
|
|
(λ (parent show-details-parent language-settings-to-show
|
|
[re-center #f]
|
|
[ok-handler void]
|
|
[definitions-text #f]) ; en/disable button, execute it
|
|
|
|
(define-values (language-to-show settings-to-show)
|
|
(let ([request-lang-to-show (language-settings-language language-settings-to-show)])
|
|
(cond
|
|
[(equal? initial-language-position (send request-lang-to-show get-language-position))
|
|
(values (list-ref (get-languages) 0)
|
|
(send (list-ref (get-languages) 0) default-settings))
|
|
(values #f #f)]
|
|
[else (values request-lang-to-show
|
|
(language-settings-settings language-settings-to-show))])))
|
|
|
|
;; hier-list items that implement this interface correspond to
|
|
;; actual language selections
|
|
(define hieritem-language<%>
|
|
(interface (hierarchical-list-item<%>)
|
|
get-language
|
|
selected))
|
|
|
|
(define selectable-hierlist%
|
|
(class hierarchical-list%
|
|
(init parent)
|
|
|
|
(inherit get-selected
|
|
client->screen
|
|
get-editor)
|
|
(define/override (on-char evt)
|
|
(let ([code (send evt get-key-code)])
|
|
(case code
|
|
[(up) (select-next sub1)]
|
|
[(down) (select-next add1)]
|
|
;; right key is fine, but nicer to close after a left
|
|
[(left) (super on-char evt)
|
|
(cond [(get-selected)
|
|
=> (λ (i)
|
|
(when (is-a? i hierarchical-list-compound-item<%>)
|
|
(send i close)))])]
|
|
[else (super on-char evt)])))
|
|
|
|
(inherit get-items)
|
|
|
|
;; select-next : (num -> num) -> void
|
|
;; finds the next/prev leaf after the selected child on the open
|
|
;; fringe using `inc' for a direction.
|
|
(define/private (select-next inc)
|
|
(define current (get-selected))
|
|
(define (choose item)
|
|
(when current (send current select #f))
|
|
(send item select #t)
|
|
;; make it visible
|
|
(let loop ([item item])
|
|
(let ([parent (send item get-parent)])
|
|
(if parent
|
|
(loop parent)
|
|
(send item scroll-to))))
|
|
(send item scroll-to))
|
|
(define (selectable? item)
|
|
(and (send item get-allow-selection?)
|
|
;; opened all the way to the top
|
|
(let loop ([p (send item get-parent)])
|
|
(or (not p)
|
|
(and (send p is-open?)
|
|
(loop (send p get-parent)))))))
|
|
(let* ([fringe (get-fringe)]
|
|
[fringe-len (vector-length fringe)]
|
|
[n (if current
|
|
(let loop ([i (sub1 (vector-length fringe))])
|
|
(cond [(< i 0) (error 'select-next "item not found in fringe")]
|
|
[(eq? current (vector-ref fringe i))
|
|
(min (sub1 fringe-len) (max 0 (inc i)))]
|
|
[else (loop (sub1 i))]))
|
|
(modulo (inc fringe-len) (add1 fringe-len)))])
|
|
;; need to choose item n, but go on looking for one that is
|
|
;; selectable and open
|
|
(let loop ([n n])
|
|
(when (< -1 n fringe-len)
|
|
(let ([item (vector-ref fringe n)])
|
|
(if (selectable? item)
|
|
(choose item)
|
|
(loop (inc n))))))))
|
|
|
|
(define cached-fringe #f)
|
|
(define/public (clear-fringe-cache) (set! cached-fringe #f))
|
|
(define (get-fringe)
|
|
(unless cached-fringe
|
|
(let ([fringe
|
|
(let loop ([items (get-items)])
|
|
(apply append
|
|
(map (λ (item)
|
|
(if (is-a? item hierarchical-list-compound-item<%>)
|
|
(cons item
|
|
(loop (send item get-items)))
|
|
(list item)))
|
|
items)))])
|
|
(set! cached-fringe (list->vector fringe))))
|
|
cached-fringe)
|
|
|
|
(define/override (on-select i)
|
|
(cond
|
|
[(and i (is-a? i hieritem-language<%>))
|
|
(define pos (send (send i get-language) get-language-position))
|
|
(if (eq? this teaching-languages-hier-list)
|
|
(preferences:set 'drracket:language-dialog:teaching-hierlist-default pos)
|
|
(preferences:set 'drracket:language-dialog:hierlist-default pos))
|
|
(if (eq? this teaching-languages-hier-list)
|
|
(set! most-recent-teaching-languages-hier-list-selection pos)
|
|
(set! most-recent-languages-hier-list-selection pos))
|
|
(something-selected this i)]
|
|
[else
|
|
(non-language-selected)]))
|
|
;; this is used only because we set `on-click-always'
|
|
(define/override (on-click i)
|
|
(when (and i (is-a? i hierarchical-list-compound-item<%>))
|
|
(send i toggle-open/closed)))
|
|
;; double-click selects a language
|
|
(define/override (on-double-select i)
|
|
(when (and i (is-a? i hieritem-language<%>))
|
|
(something-selected this i)
|
|
(ok-handler 'execute)))
|
|
|
|
(define tooltip-timer
|
|
(new timer%
|
|
[notify-callback (λ () (show-tooltip))]))
|
|
(define tooltip-frame #f)
|
|
(define hieritem-language-to-show-in-tooltip #f)
|
|
(define hieritem-tooltip-x #f)
|
|
(define hieritem-tooltip-y #f)
|
|
(define hieritem-tooltip-w #f)
|
|
(define hieritem-tooltip-h #f)
|
|
(define/override (on-event evt)
|
|
(super on-event evt)
|
|
(cond
|
|
[(or (send evt entering?)
|
|
(send evt moving?))
|
|
(define-values (ex ey) (send (get-editor) dc-location-to-editor-location
|
|
(send evt get-x)
|
|
(send evt get-y)))
|
|
(define-values (_to-show-in-tooltip _x _y _w _h)
|
|
(find-snip ex ey))
|
|
(unless (equal? _to-show-in-tooltip
|
|
hieritem-language-to-show-in-tooltip)
|
|
(set! hieritem-language-to-show-in-tooltip _to-show-in-tooltip)
|
|
(set! hieritem-tooltip-x _x)
|
|
(set! hieritem-tooltip-y _y)
|
|
(set! hieritem-tooltip-w _w)
|
|
(set! hieritem-tooltip-h _h)
|
|
(when tooltip-frame (send tooltip-frame show #f))
|
|
(send tooltip-timer stop)
|
|
(when hieritem-language-to-show-in-tooltip (send tooltip-timer start 200 #t)))]
|
|
[(send evt leaving?)
|
|
(set! hieritem-language-to-show-in-tooltip #f)
|
|
(send tooltip-timer stop)]))
|
|
(define bl (box 0))
|
|
(define bt (box 0))
|
|
(define br (box 0))
|
|
(define bb (box 0))
|
|
(define/private (find-snip x y)
|
|
(let loop ([snip (send (get-editor) find-first-snip)]
|
|
[editor (get-editor)]
|
|
[x x]
|
|
[y y])
|
|
(cond
|
|
[(not snip) (values #f #f #f #f #f)]
|
|
[else
|
|
(send editor get-snip-location snip bl bt #f)
|
|
(send editor get-snip-location snip br bb #t)
|
|
(cond
|
|
[(and (is-a? snip hierarchical-item-snip%)
|
|
(is-a? (send snip get-item) hieritem-language<%>)
|
|
(<= (unbox bl) x (unbox br))
|
|
(<= (unbox bt) y (unbox bb)))
|
|
(define w (- (unbox br) (unbox bl)))
|
|
(define h (- (unbox bb) (unbox bt)))
|
|
(send editor local-to-global bl bt)
|
|
(define-values (x y) (client->screen
|
|
(inexact->exact (round (unbox bl)))
|
|
(inexact->exact (round (unbox bt)))))
|
|
(define-values (dl dt) (get-display-left-top-inset))
|
|
(values (send snip get-item)
|
|
(- x dl)
|
|
(- y dt)
|
|
(inexact->exact (round w))
|
|
(inexact->exact (round h)))]
|
|
[(is-a? snip editor-snip%)
|
|
(define-values (es ex ey ew eh)
|
|
(loop (send (send snip get-editor) find-first-snip)
|
|
(send snip get-editor)
|
|
(- x (unbox bl))
|
|
(- y (unbox bt))))
|
|
(if es
|
|
(values es ex ey ew eh)
|
|
(loop (send snip next) editor x y))]
|
|
[else
|
|
(loop (send snip next) editor x y)])])))
|
|
(define/private (show-tooltip)
|
|
(when hieritem-language-to-show-in-tooltip
|
|
(define msg (send (send hieritem-language-to-show-in-tooltip get-language)
|
|
get-one-line-summary))
|
|
(when msg
|
|
(unless tooltip-frame
|
|
(set! tooltip-frame (new tooltip-frame%
|
|
[frame-to-track
|
|
(let loop ([w this])
|
|
(cond
|
|
[(is-a? w top-level-window<%>)
|
|
w]
|
|
[(is-a? w area<%>)
|
|
(loop (send w get-parent))]
|
|
[else #f]))])))
|
|
(send tooltip-frame set-tooltip (list msg))
|
|
(send tooltip-frame show-over
|
|
(+ hieritem-tooltip-x hieritem-tooltip-w 4)
|
|
hieritem-tooltip-y
|
|
0
|
|
0))))
|
|
|
|
(define/public (hide-tooltip)
|
|
(when tooltip-frame
|
|
(send tooltip-frame show #f)))
|
|
|
|
(super-new [parent parent])
|
|
;; do this so we can expand/collapse languages on a single click
|
|
(inherit on-click-always allow-deselect)
|
|
(on-click-always #t)
|
|
(allow-deselect #t)))
|
|
|
|
(define outermost-panel (new horizontal-panel%
|
|
[parent parent]
|
|
[alignment '(left top)]))
|
|
(define languages-choice-panel (new vertical-panel%
|
|
[parent outermost-panel]
|
|
[stretchable-height #f]
|
|
[alignment '(left top)]))
|
|
|
|
(define the-racket-language-panel (new vertical-panel%
|
|
[parent languages-choice-panel]
|
|
[alignment '(left top)]
|
|
[stretchable-height #f]))
|
|
|
|
(define use-language-in-source-rb
|
|
(new radio-box%
|
|
[label #f]
|
|
[choices (list sc-use-language-in-source)]
|
|
[parent the-racket-language-panel]
|
|
[callback
|
|
(λ (rb evt)
|
|
(use-language-in-source-rb-callback))]))
|
|
(define (use-language-in-source-rb-callback)
|
|
(module-language-selected)
|
|
(send use-chosen-language-rb set-selection #f)
|
|
(send use-teaching-language-rb set-selection #f))
|
|
(define in-source-discussion-panel (new horizontal-panel%
|
|
[parent the-racket-language-panel]
|
|
[stretchable-height #f]))
|
|
(define in-source-discussion-spacer (new horizontal-panel%
|
|
[parent in-source-discussion-panel]
|
|
[stretchable-width #f]
|
|
[min-width 32]))
|
|
(define in-source-discussion-editor-canvas
|
|
(add-discussion in-source-discussion-panel definitions-text use-language-in-source-rb-callback))
|
|
(define most-recent-languages-hier-list-selection
|
|
(preferences:get 'drracket:language-dialog:hierlist-default))
|
|
(define most-recent-teaching-languages-hier-list-selection
|
|
(preferences:get 'drracket:language-dialog:teaching-hierlist-default))
|
|
|
|
(define use-teaching-language-rb
|
|
(new radio-box%
|
|
[label #f]
|
|
[choices (list sc-use-teaching-language)]
|
|
[parent languages-choice-panel]
|
|
[callback
|
|
(λ (rb evt)
|
|
(use-teaching-language-rb-callback))]))
|
|
(define (use-teaching-language-rb-callback)
|
|
(when most-recent-teaching-languages-hier-list-selection
|
|
(select-a-language-in-hierlist teaching-languages-hier-list
|
|
(cdr most-recent-teaching-languages-hier-list-selection)))
|
|
(send use-chosen-language-rb set-selection #f)
|
|
(send use-language-in-source-rb set-selection #f)
|
|
(send use-teaching-language-rb set-selection 0)
|
|
(send other-languages-hier-list select #f)
|
|
(send teaching-languages-hier-list focus))
|
|
|
|
(define teaching-languages-hier-list-panel
|
|
(new horizontal-panel% [parent languages-choice-panel] [stretchable-height #f]))
|
|
(define teaching-languages-hier-list-spacer
|
|
(new horizontal-panel%
|
|
[parent teaching-languages-hier-list-panel]
|
|
[stretchable-width #f]
|
|
[min-width 16]))
|
|
|
|
(define teaching-languages-hier-list
|
|
(new selectable-hierlist%
|
|
[parent teaching-languages-hier-list-panel]
|
|
[style '(no-border no-hscroll auto-vscroll transparent)]))
|
|
|
|
(define use-chosen-language-rb
|
|
(new radio-box%
|
|
[label #f]
|
|
[choices (list sc-choose-a-language)]
|
|
[parent languages-choice-panel]
|
|
[callback
|
|
(λ (this-rb evt)
|
|
(use-chosen-language-rb-callback))]))
|
|
(define (use-chosen-language-rb-callback)
|
|
(show-other-languages)
|
|
(when most-recent-languages-hier-list-selection
|
|
(select-a-language-in-hierlist other-languages-hier-list
|
|
most-recent-languages-hier-list-selection))
|
|
(send use-language-in-source-rb set-selection #f)
|
|
(send use-teaching-language-rb set-selection #f)
|
|
(send teaching-languages-hier-list select #f)
|
|
(send other-languages-hier-list focus))
|
|
(define (show-other-languages)
|
|
(when (member ellipsis-spacer-panel (send languages-hier-list-panel get-children))
|
|
(send languages-hier-list-panel change-children
|
|
(λ (l)
|
|
(list languages-hier-list-spacer other-languages-hier-list)))))
|
|
|
|
(define languages-hier-list-panel (new horizontal-panel%
|
|
[parent languages-choice-panel]
|
|
[stretchable-height #f]))
|
|
(define ellipsis-spacer-panel (new horizontal-panel%
|
|
[parent languages-hier-list-panel]
|
|
[stretchable-width #f]
|
|
[min-width 32]))
|
|
(define ellipsis-message (new (class canvas%
|
|
(define/override (on-paint)
|
|
(define dc (get-dc))
|
|
(send dc set-font normal-control-font)
|
|
(send dc draw-text "..." 0 0))
|
|
(define/override (on-event evt)
|
|
(when (send evt button-up?)
|
|
(show-other-languages)))
|
|
(inherit get-dc min-width min-height)
|
|
(super-new [style '(transparent)]
|
|
[parent languages-hier-list-panel]
|
|
[stretchable-width #f]
|
|
[stretchable-height #t])
|
|
(let ()
|
|
(define dc (get-dc))
|
|
(define-values (w h _1 _2) (send dc get-text-extent "..." normal-control-font))
|
|
(min-width (inexact->exact (ceiling w)))
|
|
(min-height (inexact->exact (ceiling h)))))))
|
|
|
|
(define languages-hier-list-spacer (new horizontal-panel%
|
|
[parent languages-hier-list-panel]
|
|
[stretchable-width #f]
|
|
[min-width 16]))
|
|
|
|
(define other-languages-hier-list (new selectable-hierlist%
|
|
[parent languages-hier-list-panel]
|
|
[style '(no-border no-hscroll auto-vscroll transparent)]))
|
|
(define details-outer-panel (make-object vertical-pane% outermost-panel))
|
|
(define details/manual-parent-panel (make-object vertical-panel% details-outer-panel))
|
|
(define details-panel (make-object panel:single% details/manual-parent-panel))
|
|
|
|
(define no-details-panel (make-object vertical-panel% details-panel))
|
|
|
|
(define languages-table (make-hasheq))
|
|
(define languages (get-languages))
|
|
|
|
;; selected-language : (union (instanceof language<%>) #f)
|
|
;; invariant: selected-language and get/set-selected-language-settings
|
|
;; match the user's selection in the languages-hier-list.
|
|
;; or #f if the user is not selecting a language.
|
|
(define selected-language #f)
|
|
;; get/set-selected-language-settings (union #f (-> settings))
|
|
(define get/set-selected-language-settings #f)
|
|
|
|
(define details-computed? #f)
|
|
|
|
;; language-mixin : (implements language<%>)
|
|
;; (-> (implements area-container<%>))
|
|
;; get/set
|
|
;; ->
|
|
;; ((implements hierlist<%>) -> (implements hierlist<%>))
|
|
;; a mixin that responds to language selections and updates the details-panel
|
|
(define (language-mixin language get-language-details-panel get/set-settings)
|
|
(λ (%)
|
|
(class* % (hieritem-language<%>)
|
|
(init-rest args)
|
|
(define/public (get-language) language)
|
|
(define/public (selected)
|
|
(update-gui-based-on-selected-language language get-language-details-panel get/set-settings))
|
|
(apply super-make-object args))))
|
|
|
|
(define (update-gui-based-on-selected-language language get-language-details-panel get/set-settings)
|
|
(let ([ldp (get-language-details-panel)])
|
|
(when ldp
|
|
(send details-panel active-child ldp)))
|
|
(send revert-to-defaults-button enable #t)
|
|
(set! get/set-selected-language-settings get/set-settings)
|
|
(set! selected-language language))
|
|
|
|
(define (module-language-selected)
|
|
;; need to deselect things in the languages-hier-list at this point.
|
|
(send other-languages-hier-list select #f)
|
|
(send teaching-languages-hier-list select #f)
|
|
(send use-language-in-source-rb set-selection 0)
|
|
(send use-chosen-language-rb set-selection #f)
|
|
(send use-teaching-language-rb set-selection #f)
|
|
(ok-handler 'enable)
|
|
(send details-button enable #t)
|
|
(update-gui-based-on-selected-language module-language*language
|
|
module-language*get-language-details-panel
|
|
module-language*get/set-settings))
|
|
|
|
;; no-language-selected : -> void
|
|
;; updates the GUI for the situation where no language at all selected, and
|
|
;; and thus none of the radio buttons should be selected.
|
|
;; this generally happens when there is no preference setting for the language
|
|
;; (ie the user has just started drracket for the first time)
|
|
(define (no-language-selected)
|
|
(non-language-selected)
|
|
(send use-language-in-source-rb set-selection #f)
|
|
(send use-chosen-language-rb set-selection #f)
|
|
(send use-teaching-language-rb set-selection #f))
|
|
|
|
(define module-language*language 'module-language*-not-yet-set)
|
|
(define module-language*get-language-details-panel 'module-language*-not-yet-set)
|
|
(define module-language*get/set-settings 'module-language*-not-yet-set)
|
|
|
|
;; non-language-selected : -> void
|
|
;; updates the GUI and selected-language and get/set-selected-language-settings
|
|
;; for when some non-language is selected in the hierlist
|
|
(define (non-language-selected)
|
|
(send revert-to-defaults-button enable #f)
|
|
(send details-panel active-child no-details-panel)
|
|
(set! get/set-selected-language-settings #f)
|
|
(set! selected-language #f)
|
|
(ok-handler 'disable)
|
|
(send details-button enable #f))
|
|
|
|
;; something-selected : item -> void
|
|
(define (something-selected hierlist item)
|
|
(send use-language-in-source-rb set-selection #f)
|
|
(cond
|
|
[(eq? hierlist other-languages-hier-list)
|
|
(send use-teaching-language-rb set-selection #f)
|
|
(send use-chosen-language-rb set-selection 0)
|
|
(send teaching-languages-hier-list select #f)]
|
|
[else
|
|
(send use-teaching-language-rb set-selection 0)
|
|
(send use-chosen-language-rb set-selection #f)
|
|
(send other-languages-hier-list select #f)])
|
|
(ok-handler 'enable)
|
|
(send details-button enable #t)
|
|
(send item selected))
|
|
|
|
;; construct-details : (union (-> void) #f)
|
|
(define construct-details void)
|
|
|
|
;; add-language-to-dialog : (instanceof language<%>) -> void
|
|
;; adds the language to the dialog
|
|
;; opens all of the turn-down tags
|
|
;; when `language' matches language-to-show, update the settings
|
|
;; panel to match language-to-show, otherwise set to defaults.
|
|
(define (add-language-to-dialog language)
|
|
(define positions (send language get-language-position))
|
|
(define numbers (send language get-language-numbers))
|
|
(define teaching-language? (and (pair? positions)
|
|
(equal? (car positions)
|
|
(string-constant teaching-languages))))
|
|
|
|
;; don't show the initial language ...
|
|
(unless (equal? positions initial-language-position)
|
|
(unless (and (list? positions)
|
|
(list? numbers)
|
|
(pair? positions)
|
|
(pair? numbers)
|
|
(andmap number? numbers)
|
|
(andmap string? positions)
|
|
(= (length positions) (length numbers))
|
|
((length numbers) . >= . 1))
|
|
(error 'drracket:language
|
|
(string-append
|
|
"languages position and numbers must be lists of strings and numbers,"
|
|
" respectively, must have the same length, and must each contain at"
|
|
" least one element, got: ~e ~e")
|
|
positions numbers))
|
|
|
|
(when (null? (cdr positions))
|
|
(unless (equal? positions (list (string-constant module-language-name)))
|
|
(error 'drracket:language
|
|
"Only the module language may be at the top level. Other languages must have at least two levels")))
|
|
|
|
(send other-languages-hier-list clear-fringe-cache)
|
|
(send teaching-languages-hier-list clear-fringe-cache)
|
|
|
|
#|
|
|
|
|
inline the first level of the tree into just items in the hierlist
|
|
keep track of the starting (see call to sort method below) by
|
|
adding a second field to the second level of the tree that indicates
|
|
what the sorting number is for its level above (in the second-number mixin)
|
|
|
|
|#
|
|
(let add-sub-language ([ht languages-table]
|
|
[hier-list (if teaching-language?
|
|
teaching-languages-hier-list
|
|
other-languages-hier-list)]
|
|
[positions (if teaching-language?
|
|
(cdr positions)
|
|
positions)]
|
|
[numbers (if teaching-language?
|
|
(cdr numbers)
|
|
numbers)]
|
|
[first? #t]
|
|
[second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number
|
|
(cond
|
|
[(null? (cdr positions))
|
|
(let* ([language-details-panel #f]
|
|
[real-get/set-settings
|
|
(case-lambda
|
|
[()
|
|
(cond
|
|
[(and language-to-show
|
|
settings-to-show
|
|
(equal? (send language-to-show get-language-position)
|
|
(send language get-language-position)))
|
|
settings-to-show]
|
|
[else
|
|
(send language default-settings)])]
|
|
[(x) (void)])]
|
|
[get-language-details-panel (lambda () language-details-panel)]
|
|
[get/set-settings (lambda x (apply real-get/set-settings x))]
|
|
[position (car positions)]
|
|
[number (car numbers)])
|
|
|
|
(set! construct-details
|
|
(let ([old construct-details])
|
|
(lambda ()
|
|
(old)
|
|
(let-values ([(language-details-panel-real get/set-settings)
|
|
(make-details-panel language)])
|
|
(set! language-details-panel language-details-panel-real)
|
|
(set! real-get/set-settings get/set-settings))
|
|
|
|
(let-values ([(vis-lang vis-settings)
|
|
(cond
|
|
[(and (not selected-language)
|
|
(eq? language-to-show language))
|
|
(values language-to-show settings-to-show)]
|
|
[(eq? selected-language language)
|
|
(values language
|
|
(if (eq? language language-to-show)
|
|
settings-to-show
|
|
(send language default-settings)))]
|
|
[else (values #f #f)])])
|
|
(cond
|
|
[(and vis-lang
|
|
(equal? (send vis-lang get-language-position)
|
|
(send language get-language-position)))
|
|
(get/set-settings vis-settings)
|
|
(send details-panel active-child language-details-panel)]
|
|
[else
|
|
(get/set-settings (send language default-settings))])))))
|
|
|
|
(cond
|
|
[(equal? positions (list (string-constant module-language-name)))
|
|
(set! module-language*language language)
|
|
(set! module-language*get-language-details-panel get-language-details-panel)
|
|
(set! module-language*get/set-settings get/set-settings)]
|
|
[else
|
|
(let* ([mixin (compose
|
|
number-mixin
|
|
(language-mixin language get-language-details-panel get/set-settings))]
|
|
[item
|
|
(send hier-list new-item
|
|
(if second-number
|
|
(compose second-number-mixin mixin)
|
|
mixin))]
|
|
[text (send item get-editor)]
|
|
[delta (send language get-style-delta)])
|
|
(send item set-number number)
|
|
(when second-number
|
|
(send item set-second-number second-number))
|
|
(send text insert position)
|
|
(when delta
|
|
(cond
|
|
[(list? delta)
|
|
(for-each (λ (x)
|
|
(send text change-style
|
|
(car x)
|
|
(cadr x)
|
|
(caddr x)))
|
|
delta)]
|
|
[(is-a? delta style-delta%)
|
|
(send text change-style
|
|
(send language get-style-delta)
|
|
0
|
|
(send text last-position))])))]))]
|
|
[else
|
|
(let* ([position (car positions)]
|
|
[number (car numbers)]
|
|
[sub-ht/sub-hier-list
|
|
(hash-ref
|
|
ht
|
|
(string->symbol position)
|
|
(λ ()
|
|
(if first?
|
|
(let* ([item (send hier-list new-item number-mixin)]
|
|
[x (list (make-hasheq) hier-list item)])
|
|
(hash-set! ht (string->symbol position) x)
|
|
(send item set-number number)
|
|
(send item set-allow-selection #f)
|
|
(let* ([editor (send item get-editor)]
|
|
[pos (send editor last-position)])
|
|
(send editor insert "\n")
|
|
(send editor insert position)
|
|
(send editor change-style small-size-delta pos (+ pos 1))
|
|
(send editor change-style section-style-delta
|
|
(+ pos 1) (send editor last-position)))
|
|
x)
|
|
(let* ([new-list (send hier-list new-list
|
|
(if second-number
|
|
(compose second-number-mixin number-mixin)
|
|
number-mixin))]
|
|
[x (list (make-hasheq) new-list #f)])
|
|
(send new-list set-number number)
|
|
(when second-number
|
|
(send new-list set-second-number second-number))
|
|
(send new-list set-allow-selection #t)
|
|
(send new-list open)
|
|
(send (send new-list get-editor) insert position)
|
|
(hash-set! ht (string->symbol position) x)
|
|
x))))])
|
|
(cond
|
|
[first?
|
|
(unless (= number (send (caddr sub-ht/sub-hier-list) get-number))
|
|
(error 'add-language "language ~s; expected number for ~e to be ~e, got ~e"
|
|
(send language get-language-name)
|
|
position
|
|
(send (caddr sub-ht/sub-hier-list) get-number)
|
|
number))]
|
|
[else
|
|
(unless (= number (send (cadr sub-ht/sub-hier-list) get-number))
|
|
(error 'add-language "language ~s; expected number for ~e to be ~e, got ~e"
|
|
(send language get-language-name)
|
|
position
|
|
(send (cadr sub-ht/sub-hier-list) get-number)
|
|
number))])
|
|
(add-sub-language (car sub-ht/sub-hier-list)
|
|
(cadr sub-ht/sub-hier-list)
|
|
(cdr positions)
|
|
(cdr numbers)
|
|
#f
|
|
(if first? number #f)))]))))
|
|
|
|
(define number<%>
|
|
(interface ()
|
|
get-number
|
|
set-number))
|
|
|
|
(define second-number<%>
|
|
(interface ()
|
|
get-second-number
|
|
set-second-number))
|
|
|
|
;; number-mixin : (extends object%) -> (extends object%)
|
|
;; adds the get/set-number methods to this class
|
|
(define (number-mixin %)
|
|
(class* % (number<%>)
|
|
(field (number 0))
|
|
(define/public (get-number) number)
|
|
(define/public (set-number _number) (set! number _number))
|
|
(super-instantiate ())))
|
|
|
|
;; second-number-mixin : (extends object%) -> (extends object%)
|
|
;; adds the get/set-second-number methods to this class
|
|
(define (second-number-mixin %)
|
|
(class* % (second-number<%>)
|
|
(field (second-number 0))
|
|
(define/public (get-second-number) second-number)
|
|
(define/public (set-second-number _second-number) (set! second-number _second-number))
|
|
(super-instantiate ())))
|
|
|
|
;; make-details-panel : ((instanceof language<%>) -> (values panel (case-> (-> settings) (settings -> void))))
|
|
;; adds a details panel for `language', using
|
|
;; the language's default settings, unless this is
|
|
;; the to-show language.
|
|
(define (make-details-panel language)
|
|
(let ([panel (instantiate vertical-panel% ()
|
|
(parent details-panel)
|
|
(stretchable-width #f)
|
|
(stretchable-height #f))])
|
|
(values
|
|
panel
|
|
(send language config-panel panel))))
|
|
|
|
;; close-all-languages : -> void
|
|
;; closes all of the tabs in the language hier-list.
|
|
(define (close-all-languages)
|
|
(define (close-children list)
|
|
(for-each close-this-one (send list get-items)))
|
|
(define (close-this-one item)
|
|
(cond
|
|
[(is-a? item hierarchical-list-compound-item<%>)
|
|
(send item close)
|
|
(close-children item)]
|
|
[else (void)]))
|
|
(close-children other-languages-hier-list)
|
|
(close-children teaching-languages-hier-list))
|
|
|
|
;; open-current-language : -> void
|
|
;; opens the tabs that lead to the current language
|
|
;; and selects the current language
|
|
(define (open-current-language)
|
|
|
|
;; set the initial selection in the hierlists
|
|
(let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)])
|
|
(when hier-default
|
|
(select-a-language-in-hierlist other-languages-hier-list hier-default)))
|
|
(let ([hier-default (preferences:get 'drracket:language-dialog:teaching-hierlist-default)])
|
|
(when hier-default
|
|
(select-a-language-in-hierlist teaching-languages-hier-list (cdr hier-default))))
|
|
|
|
(send languages-hier-list-panel change-children
|
|
(λ (l)
|
|
(list ellipsis-spacer-panel ellipsis-message)))
|
|
|
|
(cond
|
|
[(not (and language-to-show settings-to-show))
|
|
(no-language-selected)]
|
|
[(is-a? language-to-show drracket:module-language:module-language<%>)
|
|
;; the above changes the radio button selections, so do it before calling module-language-selected
|
|
(module-language-selected)]
|
|
[else
|
|
(define position (send language-to-show get-language-position))
|
|
(cond
|
|
[(and (pair? position)
|
|
(equal? (car position)
|
|
(string-constant teaching-languages)))
|
|
(select-a-language-in-hierlist teaching-languages-hier-list (cdr position))
|
|
(send use-teaching-language-rb set-selection 0)
|
|
(send use-chosen-language-rb set-selection #f)
|
|
(send teaching-languages-hier-list focus)]
|
|
[else
|
|
(send languages-hier-list-panel change-children
|
|
(λ (l)
|
|
(list languages-hier-list-spacer other-languages-hier-list)))
|
|
(select-a-language-in-hierlist other-languages-hier-list position)
|
|
(send use-teaching-language-rb set-selection #f)
|
|
(send use-chosen-language-rb set-selection 0)
|
|
(send other-languages-hier-list focus)])
|
|
(send use-language-in-source-rb set-selection #f)]))
|
|
|
|
(define (select-a-language-in-hierlist hier-list language-position)
|
|
(cond
|
|
[(null? (cdr language-position))
|
|
;; nothing to open here
|
|
(send (car (send hier-list get-items)) select #t)]
|
|
[else
|
|
(let loop ([hi hier-list]
|
|
|
|
;; skip the first position, since it is flattened into the dialog
|
|
[first-pos (cadr language-position)]
|
|
[position (cddr language-position)])
|
|
(let ([matching-children
|
|
(filter (λ (x)
|
|
(equal? (send (send x get-editor) get-text)
|
|
first-pos))
|
|
(send hi get-items))])
|
|
(cond
|
|
[(null? matching-children)
|
|
(void)]
|
|
[else
|
|
(let ([child (car matching-children)])
|
|
(cond
|
|
[(null? position)
|
|
(send child select #t)]
|
|
[else
|
|
(when (is-a? child hierarchical-list-compound-item<%>) ;; test can fail when prefs are bad
|
|
(send child open)
|
|
(loop child (car position) (cdr position)))]))])))]))
|
|
|
|
;; docs-callback : -> void
|
|
(define (docs-callback)
|
|
(void))
|
|
|
|
;; details-shown? : boolean
|
|
;; indicates if the details are currently visible in the dialog
|
|
(define details-shown? (and language-to-show
|
|
settings-to-show
|
|
(not (send language-to-show default-settings? settings-to-show))))
|
|
|
|
;; details-callback : -> void
|
|
;; flips the details-shown? flag and resets the GUI
|
|
(define (details-callback)
|
|
(do-construct-details)
|
|
(set! details-shown? (not details-shown?))
|
|
(when re-center
|
|
(send re-center begin-container-sequence))
|
|
(update-show/hide-details)
|
|
(when re-center
|
|
(send re-center center 'both)
|
|
(send re-center end-container-sequence)))
|
|
|
|
;; do-construct-details : -> void
|
|
;; construct the details panels, if they have not been constructed
|
|
(define (do-construct-details)
|
|
(when construct-details
|
|
(send details-button enable #f)
|
|
(construct-details)
|
|
(set! construct-details #f)
|
|
(send details-button enable #t)))
|
|
|
|
;; show/hide-details : -> void
|
|
;; udpates the GUI based on the details-shown? flag
|
|
(define (update-show/hide-details)
|
|
(send details-button set-label
|
|
(if details-shown? hide-details-label show-details-label))
|
|
(send parent begin-container-sequence)
|
|
(send revert-to-defaults-outer-panel change-children
|
|
(λ (l)
|
|
(if details-shown? (list revert-to-defaults-button) null)))
|
|
(send details-outer-panel change-children
|
|
(λ (l)
|
|
(if details-shown? (list details/manual-parent-panel) null)))
|
|
(send parent end-container-sequence))
|
|
|
|
;; revert-to-defaults-callback : -> void
|
|
(define (revert-to-defaults-callback)
|
|
(when selected-language
|
|
(get/set-selected-language-settings
|
|
(send selected-language default-settings))))
|
|
|
|
(define show-details-label (string-constant show-details-button-label))
|
|
(define hide-details-label (string-constant hide-details-button-label))
|
|
(define details-button (make-object button%
|
|
(if (show-details-label . system-font-space->= . hide-details-label)
|
|
show-details-label
|
|
hide-details-label)
|
|
show-details-parent
|
|
(λ (x y)
|
|
(details-callback))))
|
|
|
|
(define revert-to-defaults-outer-panel (make-object horizontal-panel% show-details-parent))
|
|
(define revert-to-defaults-button (make-object button%
|
|
(string-constant revert-to-language-defaults)
|
|
revert-to-defaults-outer-panel
|
|
(λ (_1 _2)
|
|
(revert-to-defaults-callback))))
|
|
|
|
(send revert-to-defaults-outer-panel stretchable-width #f)
|
|
(send revert-to-defaults-outer-panel stretchable-height #f)
|
|
|
|
(for-each add-language-to-dialog languages)
|
|
(define (hier-list-sort-predicate x y)
|
|
(cond
|
|
[(and (x . is-a? . second-number<%>)
|
|
(y . is-a? . second-number<%>))
|
|
(cond
|
|
[(= (send x get-second-number)
|
|
(send y get-second-number))
|
|
(< (send x get-number) (send y get-number))]
|
|
[else
|
|
(< (send x get-second-number)
|
|
(send y get-second-number))])]
|
|
[(and (x . is-a? . number<%>)
|
|
(y . is-a? . second-number<%>))
|
|
(cond
|
|
[(= (send x get-number)
|
|
(send y get-second-number))
|
|
#t]
|
|
[else
|
|
(< (send x get-number)
|
|
(send y get-second-number))])]
|
|
[(and (x . is-a? . second-number<%>)
|
|
(y . is-a? . number<%>))
|
|
(cond
|
|
[(= (send x get-second-number)
|
|
(send y get-number))
|
|
#f]
|
|
[else (< (send x get-second-number)
|
|
(send y get-number))])]
|
|
[(and (x . is-a? . number<%>)
|
|
(y . is-a? . number<%>))
|
|
(< (send x get-number) (send y get-number))]
|
|
[else #f]))
|
|
(send other-languages-hier-list sort hier-list-sort-predicate)
|
|
(send teaching-languages-hier-list sort hier-list-sort-predicate)
|
|
|
|
;; remove the newline at the front of the first inlined category (if there)
|
|
;; it won't be there if the module language is at the top.
|
|
(for ([hier-list (in-list (list other-languages-hier-list teaching-languages-hier-list))])
|
|
(define items (send hier-list get-items))
|
|
(unless (null? items)
|
|
(define t (send (car items) get-editor))
|
|
(when (equal? "\n" (send t get-text 0 1))
|
|
(send t delete 0 1))))
|
|
|
|
(send details-outer-panel stretchable-width #f)
|
|
(send details/manual-parent-panel change-children
|
|
(λ (l)
|
|
(list details-panel)))
|
|
|
|
(define (config-hier-list hier-list)
|
|
(send hier-list stretchable-width #t)
|
|
(send hier-list stretchable-height #t)
|
|
(send hier-list accept-tab-focus #t)
|
|
(send hier-list allow-tab-exit #t))
|
|
(config-hier-list other-languages-hier-list)
|
|
(config-hier-list teaching-languages-hier-list)
|
|
(send parent reflow-container)
|
|
(close-all-languages)
|
|
(open-current-language)
|
|
(define (set-min-sizes hier-list)
|
|
(send hier-list min-client-width (text-width (send hier-list get-editor)))
|
|
(send hier-list min-client-height (text-height (send hier-list get-editor))))
|
|
(set-min-sizes other-languages-hier-list)
|
|
(set-min-sizes teaching-languages-hier-list)
|
|
(when details-shown?
|
|
(do-construct-details))
|
|
(update-show/hide-details)
|
|
(when get/set-selected-language-settings
|
|
;; this call to get/set-selected-language-settings has to come after the call to do-construct-details above
|
|
;; because do-construct-details sets all of the controls to the language's default settings
|
|
(get/set-selected-language-settings settings-to-show))
|
|
(size-discussion-canvas in-source-discussion-editor-canvas)
|
|
(values
|
|
(λ () selected-language)
|
|
(λ ()
|
|
(and get/set-selected-language-settings
|
|
(get/set-selected-language-settings)))
|
|
(λ (receiver evt)
|
|
(case (send evt get-key-code)
|
|
[(#\r)
|
|
(if (mouse-event-uses-shortcut-prefix? evt)
|
|
(begin (send use-language-in-source-rb set-selection 0)
|
|
(use-language-in-source-rb-callback)
|
|
#t)
|
|
#f)]
|
|
[(#\t)
|
|
(if (mouse-event-uses-shortcut-prefix? evt)
|
|
(begin
|
|
(send use-teaching-language-rb set-selection 0)
|
|
(use-teaching-language-rb-callback)
|
|
#t)
|
|
#f)]
|
|
[(#\o)
|
|
(if (mouse-event-uses-shortcut-prefix? evt)
|
|
(begin
|
|
(send use-chosen-language-rb set-selection 0)
|
|
(use-chosen-language-rb-callback)
|
|
#t)
|
|
#f)]
|
|
[else #f])))))
|
|
|
|
(define (add-discussion p definitions-text use-language-in-source-rb-callback)
|
|
(define t (new (text:hide-caret/selection-mixin text:standard-style-list%)))
|
|
(define c (new editor-canvas%
|
|
[stretchable-width #t]
|
|
[horizontal-inset 0]
|
|
[vertical-inset 0]
|
|
[parent p]
|
|
[style '(no-border no-vscroll no-hscroll transparent)]
|
|
[editor t]))
|
|
(send t set-styles-sticky #f)
|
|
(send t set-autowrap-bitmap #f)
|
|
(define size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size)))
|
|
(define (do-insert str tt-style?)
|
|
(define before (send t last-position))
|
|
(send t insert str before before)
|
|
(cond
|
|
[tt-style?
|
|
(send t change-style
|
|
(send (send t get-style-list) find-named-style "Standard")
|
|
before (send t last-position))]
|
|
[else
|
|
(send t change-style
|
|
(send (send t get-style-list) basic-style)
|
|
before (send t last-position))])
|
|
(send t change-style size-sd before (send t last-position)))
|
|
(when (send normal-control-font get-size-in-pixels)
|
|
(send size-sd set-size-in-pixels-on #t))
|
|
(let loop ([strs (regexp-split #rx"#lang" (string-constant racket-language-discussion))])
|
|
(do-insert (car strs) #f)
|
|
(unless (null? (cdr strs))
|
|
(do-insert "#lang" #t)
|
|
(loop (cdr strs))))
|
|
|
|
(define spacer-snips '())
|
|
(define spacer-poses '())
|
|
|
|
(for ([lang (in-list '(racket racket/base typed/racket scribble/base))])
|
|
(define the-lang-line (format "#lang ~a" lang))
|
|
(do-insert " " #t)
|
|
(define before-lang (send t last-position))
|
|
(do-insert the-lang-line #t)
|
|
(define after-lang (send t last-position))
|
|
(define spacer (new spacer-snip%))
|
|
(define spacer-pos (send t last-position))
|
|
(set! spacer-snips (cons spacer spacer-snips))
|
|
(set! spacer-poses (cons spacer-pos spacer-poses))
|
|
(send t insert spacer spacer-pos spacer-pos)
|
|
(do-insert " [" #f)
|
|
(define before-docs (send t last-position))
|
|
(do-insert "docs" #f)
|
|
(define after-docs (send t last-position))
|
|
(do-insert "]\n" #f)
|
|
(send t set-clickback before-lang after-lang
|
|
(λ (t start end)
|
|
(use-language-in-source-rb-callback)
|
|
(define-values (current-line-start current-line-end)
|
|
(if definitions-text
|
|
(find-language-position definitions-text)
|
|
(values #f #f)))
|
|
(define existing-lang-line (and current-line-start
|
|
(send definitions-text get-text current-line-start current-line-end)))
|
|
(case (message-box/custom
|
|
(string-constant drscheme)
|
|
(string-append
|
|
(string-constant racket-dialect-in-buffer-message)
|
|
"\n\n"
|
|
(cond
|
|
[(and existing-lang-line
|
|
(equal? existing-lang-line the-lang-line))
|
|
(format (string-constant racket-dialect-already-same-#lang-line)
|
|
existing-lang-line)]
|
|
[existing-lang-line
|
|
(format (string-constant racket-dialect-replace-#lang-line)
|
|
existing-lang-line
|
|
the-lang-line)]
|
|
[else
|
|
(format (string-constant racket-dialect-add-new-#lang-line) the-lang-line)]))
|
|
(cond
|
|
[(and existing-lang-line
|
|
(equal? existing-lang-line the-lang-line))
|
|
(string-constant ok)]
|
|
[existing-lang-line
|
|
(string-constant replace-#lang-line)]
|
|
[else
|
|
(string-constant add-#lang-line)])
|
|
(and (not (equal? existing-lang-line the-lang-line))
|
|
(string-constant cancel))
|
|
#f #f
|
|
'(default=1))
|
|
[(1)
|
|
(cond
|
|
[current-line-start
|
|
(send definitions-text begin-edit-sequence)
|
|
(send definitions-text delete current-line-start current-line-end)
|
|
(send definitions-text insert the-lang-line current-line-start current-line-start)
|
|
(send definitions-text end-edit-sequence)]
|
|
[else
|
|
(send definitions-text begin-edit-sequence)
|
|
(send definitions-text insert "\n" 0 0)
|
|
(send definitions-text insert the-lang-line 0 0)
|
|
(send definitions-text end-edit-sequence)])]
|
|
[else (void)])))
|
|
(send t set-clickback before-docs after-docs
|
|
(λ (t start end)
|
|
(define-values (path tag) (xref-tag->path+anchor (load-collections-xref)
|
|
(make-module-language-tag lang)))
|
|
(define url (path->url path))
|
|
(define url2 (if tag
|
|
(make-url (url-scheme url)
|
|
(url-user url)
|
|
(url-host url)
|
|
(url-port url)
|
|
(url-path-absolute? url)
|
|
(url-path url)
|
|
(url-query url)
|
|
tag)
|
|
url))
|
|
(send-url (url->string url2)))))
|
|
|
|
(do-insert (string-constant racket-language-discussion-end) #f)
|
|
|
|
(define kmp (send t set-keymap (keymap:get-editor)))
|
|
|
|
(send (send c get-parent) reflow-container)
|
|
|
|
(define xb (box 0))
|
|
(define max-spacer-pos
|
|
(for/fold ([m 0]) ([spacer-pos (in-list spacer-poses)])
|
|
(send t position-location spacer-pos xb #f)
|
|
(max m (unbox xb))))
|
|
(for ([spacer-pos (in-list spacer-poses)]
|
|
[spacer-snip (in-list spacer-snips)])
|
|
(send t position-location spacer-pos xb #f)
|
|
(send spacer-snip set-width (- max-spacer-pos (unbox xb))))
|
|
|
|
(send t hide-caret #t)
|
|
(send t auto-wrap #t)
|
|
(send t lock #t)
|
|
(send c accept-tab-focus #f)
|
|
(send c allow-tab-exit #t)
|
|
|
|
c)
|
|
|
|
(define (find-language-position definitions-text)
|
|
(define prt (open-input-text-editor definitions-text))
|
|
(port-count-lines! prt)
|
|
(define l (with-handlers ((exn:fail? (λ (x) #f)))
|
|
(read-language prt)))
|
|
(cond
|
|
[l
|
|
(define-values (line col pos) (port-next-location prt))
|
|
(define hash-lang-start (send definitions-text find-string "#lang" 'backward pos 0 #f))
|
|
(if hash-lang-start
|
|
(values hash-lang-start (- pos 1))
|
|
(values #f #f))]
|
|
[else
|
|
(values #f #f)]))
|
|
|
|
(define spacer-snip%
|
|
(class snip%
|
|
(inherit get-admin)
|
|
(define width 0)
|
|
(define/public (set-width w)
|
|
(set! width w)
|
|
(define admin (get-admin))
|
|
(when admin
|
|
(send admin resized this #t)))
|
|
(define/override (get-text [start 0] [end 'eof] [flattened? #f] [force-cr? #f])
|
|
"")
|
|
(define/override (get-extent dc x y wb hb db ab lb sp)
|
|
(super get-extent dc x y wb hb db ab lb sp)
|
|
(when (box? wb) (set-box! wb width)))
|
|
(super-new)
|
|
(inherit set-snipclass)
|
|
(set-snipclass spacer-sc)))
|
|
(define spacer-sc (new snip-class%))
|
|
(send spacer-sc set-classname "drracket:spacer-snipclass")
|
|
(send spacer-sc set-version 0)
|
|
(send (get-the-snip-class-list) add spacer-sc)
|
|
|
|
(define (size-discussion-canvas canvas)
|
|
(define t (send canvas get-editor))
|
|
(define by (box 0))
|
|
(send t position-location
|
|
(send t line-end-position (send t last-line))
|
|
#f
|
|
by)
|
|
(send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24)))
|
|
|
|
(define section-style-delta (make-object style-delta% 'change-bold))
|
|
(send section-style-delta set-delta-foreground "medium blue")
|
|
(define small-size-delta (make-object style-delta% 'change-size 9))
|
|
|
|
(define (add-welcome dialog welcome-before-panel welcome-after-panel)
|
|
(let* ([outer-pb%
|
|
(class pasteboard%
|
|
(define/override (can-interactive-move? evt)
|
|
#f)
|
|
(super-instantiate ()))]
|
|
[outer-pb (make-object outer-pb%)]
|
|
[bitmap
|
|
(make-object bitmap%
|
|
(build-path (collection-file-path "plt-small-shield.gif" "icons")))]
|
|
[image-snip
|
|
(make-object image-snip%
|
|
(collection-file-path "plt-small-shield.gif" "icons"))]
|
|
[before-text (make-object text%)]
|
|
[before-snip (make-object editor-snip% before-text #f)]
|
|
[before-ec%
|
|
(class editor-canvas%
|
|
(inherit get-client-size)
|
|
(define/private (update-size)
|
|
(let-values ([(cw ch) (get-client-size)])
|
|
(unless (or (zero? cw)
|
|
(zero? ch))
|
|
(let ([image-l-box (box 0)]
|
|
[image-r-box (box 0)])
|
|
(send before-text get-snip-location image-snip image-l-box #f #f)
|
|
(send before-text get-snip-location image-snip image-r-box #f #t)
|
|
(let* ([image-w (send bitmap get-width)]
|
|
[before-snip-space (- cw image-w)]
|
|
[before-snip-w (- before-snip-space
|
|
5 5 ;; space before and after inside snip
|
|
2 ;; space at end of outer editor
|
|
1 ;; space at beginning of outer editor
|
|
1 ;; space between image and snip
|
|
-5 ;; unknown space
|
|
)])
|
|
(send before-text set-max-width (max 0 before-snip-w)))))))
|
|
(define/override (on-superwindow-show shown?)
|
|
(update-size)
|
|
(super on-superwindow-show shown?))
|
|
(define/override (on-size w h)
|
|
(update-size)
|
|
(super on-size w h))
|
|
(super-instantiate ()))]
|
|
[before-ec (instantiate before-ec% ()
|
|
(parent welcome-before-panel)
|
|
(editor outer-pb)
|
|
(stretchable-height #f)
|
|
(style '(no-vscroll no-hscroll)))]
|
|
[first-line-style-delta (make-object style-delta% 'change-bold)])
|
|
(send first-line-style-delta set-delta-foreground (make-object color% 150 0 150))
|
|
(send before-ec min-width 550)
|
|
|
|
(let-values ([(cw ch) (send before-ec get-client-size)]
|
|
[(w h) (send before-ec get-size)])
|
|
(send before-ec min-height
|
|
(+ (send bitmap get-height)
|
|
8 ;; pasteboards apparently want some space here....
|
|
(- h ch))))
|
|
|
|
(send outer-pb insert image-snip)
|
|
(send outer-pb insert before-snip)
|
|
(send outer-pb move image-snip 0 0)
|
|
(send outer-pb move before-snip (send bitmap get-width) 0)
|
|
(send outer-pb set-selection-visible #f)
|
|
(send outer-pb lock #t)
|
|
|
|
;(send before-snip set-align-top-line #t)
|
|
(send before-text insert
|
|
(format (string-constant welcome-to-drscheme-version/language)
|
|
(version:version)
|
|
(this-language)))
|
|
(send before-text insert #\newline)
|
|
(send before-text insert (string-constant introduction-to-language-dialog))
|
|
(send before-text change-style
|
|
first-line-style-delta
|
|
0
|
|
(send before-text paragraph-end-position 0))
|
|
(send before-text auto-wrap #t)
|
|
|
|
(send before-text lock #t)
|
|
(send before-text hide-caret #t)
|
|
|
|
(for-each (λ (native-lang-string language)
|
|
(unless (equal? (this-language) language)
|
|
(instantiate button% ()
|
|
(label native-lang-string)
|
|
(parent welcome-after-panel)
|
|
(stretchable-width #t)
|
|
(callback (λ (x1 x2) (drracket:app:switch-language-to dialog language))))))
|
|
(string-constants is-this-your-native-language)
|
|
(all-languages))))
|
|
|
|
;; system-font-space->= : string string -> boolean
|
|
;; determines which string is wider, when drawn in the system font
|
|
(define (x . system-font-space->= . y)
|
|
(let ([bdc (make-object bitmap-dc%)])
|
|
(send bdc set-bitmap (make-object bitmap% 1 1 #t))
|
|
(send bdc set-font (send the-font-list find-or-create-font
|
|
12 'system 'normal 'normal))
|
|
(let-values ([(wx _1 _2 _3) (send bdc get-text-extent x)]
|
|
[(wy _4 _5 _6) (send bdc get-text-extent y)])
|
|
(wx . >= . wy))))
|
|
|
|
;; text-width : (isntanceof text%) -> exact-integer
|
|
;; calculates the width of widest line in the
|
|
;; editor. This only makes sense if auto-wrap
|
|
;; is turned off. Otherwise, you could just use
|
|
;; the admin's width.
|
|
(define (text-width text)
|
|
(let loop ([n (+ (send text last-line) 1)]
|
|
[current-max-width 0])
|
|
(cond
|
|
[(zero? n)
|
|
(+
|
|
10 ;; this should be some magic small constant (hopefully less than 10 on all platforms)
|
|
(floor (inexact->exact current-max-width)))]
|
|
[else (let* ([line-number (- n 1)]
|
|
[box (box 0.0)]
|
|
[eol-pos (send text line-end-position line-number)]
|
|
[eol-snip (send text find-snip eol-pos 'before)])
|
|
(when eol-snip
|
|
(send text get-snip-location eol-snip box #f #t))
|
|
(loop (- n 1)
|
|
(max current-max-width (unbox box))))])))
|
|
|
|
;; text-height : (is-a?/c text% -> exact-integer
|
|
(define (text-height text)
|
|
(let ([y-box (box 0)])
|
|
(send text position-location
|
|
(send text last-position)
|
|
#f
|
|
y-box
|
|
#f
|
|
#f
|
|
#t)
|
|
(+ 16 ;; upper bound on some space I don't know how to get.
|
|
(floor (inexact->exact (unbox y-box))))))
|
|
|
|
|
|
;
|
|
;
|
|
; ; ;;;
|
|
; ;
|
|
; ;;; ;; ;; ;;;;; ;;; ;;;; ;;;;
|
|
; ; ;; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;;; ;;;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;; ; ; ; ;
|
|
; ;;;;; ;;; ;;; ;;;;; ;;; ;; ;;;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;
|
|
; ;
|
|
; ; ;;; ;; ;; ;; ;;;; ;; ;;; ;; ;; ;;; ;;;;
|
|
; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; ; ;
|
|
; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; ;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;
|
|
; ;;;;; ;;;;;;;; ;;; ;;;; ;; ;; ;;;;; ;;;; ;;;; ;;;;
|
|
; ; ;
|
|
; ;;; ;;;
|
|
;
|
|
;
|
|
|
|
(define (add-info-specified-languages)
|
|
(for-each add-info-specified-language
|
|
(find-relevant-directories '(drscheme-language-positions))))
|
|
|
|
(define (add-info-specified-language directory)
|
|
(let ([info-proc (get-info/full directory)])
|
|
(when info-proc
|
|
(let* ([lang-positions (info-proc 'drscheme-language-positions (λ () null))]
|
|
[lang-modules (info-proc 'drscheme-language-modules (λ () null))]
|
|
[numberss (info-proc 'drscheme-language-numbers
|
|
(λ ()
|
|
(map (λ (lang-position)
|
|
(map (λ (x) 0) lang-position))
|
|
lang-positions)))]
|
|
[summaries (info-proc 'drscheme-language-one-line-summaries
|
|
(λ ()
|
|
(map (λ (lang-position) "")
|
|
lang-positions)))]
|
|
[urls (info-proc 'drscheme-language-urls
|
|
(λ ()
|
|
(map (λ (lang-position) "")
|
|
lang-positions)))]
|
|
[reader-specs
|
|
(info-proc 'drscheme-language-readers
|
|
(λ ()
|
|
(map (λ (lang-position) #f)
|
|
lang-positions)))])
|
|
(cond
|
|
[(and (list? lang-positions)
|
|
(andmap (λ (lang-position numbers)
|
|
(and (list? lang-position)
|
|
(pair? lang-position)
|
|
(andmap string? lang-position)
|
|
(list? numbers)
|
|
(andmap number? numbers)
|
|
(= (length numbers)
|
|
(length lang-position))))
|
|
lang-positions
|
|
numberss)
|
|
(list? lang-modules)
|
|
(andmap (λ (x)
|
|
(or (string? x)
|
|
(and (list? x)
|
|
(andmap string? x))))
|
|
lang-modules)
|
|
(list? summaries)
|
|
(andmap string? summaries)
|
|
|
|
(list? urls)
|
|
(andmap string? urls)
|
|
|
|
(list? reader-specs)
|
|
(andmap (λ (x)
|
|
;; approximation (no good test, really)
|
|
;; since it depends on the value of a mz
|
|
;; parameter to interpret the module spec
|
|
(or (string? x) (eq? x #f) (symbol? x) (pair? x)))
|
|
reader-specs)
|
|
|
|
(= (length lang-positions)
|
|
(length lang-modules)
|
|
(length summaries)
|
|
(length urls)
|
|
(length reader-specs)))
|
|
(for-each
|
|
(λ (lang-module lang-position lang-numbers one-line-summary url reader-spec)
|
|
(let ([%
|
|
((drracket:language:get-default-mixin)
|
|
(drracket:language:module-based-language->language-mixin
|
|
(drracket:language:simple-module-based-language->module-based-language-mixin
|
|
drracket:language:simple-module-based-language%)))]
|
|
[reader
|
|
(if reader-spec
|
|
(with-handlers ([exn:fail?
|
|
(λ (x)
|
|
(message-box (string-constant drscheme)
|
|
(if (exn? x)
|
|
(exn-message x)
|
|
(format "uncaught exception: ~s" x))
|
|
#:dialog-mixin frame:focus-table-mixin)
|
|
read-syntax/namespace-introduce)])
|
|
(contract
|
|
(->* ()
|
|
(any/c port?)
|
|
(or/c syntax? eof-object?))
|
|
(dynamic-require
|
|
(cond
|
|
[(string? reader-spec)
|
|
(build-path
|
|
directory
|
|
(platform-independent-string->path reader-spec))]
|
|
[else reader-spec])
|
|
'read-syntax)
|
|
(string->symbol (format "~s" lang-position))
|
|
'drscheme))
|
|
read-syntax/namespace-introduce)])
|
|
(add-language (instantiate % ()
|
|
(module (if (string? lang-module)
|
|
(build-path
|
|
directory
|
|
(platform-independent-string->path lang-module))
|
|
`(lib ,@lang-module)))
|
|
(language-position lang-position)
|
|
(language-id (format "plt:lang-from-module: ~s" lang-module))
|
|
(language-numbers lang-numbers)
|
|
(one-line-summary one-line-summary)
|
|
(language-url url)
|
|
(reader reader)))))
|
|
lang-modules
|
|
lang-positions
|
|
numberss
|
|
summaries
|
|
urls
|
|
reader-specs)]
|
|
[else
|
|
(message-box
|
|
(string-constant drscheme)
|
|
(format
|
|
(string-append
|
|
"The drscheme-language-position, drscheme-language-modules, drscheme-language-numbers,"
|
|
" and drscheme-language-readers specifications aren't correct. Expected"
|
|
" (listof (cons string (listof string))), (listof (listof string)), (listof (listof number)), (listof string),"
|
|
" (listof string), and (listof module-spec) respectively, where the lengths of the outer lists are the same."
|
|
" Got ~e, ~e, ~e, ~e, ~e, and ~e")
|
|
lang-positions
|
|
lang-modules
|
|
numberss
|
|
summaries
|
|
urls
|
|
reader-specs)
|
|
#:dialog-mixin frame:focus-table-mixin)])))))
|
|
|
|
(define (platform-independent-string->path str)
|
|
(apply
|
|
build-path
|
|
(map (λ (x)
|
|
(cond
|
|
[(string=? ".." x) 'up]
|
|
[(string=? "." x) 'same]
|
|
[else x]))
|
|
(regexp-split #rx"/" str))))
|
|
|
|
(define read-syntax/namespace-introduce
|
|
(λ (source-name-v [input-port (current-input-port)])
|
|
(let ([v (read-syntax source-name-v input-port)])
|
|
(if (syntax? v)
|
|
(namespace-syntax-introduce v)
|
|
v))))
|
|
|
|
|
|
|
|
;
|
|
;
|
|
; ;; ; ;; ;
|
|
; ; ; ;
|
|
; ; ;; ;; ;; ;;; ; ;;;;; ;;; ;; ;;
|
|
; ;; ; ; ; ; ; ; ; ;; ;
|
|
; ; ; ; ; ; ; ; ;;;;; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ;; ; ; ; ; ; ; ;
|
|
; ;;;;; ;; ;; ;;;;; ;;;;; ;;; ;;;;; ;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;;
|
|
; ;
|
|
; ; ;;; ;; ;; ;; ;;;; ;; ;;; ;; ;; ;;; ;;;;
|
|
; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ; ; ;
|
|
; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;; ;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;
|
|
; ;;;;; ;;;;;;;; ;;; ;;;; ;; ;; ;;;;; ;;;; ;;;; ;;;;
|
|
; ; ;
|
|
; ;;; ;;;
|
|
;
|
|
;
|
|
|
|
|
|
;; add-expand-to-front-end : mixin
|
|
;; overrides front-end to make the language a language that expands its arguments
|
|
(define (add-expand-to-front-end %)
|
|
(class %
|
|
(define/override (front-end/complete-program input settings)
|
|
(wrap-front-end (super front-end/complete-program input settings)))
|
|
(define/override (front-end/interaction input settings)
|
|
(wrap-front-end (super front-end/interaction input settings)))
|
|
(define/private (wrap-front-end thnk)
|
|
(λ ()
|
|
(let ([res (thnk)])
|
|
(cond
|
|
[(syntax? res) (with-syntax ([res res]
|
|
[expand-syntax-top-level-with-compile-time-evals
|
|
expand-syntax-top-level-with-compile-time-evals])
|
|
#'(expand-syntax-top-level-with-compile-time-evals
|
|
(quote-syntax res)))]
|
|
[(eof-object? res) res]
|
|
[else `(expand ',res)]))))
|
|
(super-instantiate ())))
|
|
|
|
(define-struct (simple-settings+assume drracket:language:simple-settings) (no-redef?))
|
|
(define simple-settings+assume->vector (make-->vector simple-settings+assume))
|
|
|
|
(define (macro-stepper-mixin %)
|
|
(class %
|
|
(super-new)
|
|
(define/augment (capability-value key)
|
|
(cond
|
|
[(eq? key 'macro-stepper:enabled) #t]
|
|
[else (inner (drracket:language:get-capability-default key)
|
|
capability-value key)]))))
|
|
|
|
(define (assume-mixin %)
|
|
(class %
|
|
(define/override (default-settings)
|
|
(extend-simple-settings (super default-settings) #t))
|
|
|
|
(define/override (marshall-settings settings)
|
|
(simple-settings+assume->vector settings))
|
|
|
|
(define/override (unmarshall-settings printable)
|
|
(and (vector? printable)
|
|
(= (vector-length printable) 7)
|
|
(let ([base
|
|
(super unmarshall-settings
|
|
(list->vector
|
|
(reverse
|
|
(cdr (reverse (vector->list printable))))))])
|
|
(and base
|
|
(extend-simple-settings
|
|
base
|
|
(and (vector-ref printable 6) #t))))))
|
|
|
|
(define/override (config-panel parent)
|
|
(let ([p (new vertical-panel% [parent parent])])
|
|
(let ([base-config (super config-panel p)]
|
|
[assume-cb (new check-box%
|
|
[parent
|
|
(new group-box-panel%
|
|
[parent p]
|
|
[label (string-constant enforce-primitives-group-box-label)]
|
|
[stretchable-height #f]
|
|
[stretchable-width #f])]
|
|
[label (string-constant enforce-primitives-check-box-label)])])
|
|
(case-lambda
|
|
[() (extend-simple-settings (base-config)
|
|
(send assume-cb get-value))]
|
|
[(c)
|
|
(base-config c)
|
|
(send assume-cb set-value (simple-settings+assume-no-redef? c))]))))
|
|
|
|
(define/override (default-settings? x)
|
|
(equal? (simple-settings+assume->vector x)
|
|
(simple-settings+assume->vector (default-settings))))
|
|
|
|
(define/private (extend-simple-settings s no-redef?)
|
|
(make-simple-settings+assume (drracket:language:simple-settings-case-sensitive s)
|
|
(drracket:language:simple-settings-printing-style s)
|
|
(drracket:language:simple-settings-fraction-style s)
|
|
(drracket:language:simple-settings-show-sharing s)
|
|
(drracket:language:simple-settings-insert-newlines s)
|
|
(drracket:language:simple-settings-annotations s)
|
|
no-redef?))
|
|
|
|
(define/override (use-namespace-require/copy-from-setting? s)
|
|
(not (simple-settings+assume-no-redef? s)))
|
|
|
|
(super-new)))
|
|
|
|
(define (add-errortrace-key-mixin %)
|
|
(class %
|
|
(define/override (on-execute setting run-in-user-thread)
|
|
(super on-execute setting run-in-user-thread)
|
|
(run-in-user-thread
|
|
(λ ()
|
|
(namespace-require 'errortrace/errortrace-key)
|
|
(namespace-require '(for-syntax errortrace/errortrace-key)))))
|
|
(super-new)))
|
|
|
|
(define (r5rs-mixin %)
|
|
(class %
|
|
(define/override (on-execute setting run-in-user-thread)
|
|
(super on-execute setting run-in-user-thread)
|
|
(run-in-user-thread
|
|
(λ ()
|
|
(read-square-bracket-as-paren #f)
|
|
(read-curly-brace-as-paren #f)
|
|
(read-accept-infix-dot #f)
|
|
(print-mpair-curly-braces #f)
|
|
(print-vector-length #f))))
|
|
(define/override (get-transformer-module) #f)
|
|
|
|
(define/override (default-settings)
|
|
(make-simple-settings+assume #f 'trad-write 'mixed-fraction-e #f #t 'debug #t))
|
|
|
|
(super-new)))
|
|
|
|
(define (pretty-big-mixin %)
|
|
(class %
|
|
;; since check syntax no longer shares the gui libraries,
|
|
;; we always share it explicitly here
|
|
(define/override (on-execute setting run-in-user-thread)
|
|
(let ([mred-name ((current-module-name-resolver) 'mred/mred #f #f)])
|
|
(run-in-user-thread
|
|
(λ ()
|
|
(namespace-attach-module drracket:init:system-namespace mred-name))))
|
|
(super on-execute setting run-in-user-thread))
|
|
(define/override (default-settings)
|
|
(let ([s (super default-settings)])
|
|
(make-simple-settings+assume (drracket:language:simple-settings-case-sensitive s)
|
|
'trad-write
|
|
(drracket:language:simple-settings-fraction-style s)
|
|
(drracket:language:simple-settings-show-sharing s)
|
|
(drracket:language:simple-settings-insert-newlines s)
|
|
(drracket:language:simple-settings-annotations s)
|
|
(simple-settings+assume-no-redef? s))))
|
|
(super-new)))
|
|
|
|
(define get-all-scheme-manual-keywords
|
|
(let ([words #f])
|
|
(λ ()
|
|
(unless words
|
|
(set! words (text:get-completions/manuals '(racket/base racket/contract))))
|
|
words)))
|
|
|
|
(define get-all-manual-keywords
|
|
(let ([words #f])
|
|
(λ ()
|
|
(unless words
|
|
(set! words (text:get-completions/manuals #f)))
|
|
words)))
|
|
|
|
;; add-built-in-languages : -> void
|
|
(define (add-built-in-languages)
|
|
(let* ([words #f]
|
|
[extras-mixin
|
|
(λ (mred-launcher? one-line-summary)
|
|
(λ (%)
|
|
(class* % (drracket:language:language<%>)
|
|
(define/override (get-one-line-summary) one-line-summary)
|
|
(inherit get-module get-transformer-module get-init-code
|
|
use-namespace-require/copy-from-setting?)
|
|
(define/override (front-end/interaction port settings)
|
|
(let ([t (super front-end/interaction port settings)])
|
|
(λ ()
|
|
(parameterize ([read-accept-lang #f])
|
|
(t)))))
|
|
(define/augment (capability-value key)
|
|
(cond
|
|
[(eq? key 'drscheme:autocomplete-words)
|
|
(get-all-manual-keywords)]
|
|
[else (inner
|
|
(drracket:language:get-capability-default key)
|
|
capability-value key)]))
|
|
(super-new))))]
|
|
[make-simple
|
|
(λ (module id position numbers mred-launcher? one-line-summary extra-mixin)
|
|
(let ([%
|
|
(extra-mixin
|
|
((extras-mixin mred-launcher? one-line-summary)
|
|
((drracket:language:get-default-mixin)
|
|
(drracket:language:module-based-language->language-mixin
|
|
(drracket:language:simple-module-based-language->module-based-language-mixin
|
|
drracket:language:simple-module-based-language%)))))])
|
|
(instantiate % ()
|
|
(module module)
|
|
(language-id id)
|
|
(language-position position)
|
|
(language-numbers numbers))))])
|
|
(add-language
|
|
(make-simple '(lib "lang/plt-pretty-big.rkt")
|
|
"plt:pretty-big"
|
|
(list (string-constant legacy-languages)
|
|
(string-constant pretty-big-scheme))
|
|
(list -200 3)
|
|
#t
|
|
(string-constant pretty-big-scheme-one-line-summary)
|
|
(λ (%) (pretty-big-mixin (macro-stepper-mixin (assume-mixin (add-errortrace-key-mixin %)))))))
|
|
(add-language
|
|
(make-simple '(lib "r5rs/lang.rkt")
|
|
"plt:r5rs"
|
|
(list (string-constant legacy-languages)
|
|
(string-constant r5rs-language-name))
|
|
(list -200 -1000)
|
|
#f
|
|
(string-constant r5rs-one-line-summary)
|
|
(lambda (%) (r5rs-mixin (macro-stepper-mixin (assume-mixin (add-errortrace-key-mixin %)))))))
|
|
|
|
(add-language
|
|
(make-simple 'racket/base
|
|
"plt:no-language-chosen"
|
|
(list (string-constant initial-language-category)
|
|
(string-constant no-language-chosen))
|
|
(list 10000 1000)
|
|
#f
|
|
"Helps the user choose an initial language"
|
|
not-a-language-extra-mixin))))
|
|
|
|
(define (not-a-language-extra-mixin %)
|
|
(class* % (not-a-language-language<%>)
|
|
(define/override (get-style-delta) drracket:rep:error-delta)
|
|
|
|
(define/override (first-opened)
|
|
(not-a-language-message)
|
|
(eprintf "\n"))
|
|
|
|
(define/override (front-end/interaction input settings)
|
|
(not-a-language-message)
|
|
(λ () eof))
|
|
(define/override (front-end/complete-program input settings)
|
|
(not-a-language-message)
|
|
(λ () eof))
|
|
|
|
(define/augment (capability-value v)
|
|
(case v
|
|
[(drscheme:define-popup) #f]
|
|
[(gui-debugger:debug-button) #f]
|
|
[(macro-stepper:enabled) #f]
|
|
[(drscheme:check-syntax-button) #f]
|
|
[else (inner (drracket:language:get-capability-default v)
|
|
capability-value v)]))
|
|
|
|
(super-new)))
|
|
|
|
;; used for identification only
|
|
(define not-a-language-language<%>
|
|
(interface ()))
|
|
|
|
|
|
|
|
;
|
|
;
|
|
; ;;
|
|
; ; ;
|
|
; ;; ;; ;;; ;;;;; ;;; ; ;;; ;; ;; ;; ;;;; ;; ;;; ;; ;; ;;;
|
|
; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ;
|
|
; ; ; ; ; ; ;;;;; ;;;; ;;;;; ; ;;;; ; ; ; ; ; ; ;;;; ; ; ;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
|
|
; ;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;;;;;;; ;;; ;;;; ;; ;; ;;;;; ;;;; ;;;;
|
|
; ; ;
|
|
; ;;; ;;;
|
|
;
|
|
;
|
|
|
|
|
|
(define (not-a-language-message)
|
|
(define (main)
|
|
(when (language-still-unchanged?)
|
|
(o (green-snip (string-constant must-choose-language)))
|
|
(o "\n")
|
|
(o (green-snip (string-constant get-guidance-before)))
|
|
(o (new link-snip%
|
|
[words (string-constant get-guidance-during)]
|
|
[callback (lambda (snip)
|
|
(not-a-language-dialog (find-parent-from-snip snip)))]))
|
|
(o (green-snip (string-constant get-guidance-after)))))
|
|
|
|
(define (green-snip str)
|
|
(let ([snp (make-object string-snip% str)])
|
|
(send snp set-style green-style)
|
|
snp))
|
|
|
|
(define green-style
|
|
(let ([list (editor:get-standard-style-list)]
|
|
[green-style-delta (make-object style-delta% 'change-family 'default)])
|
|
(send green-style-delta set-delta-foreground "DarkViolet")
|
|
(send green-style-delta set-delta 'change-italic)
|
|
(send list
|
|
find-or-create-style
|
|
(send list find-named-style "Standard")
|
|
green-style-delta)))
|
|
|
|
(define (language-still-unchanged?)
|
|
(let ([rep (drracket:rep:current-rep)])
|
|
(cond
|
|
[rep
|
|
(let* ([next-settings (send (send rep get-definitions-text) get-next-settings)]
|
|
[next-lang (language-settings-language next-settings)])
|
|
(is-a? next-lang not-a-language-language<%>))]
|
|
|
|
;; if we cannot get the REP
|
|
;; (because a tool is processing the progrm like check syntax)
|
|
;; then just assume it has not changed.
|
|
[else #t])))
|
|
|
|
(define o
|
|
(case-lambda
|
|
[(arg) (cond [(string? arg) (eprintf arg)]
|
|
[(is-a? arg snip%) (write-special arg (current-error-port))])]
|
|
[args (apply eprintf args)]))
|
|
|
|
(define arrow-cursor (make-object cursor% 'arrow))
|
|
|
|
(define link-snip%
|
|
(class editor-snip%
|
|
(init-field words callback)
|
|
|
|
(define/override (adjust-cursor dc x y editorx editory event) arrow-cursor)
|
|
|
|
(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))
|
|
(send link-sd set-delta-foreground "blue")
|
|
(send link-sd set-family 'default)
|
|
|
|
(main))
|
|
|
|
(define (not-a-language-dialog drs-frame)
|
|
(define dialog (new dialog%
|
|
(parent drs-frame)
|
|
(label (string-constant drscheme))))
|
|
(define top-hp (new horizontal-pane% [parent dialog]))
|
|
(define qa-panel (new vertical-panel% [style '(border)] (parent top-hp) (stretchable-width #f)))
|
|
(define racketeer-panel (new vertical-panel% [style '(border)] [parent top-hp] [alignment '(center center)] [stretchable-width #f]))
|
|
(define button-panel (new horizontal-pane%
|
|
(parent dialog)
|
|
(stretchable-height #f)
|
|
(alignment '(right center))))
|
|
|
|
(define cancel (new button%
|
|
(parent button-panel)
|
|
(callback (lambda (x y) (send dialog show #f)))
|
|
(label (string-constant cancel))))
|
|
|
|
(define language-chosen? #f)
|
|
|
|
(define (main)
|
|
(insert-text-pls)
|
|
(display-racketeer)
|
|
(space-em-out)
|
|
(fix-msg-sizes)
|
|
(send dialog show #t))
|
|
|
|
(define (insert-red-message)
|
|
(new canvas-message%
|
|
(parent qa-panel)
|
|
(font (get-font #:style 'italic))
|
|
(label (string-constant must-choose-language))
|
|
(color (send the-color-database find-color "red"))))
|
|
|
|
(define (space-em-out)
|
|
(send qa-panel change-children
|
|
(lambda (l)
|
|
(cond
|
|
[(null? l) l]
|
|
[else
|
|
(let loop ([x (car l)]
|
|
[r (cdr l)])
|
|
(cond
|
|
[(null? r) (list x)]
|
|
[else (list* x
|
|
(new vertical-pane%
|
|
(parent qa-panel)
|
|
(min-height 5)
|
|
(stretchable-height #f))
|
|
(loop (car r)
|
|
(cdr r)))]))]))))
|
|
|
|
(define (insert-text-pls)
|
|
(for-each
|
|
display-text-pl
|
|
(sort
|
|
(apply append (map get-text-pls (find-relevant-directories '(textbook-pls))))
|
|
(λ (x y)
|
|
(cond
|
|
[(string=? (cadr x) (string-constant how-to-design-programs))
|
|
#t]
|
|
[(string=? (string-constant how-to-design-programs) (cadr y))
|
|
#f]
|
|
[else
|
|
(string<=? (cadr x) (cadr y))])))))
|
|
|
|
(define (display-racketeer)
|
|
(new canvas-message%
|
|
(parent racketeer-panel)
|
|
(label (string-constant racketeer?)))
|
|
(new canvas-message%
|
|
[label (read-bitmap (collection-file-path "plt-logo-red-shiny.png" "icons"))]
|
|
[parent racketeer-panel]
|
|
[callback (λ () (change-current-lang-to (λ (x) (is-a? x drracket:module-language:module-language<%>))))])
|
|
(new canvas-message%
|
|
(parent racketeer-panel)
|
|
(label (string-constant use-language-in-source))
|
|
(color (send the-color-database find-color "blue"))
|
|
(callback (λ () (change-current-lang-to (λ (x) (is-a? x drracket:module-language:module-language<%>)))))
|
|
(font (get-font #:underlined #t))))
|
|
|
|
(define (display-text-pl lst)
|
|
(let ([icon-lst (car lst)]
|
|
[text-name (cadr lst)]
|
|
[lang (cddr lst)]
|
|
[using-before (string-constant using-a-textbook-before)]
|
|
[using-after (string-constant using-a-textbook-after)])
|
|
(question/answer (lambda (parent)
|
|
(new canvas-message%
|
|
(parent parent)
|
|
(label using-before))
|
|
(new canvas-message%
|
|
(parent parent)
|
|
(font (get-font #:style 'italic))
|
|
(label text-name))
|
|
(new canvas-message%
|
|
(parent parent)
|
|
(label using-after)))
|
|
(default-line2 (last lang) lang)
|
|
icon-lst)))
|
|
|
|
(define default-font (send the-font-list find-or-create-font
|
|
12
|
|
'default
|
|
'normal
|
|
'normal))
|
|
|
|
(define (get-font #:point-size [point-size (send default-font get-point-size)]
|
|
#:family (family (send default-font get-family))
|
|
#:style (style (send default-font get-style))
|
|
#:weight (weight (send default-font get-weight))
|
|
#:underlined (underlined (send default-font get-underlined))
|
|
#:smoothing (smoothing (send default-font get-smoothing)))
|
|
(send the-font-list find-or-create-font
|
|
point-size
|
|
family
|
|
style
|
|
weight
|
|
underlined
|
|
smoothing))
|
|
|
|
(define canvas-message%
|
|
(class canvas%
|
|
(init-field label
|
|
[font (get-font)]
|
|
[callback void]
|
|
[color (send the-color-database find-color "black")])
|
|
|
|
(define/override (on-event evt)
|
|
(cond
|
|
[(send evt button-up?)
|
|
(callback)]
|
|
[else
|
|
(super on-event evt)]))
|
|
|
|
(define/override (on-paint)
|
|
(define dc (get-dc))
|
|
(cond
|
|
[(string? label)
|
|
(define old-font (send dc get-font))
|
|
(define old-tf (send dc get-text-foreground))
|
|
(send dc set-text-foreground color)
|
|
(send dc set-font font)
|
|
(send dc draw-text label 0 0 #t)
|
|
(send dc set-font old-font)
|
|
(send dc set-text-foreground old-tf)]
|
|
[(is-a? label bitmap%)
|
|
(send dc draw-bitmap label 0 0)]))
|
|
|
|
(super-new [stretchable-width #f]
|
|
[stretchable-height #f]
|
|
[style '(transparent)])
|
|
|
|
(inherit min-width min-height get-dc)
|
|
(cond
|
|
[(string? label)
|
|
(define-values (w h _1 _2) (send (get-dc) get-text-extent label font #t))
|
|
(min-width (inexact->exact (ceiling w)))
|
|
(min-height (inexact->exact (ceiling h)))]
|
|
[(is-a? label bitmap%)
|
|
(min-width (inexact->exact (ceiling (send label get-width))))
|
|
(min-height (inexact->exact (ceiling (send label get-height))))])))
|
|
|
|
(define (question/answer line1 line2 icon-lst)
|
|
(display-two-line-choice
|
|
icon-lst
|
|
(λ (panel1 panel2)
|
|
(line1 panel1)
|
|
(line2 panel2))))
|
|
|
|
(define ((default-line2 lang-name lang) panel2)
|
|
(new canvas-message% (parent panel2) (label (string-constant start-with-before)))
|
|
(new canvas-message%
|
|
(parent panel2)
|
|
(label lang-name)
|
|
(color (send the-color-database find-color "blue"))
|
|
(callback (λ () (change-current-lang-to lang)))
|
|
(font (get-font #:underlined #t)))
|
|
(new canvas-message% (parent panel2) (label (string-constant start-with-after))))
|
|
|
|
;; get-text-pls : path -> (listof (list* string string (listof string))
|
|
;; gets the questions from an info.rkt 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
|
|
(string-append
|
|
"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 msgs '())
|
|
(define (fix-msg-sizes)
|
|
(let ([w (apply max (map (λ (x) (send x get-width)) msgs))])
|
|
(for-each (λ (b) (send b min-width w))
|
|
msgs)))
|
|
|
|
(define (display-two-line-choice icon-lst proc)
|
|
(let* ([hp (new horizontal-pane%
|
|
(parent qa-panel)
|
|
(alignment '(center top))
|
|
(stretchable-height #f))]
|
|
[msg (new message%
|
|
(label (make-object bitmap%
|
|
(apply collection-file-path icon-lst)
|
|
'unknown/mask))
|
|
(parent hp))]
|
|
[vp (new vertical-pane%
|
|
(parent hp)
|
|
(alignment '(left top))
|
|
(stretchable-height #f))])
|
|
(set! msgs (cons msg msgs))
|
|
(proc (new horizontal-pane% (parent vp))
|
|
(new horizontal-pane% (parent vp)))))
|
|
|
|
;; change-current-lang-to : (or/c (-> any/c boolean?) (listof string)) -> void
|
|
;; closed the guidance dialog and opens the language dialog
|
|
(define (change-current-lang-to lang-strings/predicate)
|
|
(send dialog show #f)
|
|
(let* ([predicate (if (procedure? lang-strings/predicate)
|
|
lang-strings/predicate
|
|
(λ (x) (equal? lang-strings/predicate (send x get-language-position))))]
|
|
[lang (ormap (λ (x) (and (predicate x) x))
|
|
(get-languages))])
|
|
(unless lang
|
|
(error 'change-current-lang-to "unknown language! ~s" lang-strings/predicate))
|
|
|
|
(let ([new-lang
|
|
(language-dialog #f
|
|
(language-settings lang
|
|
(send lang default-settings))
|
|
drs-frame)])
|
|
(when new-lang
|
|
(set! language-chosen? #t)
|
|
(preferences:set settings-preferences-symbol new-lang)
|
|
(send (send drs-frame get-definitions-text) set-next-settings new-lang)))))
|
|
|
|
(main))
|
|
|
|
;; find-parent-from-editor : editor -> (union frame #f)
|
|
(define (find-parent-from-editor ed)
|
|
(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<%>)
|
|
(find-parent-from-snip (send admin get-snip))))]))
|
|
|
|
;; find-parent-from-snip : snip -> (union frame #f)
|
|
(define (find-parent-from-snip snip)
|
|
(let* ([admin (send snip get-admin)]
|
|
[ed (send admin get-editor)])
|
|
(find-parent-from-editor ed))))
|