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

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