(module custom-drscheme-language mzscheme

  (require (lib "tool.ss" "drscheme")
           (lib "mred.ss" "mred")
           (lib "class.ss")
           (lib "unit.ss")
           (lib "etc.ss")
           (lib "kw.ss")
           (lib "string-constant.ss" "string-constants")
           (only (lib "tool.ss" "macro-debugger") language/macro-stepper<%>))

  (provide custom-language-level^
           custom-language-level@
           top-level->module)

  (define (top-level->module lang-path terms)
    (with-syntax ([name (datum->syntax-object #f (gensym 'program))]
                  [language (datum->syntax-object #f lang-path)]
                  [(body ...) (datum->syntax-object #f terms)]
                  [module-begin (datum->syntax-object #f '#%module-begin)])
      (list
       #`(module name language (module-begin body ...))
       #`(require name)
       #`(current-namespace (module->namespace 'name)))))

  (define-signature custom-language-level^
    (simple-language%
     custom-language-level
     language-level-render-mixin
     language-level-help-desk-mixin
     language-level-capability-mixin
     language-level-eval-as-module-mixin
     language-level-no-executable-mixin))

  (define-syntax (cond-list stx)
    (syntax-case stx ()
      [(cl [test expr] ...)
       (syntax/loc stx
         (let* ([the-list null]
                [the-list (if test (cons expr the-list) the-list)]
                ...)
           (reverse the-list)))]))

  (define-unit custom-language-level@
    (import drscheme:tool^)
    (export custom-language-level^)

    (define/kw (custom-language-level

                ;; Required parameters
                name module

                ;; Optional parameters for the base class
                #:key
                [number (string-length name)]
                [hierarchy experimental-language-hierarchy]
                [summary name]
                [url #f]
                [reader generic-syntax-reader]

                ;; Other language mixins
                #:body mixins
                )

      (let* ([default-mixin (drscheme:language:get-default-mixin)]
             [custom-mixin (apply compose (reverse mixins))])
        (new (custom-mixin (default-mixin simple-language%))
             [module module]
             [language-position (append (map car hierarchy) (list name))]
             [language-numbers (append (map cdr hierarchy) (list number))]
             [one-line-summary summary]
             [language-url url]
             [reader (make-namespace-syntax-reader reader)])))

    (define simple-language%
      (drscheme:language:module-based-language->language-mixin
       (drscheme:language:simple-module-based-language->module-based-language-mixin
        drscheme:language:simple-module-based-language%)))

    (define (language-level-render-mixin to-sexp show-void?)
      (mixin (drscheme:language:language<%>) ()
        (super-new)

        (define/override (render-value/format value settings port width)
          (unless (and (void? value) (not show-void?))
            (super render-value/format (to-sexp value) settings port width)))))

    (define (language-level-help-desk-mixin manuals)
      (mixin (drscheme:language:language<%>) ()
        (super-new)

        (define/override (order-manuals ms)
          (manuals ms))))

    (define (language-level-capability-mixin table)
      (mixin (drscheme:language:language<%>) ()
        (super-new)

        (define/augment (capability-value key)
          (hash-table-get
           table key
           (lambda ()
             (inner (drscheme:language:get-capability-default key)
                    capability-value key))))))

    (define language-level-no-executable-mixin
      (mixin (drscheme:language:language<%>) ()
        (super-new)
        (inherit get-language-name)

        (define/override (create-executable settings parent filename)
          (message-box
           "Create Executable: Error"
           (format "Sorry, ~a does not support creating executables."
                   (get-language-name))
           #f '(ok stop)))))

    (define language-level-eval-as-module-mixin
      (mixin (drscheme:language:language<%>
              drscheme:language:module-based-language<%>) ()
        (super-new)

        (inherit get-reader get-module)

        (define/private (read-all port)
          (let* ([reader (get-reader)]
                 [name (object-name port)])
            (let read-rest ([rev-forms null])
              (let* ([form (reader name port)])
                (if (eof-object? form)
                    (reverse rev-forms)
                    (read-rest (cons form rev-forms)))))))

        (define/override (front-end/complete-program port settings)
          (let* ([terms #f]
                 [program (gensym 'program)])
            (lambda ()
              ;; On the first run through, initialize the list.
              (unless terms
                (set! terms
                      (top-level->module (get-module) (read-all port))))
              ;; Produce each list element in order.
              (if (pair? terms)
                  ;; Produce and remove a list element.
                  (begin0 (car terms) (set! terms (cdr terms)))
                  ;; After null, eof forever.
                  eof))))))

    (define macro-stepper-mixin
      (mixin (drscheme:language:language<%> language/macro-stepper<%>) ()
        (super-new)

        (define/override (enable-macro-stepper?) #t)))

    (define (generic-syntax-reader . args)
      (parameterize ([read-accept-reader #t])
        (apply read-syntax args)))

    (define (make-namespace-syntax-reader reader)
      (lambda args
        (let ([stx (apply reader args)])
          (if (syntax? stx) (namespace-syntax-introduce stx) stx))))

    (define experimental-language-hierarchy
      (list (cons (string-constant experimental-languages)
                  1000)))

   )

  )