(module core mzscheme
  
  (require (lib "contract.ss")
           (lib "pretty.ss")
           (lib "servlet.ss" "web-server"))
  
  (require (planet "syntax/ast.ss" ("dherman" "javascript.plt" 5))
           (planet "test.ss" ("schematics" "schemeunit.plt" 2))
           (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
  
  (require (file "javascript/javascript.ss")
           (file "json/json.ss")
           (file "base.ss"))
  
  ; In the following type definitions:
  ;   embed-url : (request -> response) -> string
  
  ;; test/delirium : request test (test -> any) -> response
  (define (test/delirium request test test/ui)
    (test/ui test)
    (make-stop-response))
  
  ; Responders -----------------------------------
  
  ;; respond/expr : (embed-url -> javascript-expression) -> string
  (define (respond/expr generate-expr)
    (respond/stmt
     (lambda (embed-url)
       ; k-url : string
       (define k-url
         (embed-url (lambda (request) request)))
       (js:stmt (ignore ((dot Delirium sendResult) ,k-url #,(generate-expr embed-url)))))))
  
  ;; respond/stmt : (embed-url -> javascript-statement) -> string
  (define (respond/stmt generate-stmt)
    ; command : string
    (define command #f)
    (parse-result
     (request-bindings
      (send/suspend/dispatch 
       (lambda (embed-url)
         ; k-url : string
         (define k-url
           (embed-url (lambda (request) request)))
         (set! command (js (ignore ((lambda ()
                                      (try (begin #,(generate-stmt embed-url))
                                           (catch exn (begin (ignore ((dot Delirium sendExn) ,k-url exn))))))))))
         (make-response (list command)))))
     command))

  ;; make-stop-response : -> void
  (define (make-stop-response)
    (make-response 
     (list (js (ignore ((lambda ()
                          (ignore ((dot Delirium stop))))))))))
  
  ;; make-response : (list-of string) -> response
  (define (make-response content)
    (make-response/full
     200 
     "Okay"
     (current-milliseconds)
     #"text/javascript"
     null
     content))
  
  ; Parsing results ------------------------------
  
  ;; parse-result : request-environment string -> any
  (define (parse-result bindings command)
    ; type : (U 'exn 'json)
    (define type
      (if (exists-binding? 'type bindings)
          (string->symbol (extract-binding/single 'type bindings))
          (raise-exn exn:fail:delirium "No return type received.")))
    ; Procedure body:
    (case type
      [(result) (parse-json-result bindings)]
      [(exn)    (raise-exn exn:fail:delirium:browser
                  (pretty-format (list "Browser raised exception: "
                                       (parse-json-result bindings)))
                  command)]
      [else     (raise-exn exn:fail:delirium:browser
                  (format "Unknown result type: ~s" type)
                  command)]))
  
  ;; parse-json-result : request-environment -> (U json-as-scheme void)
  (define (parse-json-result bindings)
    (if (exists-binding? 'json bindings)
        (let* ([json/string (extract-binding/single 'json bindings)]
               [json/scheme (json-read (open-input-string json/string))])
          json/scheme)
        (void)))
  
  ; Contracts ------------------------------------
  
  ;; javascript-expression? : -> boolean
  (define javascript-expression? Expression?)
  
  ;; javascript-statement? : -> boolean
  (define javascript-statement? Statement?)
  
  ;; test/c : contract
  (define (schemeunit-test? item)
    (or (schemeunit-test-case? item)
        (schemeunit-test-suite? item)))

  ; Provide statements ---------------------------
  
  (provide (all-from (lib "servlet.ss" "web-server")))
  
  (provide (all-from (file "javascript/javascript.ss")))
  
  (provide schemeunit-test?
           javascript-expression?
           javascript-statement?)
  
  (provide/contract
   [test/delirium   (-> request? schemeunit-test? (-> schemeunit-test? any) response?)]
   [respond/expr    (-> (-> procedure? javascript-expression?) any)]
   [respond/stmt    (-> (-> procedure? javascript-statement?) any)])
  
  )