changelog shortlog tags changeset files revisions annotate raw

msf-abbrev.el

changeset 66: 5b737eefe5ea
author: kim.vanwyk
date: Wed Nov 10 15:19:03 2010 +0200 (18 months ago)
permissions: -rw-r--r--
description: Adding CSharp Mode and Google Weather 
     1;;; msf-abbrev.el --- maintain abbrevs in a directory tree

     2

     3;; Copyright (C) 2004,2005 Free Software Foundation, Inc.

     4

     5;; Author: Benjamin Rutt <brutt@bloomington.in.us>

     6;; Version: 1.0beta3

     7

     8;; This file is free software; you can redistribute it and/or modify

     9;; it under the terms of the GNU General Public License as published by

    10;; the Free Software Foundation; either version 2, or (at your option)

    11;; any later version.

    12

    13;; This file is distributed in the hope that it will be useful,

    14;; but WITHOUT ANY WARRANTY; without even the implied warranty of

    15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    16;; GNU General Public License for more details.

    17

    18;; You should have received a copy of the GNU General Public License

    19;; along with GNU Emacs; see the file COPYING.  If not, write to

    20;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,

    21;; Boston, MA 02111-1307, USA.

    22

    23;;; Commentary:

    24

    25;; This package allows you to place your abbrevs into your filesystem,

    26;; in a special directory tree.  More information and a demo available at

    27;; http://www.bloomington.in.us/~brutt/msf-abbrev.html

    28

    29(require 'cl)

    30

    31;; xemacs compat

    32(unless (boundp 'undo-in-progress)

    33  (defvar undo-in-progress nil

    34   "Placeholder defvar from msf-abbrev package.")

    35  (defadvice undo-more (around msf-abbrev-undo-more activate)

    36     (let ((undo-in-progress t)) (ad-do-it))))

    37

    38(defgroup msf-abbrev nil

    39  "Load abbrevs from a filesystem tree."

    40  :group 'convenience)

    41

    42;; begin user customizable vars

    43(defcustom msf-abbrev-root nil

    44  "*Root directory of user abbreviation files.

    45

    46This directory should have subdirectories such as c-mode, lisp-mode, etc."

    47  :group 'msf-abbrev

    48  :type 'path)

    49

    50(defcustom msf-abbrev-verbose nil

    51  "*Whether to be verbose for various msf-abbrev actions."

    52  :group 'msf-abbrev

    53  :type 'boolean)

    54

    55(defcustom msf-abbrev-expand-function 'msf-abbrev-expand-function-default

    56  "*Which function should be called to expand a abbrev in a file.

    57

    58The function should take one argument, the filename to expand.

    59This function will be used for all files except those with .el

    60extensions, which will be handled by the elisp interpreter

    61directly."

    62  :group 'msf-abbrev

    63  :type 'function)

    64

    65(defcustom msf-abbrev-expand-hook nil

    66  "Hook called after expansion of an msf abbrev."

    67  :group 'msf-abbrev

    68  :type 'hook)

    69

    70(defcustom msf-abbrev-indent-after-expansion nil

    71  "*Whether to indent the region inserted after the abbrev is expanded.

    72

    73This is only relevant when the default expandsion function is

    74used (see `msf-abbrev-expand-function')."

    75  :group 'msf-abbrev

    76  :type 'boolean)

    77;; end of user customizable vars

    78

    79(defvar msf-abbrev-fields-created 0)

    80

    81;; begin inlined fld.el stuff

    82(defvar fld-last-group-id nil)

    83(defvar fld-id-to-group-id (make-hash-table))

    84(defvar fld-group-id-to-exit-point (make-hash-table))

    85

    86(defvar fld-keymap (make-sparse-keymap))

    87(define-key fld-keymap (kbd "M-RET") 'fld-cleanup-form-at-point)

    88(define-key fld-keymap (kbd "TAB") 'fld-next)

    89(define-key fld-keymap (kbd "S-TAB") 'fld-prev)

    90(define-key fld-keymap (kbd "<S-iso-lefttab>") 'fld-prev)

    91(defvar fld-choose-keymap (copy-keymap fld-keymap))

    92(define-key fld-choose-keymap (kbd "RET") 'fld-choose)			       

    93(defvar fld-category-defaults nil)

    94(setq fld-category-defaults

    95      `(face highlight front-sticky t rear-sticky t

    96	     keymap ,fld-keymap))

    97(setplist 'fld-category fld-category-defaults)

    98

    99(defvar fld-id-next 0)

   100(defun fld-nextid ()

   101  (setq fld-id-next (1+ fld-id-next))

   102  fld-id-next)

   103

   104(defvar fld-group-id-next 0)

   105(defun fld-nextgroupid ()

   106  (setq fld-group-id-next (1+ fld-group-id-next))

   107  fld-group-id-next)

   108

   109(defun fld-currgroupid ()

   110  (interactive)

   111  fld-group-id-next)

   112

   113(defsubst fld-in ()

   114  (if (get-text-property (point) 'fld-id) t nil))

   115

   116(defun fld-after ()

   117  (interactive)

   118  (and (not (fld-in))

   119       (not (bobp))

   120       (save-excursion

   121	 (forward-char -1)

   122	 (fld-in))))

   123

   124(defun fld-id ()

   125  (assert (or (fld-in) (fld-after)))

   126  (save-excursion

   127    (when (fld-after)

   128      (fld-focus))

   129    (get-text-property (point) 'fld-id)))

   130

   131(defun fld-group-id ()

   132  (interactive)

   133  (assert (or (fld-in) (fld-after)))

   134  (save-excursion

   135    (when (fld-after)

   136      (fld-focus))

   137    (get-text-property (point) 'fld-group-id)))

   138

   139(defun fld-focus ()

   140  (assert (or (fld-in) (fld-after)))

   141  (when (fld-after)

   142    (forward-char -1)))

   143

   144(defun fld-beginning ()

   145  (assert (or (fld-in) (fld-after)))

   146  (let ((pt nil)

   147	(thisid nil)

   148	(done nil))

   149    (save-excursion

   150      (fld-focus)

   151      (setq thisid (get-text-property (point) 'fld-id))

   152      (if (bobp)

   153	  (setq pt (point-min))

   154	(while (not done)

   155	  (if (eq thisid (get-text-property (point) 'fld-id))

   156	      (progn

   157		(forward-char -1)

   158		(when (eq (point) (point-min))

   159		  (setq pt (point-min))

   160		  (if (not (eq thisid (get-text-property (point) 'fld-id)))

   161		      (setq pt (1+ pt)))

   162		  (setq done t)))

   163	    (setq pt (1+ (point)))

   164	    (setq done t)))))

   165    pt))

   166

   167

   168(defun fld-end ()

   169  (assert (or (fld-in) (fld-after)))

   170  (if (fld-after)

   171      (point)

   172    (let ((pt nil))

   173      (save-excursion

   174	(setq pt (or (next-single-property-change (point) 'fld-id)

   175		     (point-max))))

   176      pt)))

   177

   178(defun fld-cleanup-form-at-point ( )

   179  (interactive)

   180  (when (or (fld-in) (fld-after))

   181    (fld-cleanup (fld-group-id))))

   182

   183(defun fld-cleanup (gid)

   184  (interactive)

   185  (fld-disable-monitoring)

   186  (setq fld-ressurection-id nil

   187	fld-ressurection-now nil

   188	fld-ressurection-pos nil

   189	fld-transition-to-typed-id nil

   190	fld-transition-to-typed-now nil)

   191  (let ((ids

   192	 (delq nil

   193	       (mapcar

   194		(lambda (ls)

   195		  (if (eq gid (caddr ls))

   196		      (car ls)

   197		    nil))

   198		(fld-list-in-buffer)))))

   199    (mapc

   200     (lambda (id)

   201       (remhash id fld-id-to-group-id))

   202     ids)

   203    (remhash gid fld-group-id-to-exit-point)

   204    (save-excursion

   205      (mapcar

   206       (lambda (id_point_groupid)

   207	 (when (member (car id_point_groupid) ids)

   208	   (goto-char (cadr id_point_groupid))

   209	   (when (get-text-property (point) 'fld-choices)

   210	     (remove-text-properties

   211	      (point) (fld-end)

   212	      '(keymap nil fld-choices nil)))

   213	   (remove-text-properties

   214	    (point) (fld-end)

   215	    '(category nil fld-id nil fld-group-id nil fld-state nil))))

   216       (fld-list-in-buffer))))

   217  (fld-enable-monitoring))

   218

   219(defun fld-find-next-startpos-same-group ()

   220  (assert (or (fld-in) (fld-after)))

   221  (let ((done nil)

   222	(tmp nil)

   223	(result nil)

   224	(gid (fld-group-id)))

   225    (save-excursion

   226      (goto-char (fld-end))

   227      (when (and (fld-in)

   228		 (eq gid (fld-group-id)))

   229	(setq done t

   230	      result (point))))

   231    (if (not done)

   232	(save-excursion

   233	  (while (not done)

   234	    (setq tmp (next-single-property-change (fld-end) 'fld-id))

   235	    (if (not tmp)

   236		(setq done t)

   237	      (if (eq gid (get-text-property tmp 'fld-group-id))

   238		  (setq done t

   239			result tmp)

   240		(goto-char tmp))))))

   241    result))

   242

   243(defun fld-find-prev-startpos-same-group ()

   244  (assert (or (fld-in) (fld-after)))

   245  (let ((done nil)

   246	(tmp nil)

   247	(result nil)

   248	(gid (fld-group-id)))

   249    (save-excursion

   250      (while (not done)

   251	(setq tmp (previous-single-property-change (fld-beginning) 'fld-id))

   252	(if (not tmp)

   253	    (setq done t)

   254	  (goto-char tmp)

   255	  (fld-focus)

   256	  (if (eq gid (get-text-property (point) 'fld-group-id))

   257	      (setq done t

   258		    result (fld-beginning))))))

   259    result))

   260

   261(defun fld-next ()

   262  (interactive)

   263  (assert (or (fld-in) (fld-after)))

   264  (let ((next (fld-find-next-startpos-same-group))

   265	(loc nil)

   266	(id nil)

   267	(gid nil))

   268    (if next

   269	(goto-char next)

   270      (save-excursion

   271	(fld-focus)

   272	(setq gid (get-text-property (point) 'fld-group-id))

   273	(setq loc (gethash gid fld-group-id-to-exit-point)))

   274      (when loc

   275	;; cleanup form, and go to departure location

   276	(fld-cleanup gid)

   277	(goto-char loc)))))

   278

   279(defun fld-prev ()

   280  (interactive)

   281  (assert (or (fld-in) (fld-after)))

   282  (let ((prev (fld-find-prev-startpos-same-group)))

   283    (when prev

   284      (goto-char prev))))

   285

   286(defun fld-make (text group-id)

   287  (let* ((id (fld-nextid)))

   288    (puthash id group-id fld-id-to-group-id)

   289    (add-text-properties 0 (length text)

   290			 `(category fld-category

   291				    fld-id ,id

   292				    fld-group-id ,group-id

   293				    fld-state untyped)

   294			 text)

   295    text))

   296

   297(defun fld-choose-1 (prompt choices-list existing-choice)

   298  "Choose an item from a list."

   299  (let* (i map done o choice-index choice-info out)

   300    (setq map (make-sparse-keymap))

   301    (setq i 0)

   302    (setq choice-index 0)

   303    (kill-buffer (get-buffer-create " fld-choose"))

   304    (with-current-buffer (get-buffer-create " fld-choose")

   305      (erase-buffer)

   306      (insert "Make your choice, C-g aborts:\n\n")

   307      (mapc

   308       (lambda (c)

   309	 (insert c)

   310	 (setq choice-info (cons (cons i (list (line-number-at-pos)

   311						       (length c)))

   312					 choice-info))

   313	 (when (equal existing-choice c)

   314	   (setq choice-index i))

   315	 (setq i (1+ i))

   316	 (insert "\n"))

   317       choices-list)

   318      (setq choice-info (reverse choice-info))

   319      (goto-char (point-min))

   320      (forward-line 2)

   321      (forward-line choice-index)

   322      (setq o (make-overlay (line-beginning-position)

   323			    (+ (line-beginning-position)

   324			       (cadr (cdr (assoc choice-index choice-info))))))

   325      (overlay-put o 'face 'bold-italic))

   326    (save-window-excursion

   327      (delete-other-windows)

   328      (let ((buf (get-buffer " fld-choose")))

   329	(fit-window-to-buffer (display-buffer buf))

   330	(while (not done)

   331	  (let (

   332;; 		(cursor-in-echo-area t)

   333		(keys nil))

   334	    (setq keys (read-key-sequence-vector prompt))

   335;; 	    (message "keys are %s" keys)

   336	    (cond

   337	     ((equal keys [up])

   338	      (when (> choice-index 0)

   339		(set-buffer buf)

   340		(setq choice-index (1- choice-index))

   341		(goto-line (car (cdr (assoc choice-index choice-info))))

   342		(move-overlay o

   343			      (line-beginning-position)

   344			      (+ (line-beginning-position)

   345				 (cadr (cdr (assoc choice-index

   346						  choice-info)))))))

   347	     ((equal keys [down])

   348	      (when (< choice-index (1- i))

   349		(set-buffer buf)

   350		(setq choice-index (1+ choice-index))

   351		(goto-line (car (cdr (assoc choice-index choice-info))))

   352		(move-overlay o

   353			      (line-beginning-position)

   354			      (+ (line-beginning-position)

   355				 (cadr (cdr (assoc choice-index

   356						  choice-info)))))))

   357	     ((equal keys [13])

   358	      (setq out (nth choice-index choices-list)

   359		    done t))

   360	     ((equal keys [7])

   361	      (setq done t))

   362	     (t nil))))))

   363    (message "")

   364    out))

   365

   366;; (fld-choose-1 "Pick a letter" '("a" "b" "cabbie") "b")

   367

   368(defun fld-choose ()

   369  (interactive)

   370  (assert (or (fld-in) (fld-after)))

   371  (let ((choices nil)

   372	(choice nil)

   373	(existing-choice nil))

   374    (save-excursion

   375      (fld-focus)

   376      (setq choices (get-text-property (point) 'fld-choices))

   377      (setq existing-choice (buffer-substring-no-properties (fld-beginning)

   378							    (fld-end))))

   379    (setq choice (fld-choose-1 "choose one" choices existing-choice))

   380    (when (member choice choices)

   381;;       (message "replacing with %s" choice)

   382      (save-excursion

   383	(let ((props nil)

   384	      (oldpt nil)

   385	      (inhibit-modification-hooks t))

   386	(fld-focus)

   387	(goto-char (fld-beginning))

   388	(setq props (text-properties-at (point)))

   389	(delete-region (fld-beginning) (fld-end))

   390	(setq oldpt (point))

   391	(insert choice)

   392	(add-text-properties oldpt (point) props))))))

   393

   394(defun fld-insert-choice (default choices group-id)

   395  (interactive)

   396  (let ((old-pt (point)))

   397    (fld-insert default group-id)

   398    (add-text-properties old-pt (point)

   399			 `(fld-choices

   400			   ,(mapcar

   401			     (lambda (x)

   402			       (set-text-properties 0 (length x) nil x)

   403			       x) choices)))

   404    (put-text-property old-pt (point) 'keymap fld-choose-keymap)))

   405

   406(defun fld-list-in-buffer ()

   407  ;; return list of 3-tuples:  (id starting-position group-id)

   408  (let ((out nil)

   409	(pt nil)

   410	(flds (make-hash-table)))

   411    (save-excursion

   412      (goto-char (point-min))

   413      (when (fld-in)

   414	(puthash (fld-id) (list (point) (fld-group-id)) flds)

   415	(goto-char (fld-end)))

   416      (while (not (eobp))

   417	(if (fld-in)

   418	    (progn

   419	      (puthash (fld-id) (list (point) (fld-group-id)) flds)

   420	      (goto-char (fld-end)))

   421	  (setq pt (next-single-property-change (point) 'fld-id))

   422	  (if (not pt)

   423	      (goto-char (point-max))

   424	    (goto-char pt)

   425	    (puthash (fld-id) (list (point) (fld-group-id)) flds)

   426	    (goto-char (fld-end))))))

   427    (maphash

   428     (lambda (k v)

   429       (setq out (cons (cons k v) out)))

   430     flds)

   431    ;; (message "lsout: %s" (reverse out))

   432    (reverse out)))

   433

   434(defun fld-kill-replaced-regions ()

   435  (let ((inhibit-modification-hooks t))

   436    (save-excursion

   437      (goto-char (point-min))

   438      (while (not (eobp))

   439	(if (get-text-property (point) 'fld-about-to-be-replaced)

   440	    (delete-region (point) (1+ (point))) 

   441	  (forward-char 1))))))

   442

   443(defvar fld-detect-before nil)

   444(defvar fld-ressurection-pos nil)

   445(defvar fld-ressurection-id nil)

   446(defvar fld-ressurection-now nil)

   447(defvar fld-transition-to-typed-now nil)

   448(defvar fld-transition-to-typed-id nil)

   449(defvar fld-transition-to-typed-gid nil)

   450(defvar fld-during-save nil)

   451(defun fld-detect-pre (beg end)

   452  (if undo-in-progress

   453      nil

   454    (if (eq beg end) ;; insertion

   455	(progn

   456	  (cond

   457	   ((or (fld-in) (fld-after))

   458	    (save-excursion

   459	      (fld-focus)

   460	      (when (and (eq (get-text-property (point) 'fld-state) 'untyped)

   461			 (not fld-during-save))	;; avoid

   462		;; require-final-newline

   463		;; corner case

   464		(setq fld-transition-to-typed-id

   465		      (get-text-property (point) 'fld-id)

   466		      fld-transition-to-typed-gid

   467		      (get-text-property (point) 'fld-group-id)

   468		      fld-transition-to-typed-now t)

   469		(add-text-properties

   470		 (fld-beginning) (fld-end)

   471		 '(fld-about-to-be-replaced t)))))

   472	   ((eq (point) fld-ressurection-pos)

   473	    (setq fld-ressurection-now t))

   474	   (t nil)))

   475      ;; deletion

   476      (setq fld-detect-before (fld-list-in-buffer)))))

   477(defun fld-detect-post (beg end len)

   478;;   (if

   479;;       nil

   480;;       ;; (> beg end)

   481;;       (message "fld-detect-post: beg < end ?  %s < %s" beg end)

   482  (if undo-in-progress

   483      nil

   484    (if (eq beg end)

   485	(progn

   486	  ;; deletion

   487	  (let ((flds-now (fld-list-in-buffer)))

   488	    (when (< (length flds-now) (length fld-detect-before))

   489;; 	      (message "yo, we lost fields: %s"

   490;; 		       (set-difference (mapcar 'car fld-detect-before)

   491;; 				       (mapcar 'car flds-now)))

   492	      (let ((ls (copy-sequence fld-detect-before))

   493		    (done nil)

   494		    (id nil))

   495		(while (and (not done) ls)

   496		  (if (eq (point) (cadr (car ls)))

   497		      (progn

   498			(setq done t)

   499			(setq id (car (car ls))))

   500		    (setq ls (cdr ls))))

   501		(if (not id)

   502		    (setq fld-ressurection-pos nil)

   503;; 		  (message "could ressurect id %s" id)

   504		  (setq fld-ressurection-pos (point))

   505		  (setq fld-ressurection-id id))))))

   506      ;; insertion

   507      (cond

   508       ((eq fld-transition-to-typed-now t)

   509	(setq fld-transition-to-typed-now nil)

   510	(add-text-properties

   511	 beg end

   512	 `(category fld-category

   513		    fld-id ,fld-transition-to-typed-id

   514		    fld-group-id ,fld-transition-to-typed-gid

   515		    fld-state typed))

   516	(remove-text-properties beg end

   517				'(fld-about-to-be-replaced nil))

   518	(fld-kill-replaced-regions))

   519       ((eq fld-ressurection-now t)

   520	(setq fld-ressurection-now nil)

   521	(let ((inhibit-modification-hooks t))

   522	  (add-text-properties

   523	   beg end

   524	   `(category fld-category

   525		      fld-id ,fld-ressurection-id

   526		      fld-group-id ,(gethash fld-ressurection-id

   527					     fld-id-to-group-id)

   528		      fld-state typed))))

   529       (nil t)))))

   530

   531(defun fld-before-save ()

   532  (setq fld-during-save t))

   533(defun fld-after-save ()

   534  (setq fld-during-save nil))

   535

   536(defadvice yank (around fld-handle-yank activate)

   537  (let ((after nil)

   538;; 	(debug-on-error t)

   539	)

   540    (if (or (fld-in) (fld-after))

   541	(progn

   542	  (when (fld-after)

   543	    (setq after t))

   544	  (let ((inhibit-modification-hooks t)

   545		(yank-excluded-properties t)

   546		(old-point (point))

   547		(old-id (save-excursion (fld-focus) (fld-id))))

   548	    (when (eq (get-text-property (point) 'fld-state) 'untyped)

   549	      (add-text-properties

   550	       (fld-beginning) (fld-end)

   551	       '(fld-about-to-be-replaced t)))

   552	    ad-do-it

   553	    (add-text-properties

   554	     old-point (point)

   555	     `(category fld-category

   556			fld-id ,old-id

   557			fld-group-id ,(gethash old-id fld-id-to-group-id)

   558			fld-state typed))

   559	    (fld-kill-replaced-regions)))

   560      ad-do-it)))

   561

   562;; faster yank advice?

   563(defadvice yank (after fld-handle-yank-after activate)

   564  (when mark-active

   565    (let ((fld-id-at-mark (get-text-property (mark) 'fld-id)))

   566      (if (or fld-id-at-mark

   567	      (next-single-property-change (mark) 'fld-id nil (point)))

   568	  (let ((pos (mark))

   569		(end (point)))

   570	    (while (< pos end)

   571	      (when (get-text-property pos 'fld-id)

   572		(add-text-properties pos (1+ pos)

   573				     '(category fld-category)))

   574	      (setq pos (1+ pos))))))))

   575

   576;; slower yank advice

   577;; (defadvice yank (after fld-handle-yank-after activate)

   578;;   (let ((yanked (copy-sequence (car kill-ring)))

   579;; 	(s nil)

   580;; ;; 	(debug-on-error t)

   581;; 	(preserve-fld-props nil))

   582;;     (while (> (length yanked) 0)

   583;;       (setq s (substring yanked 0 1))

   584;;       (if (get-text-property 0 'fld-id s)

   585;; 	  (progn

   586;; 	    (setq preserve-fld-props t)

   587;; 	    (setq yanked ""))

   588;; 	(setq yanked (substring yanked 1))))

   589;;     (if preserve-fld-props

   590;; 	(let ((pos (mark))

   591;; 	      (end (point)))

   592;; 	  (while (< pos end)

   593;; 	    (when (get-text-property pos 'fld-id)

   594;; 	      (add-text-properties pos (1+ pos)

   595;; 				   '(category fld-category)))

   596;; 	    (setq pos (1+ pos)))))))

   597

   598(defadvice expand-abbrev (around fld-handle-expand-abbrev activate)

   599  (let* ((from-fld (or (fld-in) (fld-after)))

   600	 (from-fld-id (and from-fld (fld-id)))

   601	 (from-fld-start (and from-fld (fld-beginning)))

   602	 (fields-before (fld-currgroupid)))

   603    ad-do-it

   604    (when from-fld

   605      (let ((inhibit-modification-hooks t))

   606	(if (eq (fld-currgroupid) fields-before) ;; didn't make new

   607	                                         ;; form

   608	    (add-text-properties

   609	     from-fld-start (point)

   610	     `(category fld-category

   611			fld-id ,from-fld-id

   612			fld-group-id ,(gethash from-fld-id fld-id-to-group-id)

   613			fld-state typed))

   614	  ;; made new form, assimilate into our group

   615	  (save-excursion

   616	    (let ((flds (fld-list-in-buffer)))

   617	      (mapc

   618	       (lambda (id_point_groupid)

   619		 (let ((id (car id_point_groupid))

   620		       (pt (cadr id_point_groupid))

   621		       (gid (caddr id_point_groupid)))

   622		   (when (eq gid fld-last-group-id)

   623		     (goto-char pt)

   624		     (puthash id (gethash from-fld-id fld-id-to-group-id)

   625			      fld-id-to-group-id)

   626		     (add-text-properties

   627		      (point) (fld-end)

   628		      `(fld-group-id

   629			,(gethash from-fld-id fld-id-to-group-id))))))

   630	       flds))))))))

   631

   632(defadvice dabbrev-expand (around fld-handle-dabbrev-expand activate)

   633  (let* ((from-fld (or (fld-in) (fld-after)))

   634	 (orig-point (point))

   635	 (from-fld-start (and from-fld (fld-beginning)))

   636	 (from-fld-id (and from-fld (fld-id))))

   637    ad-do-it

   638    (when from-fld

   639      (add-text-properties

   640       from-fld-start (point)

   641       `(category fld-category

   642		  fld-id ,from-fld-id

   643		  fld-group-id ,(gethash from-fld-id fld-id-to-group-id)

   644		  fld-state typed)))))

   645

   646(defun fld-enable-monitoring ()

   647  (add-hook 'before-change-functions 'fld-detect-pre nil t)

   648  (add-hook 'after-change-functions 'fld-detect-post nil t)

   649  (add-hook 'before-save-hook 'fld-before-save nil t)

   650  (add-hook 'after-save-hook 'fld-after-save nil t))

   651

   652(defun fld-disable-monitoring ()

   653  (remove-hook 'before-change-functions 'fld-detect-pre t)

   654  (remove-hook 'after-change-functions 'fld-detect-post t)

   655  (remove-hook 'before-save-hook 'fld-before-save t)

   656  (remove-hook 'after-save-hook 'fld-after-save t))

   657

   658(defun fld-insert (text group-id)

   659  (fld-disable-monitoring)

   660  (setq fld-last-group-id group-id)

   661  (let ((fld (fld-make text group-id)))

   662    (insert fld)))

   663

   664(defun fld-set-exit-location (point-or-marker)

   665  (puthash fld-last-group-id point-or-marker fld-group-id-to-exit-point))

   666

   667(defun fld-activate ()

   668  (fld-enable-monitoring))

   669

   670(defun msf-abbrev-expand-function-default (file &optional transform-func)

   671  (let* ((orig-buffer (current-buffer))

   672	 (cursor-leave-point nil)

   673	 (insertion-point-begin (point-marker))

   674	 (insertion-point-end nil)

   675	 (trigger-line-opening-whitespace nil)

   676	 (text-expanded nil)

   677	 (work-buffer nil)

   678	 (fields-created-this-abbrev 0)

   679	 (gid (1+ (fld-currgroupid)))

   680	 (set-endpoint nil)

   681	 (first-field-marker nil))

   682    (setq text-expanded

   683	  (with-temp-buffer

   684	    (insert-file-contents file)

   685	    (buffer-substring-no-properties (point-min) (point-max))))

   686

   687    ;; replace any <query "Loop iterator: ">-style snippets first before

   688    ;; insertion

   689    (setq text-expanded

   690	  (let ((query-alist nil))

   691	    (with-temp-buffer

   692	      (insert text-expanded)

   693	      (goto-char (point-min))

   694	      (while (re-search-forward "\\(<\\(QUERY\\|query\\) \"\\(.*?\\)\">\\)" nil t)

   695		(let ((beginpt (match-beginning 1))

   696		      (endpt (match-end 1))

   697		      (key (match-string 3)))

   698		  (when (not (assoc key query-alist))

   699		    (setq query-alist

   700			  (cons (list key (read-from-minibuffer key))

   701				query-alist)))

   702		  (goto-char beginpt)

   703		  (delete-region beginpt endpt)

   704		  (insert (cadr (assoc key query-alist)))))

   705	      (buffer-substring-no-properties (point-min) (point-max)))))

   706

   707    ;; insert the text

   708    (insert text-expanded)

   709    (setq insertion-point-end (point-marker))

   710    (set-marker-insertion-type insertion-point-end t)

   711

   712    ;; remove all props

   713    (set-text-properties insertion-point-begin

   714			 insertion-point-end

   715			 nil)

   716

   717    (when transform-func

   718      (goto-char insertion-point-begin)

   719      (apply transform-func (list insertion-point-begin insertion-point-end)))

   720

   721    ;; replace any <varlookup "user-full-name">-style snippets

   722    (goto-char insertion-point-begin)

   723    (while (re-search-forward "<\\(VARLOOKUP\\|varlookup\\) \"\\(.*?\\)\">"

   724			      insertion-point-end t)

   725      (let ((v (match-string 2)))

   726	(replace-match (eval (intern v)) nil t)))

   727

   728    ;; replace any <ELISP "(insert "hi")">-style snippets

   729    (goto-char insertion-point-begin)

   730    (while (re-search-forward "<\\(ELISP\\|elisp\\) \"\\(.*?\\)\">" insertion-point-end t)

   731      (let ((v (match-string 2)))

   732	(replace-match "")

   733	(eval (read v))))

   734

   735    ;; replace any <COMMENT "blah blah"> snippets

   736    (goto-char insertion-point-begin)

   737    (while (re-search-forward "^<\\(COMMENT\\|comment\\) \"\\(.*?\\)\">$" insertion-point-end t)

   738      (replace-match "")

   739      (let ((kill-ring-old kill-ring))

   740	(kill-line)

   741	(setq kill-ring kill-ring-old)))

   742    (goto-char insertion-point-begin)

   743    (while (re-search-forward "<\\(COMMENT\\|comment\\) \"\\(.*?\\)\">" insertion-point-end t)

   744      (replace-match ""))

   745

   746    ;; calculate the whitespace on the beginning of the trigger line

   747    ;; and mimic it as a prefix throughout insertions

   748    (setq trigger-line-opening-whitespace

   749	  (save-excursion

   750	    (goto-char insertion-point-begin)

   751	    (let ((beg nil)

   752		  (end nil))

   753	      (beginning-of-line)

   754	      (setq beg (point))

   755	      (while (looking-at "[ \t]")

   756		(forward-char))

   757	      (setq end (point))

   758	      (buffer-substring beg end))))

   759

   760    ;; expand any trigger-line opening whitespace on subsequent lines

   761    (goto-char insertion-point-begin)

   762    (forward-line 1)

   763    (while (< (point) insertion-point-end)

   764      (insert trigger-line-opening-whitespace)

   765      (forward-line 1))

   766

   767    ;; position at end of insertion

   768    (goto-char insertion-point-end)

   769

   770    (save-excursion

   771      (goto-char insertion-point-begin)

   772      (while (re-search-forward "<\\(FORMJUMP\\|field\\) \"\\(.*?\\)\">"

   773				(marker-position insertion-point-end) t)

   774	(let ((txt (match-string 2)))

   775	  (replace-match "" nil t)

   776	  (if (not first-field-marker)

   777	      (setq first-field-marker (point-marker)))

   778	  (fld-insert txt gid))

   779	(setq fields-created-this-abbrev

   780	      (1+ fields-created-this-abbrev))))

   781

   782    ;; handle <choose><choice "OH"><choice "TX"></choose>

   783    (save-excursion

   784      (let ((choice-start nil)

   785	    (choice-stop nil)

   786	    (choices nil))

   787	(goto-char insertion-point-begin)

   788	(while (re-search-forward "<choose>"

   789				  (marker-position insertion-point-end) t)

   790	  (replace-match "" nil t)

   791	  (setq choice-start (point-marker))

   792	  (assert (re-search-forward "</choose>"

   793				     (marker-position insertion-point-end) t))

   794	  (replace-match "" nil t)

   795	  (setq choice-stop (point-marker))

   796	  (goto-char choice-start)

   797	  (if (or (not first-field-marker)

   798		  (< (point-marker) first-field-marker))

   799	      (setq first-field-marker (point-marker)))

   800	  (setq choices nil)

   801	  (while (re-search-forward "<choice \"\\(.*?\\)\">"

   802				    (marker-position choice-stop) t)

   803	    (setq choices (cons (match-string 1) choices))

   804	    (replace-match "" nil t))

   805	  (setq choices (reverse choices))

   806	  (fld-insert-choice (car choices) choices gid)

   807	  (setq fields-created-this-abbrev

   808	      (1+ fields-created-this-abbrev)))))

   809

   810    (save-excursion

   811      (goto-char insertion-point-begin)

   812      (when (re-search-forward "<endpoint>"

   813			       (marker-position insertion-point-end) t)

   814	(replace-match "" nil t)

   815	(fld-set-exit-location (point-marker))

   816	(setq set-endpoint t)))

   817    

   818    (when (> fields-created-this-abbrev 0)

   819      (when (not set-endpoint)

   820	(fld-set-exit-location insertion-point-end)

   821	(setq set-endpoint t))

   822      (fld-nextgroupid) ;; only use the group id if we added some form fields

   823      

   824      (fld-activate)

   825      

   826      ;; leave cursor at first field location from this expansion

   827      (goto-char first-field-marker)

   828      (set-marker first-field-marker nil))

   829    

   830    (save-excursion

   831      (save-restriction

   832	(goto-char insertion-point-begin)

   833	(when (re-search-forward "<\\(CURSOR\\|cursor\\)>"

   834				 (marker-position insertion-point-end) t)

   835	  (replace-match "")

   836	  (setq cursor-leave-point (point)))))

   837    (when cursor-leave-point

   838      (goto-char cursor-leave-point))

   839    

   840    ;; possibly indent the expanded text

   841    (when msf-abbrev-indent-after-expansion

   842      (indent-region insertion-point-begin insertion-point-end))

   843

   844    (setq msf-abbrev-fields-created

   845	  (+ msf-abbrev-fields-created fields-created-this-abbrev))))

   846

   847(defun msf-abbrev-expand-file (file)

   848  (if (string-match "\\.el$" file)

   849      ;; if the abbrev is an .el file, just use elisp to evaluate it

   850      (let ((evalstr

   851	     (with-temp-buffer

   852	       (insert-file-contents file)

   853	       (buffer-substring (point-min) (point-max)))))

   854	(msf-abbrev-eval (read evalstr)))

   855    (let ((transform-func nil)

   856	  (transform-file (concat file "_")))

   857      (when (file-exists-p transform-file)

   858	(setq transform-func

   859	      (read

   860	       (with-temp-buffer

   861		 (insert-file-contents transform-file)

   862		 (buffer-substring (point-min) (point-max))))))

   863      (apply msf-abbrev-expand-function (list file transform-func))))

   864  (run-hooks 'msf-abbrev-expand-hook))

   865

   866(defun msf-abbrev-directory-files (dir)

   867  (delq nil

   868	(mapcar

   869	 (lambda (x)

   870	   (let ((basenm (file-name-nondirectory x)))

   871	     (if (or (string-match "^\\." basenm)

   872		     (string-match "~$" basenm)

   873		     (string-match "_$" basenm))

   874		 nil x)))

   875	 (directory-files dir t))))

   876

   877(defun msf-abbrev-report-if-verbose (abbr modename)

   878  (when msf-abbrev-verbose

   879    (message "defined abbrev %10s for mode %s" abbr modename)))

   880

   881(defun msf-abbrev-eval (text)

   882;;   (message "about to eval %s" text)

   883  (eval text))

   884

   885(defun msf-abbrev-locate-mode-dir (modename)

   886  (let ((cpls

   887	 (file-name-all-completions

   888	  (concat modename ".aliases.") msf-abbrev-root))

   889	(dest modename))

   890    (when cpls

   891      (assert (string-match "\\(.*\\)\\.aliases\\.\\(.*\\)" (car cpls)))

   892      (setq dest (match-string 2 (car cpls))))

   893    (concat (file-name-as-directory msf-abbrev-root) dest)))

   894

   895(defmacro msf-abbrev-try-require (lib)

   896  `(let ((succeeded t))

   897     (condition-case err

   898         (require ,lib)

   899       (error (setq succeeded nil)))

   900     succeeded))

   901(defvar msf-abbrev-table nil)

   902

   903(defun msf-abbrev-load ()

   904  "Load all abbrevs under `msf-abbrev-root'.

   905

   906`msf-abbrev-root' should have subdirectories like c-mode,

   907c++-mode, cperl-mode. etc. each of which contain files whose

   908names will be used as abbreviations, expanding to the file's

   909contents.  The subdirectory `global' is special and loads up

   910global-abbrev-table, thus its abbrevs are active in every mode."

   911  (let* ((modedirs (msf-abbrev-directory-files msf-abbrev-root))

   912	 (sym nil)

   913	 (symstr nil)

   914	 (modename nil)

   915	 (fetchdir nil)

   916	 (method nil)

   917	 (hookname nil)

   918	 (abbrs-this-mode nil))

   919    (mapc

   920     (lambda (modedir)

   921       (setq modename (file-name-nondirectory modedir))

   922       (if (string-match "^\\(.*\\)\\.aliases\\.\\(.*\\)$" modename)

   923	   (setq fetchdir (match-string 2 modename)

   924		 modename (match-string 1 modename))

   925		 

   926	 (setq fetchdir modename))

   927       (setq abbrs-this-mode nil)

   928       (cond

   929	((and (boundp (setq sym (intern (concat modename "-abbrev-table"))))

   930	      (eval sym))

   931	 (setq method 'abbrev-table))

   932	((boundp (setq sym (intern (concat modename "-hook"))))

   933	 (setq method 'mode-hook))

   934	(t (progn

   935	     (message "WARNING from msf-abbrev.el:  no abbrev table %s-abbrev-table and no hook %s-hook, abbrevs for mode %s will not be loaded"

   936		      modename modename modename)

   937	     (setq method nil))))

   938       (setq symstr (symbol-name sym))

   939       (let ((abbrs (msf-abbrev-directory-files (concat (file-name-as-directory msf-abbrev-root) fetchdir)))

   940	     (abbr-sans-extension nil))

   941	 (mapc

   942	  (lambda (abbr)

   943	    (setq abbr-sans-extension

   944		  (file-name-sans-extension abbr))

   945	    (setq abbrs-this-mode

   946		  (cons (file-name-nondirectory abbr-sans-extension)

   947			abbrs-this-mode))

   948	    ;; define the new function

   949	    (let ((newfuncnm

   950		   (format "msf-abbrev-generatedfunc-%s-%s"

   951			   modename (file-name-nondirectory

   952				     abbr-sans-extension))))

   953	      ;; defun it

   954	      (msf-abbrev-eval

   955	       `(defun ,(intern newfuncnm) ()

   956		  (interactive)

   957		  (msf-abbrev-expand-file ,abbr)

   958		  'returning-nonnil-here-inhibits-self-insertion))

   959

   960	      ;; add property to inhibit expansion of trigger (e.g. SPC)

   961	      (msf-abbrev-eval

   962	       `(put ',(intern newfuncnm) 'no-self-insert t))

   963

   964	      (cond

   965	       ;; abbrev table method

   966	       ((eq method 'abbrev-table)

   967		(msf-abbrev-eval

   968		 `(define-abbrev ,sym ,(file-name-nondirectory

   969					abbr-sans-extension) ""

   970		    ',(intern newfuncnm)))

   971		(msf-abbrev-report-if-verbose

   972		 (file-name-nondirectory abbr-sans-extension) modename))

   973

   974	       ;; mode hook method

   975	       ((eq method 'mode-hook)

   976

   977		(let ((evtext

   978		       `(add-hook ',sym

   979				  (lambda ()

   980				    (define-abbrev local-abbrev-table

   981				      ,(file-name-nondirectory

   982					abbr-sans-extension) ""

   983				      ',(intern newfuncnm))))))

   984		  (msf-abbrev-eval evtext))

   985		(msf-abbrev-report-if-verbose

   986		 (file-name-nondirectory abbr-sans-extension) modename))

   987

   988	       ;; do nothing if no <MODE>-abbrev-table or <MODE>-hook exists

   989	       (t nil))))

   990

   991	  abbrs)

   992	 (add-to-list 'msf-abbrev-table

   993		      (list (file-name-nondirectory modedir)

   994			    (sort abbrs-this-mode 'string<)))))

   995     modedirs)))

   996

   997(defun msf-abbrev-reload-after-save ()

   998  (let* ((bfn (expand-file-name (buffer-file-name)))

   999	 (root (expand-file-name msf-abbrev-root)))

  1000    (when (string-match (concat "^" root) bfn)

  1001      ;; we just saved an msf-abbrev file, so reload the tree

  1002      (msf-abbrev-load))))

  1003(add-hook 'after-save-hook 'msf-abbrev-reload-after-save)

  1004

  1005(defun msf-abbrev-goto-root ()

  1006  (interactive)

  1007  (let ((current-mode-str (format "%s" major-mode)))

  1008    (if (assoc current-mode-str msf-abbrev-table)

  1009	  (dired (msf-abbrev-locate-mode-dir current-mode-str))

  1010      (dired msf-abbrev-root))))

  1011

  1012(defun msf-abbrev-define-new-abbrev-this-mode ()

  1013  (interactive)

  1014  (let* ((current-mode-str

  1015	  (cond

  1016	   ;; create an exception case for AUCTeX

  1017	   ((and

  1018	     (eq major-mode 'latex-mode)

  1019	     (boundp 'AUCTeX-version))

  1020	    "LaTeX-mode")

  1021	   ((and

  1022	     (eq major-mode 'tex-mode)

  1023	     (boundp 'AUCTeX-version))

  1024	    "TeX-mode")

  1025	   (t (format "%s" major-mode))))

  1026	 (d (msf-abbrev-locate-mode-dir current-mode-str)))

  1027    (when (or (file-exists-p d)

  1028	      (and (y-or-n-p

  1029		    (format

  1030		     "Could not find directory %s, create it? " d))

  1031		   (progn

  1032		     (make-directory d)

  1033		     t)))

  1034      (let ((name (read-from-minibuffer "Abbrev name: ")))

  1035	(find-file (concat (file-name-as-directory d) name))))))

  1036

  1037(defun msf-abbrev-abbrev-choose ()

  1038  (interactive)

  1039  (let ((tbl (assoc (format "%s" major-mode) msf-abbrev-table))

  1040	(choice nil))

  1041    (when tbl

  1042      (setq choice (completing-read "Choose abbrev: " (cadr tbl) nil t))

  1043      (insert choice)

  1044      (expand-abbrev))))

  1045

  1046(defun msf-abbrev-string-no-properties (str)

  1047  (with-temp-buffer

  1048    (insert str)

  1049    (buffer-substring-no-properties (point-min) (point-max))))

  1050

  1051(defun msf-abbrev-abbrev-complete ()

  1052  (interactive)

  1053  (let ((tbl (assoc (format "%s" major-mode) msf-abbrev-table))

  1054	(choice nil)

  1055	(thing (thing-at-point 'word))

  1056	(s nil)

  1057	(result nil))

  1058    (when (and thing tbl)

  1059      (setq tbl (cadr tbl))

  1060      (setq s (msf-abbrev-string-no-properties thing))

  1061      (setq result (try-completion s tbl))

  1062      (when result

  1063	(cond

  1064	 ((eq result t)

  1065	  (delete-windows-on (get-buffer-create "*msf-abbrev completions*"))

  1066	  (delete-region (- (point) (length s)) (point))

  1067	  (insert result)

  1068	  (expand-abbrev))

  1069	 ((not (string= result s))

  1070	  (delete-windows-on (get-buffer-create "*msf-abbrev completions*"))

  1071	  (delete-region (- (point) (length s)) (point))

  1072	  (insert result)

  1073	  (when (member result tbl)

  1074	    (expand-abbrev)))

  1075	 (t

  1076	  (with-output-to-temp-buffer "*msf-abbrev completions*"

  1077	    (display-completion-list

  1078	     (all-completions s tbl)))))))))

  1079

  1080(provide 'msf-abbrev)