Skip to content

Commit

Permalink
Fix #781 PG does not position to error.
Browse files Browse the repository at this point in the history
A test is also added to check the exact position of the error
highlighting.

Description of the fix.

We cannot use the " ^^^ " thing to compute the error location because
commands are not stripped of newlines anymoire (#774).

Solution: use the character position information with the following
subtleties

- position are given by coq **bytes** positions.
- position given by coq is the position from the previous "." fed to
  coq. I.e. we must be careful to strip any blank after the final "." of
  a command.

In the test we make the disappearing tuimeout of overlay bigger
so that tests don't fail on slow VMs  (maybe useless).

Coq-8.11 has a small glitch on positions, the test is compatible with
both behaviour.
  • Loading branch information
Matafou committed Sep 2, 2024
1 parent eca47ea commit 48b0afc
Show file tree
Hide file tree
Showing 3 changed files with 76 additions and 46 deletions.
38 changes: 33 additions & 5 deletions ci/coq-tests.el
Original file line number Diff line number Diff line change
Expand Up @@ -255,11 +255,39 @@ For example, COMMENT could be (*test-definition*)"
(coq-test-full-path "test_stepwise.v")
(lambda ()
(coq-test-goto-before " (*test-lemma2*)")
(let ((proof-point (save-excursion (coq-test-goto-after "(*error*)"))))
(proof-goto-point)
(proof-shell-wait)
(coq-should-buffer-string "Error: Unable to unify \"false\" with \"true\".")
(should (equal (proof-queue-or-locked-end) proof-point))))))
;; redefining this function locally so that self removing spans
;; remain longer. Cf span.el
(cl-letf (((symbol-function 'span-make-self-removing-span)
(lambda (beg end &rest props)
(let ((ol (span-make beg end)))
(while props
(overlay-put ol (car props) (cadr props))
(setq props (cddr props)))
(add-timeout 10 'delete-overlay ol)
ol))))

(let ((proof-point (save-excursion (coq-test-goto-after "(*error*)") (point)))
(proof-cmd-point (save-excursion
(coq-test-goto-after "(*error*)")
(re-search-forward "reflexivity")
(re-search-backward "reflexivity"))))
(proof-goto-point)
(proof-shell-wait)
(coq-should-buffer-string "Error: Unable to unify \"false\" with \"true\".")
;; checking that there is an overlay with warning face exactly
;; on "reflexivity". WARNING: this overlat lasts only for 2
;; secs, if this test is done in a (very) slow virtual machine
;; this may fail.
(should (equal (point) proof-cmd-point))
(let ((sp (span-at proof-cmd-point 'face)))
(should sp)
(should (equal (span-property sp 'face) 'proof-warning-face))
(should (equal (span-start sp) proof-cmd-point))
;; coq-8.11 used to hace ending ps shifted by one
(should (or (equal (span-end sp) (+ proof-cmd-point (length "reflexivity")))
(equal (span-end sp) (+ 1 proof-cmd-point (length "reflexivity")))))
)
(should (equal (proof-queue-or-locked-end) proof-point)))))))


;; Disable tests that use test_wholefile.v. The file is outdated, uses
Expand Down
72 changes: 33 additions & 39 deletions coq/coq.el
Original file line number Diff line number Diff line change
Expand Up @@ -2957,7 +2957,7 @@ Completion is on a quasi-exhaustive list of Coq tacticals."
"Last error from `coq-get-last-error-location' and `coq-highlight-error'.")

(defvar coq--error-location-regexp
"^Toplevel input[^:]+:\n> \\(.*\\)\n> \\([^^]*\\)\\(\\^+\\)\n"
"^Toplevel input, characters \\(?1:[0-9]+\\)-\\(?2:[0-9]+\\):\n"
"A regexp to search the header of coq error locations.")

;; I don't use proof-shell-last-output here since it is not always set to the
Expand Down Expand Up @@ -2985,43 +2985,27 @@ buffer."
(if (not parseresp) last-coq-error-location
;; proof-shell-handle-error-or-interrupt-hook is called from shell buffer
;; then highlight the corresponding error location
(proof-with-current-buffer-if-exists proof-response-buffer
(goto-char (point-max)) ;\nToplevel input, character[^:]:\n
(when (re-search-backward coq--error-location-regexp nil t)
(let ((text (match-string 1))
(pos (length (match-string 2)))
(len (length (match-string 3))))
;; clean the response buffer from ultra-ugly underlined command line
;; parsed above. Don't kill the first \n
(let ((inhibit-read-only t))
(when clean (delete-region (match-beginning 0) (match-end 0))))
(when proof-shell-unicode ;; TODO: remove this (when...) when coq-8.3 is out.
;; `pos' and `len' are actually specified in bytes, apparently. So
;; let's convert them, assuming the encoding used is utf-8.
;; Presumably in Emacs-23 we could use `string-bytes' for that
;; since the internal encoding happens to use utf-8 as well.
;; Actually in coq-8.3 one utf8 char = one space so we do not need
;; this at all
(let ((bytes text)) ;(encode-coding-string text 'utf-8-unix)
;; Check that pos&len make sense in `bytes', if not give up.
(when (>= (length bytes) (+ pos len))
;; We assume here that `text' is a single line and use \n as
;; a marker so we can find it back after decoding.
(setq bytes (concat (substring bytes 0 pos)
"\n" (substring bytes pos (+ pos len))))
(let ((chars (decode-coding-string bytes 'utf-8-unix)))
(setq pos (string-match "\n" chars))
(setq len (- (length chars) pos 1))))))
(setq last-coq-error-location (list pos len)))))))

(let* ((reg coq--error-location-regexp)
(msg proof-shell-last-response-output))
(if (not (string-match reg msg))
(setq last-coq-error-location (list 0 0))
(let ((pos (string-to-number (match-string 1 msg)))
(end (string-to-number (match-string 2 msg))))
(setq last-coq-error-location (list pos (- end pos))))))))

(defun point-add-bytes (nbytes)
"Return current point shifted by NBYTES bytes."
(byte-to-position (+ (position-bytes (point)) nbytes)))

(defun coq-highlight-error (&optional parseresp clean)
"Parse the last Coq output looking at an error message.
"Return position and length of error in last message.
Highlight the text pointed by it.
Coq error message must be like this:
\"
> command with an error here ...
Toplevel input, characters 60-66:
> ...
> ^^^^
\"
Expand All @@ -3030,20 +3014,30 @@ If PARSERESP is nil, don't really parse response buffer but take the value of
`last-coq-error-location'.
If PARSERESP and CLEAN are non-nil, delete the error location from the response
buffer."
buffer.
Important: Coq gives char positions in bytes instead of chars.
"
(proof-with-current-buffer-if-exists proof-script-buffer
(let ((mtch (coq-get-last-error-location parseresp clean)))
(when mtch
(let ((pos (car mtch))
(lgth (cadr mtch)))
(goto-char (+ (proof-unprocessed-begin) 1))
(coq-find-real-start)

;; utf8 adaptation is made in coq-get-last-error-location above
(let ((time-offset (if coq-time-commands (length coq--time-prefix) 0)))
(goto-char (+ (point) pos))
(span-make-self-removing-span (point) (+ (point) (- lgth time-offset))
'face 'proof-warning-face)))))))
;; locations are given in bytes. translate into valid positions
(let* ((cmdstart (point))
(len (- (save-excursion (coq-script-parse-cmdend-forward) (point)) (point)))
(beg (goto-char (point-add-bytes pos)))
(end (goto-char (point-add-bytes lgth))))
(if (not (and (<= pos len) (<= end (+ beg len))))
;; positions seem wrong (e.g. coq bug #19355), fallback:
(progn
(goto-char cmdstart)
(span-make-self-removing-span cmdstart (+ cmdstart len 2) 'face 'proof-warning-face))
(goto-char beg) ;; move point to error
(span-make-self-removing-span beg end 'face 'proof-warning-face)
)))))))

(defun coq-highlight-error-hook ()
(coq-highlight-error t t))
Expand Down
12 changes: 10 additions & 2 deletions generic/proof-shell.el
Original file line number Diff line number Diff line change
Expand Up @@ -930,6 +930,10 @@ the prover command buffer (e.g., with Isabelle2009 press RET inside *isabelle*).
;; Low-level commands for shell communication
;;

(defun proof-remove-trailing-blanks (s)
(let ((pos (string-match "\\s-*\\'" s)))
(substring s 0 pos)))

;;;###autoload
(defun proof-shell-insert (strings action &optional scriptspan)
"Insert STRINGS at the end of the proof shell, call `scomint-send-input'.
Expand Down Expand Up @@ -969,8 +973,12 @@ used in `proof-add-to-queue' when we start processing a queue, and in
(run-hooks 'proof-shell-insert-hook)

;; Replace CRs from string with spaces to avoid spurious prompts.
(if proof-shell-strip-crs-from-input
(setq string (subst-char-in-string ?\n ?\ string)))
(when proof-shell-strip-crs-from-input
(setq string (subst-char-in-string ?\n ?\ string)))

;; avoid feeding the proof assistant with blanks at the end that
;; will mess with error locations
(setq string (proof-remove-trailing-blanks string))

(insert string)

Expand Down

0 comments on commit 48b0afc

Please sign in to comment.