1299 lines
70 KiB
Scheme
1299 lines
70 KiB
Scheme
(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)])))
|