(module tool mzscheme
  (require (planet "file.ss" ("dherman" "io.plt" 1 6))
           (lib "file.ss")
           (lib "framework.ss" "framework")
           (lib "tool.ss" "drscheme")
           (lib "match.ss")
           (lib "mred.ss" "mred")
           (lib "unitsig.ss")
           (lib "class.ss")
	   (lib "string-constant.ss" "string-constants")
           (lib "etc.ss")
           "syntax/parse.ss"
           "compiler/compile.ss"
           (all-except "runtime/runtime.ss" object?)
           "exn.ss"
           "syntax-color.ss")

  (define (this-module-matches-collect-path? collection-name . rest)
    (with-handlers ([exn? (lambda (exn) #f)])
      (path=? (normalize-path (this-expression-source-directory))
              (normalize-path (apply build-path (collection-path collection-name) rest)))))

  (define (require-spec module-name . path)
    (if (this-module-matches-collect-path? "javascript")
        (apply require-spec/collect module-name path)
        (apply require-spec/planet module-name path)))

  (define (require-spec/collect module-name . path)
    `(lib ,module-name "javascript" ,@path))

  (define (require-spec/planet module-name . path)
    (let* ([this-dir (this-expression-source-directory)]
           [major-version (string->number (path->string (basename (dirname this-dir))))]
           [minor-version (string->number (path->string (basename this-dir)))])
      `(planet ,module-name ("dherman" "javascript.plt" ,major-version ,minor-version) ,@path)))

  (define tool@
    (unit/sig drscheme:tool-exports^
      (import drscheme:tool^)

      (define (phase1) (void))
      (define (phase2) 
        (drscheme:language-configuration:add-language
         (make-object ((drscheme:language:get-default-mixin) (javascript-lang-mixin 'ecmascript)))))

      (define (javascript-lang-mixin level)
        (class* object% (drscheme:language:language<%>)
          (define/public (first-opened) (void))
          (define/public (get-comment-character) (values "//" #\*))
          (define/public (default-settings) null)
          (define/public (default-settings? settings) #t)
          (define/public (marshall-settings s) null)
          (define/public (unmarshall-settings s) null)
          (define/public (config-panel parent)
            (case-lambda
              [() null]
              [(settings) (void)]))
          (define/public (front-end/complete-program port settings teachpack-cache)
            (lambda ()
              (if (eof-object? (peek-char-or-special port))
                  eof
                  (compile-script
                   (with-syntax-errors (lambda () (parse-script port)))))))
          (define/public (front-end/interaction port settings teachpack-cache)
            (lambda ()
              (if (eof-object? (peek-char-or-special port))
                  eof
                  (compile-interaction
                   (with-syntax-errors (lambda () (parse-script port)))))))
          (define/public (get-style-delta) #f)
          (define/public (get-language-position)
            (list (string-constant experimental-languages)
                  "JavaScript"))
          ;; TODO: this is copied from honu -- is it right?
          (define/public (order-manuals x)
            (values
             (list #"drscheme" #"tour" #"help")
             #f))
          (define/public (get-language-name) "JavaScript")
          (define/public (get-language-url) "http://www.ecma-international.org/publications/standards/Ecma-262.htm")
          (define/public (get-language-numbers) (list 1000 12))
          (define/public (get-teachpack-names) null)
          (define/public (on-execute settings run-in-user-thread)
            (let ([module-forms (require-spec "module-forms.ss")]
                  [runtime (require-spec "runtime.ss" "runtime")])
              (print-struct #t)
              (dynamic-require module-forms #f)
              (dynamic-require runtime #f)
              (let ([path1 ((current-module-name-resolver) module-forms #f #f)]
                    [path2 ((current-module-name-resolver) runtime #f #f)]
                    [n (current-namespace)])
                (run-in-user-thread
                 (lambda ()
                   (let ([previous-error-display-handler
                          (drscheme:debug:make-debug-error-display-handler
                           (error-display-handler))])
                     (error-display-handler
                      (lambda (msg exn)
                        (if (exn:fail:javascript:runtime? exn)
                            (let* ([value (exn:fail:javascript:runtime-value exn)]
                                   [msg (format "uncaught exception: ~a" (value->string value))])
                              (previous-error-display-handler msg exn))
                            (previous-error-display-handler msg exn)))))
                   (let ([previous-eval (drscheme:debug:make-debug-eval-handler (current-eval))])
                     (current-eval
                      (lambda (exp)
                        (previous-eval (if (syntax? exp)
                                           (namespace-syntax-introduce exp)
                                           exp)))))
                   (namespace-attach-module n path1)
                   (namespace-require path1)
                   (namespace-attach-module n path2)
                   (initialize-runtime!)
                   (push-completion-context!)
                   )))))
          (define/public (render-value value settings port)
            (display (completion->string value) port))
          (define/public (render-value/format value settings port width)
            (display (completion->string value) port))
          (define/public (create-executable settings parent src-file teachpacks)
            (message-box "Unsupported"
                         "Sorry - executables are not supported for JavaScript at this time"
                         parent))
          (define/public (get-one-line-summary) "ECMA-262 Edition 3 (JavaScript)")

          (super-make-object)))

      ;; 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 "javascript:syntax-coloring:scheme:~a" sym))

      ;; TODO: fix the taxonomy a little

      ;; JavaScript editing colors
      (define color-prefs-table
        `((keyword     ,(make-object color% "purple")      "keyword")
          (parenthesis ,(make-object color% 132 60 36)     "parenthesis")
          (string      ,(make-object color% "forestgreen") "string")
          (literal     ,(make-object color% "forestgreen") "literal")
          (comment     ,(make-object color% 194 116 31)    "comment")
          (error       ,(make-object color% "red")         "error")
          (identifier  ,(make-object color% 38 38 128)     "identifer")
          (default     ,(make-object color% "black")       "default")))

      ;; extend-preferences-panel : vertical-panel -> void
      ;; adds in the configuration for the Honu 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))

      ;; JavaScript 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)))

      (define (matches-language? l)
        (match l
          [(_ "JavaScript" . _) #t]
          [_ #f]))

      (define (delimiter-pair? x y)
        (or (and (char=? x #\() (char=? y #\)))
            (and (char=? x #\[) (char=? y #\]))
            (and (char=? x #\{) (char=? y #\}))))

      ;; repl-submit? : drscheme:rep:text<%> nat -> boolean
      (define (repl-submit? text prompt-position)
        (let loop ([i prompt-position]
                   [blank? #t]
                   [string-char #f]
                   [delimiter-stack null])
          (let ([c (send text get-character i)])
            (case c
              [(#\nul)
               (and (not blank?)
                    (not string-char)
                    (null? delimiter-stack))]
              [(#\( #\[ #\{)
               (if string-char
                   (loop (add1 i) #f string-char delimiter-stack)
                   (loop (add1 i) #f #f (cons c delimiter-stack)))]
              [(#\) #\] #\})
               (cond
                 [string-char
                  (loop (add1 i) #f string-char delimiter-stack)]
                 [(and (pair? delimiter-stack)
                       (delimiter-pair? (car delimiter-stack) c))
                  (loop (add1 i) #f #f (cdr delimiter-stack))]
                 [else
                  (loop (add1 i) #f #f delimiter-stack)])]
              [(#\' #\")
               (cond
                 [(and string-char (char=? c string-char))
                  (loop (add1 i) #f #f delimiter-stack)]
                 [string-char
                  (loop (add1 i) #f string-char delimiter-stack)]
                 [else
                  (loop (add1 i) #f c delimiter-stack)])]
              [(#\\)
               (if string-char
                   (loop (+ i 2) #f #f string-char delimiter-stack)
                   (loop (add1 i) #f #f string-char delimiter-stack))]
              [else
               (loop (add1 i)
                     (and blank? (char-whitespace? c))
                     string-char
                     delimiter-stack)]))))

      ;; Wire up to DrScheme.

      (drscheme:modes:add-mode "JavaScript mode" mode-surrogate repl-submit? matches-language?)
      (color-prefs:add-to-preferences-panel "JavaScript" 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)))

  (provide tool@))