1008 lines
52 KiB
Scheme
1008 lines
52 KiB
Scheme
(module tool mzscheme
|
|
(require (lib "tool.ss" "drscheme")
|
|
(lib "mred.ss" "mred") (lib "framework.ss" "framework") (lib "unitsig.ss")
|
|
(lib "include-bitmap.ss" "mrlib") (lib "etc.ss")
|
|
(lib "class.ss")
|
|
(lib "string-constant.ss" "string-constants")
|
|
(lib "Object.ss" "profj" "libs" "java" "lang") (lib "array.ss" "profj" "libs" "java" "lang")
|
|
(lib "String.ss" "profj" "libs" "java" "lang"))
|
|
(require "compile.ss" "parameters.ss" "parsers/lexer.ss" "parser.ss" "ast.ss")
|
|
|
|
(require-for-syntax "compile.ss")
|
|
|
|
(provide tool@)
|
|
|
|
;Set the default classpath
|
|
(preferences:set-default 'profj:classpath null (lambda (v) (and (list? v) (andmap string? v))))
|
|
|
|
(define tool@
|
|
(unit/sig drscheme:tool-exports^
|
|
(import drscheme:tool^)
|
|
|
|
;Set the Java editing colors
|
|
(define color-prefs-table
|
|
`((keyword ,(make-object color% "black") ,(string-constant profj-java-mode-color-keyword))
|
|
(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))
|
|
(identifier ,(make-object color% 38 38 128) ,(string-constant profj-java-mode-color-identifier))
|
|
(default ,(make-object color% "black") ,(string-constant profj-java-mode-color-default))))
|
|
|
|
;; 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-pref', called below)
|
|
(define (short-sym->style-name sym) (format "profj:syntax-coloring: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)
|
|
(for-each
|
|
(lambda (line)
|
|
(let ([sym (car line)])
|
|
(color-prefs:build-color-selection-panel
|
|
parent
|
|
(short-sym->pref-name sym)
|
|
(short-sym->style-name sym)
|
|
(format "~a" sym))))
|
|
color-prefs-table))
|
|
|
|
;Create the Java editing mode
|
|
(define mode-surrogate
|
|
(new color:text-mode%
|
|
(matches (list (list '|{| '|}|)
|
|
(list '|(| '|)|)
|
|
(list '|[| '|]|)))
|
|
(get-token get-syntax-token)
|
|
(token-sym->style short-sym->style-name)))
|
|
|
|
;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-lang%)))
|
|
(drscheme:language-configuration:add-language
|
|
(make-object ((drscheme:language:get-default-mixin) beginner-lang%))))
|
|
|
|
;(make-profj-settings symbol boolean (list string))
|
|
(define-struct profj-settings (print-style print-full? classpath) (make-inspector))
|
|
|
|
;ProfJ general language mixin
|
|
(define (java-lang-mixin level name number one-line dyn?)
|
|
(when dyn? (dynamic? #t))
|
|
(class* object% (drscheme:language:language<%>)
|
|
(define/public (first-opened) (void))
|
|
|
|
(define/public (order-manuals x)
|
|
(let* ((beg-list '(#"profj-beginner" #"tour" #"drscheme" #"help"))
|
|
(int-list (cons #"profj-intermediate" beg-list)))
|
|
(values (case level
|
|
((beginner) beg-list)
|
|
((intermediate) int-list)
|
|
((advanced full) (cons #"profj-advanced" int-list)))
|
|
#f)))
|
|
|
|
;default-settings: -> profj-settings
|
|
(define/public (default-settings)
|
|
(if (memq level `(beginner intermediate advanced))
|
|
(make-profj-settings 'field #f null)
|
|
(make-profj-settings 'type #f null)))
|
|
;default-settings? any -> bool
|
|
(define/public (default-settings? s) (equal? s (default-settings)))
|
|
|
|
;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))))
|
|
|
|
;unmarshall-settings: any -> (U profj-settings #f)
|
|
(define/public (unmarshall-settings s)
|
|
(if (and (pair? s) (= (length s) 2)
|
|
(pair? (car s)) (= (length (car s)) 1)
|
|
(pair? (cadr s)) (= (length (cadr s)) 1))
|
|
(make-profj-settings (caar s) (caadr s) null)
|
|
#f))
|
|
|
|
;Create the ProfessorJ settings selection panel
|
|
;Note: Should add strings to string constants
|
|
(define/public (config-panel _parent)
|
|
(letrec ([parent (instantiate vertical-panel% ()
|
|
(parent _parent)
|
|
(alignment '(center center))
|
|
(stretchable-height #f)
|
|
(stretchable-width #f))]
|
|
|
|
[output-panel (instantiate group-box-panel% ()
|
|
(label "Display Preferences")
|
|
(parent parent)
|
|
(alignment '(left center)))]
|
|
[print-full (when (memq level '(advanced full))
|
|
(make-object check-box% "Print entire contents of arrays?" output-panel
|
|
(lambda (x y) update-pf)))]
|
|
[print-style (make-object radio-box%
|
|
"Display style"
|
|
(list "Class" "Class+Fields" );"Graphical")
|
|
output-panel
|
|
(lambda (x y) (update-ps)))]
|
|
|
|
[update-pf (lambda () (void))]
|
|
[update-ps (lambda () (void))]
|
|
|
|
[cp-panel (instantiate group-box-panel% ()
|
|
(parent parent)
|
|
(alignment '(left center))
|
|
(label "Class path"))]
|
|
[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% "Display Current" tp-panel (lambda (x y) (list-callback)))]
|
|
[add-button (make-object button% "Add" bottom-button-panel (lambda (x y) (add-callback)))]
|
|
[remove-button (make-object button% "Remove" bottom-button-panel (lambda (x y) (remove-callback)))]
|
|
[raise-button (make-object button% "Raise" top-button-panel (lambda (x y) (raise-callback)))]
|
|
[lower-button (make-object button% "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 "Choose the directory to add to class path"
|
|
(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])
|
|
(if (memq level '(advanced full))
|
|
(send print-full get-value)
|
|
#f)
|
|
(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)))
|
|
(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 teachpack-cache)
|
|
(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-object #f `(parse-java-full-program ,(parse port name level)) #f)))))))
|
|
(define/public (front-end/interaction port settings teachpack-cache)
|
|
(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-object
|
|
#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)))))))
|
|
|
|
;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-object #f
|
|
`(,(syntax test-case)
|
|
,(dynamic-require '(lib "profj-testing.ss" "profj") 'java-values-equal?);,(syntax eq)
|
|
,(compile-interactions-ast (syntax-object->datum (syntax ast-1))
|
|
(syntax-object->datum (syntax ed-1)) level type-recs #f)
|
|
,(compile-interactions-ast (syntax-object->datum (syntax ast-2))
|
|
(syntax-object->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))))))
|
|
|
|
;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 10 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/public (on-execute settings run-in-user-thread)
|
|
(dynamic-require '(lib "Object.ss" "profj" "libs" "java" "lang") #f)
|
|
(let ([obj-path ((current-module-name-resolver) '(lib "Object.ss" "profj" "libs" "java" "lang") #f #f)]
|
|
[string-path ((current-module-name-resolver) '(lib "String.ss" "profj" "libs" "java" "lang") #f #f)]
|
|
[class-path ((current-module-name-resolver) '(lib "class.ss") #f #f)]
|
|
[mred-path ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)]
|
|
[n (current-namespace)])
|
|
(read-case-sensitive #t)
|
|
(run-in-user-thread
|
|
(lambda ()
|
|
(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)
|
|
(let ((exp (old-current-eval (syntax ex))))
|
|
(execution? #t)
|
|
(let ((name-to-require #f))
|
|
(let loop ((mods (order (compile-ast exp level execute-types)))
|
|
(extras (process-extras
|
|
(send execute-types get-interactions-boxes) execute-types))
|
|
(require? #f))
|
|
(cond
|
|
((and (not require?) (null? mods) (null? extras)) (void))
|
|
((and (not require?) (null? mods))
|
|
(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 name)))))
|
|
(loop mods extras #f))
|
|
(else
|
|
(let-values (((name syn) (get-module-name (expand (car mods)))))
|
|
(set! name-to-require name)
|
|
(syntax-as-top (old-current-eval syn))
|
|
(loop (cdr mods) extras #t))))))))
|
|
((parse-java-interactions ex loc)
|
|
(let ((exp (syntax-object->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: (lib "runtime.scm" "profj" "libs" "java")))
|
|
(namespace-require '(prefix c: (lib "contract.ss")))
|
|
)))))
|
|
|
|
#;(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-list value print-full? style null #f 0)))
|
|
(when (< 24 (total-length formatted))
|
|
(set! formatted (format-java-list value print-full? style null #t 0)))
|
|
(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 "Unsupported"
|
|
"Sorry - executables are not supported for Java at this time"
|
|
parent))
|
|
(define/public (get-one-line-summary) one-line)
|
|
|
|
(super-instantiate ())))
|
|
|
|
;Create the ProfessorJ languages
|
|
(define full-lang% (java-lang-mixin 'full "Full" 4 "Like Java 1.0 (some 1.1)" #f))
|
|
(define advanced-lang% (java-lang-mixin 'advanced "Advanced" 3 "Java-like Advanced teaching language" #f))
|
|
(define intermediate-lang%
|
|
(java-lang-mixin 'intermediate "Intermediate" 2 "Java-like Intermediate teaching language" #f))
|
|
(define beginner-lang% (java-lang-mixin 'beginner "Beginner" 1 "Java-like Beginner teaching language" #f))
|
|
(define dynamic-lang% (java-lang-mixin 'full "Java+dynamic" 5 "Java with dynamic typing capabilities" #t))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; 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)
|
|
|
|
(for-each (lambda (line)
|
|
(let ([sym (car line)]
|
|
[color (cadr line)])
|
|
(color-prefs:register-color-pref (short-sym->pref-name sym)
|
|
(short-sym->style-name sym)
|
|
color)))
|
|
color-prefs-table)
|
|
|
|
;;Java Boxes
|
|
(define java-box%
|
|
(class* decorated-editor-snip% ()
|
|
(inherit get-admin get-editor)
|
|
(define/public (get-comment) "// ")
|
|
(define/public (get-mesg) "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-special-menu get-edit-target-object)
|
|
|
|
(super-new)
|
|
(new menu-item%
|
|
(label (string-constant profj-insert-java-comment-box))
|
|
(parent (get-special-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)))))))
|
|
|
|
(drscheme:get/extend:extend-unit-frame java-comment-box-mixin)
|
|
|
|
;;Java interactions box
|
|
#;(define ji-gif (include-bitmap (lib "java-interactions-box.gif" "icons")))
|
|
(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) "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-object #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-special-menu get-edit-target-object)
|
|
|
|
(super-new)
|
|
(new menu-item%
|
|
(label (string-constant profj-insert-java-interactions-box))
|
|
(parent (get-special-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)))))))
|
|
|
|
(drscheme:get/extend:extend-unit-frame java-interactions-box-mixin)
|
|
|
|
|
|
))
|
|
(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-object->datum (syntax comp))
|
|
(syntax-object->datum (syntax ast)))))))
|
|
|
|
|
|
(define (supports-printable-interface? o)
|
|
(and (is-a? o object%)
|
|
(method-in-interface? 'my-name (object-interface o))
|
|
(method-in-interface? 'fields-for-display (object-interface o))))
|
|
|
|
(provide format-java)
|
|
;formats a java value (number, character or Object) into a string
|
|
;format-java: java-value bool symbol (list value) -> string
|
|
(define (format-java value full-print? style already-printed newline? num-tabs)
|
|
(cond
|
|
((null? value) "null")
|
|
((number? value) (format "~a" value))
|
|
((char? value) (format "'~a'" value))
|
|
((boolean? value) (if value "true" "false"))
|
|
((is-java-array? value)
|
|
(if full-print?
|
|
(array->string value (send value length) -1 #t style already-printed newline? num-tabs)
|
|
(array->string value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
|
|
((is-a? value String) (format "~v" (send value get-mzscheme-string)))
|
|
((string? value) (format "~v" value))
|
|
((or (is-a? value ObjectI) (supports-printable-interface? value))
|
|
(case style
|
|
((type) (send value my-name))
|
|
((field)
|
|
(let* ((retrieve-fields (send value fields-for-display))
|
|
(st (format "~a(" (send value my-name)))
|
|
(new-tabs (+ num-tabs 3));(string-length st)))
|
|
(fields ""))
|
|
(let loop ((current (retrieve-fields)))
|
|
(let ((next (retrieve-fields)))
|
|
(when current
|
|
(set! fields
|
|
(string-append fields
|
|
(format "~a~a = ~a~a~a"
|
|
(if newline? (if (equal? fields "")
|
|
(format "~n~a" (get-n-spaces new-tabs)); ""
|
|
(get-n-spaces new-tabs)) "")
|
|
(car current)
|
|
(if (memq (cadr current) already-printed)
|
|
(format-java (cadr current) full-print? 'type already-printed #f 0)
|
|
(format-java (cadr current) full-print? style
|
|
(cons value already-printed) newline?
|
|
(if newline?
|
|
(+ new-tabs (string-length (car current)) 3)
|
|
num-tabs)))
|
|
(if next "," "")
|
|
(if newline? (format "~n") " "))))
|
|
(loop next))))
|
|
(string-append st
|
|
(if (> (string-length fields) 1)
|
|
(substring fields 0 (sub1 (string-length fields))) "") ")")))
|
|
(else (send value my-name))))
|
|
(else (format "~a" value))))
|
|
|
|
(define (format-java-list value full-print? style already-printed newline? num-tabs)
|
|
(cond
|
|
((null? value) '("null"))
|
|
((number? value) (list (format "~a" value)))
|
|
((char? value) (list (format "'~a'" value)))
|
|
((boolean? value) (list (if value "true" "false")))
|
|
((is-java-array? value)
|
|
(if full-print?
|
|
(format-array->list value (send value length) -1 #t style already-printed newline? num-tabs)
|
|
(format-array->list value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
|
|
((is-a? value String) (list (format "~v" (send value get-mzscheme-string))))
|
|
((string? value) (list (format "~v" value)))
|
|
((or (is-a? value ObjectI) (supports-printable-interface? value))
|
|
(cond
|
|
((equal? "Image" (send value my-name))
|
|
;(printf "~a~n" ((send value fields-for-display)))
|
|
(list (cadr ((send value fields-for-display)))))
|
|
(else
|
|
(case style
|
|
((type) (list (send value my-name)))
|
|
((field)
|
|
(let* ((retrieve-fields (send value fields-for-display))
|
|
(st (format "~a(" (send value my-name)))
|
|
(new-tabs (+ num-tabs 3))
|
|
(fields null))
|
|
(let loop ((current (retrieve-fields)))
|
|
(let ((next (retrieve-fields)))
|
|
(when current
|
|
(set! fields
|
|
(append fields
|
|
(cons
|
|
(format "~a~a = "
|
|
(if newline? (if (eq? fields null)
|
|
(format "~n~a" (get-n-spaces new-tabs))
|
|
(get-n-spaces new-tabs)) "")
|
|
(car current))
|
|
(append
|
|
(if (memq (cadr current) already-printed)
|
|
(format-java-list (cadr current) full-print? 'type already-printed #f 0)
|
|
(format-java-list (cadr current) full-print? style
|
|
(cons value already-printed) newline?
|
|
(if newline?
|
|
(+ new-tabs (if (string? (car current))
|
|
(string-length (car current)) 1) 3)
|
|
num-tabs)))
|
|
(list (format "~a~a"
|
|
(if next "," "")
|
|
(if newline? (format "~n") " ")))))))
|
|
(loop next))))
|
|
(cons st
|
|
(append
|
|
(if (> (length fields) 1)
|
|
(reverse (cdr (reverse fields))) null) (list ")")))))
|
|
(else (list (send value my-name)))))))
|
|
(else (list value))))
|
|
|
|
;format-array->list: java-value int int bool symbol (list value) -> (list val)
|
|
(define (format-array->list value stop restart full-print? style already-printed nl? nt)
|
|
(letrec ((len (send value length))
|
|
(make-partial-string
|
|
(lambda (idx first-test second-test)
|
|
(cond
|
|
((first-test idx) "")
|
|
((second-test idx)
|
|
(string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
|
|
(make-partial-string (add1 idx) first-test second-test)))
|
|
(else
|
|
(string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
|
|
" "
|
|
(make-partial-string (add1 idx) first-test second-test)))))))
|
|
(if (or full-print? (< restart stop))
|
|
(list (format "[~a]" (make-partial-string 0 (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len))))))
|
|
(list (format "[~a~a~a]"
|
|
(make-partial-string 0 (lambda (i) (or (>= i stop) (>= i len))) (lambda (i) (= i (sub1 stop))))
|
|
" ... "
|
|
(make-partial-string restart (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len)))))))))
|
|
|
|
|
|
;array->string: java-value int int bool symbol (list value) -> string
|
|
(define (array->string value stop restart full-print? style already-printed nl? nt)
|
|
(letrec ((len (send value length))
|
|
(make-partial-string
|
|
(lambda (idx first-test second-test)
|
|
(cond
|
|
((first-test idx) "")
|
|
((second-test idx)
|
|
(string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
|
|
(make-partial-string (add1 idx) first-test second-test)))
|
|
(else
|
|
(string-append (format-java (send value access idx) full-print? style already-printed nl? nt)
|
|
" "
|
|
(make-partial-string (add1 idx) first-test second-test)))))))
|
|
(if (or full-print? (< restart stop))
|
|
(format "[~a]" (make-partial-string 0 (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len)))))
|
|
(format "[~a~a~a]"
|
|
(make-partial-string 0 (lambda (i) (or (>= i stop) (>= i len))) (lambda (i) (= i (sub1 stop))))
|
|
" ... "
|
|
(make-partial-string restart (lambda (i) (>= i len)) (lambda (i) (= i (sub1 len))))))))
|
|
|
|
(define (get-n-spaces n)
|
|
(cond
|
|
((= n 0) "")
|
|
(else (string-append " " (get-n-spaces (sub1 n))))))
|
|
|
|
(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 "executing main - ")
|
|
(display (,(string->symbol (string-append (cadr (main)) "-main_java.lang.String1")) x)))
|
|
'void)])
|
|
(with-syntax ([main (datum->syntax-object #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)])))
|