sml-oldindent.el

   1 ;;; sml-oldindent.el --- Old navigation and indentation functions for SML
   2
   3 ;; Copyright (C) 1999,2000,2004,2007,2012  Stefan Monnier <monnier@gnu.org>
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 3 of the License, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; if not, write to the Free Software
  17 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18
  19
  20 ;;; Commentary:
  21
  22
  23 ;;; Code:
  24
  25 (eval-when-compile (require 'cl))
  26 (require 'sml-defs)
  27
  28 ;;; First code previously help in sml-util.el and sml-defs.el.
  29
  30 (require 'cl)                           ;for `reduce'
  31 (defun sml-preproc-alist (al)
  32   "Expand an alist AL where keys can be lists of keys into a normal one."
  33   (reduce (lambda (x al)
  34             (let ((k (car x))
  35                   (v (cdr x)))
  36               (if (consp k)
  37                   (append (mapcar (lambda (y) (cons y v)) k) al)
  38                 (cons x al))))
  39           al
  40           :initial-value nil
  41           :from-end t))
  42
  43
  44
  45 (defconst sml-indent-rule
  46   (sml-preproc-alist
  47    `(("struct" . 0)
  48      (,sml-module-head-syms "d=" 0)
  49      ("local" "in" 0)
  50      ;;("of" . (3 nil))
  51      ;;("else" . (sml-indent-level 0))
  52      ;;(("in" "fun" "and" "of") . (sml-indent-level nil))
  53      ("if" "else" 0)
  54      (,sml-=-starter-syms nil)
  55      (("abstype" "case" "datatype" "if" "then" "else" "sharing" "infix" "infixr"
  56        "let" "local" "nonfix" "open" "raise" "sig" "struct" "type" "val" "while"
  57        "do" "with" "withtype")))))
  58
  59 (defconst sml-delegate
  60   (sml-preproc-alist
  61    `((("of" "else" "then" "d=") . (not (sml-bolp)))
  62      ("in" . t)))
  63   "Words which might delegate indentation to their parent.")
  64
  65 (defcustom sml-symbol-indent
  66   '(("fn" . -3)
  67     ("of" . 1)
  68     ("|" . -2)
  69     ("," . -2)
  70     (";" . -2)
  71     ;;("in" . 1)
  72     ("d=" . 2))
  73   "Special indentation alist for some symbols.
  74 An entry like (\"in\" . 1) indicates that a line starting with the
  75 symbol `in' should be indented one char further to the right.
  76 This is only used in a few specific cases, so it does not work
  77 for all symbols and in all lines starting with the given symbol."
  78   :group 'sml
  79   :type '(repeat (cons string integer)))
  80
  81 (defconst sml-open-paren
  82   (sml-preproc-alist
  83    `((,(list* "with" "in" sml-begin-syms) ,sml-begin-syms-re "\\<end\\>")))
  84   "Symbols that should behave somewhat like opening parens.")
  85
  86 (defconst sml-close-paren
  87   `(("in" "\\<l\\(ocal\\|et\\)\\>")
  88     ("with" "\\<abstype\\>")
  89     ("withtype" "\\<\\(abs\\|data\\)type\\>")
  90     ("end" ,sml-begin-syms-re)
  91     ("then" "\\<if\\>")
  92     ("else" "\\<if\\>" (sml-bolp))
  93     ("of" "\\<case\\>")
  94     ("d=" nil))
  95   "Symbols that should behave somewhat like close parens.")
  96
  97 (defconst sml-agglomerate-re "\\<else[ \t]+if\\>"
  98   "Regexp of compound symbols (pairs of symbols to be considered as one).")
  99
 100 ;;; Then, the buffer navigation (formerly sml-move.el).
 101
 102 (defvar sml-internal-syntax-table
 103   (let ((st (make-syntax-table sml-mode-syntax-table)))
 104     (modify-syntax-entry ?_ "w" st)
 105     (modify-syntax-entry ?' "w" st)
 106     (modify-syntax-entry ?. "w" st)
 107     ;; treating `~' as a word constituent is not quite right, but
 108     ;; close enough.  Think about 12.3E~2 for example.  Also `~' on its
 109     ;; own *is* a nonfix symbol.
 110     (modify-syntax-entry ?~ "w" st)
 111     st)
 112   "Syntax table used for internal sml-mode operation.")
 113
 114 ;;;
 115 ;;; various macros
 116 ;;;
 117
 118 (defmacro sml-with-ist (&rest r)
 119   (let ((ost-sym (make-symbol "oldtable")))
 120     `(let ((,ost-sym (syntax-table))
 121            (case-fold-search nil)
 122            (parse-sexp-lookup-properties t)
 123            (parse-sexp-ignore-comments t))
 124        (unwind-protect
 125            (progn (set-syntax-table sml-internal-syntax-table) . ,r)
 126          (set-syntax-table ,ost-sym)))))
 127 (def-edebug-spec sml-with-ist t)
 128
 129 (defmacro sml-move-if (&rest body)
 130   (let ((pt-sym (make-symbol "point"))
 131         (res-sym (make-symbol "result")))
 132     `(let ((,pt-sym (point))
 133            (,res-sym ,(cons 'progn body)))
 134        (unless ,res-sym (goto-char ,pt-sym))
 135        ,res-sym)))
 136 (def-edebug-spec sml-move-if t)
 137
 138 (defmacro sml-point-after (&rest body)
 139   `(save-excursion
 140      ,@body
 141      (point)))
 142 (def-edebug-spec sml-point-after t)
 143
 144 ;;
 145
 146 (defvar sml-op-prec
 147   (sml-preproc-alist
 148    '(("before" . 0)
 149      ((":=" "o") . 3)
 150      ((">" ">=" "<>" "<" "<=" "=") . 4)
 151      (("::" "@") . 5)
 152      (("+" "-" "^") . 6)
 153      (("/" "*" "quot" "rem" "div" "mod") . 7)))
 154   "Alist of SML infix operators and their precedence.")
 155
 156 (defconst sml-syntax-prec
 157   (sml-preproc-alist
 158    `((("in" "with") . 10)
 159      ((";" ",") . 20)
 160      (("=>" "d=" "=of") . (65 . 40))
 161      ("|" . (47 . 30))
 162      (("case" "of" "fn") . 45)
 163      (("if" "then" "else" "while" "do" "raise") . 50)
 164      ("handle" . 60)
 165      ("orelse" . 70)
 166      ("andalso" . 80)
 167      ((":" ":>") . 90)
 168      ("->" . 95)
 169      (,(cons "end" sml-begin-syms) . 10000)))
 170   "Alist of pseudo-precedence of syntactic elements.")
 171
 172 (defun sml-op-prec (op dir)
 173   "Return the precedence of OP or nil if it's not an infix.
 174 DIR should be set to BACK if you want to precedence w.r.t the left side
 175     and to FORW for the precedence w.r.t the right side.
 176 This assumes that we are `looking-at' the OP."
 177   (when op
 178     (let ((sprec (cdr (assoc op sml-syntax-prec))))
 179       (cond
 180        ((consp sprec) (if (eq dir 'back) (car sprec) (cdr sprec)))
 181        (sprec sprec)
 182        (t
 183         (let ((prec (cdr (assoc op sml-op-prec))))
 184           (when prec (+ prec 100))))))))
 185
 186 ;;
 187
 188 (defun sml-forward-spaces () (forward-comment 100000))
 189 (defun sml-backward-spaces () (forward-comment -100000))
 190
 191
 192 ;;
 193 ;; moving forward around matching symbols
 194 ;;
 195
 196 (defun sml-looking-back-at (re)
 197   (save-excursion
 198     (when (= 0 (skip-syntax-backward "w_")) (backward-char))
 199     (looking-at re)))
 200
 201 (defun sml-find-match-forward (this match)
 202   "Only works for word matches."
 203   (let ((level 1)
 204         (forward-sexp-function nil)
 205         (either (concat this "\\|" match)))
 206     (while (and (not (eobp)) (> level 0))
 207       (forward-sexp 1)
 208       (while (not (or (eobp) (sml-looking-back-at either)))
 209         (condition-case () (forward-sexp 1) (error (forward-char 1))))
 210       (setq level
 211             (cond
 212              ((sml-looking-back-at this) (1+ level))
 213              ((sml-looking-back-at match) (1- level))
 214              (t (error "Unbalanced")))))
 215     t))
 216
 217 (defun sml-find-match-backward (this match)
 218   (let ((level 1)
 219         (forward-sexp-function nil)
 220         (either (concat this "\\|" match)))
 221     (while (> level 0)
 222       (backward-sexp 1)
 223       (while (not (or (bobp) (looking-at either)))
 224         (condition-case () (backward-sexp 1) (error (backward-char 1))))
 225       (setq level
 226             (cond
 227              ((looking-at this) (1+ level))
 228              ((looking-at match) (1- level))
 229              (t (error "Unbalanced")))))
 230     t))
 231
 232 ;;;
 233 ;;; Read a symbol, including the special "op <sym>" case
 234 ;;;
 235
 236 (defmacro sml-move-read (&rest body)
 237   (let ((pt-sym (make-symbol "point")))
 238     `(let ((,pt-sym (point)))
 239        ,@body
 240        (when (/= (point) ,pt-sym)
 241          (buffer-substring-no-properties (point) ,pt-sym)))))
 242 (def-edebug-spec sml-move-read t)
 243
 244 (defun sml-poly-equal-p ()
 245   ;; Figure out which kind of "=" this is.
 246   ;; The idea is to look backward for the first occurrence of a token that
 247   ;; requires a definitional "=" and then see if there's such a definitional
 248   ;; equal between that token and ourselves (in which case we're not
 249   ;; a definitional = ourselves).
 250   ;; The "search for =" is naive and will match "=>" and "<=", but it turns
 251   ;; out to be OK in practice because such tokens very rarely (if ever) appear
 252   ;; between the =-starter and the corresponding definitional equal.
 253   ;; One known problem case is code like:
 254   ;; "functor foo (structure s : S) where type t = s.t ="
 255   ;; where the "type t = s.t" is mistaken for a type definition.
 256   (< (sml-point-after (re-search-backward sml-=-starter-re nil 'move))
 257      (sml-point-after (re-search-backward "=" nil 'move))))
 258
 259 (defun sml-nested-of-p ()
 260   (< (sml-point-after
 261       (re-search-backward sml-non-nested-of-starter-re nil 'move))
 262      (sml-point-after (re-search-backward "\\<case\\>" nil 'move))))
 263
 264 (defun sml-forward-sym-1 ()
 265   (or (/= 0 (skip-syntax-forward "'w_"))
 266       (/= 0 (skip-syntax-forward ".'"))))
 267 (defun sml-forward-sym ()
 268   (let ((sym (sml-move-read (sml-forward-sym-1))))
 269     (cond
 270      ((equal "op" sym)
 271       (sml-forward-spaces)
 272       (concat "op " (or (sml-move-read (sml-forward-sym-1)) "")))
 273      ((equal sym "=")
 274       (save-excursion
 275         (sml-backward-sym-1)
 276         (if (sml-poly-equal-p) "=" "d=")))
 277      ((equal sym "of")
 278       (save-excursion
 279         (sml-backward-sym-1)
 280         (if (sml-nested-of-p) "of" "=of")))
 281      ;; ((equal sym "datatype")
 282      ;;  (save-excursion
 283      ;;         (sml-backward-sym-1)
 284      ;;         (sml-backward-spaces)
 285      ;;         (if (eq (preceding-char) ?=) "=datatype" sym)))
 286      (t sym))))
 287
 288 (defun sml-backward-sym-1 ()
 289   (or (/= 0 (skip-syntax-backward ".'"))
 290       (/= 0 (skip-syntax-backward "'w_"))))
 291 (defun sml-backward-sym ()
 292   (let ((sym (sml-move-read (sml-backward-sym-1))))
 293     (when sym
 294       ;; FIXME: what should we do if `sym' = "op" ?
 295       (let ((point (point)))
 296         (sml-backward-spaces)
 297         (if (equal "op" (sml-move-read (sml-backward-sym-1)))
 298             (concat "op " sym)
 299           (goto-char point)
 300           (cond
 301            ((string= sym "=") (if (sml-poly-equal-p) "=" "d="))
 302            ((string= sym "of") (if (sml-nested-of-p) "of" "=of"))
 303            ;; ((string= sym "datatype")
 304            ;;  (save-excursion (sml-backward-spaces)
 305            ;;               (if (eq (preceding-char) ?=) "=datatype" sym)))
 306            (t sym)))))))
 307
 308
 309 (defun sml-backward-sexp (prec)
 310   "Move one sexp backward if possible, or one char else.
 311 Returns t if the move indeed moved through one sexp and nil if not.
 312 PREC is the precedence currently looked for."
 313   (let ((parse-sexp-lookup-properties t)
 314         (parse-sexp-ignore-comments t))
 315     (sml-backward-spaces)
 316     (let* ((op (sml-backward-sym))
 317            (op-prec (sml-op-prec op 'back))
 318            match)
 319       (cond
 320        ((not op)
 321         (let ((point (point)))
 322           (ignore-errors (let ((forward-sexp-function nil)) (backward-sexp 1)))
 323           (if (/= point (point)) t (ignore-errors (backward-char 1)) nil)))
 324        ;; stop as soon as precedence is smaller than `prec'
 325        ((and prec op-prec (>= prec op-prec)) nil)
 326        ;; special rules for nested constructs like if..then..else
 327        ((and (or (not prec) (and prec op-prec))
 328              (setq match (second (assoc op sml-close-paren))))
 329         (sml-find-match-backward (concat "\\<" op "\\>") match))
 330        ;; don't back over open-parens
 331        ((assoc op sml-open-paren) nil)
 332        ;; infix ops precedence
 333        ((and prec op-prec) (< prec op-prec))
 334        ;; [ prec = nil ]  a new operator, let's skip the sexps until the next
 335        (op-prec (while (sml-move-if (sml-backward-sexp op-prec))) t)
 336        ;; special symbols indicating we're getting out of a nesting level
 337        ((string-match sml-sexp-head-symbols-re op) nil)
 338        ;; if the op was not alphanum, then we still have to do the backward-sexp
 339        ;; this reproduces the usual backward-sexp, but it might be bogus
 340        ;; in this case since !@$% is a perfectly fine symbol
 341        (t t))))) ;(or (string-match "\\sw" op) (sml-backward-sexp prec))
 342
 343 (defun sml-forward-sexp (prec)
 344   "Moves one sexp forward if possible, or one char else.
 345 Returns T if the move indeed moved through one sexp and NIL if not."
 346   (let ((parse-sexp-lookup-properties t)
 347         (parse-sexp-ignore-comments t))
 348     (sml-forward-spaces)
 349     (let* ((op (sml-forward-sym))
 350            (op-prec (sml-op-prec op 'forw))
 351            match)
 352       (cond
 353        ((not op)
 354         (let ((point (point)))
 355           (ignore-errors (let ((forward-sexp-function nil)) (forward-sexp 1)))
 356           (if (/= point (point)) t (forward-char 1) nil)))
 357        ;; stop as soon as precedence is smaller than `prec'
 358        ((and prec op-prec (>= prec op-prec)) nil)
 359        ;; special rules for nested constructs like if..then..else
 360        ((and (or (not prec) (and prec op-prec))
 361              (setq match (cdr (assoc op sml-open-paren))))
 362         (sml-find-match-forward (first match) (second match)))
 363        ;; don't forw over close-parens
 364        ((assoc op sml-close-paren) nil)
 365        ;; infix ops precedence
 366        ((and prec op-prec) (< prec op-prec))
 367        ;; [ prec = nil ]  a new operator, let's skip the sexps until the next
 368        (op-prec (while (sml-move-if (sml-forward-sexp op-prec))) t)
 369        ;; special symbols indicating we're getting out of a nesting level
 370        ((string-match sml-sexp-head-symbols-re op) nil)
 371        ;; if the op was not alphanum, then we still have to do the backward-sexp
 372        ;; this reproduces the usual backward-sexp, but it might be bogus
 373        ;; in this case since !@$% is a perfectly fine symbol
 374        (t t))))) ;(or (string-match "\\sw" op) (sml-backward-sexp prec))
 375
 376 (defun sml-in-word-p ()
 377   (and (eq ?w (char-syntax (or (char-before) ? )))
 378        (eq ?w (char-syntax (or (char-after) ? )))))
 379
 380 (defun sml-user-backward-sexp (&optional count)
 381   "Like `backward-sexp' but tailored to the SML syntax."
 382   (interactive "p")
 383   (unless count (setq count 1))
 384   (sml-with-ist
 385    (let ((point (point)))
 386      (if (< count 0) (sml-user-forward-sexp (- count))
 387        (when (sml-in-word-p) (forward-word 1))
 388        (dotimes (i count)
 389          (unless (sml-backward-sexp nil)
 390            (goto-char point)
 391            (error "Containing expression ends prematurely")))))))
 392
 393 (defun sml-user-forward-sexp (&optional count)
 394   "Like `forward-sexp' but tailored to the SML syntax."
 395   (interactive "p")
 396   (unless count (setq count 1))
 397   (sml-with-ist
 398    (let ((point (point)))
 399      (if (< count 0) (sml-user-backward-sexp (- count))
 400        (when (sml-in-word-p) (backward-word 1))
 401        (dotimes (i count)
 402          (unless (sml-forward-sexp nil)
 403            (goto-char point)
 404            (error "Containing expression ends prematurely")))))))
 405
 406 ;;(defun sml-forward-thing ()
 407 ;;  (if (= ?w (char-syntax (char-after))) (forward-word 1) (forward-char 1)))
 408
 409 (defun sml-backward-arg () (sml-backward-sexp 1000))
 410 (defun sml-forward-arg () (sml-forward-sexp 1000))
 411
 412 ;;; Then the indentation code (previously in sml-mode.el).
 413
 414 (defun sml-indent-line ()
 415   "Indent current line of ML code."
 416   (interactive)
 417   (let ((savep (> (current-column) (current-indentation)))
 418         (indent (max (or (ignore-errors (sml-calculate-indentation)) 0) 0)))
 419     (if savep
 420         (save-excursion (indent-line-to indent))
 421       (indent-line-to indent))))
 422
 423 (defun sml-calculate-indentation ()
 424   (save-excursion
 425     (beginning-of-line) (skip-chars-forward "\t ")
 426     (sml-with-ist
 427      ;; Indentation for comments alone on a line, matches the
 428      ;; proper indentation of the next line.
 429      (when (looking-at "(\\*") (sml-forward-spaces))
 430      (let (data
 431            (sym (save-excursion (sml-forward-sym))))
 432        (or
 433         ;; Allow the user to override the indentation.
 434         (when (looking-at (concat ".*" (regexp-quote comment-start)
 435                                   "[ \t]*fixindent[ \t]*"
 436                                   (regexp-quote comment-end)))
 437           (current-indentation))
 438
 439         ;; Continued comment.
 440         (and (looking-at "\\*") (sml-find-comment-indent))
 441
 442         ;; Continued string ? (Added 890113 lbn)
 443         (and (looking-at "\\\\")
 444              (or (save-excursion (forward-line -1)
 445                                  (if (looking-at "[\t ]*\\\\")
 446                                      (current-indentation)))
 447                  (save-excursion
 448                    (if (re-search-backward "[^\\\\]\"" nil t)
 449                        (1+ (current-column))
 450                      0))))
 451
 452         ;; Closing parens.  Could be handled below with `sml-indent-relative'?
 453         (and (looking-at "\\s)")
 454              (save-excursion
 455                (skip-syntax-forward ")")
 456                (backward-sexp 1)
 457                (if (sml-dangling-sym)
 458                    (sml-indent-default 'noindent)
 459                  (current-column))))
 460
 461         (and (setq data (assoc sym sml-close-paren))
 462              (sml-indent-relative sym data))
 463
 464         (and (member sym sml-starters-syms)
 465              (sml-indent-starter sym))
 466
 467         (and (string= sym "|") (sml-indent-pipe))
 468
 469         (sml-indent-arg)
 470         (sml-indent-default))))))
 471
 472 (defun sml-find-comment-indent ()
 473   (save-excursion
 474     (let ((depth 1))
 475       (while (> depth 0)
 476         (if (re-search-backward "(\\*\\|\\*)" nil t)
 477             (cond
 478              ;; FIXME: That's just a stop-gap.
 479              ((eq (get-text-property (point) 'face) 'font-lock-string-face))
 480              ((looking-at "*)") (incf depth))
 481              ((looking-at comment-start-skip) (decf depth)))
 482           (setq depth -1)))
 483       (if (= depth 0)
 484           (1+ (current-column))
 485         nil))))
 486
 487 (defsubst sml-bolp ()
 488   (save-excursion (skip-chars-backward " \t|") (bolp)))
 489
 490 (defun sml-first-starter-p ()
 491   "Non-nil if starter at point is immediately preceded by let/local/in/..."
 492   (save-excursion
 493     (let ((sym (unless (save-excursion (sml-backward-arg))
 494                  (sml-backward-spaces)
 495                  (sml-backward-sym))))
 496       (if (member sym '(";" "d=")) (setq sym nil))
 497       sym)))
 498
 499
 500 (defun sml-indent-starter (orig-sym)
 501   "Return the indentation to use for a symbol in `sml-starters-syms'.
 502 Point should be just before the symbol ORIG-SYM and is not preserved."
 503   (let ((sym (unless (save-excursion (sml-backward-arg))
 504                (sml-backward-spaces)
 505                (sml-backward-sym))))
 506     (if (member sym '(";" "d=")) (setq sym nil))
 507     (if sym (sml-get-sym-indent sym)
 508       ;; FIXME: this can take a *long* time !!
 509       (setq sym (sml-find-matching-starter sml-starters-syms))
 510       (if (or (sml-first-starter-p)
 511               ;; Don't align with `and' because it might be specially indented.
 512               (and (or (equal orig-sym "and") (not (equal sym "and")))
 513                    (sml-bolp)))
 514           (+ (current-column)
 515              (if (and sml-rightalign-and (equal orig-sym "and"))
 516                  (- (length sym) 3) 0))
 517         (sml-indent-starter orig-sym)))))
 518
 519 (defun sml-indent-relative (sym data)
 520   (save-excursion
 521     (sml-forward-sym) (sml-backward-sexp nil)
 522     (unless (second data) (sml-backward-spaces) (sml-backward-sym))
 523     (+ (or (cdr (assoc sym sml-symbol-indent)) 0)
 524        (sml-delegated-indent))))
 525
 526 (defun sml-indent-pipe ()
 527   (let ((sym (sml-find-matching-starter sml-pipeheads
 528                                         (sml-op-prec "|" 'back))))
 529     (when sym
 530       (if (string= sym "|")
 531           (if (sml-bolp) (current-column) (sml-indent-pipe))
 532         (let ((pipe-indent (or (cdr (assoc "|" sml-symbol-indent)) -2)))
 533           (when (or (member sym '("datatype" "abstype"))
 534                     (and (equal sym "and")
 535                          (save-excursion
 536                            (forward-word 1)
 537                            (not (sml-funname-of-and)))))
 538             (re-search-forward "="))
 539           (sml-forward-sym)
 540           (sml-forward-spaces)
 541           (+ pipe-indent (current-column)))))))
 542
 543 (defun sml-indent-arg ()
 544   (and (save-excursion (ignore-errors (sml-forward-arg)))
 545        ;;(not (looking-at sml-not-arg-re))
 546        ;; looks like a function or an argument
 547        (sml-move-if (sml-backward-arg))
 548        ;; an argument
 549        (if (save-excursion (not (sml-backward-arg)))
 550            ;; a first argument
 551            (+ (current-column) sml-indent-args)
 552          ;; not a first arg
 553          (while (and (/= (current-column) (current-indentation))
 554                      (sml-move-if (sml-backward-arg))))
 555          (unless (save-excursion (sml-backward-arg))
 556            ;; all earlier args are on the same line
 557            (sml-forward-arg) (sml-forward-spaces))
 558          (current-column))))
 559
 560 (defun sml-get-indent (data sym)
 561   (let (d)
 562     (cond
 563      ((not (listp data)) data)
 564      ((setq d (member sym data)) (cadr d))
 565      ((and (consp data) (not (stringp (car data)))) (car data))
 566      (t sml-indent-level))))
 567
 568 (defun sml-dangling-sym ()
 569   "Non-nil if the symbol after point is dangling.
 570 The symbol can be an SML symbol or an open-paren. \"Dangling\" means that
 571 it is not on its own line but is the last element on that line."
 572   (save-excursion
 573     (and (not (sml-bolp))
 574          (< (sml-point-after (end-of-line))
 575             (sml-point-after (or (sml-forward-sym) (skip-syntax-forward "("))
 576                              (sml-forward-spaces))))))
 577
 578 (defun sml-delegated-indent ()
 579   (if (sml-dangling-sym)
 580       (sml-indent-default 'noindent)
 581     (sml-move-if (backward-word 1)
 582                  (looking-at sml-agglomerate-re))
 583     (current-column)))
 584
 585 (defun sml-get-sym-indent (sym &optional style)
 586   "Find the indentation for the SYM we're `looking-at'.
 587 If indentation is delegated, point will move to the start of the parent.
 588 Optional argument STYLE is currently ignored."
 589   (assert (equal sym (save-excursion (sml-forward-sym))))
 590   (save-excursion
 591     (let ((delegate (and (not (equal sym "end")) (assoc sym sml-close-paren)))
 592           (head-sym sym))
 593       (when (and delegate (not (eval (third delegate))))
 594         ;;(sml-find-match-backward sym delegate)
 595         (sml-forward-sym) (sml-backward-sexp nil)
 596         (setq head-sym
 597               (if (second delegate)
 598                   (save-excursion (sml-forward-sym))
 599                 (sml-backward-spaces) (sml-backward-sym))))
 600
 601       (let ((idata (assoc head-sym sml-indent-rule)))
 602         (when idata
 603           ;;(if (or style (not delegate))
 604           ;; normal indentation
 605           (let ((indent (sml-get-indent (cdr idata) sym)))
 606             (when indent (+ (sml-delegated-indent) indent)))
 607           ;; delgate indentation to the parent
 608           ;;(sml-forward-sym) (sml-backward-sexp nil)
 609           ;;(let* ((parent-sym (save-excursion (sml-forward-sym)))
 610           ;;     (parent-indent (cdr (assoc parent-sym sml-indent-starters))))
 611           ;; check the special rules
 612           ;;(+ (sml-delegated-indent)
 613           ;; (or (sml-get-indent (cdr indent-data) 1 'strict)
 614           ;; (sml-get-indent (cdr parent-indent) 1 'strict)
 615           ;; (sml-get-indent (cdr indent-data) 0)
 616           ;; (sml-get-indent (cdr parent-indent) 0))))))))
 617           )))))
 618
 619 (defun sml-indent-default (&optional noindent)
 620   (let* ((sym-after (save-excursion (sml-forward-sym)))
 621          (_ (sml-backward-spaces))
 622          (sym-before (sml-backward-sym))
 623          (sym-indent (and sym-before (sml-get-sym-indent sym-before)))
 624          (indent-after (or (cdr (assoc sym-after sml-symbol-indent)) 0)))
 625     (when (equal sym-before "end")
 626       ;; I don't understand what's really happening here, but when
 627       ;; it's `end' clearly, we need to do something special.
 628       (forward-word 1)
 629       (setq sym-before nil sym-indent nil))
 630     (cond
 631      (sym-indent
 632       ;; the previous sym is an indentation introducer: follow the rule
 633       (if noindent
 634           ;;(current-column)
 635           sym-indent
 636         (+ sym-indent indent-after)))
 637      ;; If we're just after a hanging open paren.
 638      ((and (eq (char-syntax (preceding-char)) ?\()
 639            (save-excursion (backward-char) (sml-dangling-sym)))
 640       (backward-char)
 641       (sml-indent-default))
 642      (t
 643       ;; default-default
 644       (let* ((prec-after (sml-op-prec sym-after 'back))
 645              (prec (or (sml-op-prec sym-before 'back) prec-after 100)))
 646         ;; go back until you hit a symbol that has a lower prec than the
 647         ;; "current one", or until you backed over a sym that has the same prec
 648         ;; but is at the beginning of a line.
 649         (while (and (not (sml-bolp))
 650                     (while (sml-move-if (sml-backward-sexp (1- prec))))
 651                     (not (sml-bolp)))
 652           (while (sml-move-if (sml-backward-sexp prec))))
 653         (if noindent
 654             ;; the `noindent' case does back over an introductory symbol
 655             ;; such as `fun', ...
 656             (progn
 657               (sml-move-if
 658                (sml-backward-spaces)
 659                (member (sml-backward-sym) sml-starters-syms))
 660               (current-column))
 661           ;; Use `indent-after' for cases such as when , or ; should be
 662           ;; outdented so that their following terms are aligned.
 663           (+ (if (progn
 664                    (if (equal sym-after ";")
 665                        (sml-move-if
 666                         (sml-backward-spaces)
 667                         (member (sml-backward-sym) sml-starters-syms)))
 668                    (and sym-after (not (looking-at sym-after))))
 669                  indent-after 0)
 670              (current-column))))))))
 671
 672
 673 ;; maybe `|' should be set to word-syntax in our temp syntax table ?
 674 (defun sml-current-indentation ()
 675   (save-excursion
 676     (beginning-of-line)
 677     (skip-chars-forward " \t|")
 678     (current-column)))
 679
 680
 681 (defun sml-find-matching-starter (syms &optional prec)
 682   (let (sym)
 683     (ignore-errors
 684       (while
 685           (progn (sml-backward-sexp prec)
 686                  (setq sym (save-excursion (sml-forward-sym)))
 687                  (not (or (member sym syms) (bobp)))))
 688       (if (member sym syms) sym))))
 689
 690 (provide 'sml-move)
 691 (provide 'sml-oldindent)
 692
 693 ;;; sml-oldindent.el ends here