code.delx.au - gnu-emacs-elpa/blob - packages/ada-mode/ada-skel.el

   1 ;;; ada-skel.el --- Extension to Ada mode for inserting statement skeletons  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 1987, 1993, 1994, 1996-2015  Free Software Foundation, Inc.
   4
   5 ;; Authors: Stephen Leake <stephen_leake@stephe-leake.org>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Design:
  23 ;;
  24 ;; The primary user command is `ada-skel-expand', which inserts the
  25 ;; skeleton associated with the previous word (possibly skipping a
  26 ;; name).
  27 ;;
  28 ;; We don't define skeletons that prompt for most of the content; it
  29 ;; is easier just to type in the buffer.
  30 ;;
  31 ;; These skeletons are not intended to teach a novice the language,
  32 ;; just to make it easier to write code that the ada-wisi parser
  33 ;; likes, and handle repeated names nicely.
  34
  35 ;;; History:
  36
  37 ;; Created May 1987.
  38 ;; Original version from V. Bowman as in ada.el of Emacs-18
  39 ;; (borrowed heavily from Mick Jordan's Modula-2 package for GNU,
  40 ;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.)
  41 ;;
  42 ;; Sep 1993. Daniel Pfeiffer <pfeiffer@cict.fr> (DP)
  43 ;; Introduced statement.el for smaller code and user configurability.
  44 ;;
  45 ;; Nov 1993. Rolf Ebert <ebert@enpc.fr> (RE) Moved the
  46 ;; skeleton generation into this separate file. The code still is
  47 ;; essentially written by DP
  48 ;;
  49 ;; Adapted Jun 1994. Markus Heritsch
  50 ;; <Markus.Heritsch@studbox.uni-stuttgart.de> (MH)
  51 ;; added menu bar support for templates
  52 ;;
  53 ;; 1994/12/02  Christian Egli <cegli@hcsd.hac.com>
  54 ;; General cleanup and bug fixes.
  55 ;;
  56 ;; 1995/12/20  John Hutchison <hutchiso@epi.syr.ge.com>
  57 ;; made it work with skeleton.el from Emacs-19.30. Several
  58 ;; enhancements and bug fixes.
  59 ;;
  60 ;; Sep 2013 Stephen Leake renamed to ada-skel (to match skeleton.el),
  61 ;; complete re-write: added ada-skel-alist (to get some of the
  62 ;; functionality of the sadly missed Else package). Simplified
  63 ;; skeletons; just make it easier to work with the ada-wisi parser,
  64 ;; don't try to teach syntax.
  65
  66 (require 'skeleton nil t)
  67
  68 ;;;;; user variables, example skeletons intended to be overwritten
  69
  70 (defcustom ada-skel-initial-string
  71   "{header}
  72 --  Emacs note: Type C-c C-e with point after the above placeholder
  73 --
  74 --  This text was inserted by ada-skel-initial-string;
  75 --  M-x customize-variable <RET> ada-skel-initial-string <RET>
  76 --  (info \"(ada-mode)Statement skeletons\")"
  77   "String to insert in empty buffer.
  78 This could end in a token recognized by `ada-skel-expand'."
  79   :type 'string
  80   :group 'ada
  81   :safe #'stringp)
  82
  83 (define-skeleton ada-skel-user-restricted
  84   "Example copyright/license skeleton, with automatic year and owner."
  85   ()
  86   "--  Copyright (C) " (format-time-string "%Y ") user-full-name " All Rights Reserved.\n"
  87   "\n"
  88   "pragma License (Restricted);\n"
  89 )
  90
  91 (define-skeleton ada-skel-gpl
  92   "Example copyright/license skeleton, with automatic year and owner, GPLv3."
  93   ()
  94   "--  Copyright (C) " (format-time-string "%Y ") user-full-name " All Rights Reserved.\n"
  95   "--\n"
  96   "--  This program is free software; you can redistribute it and/or\n"
  97   "--  modify it under terms of the GNU General Public License as\n"
  98   "--  published by the Free Software Foundation; either version 3, or (at\n"
  99   "--  your option) any later version. This program is distributed in the\n"
 100   "--  hope that it will be useful, but WITHOUT ANY WARRANTY; without even\n"
 101   "--  the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\n"
 102   "--  PURPOSE. See the GNU General Public License for more details. You\n"
 103   "--  should have received a copy of the GNU General Public License\n"
 104   "--  distributed with this program; see file COPYING. If not, write to\n"
 105   "--  the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,\n"
 106   "--  MA 02110-1335, USA.\n"
 107   "\n"
 108   "pragma License (GPL);\n"
 109
 110 )
 111
 112 ;; override ada-mode 4.01 autoloaded functions
 113 (define-obsolete-function-alias 'ada-header 'ada-skel-header "24.4"
 114   "Insert a descriptive header at the top of the file.")
 115
 116 ;;;;; Ada skeletons (alphabetical)
 117
 118 (define-skeleton ada-skel-accept
 119   "Insert accept statement with name from `str'."
 120   ()
 121   "accept " str " do\n"
 122   "end " str ";")
 123
 124 (define-skeleton ada-skel-case
 125   "Insert case statement."
 126   ()
 127   "case " str " is\n"
 128   "when " _ "=>\n"
 129   "end case;")
 130
 131 (define-skeleton ada-skel-declare
 132   "Insert a block statement with an optional name (from `str')."
 133   ()
 134   str & ":\n"
 135   "declare\n"
 136   _
 137   "begin\n"
 138   "exception\n"
 139   "end " str | -1 ?\;)
 140
 141 (define-skeleton ada-skel-entry
 142   "Insert entry statement with name from `str'."
 143   ()
 144   "entry " str " when " _ "\n"
 145   "is\n"
 146   "begin\n"
 147   "end " str ";")
 148
 149 (define-skeleton ada-skel-for
 150   "Insert a for loop statement with an optional name (from `str')."
 151   ()
 152   str & " :\n"
 153   "for " _ " loop\n"
 154   "end loop " str | -1 ";")
 155
 156 (define-skeleton ada-skel-function-body
 157   "Insert a function body with name from `str'."
 158   ()
 159   "function " str " return \n"
 160   "is\n"
 161   "begin\n"
 162   _
 163   "end " str ";" >)
 164
 165 (define-skeleton ada-skel-function-spec
 166   "Insert a function type specification with name from `str'."
 167   ()
 168   "function " str " return ;")
 169
 170 (define-skeleton ada-skel-header
 171   "Insert a file header comment, with automatic copyright year and prompt for copyright owner/license.
 172 Each user will probably want to override this."
 173   ()
 174   "--  Abstract :\n"
 175   "--\n"
 176   "--  " _ "\n"
 177   "--\n"
 178   "{copyright_license}\n"
 179   )
 180
 181 (define-skeleton ada-skel-if
 182   "Insert an if statement."
 183   ()
 184   "if " _ " then\n"
 185   "elsif  then\n"
 186   "else\n"
 187   "end if;")
 188
 189 (define-skeleton ada-skel-loop
 190   "Insert a loop statement with an optional name (from `str')."
 191   ()
 192   str & ":\n"
 193   "loop\n"
 194   "exit " str | -1 " when " _ ";\n"
 195   "end loop " str | -1 ";")
 196
 197 (define-skeleton ada-skel-package-body
 198   "Insert a package body with name from `str'."
 199   ()
 200   "package body " str " is\n"
 201   _
 202   "begin\n"
 203   "end " str ";")
 204
 205 (define-skeleton ada-skel-package-spec
 206   "Insert a package specification with name from `str'.
 207 See `ada-find-other-file' to create library level package body from spec."
 208   ()
 209   "package " str " is\n"
 210   _
 211   "private\n"
 212   "end " str ";")
 213
 214 (define-skeleton ada-skel-procedure-body
 215   "Insert a procedure body with name from `str'."
 216   ()
 217   "procedure " str "\n"
 218   "is\n"
 219   "begin\n"
 220   _
 221   "end " str ";")
 222
 223 (define-skeleton ada-skel-procedure-spec
 224   "Insert a procedure type specification with name from `str'."
 225   ()
 226   "procedure " str ";")
 227
 228 (define-skeleton ada-skel-protected-body
 229   "Insert a protected body with name from `str'."
 230   ()
 231   "protected body " str " is\n"
 232   _
 233   "end " str ";")
 234
 235 (define-skeleton ada-skel-protected-spec
 236   "Insert a protected type specification with name from `str'."
 237   ()
 238   "protected type " str " is\n"
 239   _
 240   "private\n"
 241   "end " str ";")
 242
 243 (define-skeleton ada-skel-record
 244   "Insert a record type declaration with a type name from `str'."
 245   ()
 246   "type " str " is record\n"
 247   _
 248   "end record;")
 249
 250 (define-skeleton ada-skel-return
 251   "Insert an extended return statement."
 252   ()
 253   "return" _ "\n"
 254   "do\n"
 255   "end return;")
 256
 257 (define-skeleton ada-skel-select
 258   "Insert a select statement."
 259   ()
 260   "select\n"
 261   _
 262   "else\n"
 263   "end select;")
 264
 265 (define-skeleton ada-skel-task-body
 266   "Insert a task body with name from `str'."
 267   ()
 268   "task body " str "\n"
 269   "is\n"
 270   _
 271   "begin\n"
 272   "end " str ";")
 273
 274 (define-skeleton ada-skel-task-spec
 275   "Insert a task specification with name from `str'."
 276   ()
 277   "task " str " is\n"
 278   _
 279   "end " str ";")
 280
 281 (define-skeleton ada-skel-while
 282   "Insert a while loop statement with an optional name (from `str')."
 283   ()
 284   str & ":\n"
 285   "while " _ " loop\n"
 286   "end loop " str | -1 ";")
 287
 288 (define-skeleton ada-skel-with-use
 289   "Insert with and use context clauses with name from `str'."
 290   ()
 291   "with " str "; use " str ";")
 292
 293 ;;;;; token alist, other functions
 294
 295 (defconst ada-skel-token-alist
 296   '(("accept" . ada-skel-accept)
 297     ("begin" . ada-skel-declare) ;; easy enough to delete the declare
 298     ("case" . ada-skel-case)
 299     ("copyright_license"
 300      ("GPL" . ada-skel-gpl)
 301      ("restricted" . ada-skel-user-restricted))
 302     ("declare" . ada-skel-declare)
 303     ("entry" . ada-skel-entry)
 304     ("for" . ada-skel-for)
 305     ("function"
 306      ("body" . ada-skel-function-body)
 307      ("spec" . ada-skel-function-spec))
 308     ("header" . ada-skel-header)
 309     ("if" . ada-skel-if)
 310     ("loop" . ada-skel-loop)
 311     ("package"
 312      ("body" . ada-skel-package-body)
 313      ("spec" . ada-skel-package-spec))
 314     ("procedure"
 315      ("body" . ada-skel-procedure-body)
 316      ("spec" . ada-skel-procedure-spec))
 317     ("protected"
 318      ("body" . ada-skel-protected-body)
 319      ("spec" . ada-skel-protected-spec))
 320     ("record" . ada-skel-record)
 321     ("return" . ada-skel-return)
 322     ("select" . ada-skel-select)
 323     ("task"
 324      ("body" . ada-skel-task-body)
 325      ("spec" . ada-skel-task-spec))
 326     ("while" . ada-skel-while)
 327     ("with" . ada-skel-with-use))
 328   "alist of elements (STRING ELEMENT). See `ada-skel-expand'.
 329 STRING must be a symbol in the current syntax, and is normally
 330 the first Ada keyword in the skeleton. All strings must be
 331 lowercase; `ada-skel-expand' converts user inputs.
 332
 333 ELEMENT may be:
 334 - a skeleton, which is inserted
 335 - an alist of (string . skeleton). User is prompted with `completing-read', selected skeleton is inserted. ")
 336
 337 (defvar ada-skel-test-input nil
 338   "When non-nil, bypasses prompt in alist token expansions - used for unit testing.")
 339
 340 (defun ada-skel-build-prompt (alist count)
 341   "Build a prompt from the keys of the ALIST.
 342 The prompt consists of the first COUNT keys from the alist, separated by `|', with
 343 trailing `...' if there are more keys."
 344   (if (>= count (length alist))
 345       (concat (mapconcat 'car alist " | ") " : ")
 346     (let ((alist-1 (butlast alist (- (length alist) count))))
 347       (concat (mapconcat 'car alist-1 " | ") " | ... : "))
 348   ))
 349
 350 (defun ada-skel-expand (&optional name)
 351   "Expand the token or placeholder before point to a skeleton, as defined by `ada-skel-token-alist'.
 352 A token is a symbol in the current syntax.
 353 A placeholder is a symbol enclosed in generic comment delimiters.
 354 If the word before point is not in `ada-skel-token-alist', assume
 355 it is a name, and use the word before that as the token."
 356   (interactive "*")
 357
 358   ;; Skip trailing space, newline, and placeholder delimiter.
 359   ;; Standard comment end included for languages where that is newline.
 360   (skip-syntax-backward " !>")
 361
 362   ;; include punctuation here, in case is is an identifier, to allow Ada.Text_IO
 363   (let* ((end (prog1 (point) (skip-syntax-backward "w_.")))
 364          (token (downcase (buffer-substring-no-properties (point) end)))
 365          (skel (assoc-string token ada-skel-token-alist))
 366          (handled nil))
 367
 368     (if skel
 369         (progn
 370           (when (listp (cdr skel))
 371             (let* ((alist (cdr skel))
 372                    (prompt (ada-skel-build-prompt alist 4)))
 373               (setq skel (assoc-string
 374                           (or ada-skel-test-input
 375                               (completing-read prompt alist))
 376                           alist))
 377               (setq ada-skel-test-input nil) ;; don't reuse input on recursive call
 378               ))
 379
 380           ;; delete placeholder delimiters around token, token, and
 381           ;; name. point is currently before token.
 382           (skip-syntax-backward "!")
 383           (delete-region
 384            (point)
 385            (progn
 386              (skip-syntax-forward "!w_")
 387              (when name
 388                (skip-syntax-forward " ")
 389                (skip-syntax-forward "w_."))
 390              (point)))
 391           (funcall (cdr skel) name)
 392           (setq handled t))
 393
 394       ;; word in point .. end is not a token; assume it is a name
 395       (when (not name)
 396         ;; avoid infinite recursion
 397
 398         ;; Do this now, because skeleton insert won't.
 399         ;;
 400         ;; We didn't do it above, because we don't want to adjust case
 401         ;; on tokens and placeholders.
 402         (save-excursion (ada-case-adjust-region (point) end))
 403         (setq token (buffer-substring-no-properties (point) end))
 404
 405         (ada-skel-expand token)
 406         (setq handled t)))
 407
 408     (when (not handled)
 409       (error "undefined skeleton token: %s" name))
 410     ))
 411
 412 (defun ada-skel-hippie-try (old)
 413   "For `hippie-expand-try-functions-list'. OLD is ignored."
 414   (if old
 415       ;; hippie is asking us to try the "next" completion; we don't have one
 416       nil
 417     (let ((pos (point))
 418           (undo-len (if (eq 't pending-undo-list)
 419                         0
 420                       (length pending-undo-list))))
 421       (undo-boundary)
 422       (condition-case nil
 423           (progn
 424             (ada-skel-expand)
 425             t)
 426         (error
 427          ;; undo hook action if any
 428          (unless (or (eq 't pending-undo-list)
 429                      (= undo-len (length pending-undo-list)))
 430            (undo))
 431
 432          ;; undo motion
 433          (goto-char pos)
 434          nil)))))
 435
 436 (defun ada-skel-next-placeholder ()
 437   "Move point to after next placeholder."
 438   (skip-syntax-forward "^!")
 439   (skip-syntax-forward "w!"))
 440
 441 (defun ada-skel-prev-placeholder ()
 442   "Move point to after previous placeholder."
 443   (skip-syntax-backward "^!"))
 444
 445 (defun ada-skel-setup ()
 446   "Setup a buffer for ada-skel."
 447   (add-hook 'skeleton-end-hook 'ada-indent-statement nil t)
 448   (when (and ada-skel-initial-string
 449              (= (buffer-size) 0))
 450     (insert ada-skel-initial-string))
 451   )
 452
 453 (provide 'ada-skeletons)
 454 (provide 'ada-skel)
 455
 456 (setq ada-expand #'ada-skel-expand)
 457 (setq ada-next-placeholder #'ada-skel-next-placeholder)
 458 (setq ada-prev-placeholder #'ada-skel-prev-placeholder)
 459
 460 (add-hook 'ada-mode-hook #'ada-skel-setup)
 461
 462 ;;; ada-skel.el ends here