diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 9ec81d11ad..14e80645ca 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -393,6 +393,14 @@ (not (= open-curlies 0)) is-if?)))) + ;; Mixin to store type information in the repl + (define user-types + (mixin (drscheme:rep:text<%>) () + (define types #f) + (define/public (get-user-types) types) + (define/public (set-user-types t) (set! types t)) + (super-new))) + ;; matches-language : (union #f (listof string)) -> boolean (define (matches-language l) (and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "ProfessorJ"))) @@ -440,6 +448,9 @@ '()))) autocomplete-words] [(eq? s 'drscheme:language-menu-title) (string-constant profj-java)] + [(eq? s 'drscheme:tabify-menu-callback) + (lambda (ed start stop) + (send ed java-tabify-selection))] [(memq s '(profj:special:java-comment-box profj:special:java-examples-box profjWizard:special:java-class @@ -714,38 +725,125 @@ (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 name level) - ,name) #f))))))) - (define/public (front-end/interaction port settings) (mred? #t) (let ([name (object-name port)] - [executed? #f]) + [rep (drscheme:rep:current-rep)] + [eventspace (current-eventspace)] + [execute-types (create-type-record)]) + (let ([name-to-require #f] + [require? #f] + [tests-run? #f] + [tests #f] + [compiled? #f] + [modules null] + [extras null]) (lambda () - (if executed? #;(eof-object? (peek-char-or-special port)) + (syntax-as-top + (let ([end? (eof-object? (peek-char-or-special port))]) + #;(if end? + eof + (datum->syntax #f `(parse-java-full-program ,(parse port name level) + ,name) #f)) + (cond + [(and end? (null? modules) (null? extras) tests-run? (not require?)) eof] + [(not compiled?) + (execution? #t) + (let* ([parsed (parse port name level)] + [compilation-units (compile-ast parsed level execute-types)] + [examples (if (testcase-ext?) + (list (send execute-types get-test-classes) null) + (find-examples compilation-units))]) + #;(printf "ProfJ compilation complete~n") + (set! compiled? #t) + (set! modules (order compilation-units)) + (when rep (send rep set-user-types execute-types)) + (set! extras (process-extras (send execute-types get-interactions-boxes) execute-types)) + (set! tests examples)) + (datum->syntax #f '(void) #f)] + [else + (cond + [(and (not require?) (null? modules) (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)] + [format (lambda (o break?) + (format-java-value o (make-format-style #t 'field break?)))]) + (set! tests-run? #t) + (datum->syntax + #f + `((lambda () + (,namespace-set-variable-value! 'current~test~object% ,tc-info) + (send ,test-engine-obj install-tests + (map (lambda (c) + (list c ([current-eval] (string->symbol c)) c)) + (list ,@(car tests)))) + (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 ,rep ,eventspace) + (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 (car os) #f))) + (when (< 24 (,(lambda (t) (total-length t)) formatted)) + (set! formatted (,format (car os) #t))) + (let loop ((out formatted)) + (unless (null? out) + (write-special (car out)) + (loop (cdr out)))) + (newline)) + (inner-loop (cdr os))))))) + #f))] + [(and (not require?) (null? modules) tests-run?) + (begin0 + (car extras) + (set! extras (cdr extras)))] + [require? + (set! require? #f) + (with-syntax ([name name-to-require]) + (syntax (require (quote name))))] + [else + #;(printf "~a~n" (syntax->datum (car mods))) + (let-values (((name syn) (get-module-name (expand (car modules))))) + (set! name-to-require name) + (set! require? #t) + (set! modules (cdr modules)) + (errortrace-annotate syn))])]))))))) + (define/public (front-end/interaction port settings) + (mred? #t) + (let* ([name (object-name port)] + [executed? #f] + [rep (drscheme:rep:current-rep)] + [types (and rep (or (send rep get-user-types) + (begin + (send rep set-user-types (create-type-record)) + (send rep get-user-types))))]) + (lambda () + (if executed? eof (begin (set! executed? #t) (syntax-as-top - (datum->syntax + (compile-interactions-ast + (parse-interactions port name level) + name level types #t) + + #;(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))))))) + `(parse-java-interactions ,(parse-interactions port name level) ,name) + #f))))))) (define (get-defn-editor port-name) (let* ([dr-frame (and (drscheme:rep:current-rep) @@ -922,11 +1020,11 @@ (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)))) + #;(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) + #;((parse-java-full-program ex s) (let ((exp (old-current-eval (syntax ex))) (src (old-current-eval (syntax (quote s))))) (execution? #t) @@ -996,9 +1094,8 @@ #;(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))) + (syntax-as-top (old-current-eval + (errortrace-annotate syn))) (loop (cdr mods) extras #t))))))))) ((parse-java-interactions ex loc) (let ((exp (syntax->datum (syntax ex)))) @@ -1320,6 +1417,7 @@ (drscheme:get/extend:extend-definitions-text indent-mixin) (drscheme:get/extend:extend-interactions-text indent-mixin) + (drscheme:get/extend:extend-interactions-text user-types) (drscheme:get/extend:extend-unit-frame java-interactions-box-mixin) (drscheme:language:register-capability 'profj:special:java-interactions-box (flat-contract boolean?) #t)