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  -*- 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 (defcustom gpr-skel-initial-string "{header}\n{project}"
  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                           ;FIXME: Unknown!
  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   "Package name: "
  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   "Project name: "
 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 (defun skeleton-expand (&optional name)
 148   "Expand the token or placeholder before point to a skeleton, as defined by `skeleton-token-alist'.
 149 A token is a symbol in the current syntax.
 150 A placeholder is a symbol enclosed in generic comment delimiters.
 151 If the word before point is not in `skeleton-token-alist', assume
 152 it is a name, and use the word before that as the token."
 153   (interactive "*")
 154
 155   ;; Skip trailing space, newline, and placeholder delimiter.
 156   ;; Standard comment end included for languages where that is newline.
 157   (skip-syntax-backward " !>")
 158
 159   ;; include punctuation here, in case is is an identifier, to allow Gpr.Text_IO
 160   (let* ((end (prog1 (point) (skip-syntax-backward "w_.")))
 161          (token (downcase (buffer-substring-no-properties (point) end)))
 162          (skel (assoc-string token (symbol-value skeleton-token-alist)))
 163          (handled nil))
 164
 165     (if skel
 166         (progn
 167           (when (listp (cdr skel))
 168             (let* ((alist (cdr skel))
 169                    (prompt (skeleton-build-prompt alist 4)))
 170               (setq skel (assoc-string
 171                           (or skeleton-test-input
 172                               (completing-read prompt alist))
 173                           alist))
 174               (setq skeleton-test-input nil) ;; don't reuse input on recursive call
 175               ))
 176
 177           ;; delete placeholder delimiters around token, token, and
 178           ;; name. point is currently before token.
 179           (skip-syntax-backward "!")
 180           (delete-region
 181            (point)
 182            (progn
 183              (skip-syntax-forward "!w_")
 184              (when name
 185                (skip-syntax-forward " ")
 186                (skip-syntax-forward "w_."))
 187              (point)))
 188           (funcall (cdr skel) name)
 189           (setq handled t))
 190
 191       ;; word in point .. end is not a token; assume it is a name
 192       (when (not name)
 193         ;; avoid infinite recursion
 194
 195         ;; Do this now, because skeleton insert won't.
 196         ;;
 197         ;; We didn't do it above, because we don't want to adjust case
 198         ;; on tokens and placeholders.
 199         ;; FIXME: hook for Ada case adjust
 200
 201         (setq token (buffer-substring-no-properties (point) end))
 202
 203         (skeleton-expand token)
 204         (setq handled t)))
 205
 206     (when (not handled)
 207       (error "undefined skeleton token: %s" name))
 208     ))
 209
 210 (defun skeleton-hippie-try (old)
 211   "For `hippie-expand-try-functions-list'. OLD is ignored."
 212   (if old
 213       ;; hippie is asking us to try the "next" completion; we don't have one
 214       nil
 215     (let ((pos (point))
 216           (undo-len (if (sequencep pending-undo-list) (length pending-undo-list) 0)))
 217       (undo-boundary)
 218       (condition-case nil
 219           (progn
 220             (skeleton-expand)
 221             t)
 222         (error
 223          ;; undo hook action if any
 224          (unless (= undo-len (if (sequencep pending-undo-list) (length pending-undo-list) 0))
 225            (undo))
 226
 227          ;; undo motion
 228          (goto-char pos)
 229          nil)))))
 230
 231 (defun skeleton-next-placeholder ()
 232   "Move point forward to start of next placeholder."
 233   (interactive)
 234   (skip-syntax-forward "^!"))
 235
 236 (defun skeleton-prev-placeholder ()
 237   "Move point forward to start of next placeholder."
 238   (interactive)
 239   (skip-syntax-backward "^!"))
 240
 241 ;; end FIXME:
 242
 243 ;;;;; token alist, setup
 244
 245 (defconst gpr-skel-token-alist
 246   '(("case" . gpr-skel-case)
 247     ("copyright_license"
 248      ("GPL" . gpr-skel-gpl)
 249      ("restricted" . gpr-skel-user-restricted))
 250     ("header" . gpr-skel-header)
 251     ("package" . gpr-skel-package)
 252     ("project" . gpr-skel-project))
 253 "For skeleton-token-alist")
 254
 255 (defun gpr-skel-setup ()
 256   "Setup a buffer gpr-skel."
 257   (setq skeleton-token-alist 'gpr-skel-token-alist)
 258   (add-hook 'skeleton-end-hook 'gpr-indent-statement nil t)
 259   (when (and gpr-skel-initial-string
 260              (= (buffer-size) 0))
 261     (insert gpr-skel-initial-string))
 262   )
 263
 264 (provide 'gpr-skeletons)
 265 (provide 'gpr-skel)
 266
 267 (setq gpr-expand #'skeleton-expand)
 268
 269 (add-hook 'gpr-mode-hook #'gpr-skel-setup)
 270
 271 ;;; end of file