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

   1 ;;; ada-fix-error.el --- utilities for automatically fixing  -*- lexical-binding:t -*-
   2 ;; errors reported by the compiler.
   3
   4 ;; Copyright (C) 1999-2009, 2012-2015 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 excluding leading pragmas.  Called with no arguments;
  41 return (BEGIN . END). BEGIN and END must be at beginning of line.
  42 If there is no context clause, BEGIN = END, at start of
  43 compilation unit.")
  44
  45 (defun ada-fix-context-clause ()
  46   (when ada-fix-context-clause
  47     (funcall ada-fix-context-clause)))
  48
  49 (defun ada-fix-insert-unit-name (unit-name)
  50   "Insert UNIT-NAME at point and capitalize it."
  51   ;; unit-name is normally gotten from a file-name, and is thus all lower-case.
  52   (let ((start-point (point))
  53         search-bound)
  54     (insert unit-name)
  55     (setq search-bound (point))
  56     (insert " ") ; separate from following words, if any, for ada-case-adjust-identifier
  57     (goto-char start-point)
  58     (while (search-forward "." search-bound t)
  59       (forward-char -1)
  60       (ada-case-adjust-identifier)
  61       (forward-char 1))
  62     (goto-char search-bound)
  63     (ada-case-adjust-identifier)
  64     (delete-char 1)))
  65
  66 (defun ada-fix-sort-context-pred (a b)
  67   "Predicate for `sort-subr'; sorts \"limited with\", \"private with\" last.
  68 Returns non-nil if a should preceed b in buffer."
  69   ;; a, b are buffer ranges in the current buffer
  70   (cl-flet
  71       ((starts-with
  72         (pat reg)
  73         (string= pat (buffer-substring-no-properties (car reg)
  74                                                      (min (point-max)
  75                                                           (+(car reg) (length pat)))))))
  76     (cond
  77      ((and
  78        (starts-with "limited with" a)
  79        (starts-with "private with" b))
  80       t)
  81
  82      ((and
  83        (starts-with "limited with" a)
  84        (not (starts-with "limited with" b)))
  85       nil)
  86
  87      ((and
  88        (not (starts-with "limited with" a))
  89        (starts-with "limited with" b))
  90       t)
  91
  92      ((and
  93        (starts-with "private with" a)
  94        (not (starts-with "private with" b)))
  95       nil)
  96
  97      ((and
  98        (not (starts-with "private with" a))
  99        (starts-with "private with" b))
 100       t)
 101
 102      (t
 103       (> 0 (compare-buffer-substrings
 104             nil (car a) (cdr a)
 105             nil (car b) (cdr b))) )
 106      )))
 107
 108 (defun ada-fix-sort-context-clause (beg end)
 109   "Sort context clauses in range BEG END."
 110   (save-excursion
 111     (save-restriction
 112       (narrow-to-region beg end)
 113       (goto-char (point-min))
 114       (sort-subr nil 'forward-line 'end-of-line nil nil 'ada-fix-sort-context-pred)
 115       )))
 116
 117 (defun ada-fix-add-with-clause (package-name)
 118   "Add a with_clause for PACKAGE_NAME.
 119 If ada-fix-sort-context-clause, sort the context clauses using
 120 sort-lines."
 121   (let ((context-clause (ada-fix-context-clause)))
 122     (when (not context-clause)
 123       (error "no compilation unit found"))
 124
 125     (goto-char (cdr context-clause))
 126     (insert "with ")
 127     (ada-fix-insert-unit-name package-name)
 128     (insert ";\n")
 129
 130     (when (and (< (car context-clause) (cdr context-clause))
 131                ada-fix-sort-context-clause)
 132       (ada-fix-sort-context-clause (car context-clause) (point)))
 133     ))
 134
 135 (defun ada-fix-extend-with-clause (child-name)
 136   "Assuming point is in a selected name, just before CHILD-NAME, add or
 137 extend a with_clause to include CHILD-NAME  .   "
 138   (let ((parent-name-end (point)))
 139     ;; Find the full parent name; skip back to whitespace, then match
 140     ;; the name forward.
 141     (skip-syntax-backward "w_.")
 142     (search-forward-regexp ada-name-regexp parent-name-end)
 143     (let ((parent-name (match-string 0))
 144           (context-clause (ada-fix-context-clause)))
 145       (goto-char (car context-clause))
 146       (if (search-forward-regexp (concat "^with " parent-name ";") (cdr context-clause) t)
 147           ;; found exisiting 'with' for parent; extend it
 148           (progn
 149             (forward-char -1) ; skip back over semicolon
 150             (insert "." child-name))
 151
 152         ;; not found; we are in a package body, with_clause for parent is in spec.
 153         ;; insert a new one
 154         (ada-fix-add-with-clause (concat parent-name "." child-name)))
 155       )))
 156
 157 (defun ada-fix-add-use-type (type)
 158   "Insert `use type' clause for TYPE at start of declarative part for current construct."
 159   (ada-goto-declarative-region-start); leaves point after 'is'
 160   (newline)
 161   (insert "use type " type ";")
 162   (newline-and-indent)
 163   (forward-line -1)
 164   (indent-according-to-mode))
 165
 166 (defun ada-fix-add-use (package)
 167   "Insert `use' clause for PACKAGE at start of declarative part for current construct."
 168   (ada-goto-declarative-region-start); leaves point after 'is'
 169   (newline)
 170   (insert "use " package ";")
 171   (newline-and-indent)
 172   (forward-line -1)
 173   (indent-according-to-mode))
 174
 175 (defvar ada-fix-error-hook nil
 176   ;; determined by ada_compiler, set by *-select-prj-compiler
 177   "Hook to recognize and fix errors.
 178 Hook functions are called with three args:
 179
 180 MSG, the `compilation--message' struct for the current error
 181
 182 SOURCE-BUFFER, the buffer containing the source to be fixed
 183
 184 SOURCE-WINDOW, the window displaying SOURCE-BUFFER.
 185
 186 Point in SOURCE-BUFFER is at error location; point in
 187 `compilation-last-buffer' is at MSG location. Focus is in
 188 compilation buffer.
 189
 190 Hook functions should return t if the error is recognized and
 191 fixed, leaving point at fix. Otherwise, they should preserve
 192 point and return nil.")
 193
 194 (defun ada-get-compilation-message ()
 195   "Get compilation message at line beginning."
 196   (get-text-property (line-beginning-position) 'compilation-message))
 197
 198 (defun ada-fix-compiler-error ()
 199   "Attempt to fix the current compiler error. Leave point at fixed code."
 200   (interactive)
 201
 202   (let ((source-buffer (current-buffer))
 203         (source-window (selected-window))
 204         (line-move-visual nil)); screws up next-line otherwise
 205
 206     (with-current-buffer compilation-last-buffer
 207       (when (not (ada-get-compilation-message))
 208         (beep)
 209         (message "FIXME: ada-fix-compiler-error")
 210         ;; not clear why this can happen, but it has
 211         (compilation-next-error 1))
 212       (let ((comp-buf-pt (point))
 213             (success
 214              (run-hook-with-args-until-success
 215               ada-fix-error-hook
 216               (compilation-next-error 0)
 217               source-buffer
 218               source-window)))
 219         ;; restore compilation buffer point
 220         (set-buffer compilation-last-buffer)
 221         (goto-char comp-buf-pt)
 222
 223         (unless success
 224           ;; none of the hooks handled the error
 225           (error "error not recognized"))
 226         ))))
 227
 228 (provide 'ada-fix-error)
 229 ;; end of file