104 lines
4.2 KiB
Scheme
104 lines
4.2 KiB
Scheme
(module servlet-language mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "tool.ss" "drscheme")
|
|
;(lib "mred.ss" "mred")
|
|
(lib "unitsig.ss"))
|
|
|
|
(provide tool@)
|
|
|
|
(define tool@
|
|
(unit/sig drscheme:tool-exports^
|
|
(import drscheme:tool^)
|
|
(define (phase1) (void))
|
|
(define (phase2)
|
|
(add-servlet-language))
|
|
|
|
;; add-servlet-language : -> void
|
|
;; adds the servlet language to drscheme
|
|
(define (add-servlet-language)
|
|
(define servlet-language%
|
|
(srvlt-lang-mixin
|
|
((drscheme:language:get-default-mixin)
|
|
(drscheme:language:module-based-language->language-mixin
|
|
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
|
drscheme:language:simple-module-based-language%)))))
|
|
(drscheme:language-configuration:add-language
|
|
(instantiate servlet-language% ())))
|
|
|
|
(define servlet-language<%>
|
|
(interface ()
|
|
))
|
|
|
|
;; srvlt-lang-mixin : (implements drscheme:language:language<%>)
|
|
;; -> (implements drscheme:language:language<%>)
|
|
(define (srvlt-lang-mixin %)
|
|
(class* % (servlet-language<%>)
|
|
|
|
(field [program-results #f])
|
|
|
|
(define/override (on-execute settings run-in-user-thread)
|
|
(set! program-results #f)
|
|
(super on-execute settings run-in-user-thread)
|
|
(run-in-user-thread
|
|
(lambda ()
|
|
(error-display-handler
|
|
(drscheme:debug:make-debug-error-display-handler (error-display-handler)))
|
|
(current-eval
|
|
(drscheme:debug:make-debug-eval-handler (current-eval)))
|
|
(with-handlers ([void (lambda (x) (printf "~a~n" (exn-message x)))])
|
|
(eval '(define start-servlet (dynamic-require '(lib "servlet-startup.ss" "web-server") 'start-servlet)))
|
|
(eval '(define raw-servlet->unit/sig (dynamic-require '(lib "servlet-startup.ss" "web-server") 'raw-servlet->unit/sig)))
|
|
(eval '(define create-module-servlet (dynamic-require '(lib "servlet-startup.ss" "web-server") 'create-module-servlet)))))))
|
|
|
|
(define/override (front-end/complete-program input settings teachpack-cache)
|
|
(let ([super-thunk (super front-end/complete-program input settings teachpack-cache)])
|
|
(unless program-results
|
|
(let loop ([continue-with-results
|
|
(lambda (rslts)
|
|
(set! program-results rslts))]
|
|
[res-cadr #f])
|
|
(let ([res-car (super-thunk)])
|
|
(cond
|
|
;; end of empty definitions window
|
|
[(and (eof-object? res-car)
|
|
(eof-object? res-cadr))
|
|
(continue-with-results '())]
|
|
|
|
;; end of non-empty definitions window
|
|
[(and (eof-object? res-car) res-cadr)
|
|
;(continue-with-results (list #`(ignore-it #,res-cadr)))
|
|
(continue-with-results (list #`(start-servlet
|
|
(raw-servlet->unit/sig #,res-cadr))))
|
|
]
|
|
|
|
;; middle
|
|
[res-cadr
|
|
(loop
|
|
(lambda (rslts)
|
|
(continue-with-results (cons res-cadr rslts)))
|
|
res-car)]
|
|
|
|
;; start of definitions window
|
|
[else
|
|
(loop continue-with-results res-car)])))))
|
|
(lambda ()
|
|
(if (null? program-results)
|
|
eof
|
|
(begin0
|
|
(car program-results)
|
|
(set! program-results (cdr program-results)))))
|
|
)
|
|
|
|
(super-instantiate ()
|
|
(module '(lib "plt-mred.ss" "lang"))
|
|
|
|
;; GregP: when you settle on a name, use string-constant here
|
|
(language-position (list "Web Server" "Advanced Servlet"))
|
|
|
|
;; GregP: figure out what these language-numbers are
|
|
;(language-numbers (list -1000 1000))
|
|
))
|
|
|
|
)))
|
|
)
|