[MLton] Simple emacs mode for editing mlb files.

[Stephen Weeks]

> I cut 'n pasted together an emacs mlb-mode to edit mlb files from
> the standard sml-mode.el file.

Thanks Ray.

I've been using (my own variant of) sml-mode for editing mlb files,
which has worked pretty well, since they use the same lexical
structure and almost the same keywords.  I think it's nice to use the
same mode for both, which makes the same commands available as well --
I have commands for running MLton, saving sml files, etc.  My guess is
a single mode may be an easier way to go.

In case we need it in the future, here's Ray's mlb.el for the
archives.

--------------------------------------------------------------------------------

;;; Simple mode for MLton's MLB files.
;;; Version: 0.1 
;;; Date: 9/12/04
;;; Author: Ray Racine with major cut and based from standard SML el files.
;;; See: SML mode el files found in Emacs/XEmacs and SML distros to see those
;;;      who did the real coding.

;;; This is my first attempt at doing anything in elisp/emacs.  All caveats apply 10x.

;;; Installation: 
;;;  - byte compile mlb.el
;;;  - copy mlb.el and mlb.elc into your emacs load-path
;;;    the same location where your SML mode el/elc files should work.
;;;  - add the following 2 s-exps to your .emacs
;;;    (add-to-list 'auto-mode-alist '("\\.mlb\\'" . mlb-mode))
;;;    (autoload (quote mlb-mode) "mlb" "\
;;;     Major mode for editing MLB (MLton build files for SML).
;;;     Entry to this mode runs the mlb-mode-hook." t nil)
 
;;; Patches,comments,fixes welcome. rracine ATTHISHOSTISFINE adelphia DOTGOESHERE net


(eval-when-compile (require 'cl))

;;==================================================================
;;; Variables 
;;==================================================================
(defcustom mlb-indent-level 4
  "*Indentation of blocks."
  :group 'mlb
  :type '(integer))

(defcustom mlb-mode-info "mlb-mode"
  "*TBD")

(defvar mlb-mode-hook nil
  "*Run upon entering `mlb-mode'.
This is a good place to put your preferred key bindings.")

;;======
;; DEFS
;;======

;; flatten nested lists
(defun flatten (ls &optional acc)
  (if (null ls) acc
    (let ((rest (flatten (cdr ls) acc))
	  (head (car ls)))
      (if (listp head)
	  (flatten head rest)
	(cons head rest)))))

;; Build word matching regexps
(defun mlb-syms-re (&rest syms)
  (concat "\\<" (regexp-opt (flatten syms) t) "\\>"))

(defconst mlb-start-block-syms
  '("local" "in" "bas")
  "MLB symbols which indicate the start of a block.")

(defconst mlb-open-syms
  `,(append '("structure" "signature" "functor" "basis") mlb-start-block-syms)
  "MLB symbols which open")

(defconst mlb-close-syms
  '("end" "in")
  "MLB symbols which indicate the end of a block.")

(defconst mlb-open-syms-re
  (apply 'mlb-syms-re (append mlb-open-syms mlb-close-syms))
  "Regexp to match start of a mlb statement.")

(defconst mlb-all-syms
  `,(append mlb-open-syms mlb-close-syms))

(defconst mlb-all-syms-re
  (apply 'mlb-syms-re mlb-all-syms))

;;==================================================================
;;; Code for MLB-MODE
;;==================================================================


(defface font-lock-module-def-face
  '((t (:bold t)))
  "Font Lock mode face used to highlight module definitions."
  :group 'font-lock-highlighting-faces)
(defvar font-lock-module-def-face 'font-lock-module-def-face
  "Face name to use for module definitions.")

(defface font-lock-interface-def-face
  '((t (:bold t)))
  "Font Lock mode face used to highlight interface definitions."
  :group 'font-lock-highlighting-faces)
(defvar font-lock-interface-def-face 'font-lock-interface-def-face
  "Face name to use for interface definitions.")

(defconst mlb-keywords-regexp
  (mlb-syms-re "basis" "bas" "local" "end" "in")
  "Regexps that match mlb keywords.")

(defconst mlb-font-lock-keywords
  `(("\\<\\(structure\\|functor\\|basis\\)\\s-+\\(\\sw+\\)"
     (1 font-lock-keyword-face)
     (2 font-lock-module-def-face))
    ("\\<\\(signature\\)\\s-+\\(\\sw+\\)"
     (1 font-lock-keyword-face)
     (2 font-lock-interface-def-face))    
    (,mlb-keywords-regexp . font-lock-keyword-face))
  "Regexps matching mlb and sml keyworks used by mlb files.")

(defconst mlb-extended-chars-for-fontification
  '((?_ . "w")(?' . "w"))
  "Underscore and quote are fontifiable chars in a word.")

(defconst mlb-font-lock-defaults
  `(mlb-font-lock-keywords nil nil ,mlb-extended-chars-for-fontification nil))

;;============================
;; Indentation & Move routines
;;============================

(defun mlb-keyword-forward ()
  (interactive)
  (when (re-search-forward mlb-all-syms-re nil t)
    (mlb-backward-read-sym)))

(defun mlb-keyword-backward ()
  (interactive)
  (when (re-search-backward mlb-all-syms-re nil t)
    (mlb-move-read-sym)))

(defun mlb-stmt-sym-backwards ()
  (interactive)
  (when (re-search-backward mlb-open-syms-re nil t)
    (mlb-move-read-sym)))

(defun mlb-stmt-sym-forwards ()
  (interactive)
  (when (re-search-forward mlb-open-syms-re nil t)
    (mlb-backward-read-sym)))

(defun goto-beginning-of-line-text ()
  (beginning-of-line)
  (skip-syntax-forward "-"))

(defun indent-1 (dent)
  (+ dent mlb-indent-level))

(defun outdent-1 (dent)
  (let ((newdent (- dent mlb-indent-level)))
    (if (< newdent 0)
	0
      newdent)))

(defun mlb-calculate-indent ()
  (interactive)
  (save-excursion
    (goto-beginning-of-line-text)    
    (let ((curr-stmt-sym (mlb-move-read-sym))
	  (curr-stmt-indent (current-indentation)))
      (beginning-of-line)
      (let ((prev-stmt-sym (mlb-stmt-sym-backwards))
	    (prev-stmt-indent (current-indentation)))
;;	(message "Prev: %s" prev-stmt-sym)
;;	(message "Curr: %s" curr-stmt-sym)
	(cond 
	 ((member prev-stmt-sym mlb-start-block-syms)
	  (cond 
	   ((member curr-stmt-sym mlb-close-syms)
	    prev-stmt-indent)
	   ((member curr-stmt-sym mlb-start-block-syms)
	    (indent-1 prev-stmt-indent))
	   (t (indent-1 prev-stmt-indent))))
	  
	 ((member prev-stmt-sym mlb-close-syms)
	  (cond ((member curr-stmt-sym mlb-close-syms)
		 (outdent-1 prev-stmt-indent))
		((member curr-stmt-sym mlb-start-block-syms)
		 prev-stmt-indent)
		(t prev-stmt-indent)))
	 
	 ((member curr-stmt-sym mlb-close-syms)
	  (outdent-1 prev-stmt-indent))
	 
	 (t prev-stmt-indent))))))

(defun mlb-move-read-sym ()
  (interactive)
  (let ((p0 (point)))
    (mlb-forward-sym)
    (when (/= (point) p0)
      (buffer-substring-no-properties (point) p0))))

(defun mlb-forward-sym ()
  (interactive)
  (or (/= 0 (skip-syntax-forward "'w_"))
      (/= 0 (skip-syntax-forward ".'"))))

(defun mlb-backward-read-sym ()
  (interactive)
  (let ((p0 (point)))
    (mlb-backward-sym)
    (when (/= (point) p0)
      (buffer-substring-no-properties p0 (point)))))

(defun mlb-backward-sym ()
  (interactive)
  (or (/= 0 (skip-syntax-backward ".'"))
      (/= 0 (skip-syntax-backward "'w_"))))

(defun mlb-back-to-outer-indent ()
  "Unindents to the next outer level of indentation."
  (interactive)
  (save-excursion
    (beginning-of-line)
    (skip-chars-forward "\t ")
    (let ((start-column (current-column))
	  (indent (current-column)))
      (if (> start-column 0)
	  (progn
	    (save-excursion
	      (while (>= indent start-column)
		(if (re-search-backward "^[^\n]" nil t)
		    (setq indent (current-indentation))
		  (setq indent 0))))
	    (backward-delete-char-untabify (- start-column indent)))))))

(defun mlb-indent-line ()
  "Indent current MLB line of code."
  (interactive)
  (let ((savep (> (current-column) (current-indentation)))
	(indent (or (mlb-calculate-indent) 0))) ;; (ignore-errors ...)
    (if (> indent 0)
	(if savep
	    (save-excursion (indent-line-to indent))
	  (indent-line-to indent))
      (mlb-back-to-outer-indent))))


;;================
;; Setup MLB Mode
;;================
(defun mlb-mode-variables ()
  (set (make-local-variable 'paragraph-start)
       (concat "^[\t ]*$\\|" page-delimiter))
  (set (make-local-variable 'paragraph-separate) paragraph-start)
  (set (make-local-variable 'indent-line-function) 'mlb-indent-line)
  (set (make-local-variable 'comment-start) "(* ")
  (set (make-local-variable 'comment-end) " *)")
  (set (make-local-variable 'comment-nested) t)
  (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*"))

(define-derived-mode mlb-mode fundamental-mode "MLB"
  "\\<mlb-mode-map>Major mode for editing MLB declarations.
This mode runs `mlb-mode-hook' prior to exiting.
\\{mlb-mode-map}"
  (set (make-local-variable 'font-lock-defaults) mlb-font-lock-defaults)
  (mlb-mode-variables))