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