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

   1 ;;; gpr-skel.el --- an extension to Gpr mode for inserting statement skeletons
   2
   3 ;; Copyright (C) 2013
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Authors: Stephen Leake <stephen_leake@stephe-leake.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Design:
  24 ;;
  25 ;; The primary user command is `gpr-skel-expand', which inserts the
  26 ;; skeleton associated with the previous word (possibly skipping a
  27 ;; name).
  28 ;;
  29 ;; We don't define skeletons that prompt for most of the content; it
  30 ;; is easier just to type in the buffer.
  31 ;;
  32 ;; These skeletons are not intended to teach a novice the language,
  33 ;; just to make it easier to write code that the gpr-wisi parser
  34 ;; likes, and handle repeated names nicely.
  35
  36 ;;; History:
  37
  38 ;; Created Dec 2013
  39
  40 (require 'skeleton)
  41 (require 'gpr-mode)
  42
  43 ;;;;; user variables, example skeletons intended to be overwritten
  44
  45 (defcustom gpr-skel-initial-string "header\nproject"
  46   "*String to insert in empty buffer.
  47 This could end in a token recognized by `gpr-skel-expand'."
  48   :type 'string
  49   :group 'gpr
  50   :safe 'stringp)
  51
  52 (define-skeleton gpr-skel-user-restricted
  53   "Example copyright/license skeleton, with automatic year and owner."
  54   ()
  55   "--  Copyright (C) " (format-time-string "%Y ") user-full-name " All Rights Reserved.\n"
  56 )
  57
  58 (define-skeleton gpr-skel-gpl
  59   "Example copyright/license skeleton, with automatic year and owner, GPLv3."
  60   ()
  61   "--  Copyright (C) " (format-time-string "%Y ") user-full-name " All Rights Reserved.\n"
  62   "--\n"
  63   "--  This program is free software; you can redistribute it and/or\n"
  64   "--  modify it under terms of the GNU General Public License as\n"
  65   "--  published by the Free Software Foundation; either version 3, or (at\n"
  66   "--  your option) any later version. This program is distributed in the\n"
  67   "--  hope that it will be useful, but WITHOUT ANY WARRANTY; without even\n"
  68   "--  the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\n"
  69   "--  PURPOSE. See the GNU General Public License for more details. You\n"
  70   "--  should have received a copy of the GNU General Public License\n"
  71   "--  distributed with this program; see file COPYING. If not, write to\n"
  72   "--  the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,\n"
  73   "--  MA 02110-1335, USA.\n"
  74 )
  75
  76 ;;;;; Gpr skeletons (alphabetical)
  77
  78 (define-skeleton gpr-skel-case
  79   "Insert case statement."
  80   ()
  81   "case " str " is\n"
  82   "when " _ "=>\n"
  83   "end case;")
  84
  85 (define-skeleton gpr-skel-header
  86   "Insert a file header comment, with automatic copyright year and prompt for copyright owner/license.
  87 Each user will probably want to override this."
  88   ()
  89   "--  Abstract :\n"
  90   "--\n"
  91   "--  " _ "\n"
  92   "--\n"
  93   "{copyright_license}\n"
  94   )
  95
  96 (define-skeleton gpr-skel-package
  97   "Insert a package with name from `str'."
  98   ()
  99   "package " str " is\n"
 100   _
 101   "end " str ";")
 102
 103 (define-skeleton gpr-skel-project
 104   "Insert a project with name from `str'."
 105   ()
 106   "project " str " is\n"
 107   _
 108   "end " str ";")
 109
 110 ;;;;; skeleton extensions
 111
 112 ;; FIXME: code below should be in skeleton.el
 113
 114 (defvar-local skeleton-token-alist nil
 115   "Symbol giving skeleton token alist of elements (STRING ELEMENT).
 116 See `skeleton-expand'.
 117 STRING must be a symbol in the current syntax, and is normally
 118 the first keyword in the skeleton. All strings must be
 119 lowercase; `skeleton-expand' converts user inputs.
 120
 121 ELEMENT may be:
 122 - a skeleton, which is inserted
 123 - an alist of (string . skeleton). User is prompted with `completing-read', selected skeleton is inserted. ")
 124
 125 (defun skeleton-add-skeleton (token skel alist &optional where)
 126   "Add an element (TOKEN . SKEL) to ALIST by side-effect.
 127 If WHERE is nil, prepend to ALIST; otherwise, prepend to sublist
 128 at WHERE."
 129   (if (null where)
 130       (setf alist (cons (cons token skel) alist))
 131     (setf (cdr (assoc where alist))
 132           (cons (cons token skel) (cdr (assoc where alist))))
 133     ))
 134
 135 (defvar skeleton-test-input nil
 136   "When non-nil, bypasses prompt in alist token expansions - used for unit testing.")
 137
 138 (defun skeleton-build-prompt (alist count)
 139   "Build a prompt from the keys of the ALIST.
 140 The prompt consists of the first COUNT keys from the alist, separated by `|', with
 141 trailing `...' if there are more keys."
 142   (if (>= count (length alist))
 143       (concat (mapconcat 'car alist " | ") " : ")
 144     (let ((alist-1 (butlast alist (- (length alist) count))))
 145       (concat (mapconcat 'car alist-1 " | ") " | ... : "))
 146   ))
 147
 148 ;;;###autoload
 149 (defun skeleton-expand (&optional name)
 150   "Expand the token or placeholder before point to a skeleton, as defined by `skeleton-token-alist'.
 151 A token is a symbol in the current syntax.
 152 A placeholder is a symbol enclosed in generic comment delimiters.
 153 If the word before point is not in `gpr-skel-token-alist', assume
 154 it is a name, and use the word before that as the token."
 155   (interactive "*")
 156
 157   ;; Skip trailing space, newline, and placeholder delimiter.
 158   ;; Standard comment end included for languages where that is newline.
 159   (skip-syntax-backward " !>")
 160
 161   ;; include punctuation here, in case is is an identifier, to allow Gpr.Text_IO
 162   (let* ((end (prog1 (point) (skip-syntax-backward "w_.")))
 163          (token (downcase (buffer-substring-no-properties (point) end)))
 164          (skel (assoc-string token (symbol-value skeleton-token-alist)))
 165          (handled nil))
 166
 167     (if skel
 168         (progn
 169           (when (listp (cdr skel))
 170             (let* ((alist (cdr skel))
 171                    (prompt (skeleton-build-prompt alist 4)))
 172               (setq skel (assoc-string
 173                           (or skeleton-test-input
 174                               (completing-read prompt alist))
 175                           alist))
 176               (setq skeleton-test-input nil) ;; don't reuse input on recursive call
 177               ))
 178
 179           ;; delete placeholder delimiters around token, token, and
 180           ;; name. point is currently before token.
 181           (skip-syntax-backward "!")
 182           (delete-region
 183            (point)
 184            (progn
 185              (skip-syntax-forward "!w_")
 186              (when name
 187                (skip-syntax-forward " ")
 188                (skip-syntax-forward "w_."))
 189              (point)))
 190           (funcall (cdr skel) name)
 191           (setq handled t))
 192
 193       ;; word in point .. end is not a token; assume it is a name
 194       (when (not name)
 195         ;; avoid infinite recursion
 196
 197         ;; Do this now, because skeleton insert won't.
 198         ;;
 199         ;; We didn't do it above, because we don't want to adjust case
 200         ;; on tokens and placeholders.
 201         ;; FIXME: hook for Ada case adjust
 202
 203         (setq token (buffer-substring-no-properties (point) end))
 204
 205         (skeleton-expand token)
 206         (setq handled t)))
 207
 208     (when (not handled)
 209       (error "undefined skeleton token: %s" name))
 210     ))
 211
 212 (defun skeleton-hippie-try (old)
 213   "For `hippie-expand-try-functions-list'. OLD is ignored."
 214   (if old
 215       ;; hippie is asking us to try the "next" completion; we don't have one
 216       nil
 217     (let ((pos (point)))
 218       (undo-boundary)
 219       (condition-case nil
 220           (progn
 221             (skeleton-expand)
 222             t)
 223         ('error
 224          ;; undo hook action, motion
 225          (undo)
 226          (goto-char pos)
 227          nil)))))
 228 ;; end FIXME:
 229
 230 ;;;;; token alist, setup
 231
 232 (defconst gpr-skel-token-alist
 233   '(("case" . gpr-skel-case)
 234     ("copyright_license"
 235      ("GPL" . gpr-skel-gpl)
 236      ("restricted" . gpr-skel-user-restricted))
 237     ("header" . gpr-skel-header)
 238     ("package" . gpr-skel-package)
 239     ("project" . gpr-skel-project))
 240 "For skeleton-token-alist")
 241
 242 (defun gpr-skel-setup ()
 243   "Setup a buffer gpr-skel."
 244   (setq skeleton-token-alist 'gpr-skel-token-alist)
 245   (add-hook 'skeleton-end-hook 'gpr-indent-statement nil t)
 246   (when (and gpr-skel-initial-string
 247              (= (buffer-size) 0))
 248     (insert gpr-skel-initial-string))
 249   )
 250
 251 (provide 'gpr-skeletons)
 252 (provide 'gpr-skel)
 253
 254 (setq gpr-expand 'skeleton-expand)
 255
 256 (add-hook 'gpr-mode-hook 'gpr-skel-setup)
 257
 258 ;;; end of file