(module tool scheme/base
  (require drscheme/tool mzlib/contract
           mred framework
           errortrace/errortrace-lib
           (prefix-in u: mzlib/unit)
           scheme/file
           mrlib/include-bitmap
           mzlib/etc
           mzlib/class
	   string-constants
           profj/libs/java/lang/Object profj/libs/java/lang/array
           profj/libs/java/lang/String)
  (require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss"
           (lib "test-engine.scm" "test-engine")
           (lib "java-tests.scm" "test-engine")
           (lib "test-coverage.scm" "test-engine")
           (except-in "ast.ss" for) #;"tester.scm"
           "display-java.ss")

  (require (for-syntax scheme/base
                       "compile.ss"))
  
  (provide tool@)

  ;Set the default classpath
  (preferences:set-default 'profj:classpath null (lambda (v) (and (list? v) (andmap string? v))))
  
  (define tool@
    (u:unit
      (u:import drscheme:tool^)
      (u:export drscheme:tool-exports^)
      ;Set the Java editing colors
      (define color-prefs-table
        `((keyword ,(make-object color% "black") ,(string-constant profj-java-mode-color-keyword))
          (prim-type ,(make-object color% "darkmagenta")
                     ,(string-constant profj-java-mode-color-prim-type))
          (identifier ,(make-object color% 38 38 128) ,(string-constant profj-java-mode-color-identifier))
          (string ,(make-object color% "forestgreen") ,(string-constant profj-java-mode-color-string))
          (literal ,(make-object color% "forestgreen") ,(string-constant profj-java-mode-color-literal))
          (comment ,(make-object color% 194 116 31) ,(string-constant profj-java-mode-color-comment))
          (error ,(make-object color% "red") ,(string-constant profj-java-mode-color-error))
          (default ,(make-object color% "black") ,(string-constant profj-java-mode-color-default))))
      (define colors-table
        (cons `(block-comment ,(make-object color% 194 116 31) ,(string-constant profj-java-mode-color-comment))
              color-prefs-table))
      
      ;Set the Java coverage colors
      (define coverage-color-prefs
        `((uncovered ,(make-object color% "black") ,(string-constant profj-java-mode-color-default))
          (covered ,(make-object color% "darkmagenta") ,(string-constant profj-coverage-color-covered))))
      
      ;; short-sym->pref-name : symbol -> symbol
      ;; returns the preference name for the color prefs
      (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
      
      ;; short-sym->style-name : symbol->string
      ;; converts the short name (from the table above) into a name in the editor list
      ;; (they are added in by `color-prefs:register-color-preference', called below)
      (define (short-sym->style-name sym) (format "profj:syntax-colors:scheme:~a" sym))
      
      ;; extend-preferences-panel : vertical-panel -> void
      ;; adds in the configuration for the Java colors to the prefs panel
      (define (extend-preferences-panel parent)
        (let ((standard-color-prefs 
               (make-object group-box-panel% (string-constant profj-java-mode-color-heading) parent))
              (coverage-color-panel
               (make-object group-box-panel% (string-constant profj-coverage-color-heading) parent))
              (put 
               (lambda (p)
                 (lambda (line)
                   (let ([sym (car line)]
                         [str (caddr line)])
                     (color-prefs:build-color-selection-panel 
                      p
                      (short-sym->pref-name sym)
                      (short-sym->style-name sym)
                      str))))))
          (for-each (put standard-color-prefs) color-prefs-table)
          (for-each (put coverage-color-panel) coverage-color-prefs)))
      
      (define mode-surrogate% 
        (class color:text-mode%
          (define/override (on-disable-surrogate text)
            (keymap:remove-chained-keymap text java-keymap)
            (super on-disable-surrogate text))
          
          (define/override (on-enable-surrogate text)
            (super on-enable-surrogate text)
            (send (send text get-keymap) chain-to-keymap java-keymap #t))
          (super-new)))
      
      ;Create the Java editing mode
      (define mode-surrogate
        (new mode-surrogate%
             (matches (list (list '|{| '|}|)
                            (list '|(| '|)|)
                            (list '|[| '|]|)))
             (get-token get-syntax-token)
             (token-sym->style short-sym->style-name)))

      (define java-keymap (new keymap:aug-keymap%))
      (send java-keymap add-function "do-return" (λ (edit event) (send edit do-return)))
      (send java-keymap map-function "return" "do-return")
      (send java-keymap map-function "s:return" "do-return")
      (send java-keymap map-function "s:c:return" "do-return")
      (send java-keymap map-function "a:return" "do-return")
      (send java-keymap map-function "s:a:return" "do-return")
      (send java-keymap map-function "c:a:return" "do-return")
      (send java-keymap map-function "c:s:a:return" "do-return")
      (send java-keymap map-function "c:return" "do-return")
      (send java-keymap map-function "d:return" "do-return")
      (keymap:send-map-function-meta java-keymap "return" "do-return")
      (keymap:send-map-function-meta java-keymap "s:return" "do-return")
      (keymap:send-map-function-meta java-keymap "s:c:return" "do-return")
      (keymap:send-map-function-meta java-keymap "a:return" "do-return")
      (keymap:send-map-function-meta java-keymap "s:a:return" "do-return")
      (keymap:send-map-function-meta java-keymap "c:a:return" "do-return")
      (keymap:send-map-function-meta java-keymap "c:s:a:return" "do-return")
      (keymap:send-map-function-meta java-keymap "c:return" "do-return")
    
      (send java-keymap add-function "tabify-at-caret" (λ (edit event) (send edit java-tabify-selection)))
      (send java-keymap map-function "TAB" "tabify-at-caret")
      
      (send java-keymap add-function "insert-{" (lambda (edit event) (send edit open-brace)))
      (send java-keymap map-function "{" "insert-{")
      (keymap:send-map-function-meta java-keymap "{" "insert-{")
      
      (define indent-mixin
        (mixin (color:text<%> editor:keymap<%>) ()
          (inherit insert classify-position set-position
                   get-start-position get-end-position get-character delete
                   backward-match backward-containing-sexp
                   find-string position-paragraph paragraph-start-position
                   begin-edit-sequence end-edit-sequence
                   is-stopped? is-frozen?
                   skip-whitespace forward-match)
          
          (define single-tab-stop 2)
          (define eol "\n")
          
          ;Returns the position immediately following the nearest open, or the start of the buffer
          ;In some cases of mismatched parens, returns false
          (define/private (get-sexp-start pos)
            (let ([sexp-start+whitespace (backward-containing-sexp pos 0)])
              (and sexp-start+whitespace
                   (skip-whitespace sexp-start+whitespace 'backward #t))))
          
          ;Returns whether a block comment just ended when at the end of the buffer
          (define/private (blockcomment-end? pos)
            (and (eq? (classify-position pos) 'block-comment)
                 (let ([close (find-string "*/" 'backward pos 0 #f)])
                   (and close (= pos (+ 2 close))))))
          
          (define/private (get-indentation start-pos)
            (letrec ([last-offset
                      (lambda (previous-line last-line-start)
                        (max (sub1 (if (> last-line-start start-pos)
                                       (- start-pos previous-line)
                                       (- last-line-start previous-line)))
                             0))]
                     [blockcomment-open
                      (lambda (pos)
                        (let loop ([open-pos (find-string "/*" 'backward pos 0 #f)])
                          (cond
                            [(or (not open-pos) (zero? open-pos)) #f]
                            [(eq? (classify-position (sub1 open-pos)) 'block-comment)
                             (loop (find-string "/*" 'backward open-pos 0 #f))]
                            [else open-pos])))]
                     [indent
                      (if (or (is-stopped?) (is-frozen?))
                          0
                          (let* ([base-offset 0]
                                 [curr-open (get-sexp-start start-pos)])
                            #;(printf "indent ~a, ~a :~a ~n" start-pos (classify-position start-pos) curr-open)
                            (cond 
                              [(and (eq? (classify-position start-pos) 'block-comment)
                                         (not (blockcomment-end? start-pos)))
                               (let* ([comment-open (blockcomment-open start-pos)]
                                      [comment-line-start (and comment-open
                                                               (find-string eol 'backward comment-open 0 #f))])
                                 (+ single-tab-stop
                                    (cond
                                      [(not comment-line-start) base-offset]
                                      [else (max 0
                                                 (sub1 (- comment-open comment-line-start)))])))]
                              [(or (not curr-open) (= curr-open 0)) base-offset]
                              [else
                               (let ([previous-line (find-string eol 'backward start-pos 0 #f)])
                                 #;(printf "prev-line ~a~n" previous-line)
                                 (cond 
                                   [(not previous-line) (+ base-offset single-tab-stop)]
                                   [(eq? (classify-position previous-line) 'block-comment)
                                    (let* ([comment-open (blockcomment-open previous-line)]
                                           [comment-line-start (and comment-open
                                                                    (find-string eol 'backward comment-open 0 #f))])
                                      (cond
                                        [(not comment-line-start) base-offset]
                                        [else (max 0
                                                   (sub1 (- comment-open comment-line-start)))]))]
                                   [(or (eq? (classify-position previous-line) 'comment)
                                        (eq? (classify-position previous-line) 'block-comment))
                                    (let* ([last-line-start (skip-whitespace (add1 previous-line) 'forward #f)]
                                           [last-line-indent (last-offset previous-line last-line-start)]
                                           [old-open (get-sexp-start last-line-start)])
                                      #;(printf "lls ~a lli ~a oo ~a~n" last-line-start last-line-indent old-open)
                                      (cond
                                        [(not old-open) last-line-indent]
                                        [(and old-open (<= curr-open old-open)) last-line-indent]
                                        [else (+ single-tab-stop last-line-indent)]))]
                                   [else
                                    (let* ([last-line-start (skip-whitespace previous-line 'forward #f)]
                                           [last-line-indent (last-offset previous-line last-line-start)]
                                           [old-open (get-sexp-start last-line-start)])
                                      #;(printf "lls ~a lli ~a oo~a~n" last-line-start last-line-indent old-open)
                                      (cond
                                        [(not old-open) last-line-indent]
                                        [(and old-open (<= curr-open old-open)) last-line-indent]
                                        [else (+ single-tab-stop last-line-indent)]))]))])))])
              (build-string (max indent 0) (λ (x) #\space))))
          
          (define/public (do-return)
            (let ([start-pos (get-start-position)]
                  [end-pos (get-end-position)])
              (if (= start-pos end-pos)
                  (insert (string-append "\n" (get-indentation start-pos)))
                  (insert "\n"))))
          
          (define/public (open-brace)
            (let* ([start-pos (get-start-position)]
                   [end-pos (get-end-position)]
                   [cur-class (classify-position start-pos)])
              (cond 
                [(and (= start-pos end-pos) 
                      (or (and (eq? cur-class 'block-comment) (blockcomment-end? start-pos))
                          (not (memq cur-class '(comment string error block-comment)))))
                 (insert (string-append "{\n" (get-indentation start-pos) "}"))
                 (set-position (add1 start-pos))
                 ]
                [else (insert "{")])))
                 
          (define/public (java-tabify-selection)
            (let ([start-para (position-paragraph (get-start-position))]
                  [end-para (position-paragraph (get-end-position))])
              (begin-edit-sequence)
              (let loop ([para start-para])
                (let* ([para-start (paragraph-start-position para)]
                       [insertion (get-indentation (max 0 (sub1 para-start)))]
                       [closer? #f]
                       [delete? #f])
                  (let loop ()
                    (let ([c (get-character para-start)]
                          [class (classify-position para-start)])
                      (cond
                        [(and (eq? 'white-space class)
                              (not (char=? c #\015))
                              (not (char=? c #\012)))
                         (set! delete? #t)
                         (delete para-start (+ para-start 1))
                         (loop)]
                        [(and (not (eq? 'block-comment class)) (char=? #\} c))
                         (set! closer? #t)])))
                  (cond
                    [closer?
                     (insert (substring insertion 0 (max 0 (- (string-length insertion) single-tab-stop))) para-start para-start)]
                    [(or delete? (not (eq? 'block-comment (classify-position para-start))))
                     (insert insertion para-start para-start)]))
                (unless (= para end-para)
                  (loop (+ para 1))))
              (end-edit-sequence)))

          (super-new)))
      
      ;repl-submit: text int -> bool
      ;Determines if the reple should submit or not
      (define (repl-submit text prompt-position)
        (let ((is-if? #f)
              (is-string? #f)
              (open-parens 0)
              (open-braces 0)
              (open-curlies 0))
          (let loop ((index 1) (char (send text get-character prompt-position)))
            (unless (eq? char #\nul)
              (cond 
                ;beginning of if statement
                ((and (= index 1) 
                      (eq? char #\i) 
                      (eq? (send text get-character (add1 prompt-position)) #\f)
                      (eq? (send text get-character (+ 2 prompt-position)) #\space))
                 (set! is-if? #t)
                 (loop 3 (send text get-character (+ 3 prompt-position))))
                ((eq? char #\()
                 (unless is-string? (set! open-parens (add1 open-parens)))
                 (loop (add1 index) (send text get-character (+ index prompt-position))))
                ((eq? char #\))
                 (unless is-string? (set! open-parens (sub1 open-parens)))
                 (loop (add1 index) (send text get-character (+ index prompt-position))))
                ((eq? char #\{)
                 (unless is-string? (set! open-curlies (add1 open-curlies)))
                 (loop (add1 index) (send text get-character (+ index prompt-position))))
                ((eq? char #\})
                 (unless is-string? (set! open-curlies (sub1 open-curlies)))
                 (loop (add1 index) (send text get-character (+ index prompt-position))))
                ((eq? char #\[)
                 (unless is-string? (set! open-braces (add1 open-braces)))
                 (loop (add1 index) (send text get-character (+ index prompt-position))))
                ((eq? char #\])
                 (unless is-string? (set! open-braces (sub1 open-braces)))
                 (loop (add1 index) (send text get-character (+ index prompt-position))))
                ;beginning of string
                ((eq? char #\")
                 (set! is-string? (not is-string?))
                 (loop (add1 index) (send text get-character (+ index prompt-position))))
                (else
                 (loop (add1 index) (send text get-character (+ index prompt-position)))))))
          (not (or (not (= open-parens 0))
                   (not (= open-braces 0))
                   (not (= open-curlies 0))
                   is-if?))))
      
      ;; matches-language : (union #f (listof string)) -> boolean
      (define (matches-language l)
        (and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "ProfessorJ")))
      
      (define (phase1) void)
      ;Add all the ProfessorJ languages into DrScheme
      (define (phase2) 
        (drscheme:language-configuration:add-language
         (make-object ((drscheme:language:get-default-mixin) dynamic-lang%)))
        (drscheme:language-configuration:add-language
         (make-object ((drscheme:language:get-default-mixin) full-lang%)))
        (drscheme:language-configuration:add-language
         (make-object ((drscheme:language:get-default-mixin) advanced-lang%)))
        (drscheme:language-configuration:add-language 
         (make-object ((drscheme:language:get-default-mixin) intermediate+access-lang%)))
        (drscheme:language-configuration:add-language
         (make-object ((drscheme:language:get-default-mixin) intermediate-lang%)))
        (drscheme:language-configuration:add-language
         (make-object ((drscheme:language:get-default-mixin) beginner-lang%))))
      
      ;(make-profj-settings symbol boolean boolean boolean boolean (list string))
      (define-struct profj-settings 
        (print-style print-full? allow-check? allow-test? run-tests? coverage? classpath)
        #:transparent)
      
      ;ProfJ general language mixin
      (define (java-lang-mixin level name number one-line dyn? manual-dirname)
        (when dyn? (dynamic? #t))
        (class* object% (drscheme:language:language<%>)
          (define/public (extra-repl-information settings port) (void))
          (define/public (get-reader-module) #f)
          (define/public (get-metadata a b) #f)
          (define/public (metadata->settings m) #f)
          (define/public (get-metadata-lines) #f)
          
          (define autocomplete-words #f)
          
          (define/public (capability-value s) 
            (cond
              [(eq? s 'drscheme:autocomplete-words)
               (unless autocomplete-words 
                 (set! autocomplete-words
                       (if manual-dirname
                           (text:get-completions/manuals (list manual-dirname))
                           '())))
               autocomplete-words]
              [(eq? s 'drscheme:language-menu-title) (string-constant profj-java)]
              [(memq s '(profj:special:java-comment-box 
                         profj:special:java-examples-box 
                         profjWizard:special:java-class
                         profjWizard:special:java-union
                         drscheme:special:insert-image
                         drscheme:special:insert-large-letters
                         tests:dock-menu
                         tests:test-menu)) #t]
              [(memq s '(slideshow:special-menu 
                         drscheme:define-popup
                         profj:special:java-interactions-box)) #f]
              [(regexp-match #rx"^drscheme:special:" (format "~a" s)) #f]
              [else (drscheme:language:get-capability-default s)]))
          (define/public (first-opened) (void))
          
          ;default-settings: -> profj-settings
          (define/public (default-settings) 
            (if (memq level `(beginner intermediate intermediate+access advanced))
                (make-profj-settings 'field #f #t #f #t #t null)
                (make-profj-settings 'type #f #t #t #f #f null)))
          ;default-settings? any -> bool
          (define/public (default-settings? s) (equal? s (default-settings)))
          
          (define/public (update-test-setting s test?)
            (make-profj-settings (profj-settings-print-style s)
                                 (profj-settings-print-full? s)
                                 (profj-settings-allow-check? s)
                                 (profj-settings-allow-test? s)
                                 test?
                                 (profj-settings-coverage? s)
                                 (profj-settings-classpath s)))

          ;marshall-settings: profj-settings -> (list (list symbol) (list bool) (list string))
          (define/public (marshall-settings s)
            (list (list (profj-settings-print-style s))
                  (list (profj-settings-print-full? s))
                  (list (profj-settings-allow-check? s))
                  (list (profj-settings-allow-test? s))
                  (list (profj-settings-run-tests? s))
                  (list (profj-settings-coverage? s))))
          
          ;unmarshall-settings: any -> (U profj-settings #f)
          (define/public (unmarshall-settings s)
            (if (and (pair? s) (= (length s) 6)
                     (pair? (car s)) (= (length (car s)) 1)
                     (pair? (cadr s)) (= (length (cadr s)) 1)
                     (pair? (caddr s)) (= (length (caddr s)) 1)
                     (pair? (cadddr s)) (= (length (cadddr s)) 1)
                     (pair? (list-ref s 4)) (= (length (list-ref s 4)) 1)
                     (pair? (list-ref s 5)) (= (length (list-ref s 5)) 1))
                (make-profj-settings (caar s) (caadr s) (caaddr s) 
                                     (car (cadddr s))
                                     (car (list-ref s 4)) (car (list-ref s 5)) null)
                #f))

          ;Create the ProfessorJ settings selection panel
          (define/public (config-panel _parent)
            (letrec ([parent (instantiate vertical-panel% ()
                               (parent _parent)
                               (alignment '(center center))
                               (stretchable-height #f)
                               (stretchable-width #f))]                     
                     [print-prefs (instantiate group-box-panel% ()
                                     (label (string-constant profj-language-config-display-preferences))
                                     (parent parent)
                                     (alignment '(left center)))]
                     [print-full (when (memq level '(advanced full))
                                   (make-object check-box% 
                                     (string-constant profj-language-config-display-array)
                                     print-prefs 
                                     (lambda (x y) update-pf)))]
                     [print-style (make-object radio-box%
                                    (string-constant profj-language-config-display-style)
                                    (list (string-constant profj-language-config-class) (string-constant profj-language-config-display-field));"Graphical")
                                    print-prefs
                                    (lambda (x y) (update-ps)))]
                     [testing-prefs (instantiate group-box-panel% ()
                                      (label (string-constant profj-language-config-testing-preferences))
                                      (parent parent)
                                      (alignment '(left center)))]
                     [allow-testing (when (eq? level 'full)
                                      (make-object check-box% 
                                        (string-constant profj-language-config-testing-check) 
                                        testing-prefs
                                        (lambda (x y) update-at)))]
                     [allow-test (when (eq? level 'full)
                                   (make-object check-box% (string-constant profj-language-config-support-test-language)
                                     testing-prefs (lambda (x y) update-at2)))]
                     #;[display-testing 
                      (make-object check-box% (string-constant profj-language-config-testing-enable)
                        testing-prefs (lambda (x y) (update-dt x y)))]
                     [collect-coverage 
                      (make-object check-box% (string-constant profj-language-config-testing-coverage)
                        testing-prefs (lambda (x y) update-cc))]
                     
                     [update-pf (lambda () (void))]
                     [update-ps (lambda () (void))]
                     [update-at (lambda () (void))]
                     [update-at2 (lambda () (void))]
                     [update-dt (lambda (box event) 
                                  (when (eq? 'check-box (send event get-event-type))
                                    (send collect-coverage enable (send box get-value))))]
                     [update-cc (lambda () (void))]
                     
                     [cp-panel (instantiate group-box-panel% ()
                                            (parent parent)
                                            (alignment '(left center))
                                            (label (string-constant profj-language-config-classpath)))]
                     [tp-panel (instantiate horizontal-panel% ()
                                 (parent cp-panel)
                                 (alignment '(center center))
                                 (stretchable-height #f))]
                     [lb (instantiate list-box% ()
                                     (parent cp-panel)
                                     (choices `("a" "b" "c"))
                                     (label #f)
                                     (callback (lambda (x y) (update-buttons))))]
                     [top-button-panel (instantiate horizontal-panel% ()
                                         (parent cp-panel)
                                         (alignment '(center center))
                                         (stretchable-height #f))]
                     [bottom-button-panel (instantiate horizontal-panel% ()
                                            (parent cp-panel)
                                            (alignment '(center center))
                                            (stretchable-height #f))]
                     [list-button 
                      (make-object button% (string-constant profj-language-config-classpath-display) tp-panel 
                        (lambda (x y) (list-callback)))]
                     [add-button 
                      (make-object button% (string-constant ml-cp-add) bottom-button-panel 
                        (lambda (x y) (add-callback)))]
                     [remove-button 
                      (make-object button% (string-constant ml-cp-remove) bottom-button-panel 
                        (lambda (x y) (remove-callback)))]
                     [raise-button 
                      (make-object button% (string-constant ml-cp-raise) top-button-panel 
                        (lambda (x y) (raise-callback)))]
                     [lower-button 
                      (make-object button% (string-constant ml-cp-lower) top-button-panel 
                        (lambda (x y) (lower-callback)))]
                     [enable? #f]
                     
                     [update-buttons 
                      (lambda ()
                        (let ([lb-selection (send lb get-selection)]
                              [lb-tot (send lb get-number)])
                          (send remove-button enable (and lb-selection enable?))
                          (send raise-button enable (and lb-selection enable? (not (= lb-selection 0))))
                          (send lower-button enable (and lb-selection enable? (not (= lb-selection (- lb-tot 1)))))))]
                     [add-callback
                      (lambda ()
                        (let ([dir (get-directory (string-constant profj-language-config-choose-classpath-directory) 
                                                  (send parent get-top-level-window))])
                          (when dir
                            (send lb append dir #f)
                            (preferences:set 'profj:classpath (cons dir (preferences:get 'profj:classpath)))
                            (update-buttons))))]
                     [list-callback
                      (lambda ()
                        (send lb clear)
                        (let ((cpath (preferences:get 'profj:classpath)))
                          (let loop ((n 0) (l cpath))
                            (cond
                              ((> n (sub1 (length cpath))) (void))
                              (else (send lb append (car l))
                                    (send lb set-data n (car l))
                                    (loop (+ n 1) (cdr l)))))
                          (unless (null? cpath)
                            (send lb set-selection 0))
                          (set! enable? #t)
                          (update-buttons)))]
                     [remove-callback
                      (lambda ()
                        (let ([to-delete (send lb get-selection)])
                           (send lb delete to-delete)
                          (unless (zero? (send lb get-number))
                            (send lb set-selection (min to-delete (- (send lb get-number) 1))))
                          (preferences:set 'profj:classpath (get-classpath))
                          (update-buttons)))]
                     [lower-callback
                      (lambda ()
                        (let* ([sel (send lb get-selection)]
                               [vec (get-lb-vector)]
                               [below (vector-ref vec (+ sel 1))])
                          (vector-set! vec (+ sel 1) (vector-ref vec sel))
                          (vector-set! vec sel below)
                          (set-lb-vector vec)
                          (send lb set-selection (+ sel 1))
                          (preferences:set 'profj:classpath (get-classpath))
                          (update-buttons)))]
                     [raise-callback
                      (lambda ()
                        (let* ([sel (send lb get-selection)]
                               [vec (get-lb-vector)]
                               [above (vector-ref vec (- sel 1))])
                          (vector-set! vec (- sel 1) (vector-ref vec sel))
                          (vector-set! vec sel above)
                          (set-lb-vector vec)
                          (send lb set-selection (- sel 1))
                          (preferences:set 'profj:classpath (get-classpath))
                          (update-buttons)))]
                     [get-lb-vector
                      (lambda ()
                        (list->vector
                         (let loop ([n 0])
                           (cond
                             [(= n (send lb get-number)) null]
                             [else (cons (cons (send lb get-string n)
                                               (send lb get-data n))
                                         (loop (+ n 1)))]))))]
                     [set-lb-vector
                      (lambda (vec)
                        (send lb clear)
                        (let loop ([n 0])
                          (cond
                            [(= n (vector-length vec)) (void)]
                            [else (send lb append (car (vector-ref vec n)))
                                  (send lb set-data n (cdr (vector-ref vec n)))
                                  (loop (+ n 1))])))]
                     [get-classpath
                      (lambda ()
                        (let loop ([n 0])
                          (cond
                            [(= n (send lb get-number)) null]
                            [else
                             (let ([data (send lb get-data n)])
                               (cons (if data
                                         'default
                                         (send lb get-string n))
                                     (loop (+ n 1))))])))]
                     [install-classpath
                      (lambda (paths)
                        (send lb clear)
                        (for-each (lambda (cp)
                                    (if (symbol? cp)
                                        (send lb append "Default" #t)
                                        (send lb append cp #f)))
                                  paths))])
              (send lb set '())
              (update-buttons)
              
              (case-lambda
                [()
                 (make-profj-settings (case (send print-style get-selection)
                                        [(0) 'type]
                                        [(1) 'field]
                                        [(2) 'graphical])
                                      (and (memq level '(advanced full))
                                           (send print-full get-value))
                                      (or (not (eq? level 'full))
                                          (send allow-testing get-value))
                                      (and (eq? level 'full)
                                           (send allow-test get-value))
                                      #t #;(send display-testing get-value)
                                      (and #t #;(send display-testing get-value)
                                           (send collect-coverage get-value))
                                      (get-classpath))]
                [(settings)
                 (send print-style set-selection
                       (case (profj-settings-print-style settings)
                         ((type default) 0)
                         ((field) 1)
                         ((graphical) 2)))
                 (when (memq level '(advanced full))
                   (send print-full set-value (profj-settings-print-full? settings)))
                 (when (eq? level 'full)
                   (send allow-testing set-value (profj-settings-allow-check? settings)))
                 (when (eq? level 'full)
                   (send allow-test set-value (profj-settings-allow-test? settings)))
                 #;(send display-testing set-value (profj-settings-run-tests? settings))
                 (if #t #;(send display-testing get-value)
                     (send collect-coverage set-value (profj-settings-coverage? settings))
                     (send collect-coverage enable #f))
                 (install-classpath (profj-settings-classpath settings))])))
                     
          ;;Stores the types that can be used in the interactions window
          ;;execute-types: type-record 
          (define execute-types (create-type-record))
          
          (define/public (front-end/complete-program port settings)
            (set! execute-types (create-type-record))
            (mred? #t)
            (let ([name (object-name port)])
              (lambda ()
                (syntax-as-top
                 (let ((end? (eof-object? (peek-char-or-special port))))
                   (if end? 
                       eof 
                       (datum->syntax #f `(parse-java-full-program ,(parse port (get-defn-editor name) #;(quote name) level)
                                                                   ,name) #f)))))))
          (define/public (front-end/interaction port settings)
            (mred? #t)
            (let ([name (object-name port)]
                  [executed? #f])
              (lambda ()
                (if executed? #;(eof-object? (peek-char-or-special port))
                    eof
                    (begin
                      (set! executed? #t)
                      (syntax-as-top
                       (datum->syntax
                        #f
                        #;`(compile-interactions-helper ,(lambda (ast) (compile-interactions-ast ast name level execute-types))
                                                        ,(parse-interactions port name level))
                          `(parse-java-interactions ,(parse-interactions port name level) ,name)
                          #f)))))))
          
          (define (get-defn-editor port-name)
            (let* ([dr-frame (send (drscheme:rep:current-rep) get-top-level-window)]
                   [tabs (and dr-frame  (send dr-frame get-tabs))]
                   [defs (if dr-frame
                             (map (lambda (t) (send t get-defs)) tabs)
                             null)]
                   [def (filter (lambda (d)
                                  (and (is-a? d drscheme:unit:definitions-text<%>)
                                       (send d port-name-matches? port-name)))
                                    defs)])
              (and dr-frame 
                   (= 1 (length def))
                   (car def))))
           
          ;process-extras: (list struct) type-record -> (list syntax)
          (define/private (process-extras extras type-recs)
            (cond
              ((null? extras) null)
              ((example-box? (car extras))
               (let ((contents (eval (example-box-contents (car extras)))))
                 (append 
                  (map (lambda (example)
                         (let* ((type-editor (car example))
                                (type (parse-type (open-input-text-editor type-editor) type-editor level))
                                (name-editor (cadr example))
                                (name (parse-name (open-input-text-editor name-editor) name-editor))
                                (val-editor (caddr example))
                                (val (parse-expression (open-input-text-editor val-editor) val-editor level)))
                           (compile-interactions-ast
                            (make-var-init (make-var-decl name null type #f #f) val #f)
                            val-editor level type-recs #t)))
                       contents)
                  (process-extras (cdr extras) type-recs))))
              ((test-case? (car extras))
               ;(printf "in process-extras~n")
               ;(printf "~a~n" (test-case-test (car extras)))
               (cons
                (let ((tc (test-case-test (car extras))))
                  (syntax-case tc (parse-java-interactions)
                    ((test-case eq (parse-java-interactions ast-1 ed-1) 
                                (parse-java-interactions ast-2 ed-2) end1 end2)
                     (datum->syntax #f
                                    `(,(syntax test-case)
                                      ,(dynamic-require '(lib "profj-testing.ss" "profj") 'java-values-equal?);,(syntax eq)
                                      ,(compile-interactions-ast (syntax->datum (syntax ast-1))
                                                                 (syntax->datum (syntax ed-1)) level type-recs #f)
                                      ,(compile-interactions-ast (syntax->datum (syntax ast-2))
                                                                 (syntax->datum (syntax ed-2)) level type-recs #f)
                                      ,(syntax end1) ,(syntax end2))
                                    #f))
                    (_ tc))) (process-extras (cdr extras) type-recs))
               #;(cons (test-case-test (car extras)) (process-extras (cdr extras) type-recs)))
              #;((interact-case? (car extras))
               (let ((interact-box (interact-case-box (car extras))))
                 (send interact-box set-level level)
                 (send interact-box set-records execute-types)
                 (send interact-box set-ret-kind #t)
                 (append 
                  (with-handlers ((exn? 
                                   (lambda (e)
                                     (send execute-types clear-interactions)
                                     (raise e))))
                    (let-values (((syn-list t t2) 
                                  (send interact-box read-special #f #f #f #f))) syn-list))
                  (process-extras (cdr extras) type-recs))))))
        
          (define/private (find-examples cus)
            (let cu-loop ((cs cus) (examples null) (near-examples null))
              (cond
                ((null? cs) (list examples near-examples))
                (else
                 (let class-loop ((names (compilation-unit-contains (car cs)))
                                  (ex examples)
                                  (ne near-examples))
                   (cond
                     ((null? names) (cu-loop (cdr cs) ex ne))
                     ((regexp-match "Example" (car names))
                      (class-loop (cdr names)
                                  (cons (car names) ex)
                                  ne))
                     ((or (regexp-match "Eample" (car names))
                          (regexp-match "Exmple" (car names))
                          (regexp-match "Exaple" (car names))
                          (regexp-match "Examle" (car names))
                          (regexp-match "Exampe" (car names))
                          (regexp-match "Exampl" (car names))
                          (regexp-match "Eaxmple" (car names)))
                      (class-loop (cdr names)
                                  ex
                                  (cons (format (string-constant profj-test-name-close-to-example)
                                                (car names))
                                        ne)))
                     ((regexp-match "example" (car names))
                      (class-loop (cdr names)
                                  ex
                                  (cons (format (string-constant profj-test-name-example-miscapitalized)
                                                (car names))
                                        ne)))
                     (else
                      (class-loop (cdr names) ex ne))))))))
                
            
          
          ;find-main-module: (list compilation-unit) -> (U syntax #f)
          (define/private (find-main-module mod-lists)
            (if (null? mod-lists)
                #f
                (let ((names (compilation-unit-contains (car mod-lists)))
                      (syntaxes (compilation-unit-code (car mod-lists))))
                  (if (member (cadr (main)) names)
                      (if (= (length syntaxes) 1)
                          (list-ref syntaxes 0)
                          (list-ref syntaxes (find-position names 1)))
                      (find-main-module (cdr mod-lists))))))
        
          ;find-position: (list string) number-> number
          (define/private (find-position l p)
            (when (null? l)
              (error 'find-position "Internal Error: member incorrectly chose an element as a member"))
            (if (equal? (cadr (main)) (car l))
                p
                (find-position (cdr l) (add1 p))))
          
          ;order: (list compilation-unit) -> (list syntax)
          (define/private (order mod-lists)
            (if (null? mod-lists)
                null
                (append (compilation-unit-code (car mod-lists))
                        (order (cdr mod-lists)))))
              
          (define/public (get-comment-character) (values "//" #\*))
          (define/public (get-style-delta) #f)
          (define/public (get-language-position) 
            (cons (string-constant experimental-languages) (list "ProfessorJ" name)))
          (define/public (get-language-numbers) (list 1000 -1000 number))
          (define/public (get-language-name) (string-append "ProfessorJ: " name))
          (define/public (get-language-url) #f)
          (define/public (get-teachpack-names) null)

          (define/private (syntax-as-top s)
	    (if (syntax? s) (namespace-syntax-introduce s) s))
          
          (define/private (get-program-windows rep source)
            (let* ([dr-frame (send rep get-top-level-window)]
                   [tabs (and dr-frame 
                              (send dr-frame get-tabs))]
                   [tab/defs (if dr-frame
                                 (map (lambda (t) (cons (send t get-defs) t)) tabs)
                                 null)]
                   [tab/def (filter (lambda (t/d)
                                      (and (is-a? (car t/d) drscheme:unit:definitions-text<%>)
                                           (send (car t/d) port-name-matches? source)))
                                    tab/defs)])
              (and dr-frame 
                   (= 1 (length tab/def))
                   (list dr-frame (car (car tab/def)) (cdr (car tab/def))))))               
          
          (define/public (on-execute settings run-in-user-thread)
            (dynamic-require 'profj/libs/java/lang/Object #f)
            (let ([obj-path ((current-module-name-resolver) 'profj/libs/java/lang/Object #f #f)]
                  [string-path ((current-module-name-resolver) 'profj/libs/java/lang/String #f #f)]
                  [class-path ((current-module-name-resolver) 'mzlib/class #f #f)]
                  [mred-path ((current-module-name-resolver) 'mred #f #f)]
                  [n (current-namespace)]
                  [e (current-eventspace)])
              (test-ext? (profj-settings-allow-check? settings))
              (testcase-ext? (profj-settings-allow-test? settings))
              (let ((execute-types (create-type-record)))
                (run-in-user-thread
                 (lambda ()
                   (test-ext? (profj-settings-allow-check? settings))
                   (testcase-ext? (profj-settings-allow-test? settings))
                   (test-execute (get-preference 'tests:enable? (lambda () #t)))
                   (coverage? (and (test-execute) (profj-settings-coverage? settings)))
                   (error-display-handler 
                    (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
                   (let ((old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))))
                     (current-eval 
                      (lambda (exp)
                        (syntax-case exp (parse-java-full-program parse-java-interactions)
                          ((parse-java-full-program ex s)
                           (let ((exp (old-current-eval (syntax ex)))
                                 (src (old-current-eval (syntax (quote s)))))
                             (execution? #t)
                             (set! execute-types (create-type-record))
                             (let* ((compilation-units (compile-ast exp level execute-types))
                                    (examples (if (testcase-ext?)
                                                  (list (send execute-types get-test-classes) null)
                                                  (find-examples compilation-units))))
                               #;(printf "ProfJ compilation complete~n")
                               (let ((name-to-require #f)
                                     (tests-run? #f))
                                 (let loop ((mods (order compilation-units))
                                            (extras (process-extras 
                                                     (send execute-types get-interactions-boxes) 
                                                     execute-types))
                                            (require? #f))
                                   (cond
                                     ((and (not require?) (null? mods) tests-run? (null? extras)) (void))
                                     ((and (not require?) (null? mods) (not tests-run?))
                                      (let* ([test-engine-obj 
                                              (make-object (if (testcase-ext?) java-test-base% java-examples-engine%))]
                                             [tc-info (send test-engine-obj get-info)])
                                        (namespace-set-variable-value! 'current~test~object% tc-info)
                                        (send test-engine-obj install-tests 
                                              (map (lambda (c)
                                                     (list c (old-current-eval (string->symbol c)) c))
                                                   (car examples)))
                                        (when (coverage?)
                                          (send (send test-engine-obj get-info) add-analysis 
                                                (make-object coverage-analysis%)))
                                        (send test-engine-obj refine-display-class 
                                              (cond
                                                [(and (testcase-ext?) (coverage?)) java-test-coverage-graphics%]
                                                [(coverage?) java-examples-coverage-graphics%]
                                                [(testcase-ext?) java-test-graphics%]
                                                [else java-examples-graphics%]))
                                        #;(printf "About to run tests~n")
                                        (send test-engine-obj run)
                                        #;(printf "Test methods run~n")
                                        (send test-engine-obj setup-display (drscheme:rep:current-rep) e)
                                        (send test-engine-obj summarize-results (current-output-port))
                                        (let ([test-objs (send test-engine-obj test-objects)])
                                          (let inner-loop ((os test-objs))
                                            (unless (null? os)
                                              (let ((formatted 
                                                     (format-java-value (car os) (make-format-style #t 'field #f))))
                                                (when (< 24 (total-length formatted))
                                                  (set! formatted 
                                                        (format-java-value (car os) (make-format-style #t 'field #t))))
                                                (let loop ((out formatted))
                                                  (unless (null? out)
                                                    (write-special (car out))
                                                    (loop (cdr out))))
                                                (newline))
                                              (inner-loop (cdr os))))))
                                      (set! tests-run? #t)
                                      (loop mods extras require?))
                                     ((and (not require?) (null? mods) tests-run?)
                                      (old-current-eval (syntax-as-top (car extras)))
                                      (loop mods (cdr extras) require?))
                                     (require? 
                                      (old-current-eval 
                                       (syntax-as-top (with-syntax ([name name-to-require])
                                                        (syntax (require (quote name))))))
                                      (loop mods extras #f))
                                     (else 
                                      #;(printf "~a~n" (syntax->datum (car mods)))
                                      (let-values (((name syn) (get-module-name (expand (car mods)))))
                                        (set! name-to-require name)
                                        (syntax-as-top #;(eval (annotate-top (compile syn)))
                                         (old-current-eval 
                                          (errortrace-annotate syn)))
                                        (loop (cdr mods) extras #t)))))))))
                          ((parse-java-interactions ex loc)
                           (let ((exp (syntax->datum (syntax ex))))
                             (old-current-eval 
                              (syntax-as-top (compile-interactions-ast exp (syntax loc) level execute-types #t)))))
                          (_ (old-current-eval exp))))))
                   (with-handlers ([void (lambda (x)  (printf "~a~n" (exn-message x)))])
                     (namespace-require 'mzscheme)
                     (namespace-attach-module n obj-path)
                     (namespace-attach-module n string-path)
                     (namespace-attach-module n class-path)
                     (namespace-attach-module n mred-path)
                     (namespace-require obj-path)
                     (namespace-require string-path)
                     (namespace-require class-path)
                     (namespace-require mred-path)
                     (namespace-require '(prefix javaRuntime: profj/libs/java/runtime))
                     (namespace-require '(prefix c: mzlib/contract))
                     ))))))
          
          #;(define/public (render-value value settings port); port-write)
            (let ((print-full? (profj-settings-print-full? settings))
                  (style (profj-settings-print-style settings)))
              (write-special 
               (if (is-a? value String)
                     (format-java value print-full? style null #t 0)
                     (let ((out (format-java value print-full? style null #f 0)))
                       (if (< 25 (string-length out))
                           (format-java value print-full? style null #t 0)
                           out))) port)
              (void)))
          
          (define/public (render-value value settings port)
            (let* ((print-full? (profj-settings-print-full? settings))
                   (style (profj-settings-print-style settings))
                   (formatted (format-java-value value 
                                                 (make-format-style print-full? style #f))))
              (when (< 24 (total-length formatted))
                (set! formatted (format-java-value value (make-format-style print-full? style #t))))
              (let loop ((out formatted))
                (unless (null? out)
                  (write-special (car out) port)
                  (loop (cdr out))))))
          
          (define/private (total-length lst)
            (cond
              ((null? lst) 0)
              ((string? (car lst)) (+ (string-length (car lst))
                                      (total-length (cdr lst))))
              (else (add1 (total-length (cdr lst))))))
              
          (define/public (render-value/format value settings port width) 
            (render-value value settings port)
            (newline port))
          
          (define/public (create-executable fn parent . args)
            ;(printf "create-exe called~n")
	    (message-box (string-constant profj-unsupported)
			 (string-constant profj-executables-unsupported)
			 parent))
	  (define/public (get-one-line-summary) one-line)
          
          (super-instantiate ())))
      
      ;Create the ProfessorJ languages
      (define dynamic-lang% (java-lang-mixin 'full (string-constant profj-dynamic-lang) 6 (string-constant profj-dynamic-lang-one-summary) #t #f))
      (define full-lang% (java-lang-mixin 'full (string-constant profj-full-lang) 5 (string-constant profj-full-lang-one-line-summary) #f #f))
      (define advanced-lang% (java-lang-mixin 'advanced (string-constant profj-advanced-lang) 4 (string-constant profj-advanced-lang-one-line-summary) #f
                                              "profj-advanced"))
      (define intermediate+access-lang% 
        (java-lang-mixin 'intermediate+access 
                         (string-constant profj-intermediate-access-lang) 3 (string-constant profj-intermediate-access-lang-one-line-summary) #f
                         "profj-intermediate-access"))
      (define intermediate-lang% 
        (java-lang-mixin 'intermediate (string-constant profj-intermediate-lang) 2 (string-constant profj-intermediate-lang-one-line-summary) #f
                         "profj-intermediate"))
      (define beginner-lang% (java-lang-mixin 'beginner (string-constant profj-beginner-lang) 1 (string-constant profj-beginner-lang-one-line-summary) #f
                                              "profj-beginner"))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;
      ;;  Wire up to DrScheme
      ;;
      
      (drscheme:modes:add-mode (string-constant profj-java-mode) mode-surrogate repl-submit matches-language)
      (color-prefs:add-to-preferences-panel (string-constant profj-java) extend-preferences-panel)
      
      (define (register line)
        (let ([sym (car line)]
              [color (cadr line)])
          (color-prefs:register-color-preference (short-sym->pref-name sym)
                                                 (short-sym->style-name sym)
                                                 color)))
      (for-each register colors-table)
      (for-each register coverage-color-prefs)
      
      ;;Java Boxes
      (define java-box%
        (class* decorated-editor-snip% ()
          (inherit get-admin get-editor)
          (define/public (get-comment) "// ")
          (define/public (get-mesg) (string-constant profj-convert-to-text-comment))

          (define/override get-text
            (opt-lambda (offset num [flattened? #t])
              (let* ([super-res (super get-text offset num flattened?)]
                     [replaced (string-append (send this get-comment) 
                                              (regexp-replace* "\n" super-res 
                                                               (string-append "\n" (send this get-comment))))])
                (if (char=? #\newline (string-ref replaced (- (string-length replaced) 1)))
                    replaced
		    (string-append replaced "\n")))))
          (define/override (get-menu)
            (let ([menu (make-object popup-menu%)])
              (make-object menu-item% 
                (send this get-mesg)
                menu
                (lambda (x y)
                  (let ([to-ed (find-containing-editor)])
                    (when to-ed
                      (let ([this-pos (find-this-position)])
                        (when this-pos
                          (let ([from-ed (get-editor)])
                            (send to-ed begin-edit-sequence)
                            (send from-ed begin-edit-sequence)
                            (copy-contents-with-comment-char-to-position to-ed from-ed (+ this-pos 1))
                            (send to-ed delete this-pos (+ this-pos 1))
                            (send to-ed end-edit-sequence)
                            (send from-ed end-edit-sequence))))))))
              menu))
          ;; find-containing-editor : -> (union #f editor)
          (define/private (find-containing-editor)
            (let ([admin (get-admin)])
              (and admin
                   (send admin get-editor))))
          
          ;; find-this-position : -> (union #f number)
          (define/private (find-this-position)
            (let ([ed (find-containing-editor)])
              (and ed
                   (send ed get-snip-position this))))
          
          ;; copy-contents-with-comment-char-to-position : (is-a? text%) number -> void
          (define/private (copy-contents-with-comment-char-to-position to-ed from-ed pos)
            (let loop ([snip (find-last-snip from-ed)])
              (cond
                [snip 
                 (when (or (memq 'hard-newline (send snip get-flags))
                           (memq 'newline (send snip get-flags)))
                   (send to-ed insert (send this get-comment) pos))
                 (send to-ed insert (send snip copy) pos)
                 (loop (send snip previous))]
                [else 
                 (send to-ed insert (send this get-comment) pos)])))
          
          ;; find-last-snip : editor -> snip
          ;; returns the last snip in the editor
          (define/private (find-last-snip ed)
            (let loop ([snip (send ed find-first-snip)]
                       [acc (send ed find-first-snip)])
              (cond
                [snip (loop (send snip next) snip)]
                [else acc])))
          
          (super-instantiate ())
          ))
      
      ;Comment box
      ;;Comment icon
      (define comment-gif (include-bitmap (lib "slash-slash.gif" "icons")))
      
      ;;The following code has been taken with small modifications from framework/private/comment-box.ss
      (define snipclass-java-comment%
        (class decorated-editor-snipclass%
          (define/override (make-snip stream-in) (instantiate java-comment-box% ()))
          (super-instantiate ())))
      
      (define snipclass-comment (make-object snipclass-java-comment%))
      (send snipclass-comment set-version 1)
      (send snipclass-comment set-classname "java-comment-box%")
      (send (get-the-snip-class-list) add snipclass-comment)
      
      (define java-comment-box%
        (class* java-box% (readable-snip<%>)
          (define/override (make-editor) (new text:keymap%))
          (define/override (make-snip) (make-object java-comment-box%))
          (define/override (get-corner-bitmap) comment-gif)
          (define/override (get-position) 'left-top)

          (define/public (read-special source line column position)
            (make-special-comment 1))
          
          (super-instantiate ())
          (inherit set-snipclass get-editor)
          (set-snipclass snipclass-comment)))
          
      (define (java-comment-box-mixin %)
        (class %
          (inherit
            get-insert-menu
            get-special-menu get-edit-target-object register-capability-menu-item)
          
          (super-new)
          (new menu-item%
            (label  (string-constant profj-insert-java-comment-box))
            (parent (get-insert-menu))
            (callback
             (lambda (menu event)
               (let ([c-box (new java-comment-box%)]
                     [text (get-edit-target-object)])
                 (send text insert c-box)
                 (send text set-caret-owner c-box 'global))))
            (demand-callback
             (lambda (mi)
               (send mi enable ((get-edit-target-object) . is-a? . text%)))))
          (register-capability-menu-item 'profj:special:java-comment-box (get-insert-menu))
          ))
      
      (drscheme:get/extend:extend-unit-frame java-comment-box-mixin)
      (drscheme:language:register-capability 'profj:special:java-comment-box (flat-contract boolean?) #f)
      
      ;;Java interactions box
      (define ji-gif (include-bitmap (lib "j.gif" "icons")))
      
      (define snipclass-java-interactions%
        (class decorated-editor-snipclass%
          (define/override (make-snip stream-in) (instantiate java-interactions-box% ()))
          (super-instantiate ())))
      
      (define snipclass-interactions (make-object snipclass-java-interactions%))
      (send snipclass-interactions set-version 1)
      (send snipclass-interactions set-classname "java-interactions-box%")
      (send (get-the-snip-class-list) add snipclass-interactions)
      
      (define java-interactions-box%
        (class* java-box% (readable-snip<%>)
          (define/override (make-editor) (new ((drscheme:unit:get-program-editor-mixin) color:text%)))
          (define/override (make-snip) (make-object java-interactions-box%))
          (define/override (get-corner-bitmap) ji-gif)
          (define/override (get-mesg) (string-constant profj-convert-to-comment))
          (define level 'full)
          (define type-recs (create-type-record))
          (define ret-list? #f)
          (define/public (set-level l) (set! level l))
          (define/public (set-records tr) (set! type-recs tr))
          (define/public (set-ret-kind k) (set! ret-list? k)) 
          (define-struct input-length (start-pos end-pos))

          (define/private (newline? char) (memq char '(#\015 #\012)))
          
          (define/public (read-special source line column position)
            (let* ((ed (get-editor))
                   (port (open-input-text-editor ed 0 'end (editor-filter #t)))
                   (inputs-list null))
              (let outer-loop ((c (read-char-or-special port)) (start 0))
                (unless (eof-object? c)
                  (let inner-loop ((put c) (offset start))
                    (cond
                      ((eof-object? put)
                       (set! inputs-list (cons (make-input-length start offset) inputs-list))
                       (outer-loop (read-char-or-special port) (add1 offset)))
                      ((newline? put) 
                       (let ((new-put (read-char-or-special port))) 
                         (if (or (eof-object? new-put) (newline? new-put))
                             (begin
                               (set! inputs-list (cons (make-input-length start (add1 offset)) inputs-list))
                               (outer-loop (read-char-or-special port) (+ 2 offset)))
                             (inner-loop new-put (add1 offset)))))
                      #;((or (eq? put #\015) (eq? put #\012) (eof-object? put))
                         (set! inputs-list (cons (make-input-length start offset) inputs-list))
                         (outer-loop (read-char-or-special port) (add1 offset)))
                      (else (inner-loop (read-char-or-special port) (add1 offset)))))))
              (let ((syntax-list (map 
                                  (lambda (input-len)
                                    (interactions-offset (input-length-start-pos input-len))
                                    
                                    (compile-interactions (open-input-text-editor ed 
                                                                                  (input-length-start-pos input-len)
                                                                                  (input-length-end-pos input-len)
                                                                                  (editor-filter #t))
                                                          ed type-recs level))
                                  (reverse inputs-list))))
                ;(printf "~a~n~a~n" syntax-list (map remove-requires syntax-list))
                (if ret-list?
                    syntax-list
                    (datum->syntax #f `(begin ,@(map remove-requires syntax-list)) #f)))))
          (define (remove-requires syn)
            (syntax-case* syn (begin require) (lambda (r1 r2) (eq? (syntax-e r1) (syntax-e r2)))
              ((begin (require x ...) exp1 exp ...) (syntax (begin exp1 exp ...)))
              (else syn)))
          
          (super-instantiate ())
          (inherit set-snipclass get-editor)
          (set-snipclass snipclass-interactions)
          (send (get-editor) start-colorer
                short-sym->style-name get-syntax-token 
                (list (list '|{| '|}|)
                      (list '|(| '|)|)
                      (list '|[| '|]|)))
          ))
      
      (define (java-interactions-box-mixin %)
        (class %
          (inherit get-insert-menu
                   get-special-menu get-edit-target-object register-capability-menu-item)
          
          (super-new)
          (new menu-item%
               (label (string-constant profj-insert-java-interactions-box))
               (parent (get-insert-menu))
               (callback
                (lambda (menu event)
                  (let ([i-box (new java-interactions-box%)]
                        [text (get-edit-target-object)])
                    (send text insert i-box)
                    (send text set-caret-owner i-box 'global)))))
          (register-capability-menu-item 'profj:special:java-interactions-box (get-insert-menu))
          ))
      
      (drscheme:get/extend:extend-definitions-text indent-mixin)
      (drscheme:get/extend:extend-interactions-text indent-mixin)
      (drscheme:get/extend:extend-unit-frame java-interactions-box-mixin)
      (drscheme:language:register-capability 'profj:special:java-interactions-box (flat-contract boolean?) #t)
 
  ))
  (define (editor-filter delay?)
    (lambda (s)
      (let ((name (send (send s get-snipclass) get-classname)))
        (cond
          ((equal? "test-case-box%" name) (values (make-test-case s) 1))
          ((equal? "java-interactions-box%" name) (values (make-interact-case s) 1))
          ((equal? "java-class-box%" name) (values (make-class-case s) 1))
          (delay? (values (lambda () (send s read-one-special 0 #f #f #f #f)) 1))
          (else (values s 1))))))
    
  (provide compile-interactions-helper)
  (define-syntax (compile-interactions-helper syn)
    (syntax-case syn ()
      ((_ comp ast)
        (namespace-syntax-introduce ((syntax->datum (syntax comp))
                                     (syntax->datum (syntax ast)))))))
  
  (define (get-module-name stx)
    (syntax-case stx (module #%plain-module-begin)
      [(module name lang (#%plain-module-begin bodies ...))
       (values (syntax name)
               (syntax (module name lang
                         (#%plain-module-begin bodies ...))))]
      [else 
       (raise-syntax-error 'Java 
                           "Internal Syntax error in getting module name"
                           stx)]))
  
  (define (add-main-call stx)
    (syntax-case stx (module #%plain-module-begin)
      [(module name lang (#%plain-module-begin bodies ...))
       (let ([execute-body (if (car (main))
                               `(lambda (x) 
				  (display (string-constant profj-executing-main))
                                  (display " - ")
                                  (display (,(string->symbol (string-append (cadr (main)) "-main_java.lang.String1")) x)))
                               'void)])
         (with-syntax ([main (datum->syntax #f execute-body #f)]) 
           (values (syntax name)
                   (syntax (module name lang 
                             (#%plain-module-begin 
                              (begin bodies ...)
                              (main "temporary")))))))]
      [else
       (raise-syntax-error 'Java
                           "Internal Syntax error in compiling Java Program"
                           stx)])))
