cgit.sxemacs.org Git - packages/blob - xemacs-packages/sml-mode/sml-mode.el

   1 ;;; sml-mode.el --- Major mode for editing (Standard) ML
   2
   3 ;; Copyright (C) 1989       Lars Bo Nielsen
   4 ;; Copyright (C) 1994-1997  Matthew J. Morley
   5 ;; Copyright (C) 1999-2000  Stefan Monnier
   6
   7 ;; Author: Lars Bo Nielsen
   8 ;;      Olin Shivers
   9 ;;      Fritz Knabe (?)
  10 ;;      Steven Gilmore (?)
  11 ;;      Matthew Morley <mjm@scs.leeds.ac.uk> (aka <matthew@verisity.com>)
  12 ;;      Matthias Blume <blume@cs.princeton.edu> (aka <blume@kurims.kyoto-u.ac.jp>)
  13 ;;      (Stefan Monnier) monnier@cs.yale.edu
  14 ;; Maintainer: (Stefan Monnier) monnier+lists/emacs/sml@flint.cs.yale.edu
  15 ;; Keywords: SML
  16 ;; $Revision: 1.27 $
  17 ;; $Date: 2001/09/18 19:09:26 $
  18
  19 ;; This file is not part of GNU Emacs, but it is distributed under the
  20 ;; same conditions.
  21
  22 ;; This program is free software; you can redistribute it and/or
  23 ;; modify it under the terms of the GNU General Public License as
  24 ;; published by the Free Software Foundation; either version 2, or (at
  25 ;; your option) any later version.
  26
  27 ;; This program is distributed in the hope that it will be useful, but
  28 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  29 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  30 ;; General Public License for more details.
  31
  32 ;; You should have received a copy of the GNU General Public License
  33 ;; along with GNU Emacs; see the file COPYING. If not, write to the
  34 ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  35
  36 ;;; Commentary:
  37
  38 ;;; HISTORY
  39
  40 ;; Still under construction: History obscure, needs a biographer as
  41 ;; well as a M-x doctor. Change Log on request.
  42
  43 ;; Hacked by Olin Shivers for comint from Lars Bo Nielsen's sml.el.
  44
  45 ;; Hacked by Matthew Morley to incorporate Fritz Knabe's hilite and
  46 ;; font-lock patterns, some of Steven Gilmore's (reduced) easy-menus,
  47 ;; and numerous bugs and bug-fixes.
  48
  49 ;;; DESCRIPTION
  50
  51 ;; See accompanying info file: sml-mode.info
  52
  53 ;;; FOR YOUR .EMACS FILE
  54
  55 ;; If sml-mode.el lives in some non-standard directory, you must tell
  56 ;; emacs where to get it. This may or may not be necessary:
  57
  58 ;; (add-to-list 'load-path "~jones/lib/emacs/")
  59
  60 ;; Then to access the commands autoload sml-mode with that command:
  61
  62 ;; (load "sml-mode-startup")
  63
  64 ;; sml-mode-hook is run whenever a new sml-mode buffer is created.
  65
  66 ;; Finally, there are inferior-sml-{mode,load}-hooks -- see comments
  67 ;; in sml-proc.el. For much more information consult the mode's *info*
  68 ;; tree.
  69
  70 ;;; Code:
  71
  72 (eval-when-compile (require 'cl))
  73 (require 'sml-util)
  74 (require 'sml-move)
  75 (require 'sml-defs)
  76 (condition-case nil (require 'skeleton) (error nil))
  77
  78 ;;; VARIABLES CONTROLLING INDENTATION
  79
  80 (defcustom sml-indent-level 4
  81   "*Indentation of blocks in ML (see also `sml-structure-indent')."
  82   :group 'sml
  83   :type '(integer))
  84
  85 (defcustom sml-indent-args sml-indent-level
  86   "*Indentation of args placed on a separate line."
  87   :group 'sml
  88   :type '(integer))
  89
  90 ;; (defvar sml-indent-align-args t
  91 ;;   "*Whether the arguments should be aligned.")
  92
  93 ;; (defvar sml-case-indent nil
  94 ;;   "*How to indent case-of expressions.
  95 ;;     If t:   case expr                     If nil:   case expr of
  96 ;;               of exp1 => ...                            exp1 => ...
  97 ;;                | exp2 => ...                          | exp2 => ...
  98
  99 ;; The first seems to be the standard in SML/NJ, but the second
 100 ;; seems nicer...")
 101
 102 (defcustom sml-electric-semi-mode nil
 103   "*If non-nil, `\;' will self insert, reindent the line, and do a newline.
 104 If nil, just insert a `\;'.  (To insert while t, do: \\[quoted-insert] \;)."
 105   :group 'sml
 106   :type 'boolean)
 107
 108 (defcustom sml-rightalign-and t
 109   "If non-nil, right-align `and' with its leader.
 110 If nil:                                 If t:
 111         datatype a = A                          datatype a = A
 112         and b = B                                    and b = B"
 113   :group 'sml
 114   :type 'boolean)
 115
 116 ;;; OTHER GENERIC MODE VARIABLES
 117
 118 (defvar sml-mode-info "sml-mode"
 119   "*Where to find Info file for `sml-mode'.
 120 The default assumes the info file \"sml-mode.info\" is on Emacs' info
 121 directory path.  If it is not, either put the file on the standard path
 122 or set the variable `sml-mode-info' to the exact location of this file
 123
 124   (setq sml-mode-info \"/usr/me/lib/info/sml-mode\")
 125
 126 in your .emacs file. You can always set it interactively with the
 127 set-variable command.")
 128
 129 (defvar sml-mode-hook nil
 130   "*Run upon entering `sml-mode'.
 131 This is a good place to put your preferred key bindings.")
 132
 133 ;;; CODE FOR SML-MODE
 134
 135 (defun sml-mode-info ()
 136   "Command to access the TeXinfo documentation for `sml-mode'.
 137 See doc for the variable `sml-mode-info'."
 138   (interactive)
 139   (require 'info)
 140   (condition-case nil
 141       (info sml-mode-info)
 142     (error (progn
 143              (describe-variable 'sml-mode-info)
 144              (message "Can't find it... set this variable first!")))))
 145
 146
 147 ;;; Autoload functions -- no-doc is another idea cribbed from AucTeX!
 148
 149 (let ((sml-no-doc
 150        "This function is part of sml-proc, and has not yet been loaded.
 151 Full documentation will be available after autoloading the function."))
 152
 153   (autoload 'sml-compile        "sml-proc"   sml-no-doc t)
 154   (autoload 'sml-load-file      "sml-proc"   sml-no-doc t)
 155   (autoload 'switch-to-sml      "sml-proc"   sml-no-doc t)
 156   (autoload 'sml-send-region    "sml-proc"   sml-no-doc t)
 157   (autoload 'sml-send-buffer    "sml-proc"   sml-no-doc t))
 158
 159 ;; font-lock setup
 160
 161 (defconst sml-keywords-regexp
 162   (sml-syms-re "abstraction" "abstype" "and" "andalso" "as" "before" "case"
 163                "datatype" "else" "end" "eqtype" "exception" "do" "fn"
 164                "fun" "functor" "handle" "if" "in" "include" "infix"
 165                "infixr" "let" "local" "nonfix" "of" "op" "open" "orelse"
 166                "overload" "raise" "rec" "sharing" "sig" "signature"
 167                "struct" "structure" "then" "type" "val" "where" "while"
 168                "with" "withtype" "o")
 169   "A regexp that matches any and all keywords of SML.")
 170
 171 (defconst sml-tyvarseq-re
 172   "\\(\\('+\\(\\sw\\|\\s_\\)+\\|(\\([,']\\|\\sw\\|\\s_\\|\\s-\\)+)\\)\\s-+\\)?")
 173
 174 (defconst sml-font-lock-keywords
 175   `(;;(sml-font-comments-and-strings)
 176     (,(concat "\\<\\(fun\\|and\\)\\s-+" sml-tyvarseq-re "\\(\\sw+\\)\\s-+[^ \t\n=]")
 177      (1 font-lock-keyword-face)
 178      (6 font-lock-function-name-face))
 179     (,(concat "\\<\\(\\(data\\|abs\\|with\\|eq\\)?type\\)\\s-+" sml-tyvarseq-re "\\(\\sw+\\)")
 180      (1 font-lock-keyword-face)
 181      (7 font-lock-type-def-face))
 182     ("\\<\\(val\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
 183      (1 font-lock-keyword-face)
 184      ;;(6 font-lock-variable-def-face nil t)
 185      (3 font-lock-variable-name-face))
 186     ("\\<\\(structure\\|functor\\|abstraction\\)\\s-+\\(\\sw+\\)"
 187      (1 font-lock-keyword-face)
 188      (2 font-lock-module-def-face))
 189     ("\\<\\(signature\\)\\s-+\\(\\sw+\\)"
 190      (1 font-lock-keyword-face)
 191      (2 font-lock-interface-def-face))
 192
 193     (,sml-keywords-regexp . font-lock-keyword-face))
 194   "Regexps matching standard SML keywords.")
 195
 196 (defface font-lock-type-def-face
 197   '((t (:bold t)))
 198   "Font Lock mode face used to highlight type definitions."
 199   :group 'font-lock-highlighting-faces)
 200 (defvar font-lock-type-def-face 'font-lock-type-def-face
 201   "Face name to use for type definitions.")
 202
 203 (defface font-lock-module-def-face
 204   '((t (:bold t)))
 205   "Font Lock mode face used to highlight module definitions."
 206   :group 'font-lock-highlighting-faces)
 207 (defvar font-lock-module-def-face 'font-lock-module-def-face
 208   "Face name to use for module definitions.")
 209
 210 (defface font-lock-interface-def-face
 211   '((t (:bold t)))
 212   "Font Lock mode face used to highlight interface definitions."
 213   :group 'font-lock-highlighting-faces)
 214 (defvar font-lock-interface-def-face 'font-lock-interface-def-face
 215   "Face name to use for interface definitions.")
 216
 217 ;;
 218 ;; Code to handle nested comments and unusual string escape sequences
 219 ;;
 220
 221 (defsyntax sml-syntax-prop-table
 222   '((?\\ . ".") (?* . "."))
 223   "Syntax table for text-properties")
 224
 225 ;; For Emacsen that have no built-in support for nested comments
 226 (defun sml-get-depth-st ()
 227   (save-excursion
 228     (let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil))
 229            (foo (backward-char))
 230            (disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp))
 231            (pt (point)))
 232       (when disp
 233         (let* ((depth
 234                 (save-match-data
 235                   (if (re-search-backward "\\*)\\|(\\*" nil t)
 236                       (+ (or (get-char-property (point) 'comment-depth) 0)
 237                          (case (char-after) (?\( 1) (?* 0))
 238                          disp)
 239                     0)))
 240                (depth (if (> depth 0) depth)))
 241           (put-text-property pt (1+ pt) 'comment-depth depth)
 242           (when depth sml-syntax-prop-table))))))
 243
 244 (defconst sml-font-lock-syntactic-keywords
 245   `(("^\\s-*\\(\\\\\\)" (1 ',sml-syntax-prop-table))
 246     ,@(unless sml-builtin-nested-comments-flag
 247         '(("(?\\(\\*\\))?" (1 (sml-get-depth-st)))))))
 248
 249 (defconst sml-font-lock-defaults
 250   '(sml-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil
 251     (font-lock-syntactic-keywords . sml-font-lock-syntactic-keywords)))
 252
 253 ;;;;
 254 ;;;; Imenu support
 255 ;;;;
 256
 257 (defvar sml-imenu-regexp
 258   (concat "^[ \t]*\\(let[ \t]+\\)?"
 259           (regexp-opt (append sml-module-head-syms
 260                               '("and" "fun" "datatype" "abstype" "type")) t)
 261           "\\>"))
 262
 263 (defun sml-imenu-create-index ()
 264   (let (alist)
 265     (goto-char (point-max))
 266     (while (re-search-backward sml-imenu-regexp nil t)
 267       (save-excursion
 268         (let ((kind (match-string 2))
 269               (column (progn (goto-char (match-beginning 2)) (current-column)))
 270               (location
 271                (progn (goto-char (match-end 0))
 272                       (sml-forward-spaces)
 273                       (when (looking-at sml-tyvarseq-re)
 274                         (goto-char (match-end 0)))
 275                       (point)))
 276               (name (sml-forward-sym)))
 277           ;; Eliminate trivial renamings.
 278           (when (or (not (member kind '("structure" "signature")))
 279                     (progn (search-forward "=")
 280                            (sml-forward-spaces)
 281                            (looking-at "sig\\|struct")))
 282             (push (cons (concat (make-string (/ column 2) ?\ ) name) location)
 283                   alist)))))
 284     alist))
 285
 286 ;;; MORE CODE FOR SML-MODE
 287
 288 ;;;###autoload(add-to-list 'auto-mode-alist '("\\.s\\(ml\\|ig\\)\\'" . sml-mode))
 289
 290 ;; XEmacs hack, autoload a dummy autoload instead of a derived mode.
 291 ;;;###autoload(autoload 'sml-mode "sml-mode" nil t)
 292 (define-derived-mode sml-mode fundamental-mode "SML"
 293   "\\<sml-mode-map>Major mode for editing ML code.
 294 This mode runs `sml-mode-hook' just before exiting.
 295 \\{sml-mode-map}"
 296   (set (make-local-variable 'font-lock-defaults) sml-font-lock-defaults)
 297   (set (make-local-variable 'outline-regexp) sml-outline-regexp)
 298   (set (make-local-variable 'imenu-create-index-function)
 299        'sml-imenu-create-index)
 300   (set (make-local-variable 'add-log-current-defun-function)
 301        'sml-current-fun-name)
 302   ;; forward-sexp-function is an experimental variable in my hacked Emacs.
 303   (set (make-local-variable 'forward-sexp-function) 'sml-user-forward-sexp)
 304   ;; For XEmacs
 305   (easy-menu-add sml-mode-menu)
 306   ;; Compatibility
 307   (unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil))
 308   (sml-mode-variables))
 309
 310 (defun sml-mode-variables ()
 311   (set-syntax-table sml-mode-syntax-table)
 312   (setq local-abbrev-table sml-mode-abbrev-table)
 313   ;; A paragraph is separated by blank lines or ^L only.
 314
 315   (set (make-local-variable 'paragraph-start)
 316        (concat "^[\t ]*$\\|" page-delimiter))
 317   (set (make-local-variable 'paragraph-separate) paragraph-start)
 318   (set (make-local-variable 'indent-line-function) 'sml-indent-line)
 319   (set (make-local-variable 'comment-start) "(* ")
 320   (set (make-local-variable 'comment-end) " *)")
 321   (set (make-local-variable 'comment-nested) t)
 322   ;;(set (make-local-variable 'block-comment-start) "* ")
 323   ;;(set (make-local-variable 'block-comment-end) "")
 324   ;; (set (make-local-variable 'comment-column) 40)
 325   (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*"))
 326
 327 (defun sml-funname-of-and ()
 328   "Name of the function this `and' defines, or nil if not a function.
 329 Point has to be right after the `and' symbol and is not preserved."
 330   (sml-forward-spaces)
 331   (if (looking-at sml-tyvarseq-re) (goto-char (match-end 0)))
 332   (let ((sym (sml-forward-sym)))
 333     (sml-forward-spaces)
 334     (unless (or (member sym '(nil "d="))
 335                 (member (sml-forward-sym) '("d=")))
 336       sym)))
 337
 338 (defun sml-electric-pipe ()
 339   "Insert a \"|\".
 340 Depending on the context insert the name of function, a \"=>\" etc."
 341   (interactive)
 342   (sml-with-ist
 343    (unless (save-excursion (skip-chars-backward "\t ") (bolp)) (insert "\n"))
 344    (insert "| ")
 345    (let ((text
 346           (save-excursion
 347             (backward-char 2)           ;back over the just inserted "| "
 348             (let ((sym (sml-find-matching-starter sml-pipeheads
 349                                                   (sml-op-prec "|" 'back))))
 350               (sml-forward-sym)
 351               (sml-forward-spaces)
 352               (cond
 353                ((string= sym "|")
 354                 (let ((f (sml-forward-sym)))
 355                   (sml-find-forward "\\(=>\\|=\\||\\)\\S.")
 356                   (cond
 357                    ((looking-at "|") "") ;probably a datatype
 358                    ((looking-at "=>") " => ") ;`case', or `fn' or `handle'
 359                    ((looking-at "=") (concat f "  = "))))) ;a function
 360                ((string= sym "and")
 361                 ;; could be a datatype or a function
 362                 (setq sym (sml-funname-of-and))
 363                 (if sym (concat sym "  = ") ""))
 364                ;; trivial cases
 365                ((string= sym "fun")
 366                 (while (and (setq sym (sml-forward-sym))
 367                             (string-match "^'" sym))
 368                   (sml-forward-spaces))
 369                 (concat sym "  = "))
 370                ((member sym '("case" "handle" "fn" "of")) " => ")
 371                ;;((member sym '("abstype" "datatype")) "")
 372                (t ""))))))
 373
 374      (insert text)
 375      (indent-according-to-mode)
 376      (beginning-of-line)
 377      (skip-chars-forward "\t |")
 378      (skip-syntax-forward "w")
 379      (skip-chars-forward "\t ")
 380      (when (and (not (eobp)) (= ?= (char-after))) (backward-char)))))
 381
 382 (defun sml-electric-semi ()
 383   "Insert a \;.
 384 If variable `sml-electric-semi-mode' is t, indent the current line, insert
 385 a newline, and indent."
 386   (interactive)
 387   (insert "\;")
 388   (if sml-electric-semi-mode
 389       (reindent-then-newline-and-indent)))
 390
 391 ;;; INDENTATION !!!
 392
 393 (defun sml-mark-function ()
 394   "Synonym for `mark-paragraph' -- sorry.
 395 If anyone has a good algorithm for this..."
 396   (interactive)
 397   (mark-paragraph))
 398
 399 (defun sml-indent-line ()
 400   "Indent current line of ML code."
 401   (interactive)
 402   (let ((savep (> (current-column) (current-indentation)))
 403         (indent (max (or (ignore-errors (sml-calculate-indentation)) 0) 0)))
 404     (if savep
 405         (save-excursion (indent-line-to indent))
 406       (indent-line-to indent))))
 407
 408 (defun sml-back-to-outer-indent ()
 409   "Unindents to the next outer level of indentation."
 410   (interactive)
 411   (save-excursion
 412     (beginning-of-line)
 413     (skip-chars-forward "\t ")
 414     (let ((start-column (current-column))
 415           (indent (current-column)))
 416       (if (> start-column 0)
 417           (progn
 418             (save-excursion
 419               (while (>= indent start-column)
 420                 (if (re-search-backward "^[^\n]" nil t)
 421                     (setq indent (current-indentation))
 422                   (setq indent 0))))
 423             (backward-delete-char-untabify (- start-column indent)))))))
 424
 425 (defun sml-find-comment-indent ()
 426   (save-excursion
 427     (let ((depth 1))
 428       (while (> depth 0)
 429         (if (re-search-backward "(\\*\\|\\*)" nil t)
 430             (cond
 431              ;; FIXME: That's just a stop-gap.
 432              ((eq (get-text-property (point) 'face) 'font-lock-string-face))
 433              ((looking-at "*)") (incf depth))
 434              ((looking-at comment-start-skip) (decf depth)))
 435           (setq depth -1)))
 436       (if (= depth 0)
 437           (1+ (current-column))
 438         nil))))
 439
 440 (defun sml-calculate-indentation ()
 441   (save-excursion
 442     (beginning-of-line) (skip-chars-forward "\t ")
 443     (sml-with-ist
 444      ;; Indentation for comments alone on a line, matches the
 445      ;; proper indentation of the next line.
 446      (when (looking-at "(\\*") (sml-forward-spaces))
 447      (let (data
 448            (sml-point (point))
 449            (sym (save-excursion (sml-forward-sym))))
 450        (or
 451         ;; Allow the user to override the indentation.
 452         (when (looking-at (concat ".*" (regexp-quote comment-start)
 453                                   "[ \t]*fixindent[ \t]*"
 454                                   (regexp-quote comment-end)))
 455           (current-indentation))
 456
 457         ;; Continued comment.
 458         (and (looking-at "\\*") (sml-find-comment-indent))
 459
 460         ;; Continued string ? (Added 890113 lbn)
 461         (and (looking-at "\\\\")
 462              (save-excursion
 463                (if (save-excursion (previous-line 1)
 464                                    (beginning-of-line)
 465                                    (looking-at "[\t ]*\\\\"))
 466                    (progn (previous-line 1) (current-indentation))
 467                  (if (re-search-backward "[^\\\\]\"" nil t)
 468                      (1+ (current-column))
 469                    0))))
 470
 471         ;; Closing parens.  Could be handled below with `sml-indent-relative'?
 472         (and (looking-at "\\s)")
 473              (save-excursion
 474                (skip-syntax-forward ")")
 475                (backward-sexp 1)
 476                (if (sml-dangling-sym)
 477                    (sml-indent-default 'noindent)
 478                  (current-column))))
 479
 480         (and (setq data (assoc sym sml-close-paren))
 481              (sml-indent-relative sym data))
 482
 483         (and (member sym sml-starters-syms)
 484              (sml-indent-starter sym))
 485
 486         (and (string= sym "|") (sml-indent-pipe))
 487
 488         (sml-indent-arg)
 489         (sml-indent-default))))))
 490
 491 (defsubst sml-bolp ()
 492   (save-excursion (skip-chars-backward " \t|") (bolp)))
 493
 494 (defun sml-indent-starter (orig-sym)
 495   "Return the indentation to use for a symbol in `sml-starters-syms'.
 496 Point should be just before the symbol ORIG-SYM and is not preserved."
 497   (let ((sym (unless (save-excursion (sml-backward-arg))
 498                (sml-backward-spaces)
 499                (sml-backward-sym))))
 500     (if (equal sym "d=") (setq sym nil))
 501     (if sym (sml-get-sym-indent sym)
 502       ;; FIXME: this can take a *long* time !!
 503       (setq sym (sml-find-matching-starter sml-starters-syms))
 504       ;; Don't align with `and' because it might be specially indented.
 505       (if (and (or (equal orig-sym "and") (not (equal sym "and")))
 506                (sml-bolp))
 507           (+ (current-column)
 508              (if (and sml-rightalign-and (equal orig-sym "and"))
 509                  (- (length sym) 3) 0))
 510         (sml-indent-starter orig-sym)))))
 511
 512 (defun sml-indent-relative (sym data)
 513   (save-excursion
 514     (sml-forward-sym) (sml-backward-sexp nil)
 515     (unless (second data) (sml-backward-spaces) (sml-backward-sym))
 516     (+ (or (cdr (assoc sym sml-symbol-indent)) 0)
 517        (sml-delegated-indent))))
 518
 519 (defun sml-indent-pipe ()
 520   (let ((sym (sml-find-matching-starter sml-pipeheads
 521                                         (sml-op-prec "|" 'back))))
 522     (when sym
 523       (if (string= sym "|")
 524           (if (sml-bolp) (current-column) (sml-indent-pipe))
 525         (let ((pipe-indent (or (cdr (assoc "|" sml-symbol-indent)) -2)))
 526           (when (or (member sym '("datatype" "abstype"))
 527                     (and (equal sym "and")
 528                          (save-excursion
 529                            (forward-word 1)
 530                            (not (sml-funname-of-and)))))
 531             (re-search-forward "="))
 532           (sml-forward-sym)
 533           (sml-forward-spaces)
 534           (+ pipe-indent (current-column)))))))
 535
 536 (defun sml-find-forward (re)
 537   (sml-forward-spaces)
 538   (while (and (not (looking-at re))
 539               (progn
 540                 (or (ignore-errors (forward-sexp 1) t) (forward-char 1))
 541                 (sml-forward-spaces)
 542                 (not (looking-at re))))))
 543
 544 (defun sml-indent-arg ()
 545   (and (save-excursion (ignore-errors (sml-forward-arg)))
 546        ;;(not (looking-at sml-not-arg-re))
 547        ;; looks like a function or an argument
 548        (sml-move-if (sml-backward-arg))
 549        ;; an argument
 550        (if (save-excursion (not (sml-backward-arg)))
 551            ;; a first argument
 552            (+ (current-column) sml-indent-args)
 553          ;; not a first arg
 554          (while (and (/= (current-column) (current-indentation))
 555                      (sml-move-if (sml-backward-arg))))
 556          (unless (save-excursion (sml-backward-arg))
 557            ;; all earlier args are on the same line
 558            (sml-forward-arg) (sml-forward-spaces))
 559          (current-column))))
 560
 561 (defun sml-get-indent (data sym)
 562   (let ((head-sym (pop data)) d)
 563     (cond
 564      ((not (listp data)) data)
 565      ((setq d (member sym data)) (second d))
 566      ((and (consp data) (not (stringp (car data)))) (car data))
 567      (t sml-indent-level))))
 568
 569 (defun sml-dangling-sym ()
 570   "Non-nil if the symbol after point is dangling.
 571 The symbol can be an SML symbol or an open-paren. \"Dangling\" means that
 572 it is not on its own line but is the last element on that line."
 573   (save-excursion
 574     (and (not (sml-bolp))
 575          (< (sml-point-after (end-of-line))
 576             (sml-point-after (or (sml-forward-sym) (skip-syntax-forward "("))
 577                              (sml-forward-spaces))))))
 578
 579 (defun sml-delegated-indent ()
 580   (if (sml-dangling-sym)
 581       (sml-indent-default 'noindent)
 582     (sml-move-if (backward-word 1)
 583                  (looking-at sml-agglomerate-re))
 584     (current-column)))
 585
 586 (defun sml-get-sym-indent (sym &optional style)
 587   "Find the indentation for the SYM we're `looking-at'.
 588 If indentation is delegated, point will move to the start of the parent.
 589 Optional argument STYLE is currently ignored."
 590   (assert (equal sym (save-excursion (sml-forward-sym))))
 591   (save-excursion
 592     (let ((delegate (assoc sym sml-close-paren))
 593           (head-sym sym))
 594       (when (and delegate (not (eval (third delegate))))
 595         ;;(sml-find-match-backward sym delegate)
 596         (sml-forward-sym) (sml-backward-sexp nil)
 597         (setq head-sym
 598               (if (second delegate)
 599                   (save-excursion (sml-forward-sym))
 600                 (sml-backward-spaces) (sml-backward-sym))))
 601
 602       (let ((idata (assoc head-sym sml-indent-rule)))
 603         (when idata
 604           ;;(if (or style (not delegate))
 605           ;; normal indentation
 606           (let ((indent (sml-get-indent idata sym)))
 607             (when indent (+ (sml-delegated-indent) indent)))
 608           ;; delgate indentation to the parent
 609           ;;(sml-forward-sym) (sml-backward-sexp nil)
 610           ;;(let* ((parent-sym (save-excursion (sml-forward-sym)))
 611           ;;     (parent-indent (cdr (assoc parent-sym sml-indent-starters))))
 612           ;; check the special rules
 613           ;;(+ (sml-delegated-indent)
 614           ;; (or (sml-get-indent indent-data 1 'strict)
 615           ;; (sml-get-indent parent-indent 1 'strict)
 616           ;; (sml-get-indent indent-data 0)
 617           ;; (sml-get-indent parent-indent 0))))))))
 618           )))))
 619
 620 (defun sml-indent-default (&optional noindent)
 621   (let* ((sym-after (save-excursion (sml-forward-sym)))
 622          (_ (sml-backward-spaces))
 623          (sym-before (sml-backward-sym))
 624          (sym-indent (and sym-before (sml-get-sym-indent sym-before)))
 625          (indent-after (or (cdr (assoc sym-after sml-symbol-indent)) 0)))
 626     (when (equal sym-before "end")
 627       ;; I don't understand what's really happening here, but when
 628       ;; it's `end' clearly, we need to do something special.
 629       (forward-word 1)
 630       (setq sym-before nil sym-indent nil))
 631     (cond
 632      (sym-indent
 633       ;; the previous sym is an indentation introducer: follow the rule
 634       (if noindent
 635           ;;(current-column)
 636           sym-indent
 637         (+ sym-indent indent-after)))
 638      ;; If we're just after a hanging open paren.
 639      ((and (eq (char-syntax (preceding-char)) ?\()
 640            (save-excursion (backward-char) (sml-dangling-sym)))
 641       (backward-char)
 642       (sml-indent-default))
 643      (t
 644       ;; default-default
 645       (let* ((prec-after (sml-op-prec sym-after 'back))
 646              (prec (or (sml-op-prec sym-before 'back) prec-after 100)))
 647         ;; go back until you hit a symbol that has a lower prec than the
 648         ;; "current one", or until you backed over a sym that has the same prec
 649         ;; but is at the beginning of a line.
 650         (while (and (not (sml-bolp))
 651                     (while (sml-move-if (sml-backward-sexp (1- prec))))
 652                     (not (sml-bolp)))
 653           (while (sml-move-if (sml-backward-sexp prec))))
 654         (if noindent
 655             ;; the `noindent' case does back over an introductory symbol
 656             ;; such as `fun', ...
 657             (progn
 658               (sml-move-if
 659                (sml-backward-spaces)
 660                (member (sml-backward-sym) sml-starters-syms))
 661               (current-column))
 662           ;; Use `indent-after' for cases such as when , or ; should be
 663           ;; outdented so that their following terms are aligned.
 664           (+ (if (progn
 665                    (if (equal sym-after ";")
 666                        (sml-move-if
 667                         (sml-backward-spaces)
 668                         (member (sml-backward-sym) sml-starters-syms)))
 669                    (and sym-after (not (looking-at sym-after))))
 670                  indent-after 0)
 671              (current-column))))))))
 672
 673
 674 ;; maybe `|' should be set to word-syntax in our temp syntax table ?
 675 (defun sml-current-indentation ()
 676   (save-excursion
 677     (beginning-of-line)
 678     (skip-chars-forward " \t|")
 679     (current-column)))
 680
 681
 682 (defun sml-find-matching-starter (syms &optional prec)
 683   (let (sym)
 684     (ignore-errors
 685       (while
 686           (progn (sml-backward-sexp prec)
 687                  (setq sym (save-excursion (sml-forward-sym)))
 688                  (not (or (member sym syms) (bobp)))))
 689       (if (member sym syms) sym))))
 690
 691 (defun sml-skip-siblings ()
 692   (while (and (not (bobp)) (sml-backward-arg))
 693     (sml-find-matching-starter sml-starters-syms))
 694   (when (looking-at "in\\>\\|local\\>")
 695     ;;skip over `local...in' and continue
 696     (forward-word 1)
 697     (sml-backward-sexp nil)
 698     (sml-skip-siblings)))
 699
 700 (defun sml-beginning-of-defun ()
 701   (let ((sym (sml-find-matching-starter sml-starters-syms)))
 702     (if (member sym '("fun" "and" "functor" "signature" "structure"
 703                       "abstraction" "datatype" "abstype"))
 704         (save-excursion (sml-forward-sym) (sml-forward-spaces)
 705                         (sml-forward-sym))
 706       ;; We're inside a "non function declaration": let's skip all other
 707       ;; declarations that we find at the same level and try again.
 708       (sml-skip-siblings)
 709       ;; Obviously, let's not try again if we're at bobp.
 710       (unless (bobp) (sml-beginning-of-defun)))))
 711
 712 (defcustom sml-max-name-components 3
 713   "Maximum number of components to use for the current function name."
 714   :group 'sml
 715   :type 'integer)
 716
 717 (defun sml-current-fun-name ()
 718   (save-excursion
 719     (let ((count sml-max-name-components)
 720           fullname name)
 721       (end-of-line)
 722       (while (and (> count 0)
 723                   (setq name (sml-beginning-of-defun)))
 724         (decf count)
 725         (setq fullname (if fullname (concat name "." fullname) name))
 726         ;; Skip all other declarations that we find at the same level.
 727         (sml-skip-siblings))
 728       fullname)))
 729
 730
 731 ;;; INSERTING PROFORMAS (COMMON SML-FORMS)
 732
 733 (defvar sml-forms-alist nil
 734   "*Alist of code templates.
 735 You can extend this alist to your heart's content.  For each additional
 736 template NAME in the list, declare a keyboard macro or function (or
 737 interactive command) called 'sml-form-NAME'.
 738 If 'sml-form-NAME' is a function it takes no arguments and should
 739 insert the template at point\; if this is a command it may accept any
 740 sensible interactive call arguments\; keyboard macros can't take
 741 arguments at all.  Apropos keyboard macros, see `name-last-kbd-macro'
 742 and `sml-addto-forms-alist'.
 743 `sml-forms-alist' understands let, local, case, abstype, datatype,
 744 signature, structure, and functor by default.")
 745
 746 (defmacro sml-def-skeleton (name interactor &rest elements)
 747   (when (fboundp 'define-skeleton)
 748     (let ((fsym (intern (concat "sml-form-" name))))
 749       `(progn
 750          (add-to-list 'sml-forms-alist ',(cons name fsym))
 751          (define-abbrev sml-mode-abbrev-table ,name "" ',fsym)
 752          (define-skeleton ,fsym
 753            ,(format "SML-mode skeleton for `%s..' expressions" name)
 754            ,interactor
 755            ,(concat name " ") >
 756            ,@elements)))))
 757 (put 'sml-def-skeleton 'lisp-indent-function 2)
 758
 759 (sml-def-skeleton "let" nil
 760   @ "\nin " > _ "\nend" >)
 761
 762 (sml-def-skeleton "if" nil
 763   @ " then " > _ "\nelse " > _)
 764
 765 (sml-def-skeleton "local" nil
 766   @ "\nin" > _ "\nend" >)
 767
 768 (sml-def-skeleton "case" "Case expr: "
 769   str "\nof " > _ " => ")
 770
 771 (sml-def-skeleton "signature" "Signature name: "
 772   str " =\nsig" > "\n" > _ "\nend" >)
 773
 774 (sml-def-skeleton "structure" "Structure name: "
 775   str " =\nstruct" > "\n" > _ "\nend" >)
 776
 777 (sml-def-skeleton "functor" "Functor name: "
 778   str " () : =\nstruct" > "\n" > _ "\nend" >)
 779
 780 (sml-def-skeleton "datatype" "Datatype name and type params: "
 781   str " =" \n)
 782
 783 (sml-def-skeleton "abstype" "Abstype name and type params: "
 784   str " =" \n _ "\nwith" > "\nend" >)
 785
 786 ;;
 787
 788 (sml-def-skeleton "struct" nil
 789   _ "\nend" >)
 790
 791 (sml-def-skeleton "sig" nil
 792   _ "\nend" >)
 793
 794 (sml-def-skeleton "val" nil
 795   @ " = " > _)
 796
 797 (sml-def-skeleton "fn" nil
 798   @ " =>" > _)
 799
 800 (sml-def-skeleton "fun" nil
 801   @ " =" > _)
 802
 803 ;;
 804
 805 (defun sml-forms-menu (menu)
 806   (mapcar (lambda (x)
 807             (let ((name (car x))
 808                   (fsym (cdr x)))
 809               (vector name fsym t)))
 810           sml-forms-alist))
 811
 812 (defvar sml-last-form "let")
 813
 814 (defun sml-electric-space ()
 815   "Expand a symbol into an SML form, or just insert a space.
 816 If the point directly precedes a symbol for which an SML form exists,
 817 the corresponding form is inserted."
 818   (interactive)
 819   (let ((abbrev-mode (not abbrev-mode))
 820         (last-command-char ?\ )
 821         ;; Bind `this-command' to fool skeleton's special abbrev handling.
 822         (this-command 'self-insert-command))
 823     (call-interactively 'self-insert-command)))
 824
 825 (defun sml-insert-form (name newline)
 826   "Interactive short-cut to insert the NAME common ML form.
 827 If a prefix argument is given insert a NEWLINE and indent first, or
 828 just move to the proper indentation if the line is blank\; otherwise
 829 insert at point (which forces indentation to current column).
 830
 831 The default form to insert is 'whatever you inserted last time'
 832 \(just hit return when prompted\)\; otherwise the command reads with
 833 completion from `sml-forms-alist'."
 834   (interactive
 835    (list (completing-read
 836           (format "Form to insert: (default %s) " sml-last-form)
 837           sml-forms-alist nil t nil)
 838          current-prefix-arg))
 839   ;; default is whatever the last insert was...
 840   (if (string= name "") (setq name sml-last-form) (setq sml-last-form name))
 841   (unless (or (not newline)
 842               (save-excursion (beginning-of-line) (looking-at "\\s-*$")))
 843     (insert "\n"))
 844   (unless (/= ?w (char-syntax (preceding-char))) (insert " "))
 845   (let ((f (cdr (assoc name sml-forms-alist))))
 846     (cond
 847      ((commandp f) (command-execute f))
 848      (f (funcall f))
 849      (t (error "Undefined form: %s" name)))))
 850
 851 ;; See also macros.el in emacs lisp dir.
 852
 853 (defun sml-addto-forms-alist (name)
 854   "Assign a name to the last keyboard macro defined.
 855 Argument NAME is transmogrified to sml-form-NAME which is the symbol
 856 actually defined.
 857
 858 The symbol's function definition becomes the keyboard macro string.
 859
 860 If that works, NAME is added to `sml-forms-alist' so you'll be able to
 861 reinvoke the macro through \\[sml-insert-form].  You might want to save
 862 the macro to use in a later editing session -- see `insert-kbd-macro'
 863 and add these macros to your .emacs file.
 864
 865 See also `edit-kbd-macro' which is bound to \\[edit-kbd-macro]."
 866   (interactive "sName for last kbd macro (\"sml-form-\" will be added): ")
 867   (when (string= name "") (error "No command name given"))
 868   (let ((fsym (intern (concat "sml-form-" name))))
 869     (name-last-kbd-macro fsym)
 870     (message "Macro bound to %s" fsym)
 871     (add-to-list 'sml-forms-alist (cons name fsym))))
 872
 873 ;;;;
 874 ;;;;  SML/NJ's Compilation Manager support
 875 ;;;;
 876
 877 (defvar sml-cm-mode-syntax-table sml-mode-syntax-table)
 878 (defvar sml-cm-font-lock-keywords
 879  `(,(concat "\\<" (regexp-opt '("library" "group" "is" "structure"
 880                                 "functor" "signature" "funsig") t)
 881             "\\>")))
 882 ;;;###autoload
 883 (add-to-list 'completion-ignored-extensions "CM/")
 884 ;;;###autoload(add-to-list 'auto-mode-alist '("\\.cm\\'" . sml-cm-mode))
 885 ;; XEmacs hack, autoload a dummy autoload instead of a derived mode.
 886 ;;;###autoload
 887 (autoload 'sml-cm-mode "sml-mode")
 888 (define-derived-mode sml-cm-mode fundamental-mode "SML-CM"
 889   "Major mode for SML/NJ's Compilation Manager configuration files."
 890   (local-set-key "\C-c\C-c" 'sml-compile)
 891   (set (make-local-variable 'font-lock-defaults)
 892        '(sml-cm-font-lock-keywords nil t nil nil)))
 893
 894 ;;;;
 895 ;;;; ML-Lex support
 896 ;;;;
 897
 898 (defvar sml-lex-font-lock-keywords
 899   (append
 900    '(("^%\\sw+" . font-lock-builtin-face)
 901      ("^%%" . font-lock-module-def-face))
 902    sml-font-lock-keywords))
 903 (defconst sml-lex-font-lock-defaults
 904   (cons 'sml-lex-font-lock-keywords (cdr sml-font-lock-defaults)))
 905
 906 ;; XEmacs hack, autoload a dummy autoload instead of a derived mode.
 907 ;;;###autoload
 908 (autoload 'sml-lex-mode "sml-mode")
 909 (define-derived-mode sml-lex-mode sml-mode "SML-Lex"
 910   "Major Mode for editing ML-Lex files."
 911   (set (make-local-variable 'font-lock-defaults) sml-lex-font-lock-defaults))
 912
 913 ;;;;
 914 ;;;; ML-Yacc support
 915 ;;;;
 916
 917 (defface sml-yacc-bnf-face
 918   '((t (:foreground "darkgreen")))
 919   "Face used to highlight (non)terminals in `sml-yacc-mode'.")
 920 (defvar sml-yacc-bnf-face 'sml-yacc-bnf-face)
 921
 922 (defcustom sml-yacc-indent-action 16
 923   "Indentation column of the opening paren of actions."
 924   :group 'sml
 925   :type 'integer)
 926
 927 (defcustom sml-yacc-indent-pipe nil
 928   "Indentation column of the pipe char in the BNF.
 929 If nil, align it with `:' or with previous cases."
 930   :group 'sml
 931   :type 'integer)
 932
 933 (defcustom sml-yacc-indent-term nil
 934   "Indentation column of the (non)term part.
 935 If nil, align it with previous cases."
 936   :group 'sml
 937   :type 'integer)
 938
 939 (defvar sml-yacc-font-lock-keywords
 940   (cons '("^\\(\\sw+\\s-*:\\|\\s-*|\\)\\(\\s-*\\sw+\\)*\\s-*\\(\\(%\\sw+\\)\\s-+\\sw+\\|\\)"
 941           (0 (save-excursion
 942                (save-match-data
 943                  (goto-char (match-beginning 0))
 944                  (unless (or (re-search-forward "\\<of\\>" (match-end 0) 'move)
 945                              (progn (sml-forward-spaces)
 946                                     (not (looking-at "("))))
 947                    sml-yacc-bnf-face))))
 948           (4 font-lock-builtin-face t t))
 949         sml-lex-font-lock-keywords))
 950 (defconst sml-yacc-font-lock-defaults
 951   (cons 'sml-yacc-font-lock-keywords (cdr sml-font-lock-defaults)))
 952
 953 (defun sml-yacc-indent-line ()
 954   "Indent current line of ML-Yacc code."
 955   (let ((savep (> (current-column) (current-indentation)))
 956         (indent (max (or (ignore-errors (sml-yacc-indentation)) 0) 0)))
 957     (if savep
 958         (save-excursion (indent-line-to indent))
 959       (indent-line-to indent))))
 960
 961 (defun sml-yacc-indentation ()
 962   (save-excursion
 963     (back-to-indentation)
 964     (or (and (looking-at "%\\|\\(\\sw\\|\\s_\\)+\\s-*:") 0)
 965         (when (save-excursion
 966                 (condition-case nil (progn (up-list -1) nil) (scan-error t)))
 967           ;; We're outside an action.
 968           (cond
 969            ;; Special handling of indentation inside %term and %nonterm
 970            ((save-excursion
 971               (and (re-search-backward "^%\\(\\sw+\\)" nil t)
 972                    (member (match-string 1) '("term" "nonterm"))))
 973             (if (numberp sml-yacc-indent-term) sml-yacc-indent-term
 974               (let ((offset (if (looking-at "|") -2 0)))
 975                 (forward-line -1)
 976                 (looking-at "\\s-*\\(%\\sw*\\||\\)?\\s-*")
 977                 (goto-char (match-end 0))
 978                 (+ offset (current-column)))))
 979            ((looking-at "(") sml-yacc-indent-action)
 980            ((looking-at "|")
 981             (if (numberp sml-yacc-indent-pipe) sml-yacc-indent-pipe
 982               (backward-sexp 1)
 983               (while (progn (sml-backward-spaces)
 984                             (/= 0 (skip-syntax-backward "w_"))))
 985               (sml-backward-spaces)
 986               (if (not (looking-at "\\s-$"))
 987                   (1- (current-column))
 988                 (skip-syntax-forward " ")
 989                 (- (current-column) 2))))))
 990         ;; default to SML rules
 991         (sml-calculate-indentation))))
 992
 993 ;;;###autoload(add-to-list 'auto-mode-alist '("\\.grm\\'" . sml-yacc-mode))
 994 ;; XEmacs hack, autoload a dummy autoload instead of a derived mode.
 995 ;;;###autoload
 996 (autoload 'sml-yacc-mode "sml-mode")
 997 (define-derived-mode sml-yacc-mode sml-mode "SML-Yacc"
 998   "Major Mode for editing ML-Yacc files."
 999   (set (make-local-variable 'indent-line-function) 'sml-yacc-indent-line)
1000   (set (make-local-variable 'font-lock-defaults) sml-yacc-font-lock-defaults))
1001
1002 (provide 'sml-mode)
1003
1004 ;;; sml-mode.el ends here