#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"
           string-constants
           framework
           setup/getinfo
           syntax/toplevel
           (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-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 use-language-in-source)
                           (format " (~aU)" menukey-string))
            (string-append (string-constant choose-a-language)
                           (format " (~aC)" menukey-string))
            mouse-event-uses-shortcut-prefix?)))
  
  (define sc-lang-in-source-discussion (string-constant lang-in-source-discussion))

  (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^])
    (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)
    
    ;; add-language : (instanceof language%) -> void
    ;; only allows addition on phase2
    ;; effect: updates `languages'
    (define add-language
      (λ (language [front? #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)
        (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 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-instantiate ())))
        
        (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))))
        
        ;; 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))
        
        ;; 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 #t)
        
        (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]) ; 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)
            (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<%>))
                 (preferences:set 'drracket:language-dialog:hierlist-default (send (send i get-language) get-language-position))
                 (set! most-recent-languages-hier-list-selection i)
                 (something-selected 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 i)
                (ok-handler 'execute)))
            (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-pane% [parent parent]))
        (define languages-choice-panel (new vertical-panel%
                                            [parent outermost-panel]
                                            [alignment '(left top)]))
        
        (define use-language-in-source-rb
          (new radio-box% 
               [label #f]
               [choices (list sc-use-language-in-source)]
               [parent languages-choice-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))
        (define in-source-discussion-panel (new horizontal-panel% 
                                                [parent languages-choice-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))
        (define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default))
        (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)
          (when most-recent-languages-hier-list-selection
            (send languages-hier-list select 
                  most-recent-languages-hier-list-selection))
          (send use-language-in-source-rb set-selection #f)
          (send languages-hier-list focus))
        (define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel]))
        (define languages-hier-list-spacer (new horizontal-panel% 
                                                [parent languages-hier-list-panel]
                                                [stretchable-width #f]
                                                [min-width 16]))
        
        (define 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 one-line-summary-message (instantiate message% ()
                                           (parent parent)
                                           (label "")
                                           (stretchable-width #t)))
        
        (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 one-line-summary-message set-label (send language get-one-line-summary))
          (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 languages-hier-list select #f)
          (send use-chosen-language-rb set-selection #f)
          (send use-language-in-source-rb set-selection 0)
          (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 neither 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-chosen-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 use-chosen-language-rb set-selection 0)
          (send use-language-in-source-rb set-selection #f)
          (send revert-to-defaults-button enable #f)
          (send details-panel active-child no-details-panel)
          (send one-line-summary-message set-label "")
          (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 item)
          (send use-chosen-language-rb set-selection 0)
          (send use-language-in-source-rb set-selection #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)
          (let ([positions (send language get-language-position)]
                [numbers (send language get-language-numbers)])
            
            ;; 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
                       "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 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 languages-hier-list]
                                     [positions positions]
                                     [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 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)
          (cond
            [(not (and language-to-show settings-to-show))
             (no-language-selected)]
            [(is-a? language-to-show drracket:module-language:module-language<%>)
             (let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)])
               (when hier-default
                 (select-a-language-in-hierlist hier-default)))
             ;; the above changes the radio button selections, so do it before calling module-language-selected
             (module-language-selected)]
            [else
             (send languages-hier-list focus) ;; only focus when the module language isn't selected
             (send use-chosen-language-rb set-selection 0)
             (send use-language-in-source-rb set-selection #f)
             (select-a-language-in-hierlist (send language-to-show get-language-position))]))
        
        (define (select-a-language-in-hierlist language-position)
          (cond
            [(null? (cdr language-position))
             ;; nothing to open here
             (send (car (send languages-hier-list get-items)) select #t)
             (void)]
            [else
             (let loop ([hi languages-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) 
                    ;; just give up here. probably this means that a bad preference was saved 
                    ;; and we're being called from the module-language case in 'open-current-language'
                    (void)]
                   [else
                    (let ([child (car matching-children)])
                      (cond
                        [(null? position)
                         (send child select #t)]
                        [else
                         (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)
        (send outermost-panel set-alignment 'center 'center)
        
        (for-each add-language-to-dialog languages)
        (send languages-hier-list sort 
              (λ (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])))
        
        ;; 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.
        (let ([t (send (car (send languages-hier-list get-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)))
        
        (send languages-hier-list stretchable-width #t)
        (send languages-hier-list stretchable-height #t)
        (send languages-hier-list accept-tab-focus #t)
        (send languages-hier-list allow-tab-exit #t)
        (send parent reflow-container)
        (close-all-languages)
        (open-current-language)
        (send languages-hier-list min-client-width (text-width (send languages-hier-list get-editor)))
        (send languages-hier-list min-client-height (text-height (send languages-hier-list get-editor)))
        (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)
             [(#\u) 
              (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)]
             [(#\c)
              (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)
      (let* ([t (new text:standard-style-list%)]
             [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)
        (let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))]
               [do-insert
                (λ (str tt-style?)
                  (let ([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" sc-lang-in-source-discussion)])
            (do-insert (car strs) #f)
            (unless (null? (cdr strs))
              (do-insert "#lang" #t)
              (loop (cdr strs)))))
        (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 (size-discussion-canvas canvas)
      (let ([t (send canvas get-editor)])
        
        (let ([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)
        (+ 10 ;; upper bound on some platform specific 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)))
                                                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))])))))
    
    (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)]))
                    (define/override (create-executable setting parent program-filename)
                      (let ([executable-fn
                             (drracket:language:put-executable
                              parent
                              program-filename
                              #t
                              mred-launcher?
                              (if mred-launcher?
                                  (string-constant save-a-mred-launcher)
                                  (string-constant save-a-mzscheme-launcher)))])
                        (when executable-fn
                          (drracket:language:create-module-based-launcher
                           program-filename
                           executable-fn
                           (get-module)
                           (get-transformer-module)
                           (get-init-code setting)
                           mred-launcher?
                           (use-namespace-require/copy-from-setting? setting)))))
                    (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)
          (fprintf (current-error-port) "\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)
              (fprintf (current-error-port) arg)]
             [(is-a? arg snip%)
              (write-special arg (current-error-port))])]
          [args (apply fprintf (current-error-port) 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))
      (define stupid-internal-define-syntax1
        (begin (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 plt-logo-shiny
        (make-object bitmap% (collection-file-path "plt-logo-red-shiny.png" "icons")
          'png/mask))

      (define (display-racketeer)
        (new canvas-message% 
             (parent racketeer-panel)
             (label (string-constant racketeer?)))
        (new canvas% 
             [parent racketeer-panel]
             [stretchable-width #f]
             [paint-callback
              (λ (c dc)
                (send dc set-scale 1/2 1/2)
                (send dc draw-bitmap plt-logo-shiny 0 0
                      'solid (send the-color-database find-color "black")
                      (send plt-logo-shiny get-loaded-mask)))]
             [style '(transparent)]
             [min-width (floor (/ (send plt-logo-shiny get-width) 2))]
             [min-height (floor (/ (send plt-logo-shiny get-height) 2))])
        (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)
            (let* ([dc (get-dc)]
                   [old-font (send dc get-font)]
                   [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)))
          
          (super-new [stretchable-width #f]
                     [stretchable-height #f]
                     [style '(transparent)])
          
          (inherit min-width min-height get-dc)
          (let-values ([(w h _1 _2) (send (get-dc) get-text-extent label font #t)])
            (min-width (inexact->exact (floor w)))
            (min-height (inexact->exact (floor h))))))
      
      (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
                      "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))))
