(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")
           "parser.scm"
           "syntax-coloring.scm"
           ;"syntax/parse.ss"
           ;"compiler/compile.ss"
           ;(all-except "runtime/runtime.ss" object?)
           ;"exn.ss"
           )
  
  (define tool@
    (unit/sig drscheme:tool-exports^
      (import drscheme:tool^)
      ;;;
      ;;; PHASE 1
      ;;;
            
      ; Phase1 is called after all tools have been loaded by DrScheme.
      ; Phase 1 functions are drscheme:language:extend-language-interface
      ; and drscheme:unit:add-to-program-editor-mixin.
      
      (define (phase1) (void)) 
      
      ;;;
      ;;; PHASE 2
      ;;;
      
      ; Phase 2 functions are
      ;   - drscheme:language-configuration:add-language
      ;   - drscheme:language:get-default-mixin
      ;   - drscheme:language:get-language-extensions
      
      (define (phase2) 
        (drscheme:language-configuration:add-language
         (make-object ((drscheme:language:get-default-mixin) 
                       (stylesheet-lang-mixin 'stylesheet)))))

      (define (stylesheet-lang-mixin level)
        (class* object% (drscheme:language:language<%>)
          
          ; config-panel
          ;   This method used by the language configuration dialog to construct
          ;   the "details" panel for this language. It accepts a parent panel and
          ;   returns a get/set function that either updates the GUI to the argument
          ;   or returns the settings for the current GUI.
          (define/public (config-panel parent)
            (case-lambda
              [() null]
              [(settings) (void)]))
          ; create-executable
          ;   This method creates an executable in the given language. The program-filename
          ;   is the name of the program to store in the executable and executable-filename
          ;   is the name of a file where the executable goes.
          (define/public (create-executable settings parent src-file teachpacks)
            (message-box "Unsupported"
                         "Cascading Style Sheets are static text files."
                         parent))
          ; default-settings
          ;     Specifies the default settings for this language.
          (define/public (default-settings) null)
          ; default-settings?
          ;   Return #t if the input settings matches the default settings obtained via default-settings.
          (define/public (default-settings? settings) #t)
          ; first-opened
          ;   This method is called when the language is initialized, but no
          ;   program is run. It is called from the user's eventspace's main thread.
          (define/public (first-opened) (void))
          ; front-end/complete-program
          ;   the front-end/complete-program method  reads, parses, and optionally compiles
          ;   a program in the language. The first argument contains all of the data to be
          ;   read (until eof) and the second argument is a value representing the source
          ;   of the program (typically an editor, but may also be a string naming a file
          ;   or some other value).
          ;       The third argument is the current settings for the language. The
          ;   front-end/complete-program method is expected to return a thunk that is called
          ;   repeatedly to get all of the expressions in the program. When all expressions
          ;   have been read, the thunk is expected to return eof.
          ;       This method is only called for programs in the definitions window. Notably, it
          ;   is not called for programs that are loaded or evaled. See current-load and
          ;   current-eval for those.
          ;       This method is expected to raise an appropriate exception if the program is
          ;   malformed, eg an exn:syntax or exn:read.
          ;       This is called on the user's thread, as is the thunk it returns.
          ;       Implementations of this method should not return fully expanded expressions, since
          ;   there are two forms of expansion, using either expand or expand-top-level-with-compile-time-evals
          ;   and the use of the expanded code dictates which applies.
          (define/public (front-end/complete-program port settings teachpack-cache)
            (front-end port settings))
          
          (define/private (front-end port settings)
            (let ([name (object-name port)])
              (lambda ()
                (if (eof-object? (peek-char port))
                    eof
		    #`'#,(parse-css-port port name)))))
          ; front-end/interaction
          ;   This method is just like front-end/complete-program except that it is called
          ;   with program fragments, for example the expressions entered in the interactions
          ;   window. It is also used in other contexts by tools to expand single expressions.
          (define/public (front-end/interaction port settings teachpack-cache)
            (front-end port settings))
          ; get-comment-character
          ;   Returns text to be used for the ``Insert Large Letters'' menu item in DrScheme.
          ;   The first result is a prefix to be placed at the beginning of each line and the
          ;   second result is a character to be used for each pixel in the letters. 
          (define/public (get-comment-character) 
            (values))  ; disable
          ; get-language-name
          ;   Returns the name of the language as shown in the REPL when executing
          ;   programs in the language. 
          (define/public (get-language-name) 
            "Stylesheet")
          ; get-language-numbers
          ;   This method is used in a manner analogous to get-language-position.
          ;   Each element in the list indicates how the names at that point in dialog will
          ;   be sorted. Names with lower numbers appear first. If two languages are added to
          ;   DrScheme with the same strings (as given by the get-language-position method)
          ;   the corresponding numbers returned by this method must be the same.
          (define/public (get-language-numbers)
            (list 1000 12)) ; TODO: check numbers
          ; get-language-position
          ;   This method returns a list of strings that is used to organize this language
          ;   with the other languages. Each entry in that list is a category or subcategory of
          ;   the language and the last entry in the list is the name of the language itself. In
          ;   the language dialog, each element in the list except for the last will be a nested
          ;   turn down triangle on the left of the dialog. The final entry will be the name that
          ;   the user can choose to select this language. Names that are the same will be combined
          ;   into the same turndown entry. [See example in HelpDesk manual]
          (define/public (get-language-position)
            (list (string-constant experimental-languages)
                  "Stylesheet"))
          ; get-language-url
          ;   Returns a url for the language.
          (define/public (get-language-url)
            "http://http://www.w3.org/TR/CSS21/cover.html")
          ; get-oneline-summary
          ;    The result of this method is shown in the language dialog when the user
          ;    selects this language.
          (define/public (get-one-line-summary) 
            "CSS 2.1 (Cascading Style Sheets)")
          ; get-style-delta
          ;   The style delta that this method returns is used in the language dialog and the
          ;   DrScheme REPL when the language's name is printed.
          ;       When it is #f, no styling is used.
          ;       If the result is a list, each element is expected to be a list of three items,
          ;   a style-delta, and two numbers. The style delta will be applied to the corresponding
          ;   portion of the name.
          (define/public (get-style-delta) 
            #f)
          ; marshall-settings
          ;    Translates an instance of the settings type into a scheme object that can
          ;  be written out to disk.
          (define/public (marshall-settings s) null)
          ; unmarshall-settings
          ;   Translates a Scheme value into a settings, returning #f if that is not possible.
          (define/public (unmarshall-settings s) null)
          ; on-execute
          ;   The on-execute method is called on DrScheme's eventspace's main thread before any
          ;   evaluation happens during execution. Use this method to initialize MzScheme's parameters
          ;   for the user. [See more in the HelpDesk manual]
          (define/public (on-execute settings run-in-user-thread)
            ; (read-case-sensitive #f)
            (run-in-user-thread 
             (lambda () 
               (error-display-handler 
                (drscheme:debug:make-debug-error-display-handler (error-display-handler)))
               (error-print-source-location #t)
               (void))))
          ; order-manuals
          ;   Returns a sublist of its input, that specifies the manuals (and their order) to
          ;   search in. The boolean result indicates if doc.txt files should be searched.
          (define/public (order-manuals x)
            (values
             (list #"drscheme" #"tour" #"help")
             #t))
          ; render-value
          ;   This method is just like render-value/format except that it is expected to
          ;   put the entire value on a single line with no newline after the value.
          (define/public (render-value value settings port)
            (display value port))
          ; render-value/format
          ;   This method is used to print values into a port, for display to a user.
          ;   The final argument is a maximum width to use (in characters) when formatting
          ;   the value.
          ;       This method is expected to format the value by inserting newlines in appropriate
          ;   places and is expected to render a newline after the value.
          (define/public (render-value/format value settings port width)
            (display value port))
          
          
          ; ???
          (define/public (get-teachpack-names) null)
          
          (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 "stylesheet:syntax-coloring:scheme:~a" sym))

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

      ;; Stylesheet 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
          [(_ "Stylesheet" . _) #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 "Stylesheet mode" mode-surrogate repl-submit? matches-language?)
      (color-prefs:add-to-preferences-panel "Stylesheet" 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@))