;;; -*- lexical-binding: t; -*-

;; Author: Andrea Corallo <andrea.corallo@arm.com>
;; Package: mdcompact
;; Keywords: languages, extensions
;; Package-Requires: ((emacs "29"))

;; This file is part of GCC.

;; GCC 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.

;; GCC 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 GCC.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Convert multi choice GCC machine description patterns to compact
;; syntax.

;;; Usage:

;; With the point on a pattern run 'M-x mdcomp-run-at-point' to
;; convert that pattern.

;; Run 'M-x mdcomp-run-buffer' to convert all convertible patterns in
;; the current buffer.

;; Run 'M-x mdcomp-run-directory' to convert all convertible patterns
;; in a directory.

;; One can invoke the tool from shell as well, ex for running it on
;; the arm backend from the GCC checkout directory:
;; emacs -batch -l ./contrib/mdcompact/mdcompact.el -f mdcomp-run-directory ./gcc/config/arm/

;;; Code:

(require 'cl-lib)
(require 'rx)

(defconst
  mdcomp-constr-rx
  (rx "(match_operand" (? ":" (1+ (or punct alnum)))
      (1+ space) (group-n 1 num) (1+ space) "\""
      (1+ (or alnum "_" "<" ">")) "\""
      (group-n 2 (1+ space) "\"" (group-n 3 (0+ (not "\""))) "\"")
      ")"))

(cl-defstruct mdcomp-operand
  num
  cstr)

(cl-defstruct mdcomp-attr
  name
  vals)

;; A reasonable name
(rx-define mdcomp-name (1+ (or alnum "_")))

(defconst mdcomp-attr-rx
  (rx "(set_attr" (1+ space) "\""
      (group-n 1 mdcomp-name)
      "\"" (1+ space) "\""
      (group-n 2 (1+ (not ")")))
      "\"" (0+ space) ")"))

(defun mdcomp-parse-delete-attr ()
  (save-match-data
    (when (re-search-forward mdcomp-attr-rx nil t)
      (let ((res (save-match-data
		   (make-mdcomp-attr
		    :name (match-string-no-properties 1)
		    :vals (cl-delete-if #'string-empty-p
					(split-string
					 (replace-regexp-in-string
					  (rx "\\") ""
					  (match-string-no-properties 2))
						      (rx (1+ (or space ",")))))))))
	(if (length= (mdcomp-attr-vals res) 1)
	    'short
	  (delete-region (match-beginning 0) (match-end 0))
	  res)))))

(defun mdcomp-parse-attrs ()
  (save-excursion
    (let* ((res (cl-loop for x = (mdcomp-parse-delete-attr)
			 while x
			 collect x))
	   (beg (re-search-backward (rx bol (1+ space) "["))))
      (unless (memq 'short res)
	(when res
	  (delete-region beg (re-search-forward (rx "]")))))
      (cl-delete 'short res))))

(defun mdcomp-remove-quoting (beg)
  (save-excursion
    (save-match-data
      (replace-regexp-in-region (regexp-quote "\\\\") "\\\\" beg (point-max))
      (replace-regexp-in-region (regexp-quote "\\\"") "\"" beg (point-max)))))

(defun mdcomp-remove-escaped-newlines (beg)
  (save-excursion
    (save-match-data
      (replace-regexp-in-region (rx "\\" eol (0+ space)) " " beg (point-max)))))

(defun mdcomp-parse-delete-cstr ()
  (cl-loop while (re-search-forward mdcomp-constr-rx nil t)
	   unless (string= "" (match-string-no-properties 3))
	     collect (save-match-data
		       (make-mdcomp-operand
			:num (string-to-number (match-string-no-properties 1))
			:cstr (cl-delete-if #'string-empty-p
					    (split-string
					     (replace-regexp-in-string " " ""
								       (match-string-no-properties 3))
					     (rx (1+ ","))))))
	   do (delete-region (match-beginning 2) (match-end 2))))

(defun mdcomp-run* ()
  (let* ((ops (mdcomp-parse-delete-cstr))
	     (attrs (mdcomp-parse-attrs))
	     (beg (re-search-forward "\"@")))
	(cl-sort ops (lambda (x y)
		       (< (mdcomp-operand-num x) (mdcomp-operand-num y))))
	(mdcomp-remove-escaped-newlines beg)
	(save-match-data
	  (save-excursion
	    (left-char 2)
	    (forward-sexp)
	    (left-char 1)
	    (delete-char 1)
	    (insert "\n  }")))
	(mdcomp-remove-quoting beg)
	(replace-match "{@")
	(re-search-forward (rx (or "\"" ")")))
	(re-search-backward "@")
	(right-char 1)
	(insert "[ cons: ")
	(cl-loop
	 for op in ops
	 when (string-match "=" (cl-first (mdcomp-operand-cstr op)))
	 do (insert "=")
	 do (insert (number-to-string (mdcomp-operand-num op)) ", ")
	 finally
	 (progn
	   ;; In case add attributes names
	   (when attrs
	     (delete-char -2)
	     (insert "; attrs: ")
	     (cl-loop for attr in attrs
		      do (insert (mdcomp-attr-name attr) ", ")))
	   (delete-char -2)
	   (insert "]")))
	(cl-loop
	 while (re-search-forward (rx bol (0+ space) (or (group-n 1 "* return")
							 (group-n 2 "}")
							 "#" alpha "<"))
				  nil t)
	 for i from 0
	 when (match-string 2)
	   do (cl-return)
	 when (match-string 1)
	   do (progn
		(delete-region (match-beginning 1) (+ (match-beginning 1) (length "* return")))
		(insert "<<")
		(left-char 1))
	 do
	 (progn
	   (left-char 1)
	   (cl-loop
	    initially (insert " [ ")
	    for op in ops
	    for c = (nth i (mdcomp-operand-cstr op))
	    unless c
	      do (cl-return)
	    do (insert (if (string-match "=" c)
			   (substring c 1 nil)
			 c)
		       ", ")
	    finally (progn
		      (when attrs
			(delete-char -2)
			(insert "; ")
			(cl-loop for attr in attrs
				 for str = (nth i (mdcomp-attr-vals attr))
				 when str
				   do (insert str)
				 do (insert ", ")))
		      (delete-char -2)
		      (insert " ] ")
		      (move-end-of-line 1)))))
	;; remove everything after ] align what needs to be aligned
	;; and re-add the asm template
	(re-search-backward (regexp-quote "@[ cons:"))
	(let* ((n (length (mdcomp-operand-cstr (car ops))))
	       (asms (cl-loop
		      initially (re-search-forward "]")
		      repeat n
		      collect (let* ((beg (re-search-forward "]"))
				     (end (re-search-forward (rx eol)))
				     (str (buffer-substring-no-properties beg end)))
				(delete-region beg end)
				str)))
	       (beg (re-search-backward (regexp-quote "@[ cons:")))
	       (indent-tabs-mode nil))
	  (re-search-forward "}")
	  (align-regexp beg (point) (rx  (group-n 1 "") "["))
	  (align-regexp beg (point) (rx  (group-n 1 "") (or "," ";")) nil nil t)
	  (align-regexp beg (point) (rx  (group-n 1 "") "]"))
	  (goto-char beg)
	  (cl-loop
	   initially (re-search-forward "]")
	   for i below n
	   do (progn
		(re-search-forward "]")
		(insert (nth i asms))))
	  (when (re-search-forward (rx (1+ (or space eol)) ")") nil t)
	    (replace-match "\n)" nil t)))))

(defun mdcomp-narrow-to-md-pattern ()
  (condition-case nil
      (let ((beg (re-search-forward "\n("))
	    (end (re-search-forward (rx bol (1+ ")")))))
	(narrow-to-region beg end))
    (error
     (narrow-to-defun))))

(defun mdcomp-run-at-point ()
  "Convert the multi choice top-level form around point to compact syntax."
  (interactive)
  (save-restriction
    (save-mark-and-excursion
      (mdcomp-narrow-to-md-pattern)
      (goto-char (point-min))
      (let ((pattern-name (save-excursion
			    (re-search-forward (rx "\"" (group-n 1 (1+ (not "\""))) "\""))
			    (match-string-no-properties 1)))
	    (orig-text (buffer-substring-no-properties (point-min) (point-max))))
	(condition-case nil
	    (progn
	      (mdcomp-run*)
	      (message "Converted: %s" pattern-name))
	  (error
	   (message "Skipping convertion for: %s" pattern-name)
	   (delete-region (point-min) (point-max))
	   (insert orig-text)
	   'fail))))))

(defun mdcomp-run-buffer ()
  "Convert the multi choice top-level forms in the buffer to compact syntax."
  (interactive)
  (save-excursion
    (message "Conversion for buffer %s started" (buffer-file-name))
    (goto-char (point-min))
    (while (re-search-forward
	    (rx "match_operand" (1+ any) letter (0+ space) "," (0+ space) letter) nil t)
      (when (eq (mdcomp-run-at-point) 'fail)
	(condition-case nil
	    (forward-sexp)
	  (error
	   ;; If forward-sexp fails falls back.
	   (re-search-forward (rx ")" eol eol))))))
    (message "Conversion done")))

(defconst mdcomp-file-rx (rx bol alpha (0+ not-newline) ".md" eol))

(defun mdcomp-run-directory (folder &optional recursive)
  "Run el mdcompact on a FOLDER possibly in a RECURSIVE fashion."
  (interactive "D")
  (let ((before-save-hook nil)
	(init-time (current-time)))
    (mapc (lambda (f)
	    (with-temp-file f
	      (message "Working on %s" f)
	      (insert-file-contents f)
	      (mdcomp-run-buffer)
	      (message "Done with %s" f)))
	  (if recursive
	      (directory-files-recursively folder mdcomp-file-rx)
	    (directory-files folder t mdcomp-file-rx)))
    (message "Converted in %f sec" (float-time (time-since init-time)))))

(defun mdcomp-batch-run-directory ()
  "Same as `mdcomp-run-directory' but use cmd line args."
  (mdcomp-run-directory (nth 0 argv) (nth 1 argv)))

(provide 'mdcompact)

;;; mdcompact.el ends here