.emacs.d/yasnippet.el
author Adam Gomaa <adam@gomaa.us>
Sun Dec 18 13:13:02 2011 -0500
changeset 521 67f37d330ad0
permissions -rw-r--r--
Remove project & _list_projects, I don't use them anymore.
code@51
     1
;;; yasnippet.el --- Yet another snippet extension for Emacs.
code@51
     2
code@51
     3
;; Copyright 2008 pluskid
code@51
     4
;; 
code@51
     5
;; Author: pluskid <pluskid@gmail.com>
code@51
     6
;; Version: 0.5.2
code@51
     7
;; X-URL: http://code.google.com/p/yasnippet/
code@51
     8
code@51
     9
;; This file is free software; you can redistribute it and/or modify
code@51
    10
;; it under the terms of the GNU General Public License as published by
code@51
    11
;; the Free Software Foundation; either version 2, or (at your option)
code@51
    12
;; any later version.
code@51
    13
code@51
    14
;; This file is distributed in the hope that it will be useful,
code@51
    15
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
code@51
    16
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
code@51
    17
;; GNU General Public License for more details.
code@51
    18
code@51
    19
;; You should have received a copy of the GNU General Public License
code@51
    20
;; along with GNU Emacs; see the file COPYING.  If not, write to
code@51
    21
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
code@51
    22
;; Boston, MA 02111-1307, USA.
code@51
    23
code@51
    24
;;; Commentary:
code@51
    25
code@51
    26
;; Basic steps to setup:
code@51
    27
;;   1. Place `yasnippet.el' in your `load-path'.
code@51
    28
;;   2. In your .emacs file:
code@51
    29
