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

   1 ;;; ada-fix-error.el --- utilities for automatically fixing
   2 ;; errors reported by the compiler.
   3
   4 ;; Copyright (C) 1999-2009, 2012-2014 Free Software Foundation, Inc.
   5
   6 ;; Author     : Stephen Leake      <Stephen_Leake@stephe-leake.org>
   7 ;; Maintainer : Stephen Leake      <Stephen_Leake@stephe-leake.org>
   8 ;; Web site   : http://www.stephe-leake.org/
   9 ;; Keywords   : languages ada error
  10
  11 ;; This file is part of GNU Emacs
  12
  13 ;; This program is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  25 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26
  27 ;;;; code
  28
  29 (require 'ada-mode)
  30 (require 'cl-lib)
  31 (require 'compile)
  32
  33 (defcustom ada-fix-sort-context-clause t
  34   "*If non-nil, sort context clause when inserting 'with'"
  35   :type 'boolean
  36   :group 'ada)
  37
  38 (defvar ada-fix-context-clause nil
  39   "Function to return the region containing the context clause for the current buffer.
  40 Called with no arguments; return (BEGIN . END). BEGIN and
  41 END must be at beginning of line.  If there is no context
  42 clause, BEGIN = END, at start of compilation unit.")
  43
  44 (defun ada-fix-context-clause ()
  45   (when ada-fix-context-clause
  46     (funcall ada-fix-context-clause)))
  47
  48 (defun ada-fix-insert-unit-name (unit-name)
  49   "Insert UNIT-NAME at point and capitalize it."
  50   ;; unit-name is normally gotten from a file-name, and is thus all lower-case.
  51   (let ((start-point (point))
  52         search-bound)
  53     (insert unit-name)
  54     (setq search-bound (point))
  55     (insert " ") ; separate from following words, if any, for ada-case-adjust-identifier
  56     (goto-char start-point)
  57     (while (search-forward "." search-bound t)
  58       (forward-char -1)
  59       (ada-case-adjust-identifier)
  60       (forward-char 1))
  61     (goto-char search-bound)
  62     (ada-case-adjust-identifier)
  63     (delete-char 1)))
  64
  65 (defun ada-fix-add-with-clause (package-name)
  66   "Add a with_clause for PACKAGE_NAME.
  67 If ada-fix-sort-context-clause, sort the context clauses using
  68 sort-lines."
  69   (let ((context-clause (ada-fix-context-clause)))
  70     (when (not context-clause)
  71       (error "no compilation unit found"))
  72
  73     (goto-char (cdr context-clause))
  74     (insert "with ")
  75     (ada-fix-insert-unit-name package-name)
  76     (insert ";\n")
  77
  78     (when (and (< (car context-clause) (cdr context-clause))
  79                ada-fix-sort-context-clause)
  80       ;; FIXME (later): this puts "limited with", "private with" at top of list; prefer at bottom
  81       (sort-lines nil (car context-clause) (point)))
  82     ))
  83
  84 (defun ada-fix-extend-with-clause (child-name)
  85   "Assuming point is in a selected name, just before CHILD-NAME, add or
  86 extend a with_clause to include CHILD-NAME  .   "
  87   (let ((parent-name-end (point)))
  88     ;; Find the full parent name; skip back to whitespace, then match
  89     ;; the name forward.
  90     (skip-syntax-backward "w_.")
  91     (search-forward-regexp ada-name-regexp parent-name-end)
  92     (let ((parent-name (match-string 0))
  93           (context-clause (ada-fix-context-clause)))
  94       (goto-char (car context-clause))
  95       (if (search-forward-regexp (concat "^with " parent-name ";") (cdr context-clause) t)
  96           ;; found exisiting 'with' for parent; extend it
  97           (progn
  98             (forward-char -1) ; skip back over semicolon
  99             (insert "." child-name))
 100
 101         ;; not found; we are in a package body, with_clause for parent is in spec.
 102         ;; insert a new one
 103         (ada-fix-add-with-clause (concat parent-name "." child-name)))
 104       )))
 105
 106 (defun ada-fix-add-use-type (type)
 107   "Insert 'use type' clause for TYPE at start of declarative part for current construct."
 108   (ada-goto-declarative-region-start); leaves point after 'is'
 109   (newline)
 110   (insert "use type " type ";")
 111   (newline-and-indent)
 112   (forward-line -1)
 113   (indent-according-to-mode))
 114
 115 (defun ada-fix-add-use (package)
 116   "Insert 'use' clause for PACKAGE at start of declarative part for current construct."
 117   (ada-goto-declarative-region-start); leaves point after 'is'
 118   (newline)
 119   (insert "use " package ";")
 120   (newline-and-indent)
 121   (forward-line -1)
 122   (indent-according-to-mode))
 123
 124 (defvar ada-fix-error-hook nil
 125   ;; determined by ada_compiler, set by *-select-prj-compiler
 126   "Hook to recognize and fix errors.
 127 Hook functions are called with three args:
 128
 129 MSG, the `compilation--message' struct for the current error
 130
 131 SOURCE-BUFFER, the buffer containing the source to be fixed
 132
 133 SOURCE-WINDOW, the window displaying SOURCE-BUFFER.
 134
 135 Point in SOURCE-BUFFER is at error location; point in
 136 `compilation-last-buffer' is at MSG location. Focus is in
 137 compilation buffer.
 138
 139 Hook functions should return t if the error is recognized and
 140 fixed, leaving point at fix. Otherwise, they should preserve
 141 point and return nil.")
 142
 143 (defun ada-get-compilation-message ()
 144   "Get compilation message at point.
 145 Compatible with Emacs 23.4 and 24.x."
 146   (cl-case emacs-major-version
 147     (23 (get-text-property (point) 'message))
 148     (24 (get-text-property (point) 'compilation-message))))
 149
 150 (defun ada-fix-compiler-error ()
 151   "Attempt to fix the current compiler error. Leave point at fixed code."
 152   (interactive)
 153
 154   (let ((source-buffer (current-buffer))
 155         (source-window (selected-window))
 156         (line-move-visual nil)); screws up next-line otherwise
 157
 158     (with-current-buffer compilation-last-buffer
 159       (when (not (ada-get-compilation-message))
 160         ;; not clear why this can happens, but it does
 161         (compilation-next-error 1))
 162       (let ((comp-buf-pt (point))
 163             (success
 164              (run-hook-with-args-until-success
 165               ada-fix-error-hook
 166               (compilation-next-error 0)
 167               source-buffer
 168               source-window)))
 169         ;; restore compilation buffer point
 170         (set-buffer compilation-last-buffer)
 171         (goto-char comp-buf-pt)
 172
 173         (unless success
 174           ;; none of the hooks handled the error
 175           (error "error not recognized"))
 176         ))))
 177
 178 (provide 'ada-fix-error)
 179 ;; end of file