;;; 
;;; Copyright (c) 1997 Massachusetts Institute of Technology
;;;

;;; Author: patl

(require 'compile)

(define-derived-mode curl-mode lisp-mode "Curl"
  "Major mode for editing Curl code."

  ;; Curlys need to balance...
  (modify-syntax-entry ?{ "(}  " curl-mode-syntax-table)
  (modify-syntax-entry ?} "){  " curl-mode-syntax-table)

  ;; ...parens do not
  (modify-syntax-entry ?\( "_   " curl-mode-syntax-table)
  (modify-syntax-entry ?\) "_   " curl-mode-syntax-table)

  ;; Vertical bars start comments...
  (modify-syntax-entry ?\| "< 23b" curl-mode-syntax-table)
  (modify-syntax-entry ?# "' 14" curl-mode-syntax-table)

  ;; ...semicolons do not
  (modify-syntax-entry ?\; "_   " curl-mode-syntax-table)

  ;; Colon and equals are separators
  (modify-syntax-entry ?: ".   " curl-mode-syntax-table)
  (modify-syntax-entry ?= ".   " curl-mode-syntax-table)
  
  ;; How comments work
  (setq comment-start "|")
  (setq comment-start-skip
	"\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(|+\\|#|\\) *")

  ;; Trick lisp mode into using our definitions
  (make-local-variable 'lisp-indent-function)
  (setq lisp-indent-function 'curl-indent-function)
  (setq indent-region-function nil)

  (setq fill-paragraph-function nil)	; for now...

  ;; Font-lock stuff
  (make-local-variable 'font-lock-defaults)
  (setq font-lock-defaults curl-font-lock-defaults)

  ;; Make "C-x `" work
  (if (not (assoc (car curl-compilation-error-regexp)
		  compilation-error-regexp-alist))
      (progn
	(setq compilation-error-regexp-alist
	      (cons curl-compilation-error-regexp
		    compilation-error-regexp-alist))))

  (define-key curl-mode-map "\C-c\C-c" 'comment-region)
  )

(defvar curl-compilation-error-regexp
  '("^/local/\\(.*\\):\\([0-9]+\\)\r?$" 1 2)
  "Element to be added to compilation-error-regexp-alist for Curl mode.")

(defvar curl-user-specform-alist nil)

(defvar curl-internal-specform-alist
  '(("letrec" . curl-let-indent)
    ("let" . curl-let-indent)
    ("loop" . curl-let-indent)

    ("lambda" . defun)

    ("call-with-input-file" . 1)
    ("with-input-from-file" . 1)
    ("with-input-from-port" . 1)
    ("call-with-output-file" . 1)
    ("with-output-to-file" . 1)
    ("with-output-to-port" . 1)

    ("if" . nil)
    ("when" . 1)
    ("until" . 1)
    ("unless" . 1)
    ("while" . 1)
    ("dotimes" . 1)

    ("invoke-method" . 3)

    ("cond" . nil)
    ("return" . nil)
    ("error" . nil)
    ("breakpoint" . nil)
    ("backtrace" . nil)
    ))

(defvar curl-specform-alist
  (append curl-internal-specform-alist curl-user-specform-alist))

(defvar curl-font-lock-defaults
  `(curl-font-lock-keywords
    nil		; do fontify strings and comments
    nil		; case is significant
    ,(mapcar (function (lambda (c) (cons c "w")))
	     "+-*/.<>!?$%_&~^;") ; make these word syntax for font-lock
    beginning-of-defun
    ))

(defconst curl-font-lock-keywords-1
  (list
   (list
    (concat
     "{\\(define\\("
     "\\(-class\\|-mixin-class\\|-sterile-class\\)\\|"
     "\\(-constant\\|-variable\\)\\|"
;     "\\([ \t\{]\\|-form-reader\\|-form\\|-macro\\|-external\\|-syntax\\|-method\\)\\)\\)"
     "\\([ \t\{]\\|-[^ \t\{]*\\)\\)\\)"
     "[ \t\{]*"
     "\\(\\sw+\\)?")
    '(1 font-lock-keyword-face)
    '(6 (cond ((match-beginning 3) font-lock-type-face)
	      ((match-beginning 4) font-lock-variable-name-face)
	      ((match-beginning 5) font-lock-function-name-face))
	nil t)))
  "Minimal fontification for Curl code.")

(defconst curl-font-lock-keywords-2
  (append
   curl-font-lock-keywords-1
   (list
    (list (concat "{\\(" (mapconcat 'car curl-specform-alist "\\|") "\\)")
	  '(1 font-lock-keyword-face nil t))
    '("\\(\\sw+\\)?:\\(\\sw+\\)"
      (1 font-lock-variable-name-face nil t)
;      (2 font-lock-type-face nil t)
      )
    ))
  "Gaudy fontification for Curl code")

(defvar curl-font-lock-keywords curl-font-lock-keywords-2
  "Default fontification for Curl code")

;; This is a copy of lisp-indent-function modified to use
;; curl-specform-obarray and to recogize "define-foo" forms.

(defun curl-indent-function (indent-point state)
  (let ((normal-indent (current-column)))
    (goto-char (1+ (elt state 1)))
    (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t)
    (if (and (elt state 2)
             (not (looking-at "\\sw\\|\\s_")))
        ;; car of form doesn't seem to be a a symbol
        (progn
          (if (not (> (save-excursion (forward-line 1) (point))
                      calculate-lisp-indent-last-sexp))
              (progn (goto-char calculate-lisp-indent-last-sexp)
                     (beginning-of-line)
                     (parse-partial-sexp (point)
					 calculate-lisp-indent-last-sexp 0 t)))
          ;; Indent under the list or under the first sexp on the same
          ;; line as calculate-lisp-indent-last-sexp.  Note that first
          ;; thing on that line has to be complete sexp since we are
          ;; inside the innermost containing sexp.
          (backward-prefix-chars)
          (current-column))
      (let ((function (buffer-substring (point)
					(progn (forward-sexp 1) (point))))
	    method)
	(setq method
	      (symbol-value (intern-soft function curl-specform-obarray)))
	(cond ((or (eq method 'defun)
		   (and (null method)
			(string-match "\\`define" function)))
	       (curl-indent-defform state indent-point))
	      ((integerp method)
	       (lisp-indent-specform method state
				     indent-point normal-indent))
	      (method
	       (funcall method state indent-point)))))))

(defun curl-indent-defform (state indent-point)
  (goto-char (elt state 1))
  (+ lisp-body-indent (current-column)))

;; Deal with Curl's funny "let"

(defun curl-let-indent (state indent-point)
  (let (containing-form-column)
    (save-excursion
      (goto-char (elt state 1))
      (setq containing-form-column (current-column))
      (goto-char indent-point)
      (skip-syntax-forward " ")
      (if (looking-at "|\\|{")
	  (+ lisp-body-indent containing-form-column)
	(list normal-indent)
	))))

(defvar curl-specform-obarray (make-vector 37 0)
  "Hash table mapping Curl special forms to their indentation styles")

(mapcar
 (function (lambda (c) (set (intern (car c) curl-specform-obarray)
			    (cdr c))))
 curl-specform-alist)

(provide 'curl)