;;; e2-mode.el --- Major Mode for E2                 -*- lexical-binding: t; -*-

;; Copyright (C) 2021  Florian Guthmann
;; Copyright (C) 2022, 2023  Philip Kaludercic

;; Author: Florian Guthmann <florian.guthmann@fau.de>
;; Version: $Id: e2-mode.el,v 1.8 2023/06/18 17:00:39 oj14ozun Exp $
;; Maintainer: Philip Kaludercic <philip.kaludercic@fau.de>
;; URL: https://wwwcip.cs.fau.de/~oj14ozun/src+etc/e2-mode.el
;; Package-Requires: ((emacs "25.1") (flymake "1.0.0"))
;; Package-Version: 1
;; Keywords: languages

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; A major mode for the programming language E2 (as used in the
;; compiler courses of the programming systems chair at the University
;; of Erlangen and Nuremberg: https://www.ps.tf.fau.de/ue1/), with
;; support for:
;;
;; - Syntax Highlighting (font-lock).
;; - Indentation (SMIE).
;; - Completion (completion-at-point).
;; - Compilation (`compile').
;; - On-the-fly Error Checking (Flymake).
;; - Jump-to-definition (Xref).
;; - Function index (Imenu).

;;; Code:

(eval-when-compile (require 'subr-x))
(eval-when-compile (require 'rx))
(require 'cl-generic)
(require 'xref)
(require 'smie)

(defgroup e2-mode ()
  "Major mode for the E2 programming language."
  :group 'languages
  :prefix "e2-")

(defcustom e2-compiler-executable nil
  "Path to the E2 compiler."
  :type '(option (const :tag "Unset" nil)
                 (file :must-match t)))

(defconst e2-keywords
  '("func" "end" "if" "then" "else" "while"
    "do" "return" "var" "and" "or" "as")
  "List of E2 keywords.")

(defconst e2-types
  '("int" "real")
  "List of E2 types.")

(defconst e2-builtin
  '("writeChar" "readChar" "writeInt" "readInt"
    "writeReal" "readReal" "exit")
  "List of E2 standard library functions.")

(defconst e2-grammar
  (eval-when-compile
    (smie-prec2->grammar
     (smie-bnf->prec2
      '((insts    (inst ";" insts)
                  (inst))
        (inst     ("func" id "_begin" insts "end")
                  ("var" id ":" id)
                  ("if" bool-exp "then" insts "else" insts "end")
                  ("if" bool-exp "then" insts "end")
                  ("while" bool-exp "do" insts "end")
                  ("return" exp)
                  (id ":=" exp))
        (bool-exp (bool-exp "and" bool-exp)
                  (bool-exp "or" bool-exp)
                  (cmp-exp))
        (cmp-exp  (exp "==" exp)
                  (exp "!=" exp)
                  (exp "<" exp)
                  (exp ">" exp)
                  (exp "<=" exp)
                  (exp ">=" exp))
        (exp      (exp "[" exp "]")
                  (exp "+" exp)
                  (exp "-" exp)
                  (exp "*" exp)
                  (exp "/" exp)
                  (id))
        (id))
      '((right "and") (right "or"))
      '((assoc "+") (assoc "-")
        (assoc "*") (assoc "/")
        (right "[")))))
  "SMIE grammar for E2.")

(defconst e2-syntax-table
  (let ((st (make-syntax-table)))
    (modify-syntax-entry ?\# "<" st)
    (modify-syntax-entry ?\n ">#" st)
    (modify-syntax-entry ?\; "." st)
    (modify-syntax-entry ?* "." st)
    (modify-syntax-entry ?+ "." st)
    (modify-syntax-entry ?/ "." st)
    (modify-syntax-entry ?- "." st)
    st)
  "Syntax table for E2 mode.")

(defun e2--func-list ()
  "Scan the file for function definitions."
  (let (funcs)
    (save-restriction
      (widen)
      (save-excursion
        (goto-char (point-min))
        (while (search-forward-regexp
                (rx bol (* space) "func" (+ space)
                    (group (+ (any "_" alnum)))
                    "(" (*? nonl) ")" (* space)
                    (? ":" (* space) (group (or "int" "real"))))
                nil t)
          (push (propertize (match-string-no-properties 1)
                            'e2-signature (match-string-no-properties 2)
                            'e2-position  (match-beginning 1))
                funcs))))
    (append funcs e2-builtin)))

(defun e2--var-list (&optional point)
  "Return a list of visible variables at POINT.
If POINT is not given, default to the current point."
  (let (vars)
    (save-restriction
      (widen)
      (save-excursion
        (goto-char (point-min))
        (while (search-forward-regexp
                (rx symbol-start
                    (or (: (group-n 1 "func")
                           symbol-end)
                        (: (group-n 1 "var") symbol-end (+ space)
                           (group-n 2 (+ (or alnum "_"))) (* space)
                           ":" (* space)
                           (group-n 3 (+? nonl))
                           (* space) ";")))
                nil t)
          (cond
           ((string= (match-string 1) "var")
            (push (propertize (match-string-no-properties 2)
                              'e2-signature (match-string-no-properties 3)
                              'e2-position  (match-beginning 2))
                  vars))
           ((string= (match-string 1) "func")
            (goto-char (match-beginning 0))
            (smie-forward-sexp))))))
    (save-restriction
      (save-excursion
        (let ((end (or point (point))))
          (when (search-backward-regexp
                 (rx bol (* space) symbol-start "func" symbol-end (* space)
                     (+ (any "_" alnum)) "(" (group (*? nonl)) ")")
                 nil t)
            (save-restriction
              (narrow-to-region (match-beginning 1) (match-end 1))
              (save-excursion
                (while (search-forward-regexp
                        (rx (group (+ (or alnum "_"))) (* space)
                            ":" (* space) (group (+? nonl)) (* space) (? ","))
                        nil t)
                  (push (propertize (match-string-no-properties 1)
                                    'e2-signature (match-string-no-properties 2)
                                    'e2-position  (match-beginning 1))
                        vars))))
            (narrow-to-region (point) end)
            (while (search-forward-regexp
                    (rx symbol-start "var" symbol-end (+ space)
                        (group (+ (or alnum "_"))) (* space)
                        ":" (* space) (group (+? nonl)) (* space) ";")
                    nil t)
              (push (propertize (match-string-no-properties 1)
                                'e2-signature (match-string-no-properties 2)
                                'e2-position  (match-beginning 1))
                    vars))))))
    vars))

(defun e2-capf-annotate (str)
  "Extract the type signature from STR."
  (let ((sig (get-text-property 0 'e2-signature str)))
    (and sig (concat " : " sig))))

(defun e2-completion-at-point ()
  "Completion at point backend for e2."
  (let ((beg (save-excursion
               (skip-syntax-backward "w_")
               (point)))
        (end (save-excursion
               (skip-syntax-forward "w_")
               (point))))
    (and (or (/= beg end)
             (not (looking-back (rx (or bol (+ space))) (point-min))))
         (list beg end
               (completion-table-dynamic
                (lambda (&rest _ignore)
                  (delete-dups
                   (append e2-keywords e2-types
                           (e2--func-list)
                           (e2--var-list)))))
               :annotation-function #'e2-capf-annotate
               :exclusive 'no))))

(defconst e2-font-lock-keywords
  `(("#.*$" . font-lock-comment-face)
    (,(regexp-opt e2-keywords 'words) . font-lock-keyword-face)
    (,(regexp-opt e2-types 'words) . font-lock-type-face)
    (,(regexp-opt e2-builtin 'symbols) . font-lock-builtin-face)
    ("'[ -~]'" . font-lock-string-face)
    ("\\([_[:alpha:]][_[:alnum:]]*\\)[[:space:]]*("
     1 font-lock-function-name-face)))

(defconst e2-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "M-C-d") #'smie-down-list)
    (define-key map (kbd "C-c ]") #'smie-close-block)
    (define-key map (kbd "C-c C-c") #'e2-compile)
    map)
  "Keymap for E2 mode.")

(defun e2-compile (file)
  "Call the E2 compiler on FILE.
This makes use of the `e2-compiler-executable' user option."
  (interactive "fFile: ")
  (unless (and e2-compiler-executable (executable-find e2-compiler-executable))
    (user-error "Cannot find E2 compiler"))
  (compile (format "%s %s" e2-compiler-executable file)))

(defvar-local e2--flymake-process nil "Active flymake process.")

(defun e2--flymake-backend (report-fn &rest _args)
  "Flymake backend for E2.
The argument REPORT-FN is documented in the Flymake manual, under
the Info node `(flymake) Backend functions'."
  (when (and e2-compiler-executable (executable-find e2-compiler-executable))
    (when (process-live-p e2--flymake-process)
      (kill-process e2--flymake-process))
    (let* ((in (make-temp-file "e2-flymake" nil nil (buffer-string)))
           (buffer (current-buffer))
           (sentinel
            (lambda (proc _event)
              (with-current-buffer (process-buffer proc)
                (goto-char (point-min))
                (let (diags)
                  (while (search-forward
                          (rx bol
                              "[" (group (+ digit))
                              ":" (group (+ digit))
                              "]" (* space) (group (+ nonl)))
                          nil t)
                    (let* ((line (string-to-number (match-string 1)))
                           (col (string-to-number (match-string 1)))
                           (region (flymake-diag-region buffer line col)))
                      (push (flymake-make-diagnostic
                             buffer (car region) (cdr region)
                             :error (match-string 3))
                            diags)))
                  (funcall report-fn diags)))
              (unless (process-live-p proc)
                (delete-file in)))))
      (setq e2--flymake-process
            (make-process
             :noquery t :connection-type 'pipe
             :buffer (generate-new-buffer " *e2-flymake*")
             :command (list e2-compiler-executable in)
             :sentinel sentinel)))))

(defun e2-beginning-of-defun (&optional arg)
  "Move to the beginning of a top level definition.
If ARG is non-nil, repeat the operation ARG times."
  (dotimes (_ (or arg 1))
    (re-search-backward (rx bol (* space) "func") nil t)))

(defun e2-end-of-defun ()
  "Move to the end of a top level definition."
  (unless (looking-at-p (rx (* blank "\n") "func"))
    (re-search-backward (rx bol (* space) "func") nil t))
  (smie-forward-sexp))

(defun e2-backward-token ()
  "Scan a token backward."
  (let (pos tok)
    (save-excursion
      (setq tok (smie-default-backward-token))
      (setq pos (point)))
    (cond
     ((looking-back
       (rx bol (* space) symbol-start "func" symbol-end (* space)
           (+ (any "_" alnum)) "(" (group (*? nonl)) ")"
           (? (* space) ":" (* space) (or "int" "real"))
           (+ space))
       (point-min))
      (skip-chars-backward " \n\t")
      "_begin")
     ((or (not (string= tok "end"))
          (looking-back "end" (line-beginning-position)))
      (goto-char pos)
      tok)
     ((skip-chars-backward " \n\t")
      ";"))))

(defun e2-forward-token ()
  "Scan a token forward."
  (let (last-tok)
    (save-excursion
      (setq last-tok (smie-default-backward-token)))
    (cond
     ((and (looking-back
            (rx ")" (? (* space) ":" (* space) (or "int" "real")))
            (line-beginning-position))
           (eolp))
      (forward-char) "_begin")
     ((and (string= last-tok "end")
           (looking-back "end" (line-beginning-position)))
      (forward-char) ";")
     ((smie-default-forward-token)))))

(cl-defmethod xref-backend-definitions ((_ (eql e2)) id)
  "Xref backend for E2.
It attempts to find all symbols that satisfy ID."
  (let (xrefs)
    (dolist (sym (append (e2--var-list) (e2--func-list)))
      (when (string= sym id)
        (let ((pos (get-text-property 0 'e2-position sym)))
          (when pos
            (let ((loc (xref-make-buffer-location
                        (current-buffer) pos)))
              (push (xref-make id loc) xrefs))))))
    xrefs))

(defun e2-imenu-create-index ()
  "Create a Imenu index."
  (mapcan
   (lambda (sym)
     (let ((pos (get-text-property 0 'e2-position sym)))
       (and pos (list (cons sym pos)))))
   (e2--func-list)))

;;;###autoload
(define-derived-mode e2-mode prog-mode "E2"
  "Major mode for editing programs in E2."
  (setq-local completion-at-point-functions (list #'e2-completion-at-point))
  (setq-local font-lock-defaults '(e2-font-lock-keywords))
  (setq-local comment-start "# ")
  (setq-local comment-end "")
  (setq-local comment-start-skip "#+ *")
  (setq-local beginning-of-defun-function #'e2-beginning-of-defun)
  (setq-local end-of-defun-function #'e2-end-of-defun)
  (setq-local sentence-end (rx (or ";" (: word-start "end" word-end))))
  (setq-local sentence-end-double-space nil)
  (setq-local imenu-generic-expression
              `((nil ,(rx bol "func" (+ space) (group (+ (any "_" alnum)))) 1)))
  (setq-local smie-indent-basic 2)
  (smie-setup e2-grammar #'ignore
              :backward-token #'e2-backward-token
              :forward-token #'e2-forward-token)
  (setq-local xref-backend-functions (lambda () 'e2))
  (add-hook 'flymake-diagnostic-functions
            #'e2--flymake-backend
            nil t)
  (setq-local imenu-create-index-function #'e2-imenu-create-index))

;;;###autoload
(add-to-list 'auto-mode-alist '("\\.e2\\'" . e2-mode))

;;;###autoload
(add-to-list 'auto-mode-alist '("\\.ir\\'" . asm-mode))

;; Local Variables:
;; indent-tabs-mode: nil
;; show-trailing-whitespace: t
;; End:

(provide 'e2-mode)
;;; e2-mode.el ends here