;;        (require 'yasnippet)
code@51
    30
;;   3. Place the `snippets' directory somewhere. E.g: ~/.emacs.d/snippets
code@51
    31
;;   4. In your .emacs file
code@51
    32
;;        (yas/initialize)
code@51
    33
;;        (yas/load-directory "~/.emacs.d/snippets")
code@51
    34
;;
code@51
    35
;; For more information and detailed usage, refer to the project page:
code@51
    36
;;      http://code.google.com/p/yasnippet/
code@51
    37
code@51
    38
(require 'cl)
code@51
    39
code@51
    40
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
    41
;; User customizable variables
code@51
    42
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
    43
(defvar yas/key-syntaxes (list "w" "w_" "w_." "^ ")
code@51
    44
  "A list of syntax of a key. This list is tried in the order
code@51
    45
to try to find a key. For example, if the list is '(\"w\" \"w_\").
code@51
    46
And in emacs-lisp-mode, where \"-\" has the syntax of \"_\":
code@51
    47
code@51
    48
foo-bar
code@51
    49
code@51
    50
will first try \"bar\", if not found, then \"foo-bar\" is tried.")
code@51
    51
code@51
    52
(defvar yas/root-directory nil
code@51
    53
  "The (list of) root directory that stores the snippets for each 
code@51
    54
major modes.")
code@51
    55
code@51
    56
(defvar yas/indent-line t
code@51
    57
  "Each (except the 1st) line of the snippet template is indented to
code@51
    58
current column if this variable is non-`nil'.")
code@51
    59
(make-variable-buffer-local 'yas/indent-line)
code@51
    60
code@51
    61
(defvar yas/trigger-key (kbd "TAB")
code@51
    62
  "The key to bind as a trigger of snippet.")
code@51
    63
(defvar yas/next-field-key (kbd "TAB")
code@51
    64
  "The key to navigate to next field.")
code@51
    65
code@51
    66
(defvar yas/keymap (make-sparse-keymap)
code@51
    67
  "The keymap of snippet.")
code@51
    68
(define-key yas/keymap yas/next-field-key 'yas/next-field-group)
code@51
    69
(define-key yas/keymap (kbd "S-TAB") 'yas/prev-field-group)
code@51
    70
(define-key yas/keymap (kbd "<S-iso-lefttab>") 'yas/prev-field-group)
code@51
    71
(define-key yas/keymap (kbd "<S-tab>") 'yas/prev-field-group)
code@51
    72
(define-key yas/keymap (kbd "<backtab>") 'yas/prev-field-group)
code@51
    73
code@51
    74
(defvar yas/show-all-modes-in-menu nil
code@51
    75
  "Currently yasnippet only all \"real modes\" to menubar. For
code@51
    76
example, you define snippets for \"cc-mode\" and make it the
code@51
    77
parent of `c-mode', `c++-mode' and `java-mode'. There's really
code@51
    78
no such mode like \"cc-mode\". So we don't show it in the yasnippet
code@51
    79
menu to avoid the menu becoming too big with strange modes. The
code@51
    80
snippets defined for \"cc-mode\" can still be accessed from
code@51
    81
menu-bar->c-mode->parent (or c++-mode, java-mode, all are ok).
code@51
    82
However, if you really like to show all modes in the menu, set
code@51
    83
this variable to t.")
code@51
    84
(defvar yas/use-menu t
code@51
    85
  "If this is set to `t', all snippet template of the current
code@51
    86
mode will be listed under the menu \"yasnippet\".")
code@51
    87
(defvar yas/trigger-symbol " =>"
code@51
    88
  "The text that will be used in menu to represent the trigger.")
code@51
    89
code@51
    90
(defface yas/field-highlight-face
code@51
    91
  '((((class color) (background light)) (:background "DarkSeaGreen2"))
code@51
    92
    (t (:background "DimGrey")))
code@51
    93
  "The face used to highlight a field of snippet.")
code@51
    94
(defface yas/mirror-highlight-face
code@51
    95
  '((((class color) (background light)) (:background "LightYellow2"))
code@51
    96
    (t (:background "gray22")))
code@51
    97
  "The face used to highlight mirror fields of a snippet.")
code@51
    98
code@51
    99
(defvar yas/window-system-popup-function #'yas/dropdown-list-popup-for-template
code@51
   100
  "When there's multiple candidate for a snippet key. This function
code@51
   101
is called to let user select one of them. `yas/text-popup-function'
code@51
   102
is used instead when not in a window system.")
code@51
   103
(defvar yas/text-popup-function #'yas/dropdown-list-popup-for-template
code@51
   104
  "When there's multiple candidate for a snippet key. If not in a
code@51
   105
window system, this function is called to let user select one of
code@51
   106
them. `yas/window-system-popup-function' is used instead when in
code@51
   107
a window system.")
code@51
   108
code@51
   109
(defvar yas/extra-mode-hooks
code@51
   110
  '(ruby-mode-hook actionscript-mode-hook)
code@51
   111
  "A list of mode-hook that should be hooked to enable yas/minor-mode.
code@51
   112
Most modes need no special consideration. Some mode (like ruby-mode)
code@51
   113
doesn't call `after-change-major-mode-hook' need to be hooked explicitly.")
code@51
   114
code@51
   115
(defvar yas/after-exit-snippet-hook
code@51
   116
  '()
code@51
   117
  "Hooks to run after a snippet exited.
code@51
   118
The hooks will be run in an environment where some variables bound to 
code@51
   119
proper values:
code@51
   120
 * yas/snippet-beg : The beginning of the region of the snippet.
code@51
   121
 * yas/snippet-end : Similar to beg.")
code@51
   122
code@51
   123
(defvar yas/before-expand-snippet-hook
code@51
   124
  '()
code@51
   125
  "Hooks to run after a before expanding a snippet.")
code@51
   126
code@51
   127
(defvar yas/buffer-local-condition 
code@51
   128
  '(if (and (not (bobp))
code@51
   129
	    (or (equal "font-lock-comment-face"
code@51
   130
		       (get-char-property (1- (point))
code@51
   131
					  'face))
code@51
   132
		(equal "font-lock-string-face"
code@51
   133
		       (get-char-property (1- (point))
code@51
   134
					  'face))))
code@51
   135
       '(require-snippet-condition . force-in-comment)
code@51
   136
     t)
code@51
   137
  "Condition to yasnippet local to each buffer.
code@51
   138
code@51
   139
    * If yas/buffer-local-condition evaluate to nil, snippet
code@51
   140
      won't be expanded.
code@51
   141
code@51
   142
    * If it evaluate to the a cons cell where the car is the
code@51
   143
      symbol require-snippet-condition and the cdr is a
code@51
   144
      symbol (let's call it requirement):
code@51
   145
       * If the snippet has no condition, then it won't be
code@51
   146
         expanded.
code@51
   147
       * If the snippet has a condition but evaluate to nil or
code@51
   148
         error occured during evaluation, it won't be expanded.
code@51
   149
       * If the snippet has a condition that evaluate to
code@51
   150
         non-nil (let's call it result):
code@51
   151
          * If requirement is t, the snippet is ready to be
code@51
   152
            expanded.
code@51
   153
          * If requirement is eq to result, the snippet is ready
code@51
   154
            to be expanded.
code@51
   155
          * Otherwise the snippet won't be expanded.
code@51
   156
    * If it evaluate to other non-nil value:
code@51
   157
       * If the snippet has no condition, or has a condition that
code@51
   158
         evaluate to non-nil, it is ready to be expanded.
code@51
   159
       * Otherwise, it won't be expanded.
code@51
   160
code@51
   161
Here's an example:
code@51
   162
code@51
   163
 (add-hook 'python-mode-hook
code@51
   164
           '(lambda ()
code@51
   165
              (setq yas/buffer-local-condition
code@51
   166
                    '(if (python-in-string/comment)
code@51
   167
                         '(require-snippet-condition . force-in-comment)
code@51
   168
                       t))))")
code@51
   169
code@51
   170
(defvar yas/fallback-behavior 'call-other-command
code@51
   171
  "The fall back behavior of YASnippet when it can't find a snippet
code@51
   172
to expand. 
code@51
   173
code@51
   174
 * 'call-other-command means try to temporarily disable
code@51
   175
    YASnippet and call other command bound to `yas/trigger-key'.
code@51
   176
 * 'return-nil means return nil.")
code@51
   177
code@51
   178
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
   179
;; Internal variables
code@51
   180
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
   181
(defvar yas/version "0.5.2")
code@51
   182
code@51
   183
(defvar yas/snippet-tables (make-hash-table)
code@51
   184
  "A hash table of snippet tables corresponding to each major-mode.")
code@51
   185
(defvar yas/menu-table (make-hash-table)
code@51
   186
  "A hash table of menus of corresponding major-mode.")
code@51
   187
(defvar yas/menu-keymap (make-sparse-keymap "YASnippet"))
code@51
   188
;; empty menu will cause problems, so we insert some items
code@51
   189
(define-key yas/menu-keymap [yas/about]
code@51
   190
  '(menu-item "About" yas/about))
code@51
   191
(define-key yas/menu-keymap [yas/reload]
code@51
   192
  '(menu-item "Reload all snippets" yas/reload-all))
code@51
   193
(define-key yas/menu-keymap [yas/load]
code@51
   194
  '(menu-item "Load snippets..." yas/load-directory))
code@51
   195
(define-key yas/menu-keymap [yas/separator]
code@51
   196
  '(menu-item "--"))
code@51
   197
code@51
   198
(defvar yas/known-modes
code@51
   199
  '(ruby-mode rst-mode)
code@51
   200
  "A list of mode which is well known but not part of emacs.")
code@51
   201
(defconst yas/escape-backslash
code@51
   202
  (concat "YASESCAPE" "BACKSLASH" "PROTECTGUARD"))
code@51
   203
(defconst yas/escape-dollar
code@51
   204
  (concat "YASESCAPE" "DOLLAR" "PROTECTGUARD"))
code@51
   205
(defconst yas/escape-backquote
code@51
   206
  (concat "YASESCAPE" "BACKQUOTE" "PROTECTGUARD"))
code@51
   207
code@51
   208
(defconst yas/field-regexp
code@51
   209
  (concat "$\\([0-9]+\\)" "\\|"
code@51
   210
	  "${\\(?:\\([0-9]+\\):\\)?\\([^}]*\\)}"))
code@51
   211
code@51
   212
(defvar yas/snippet-id-seed 0
code@51
   213
  "Contains the next id for a snippet")
code@51
   214
(defun yas/snippet-next-id ()
code@51
   215
  (let ((id yas/snippet-id-seed))
code@51
   216
    (incf yas/snippet-id-seed)
code@51
   217
    id))
code@51
   218
code@51
   219
(defvar yas/overlay-modification-hooks
code@51
   220
  (list 'yas/overlay-modification-hook)
code@51
   221
  "The list of hooks to the overlay modification event.")
code@51
   222
(defvar yas/overlay-insert-in-front-hooks
code@51
   223
  (list 'yas/overlay-insert-in-front-hook)
code@51
   224
  "The list of hooks of the overlay inserted in front event.")
code@51
   225
(defvar yas/keymap-overlay-modification-hooks
code@51
   226
  (list 'yas/overlay-maybe-insert-behind-hook)
code@51
   227
  "The list of hooks of the big keymap overlay modification event.")
code@51
   228
code@51
   229
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
   230
;; YASnippet minor mode
code@51
   231
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
   232
(defvar yas/minor-mode-map (make-sparse-keymap)
code@51
   233
  "The keymap of yas/minor-mode")
code@51
   234
(defvar yas/minor-mode-on-hook nil
code@51
   235
  "Hook to call when yas/minor-mode is on.")
code@51
   236
(defvar yas/minor-mode-off-hook nil
code@51
   237
  "Hook to call when yas/minor-mode is off.")
code@51
   238
(define-minor-mode yas/minor-mode
code@51
   239
  "Toggle YASnippet mode.
code@51
   240
With no argument, this command toggles the mode.
code@51
   241
positive prefix argument turns on the mode.
code@51
   242
Negative prefix argument turns off the mode.
code@51
   243
code@51
   244
When YASnippet mode is enabled, the TAB key
code@51
   245
expands snippets of code depending on the mode.
code@51
   246
code@51
   247
You can customize the key through `yas/trigger-key'."
code@51
   248
  ;; The initial value.
code@51
   249
  nil
code@51
   250
  ;; The indicator for the mode line.
code@51
   251
  " yas"
code@51
   252
  :group 'editing
code@51
   253
  (define-key yas/minor-mode-map yas/trigger-key 'yas/expand))
code@51
   254
code@51
   255
(defun yas/minor-mode-on ()
code@51
   256
  "Turn on YASnippet minor mode."
code@51
   257
  (interactive)
code@51
   258
  (yas/minor-mode 1))
code@51
   259
(defun yas/minor-mode-off ()
code@51
   260
  "Turn off YASnippet minor mode."
code@51
   261
  (interactive)
code@51
   262
  (yas/minor-mode -1))
code@51
   263
code@51
   264
code@51
   265
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
   266
;; Internal Structs
code@51
   267
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
   268
(defstruct (yas/template (:constructor yas/make-template
code@51
   269
				       (content name condition)))
code@51
   270
  "A template for a snippet."
code@51
   271
  content
code@51
   272
  name
code@51
   273
  condition)
code@51
   274
(defstruct (yas/snippet (:constructor yas/make-snippet ()))
code@51
   275
  "A snippet."
code@51
   276
  (groups nil)
code@51
   277
  (exit-marker nil)
code@51
   278
  (id (yas/snippet-next-id) :read-only t)
code@51
   279
  (overlay nil))
code@51
   280
(defstruct (yas/group (:constructor yas/make-group (primary-field snippet)))
code@51
   281
  "A group contains a list of field with the same number."
code@51
   282
  primary-field
code@51
   283
  (fields (list primary-field))
code@51
   284
  (next nil)
code@51
   285
  (prev nil)
code@51
   286
  snippet)
code@51
   287
(defstruct (yas/field 
code@51
   288
	    (:constructor yas/make-field (overlay number value transform)))
code@51
   289
  "A field in a snippet."
code@51
   290
  overlay
code@51
   291
  number
code@51
   292
  transform
code@51
   293
  value)
code@51
   294
(defstruct (yas/snippet-table (:constructor yas/make-snippet-table ()))
code@51
   295
  "A table to store snippets for a perticular mode."
code@51
   296
  (hash (make-hash-table :test 'equal))
code@51
   297
  (parent nil))
code@51
   298
code@51
   299
(defun yas/snippet-valid? (snippet)
code@51
   300
  "See if snippet is valid (ie. still alive)."
code@51
   301
  (and (not (null snippet))
code@51
   302
       (not (null (yas/snippet-overlay snippet)))
code@51
   303
       (not (null (overlay-start (yas/snippet-overlay snippet))))))
code@51
   304
code@51
   305
(defun yas/snippet-add-field (snippet field)
code@51
   306
  "Add FIELD to SNIPPET."
code@51
   307
  (let ((group (find field
code@51
   308
		     (yas/snippet-groups snippet)
code@51
   309
		     :test
code@51
   310
		     '(lambda (field group)
code@51
   311
			(and (not (null (yas/field-number field)))
code@51
   312
			     (not (null (yas/group-number group)))
code@51
   313
			     (= (yas/field-number field)
code@51
   314
				(yas/group-number group)))))))
code@51
   315
    (if group
code@51
   316
	(yas/group-add-field group field)
code@51
   317
      (push (yas/make-group field snippet)
code@51
   318
	    (yas/snippet-groups snippet)))))
code@51
   319
code@51
   320
(defun yas/group-value (group)
code@51
   321
  "Get the default value of the field group."
code@51
   322
  (or (yas/field-value
code@51
   323
       (yas/group-primary-field group))
code@51
   324
      ""))
code@51
   325
(defun yas/group-number (group)
code@51
   326
  "Get the number of the field group."
code@51
   327
  (yas/field-number
code@51
   328
   (yas/group-primary-field group)))
code@51
   329
(defun yas/group-add-field (group field)
code@51
   330
  "Add a field to the field group. If the value of the primary 
code@51
   331
field is nil and that of the field is not nil, the field is set
code@51
   332
as the primary field of the group."
code@51
   333
  (push field (yas/group-fields group))
code@51
   334
  (when (and (null (yas/field-value (yas/group-primary-field group)))
code@51
   335
	     (yas/field-value field))
code@51
   336
    (setf (yas/group-primary-field group) field)))
code@51
   337
code@51
   338
(defun yas/snippet-field-compare (field1 field2)
code@51
   339
  "Compare two fields. The field with a number is sorted first.
code@51
   340
If they both have a number, compare through the number. If neither
code@51
   341
have, compare through the start point of the overlay."
code@51
   342
  (let ((n1 (yas/field-number field1))
code@51
   343
	(n2 (yas/field-number field2)))
code@51
   344
    (if n1
code@51
   345
	(if n2
code@51
   346
	    (< n1 n2)
code@51
   347
	  t)
code@51
   348
      (if n2
code@51
   349
	  nil
code@51
   350
	(< (overlay-start (yas/field-overlay field1))
code@51
   351
	   (overlay-start (yas/field-overlay field2)))))))
code@51
   352
code@51
   353
(defun yas/template-condition-predicate (condition)
code@51
   354
  (condition-case err
code@51
   355
      (save-excursion
code@51
   356
	(save-restriction
code@51
   357
	  (save-match-data
code@51
   358
	    (eval condition))))
code@51
   359
    (error (progn
code@51
   360
	     (message (format "[yas]error in condition evaluation: %s"
code@51
   361
			      (error-message-string err)))
code@51
   362
	     nil))))
code@51
   363
code@51
   364
(defun yas/filter-templates-by-condition (templates)
code@51
   365
  "Filter the templates using the condition. The rules are:
code@51
   366
code@51
   367
 * If the template has no condition, it is kept.
code@51
   368
 * If the template's condition eval to non-nil, it is kept.
code@51
   369
 * Otherwise (eval error or eval to nil) it is filtered."
code@51
   370
  (remove-if '(lambda (pair)
code@51
   371
		(let ((condition (yas/template-condition (cdr pair))))
code@51
   372
		  (if (null condition)
code@51
   373
		      (if yas/require-template-condition
code@51
   374
			  t
code@51
   375
			nil)
code@51
   376
		    (let ((result 
code@51
   377
			   (yas/template-condition-predicate condition)))
code@51
   378
		      (if (eq yas/require-template-condition t)
code@51
   379
			  result
code@51
   380
			(not (eq result yas/require-template-condition)))))))
code@51
   381
	     templates))
code@51
   382
code@51
   383
(defun yas/snippet-table-fetch (table key)
code@51
   384
  "Fetch a snippet binding to KEY from TABLE. If not found,
code@51
   385
fetch from parent if any."
code@51
   386
  (let ((templates (yas/filter-templates-by-condition
code@51
   387
		    (gethash key (yas/snippet-table-hash table)))))
code@51
   388
    (when (and (null templates)
code@51
   389
	       (not (null (yas/snippet-table-parent table))))
code@51
   390
      (setq templates (yas/snippet-table-fetch
code@51
   391
		       (yas/snippet-table-parent table)
code@51
   392
		       key)))
code@51
   393
    templates))
code@51
   394
(defun yas/snippet-table-store (table full-key key template)
code@51
   395
  "Store a snippet template in the table."
code@51
   396
  (puthash key
code@51
   397
	   (yas/modify-alist (gethash key
code@51
   398
				      (yas/snippet-table-hash table))
code@51
   399
			     full-key
code@51
   400
			     template)
code@51
   401
	   (yas/snippet-table-hash table)))
code@51
   402
code@51
   403
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
   404
;; Internal functions
code@51
   405
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
   406
(defun yas/ensure-minor-mode-priority ()
code@51
   407
  "Ensure that the key binding of yas/minor-mode takes priority."
code@51
   408
  (unless (eq 'yas/minor-mode
code@51
   409
	      (caar minor-mode-map-alist))
code@51
   410
    (setq minor-mode-map-alist
code@51
   411
	  (cons
code@51
   412
	   (cons 'yas/minor-mode yas/minor-mode-map)
code@51
   413
	   (assq-delete-all 'yas/minor-mode
code@51
   414
			    minor-mode-map-alist)))))
code@51
   415
code@51
   416
(defun yas/real-mode? (mode)
code@51
   417
  "Try to find out if MODE is a real mode. The MODE bound to
code@51
   418
a function (like `c-mode') is considered real mode. Other well
code@51
   419
known mode like `ruby-mode' which is not part of Emacs might
code@51
   420
not bound to a function until it is loaded. So yasnippet keeps
code@51
   421
a list of modes like this to help the judgement."
code@51
   422
  (or (fboundp mode)
code@51
   423
      (find mode yas/known-modes)))
code@51
   424
code@51
   425
(defun yas/eval-string (string)
code@51
   426
  "Evaluate STRING and convert the result to string."
code@51
   427
  (condition-case err
code@51
   428
      (save-excursion
code@51
   429
	(save-restriction
code@51
   430
	  (save-match-data
code@51
   431
	    (format "%s" (eval (read string))))))
code@51
   432
    (error (format "(error in elisp evaluation: %s)" 
code@51
   433
		   (error-message-string err)))))
code@51
   434
(defun yas/calculate-field-value (field value)
code@51
   435
  "Calculate the value of the field. If there's a transform
code@51
   436
for this field, apply it. Otherwise, the value is returned
code@51
   437
unmodified."
code@51
   438
  (let ((text value)
code@51
   439
	(transform (yas/field-transform field)))
code@51
   440
    (if transform
code@51
   441
	(yas/eval-string transform)
code@51
   442
      text)))
code@51
   443
(defsubst yas/replace-all (from to)
code@51
   444
  "Replace all occurance from FROM to TO."
code@51
   445
  (goto-char (point-min))
code@51
   446
  (while (search-forward from nil t)
code@51
   447
    (replace-match to t t)))
code@51
   448
code@51
   449
(defun yas/snippet-table (mode)
code@51
   450
  "Get the snippet table corresponding to MODE."
code@51
   451
  (let ((table (gethash mode yas/snippet-tables)))
code@51
   452
    (unless table
code@51
   453
      (setq table (yas/make-snippet-table))
code@51
   454
      (puthash mode table yas/snippet-tables))
code@51
   455
    table))
code@51
   456
(defsubst yas/current-snippet-table ()
code@51
   457
  "Get the snippet table for current major-mode."
code@51
   458
  (yas/snippet-table major-mode))
code@51
   459
code@51
   460
(defun yas/menu-keymap-for-mode (mode)
code@51
   461
  "Get the menu keymap correspondong to MODE."
code@51
   462
  (let ((keymap (gethash mode yas/menu-table)))
code@51
   463
    (unless keymap
code@51
   464
      (setq keymap (make-sparse-keymap))
code@51
   465
      (puthash mode keymap yas/menu-table))
code@51
   466
    keymap))
code@51
   467
code@51
   468
(defun yas/current-key ()
code@51
   469
  "Get the key under current position. A key is used to find
code@51
   470
the template of a snippet in the current snippet-table."
code@51
   471
  (let ((start (point))
code@51
   472
	(end (point))
code@51
   473
	(syntaxes yas/key-syntaxes)
code@51
   474
	syntax done templates)
code@51
   475
    (while (and (not done) syntaxes)
code@51
   476
      (setq syntax (car syntaxes))
code@51
   477
      (setq syntaxes (cdr syntaxes))
code@51
   478
      (save-excursion
code@51
   479
	(skip-syntax-backward syntax)
code@51
   480
	(setq start (point)))
code@51
   481
      (setq templates
code@51
   482
	    (yas/snippet-table-fetch
code@51
   483
	     (yas/current-snippet-table)
code@51
   484
	     (buffer-substring-no-properties start end)))
code@51
   485
      (if templates
code@51
   486
	  (setq done t)
code@51
   487
	(setq start end)))
code@51
   488
    (list templates
code@51
   489
	  start
code@51
   490
	  end)))
code@51
   491
code@51
   492
(defun yas/synchronize-fields (field-group)
code@51
   493
  "Update all fields' text according to the primary field."
code@51
   494
  (when (yas/snippet-valid? (yas/group-snippet field-group))
code@51
   495
    (save-excursion
code@51
   496
      (let* ((inhibit-modification-hooks t)
code@51
   497
	     (primary (yas/group-primary-field field-group))
code@51
   498
	     (primary-overlay (yas/field-overlay primary))
code@51
   499
	     (text (buffer-substring-no-properties (overlay-start primary-overlay)
code@51
   500
						   (overlay-end primary-overlay))))
code@51
   501
	(dolist (field (yas/group-fields field-group))
code@51
   502
	  (let* ((field-overlay (yas/field-overlay field))
code@51
   503
		 (original-length (- (overlay-end field-overlay)
code@51
   504
				     (overlay-start field-overlay))))
code@51
   505
	    (unless (eq field-overlay primary-overlay)
code@51
   506
	      (goto-char (overlay-start field-overlay))
code@51
   507
	      (insert (yas/calculate-field-value field text))
code@51
   508
	      (if (= (overlay-start field-overlay)
code@51
   509
		     (overlay-end field-overlay))
code@51
   510
		  (move-overlay field-overlay
code@51
   511
				(overlay-start field-overlay)
code@51
   512
				(point))
code@51
   513
		(delete-char original-length)))))))))
code@51
   514
  
code@51
   515
(defun yas/overlay-modification-hook (overlay after? beg end &optional length)
code@51
   516
  "Modification hook for snippet field overlay."
code@51
   517
  (when (and after? (not undo-in-progress))
code@51
   518
    (yas/synchronize-fields (overlay-get overlay 'yas/group))))
code@51
   519
(defun yas/overlay-insert-in-front-hook (overlay after? beg end &optional length)
code@51
   520
  "Hook for snippet overlay when text is inserted in front of a snippet field."
code@51
   521
  (when after?
code@51
   522
    (let ((field-group (overlay-get overlay 'yas/group))
code@51
   523
	  (inhibit-modification-hooks t))
code@51
   524
      (when (not (overlay-get overlay 'yas/modified?))
code@51
   525
	(overlay-put overlay 'yas/modified? t)
code@51
   526
	(when (> (overlay-end overlay) end)
code@51
   527
	  (save-excursion
code@51
   528
	    (goto-char end)
code@51
   529
	    (delete-char (- (overlay-end overlay) end)))))
code@51
   530
     (yas/synchronize-fields field-group))))
code@51
   531
(defun yas/overlay-maybe-insert-behind-hook (overlay after? beg end &optional length)
code@51
   532
  "Insert behind hook sometimes doesn't get called. I don't know why.
code@51
   533
So I add modification hook in the big overlay and try to detect `insert-behind'
code@51
   534
event manually."
code@51
   535
  (when after?
code@51
   536
    (cond ((and (= beg end)
code@51
   537
		(> length 0)
code@51
   538
		(= (overlay-start overlay)
code@51
   539
		   (overlay-end overlay)))
code@51
   540
	   (yas/exit-snippet (overlay-get overlay 'yas/snippet-reference)))
code@51
   541
	  ((and (= length 0)
code@51
   542
		(> end beg)
code@51
   543
		(null (yas/current-snippet-overlay beg))
code@51
   544
		(not (bobp)))
code@51
   545
	   (let ((field-overlay (yas/current-snippet-overlay (1- beg))))
code@51
   546
	     (if field-overlay
code@51
   547
		 (when (= beg (overlay-end field-overlay))
code@51
   548
		   (move-overlay field-overlay
code@51
   549
				 (overlay-start field-overlay)
code@51
   550
				 end)
code@51
   551
		   (yas/synchronize-fields (overlay-get field-overlay 'yas/group)))
code@51
   552
	       (let ((snippet (yas/snippet-of-current-keymap))
code@51
   553
		     (done nil))
code@51
   554
		 (if snippet
code@51
   555
		     (do* ((groups (yas/snippet-groups snippet) (cdr groups))
code@51
   556
			   (group (car groups) (car groups)))
code@51
   557
			 ((or (null groups)
code@51
   558
			      done))
code@51
   559
		       (setq field-overlay (yas/field-overlay 
code@51
   560
					    (yas/group-primary-field group)))
code@51
   561
		       (when (and (= (overlay-start field-overlay)
code@51
   562
				     (overlay-end field-overlay))
code@51
   563
				  (= beg
code@51
   564
				     (overlay-start field-overlay)))
code@51
   565
			 (move-overlay field-overlay beg end)
code@51
   566
			 (yas/synchronize-fields group)
code@51
   567
			 (setq done t)))))))))))
code@51
   568
code@51
   569
(defun yas/undo-expand-snippet (start end key snippet)
code@51
   570
  "Undo a snippet expansion. Delete the overlays. This undo can't be
code@51
   571
redo-ed."
code@51
   572
  (let ((undo (car buffer-undo-list)))
code@51
   573
    (while (null undo)
code@51
   574
      (setq buffer-undo-list (cdr buffer-undo-list))
code@51
   575
      (setq undo (car buffer-undo-list)))
code@51
   576
    ;; Remove this undo operation record
code@51
   577
    (setq buffer-undo-list (cdr buffer-undo-list))
code@51
   578
  (let ((inhibit-modification-hooks t)
code@51
   579
	(buffer-undo-list t))
code@51
   580
    (yas/exit-snippet snippet)
code@51
   581
    (goto-char start)
code@51
   582
    (delete-char (- end start))
code@51
   583
    (insert key))))
code@51
   584
code@51
   585
(defun yas/expand-snippet (start end template)
code@51
   586
  "Expand snippet at current point. Text between START and END
code@51
   587
will be deleted before inserting template."
code@51
   588
  (run-hooks 'yas/before-expand-snippet-hook)
code@51
   589
code@51
   590
  (goto-char start)
code@51
   591
code@51
   592
  (let ((key (buffer-substring-no-properties start end))
code@51
   593
	(original-undo-list buffer-undo-list)
code@51
   594
	(inhibit-modification-hooks t)
code@51
   595
	(length (- end start))
code@51
   596
	(column (current-column)))
code@51
   597
    (save-restriction
code@51
   598
      (narrow-to-region start start)
code@51
   599
code@51
   600
      (setq buffer-undo-list t)
code@51
   601
      (insert template)
code@51
   602
code@51
   603
      ;; Step 1: do necessary indent
code@51
   604
      (when yas/indent-line
code@51
   605
	(let* ((indent (if indent-tabs-mode
code@51
   606
			   (concat (make-string (/ column tab-width) ?\t)
code@51
   607
				   (make-string (% column tab-width) ?\ ))
code@51
   608
			 (make-string column ?\ ))))
code@51
   609
	  (goto-char (point-min))
code@51
   610
	  (while (and (zerop (forward-line))
code@51
   611
		      (= (current-column) 0))
code@51
   612
	    (insert indent))))
code@51
   613
code@51
   614
      ;; Step 2: protect backslash and backquote
code@51
   615
      (yas/replace-all "\\\\" yas/escape-backslash)
code@51
   616
      (yas/replace-all "\\`" yas/escape-backquote)
code@51
   617
code@51
   618
      ;; Step 3: evaluate all backquotes
code@51
   619
      (goto-char (point-min))
code@51
   620
      (while (re-search-forward "`\\([^`]*\\)`" nil t)
code@51
   621
	(replace-match (yas/eval-string (match-string-no-properties 1))
code@51
   622
		       t t))
code@51
   623
code@51
   624
      ;; Step 4: protect all escapes, including backslash and backquot
code@51
   625
      ;; which may be produced in Step 3
code@51
   626
      (yas/replace-all "\\\\" yas/escape-backslash)
code@51
   627
      (yas/replace-all "\\`" yas/escape-backquote)
code@51
   628
      (yas/replace-all "\\$" yas/escape-dollar)
code@51
   629
code@51
   630
      (let ((snippet (yas/make-snippet)))
code@51
   631
	;; Step 5: Create fields
code@51
   632
	(goto-char (point-min))
code@51
   633
	(while (re-search-forward yas/field-regexp nil t)
code@51
   634
	  (let ((number (or (match-string-no-properties 1)
code@51
   635
			    (match-string-no-properties 2)))
code@51
   636
		(transform nil)
code@51
   637
		(value (match-string-no-properties 3)))
code@51
   638
	    (when (eq (elt value 0) ?\$)
code@51
   639
	      (setq transform (substring value 1))
code@51
   640
	      (setq value nil))
code@51
   641
	    (if (and number
code@51
   642
		     (string= "0" number))
code@51
   643
		(progn
code@51
   644
		  (replace-match "")
code@51
   645
		  (setf (yas/snippet-exit-marker snippet)
code@51
   646
			(copy-marker (point) t)))
code@51
   647
	      (yas/snippet-add-field
code@51
   648
	       snippet
code@51
   649
	       (yas/make-field
code@51
   650
		(make-overlay (match-beginning 0) (match-end 0))
code@51
   651
		(and number (string-to-number number))
code@51
   652
		value
code@51
   653
		transform)))))
code@51
   654
code@51
   655
	;; Step 6: Sort and link each field group
code@51
   656
	(setf (yas/snippet-groups snippet)
code@51
   657
	      (sort (yas/snippet-groups snippet)
code@51
   658
		    '(lambda (group1 group2)
code@51
   659
		       (yas/snippet-field-compare
code@51
   660
			(yas/group-primary-field group1)
code@51
   661
			(yas/group-primary-field group2)))))
code@51
   662
	(let ((prev nil))
code@51
   663
	  (dolist (group (yas/snippet-groups snippet))
code@51
   664
	    (setf (yas/group-prev group) prev)
code@51
   665
	    (when prev
code@51
   666
	      (setf (yas/group-next prev) group))
code@51
   667
	    (setq prev group)))
code@51
   668
code@51
   669
	;; Step 7: Create keymap overlay for snippet
code@51
   670
	(let ((overlay (make-overlay (point-min)
code@51
   671
				     (point-max)
code@51
   672
				     nil
code@51
   673
				     nil
code@51
   674
				     t)))
code@51
   675
	  (overlay-put overlay 
code@51
   676
		       'modification-hooks
code@51
   677
		       yas/keymap-overlay-modification-hooks)
code@51
   678
	  (overlay-put overlay 
code@51
   679
		       'insert-behind-hooks
code@51
   680
		       yas/keymap-overlay-modification-hooks)
code@51
   681
	  (overlay-put overlay 'keymap yas/keymap)
code@51
   682
	  (overlay-put overlay 'yas/snippet-reference snippet)
code@51
   683
	  (setf (yas/snippet-overlay snippet) overlay))
code@51
   684
	
code@51
   685
	;; Step 8: Replace fields with default values
code@51
   686
	(dolist (group (yas/snippet-groups snippet))
code@51
   687
	  (let ((value (yas/group-value group)))
code@51
   688
	    (dolist (field (yas/group-fields group))
code@51
   689
	      (let* ((overlay (yas/field-overlay field))
code@51
   690
		     (start (overlay-start overlay))
code@51
   691
		     (end (overlay-end overlay))
code@51
   692
		     (length (- end start)))
code@51
   693
		(goto-char start)
code@51
   694
		(insert (yas/calculate-field-value field value))
code@51
   695
		(delete-char length)))))
code@51
   696
code@51
   697
	;; Step 9: restore all escape characters
code@51
   698
	(yas/replace-all yas/escape-dollar "$")
code@51
   699
	(yas/replace-all yas/escape-backquote "`")
code@51
   700
	(yas/replace-all yas/escape-backslash "\\")
code@51
   701
code@51
   702
	;; Step 10: Set up properties of overlays
code@51
   703
	(dolist (group (yas/snippet-groups snippet))
code@51
   704
	  (let ((overlay (yas/field-overlay
code@51
   705
			  (yas/group-primary-field group))))
code@51
   706
	    (overlay-put overlay 'yas/snippet snippet)
code@51
   707
	    (overlay-put overlay 'yas/group group)
code@51
   708
	    (overlay-put overlay 'yas/modified? nil)
code@51
   709
	    (overlay-put overlay 'modification-hooks yas/overlay-modification-hooks)
code@51
   710
	    (overlay-put overlay 'insert-in-front-hooks yas/overlay-insert-in-front-hooks)
code@51
   711
	    (overlay-put overlay 'face 'yas/field-highlight-face)
code@51
   712
	    (dolist (field (yas/group-fields group))
code@51
   713
	      (unless (equal overlay (yas/field-overlay field))
code@51
   714
		(overlay-put (yas/field-overlay field)
code@51
   715
			     'face 
code@51
   716
			     'yas/mirror-highlight-face)))))
code@51
   717
code@51
   718
	;; Step 11: move to end and make sure exit-marker exist
code@51
   719
	(goto-char (point-max))
code@51
   720
	(unless (yas/snippet-exit-marker snippet)
code@51
   721
	  (setf (yas/snippet-exit-marker snippet) (copy-marker (point) t)))
code@51
   722
code@51
   723
	;; Step 12: Construct undo information
code@51
   724
	(unless (eq original-undo-list t)
code@51
   725
	  (add-to-list 'original-undo-list
code@51
   726
		       `(apply yas/undo-expand-snippet
code@51
   727
			       ,(point-min)
code@51
   728
			       ,(point-max)
code@51
   729
			       ,key
code@51
   730
			       ,snippet)))
code@51
   731
code@51
   732
	;; Step 13: remove the trigger key
code@51
   733
	(widen)
code@51
   734
	(delete-char length)
code@51
   735
code@51
   736
	(setq buffer-undo-list original-undo-list)
code@51
   737
code@51
   738
	;; Step 14: place the cursor at a proper place
code@51
   739
	(let ((groups (yas/snippet-groups snippet))
code@51
   740
	      (exit-marker (yas/snippet-exit-marker snippet)))
code@51
   741
	  (if groups
code@51
   742
	      (goto-char (overlay-start 
code@51
   743
			  (yas/field-overlay
code@51
   744
			   (yas/group-primary-field
code@51
   745
			    (car groups)))))
code@51
   746
	    ;; no need to call exit-snippet, since no overlay created.
code@51
   747
	    (yas/exit-snippet snippet)))))))
code@51
   748
code@51
   749
(defun yas/current-snippet-overlay (&optional point)
code@51
   750
  "Get the most proper overlay which is belongs to a snippet."
code@51
   751
  (let ((point (or point (point)))
code@51
   752
	(snippet-overlay nil))
code@51
   753
    (dolist (overlay (overlays-at point))
code@51
   754
      (when (overlay-get overlay 'yas/snippet)
code@51
   755
	(if (null snippet-overlay)
code@51
   756
	    (setq snippet-overlay overlay)
code@51
   757
	  (when (> (yas/snippet-id (overlay-get overlay 'yas/snippet))
code@51
   758
		   (yas/snippet-id (overlay-get snippet-overlay 'yas/snippet)))
code@51
   759
	    (setq snippet-overlay overlay)))))
code@51
   760
    snippet-overlay))
code@51
   761
code@51
   762
(defun yas/snippet-of-current-keymap (&optional point)
code@51
   763
  "Get the snippet holding the snippet keymap under POINT."
code@51
   764
  (let ((point (or point (point)))
code@51
   765
	(keymap-snippet nil)
code@51
   766
	(snippet nil))
code@51
   767
    (dolist (overlay (overlays-at point))
code@51
   768
      (setq snippet (overlay-get overlay 'yas/snippet-reference))
code@51
   769
      (when snippet
code@51
   770
	(if (null keymap-snippet)
code@51
   771
	    (setq keymap-snippet snippet)
code@51
   772
	  (when (> (yas/snippet-id snippet)
code@51
   773
		   (yas/snippet-id keymap-snippet))
code@51
   774
	    (setq keymap-snippet snippet)))))
code@51
   775
    keymap-snippet))
code@51
   776
code@51
   777
(defun yas/current-overlay-for-navigation ()
code@51
   778
  "Get current overlay for navigation. Might be overlay at current or previous point."
code@51
   779
  (let ((overlay1 (yas/current-snippet-overlay))
code@51
   780
	(overlay2 (if (bobp)
code@51
   781
		      nil
code@51
   782
		    (yas/current-snippet-overlay (- (point) 1)))))
code@51
   783
    (if (null overlay1)
code@51
   784
	overlay2
code@51
   785
      (if (or (null overlay2)
code@51
   786
	      (eq (overlay-get overlay1 'yas/snippet) 
code@51
   787
		  (overlay-get overlay2 'yas/snippet)))
code@51
   788
	  overlay1
code@51
   789
	(if (> (yas/snippet-id (overlay-get overlay2 'yas/snippet))
code@51
   790
	       (yas/snippet-id (overlay-get overlay1 'yas/snippet)))
code@51
   791
	    overlay2
code@51
   792
	  overlay1)))))
code@51
   793
code@51
   794
(defun yas/navigate-group (group next?)
code@51
   795
  "Go to next of previous field group. Exit snippet if none."
code@51
   796
  (let ((target (if next?
code@51
   797
		    (yas/group-next group)
code@51
   798
		  (yas/group-prev group))))
code@51
   799
    (if target
code@51
   800
	(goto-char (overlay-start
code@51
   801
		    (yas/field-overlay
code@51
   802
		     (yas/group-primary-field target))))
code@51
   803
      (yas/exit-snippet (yas/group-snippet group)))))
code@51
   804
code@51
   805
(defun yas/parse-template ()
code@51
   806
  "Parse the template in the current buffer.
code@51
   807
If the buffer contains a line of \"# --\" then the contents
code@51
   808
above this line are ignored. Variables can be set above this
code@51
   809
line through the syntax:
code@51
   810
code@51
   811
#name : value
code@51
   812
code@51
   813
Here's a list of currently recognized variables:
code@51
   814
code@51
   815
 * name
code@51
   816
 * contributor
code@51
   817
 * condition
code@51
   818
code@51
   819
#name: #include \"...\"
code@51
   820
# --
code@51
   821
#include \"$1\""
code@51
   822
  (goto-char (point-min))
code@51
   823
  (let (template name bound condition)
code@51
   824
    (if (re-search-forward "^# --\n" nil t)
code@51
   825
	(progn (setq template 
code@51
   826
		     (buffer-substring-no-properties (point) 
code@51
   827
						     (point-max)))
code@51
   828
	       (setq bound (point))
code@51
   829
	       (goto-char (point-min))
code@51
   830
	       (while (re-search-forward "^#\\([^ ]+\\) *: *\\(.*\\)$" bound t)
code@51
   831
		 (when (string= "name" (match-string-no-properties 1))
code@51
   832
		   (setq name (match-string-no-properties 2)))
code@51
   833
		 (when (string= "condition" (match-string-no-properties 1))
code@51
   834
		   (setq condition (read (match-string-no-properties 2))))))
code@51
   835
      (setq template
code@51
   836
	    (buffer-substring-no-properties (point-min) (point-max))))
code@51
   837
    (list template name condition)))
code@51
   838
code@51
   839
(defun yas/directory-files (directory file?)
code@51
   840
  "Return directory files or subdirectories in full path."
code@51
   841
  (remove-if (lambda (file)
code@51
   842
	       (or (string-match "^\\."
code@51
   843
				 (file-name-nondirectory file))
code@51
   844
		   (if file?
code@51
   845
		       (file-directory-p file)
code@51
   846
		     (not (file-directory-p file)))))
code@51
   847
	     (directory-files directory t)))
code@51
   848
code@51
   849
(defun yas/make-menu-binding (template)
code@51
   850
  (lexical-let ((template template))
code@51
   851
    (lambda ()
code@51
   852
      (interactive)
code@51
   853
      (yas/expand-snippet (point) 
code@51
   854
			  (point)
code@51
   855
			  template))))
code@51
   856
code@51
   857
(defun yas/modify-alist (alist key value)
code@51
   858
  "Modify ALIST to map KEY to VALUE. return the new alist."
code@51
   859
  (let ((pair (assoc key alist)))
code@51
   860
    (if (null pair)
code@51
   861
	(cons (cons key value)
code@51
   862
	      alist)
code@51
   863
      (setcdr pair value)
code@51
   864
      alist)))
code@51
   865
code@51
   866
(defun yas/fake-keymap-for-popup (templates)
code@51
   867
  "Create a fake keymap for popup menu usage."
code@51
   868
  (cons 'keymap 
code@51
   869
	(mapcar (lambda (pair)
code@51
   870
		  (let* ((template (cdr pair))
code@51
   871
			 (name (yas/template-name template))
code@51
   872
			 (content (yas/template-content template)))
code@51
   873
		    (list content 'menu-item name t)))
code@51
   874
		templates)))
code@51
   875
code@51
   876
(defun yas/point-to-coord (&optional point)
code@51
   877
  "Get the xoffset/yoffset information of POINT.
code@51
   878
If POINT is not given, default is to current point.
code@51
   879
If `posn-at-point' is not available (like in Emacs 21.3),
code@51
   880
t is returned simply."
code@51
   881
  (if (fboundp 'posn-at-point)
code@51
   882
      (let ((x-y (posn-x-y (posn-at-point (or point (point))))))
code@51
   883
	(list (list (+ (car x-y) 10)
code@51
   884
		    (+ (cdr x-y) 20))
code@51
   885
	      (selected-window)))
code@51
   886
    t))
code@51
   887
 
code@51
   888
(defun yas/x-popup-menu-for-template (templates)
code@51
   889
  "Show a popup menu listing templates to let the user select one."
code@51
   890
  (car (x-popup-menu (yas/point-to-coord)
code@51
   891
		     (yas/fake-keymap-for-popup templates))))
code@51
   892
(defun yas/text-popup-for-template (templates)
code@51
   893
  "Can't display popup menu in text mode. Just select the first one."
code@51
   894
  (yas/template-content (cdar templates)))
code@51
   895
(defun yas/dropdown-list-popup-for-template (templates)
code@51
   896
  "Use dropdown-list.el to popup for templates. Better than the 
code@51
   897
default \"select first\" behavior of `yas/text-popup-for-template'.
code@51
   898
You can also use this in window-system.
code@51
   899
code@51
   900
NOTE: You need to download and install dropdown-list.el to use this."
code@51
   901
  (if (fboundp 'dropdown-list)
code@51
   902
      (let ((n (dropdown-list (mapcar (lambda (i)
code@51
   903
					(yas/template-name
code@51
   904
					 (cdr i)))
code@51
   905
				      templates))))
code@51
   906
	(if n
code@51
   907
	    (yas/template-content
code@51
   908
	     (cdr (nth n templates)))
code@51
   909
	  nil))
code@51
   910
    (error "Please download and install dropdown-list.el to use this")))
code@51
   911
code@51
   912
(defun yas/popup-for-template (templates)
code@51
   913
  (if window-system
code@51
   914
      (funcall yas/window-system-popup-function templates)
code@51
   915
    (funcall yas/text-popup-function templates)))
code@51
   916
code@51
   917
(defun yas/load-directory-1 (directory &optional parent)
code@51
   918
  "Really do the job of loading snippets from a directory 
code@51
   919
hierarchy."
code@51
   920
  (let ((mode-sym (intern (file-name-nondirectory directory)))
code@51
   921
	(snippets nil))
code@51
   922
    (with-temp-buffer
code@51
   923
      (dolist (file (yas/directory-files directory t))
code@51
   924
	(when (file-readable-p file)
code@51
   925
	  (insert-file-contents file nil nil nil t)
code@51
   926
	  (push (cons (file-name-nondirectory file)
code@51
   927
		      (yas/parse-template))
code@51
   928
		snippets))))
code@51
   929
    (yas/define-snippets mode-sym
code@51
   930
			 snippets
code@51
   931
			 parent)
code@51
   932
    (dolist (subdir (yas/directory-files directory nil))
code@51
   933
      (yas/load-directory-1 subdir mode-sym))))
code@51
   934
code@51
   935
(defun yas/quote-string (string)
code@51
   936
  "Escape and quote STRING.
code@51
   937
foo\"bar\\! -> \"foo\\\"bar\\\\!\""
code@51
   938
  (concat "\""
code@51
   939
	  (replace-regexp-in-string "[\\\"]"
code@51
   940
				    "\\\\\\&"
code@51
   941
				    string
code@51
   942
				    t)
code@51
   943
	  "\""))
code@51
   944
code@51
   945
(defun yas/compile-bundle
code@51
   946
  (&optional yasnippet yasnippet-bundle snippet-roots code)
code@51
   947
  "Compile snippets in SNIPPET-ROOTS to a single bundle file.
code@51
   948
SNIPPET-ROOTS is a list of root directories that contains the snippets
code@51
   949
definition. YASNIPPET is the yasnippet.el file path. YASNIPPET-BUNDLE
code@51
   950
is the output file of the compile result. CODE is the code you would
code@51
   951
like to used to initialize yasnippet. Here's the default value for
code@51
   952
all the parameters:
code@51
   953
code@51
   954
 (yas/compile-bundle \"yasnippet.el\"
code@51
   955
                     \"./yasnippet-bundle.el\"
code@51
   956
                     '(\"snippets\")
code@51
   957
                     \"(yas/initialize)\")"
code@51
   958
  (when (null yasnippet)
code@51
   959
    (setq yasnippet "yasnippet.el"))
code@51
   960
  (when (null yasnippet-bundle)
code@51
   961
    (setq yasnippet-bundle "./yasnippet-bundle.el"))
code@51
   962
  (when (null snippet-roots)
code@51
   963
    (setq snippet-roots '("snippets")))
code@51
   964
  (when (null code)
code@51
   965
    (setq code "(yas/initialize)"))
code@51
   966
code@51
   967
  (let ((dirs (or (and (listp snippet-roots) snippet-roots)
code@51
   968
		  (list snippet-roots)))
code@51
   969
	(bundle-buffer nil))
code@51
   970
    (with-temp-buffer
code@51
   971
      (setq bundle-buffer (current-buffer))
code@51
   972
      (insert-file-contents yasnippet)
code@51
   973
      (goto-char (point-max))
code@51
   974
      (insert ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
code@51
   975
      (insert ";;;;      Auto-generated code         ;;;;\n")
code@51
   976
      (insert ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
code@51
   977
      (insert code "\n")
code@51
   978
      (flet ((yas/define-snippets 
code@51
   979
	      (mode snippets &optional parent)
code@51
   980
	      (with-current-buffer bundle-buffer
code@51
   981
		(insert ";;; snippets for " (symbol-name mode) "\n")
code@51
   982
		(insert "(yas/define-snippets '" (symbol-name mode) "\n")
code@51
   983
		(insert "'(\n")
code@51
   984
		(dolist (snippet snippets)
code@51
   985
		  (insert "  (" 
code@51
   986
			  (yas/quote-string (car snippet))
code@51
   987
			  " "
code@51
   988
			  (yas/quote-string (cadr snippet))
code@51
   989
			  " "
code@51
   990
			  (if (caddr snippet)
code@51
   991
			      (yas/quote-string (caddr snippet))
code@51
   992
			    "nil")
code@51
   993
			  " "
code@51
   994
			  (if (nth 3 snippet)
code@51
   995
			      (format "'%s" (nth 3 snippet))
code@51
   996
			    "nil")
code@51
   997
			  ")\n"))
code@51
   998
		(insert "  )\n")
code@51
   999
		(insert (if parent
code@51
  1000
			    (concat "'" (symbol-name parent))
code@51
  1001
			  "nil")
code@51
  1002
			")\n\n"))))
code@51
  1003
	    (dolist (dir dirs)
code@51
  1004
	      (dolist (subdir (yas/directory-files dir nil))
code@51
  1005
		(yas/load-directory-1 subdir nil))))
code@51
  1006
      (insert "(provide '"
code@51
  1007
	      (file-name-nondirectory
code@51
  1008
	       (file-name-sans-extension
code@51
  1009
		yasnippet-bundle))
code@51
  1010
	      ")\n")
code@51
  1011
      (setq buffer-file-name yasnippet-bundle)
code@51
  1012
      (save-buffer))))
code@51
  1013
code@51
  1014
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1015
;; User level functions
code@51
  1016
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1017
(defun yas/about ()
code@51
  1018
  (interactive)
code@51
  1019
  (message (concat "yasnippet (version "
code@51
  1020
		   yas/version
code@51
  1021
		   ") -- pluskid <pluskid@gmail.com>")))
code@51
  1022
(defun yas/reload-all ()
code@51
  1023
  "Reload all snippets."
code@51
  1024
  (interactive)
code@51
  1025
  (if yas/root-directory
code@51
  1026
      (if (listp yas/root-directory)
code@51
  1027
	  (dolist (directory yas/root-directory)
code@51
  1028
	    (yas/load-directory directory))
code@51
  1029
	(yas/load-directory yas/root-directory))
code@51
  1030
    (call-interactively 'yas/load-directory))
code@51
  1031
  (message "done."))
code@51
  1032
code@51
  1033
(defun yas/load-directory (directory)
code@51
  1034
  "Load snippet definition from a directory hierarchy.
code@51
  1035
Below the top-level directory, each directory is a mode
code@51
  1036
name. And under each subdirectory, each file is a definition
code@51
  1037
of a snippet. The file name is the trigger key and the
code@51
  1038
content of the file is the template."
code@51
  1039
  (interactive "DSelect the root directory: ")
code@51
  1040
  (when (and (interactive-p)
code@51
  1041
	     (file-directory-p directory))
code@51
  1042
    (add-to-list 'yas/root-directory directory))
code@51
  1043
  (dolist (dir (yas/directory-files directory nil))
code@51
  1044
    (yas/load-directory-1 dir))
code@51
  1045
  (when (interactive-p)
code@51
  1046
    (message "done.")))
code@51
  1047
code@51
  1048
(defun yas/initialize ()
code@51
  1049
  "Do necessary initialization."
code@51
  1050
  (add-hook 'after-change-major-mode-hook
code@51
  1051
	    'yas/minor-mode-on)
code@51
  1052
  (dolist (hook yas/extra-mode-hooks)
code@51
  1053
    (add-hook hook
code@51
  1054
	      'yas/minor-mode-on))
code@51
  1055
  (add-hook 'yas/minor-mode-on-hook
code@51
  1056
	    'yas/ensure-minor-mode-priority)
code@51
  1057
  (when yas/use-menu
code@51
  1058
    (define-key-after 
code@51
  1059
      (lookup-key global-map [menu-bar])
code@51
  1060
      [yasnippet]
code@51
  1061
      (cons "YASnippet" yas/menu-keymap)
code@51
  1062
      'buffer)))
code@51
  1063
code@51
  1064
(defun yas/define-snippets (mode snippets &optional parent-mode)
code@51
  1065
  "Define snippets for MODE. SNIPPETS is a list of
code@51
  1066
snippet definition, of the following form:
code@51
  1067
code@51
  1068
 (KEY TEMPLATE NAME CONDITION)
code@51
  1069
code@51
  1070
or the NAME and CONDITION may be omitted. The optional 3rd
code@51
  1071
parameter can be used to specify the parent mode of MODE. That
code@51
  1072
is, when looking a snippet in MODE failed, it can refer to its
code@51
  1073
parent mode. The PARENT-MODE may not need to be a real mode."
code@51
  1074
  (let ((snippet-table (yas/snippet-table mode))
code@51
  1075
	(parent-table (if parent-mode
code@51
  1076
			  (yas/snippet-table parent-mode)
code@51
  1077
			nil))
code@51
  1078
	(keymap (if yas/use-menu
code@51
  1079
		    (yas/menu-keymap-for-mode mode)
code@51
  1080
		  nil)))
code@51
  1081
    (when parent-table
code@51
  1082
      (setf (yas/snippet-table-parent snippet-table)
code@51
  1083
	    parent-table)
code@51
  1084
      (when yas/use-menu
code@51
  1085
	(define-key keymap (vector 'parent-mode)
code@51
  1086
	  `(menu-item "parent mode"
code@51
  1087
		      ,(yas/menu-keymap-for-mode parent-mode)))))
code@51
  1088
    (when (and yas/use-menu
code@51
  1089
	       (yas/real-mode? mode))
code@51
  1090
      (define-key yas/menu-keymap (vector mode)
code@51
  1091
	`(menu-item ,(symbol-name mode) ,keymap)))
code@51
  1092
    (dolist (snippet snippets)
code@51
  1093
      (let* ((full-key (car snippet))
code@51
  1094
	     (key (file-name-sans-extension full-key))
code@51
  1095
	     (name (caddr snippet))
code@51
  1096
	     (condition (nth 3 snippet))
code@51
  1097
	     (template (yas/make-template (cadr snippet)
code@51
  1098
					  (or name key)
code@51
  1099
					  condition)))
code@51
  1100
	(yas/snippet-table-store snippet-table
code@51
  1101
				 full-key
code@51
  1102
				 key
code@51
  1103
				 template)
code@51
  1104
	(when yas/use-menu
code@51
  1105
	  (define-key keymap (vector (make-symbol full-key))
code@51
  1106
	    `(menu-item ,(yas/template-name template)
code@51
  1107
			,(yas/make-menu-binding (yas/template-content template))
code@51
  1108
			:keys ,(concat key yas/trigger-symbol))))))))
code@51
  1109
code@51
  1110
(defun yas/set-mode-parent (mode parent)
code@51
  1111
  "Set parent mode of MODE to PARENT."
code@51
  1112
  (setf (yas/snippet-table-parent
code@51
  1113
	 (yas/snippet-table mode))
code@51
  1114
	(yas/snippet-table parent))
code@51
  1115
  (when yas/use-menu
code@51
  1116
    (define-key (yas/menu-keymap-for-mode mode) (vector 'parent-mode)
code@51
  1117
      `(menu-item "parent mode"
code@51
  1118
		  ,(yas/menu-keymap-for-mode parent)))))
code@51
  1119
code@51
  1120
(defun yas/define (mode key template &optional name condition)
code@51
  1121
  "Define a snippet. Expanding KEY into TEMPLATE.
code@51
  1122
NAME is a description to this template. Also update
code@51
  1123
the menu if `yas/use-menu' is `t'. CONDITION is the
code@51
  1124
condition attached to this snippet. If you attach a
code@51
  1125
condition to a snippet, then it will only be expanded
code@51
  1126
when the condition evaluated to non-nil."
code@51
  1127
  (yas/define-snippets mode
code@51
  1128
		       (list (list key template name condition))))
code@51
  1129
    
code@51
  1130
code@51
  1131
(defun yas/hippie-try-expand (first-time?)
code@51
  1132
  "Integrate with hippie expand. Just put this function in
code@51
  1133
`hippie-expand-try-functions-list'."
code@51
  1134
  (if (not first-time?)
code@51
  1135
      (let ((yas/fallback-behavior 'return-nil))
code@51
  1136
	(yas/expand))
code@51
  1137
    (when (and (null (car buffer-undo-list))
code@51
  1138
	       (eq 'apply
code@51
  1139
		   (car (cadr buffer-undo-list)))
code@51
  1140
	       (eq 'yas/undo-expand-snippet
code@51
  1141
		   (cadr (cadr buffer-undo-list))))
code@51
  1142
      (undo 1))
code@51
  1143
    nil))
code@51
  1144
code@51
  1145
(defun yas/expand ()
code@51
  1146
  "Expand a snippet."
code@51
  1147
  (interactive)
code@51
  1148
  (let ((local-condition (yas/template-condition-predicate
code@51
  1149
			  yas/buffer-local-condition)))
code@51
  1150
    (if local-condition
code@51
  1151
	(let ((yas/require-template-condition 
code@51
  1152
	       (if (and (consp local-condition)
code@51
  1153
			(eq 'require-snippet-condition (car local-condition))
code@51
  1154
			(symbolp (cdr local-condition)))
code@51
  1155
		   (cdr local-condition)
code@51
  1156
		 nil)))
code@51
  1157
	  (multiple-value-bind (templates start end) (yas/current-key)
code@51
  1158
	    (if templates
code@51
  1159
		(let ((template (if (null (cdr templates)) ; only 1 template
code@51
  1160
				    (yas/template-content (cdar templates))
code@51
  1161
				  (yas/popup-for-template templates))))
code@51
  1162
		  (if template
code@51
  1163
		    (progn (yas/expand-snippet start end template)
code@51
  1164
			   'expanded)	; expanded successfully
code@51
  1165
		    'interruptted))	; interrupted by user
code@51
  1166
	      (if (eq yas/fallback-behavior 'return-nil)
code@51
  1167
		  nil			; return nil
code@51
  1168
		(let* ((yas/minor-mode nil)
code@51
  1169
		       (command (key-binding yas/trigger-key)))
code@51
  1170
		  (when (commandp command)
code@51
  1171
		    (call-interactively command))))))))))
code@51
  1172
      
code@51
  1173
(defun yas/next-field-group ()
code@51
  1174
  "Navigate to next field group. If there's none, exit the snippet."
code@51
  1175
  (interactive)
code@51
  1176
  (let ((overlay (yas/current-overlay-for-navigation)))
code@51
  1177
    (if overlay
code@51
  1178
	(yas/navigate-group (overlay-get overlay 'yas/group) t)
code@51
  1179
      (let ((snippet (yas/snippet-of-current-keymap))
code@51
  1180
	    (done nil))
code@51
  1181
	(if snippet
code@51
  1182
	    (do* ((groups (yas/snippet-groups snippet) (cdr groups))
code@51
  1183
		  (group (car groups) (car groups)))
code@51
  1184
		((or (null groups)
code@51
  1185
		     done)
code@51
  1186
		 (unless done 
code@51
  1187
		   (let* ((overlay (yas/snippet-overlay snippet))
code@51
  1188
			  (keymap (overlay-get overlay 'keymap))
code@51
  1189
			  (command nil))
code@51
  1190
		     (overlay-put overlay 'keymap nil)
code@51
  1191
		     (overlay-put overlay 'yas/snippet-reference nil)
code@51
  1192
		     (setq command (key-binding yas/next-field-key))
code@51
  1193
		     (when (commandp command)
code@51
  1194
		       (call-interactively command))
code@51
  1195
		     (overlay-put overlay 'keymap keymap)
code@51
  1196
		     (overlay-put overlay 'yas/snippet-reference snippet))))
code@51
  1197
	      (when (= (point)
code@51
  1198
		       (overlay-start
code@51
  1199
			(yas/field-overlay
code@51
  1200
			 (yas/group-primary-field group))))
code@51
  1201
		(setq done t)
code@51
  1202
		(yas/navigate-group group t))))))))
code@51
  1203
code@51
  1204
(defun yas/prev-field-group ()
code@51
  1205
  "Navigate to prev field group. If there's none, exit the snippet."
code@51
  1206
  (interactive)
code@51
  1207
  (let ((overlay (yas/current-overlay-for-navigation)))
code@51
  1208
    (if overlay
code@51
  1209
	(yas/navigate-group (overlay-get overlay 'yas/group) nil)
code@51
  1210
      (let ((snippet (yas/snippet-of-current-keymap))
code@51
  1211
	    (done nil))
code@51
  1212
	(if snippet
code@51
  1213
	  (do* ((groups (yas/snippet-groups snippet) (cdr groups))
code@51
  1214
		(group (car groups) (car groups)))
code@51
  1215
	      ((or (null groups)
code@51
  1216
		   done)
code@51
  1217
	       (unless done (message "Not in a snippet field.")))
code@51
  1218
	    (when (= (point)
code@51
  1219
		     (overlay-start
code@51
  1220
		      (yas/field-overlay
code@51
  1221
		       (yas/group-primary-field group))))
code@51
  1222
	      (setq done t)
code@51
  1223
	      (yas/navigate-group group nil)))
code@51
  1224
	  (message "Not in a snippet field."))))))
code@51
  1225
code@51
  1226
(defun yas/exit-snippet (snippet)
code@51
  1227
  "Goto exit-marker of SNIPPET and delete the snippet."
code@51
  1228
  (interactive)
code@51
  1229
  (let ((overlay (yas/snippet-overlay snippet)))
code@51
  1230
    (let ((yas/snippet-beg (overlay-start overlay))
code@51
  1231
	  (yas/snippet-end (overlay-end overlay)))
code@51
  1232
      (goto-char (yas/snippet-exit-marker snippet))
code@51
  1233
      (delete-overlay overlay)
code@51
  1234
      (dolist (group (yas/snippet-groups snippet))
code@51
  1235
	(dolist (field (yas/group-fields group))
code@51
  1236
	  (delete-overlay (yas/field-overlay field))))
code@51
  1237
code@51
  1238
      (run-hooks 'yas/after-exit-snippet-hook))))
code@51
  1239
code@51
  1240
(provide 'yasnippet)
code@51
  1241
code@51
  1242
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1243
;; Monkey patching for other functions that's causing
code@51
  1244
;; problems to yasnippet. For details on why I patch
code@51
  1245
;; those functions, refer to
code@51
  1246
;;   http://code.google.com/p/yasnippet/wiki/MonkeyPatching
code@51
  1247
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1248
(defadvice c-neutralize-syntax-in-CPP
code@51
  1249
  (around yas-mp/c-neutralize-syntax-in-CPP activate)
code@51
  1250
  "Adviced `c-neutralize-syntax-in-CPP' to properly 
code@51
  1251
handle the end-of-buffer error fired in it by calling
code@51
  1252
`forward-char' at the end of buffer."
code@51
  1253
  (condition-case err
code@51
  1254
      ad-do-it
code@51
  1255
    (error (message (error-message-string err)))))
code@51
  1256
code@51
  1257
code@51
  1258
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1259
;; Contents of dropdown-list.el
code@51
  1260
;;
code@51
  1261
;; dropdown-list.el is used by yasnippet to select multiple
code@51
  1262
;; candidate snippets.
code@51
  1263
;;
code@51
  1264
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1265
;;; dropdown-list.el --- Drop-down menu interface
code@51
  1266
;;
code@51
  1267
;; Filename: dropdown-list.el
code@51
  1268
;; Description: Drop-down menu interface
code@51
  1269
;; Author: Jaeyoun Chung [jay.chung@gmail.com]
code@51
  1270
;; Maintainer:
code@51
  1271
;; Copyright (C) 2008 Jaeyoun Chung
code@51
  1272
;; Created: Sun Mar 16 11:20:45 2008 (Pacific Daylight Time)
code@51
  1273
;; Version: 
code@51
  1274
;; Last-Updated: Sun Mar 16 12:19:49 2008 (Pacific Daylight Time)
code@51
  1275
;;           By: dradams
code@51
  1276
;;     Update #: 43
code@51
  1277
;; URL: http://www.emacswiki.org/cgi-bin/wiki/dropdown-list.el
code@51
  1278
;; Keywords: convenience menu
code@51
  1279
;; Compatibility: GNU Emacs 21.x, GNU Emacs 22.x
code@51
  1280
;;
code@51
  1281
;; Features that might be required by this library:
code@51
  1282
;;
code@51
  1283
;;   `cl'.
code@51
  1284
;;
code@51
  1285
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1286
;;
code@51
  1287
;;; Commentary:
code@51
  1288
;;
code@51
  1289
;;  According to Jaeyoun Chung, "overlay code stolen from company-mode.el."
code@51
  1290
;;
code@51
  1291
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1292
;;
code@51
  1293
;;; Change log:
code@51
  1294
;;
code@51
  1295
;; 2008/03/16 dadams
code@51
  1296
;;     Clean-up - e.g. use char-to-string for control chars removed by email posting.
code@51
  1297
;;     Moved example usage code (define-key*, command-selector) inside the library.
code@51
  1298
;;     Require cl.el at byte-compile time.
code@51
  1299
;;     Added GPL statement.
code@51
  1300
;; 2008/01/06 Jaeyoun Chung
code@51
  1301
;;     Posted to gnu-emacs-sources@gnu.org at 9:10 p.m.
code@51
  1302
;;
code@51
  1303
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1304
;;
code@51
  1305
;; This program is free software; you can redistribute it and/or
code@51
  1306
;; modify it under the terms of the GNU General Public License as
code@51
  1307
;; published by the Free Software Foundation; either version 3, or
code@51
  1308
;; (at your option) any later version.
code@51
  1309
;;
code@51
  1310
;; This program is distributed in the hope that it will be useful,
code@51
  1311
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
code@51
  1312
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
code@51
  1313
;; General Public License for more details.
code@51
  1314
;;
code@51
  1315
;; You should have received a copy of the GNU General Public License
code@51
  1316
;; along with this program; see the file COPYING.  If not, write to
code@51
  1317
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
code@51
  1318
;; Floor, Boston, MA 02110-1301, USA.
code@51
  1319
;;
code@51
  1320
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1321
;;
code@51
  1322
;;; Code:
code@51
  1323
code@51
  1324
(eval-when-compile (require 'cl)) ;; decf, fourth, incf, loop, mapcar*
code@51
  1325
code@51
  1326
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1327
code@51
  1328
(defface dropdown-list-face
code@51
  1329
    '((t :inherit default :background "lightyellow" :foreground "black"))
code@51
  1330
  "*Bla." :group 'dropdown-list)
code@51
  1331
code@51
  1332
(defface dropdown-list-selection-face
code@51
  1333
    '((t :inherit dropdown-list :background "purple"))
code@51
  1334
  "*Bla." :group 'dropdown-list)
code@51
  1335
code@51
  1336
(defvar dropdown-list-overlays nil)
code@51
  1337
code@51
  1338
(defun dropdown-list-hide ()
code@51
  1339
  (while dropdown-list-overlays
code@51
  1340
    (delete-overlay (pop dropdown-list-overlays))))
code@51
  1341
code@51
  1342
(defun dropdown-list-put-overlay (beg end &optional prop value prop2 value2)
code@51
  1343
  (let ((ov (make-overlay beg end)))
code@51
  1344
    (overlay-put ov 'window t)
code@51
  1345
    (when prop
code@51
  1346
      (overlay-put ov prop value)
code@51
  1347
      (when prop2 (overlay-put ov prop2 value2)))
code@51
  1348
    ov))
code@51
  1349
code@51
  1350
(defun dropdown-list-line (start replacement &optional no-insert)
code@51
  1351
  ;; start might be in the middle of a tab, which means we need to hide the
code@51
  1352
  ;; tab and add spaces
code@51
  1353
  (let ((end (+ start (length replacement)))
code@51
  1354
        beg-point end-point
code@51
  1355
        before-string after-string)
code@51
  1356
    (goto-char (point-at-eol))
code@51
  1357
    (if (< (current-column) start)
code@51
  1358
        (progn (setq before-string (make-string (- start (current-column)) ? ))
code@51
  1359
               (setq beg-point (point)))
code@51
  1360
      (goto-char (point-at-bol)) ;; Emacs bug, move-to-column is wrong otherwise
code@51
  1361
      (move-to-column start)
code@51
  1362
      (setq beg-point (point))
code@51
  1363
      (when (> (current-column) start)
code@51
  1364
        (goto-char (1- (point)))
code@51
  1365
        (setq beg-point (point))
code@51
  1366
        (setq before-string (make-string (- start (current-column)) ? ))))
code@51
  1367
    (move-to-column end)
code@51
  1368
    (setq end-point (point))
code@51
  1369
    (let ((end-offset (- (current-column) end)))
code@51
  1370
      (when (> end-offset 0) (setq after-string (make-string end-offset ?b))))
code@51
  1371
    (when no-insert
code@51
  1372
      ;; prevent inheriting of faces
code@51
  1373
      (setq before-string (when before-string (propertize before-string 'face 'default)))
code@51
  1374
      (setq after-string (when after-string (propertize after-string 'face 'default))))
code@51
  1375
    (let ((string (concat before-string replacement after-string)))
code@51
  1376
      (if no-insert
code@51
  1377
          string
code@51
  1378
        (push (dropdown-list-put-overlay beg-point end-point 'invisible t
code@51
  1379
                                         'after-string string)
code@51
  1380
              dropdown-list-overlays)))))
code@51
  1381
code@51
  1382
(defun dropdown-list-start-column (display-width)
code@51
  1383
  (let ((column (mod (current-column) (window-width)))
code@51
  1384
        (width (window-width)))
code@51
  1385
    (cond ((<= (+ column display-width) width) column)
code@51
  1386
          ((> column display-width) (- column display-width))
code@51
  1387
          ((>= width display-width) (- width display-width))
code@51
  1388
          (t nil))))
code@51
  1389
code@51
  1390
(defun dropdown-list-move-to-start-line (candidate-count)
code@51
  1391
  (decf candidate-count)
code@51
  1392
  (let ((above-line-count (save-excursion (- (vertical-motion (- candidate-count)))))
code@51
  1393
        (below-line-count (save-excursion (vertical-motion candidate-count))))
code@51
  1394
    (cond ((= below-line-count candidate-count)
code@51
  1395
           t)
code@51
  1396
          ((= above-line-count candidate-count)
code@51
  1397
           (vertical-motion (- candidate-count))
code@51
  1398
           t)
code@51
  1399
          ((>= (+ below-line-count above-line-count) candidate-count)
code@51
  1400
           (vertical-motion (- (- candidate-count below-line-count)))
code@51
  1401
           t)
code@51
  1402
          (t nil))))
code@51
  1403
code@51
  1404
(defun dropdown-list-at-point (candidates &optional selidx)
code@51
  1405
  (dropdown-list-hide)
code@51
  1406
  (let* ((lengths (mapcar #'length candidates))
code@51
  1407
         (max-length (apply #'max lengths))
code@51
  1408
         (start (dropdown-list-start-column (+ max-length 3)))
code@51
  1409
         (i -1)
code@51
  1410
         (candidates (mapcar* (lambda (candidate length)
code@51
  1411
                                (let ((diff (- max-length length)))
code@51
  1412
                                  (propertize
code@51
  1413
                                   (concat (if (> diff 0)
code@51
  1414
                                               (concat candidate (make-string diff ? ))
code@51
  1415
                                             (substring candidate 0 max-length))
code@51
  1416
                                           (format "%3d" (+ 2 i)))
code@51
  1417
                                   'face (if (eql (incf i) selidx)
code@51
  1418
                                             'dropdown-list-selection-face
code@51
  1419
                                           'dropdown-list-face))))
code@51
  1420
                              candidates
code@51
  1421
                              lengths)))
code@51
  1422
    (save-excursion
code@51
  1423
      (and start
code@51
  1424
           (dropdown-list-move-to-start-line (length candidates))
code@51
  1425
           (loop initially (vertical-motion 0)
code@51
  1426
              for candidate in candidates
code@51
  1427
              do (dropdown-list-line (+ (current-column) start) candidate)
code@51
  1428
              while (/= (vertical-motion 1) 0)
code@51
  1429
              finally return t)))))
code@51
  1430
code@51
  1431
(defun dropdown-list (candidates)
code@51
  1432
  (let ((selection)
code@51
  1433
        (temp-buffer))
code@51
  1434
    (save-window-excursion
code@51
  1435
      (unwind-protect
code@51
  1436
           (let ((candidate-count (length candidates))
code@51
  1437
                 done key selidx)
code@51
  1438
             (while (not done)
code@51
  1439
               (unless (dropdown-list-at-point candidates selidx)
code@51
  1440
                 (switch-to-buffer (setq temp-buffer (get-buffer-create "*selection*"))
code@51
  1441
                                   'norecord)
code@51
  1442
                 (delete-other-windows)
code@51
  1443
                 (delete-region (point-min) (point-max))
code@51
  1444
                 (insert (make-string (length candidates) ?\n))
code@51
  1445
                 (goto-char (point-min))
code@51
  1446
                 (dropdown-list-at-point candidates selidx))
code@51
  1447
               (setq key (read-key-sequence ""))
code@51
  1448
               (cond ((and (stringp key)
code@51
  1449
                           (>= (aref key 0) ?1)
code@51
  1450
                           (<= (aref key 0) (+ ?0 (min 9 candidate-count))))
code@51
  1451
                      (setq selection (- (aref key 0) ?1)
code@51
  1452
                            done      t))
code@51
  1453
                     ((member key `(,(char-to-string ?\C-p) [up]))
code@51
  1454
                      (setq selidx (mod (+ candidate-count (1- (or selidx 0)))
code@51
  1455
                                        candidate-count)))
code@51
  1456
                     ((member key `(,(char-to-string ?\C-n) [down]))
code@51
  1457
                      (setq selidx (mod (1+ (or selidx -1)) candidate-count)))
code@51
  1458
                     ((member key `(,(char-to-string ?\f))))
code@51
  1459
                     ((member key `(,(char-to-string ?\r) [return]))
code@51
  1460
                      (setq selection selidx
code@51
  1461
                            done      t))
code@51
  1462
                     (t (setq done t)))))
code@51
  1463
        (dropdown-list-hide)
code@51
  1464
        (and temp-buffer (kill-buffer temp-buffer)))
code@51
  1465
      ;;     (when selection
code@51
  1466
      ;;       (message "your selection => %d: %s" selection (nth selection candidates))
code@51
  1467
      ;;       (sit-for 1))
code@51
  1468
      selection)))
code@51
  1469
code@51
  1470
(defun define-key* (keymap key command)
code@51
  1471
  "Add COMMAND to the multiple-command binding of KEY in KEYMAP.
code@51
  1472
Use multiple times to bind different COMMANDs to the same KEY."
code@51
  1473
  (define-key keymap key (combine-command command (lookup-key keymap key))))
code@51
  1474
code@51
  1475
(defun combine-command (command defs)
code@51
  1476
  "$$$$$ FIXME - no doc string"
code@51
  1477
  (cond ((null defs) command)
code@51
  1478
        ((and (listp defs)
code@51
  1479
              (eq 'lambda (car defs))
code@51
  1480
              (= (length defs) 4)
code@51
  1481
              (listp (fourth defs))
code@51
  1482
              (eq 'command-selector (car (fourth defs))))
code@51
  1483
         (unless (member `',command (cdr (fourth defs)))
code@51
  1484
           (setcdr (fourth defs) (nconc (cdr (fourth defs)) `(',command))))
code@51
  1485
         defs)
code@51
  1486
        (t
code@51
  1487
         `(lambda () (interactive) (command-selector ',defs ',command)))))
code@51
  1488
code@51
  1489
(defvar command-selector-last-command nil "$$$$$ FIXME - no doc string")
code@51
  1490
code@51
  1491
(defun command-selector (&rest candidates)
code@51
  1492
  "$$$$$ FIXME - no doc string"
code@51
  1493
  (if (and (eq last-command this-command) command-selector-last-command)
code@51
  1494
      (call-interactively command-selector-last-command)
code@51
  1495
    (let* ((candidate-strings
code@51
  1496
            (mapcar (lambda (candidate)
code@51
  1497
                      (format "%s" (if (symbolp candidate)
code@51
  1498
                                       candidate
code@51
  1499
                                     (let ((s (format "%s" candidate)))
code@51
  1500
                                       (if (>= (length s) 7)
code@51
  1501
                                           (concat (substring s 0 7) "...")
code@51
  1502
                                         s)))))
code@51
  1503
                    candidates))
code@51
  1504
           (selection (dropdown-list candidate-strings)))
code@51
  1505
      (when selection
code@51
  1506
        (let ((cmd (nth selection candidates)))
code@51
  1507
          (call-interactively cmd)
code@51
  1508
          (setq command-selector-last-command cmd))))))
code@51
  1509
code@51
  1510
;;;;;;;;;;;;;;;;;;;;
code@51
  1511
code@51
  1512
(provide 'dropdown-list)
code@51
  1513
code@51
  1514
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
code@51
  1515
;;; dropdown-list.el ends here
code@51
  1516