;; Kwangkeun Yi, Feb 2000
;; adapted from OCaml 2.04 emacs/caml-font.el

;; useful colors

(cond
 ((and (x-display-color-p)
       (not (memq 'font-lock-type-face (face-list))))
  ; make the necessary faces
  (make-face 'Firebrick)
  (set-face-foreground 'Firebrick "Firebrick")
  (make-face 'RosyBrown)
  (set-face-foreground 'RosyBrown "RosyBrown")
  (make-face 'MidnightBlue)
  (set-face-foreground 'MidnightBlue "MidnightBlue")
  (make-face 'DarkGoldenRod)
  (set-face-foreground 'DarkGoldenRod "DarkGoldenRod")
  ; assign them as standard faces
  (setq font-lock-comment-face 'Firebrick)
  (setq font-lock-string-face 'RosyBrown)
  (setq font-lock-function-name-face 'MidnightBlue)
  (setq font-lock-variable-name-face 'DarkGoldenRod)))

; The same definition is in n.el:
; we don't know in which order they will be loaded.
(defvar n-quote-char "'"
  "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.")

(defconst n-font-lock-keywords
  (list
;comments
   '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)"
     2 font-lock-comment-face)
   '("//[^\n]*" . font-lock-comment-face)
;character literals
   (cons (concat n-quote-char "\\(\\\\\\([ntbr" n-quote-char "\\]\\|"
		 "[0-9][0-9][0-9]\\)\\|.\\)" n-quote-char
		 "\\|\"[^\"\\]*\\(\\\\\\(.\\|\n\\)[^\"\\]*\\)*\"")
	 'font-lock-string-face)
;labels (and open)
   '("\\([?]?\\<[A-Za-z][A-Za-z0-9_']*:\\)\\([^:=]\\|\\'\\|$\\)" 1
     font-lock-variable-name-face)
   '("\\<\\(assert\\|open\\|include\\)\\>\\|[?]?\\<:[A-Za-z][A-Za-z0-9_']*\\>"
     . font-lock-variable-name-face)
;modules and constructors
   '("\\(\\<\\|:\\)\\([A-Z][A-Za-z0-9_']*\\)\\>"
     2 font-lock-function-name-face)
   '("`[A-Za-z][A-Za-z0-9_']*\\>" . font-lock-function-name-face)
;definition
   (cons (concat
	  "\\<\\(a\\(nd\\|s\\)\\|case"
	  "\\|exception\\|f\\(n\\|un\\(ct\\(ion\\|or\\)\\)?\\)"
	  "\\|s\\(tructure\\|ignature\\|haring\\)"
	  "\\|of\\|rec\\|type\\|abstype"
	  "\\|val\\|where\\|local\\|let\\)\\>")
	 'font-lock-type-face)
;blocking
   '("\\(\\<\\|:\\)\\(in\\|do\\|end\\|s\\(ig\\|truct\\)\\|with\\)\\>"
     2 font-lock-variable-name-face)
   
;control
   (cons (concat
	  "\\<\\(if\\|then\\|else"
	  "\\|handle\\|for\\|while\\)\\>"
	  "\\|\|\\|=>")
	 'font-lock-type-face)
   '("\\<raise\\>" . font-lock-comment-face)))

(defconst inferior-n-font-lock-keywords
  (append
   (list
;inferior
    '("^[#-]" . font-lock-comment-face)
;labels
    '("[? \t]:[A-Za-z][A-Za-z0-9_']*\\>" . font-lock-variable-name-face))
   n-font-lock-keywords))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar n-font-cache '((0 . normal))
  "List of (POSITION . STATE) pairs for an N buffer.
The STATE is either `normal', `comment', or `string'.  The POSITION is
immediately after the token that caused the state change.")

(make-variable-buffer-local 'n-font-cache)

(defun n-font-comments-and-strings (limit)
  "Fontify N comments and strings up to LIMIT.
Handles nested comments and N's escapes for breaking a string over lines.
Uses n-font-cache to maintain the fontification state over the buffer."
  (let ((beg (point))
	last class)
    (while (< beg limit)
      (while (and n-font-cache
		  (> (car (car n-font-cache)) beg))
	(setq n-font-cache (cdr n-font-cache)))
      (setq last (car (car n-font-cache)))
      (setq class (cdr (car n-font-cache)))
      (goto-char last)
      (cond
       ((eq class 'normal)
	(cond
	 ((not (re-search-forward "\\((\\*\\)\\|\\(\"\\)" limit t))
	  (goto-char limit))
	 ((match-beginning 1)
	  (setq n-font-cache (cons (cons (point) 'comment) n-font-cache)))
	 ((match-beginning 2)
	  (setq n-font-cache (cons (cons (point) 'string) n-font-cache)))))
       ((eq class 'comment)
	(cond
	 ((let ((nest 1))
	    (while (and (> nest 0)
			(re-search-forward "\\((\\*\\)\\|\\(\\*)\\)" limit t))
	      (cond
	       ((match-beginning 1) (setq nest (+ nest 1)))
	       ((match-beginning 2) (setq nest (- nest 1)))))
	    (> nest 0))
	  (goto-char limit))
	 (t
	  (setq n-font-cache (cons (cons (point) 'normal) n-font-cache))))
	(put-text-property (- last 2) (point) 'face 'font-lock-comment-face))
       ((eq class 'string)
	(while (and (re-search-forward
		     "\\(\"\\)\\|\\(\\\\\\s-*\\\\\\)\\|\\(\\\\\"\\)" limit t)
		     (not (match-beginning 1))))
	(cond
	 ((match-beginning 1)
	  (setq n-font-cache (cons (cons (point) 'normal) n-font-cache)))
	 (t
	  (goto-char limit)))
	(put-text-property (- last 1) (point) 'face 'font-lock-string-face)))
      (setq beg (point)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; font-lock commands are similar for n-mode and inferior-n-mode
(defvar n-font-lock-all nil
  "Font-lock matchers for N.")

(setq n-mode-hook
      '(lambda ()
         (let ((new-font-lock (fboundp 'global-font-lock-mode)))
           (or n-font-lock-all
               (setq n-font-lock-all
                     (append
                      (and new-font-lock
                           (list (list 'n-font-comments-and-strings)))
                      n-font-lock-keywords)))
           (cond
            (new-font-lock
             (make-local-variable 'font-lock-defaults)
             (setq font-lock-defaults '(n-font-lock-all t)))
            (t
             (setq font-lock-keywords n-font-lock-all))))
	 (make-local-variable 'font-lock-keywords-only)
	 (setq font-lock-keywords-only t)
	 (font-lock-mode 1)))

(defvar inferior-n-font-lock-all nil
  "Font-lock matchers for inferior N.")

(setq inferior-n-mode-hook
      '(lambda ()
         (let ((new-font-lock (fboundp 'global-font-lock-mode)))
           (or inferior-n-font-lock-all
               (setq inferior-n-font-lock-all
                     (append
                      (and new-font-lock
                           (list (list 'n-font-comments-and-strings)))
                      inferior-n-font-lock-keywords)))
           (cond
            (new-font-lock
             (make-local-variable 'font-lock-defaults)
             (setq font-lock-defaults '(inferior-n-font-lock-all t)))
            (t
             (setq font-lock-keywords inferior-n-font-lock-all))))
	 (make-local-variable 'font-lock-keywords-only)
	 (setq font-lock-keywords-only t)
	 (font-lock-mode 1)))

(provide 'n-font)


