(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)])))