branch: externals/phps-mode commit d3ae8da2acf67db1717784132cc87071cfcb9057 Author: Christian Johansson <christ...@cvj.se> Commit: Christian Johansson <christ...@cvj.se>
Improved error-handling and error-presentation --- phps-mode-lex-analyzer.el | 123 ++++++++++++++++-------------- phps-mode-lexer.el | 185 ++++++++++++++++++++++++---------------------- phps-mode-serial.el | 40 +++++----- phps-mode.el | 4 +- 4 files changed, 191 insertions(+), 161 deletions(-) diff --git a/phps-mode-lex-analyzer.el b/phps-mode-lex-analyzer.el index 89f79c1..d3a87b3 100644 --- a/phps-mode-lex-analyzer.el +++ b/phps-mode-lex-analyzer.el @@ -342,7 +342,9 @@ (setq async nil)) (phps-mode-serial-commands buffer-name - (lambda() (phps-mode-lex-analyzer--lex-string buffer-contents)) + (lambda() + (phps-mode-lex-analyzer--lex-string buffer-contents)) + (lambda(result) (when (get-buffer buffer-name) (with-current-buffer buffer-name @@ -363,27 +365,33 @@ (let ((token-syntax-color (phps-mode-lex-analyzer--get-token-syntax-color token-name))) (if token-syntax-color (phps-mode-lex-analyzer--set-region-syntax-color start end token-syntax-color) - (phps-mode-lex-analyzer--clear-region-syntax-color start end))))) + (phps-mode-lex-analyzer--clear-region-syntax-color start end)))))))) + + (lambda(result) + (when (get-buffer buffer-name) + (with-current-buffer buffer-name + (let ((error-type (nth 0 result)) + (error-message (nth 1 result)) + (error-start (nth 2 result)) + (error-end (nth 3 result))) + (when error-message + (if (equal error-type 'phps-lexer-error) + (progn + (when error-start + (if error-end + (phps-mode-lex-analyzer--set-region-syntax-color + error-start + error-end + (list 'font-lock-face 'font-lock-warning-face)) + (phps-mode-lex-analyzer--set-region-syntax-color + error-start + (point-max) + (list 'font-lock-face 'font-lock-warning-face)))) + (display-warning 'phps-mode error-message :warning "*PHPs Lexer Errors*")) + (display-warning error-type error-message :warning))))))) + + nil - (let ((errors (nth 4 result)) - (error-start) - (error-end)) - (when errors - (setq error-start (car (cdr errors))) - (when error-start - (if (car (cdr (cdr errors))) - (progn - (setq error-end (car (cdr (cdr (cdr errors))))) - (phps-mode-lex-analyzer--set-region-syntax-color - error-start - error-end - (list 'font-lock-face 'font-lock-warning-face))) - (setq error-end (point-max)) - (phps-mode-lex-analyzer--set-region-syntax-color - error-start - error-end - (list 'font-lock-face 'font-lock-warning-face)))) - (signal 'error (list (format "Lex Errors: %s" (car errors))))))))) async async-by-process))) @@ -407,6 +415,7 @@ incremental-state incremental-state-stack head-tokens)) + (lambda(result) (when (get-buffer buffer-name) (with-current-buffer buffer-name @@ -433,28 +442,33 @@ (phps-mode-lex-analyzer--set-region-syntax-color start end token-syntax-color) (phps-mode-lex-analyzer--clear-region-syntax-color start end))))) - (let ((errors (nth 4 result)) - (error-start) - (error-end)) - (when errors - (setq error-start (car (cdr errors))) - (when error-start - (if (car (cdr (cdr errors))) - (progn - (setq error-end (car (cdr (cdr (cdr errors))))) - (phps-mode-lex-analyzer--set-region-syntax-color - error-start - error-end - (list 'font-lock-face 'font-lock-warning-face))) - (setq error-end (point-max)) - (phps-mode-lex-analyzer--set-region-syntax-color - error-start - error-end - (list 'font-lock-face 'font-lock-warning-face)))) - (signal 'error (list (format "Incremental Lex Errors: %s" (car errors)))))) - (phps-mode-debug-message (message "Incremental tokens: %s" incremental-tokens))))) + + (lambda(result) + (when (get-buffer buffer-name) + (with-current-buffer buffer-name + (let ((error-type (nth 0 result)) + (error-message (nth 1 result)) + (error-start (nth 2 result)) + (error-end (nth 3 result))) + (when error-message + (if (equal error-type 'phps-lexer-error) + (progn + (when error-start + (if error-end + (phps-mode-lex-analyzer--set-region-syntax-color + error-start + error-end + (list 'font-lock-face 'font-lock-warning-face)) + (phps-mode-lex-analyzer--set-region-syntax-color + error-start + (point-max) + (list 'font-lock-face 'font-lock-warning-face)))) + (display-warning 'phps-mode error-message :warning "*PHPs Lexer Errors*")) + (display-warning error-type error-message :warning))))))) + + nil async async-by-process))) @@ -2407,20 +2421,21 @@ SQUARE-BRACKET-LEVEL and ROUND-BRACKET-LEVEL." (setq semantic-lex-analyzer #'phps-mode-lex-analyzer--re2c-lex) ;; Catch errors to kill generated buffer - (condition-case conditions - (progn + (let ((got-error t)) + (unwind-protect ;; Run lexer or incremental lexer - (if (and start end) - (let ((incremental-tokens (semantic-lex start end))) - (setq - phps-mode-lex-analyzer--tokens - (append tokens incremental-tokens))) - (setq - phps-mode-lex-analyzer--tokens - (semantic-lex-buffer)))) - ((error t) (progn - (kill-buffer) - (signal 'error (cdr conditions))))) + (progn + (if (and start end) + (let ((incremental-tokens (semantic-lex start end))) + (setq + phps-mode-lex-analyzer--tokens + (append tokens incremental-tokens))) + (setq + phps-mode-lex-analyzer--tokens + (semantic-lex-buffer))) + (setq got-error nil)) + (when got-error + (kill-buffer)))) ;; Copy variables outside of buffer (setq state phps-mode-lexer--state) diff --git a/phps-mode-lexer.el b/phps-mode-lexer.el index 7f50ab2..d3dbeb6 100644 --- a/phps-mode-lexer.el +++ b/phps-mode-lexer.el @@ -39,6 +39,9 @@ (require 'subr-x) +(define-error 'phps-lexer-error "PHPs Lexer Error") + + ;; INITIALIZE SETTINGS @@ -147,7 +150,7 @@ (if old-state (phps-mode-lexer--BEGIN old-state) (signal - 'error + 'phps-lexer-error (list (format "Trying to pop last state at %d" (point)) (point)))))) @@ -244,12 +247,14 @@ (defun phps-mode-lexer--re2c-execute () "Execute matching body (if any)." (if phps-mode-lexer--match-body - (progn + (progn (set-match-data phps-mode-lexer--match-data) (funcall phps-mode-lexer--match-body)) (signal - 'error - (list "Found no matching lexer rule to execute at %d" (point))))) + 'phps-lexer-error + (list + (format "Found no matching lexer rule to execute at %d" (point)) + (point))))) (defun phps-mode-lexer--reset-match-data () "Reset match data." @@ -540,13 +545,13 @@ ")"))) (when (phps-mode-wy-macros--CG 'PARSER_MODE) (signal - 'error (list - (format - "The (real) cast is deprecated, use (float) instead at %d" - (match-beginning 0) - ) - (match-beginning 0) - (match-end 0))) + 'phps-lexer-error + (list + (format + "The (real) cast is deprecated, use (float) instead at %d" + (match-beginning 0)) + (match-beginning 0) + (match-end 0))) (phps-mode-lexer--RETURN_TOKEN 'T_DOUBLE_CAST (match-beginning 0) (match-end 0)))) (phps-mode-lexer--match-macro @@ -1101,12 +1106,12 @@ (phps-mode-lexer--RETURN_TOKEN 'T_COMMENT start (match-end 0))) (progn (signal - 'error - (list (format - "Un-terminated comment starting at %d" - (point)) - (point) - ))))))) + 'phps-lexer-error + (list + (format + "Un-terminated comment starting at %d" + start) + start))))))) (phps-mode-lexer--match-macro (and ST_IN_SCRIPTING (looking-at (concat "\\?>" phps-mode-lexer--NEWLINE "?"))) @@ -1199,7 +1204,7 @@ (progn (setq open-quote nil) (signal - 'error + 'phps-lexer-error (list (format "Found no ending of quote at %s" start) start)))))))) @@ -1276,7 +1281,8 @@ (phps-mode-lexer--match-macro (and ST_DOUBLE_QUOTES (looking-at phps-mode-lexer--ANY_CHAR)) - (let ((start (point))) + (let ((start (point)) + (start-error (car (cdr (nth 2 phps-mode-lexer--tokens))))) (let ((string-start (search-forward-regexp "[^\\\\]\"" nil t))) (if string-start (let* ((end (- (match-end 0) 1)) @@ -1296,92 +1302,95 @@ ))) (progn (signal - 'error + 'phps-lexer-error (list - (format "Found no ending of double quoted region starting at %d" start) - start))))))) + (format "Found no ending of double quoted region starting at %d" start-error) + start-error))))))) (phps-mode-lexer--match-macro (and ST_BACKQUOTE (looking-at phps-mode-lexer--ANY_CHAR)) - (let ((string-start (search-forward-regexp "\\([^\\\\]`\\|\\$\\|{\\)" nil t))) - (if string-start - (let ((start (- (match-end 0) 1))) - ;; (message "Skipping backquote forward over %s" (buffer-substring-no-properties old-start start)) - (phps-mode-lexer--RETURN_TOKEN 'T_CONSTANT_ENCAPSED_STRING old-start start) - ) - (progn - (signal - 'error - (list - (format "Found no ending of back-quoted string starting at %d" (point)) - (point))))))) + (let ((start (car (cdr (car phps-mode-lexer--tokens))))) + (let ((string-start (search-forward-regexp "\\([^\\\\]`\\|\\$\\|{\\)" nil t))) + (if string-start + (let ((start (- (match-end 0) 1))) + ;; (message "Skipping backquote forward over %s" (buffer-substring-no-properties old-start start)) + (phps-mode-lexer--RETURN_TOKEN 'T_CONSTANT_ENCAPSED_STRING old-start start)) + (progn + (signal + 'phps-lexer-error + (list + (format "Found no ending of back-quoted string starting at %d" start) + start))))))) (phps-mode-lexer--match-macro (and ST_HEREDOC (looking-at phps-mode-lexer--ANY_CHAR)) ;; Check for $, ${ and {$ forward - (let ((string-start - (search-forward-regexp - (concat - "\\(\n" - heredoc-label - ";?\n\\|\\$" - phps-mode-lexer--LABEL - "\\|{\\$" - phps-mode-lexer--LABEL - "\\|\\${" - phps-mode-lexer--LABEL - "\\)" - ) nil t))) - (if string-start - (let* ((start (match-beginning 0)) - (end (match-end 0)) - (data (buffer-substring-no-properties start end))) - ;; (message "Found something ending at %s" data) - - (cond - - ((string-match (concat "\n" heredoc-label ";?\n") data) - ;; (message "Found heredoc end at %s-%s" start end) - (phps-mode-lexer--BEGIN 'ST_END_HEREDOC) - (phps-mode-lexer--RETURN_TOKEN 'T_ENCAPSED_AND_WHITESPACE old-start start)) + (let ((start (car (cdr (car phps-mode-lexer--tokens))))) + (let ((string-start + (search-forward-regexp + (concat + "\\(\n" + heredoc-label + ";?\n\\|\\$" + phps-mode-lexer--LABEL + "\\|{\\$" + phps-mode-lexer--LABEL + "\\|\\${" + phps-mode-lexer--LABEL + "\\)" + ) nil t))) + (if string-start + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (data (buffer-substring-no-properties start end))) + ;; (message "Found something ending at %s" data) - (t - ;; (message "Found variable at '%s'.. Skipping forward to %s" data start) - (phps-mode-lexer--RETURN_TOKEN 'T_ENCAPSED_AND_WHITESPACE old-start start) - ) + (cond - )) - (progn - (signal - 'error - (list - (format "Found no ending of heredoc at %d" (point)) - (point))))))) + ((string-match (concat "\n" heredoc-label ";?\n") data) + ;; (message "Found heredoc end at %s-%s" start end) + (phps-mode-lexer--BEGIN 'ST_END_HEREDOC) + (phps-mode-lexer--RETURN_TOKEN 'T_ENCAPSED_AND_WHITESPACE old-start start)) + + (t + ;; (message "Found variable at '%s'.. Skipping forward to %s" data start) + (phps-mode-lexer--RETURN_TOKEN 'T_ENCAPSED_AND_WHITESPACE old-start start) + ) + + )) + (progn + (signal + 'phps-lexer-error + (list + (format "Found no ending of heredoc starting at %d" start) + start))))))) (phps-mode-lexer--match-macro (and ST_NOWDOC (looking-at phps-mode-lexer--ANY_CHAR)) - (let ((string-start (search-forward-regexp (concat "\n" heredoc-label ";?\\\n") nil t))) - (if string-start - (let* ((start (match-beginning 0)) - (end (match-end 0)) - (_data (buffer-substring-no-properties start end))) - ;; (message "Found something ending at %s" _data) - ;; (message "Found nowdoc end at %s-%s" start end) - (phps-mode-lexer--BEGIN 'ST_END_HEREDOC) - (phps-mode-lexer--RETURN_TOKEN 'T_ENCAPSED_AND_WHITESPACE old-start start)) - (progn - (signal - 'error - (list - (format "Found no ending of newdoc starting at %d" (point)) - (point))))))) + (let ((start (car (cdr (car phps-mode-lexer--tokens))))) + (let ((string-start (search-forward-regexp (concat "\n" heredoc-label ";?\\\n") nil t))) + (if string-start + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (_data (buffer-substring-no-properties start end))) + ;; (message "Found something ending at %s" _data) + ;; (message "Found nowdoc end at %s-%s" start end) + (phps-mode-lexer--BEGIN 'ST_END_HEREDOC) + (phps-mode-lexer--RETURN_TOKEN 'T_ENCAPSED_AND_WHITESPACE old-start start)) + (progn + (signal + 'phps-lexer-error + (list + (format "Found no ending of nowdoc starting at %d" start) + start))))))) (phps-mode-lexer--match-macro (and (or ST_IN_SCRIPTING ST_VAR_OFFSET) (looking-at phps-mode-lexer--ANY_CHAR)) (signal - 'error (list - (format "Unexpected character at %d" (point)) - (point)))) + 'phps-lexer-error + (list + (format "Unexpected character at %d" (match-beginning 0)) + (match-beginning 0)))) (when phps-mode-lexer--match-length (phps-mode-lexer--re2c-execute))))) diff --git a/phps-mode-serial.el b/phps-mode-serial.el index 1dc7d19..dccbc70 100644 --- a/phps-mode-serial.el +++ b/phps-mode-serial.el @@ -7,7 +7,6 @@ ;;; Code: - ;; VARIABLES @@ -43,7 +42,7 @@ (:propertize (:eval (if (equal phps-mode-serial--status 'running) "Running.." "")) face phps-mode-serial--mode-line-face-running) (:propertize (:eval (if (equal phps-mode-serial--status 'error) "Error" "")) - face phps-mode-serial--mode-line-face-error) + face phps-mode-serial--mode-line-face-error) (:propertize (:eval (if (equal phps-mode-serial--status 'success) "OK" "")) face phps-mode-serial--mode-line-face-success))) @@ -64,8 +63,8 @@ (thread-live-p (gethash key phps-mode-serial--async-threads))) (thread-signal (gethash key phps-mode-serial--async-threads) 'quit nil))) -(defun phps-mode-serial-commands (key start end &optional async async-by-process) - "Run command with KEY, first START and if successfully then END with the result of START as argument. Optional arguments ASYNC ASYNC-BY-PROCESS specifies additional options." +(defun phps-mode-serial-commands (key start end &optional start-error end-error async async-by-process) + "Run command with KEY, first START and if successfully then END with the result of START as argument. Optional arguments START-ERROR, END-ERROR that are called on errors. ASYNC ASYNC-BY-PROCESS specifies additional options for synchronicity." (let ((start-time (current-time))) (when phps-mode-serial--profiling (message "PHPs - Starting serial commands for buffer '%s'.." key)) @@ -92,7 +91,8 @@ (progn (let ((start-return (funcall start))) (list 'success start-return start-time))) - ((error t) (list 'error (cdr conditions) start-time)))) + (error (list 'error conditions start-time)))) + (lambda (start-return) (let ((status (car start-return)) (value (car (cdr start-return))) @@ -117,7 +117,7 @@ (progn (let ((return (funcall end value))) (setq end-return (list 'success return start-time)))) - ((error t) (setq end-return (list 'error (cdr conditions) start-time)))) + (error (setq end-return (list 'error conditions start-time)))) ;; Profile execution in debug mode (when phps-mode-serial--profiling @@ -139,11 +139,13 @@ (when (string= status "error") (with-current-buffer key (setq phps-mode-serial--status 'error)) - (display-warning 'phps-mode (format "%s" (car value)))))) + (when end-error + (funcall end-error value))))) (when (string= status "error") (with-current-buffer key (setq phps-mode-serial--status 'error)) - (display-warning 'phps-mode (format "%s" (car value)))))))) + (when start-error + (funcall start-error value))))))) phps-mode-serial--async-processes)) (signal 'error (list "Async-start function is missing"))) @@ -159,7 +161,7 @@ (condition-case conditions (let ((return (funcall start))) (setq start-return (list 'success return start-time))) - ((error t) (setq start-return (list 'error (cdr conditions) start-time)))) + (error (setq start-return (list 'error conditions start-time)))) ;; Profile execution in debug mode (when phps-mode-serial--profiling @@ -177,11 +179,12 @@ (if (string= status "success") (progn + ;; Then execute end lambda (condition-case conditions (let ((return (funcall end value))) (setq end-return (list 'success return start-time))) - ((error t) (setq end-return (list 'error (cdr conditions) start-time)))) + (error (setq end-return (list 'error conditions start-time)))) ;; Profile execution (when phps-mode-serial--profiling @@ -203,12 +206,14 @@ (when (string= status "error") (with-current-buffer key (setq phps-mode-serial--status 'error)) - (display-warning 'phps-mode (format "%s" (car value)))))) + (when end-error + (funcall end-error value))))) (when (string= status "error") (with-current-buffer key (setq phps-mode-serial--status 'error)) - (display-warning 'phps-mode (format "%s" (car value)))))))) + (when start-error + (funcall start-error value))))))) key) phps-mode-serial--async-threads)) @@ -220,7 +225,7 @@ (progn (let ((return (funcall start))) (setq start-return (list 'success return start-time)))) - ((error t) (setq start-return (list 'error (cdr conditions) start-time)))) + (error (setq start-return (list 'error conditions start-time)))) ;; Profile execution in debug mode (when phps-mode-serial--profiling @@ -243,7 +248,7 @@ (condition-case conditions (let ((return (funcall end value))) (setq end-return (list 'success return start-time))) - ((error t) (setq end-return (list 'error (cdr conditions) start-time)))) + (error (setq end-return (list 'error conditions start-time)))) ;; Profile execution in debug mode (when phps-mode-serial--profiling @@ -265,13 +270,14 @@ (when (string= status "error") (with-current-buffer key (setq phps-mode-serial--status 'error)) - (display-warning 'phps-mode (format "%s" (car value)))))) + (when end-error + (funcall end-error value))))) (when (string= status "error") (with-current-buffer key (setq phps-mode-serial--status 'error)) - (display-warning 'phps-mode (format "%s" (car value)))))))))) - + (when start-error + (funcall start-error value))))))))) (provide 'phps-mode-serial) ;;; phps-mode-serial.el ends here diff --git a/phps-mode.el b/phps-mode.el index b3db1aa..b248544 100644 --- a/phps-mode.el +++ b/phps-mode.el @@ -5,8 +5,8 @@ ;; Author: Christian Johansson <christ...@cvj.se> ;; Maintainer: Christian Johansson <christ...@cvj.se> ;; Created: 3 Mar 2018 -;; Modified: 12 May 2020 -;; Version: 0.3.48 +;; Modified: 18 May 2020 +;; Version: 0.3.49 ;; Keywords: tools, convenience ;; URL: https://github.com/cjohansson/emacs-phps-mode