Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml-mode/trunk/sml-mode.el
ViewVC logotype

Diff of /sml-mode/trunk/sml-mode.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 333, Tue Jun 15 03:41:26 1999 UTC revision 334, Thu Jun 17 02:43:15 1999 UTC
# Line 122  Line 122 
122  (defvar sml-pipe-indent -2  (defvar sml-pipe-indent -2
123    "*Extra (usually negative) indentation for lines beginning with `|'.")    "*Extra (usually negative) indentation for lines beginning with `|'.")
124    
 (defvar sml-indent-case-of 2  
   "*Indentation of an `of'¬†on its own line.")  
   
125  (defvar sml-indent-args 4  (defvar sml-indent-args 4
126    "*Indentation of args placed on a separate line.")    "*Indentation of args placed on a separate line.")
127    
128  (defvar sml-indent-align-args t  (defvar sml-indent-align-args t
129    "*Whether the arguments should be aligned.")    "*Whether the arguments should be aligned.")
130    
131    (defvar sml-nested-if-indent t
132      "*Determine how nested if-then-else will be formatted:
133        If t: if exp1 then exp2               If nil:   if exp1 then exp2
134              else if exp3 then exp4                    else if exp3 then exp4
135              else if exp5 then exp6                         else if exp5 then exp6
136              else exp7                                           else exp7")
137    
138  (defvar sml-case-indent nil  (defvar sml-case-indent nil
139    "*How to indent case-of expressions.    "*How to indent case-of expressions.
140      If t:   case expr                     If nil:   case expr of      If t:   case expr                     If nil:   case expr of
# Line 352  Line 356 
356  Depending on the context insert the name of function, a \"=>\" etc."  Depending on the context insert the name of function, a \"=>\" etc."
357    (interactive)    (interactive)
358    (sml-with-ist    (sml-with-ist
359       (unless (save-excursion (skip-chars-backward "\t ") (bolp)) (insert "\n"))
360       (insert "| ")
361     (let ((text     (let ((text
362            (save-excursion            (save-excursion
363              (sml-find-matching-starter sml-pipehead-re)              (backward-char 2)           ;back over the just inserted "| "
364                (sml-find-matching-starter sml-pipehead-re
365                                           (sml-op-prec "|" 'back))
366                (let ((sym (sml-forward-sym)))
367                  (sml-forward-spaces)
368                  (cond
369                   ((string= sym "|")
370                    (let ((f (sml-forward-sym)))
371                      (sml-find-forward "\\(=>\\|=\\||\\)\\S.")
372              (cond              (cond
373               ;; It was a function, insert the function name                     ((looking-at "|") "") ;probably a datatype
374               ((or (looking-at "fun\\>")                     ((looking-at "=>") " => ") ;`case', or `fn' or `handle'
375                    (and (looking-at "and\\>")                     ((looking-at "=") (concat f "  = "))))) ;a function
376                         (save-excursion                 ((string= sym "and")
377                           (sml-find-matching-starter                  ;; could be a datatype or a function
378                            (sml-syms-re "datatype" "abstype" "fun"))                  (while (and (setq sym (sml-forward-sym))
379                           (looking-at "fun\\>"))))                              (string-match "^'" sym))
380                (forward-word 1) (sml-forward-spaces)                    (sml-forward-spaces))
381                (concat                  (sml-forward-spaces)
382                 (buffer-substring (point) (progn (forward-word 1) (point)))                  (if (or (not sym)
383                 "  = "))                          (equal (sml-forward-sym) "d="))
384                        ""
385               ((looking-at (sml-syms-re "case" "handle" "fn")) " => ")                    (concat sym "  = ")))
386               ((looking-at (sml-syms-re "abstype" "datatype" "and")) "")                 ;; trivial cases
387               (t (error "Wow, now, there's a bug"))))))                 ((string= sym "fun")
388                    (while (and (setq sym (sml-forward-sym))
389                                (string-match "^'" sym))
390                      (sml-forward-spaces))
391                    (concat sym "  = "))
392                   ((member sym '("case" "handle" "fn")) " => ")
393                   ((member sym '("abstype" "datatype")) "")
394                   (t (error "Wow, now, there's a bug")))))))
395    
396       (unless (save-excursion (skip-chars-backward "\t ") (bolp)) (insert "\n"))       (insert text)
      (insert "| " text)  
397       (sml-indent-line)       (sml-indent-line)
398       (beginning-of-line)       (beginning-of-line)
399       (skip-chars-forward "\t |")       (skip-chars-forward "\t |")
# Line 452  Line 472 
472               ((looking-at comment-start-skip) (decf depth)))               ((looking-at comment-start-skip) (decf depth)))
473            (setq depth -1)))            (setq depth -1)))
474        (if (= depth 0)        (if (= depth 0)
475            (current-column)            (1+ (current-column))
476          nil))))          nil))))
477    
478  (defun sml-calculate-indentation ()  (defun sml-calculate-indentation ()
479    (save-excursion    (save-excursion
480      (beginning-of-line) (skip-chars-forward "\t ")      (beginning-of-line) (skip-chars-forward "\t ")
481      (sml-with-ist      (sml-with-ist
      (let ((indent 0)  
            (sml-point (point)))  
        (or  
         ;;(and (bobp) 0)  
   
482          ;; Indentation for comments alone on a line, matches the          ;; Indentation for comments alone on a line, matches the
483          ;; proper indentation of the next line.          ;; proper indentation of the next line.
484          (and (looking-at comment-start-skip) (sml-forward-spaces) nil)       (when (looking-at comment-start-skip) (sml-forward-spaces))
485         (let (data
486               (sml-point (point))
487               (sym (save-excursion (sml-forward-sym))))
488           (or
489          ;; continued comment          ;; continued comment
490          (and (looking-at "\\*") (setq indent (sml-find-comment-indent))          (and (looking-at "\\*") (sml-find-comment-indent))
              (1+ indent))  
491    
492          ;; Continued string ? (Added 890113 lbn)          ;; Continued string ? (Added 890113 lbn)
493          (and (looking-at "\\\\")          (and (looking-at "\\\\")
# Line 483  Line 500 
500                       (1+ (current-column))                       (1+ (current-column))
501                     0))))                     0))))
502    
503          (and (looking-at "in\\>")       ; Match the beginning let/local          (and (setq data (assoc sym sml-close-paren))
504               (sml-find-match-indent "\\<in\\>" "\\<l\\(ocal\\|et\\)\\>"))               (sml-indent-relative sym data))
   
         (and (looking-at "end\\>")      ; Match the beginning  
              ;; FIXME: should match "in" if available.  Or maybe not  
              (sml-find-match-indent "\\<end\\>" sml-begin-symbols-re))  
   
         (and (looking-at "else\\>")     ; Match the if  
              (progn  
                (sml-find-match-backward "\\<else\\>" "\\<if\\>")  
                ;;(sml-move-if (backward-word 1)  
                ;;           (and sml-nested-if-indent  
                ;;                (looking-at "else[ \t]+if\\>")))  
                (if (sml-dangling-sym)  
                      (sml-indent-default 'noindent)  
                  (current-column))))  
   
         (and (looking-at "then\\>")     ; Match the if + extra indentation  
              (sml-find-match-indent "\\<then\\>" "\\<if\\>" t))  
   
         (and (looking-at "of\\>")  
              (progn  
                (sml-find-match-backward "\\<of\\>" "\\<case\\>")  
                (+ (current-column) sml-indent-case-of)))  
505    
506          (and (looking-at sml-starters-re)          (and (looking-at sml-starters-re)
507               (let ((sym (unless (save-excursion (sml-backward-arg))               (let ((sym (unless (save-excursion (sml-backward-arg))
508                            (sml-backward-spaces)                            (sml-backward-spaces)
509                            (sml-backward-sym))))                            (sml-backward-sym))))
510                 (if sym (sml-get-sym-indent sym)                 (if sym (sml-get-sym-indent sym)
511                     ;; FIXME: this can take a *long* time !!
512                   (sml-find-matching-starter sml-starters-re)                   (sml-find-matching-starter sml-starters-re)
513                   (current-column))))                   (current-column))))
514    
515          (and (looking-at "|") (sml-indent-pipe))          (and (string= sym "|") (sml-indent-pipe))
516    
517          (sml-indent-arg)          (sml-indent-arg)
518          (sml-indent-default))))))          (sml-indent-default))))))
519    
520    (defun sml-indent-relative (sym data)
521      (save-excursion
522        (sml-forward-sym) (sml-backward-sexp nil)
523        (unless (cdr data) (sml-backward-spaces) (sml-backward-sym))
524        (+ (or (cdr (assoc sym sml-symbol-indent)) 0)
525           (sml-delegated-indent))))
526    
527  (defun sml-indent-pipe ()  (defun sml-indent-pipe ()
528    (when (sml-find-matching-starter (concat "|\\|\\<of\\>\\|" sml-pipehead-re)    (when (sml-find-matching-starter sml-pipehead-re
529                                     (sml-op-prec "|" 'back))                                     (sml-op-prec "|" 'back))
530      (if (looking-at "|")      (if (looking-at "|")
531          (if (sml-bolp) (current-column) (sml-indent-pipe))          (if (sml-bolp) (current-column) (sml-indent-pipe))
532        (cond        (when (looking-at "\\(data\\|abs\\)type\\>")
533         ((looking-at "datatype\\>")          (re-search-forward "="))
534          (re-search-forward "=")        (sml-forward-sym)
         (forward-char))  
        ((looking-at "case\\>")  
         (sml-forward-sym)       ;skip `case'  
         (sml-find-match-forward "\\<case\\>" "\\<of\\>"))  
        (t  
         (forward-word 1)))  
535        (sml-forward-spaces)        (sml-forward-spaces)
536        (+ sml-pipe-indent (current-column)))))        (+ sml-pipe-indent (current-column)))))
537    
538    (defun sml-find-forward (re)
539      (sml-forward-spaces)
540      (while (and (not (looking-at re))
541                  (progn
542                    (or (ignore-errors (forward-sexp 1) t) (forward-char 1))
543                    (sml-forward-spaces)
544                    (not (looking-at re))))))
545    
546  (defun sml-indent-arg ()  (defun sml-indent-arg ()
547    (and (save-excursion (ignore-errors (sml-forward-arg)))    (and (save-excursion (ignore-errors (sml-forward-arg)))
# Line 556  Line 560 
560             (sml-forward-arg) (sml-forward-spaces))             (sml-forward-arg) (sml-forward-spaces))
561           (current-column))))           (current-column))))
562    
563  (defun sml-re-assoc (al sym)  (defun sml-get-indent (data sym)
564    (when sym    (let ((head-sym (pop data)) d)
565      (cdr (assoc* sym al      (cond
566                   :test (lambda (x y) (string-match y x))))))       ((not (listp data)) data)
567         ((setq d (member sym data)) (second d))
568  (defun sml-get-indent (data n &optional strict)       ((and (consp data) (not (stringp (car data)))) (car data))
569    (eval (if (listp data)       (t sml-indent-level))))
             (nth n data)  
           (and (not strict) data))))  
570    
571  (defun sml-dangling-sym ()  (defun sml-dangling-sym ()
572    (save-excursion    (save-excursion
# Line 573  Line 575 
575              (sml-point-after (sml-forward-sym)              (sml-point-after (sml-forward-sym)
576                               (sml-forward-spaces))))))                               (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                     (and sml-nested-if-indent
583                          (looking-at sml-agglomerate-re)))
584        (current-column)))
585    
586  (defun sml-get-sym-indent (sym &optional style)  (defun sml-get-sym-indent (sym &optional style)
587    "expects to be looking-at SYM.    "expects to be looking-at SYM.
588  If indentation is delegated, the point will be at the start of  If indentation is delegated, the point will be at the start of
589  the parent at the end of this function."  the parent at the end of this function."
590    (let ((indent-data (sml-re-assoc sml-indent-starters sym))    (assert (equal sym (save-excursion (sml-forward-sym))))
591          (delegate (eval (sml-re-assoc sml-delegate sym))))    (save-excursion
592      (or (when indent-data      (let ((delegate (assoc sym sml-close-paren))
593            (if (or style (not delegate))            (head-sym sym))
594          (when delegate
595            ;;(sml-find-match-backward sym delegate)
596            (sml-forward-sym) (sml-backward-sexp nil)
597            (setq head-sym
598                  (if (cdr 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                ;; normal indentation
606                (let ((indent (sml-get-indent indent-data (or style 0))))            (let ((indent (sml-get-indent idata sym)))
607                  (when indent              (when indent (+ (sml-delegated-indent) indent)))
                   (+ (if (sml-dangling-sym)  
                          (sml-indent-default 'noindent)  
                        (current-column))  
                      indent)))  
608              ;; delgate indentation to the parent              ;; delgate indentation to the parent
609              (sml-forward-sym) (sml-backward-sexp nil)            ;;(sml-forward-sym) (sml-backward-sexp nil)
610              (let* ((parent-sym (save-excursion (sml-forward-sym)))            ;;(let* ((parent-sym (save-excursion (sml-forward-sym)))
611                     (parent-indent (sml-re-assoc sml-indent-starters parent-sym)))            ;;     (parent-indent (cdr (assoc parent-sym sml-indent-starters))))
612                ;; check the special rules                ;; check the special rules
613                ;;(sml-move-if (backward-word 1)            ;;(+ (sml-delegated-indent)
614                  ;;         (looking-at "\\<else[ \t]+if\\>"))            ;; (or (sml-get-indent indent-data 1 'strict)
615                (+ (if (sml-dangling-sym)            ;; (sml-get-indent parent-indent 1 'strict)
616                       (sml-indent-default 'noindent)            ;; (sml-get-indent indent-data 0)
617                     (current-column))            ;; (sml-get-indent parent-indent 0))))))))
618                   (or (sml-get-indent indent-data 1 'strict)            )))))
                      (sml-get-indent parent-indent 1 'strict)  
                      (sml-get-indent indent-data 0)  
                      (sml-get-indent parent-indent 0))))))  
         ;; (save-excursion  
         ;;   (sml-forward-sym)  
         ;;   (when (> (sml-point-after (end-of-line))  
         ;;            (progn (sml-forward-spaces) (point)))  
         ;;     (current-column)))  
         )))  
619    
620  (defun sml-indent-default (&optional noindent)  (defun sml-indent-default (&optional noindent)
621    (let* ((sym-after (save-excursion (sml-forward-sym)))    (let* ((sym-after (save-excursion (sml-forward-sym)))
622           (prec-after (sml-op-prec sym-after 'back))           (prec-after (sml-op-prec sym-after 'back))
623             (indent-after (or (cdr (assoc sym-after sml-symbol-indent)) 0))
624           (_ (sml-backward-spaces))           (_ (sml-backward-spaces))
625           (sym-before (sml-backward-sym))           (sym-before (sml-backward-sym))
626           (prec (or (sml-op-prec sym-before 'back) prec-after 100))           (prec (or (sml-op-prec sym-before 'back) prec-after 100))
627           (sym-indent (and sym-before (sml-get-sym-indent sym-before))))           (sym-indent (and sym-before (sml-get-sym-indent sym-before))))
628      (or (and sym-indent (if noindent (current-column) sym-indent))      (if sym-indent
629          (progn          (if noindent (current-column) (+ sym-indent indent-after))
630            ;;(sml-forward-sym)            ;;(sml-forward-sym)
631            (while (and (not (sml-bolp))            (while (and (not (sml-bolp))
632                        (sml-move-if (sml-backward-sexp (1- prec)))                        (sml-move-if (sml-backward-sexp (1- prec)))
633                        (not (sml-bolp)))                        (not (sml-bolp)))
634              (while (sml-move-if (sml-backward-sexp prec))))              (while (sml-move-if (sml-backward-sexp prec))))
635            (or (and (not (sml-bolp))  ;;       (or (and (not (sml-bolp))
636                     ;; If we backed over an equal char which was not the  ;;             ;; If we backed over an equal char which was not the
637                     ;; polymorphic equality, then we did what amounts to  ;;             ;; polymorphic equality, then we did what amounts to
638                     ;; delegate indent from `=' to the corresponding head, so we  ;;             ;; delegate indent from `=' to the corresponding head, so we
639                     ;; need to look at the preceding symbol and follow its  ;;             ;; need to look at the preceding symbol and follow its
640                     ;; intentation instructions.  ;;             ;; intentation instructions.
641                     (= prec 65) (string-equal "=" sym-before)  ;;             (string-equal "d=" sym-before)
642                     (save-excursion  ;;             (let ((point (point)))
643                       (sml-backward-spaces)  ;;               (sml-backward-spaces)
644                       (let* ((sym (sml-backward-sym))  ;;               (let* ((sym (sml-backward-sym))
645                              (sym-indent (sml-re-assoc sml-indent-starters sym)))  ;;                      (sym-indent (cdr (assoc-default sym sml-indent-rule))))
646                         (when sym-indent  ;;                 (when sym-indent
647                           (if noindent  ;;                   (if noindent (current-column)
648                               (current-column)  ;;                     (let ((sym-indent (sml-get-sym-indent sym 1)))
649                             (sml-get-sym-indent sym 1))))))  ;;                       (if sym-indent (+ indent-after sym-indent)
650                (current-column))))))  ;;                         (goto-char point)
651    ;;                         (+ indent-after (current-column)))))))))
652    
653          (when noindent
654            (sml-move-if (sml-backward-spaces)
655                         (string-match sml-starters-re (or (sml-backward-sym) ""))))
656          (current-column))))
657    
658    
659  (defun sml-bolp ()  (defun sml-bolp ()
# Line 654  Line 669 
669      (current-column)))      (current-column)))
670    
671    
 (defun sml-find-match-indent (this match &optional indented)  
   (save-excursion  
     (sml-find-match-backward this match)  
     (if (or indented (not (sml-dangling-sym)))  
         (current-column)  
       (sml-indent-default 'noindent))))  
   
672  (defun sml-find-matching-starter (regexp &optional prec)  (defun sml-find-matching-starter (regexp &optional prec)
673      (ignore-errors
674    (sml-backward-sexp prec)    (sml-backward-sexp prec)
675    (while (not (or (looking-at regexp) (bobp)))    (while (not (or (looking-at regexp) (bobp)))
676      (sml-backward-sexp prec))      (sml-backward-sexp prec))
677    (not (bobp)))      (not (bobp))))
678    
679  (defun sml-comment-indent ()  (defun sml-comment-indent ()
680    (if (looking-at "^(\\*")              ; Existing comment at beginning    (if (looking-at "^(\\*")              ; Existing comment at beginning
# Line 677  Line 686 
686    
687  ;;; INSERTING PROFORMAS (COMMON SML-FORMS)  ;;; INSERTING PROFORMAS (COMMON SML-FORMS)
688    
689  (defvar sml-forms-alist  (defvar sml-forms-alist nil
690    '(("let") ("local") ("case") ("abstype") ("datatype")    "*The alist of templates to auto-insert.
     ("signature") ("structure") ("functor"))  
   "*The list of templates to auto-insert.  
691    
692  You can extend this alist to your heart's content. For each additional  You can extend this alist to your heart's content. For each additional
693  template NAME in the list, declare a keyboard macro or function (or  template NAME in the list, declare a keyboard macro or function (or
# Line 695  Line 702 
702  `sml-forms-alist' understands let, local, case, abstype, datatype,  `sml-forms-alist' understands let, local, case, abstype, datatype,
703  signature, structure, and functor by default.")  signature, structure, and functor by default.")
704    
705    (defmacro sml-def-skeleton (name interactor &rest elements)
706      (let ((fsym (intern (concat "sml-form-" name))))
707        `(progn
708           (add-to-list 'sml-forms-alist ',(cons name fsym))
709           (define-skeleton ,fsym
710             ,(format "SML-mode skeleton for `%s..' expressions" name)
711             ,interactor
712             ,(concat " " name " ") >
713             ,@elements))))
714    (put 'sml-def-skeleton 'lisp-indent-function 2)
715    
716    (sml-def-skeleton "let" nil
717      _ "\nin" > "\nend" >)
718    
719    (sml-def-skeleton "if" nil
720      _ " then " > "\nelse " >)
721    
722    (sml-def-skeleton "local" nil
723      _ "\nin" > "\nend" >)
724    
725    (sml-def-skeleton "case" "Case expr: "
726      str (if sml-case-indent "\nof " " of\n") > _ " => ")
727    
728    (sml-def-skeleton "signature" "Signature name: "
729      str " =\nsig" > "\n" > _ "\nend" >)
730    
731    (sml-def-skeleton "structure" "Structure name: "
732      str " =\nstruct" > "\n" > _ "\nend" >)
733    
734    (sml-def-skeleton "functor" "Functor name: "
735      str " () : =\nstruct" > "\n" > _ "\nend" >)
736    
737    (sml-def-skeleton "datatype" "Datatype name and type parameters: "
738      str " =" \n)
739    
740    (sml-def-skeleton "abstype" "Abstype name and type parameters: "
741      str " =" \n _ "\nwith" > "\nend" >)
742    
743    ;;
744    
745    (defun sml-forms-menu (menu)
746      (easy-menu-filter-return
747       (easy-menu-create-menu "Forms"
748             (mapcar (lambda (x)
749                       (let ((name (car x))
750                             (fsym (cdr x)))
751                         (vector name fsym t)))
752                     sml-forms-alist))))
753    
754    (defvar sml-last-form "let")
755    
756    (defun sml-insert-form (name newline)
757      "Interactive short-cut to insert a common ML form.
758    If a perfix argument is given insert a newline and indent first, or
759    just move to the proper indentation if the line is blank\; otherwise
760    insert at point (which forces indentation to current column).
761    
762    The default form to insert is 'whatever you inserted last time'
763    \(just hit return when prompted\)\; otherwise the command reads with
764    completion from `sml-forms-alist'."
765      (interactive
766       (list (completing-read
767              (format "Form to insert: (default %s) " sml-last-form)
768              sml-forms-alist nil t nil)
769             current-prefix-arg))
770      ;; default is whatever the last insert was...
771      (if (string= name "") (setq name sml-last-form) (setq sml-last-form name))
772      (unless (or (not newline)
773                  (save-excursion (beginning-of-line) (looking-at "\\s-*$")))
774        (insert "\n"))
775      (let ((f (cdr (assoc name sml-forms-alist))))
776        (cond
777         ((commandp f) (command-execute f))
778         (f (funcall f))
779         (t (error "Undefined form: %s" name)))))
780    
781  ;; See also macros.el in emacs lisp dir.  ;; See also macros.el in emacs lisp dir.
782    
783  (defun sml-addto-forms-alist (name)  (defun sml-addto-forms-alist (name)
# Line 711  Line 794 
794    
795  See also `edit-kbd-macro' which is bound to \\[edit-kbd-macro]."  See also `edit-kbd-macro' which is bound to \\[edit-kbd-macro]."
796    (interactive "sName for last kbd macro (\"sml-form-\" will be added): ")    (interactive "sName for last kbd macro (\"sml-form-\" will be added): ")
797    (if (string-equal name "")    (when (string= name "") (error "No command name given"))
798        (error "No command name given")    (let ((fsym (intern (concat "sml-form-" name))))
799      (name-last-kbd-macro (intern (concat "sml-form-" name)))      (name-last-kbd-macro fsym)
800      (message (concat "Macro bound to sml-form-" name))      (message "Macro bound to %s" fsym)
801      (or (assoc name sml-forms-alist)      (add-to-list 'sml-forms-alist (cons name fsym))))
         (setq sml-forms-alist (cons (list name) sml-forms-alist)))))  
802    
803  ;; at a pinch these could be added to SML/Forms menu through the good  ;; at a pinch these could be added to SML/Forms menu through the good
804  ;; offices of activate-menubar-hook or something... but documentation  ;; offices of activate-menubar-hook or something... but documentation
805  ;; of this and/or menu-bar-update-hook is sparse in 19.33. anyway, use  ;; of this and/or menu-bar-update-hook is sparse in 19.33. anyway, use
806  ;; completing read for sml-insert-form prompt...  ;; completing read for sml-insert-form prompt...
807    
 (defvar sml-last-form "let"  
   "The most recent sml form inserted.")  
   
 (defun sml-insert-form (arg)  
   "Interactive short-cut to insert a common ML form.  
 If a perfix argument is given insert a newline and indent first, or  
 just move to the proper indentation if the line is blank\; otherwise  
 insert at point (which forces indentation to current column).  
   
 The default form to insert is 'whatever you inserted last time'  
 \(just hit return when prompted\)\; otherwise the command reads with  
 completion from `sml-forms-alist'."  
   (interactive "P")  
   (let ((name (completing-read  
                (format "Form to insert: (default %s) " sml-last-form)  
                sml-forms-alist nil t nil)))  
     ;; default is whatever the last insert was...  
     (if (string= name "") (setq name sml-last-form))  
     (setq sml-last-form name)  
     (if arg  
         (if (save-excursion (beginning-of-line) (looking-at "[ \t]*$"))  
             (sml-indent-line)  
           (newline-and-indent)))  
     (cond ((string= name "let") (sml-form-let))  
           ((string= name "local") (sml-form-local))  
           ((string= name "case") (sml-form-case))  
           ((string= name "abstype") (sml-form-abstype))  
           ((string= name "datatype") (sml-form-datatype))  
           ((string= name "functor") (sml-form-functor))  
           ((string= name "structure") (sml-form-structure))  
           ((string= name "signature") (sml-form-signature))  
           (t  
            (let ((template (intern (concat "sml-form-" name))))  
              (if (fboundp template)  
                  (if (commandp template)  
                      ;; it may be a named kbd macro too  
                      (command-execute template)  
                    (funcall template))  
                (error  
                 (format "Undefined format function: %s" template))))))))  
   
 (defun sml-form-let ()  
   "Insert a `let in end' template."  
   (interactive)  
   (sml-let-local "let"))  
   
 (defun sml-form-local ()  
   "Insert a `local in end' template."  
   (interactive)  
   (sml-let-local "local"))  
   
 (defun sml-let-local (starter)  
   "Insert a let or local template, depending on STARTER string."  
   (let ((indent (current-column)))  
     (insert starter)  
     (insert "\n") (indent-to (+ sml-indent-level indent))  
     (save-excursion                     ; so point returns here  
       (insert "\n")  
       (indent-to indent)  
       (insert "in\n")  
       (indent-to (+ sml-indent-level indent))  
       (insert "\n")  
       (indent-to indent)  
       (insert "end"))))  
   
 (defun sml-form-case ()  
   "Insert a case expression template, prompting for the case-expresion."  
   (interactive)  
   (let ((expr (read-string "Case expr: "))  
         (indent (current-column)))  
     (insert (concat "case " expr))  
     (if sml-case-indent  
         (progn  
           (insert "\n")  
           (indent-to (+ 2 indent))  
           (insert "of "))  
       (insert " of\n")  
       (indent-to (+ indent sml-indent-level)))  
     (save-excursion (insert " => "))))  
   
 (defun sml-form-signature ()  
   "Insert a generative signature binding, prompting for the name."  
   (interactive)  
   (let ((indent (current-column))  
         (name (read-string "Signature name: ")))  
     (insert (concat "signature " name " ="))  
     (insert "\n")  
     (indent-to (+ sml-structure-indent indent))  
     (insert "sig\n")  
     (indent-to (+ sml-structure-indent sml-indent-level indent))  
     (save-excursion  
       (insert "\n")  
       (indent-to (+ sml-structure-indent indent))  
       (insert "end"))))  
   
 (defun sml-form-structure ()  
   "Insert a generative structure binding, prompting for the name.  
 The command also prompts for any signature constraint -- you should  
 specify \":\" or \":>\" and the constraining signature."  
   (interactive)  
   (let ((indent (current-column))  
         (name (read-string (concat "Structure name: ")))  
         (signame (read-string "Signature constraint (default none): ")))  
     (insert (concat "structure " name " "))  
     (insert (if (string= "" signame) "=" (concat signame " =")))  
     (insert "\n")  
     (indent-to (+ sml-structure-indent indent))  
     (insert "struct\n")  
     (indent-to (+ sml-structure-indent sml-indent-level indent))  
     (save-excursion  
       (insert "\n")  
       (indent-to (+ sml-structure-indent indent))  
       (insert "end"))))  
   
 (defun sml-form-functor ()  
   "Insert a genarative functor binding, prompting for the name.  
 The command also prompts for the required signature constraint -- you  
 should specify \":\" or \":>\" and the constraining signature."  
   (interactive)  
   (let ((indent(current-indentation))  
         (name (read-string "Name of functor: "))  
         (signame (read-string "Signature constraint: " ":" )))  
     (insert (concat "functor " name " () " signame " ="))  
     (insert "\n")  
     (indent-to (+ sml-structure-indent indent))  
     (insert "struct\n")  
     (indent-to (+ sml-structure-indent sml-indent-level indent))  
     (save-excursion                     ; return to () instead?  
       (insert "\n")  
       (indent-to (+ sml-structure-indent indent))  
       (insert "end"))))  
   
 (defun sml-form-datatype ()  
   "Insert a datatype declaration, prompting for name and type parameter."  
   (interactive)  
   (let ((indent (current-indentation))  
         (type (read-string "Datatype type parameter (default none): "))  
         (name (read-string (concat "Name of datatype: "))))  
     (insert (concat "datatype "  
                     (if (string= type "") "" (concat type " "))  
                     name " ="))  
     (insert "\n")  
     (indent-to (+ sml-indent-level indent))))  
   
 (defun sml-form-abstype ()  
   "Insert an abstype declaration, prompting for name and type parameter."  
   (interactive)  
   (let ((indent(current-indentation))  
         (type (read-string "Abstype type parameter (default none): "))  
         (name (read-string "Name of abstype: ")))  
     (insert (concat "abstype "  
                     (if (string= type "") "" (concat type " "))  
                     name " ="))  
     (insert "\n")  
     (indent-to (+ sml-indent-level indent))  
     (save-excursion  
       (insert "\n")  
       (indent-to indent)  
       (insert "with\n")  
       (indent-to (+ sml-indent-level indent))  
       (insert "\n")  
       (indent-to indent)  
       (insert "end"))))  
   
808  ;;; & do the user's customisation  ;;; & do the user's customisation
809  (run-hooks 'sml-load-hook)  (run-hooks 'sml-load-hook)
810    

Legend:
Removed from v.333  
changed lines
  Added in v.334

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0