mirror of
https://github.com/pestctrl/emacs-config.git
synced 2026-02-16 08:14:15 +00:00
198 lines
7.8 KiB
EmacsLisp
198 lines
7.8 KiB
EmacsLisp
;;; act-on-test-file.el --- -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2022 Benson Chu
|
|
|
|
;; Author: Benson Chu <bensonchu457@gmail.com>
|
|
;; Created: [2022-12-16 19:17]
|
|
|
|
;; This file is not part of GNU Emacs
|
|
|
|
;; 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:
|
|
|
|
;;; Code:
|
|
(require 'llvm-shared)
|
|
(require 'action-map-lib)
|
|
(require 'dash)
|
|
|
|
(defvar ll/test-file-action-map
|
|
'((normal :key ?\^M :major-mode nil :buffer-string "run" :description "[RET] run test")
|
|
(verbose :key ?v :major-mode nil :buffer-string "verbose" :description "[v]erbose")
|
|
(all :key ?a :major-mode nil :buffer-string "VERBOSE" :description "[a]ll-output")
|
|
(test-action :key ?A :major-mode asm-mode :buffer-string "test-action" :description "test [A]ction")))
|
|
|
|
(defun ll/is-test-file (file)
|
|
(and (member (file-name-extension file)
|
|
'("ll" "c" "mir" "s"))
|
|
(string-match-p ".*llvm-project.*test.*" file)))
|
|
|
|
(defun ll/get-test-run-commands (file)
|
|
(with-current-buffer (or (find-buffer-visiting file)
|
|
(find-file-noselect file))
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(let ((r (rx line-start (+ (or "|" ";" "/" "#")) (+ " ") "RUN:" (+ space) (group(+ nonl) line-end)))
|
|
(temp "")
|
|
l)
|
|
(while (re-search-forward r nil t)
|
|
(let ((str (match-string 1)))
|
|
(set-text-properties 0 (length str) nil str)
|
|
(if (string-match (rx line-start (group (+ nonl)) "\\" line-end) str)
|
|
(setq temp (concat temp (match-string 1 str)))
|
|
(setq temp (concat temp str))
|
|
(push temp l)
|
|
(setq temp ""))))
|
|
l))))
|
|
|
|
(defun ll/get-required-binaries-for-test (file)
|
|
(->> (ll/get-test-run-commands file)
|
|
(mapcan #'(lambda (x) (split-string x "|")))
|
|
(mapcar #'string-trim)
|
|
(mapcar #'(lambda (x)
|
|
(let ((str (car (split-string x " "))))
|
|
(if (member str '("%clang" "%clang_cc1"))
|
|
"clang"
|
|
str))))
|
|
(seq-uniq)))
|
|
|
|
(defun ll/test-ensure-binary-built (file)
|
|
;; TODO: assumed build-dir constant, should take as argument and prompt
|
|
;; further up
|
|
(let ((dir (lls/get-llvm-build-dir))
|
|
(tools (ll/get-required-binaries-for-test file)))
|
|
(lls/ninja-build-tools dir tools)))
|
|
|
|
(defun ll/build-lit-command (file action)
|
|
(format "%s %s %s"
|
|
(car (lls/get-tool "llvm-lit"))
|
|
(pcase action
|
|
('verbose "-v")
|
|
('all "-a")
|
|
(_ ""))
|
|
file ))
|
|
|
|
(defun ll/get-cc1-string (path)
|
|
(concat "clang -cc1 "
|
|
"-internal-isystem " (expand-file-name "lib/clang/16.0.0/include" path)
|
|
" -nostdsysteminc"))
|
|
|
|
(defun ll/prompt-test-action (file action)
|
|
;; TODO: assumed build-dir constant, should take as argument and prompt
|
|
;; further up
|
|
(let* ((lookups (make-hash-table :test #'equal))
|
|
(commands
|
|
(--> (ll/get-test-run-commands file)
|
|
;; TODO: assumed that first command will DWIM
|
|
(mapcar #'(lambda (x) (car (split-string x "|"))) it)
|
|
(mapcar #'(lambda (x) (string-trim x)) it)
|
|
;; TODO: assuming all commands will be llc
|
|
(mapcar #'(lambda (x)
|
|
(let ((res x))
|
|
(setq res (string-replace "not " "" res))
|
|
(string-match (rx line-start
|
|
(group
|
|
(optional "%")
|
|
(+ (not space))))
|
|
x)
|
|
(setq res
|
|
(apcase (match-string 1 x)
|
|
("%clang_cc1"
|
|
(replace-match (ll/get-cc1-string it) nil nil x 1))
|
|
("%clang"
|
|
(replace-match "clang" nil nil x 1))
|
|
(t res)))
|
|
(string-match (rx line-start
|
|
(group (or "clang" "llc" "llvm-mc"))
|
|
" ")
|
|
res)
|
|
(let* ((tool (match-string 1 res))
|
|
(resolved
|
|
(save-match-data
|
|
(or (gethash tool lookups)
|
|
(aprog1 (lls/prompt-tool (concat tool "$"))
|
|
(puthash tool it lookups))))))
|
|
(replace-match resolved nil nil res 1))))
|
|
it)
|
|
(mapcar #'(lambda (x)
|
|
(string-replace "%s" file x))
|
|
it))))
|
|
(my/completing-read "Which command? " commands)))
|
|
|
|
(defun ll/build-test-command (file action)
|
|
(let (actions)
|
|
(if (eq action 'test-action)
|
|
(push (ll/prompt-test-action file action) actions)
|
|
(push (ll/build-lit-command file action) actions))
|
|
(when (y-or-n-p "Rebuild before running test? ")
|
|
(push (ll/test-ensure-binary-built file) actions))
|
|
(mapconcat #'identity
|
|
actions
|
|
" && ")))
|
|
|
|
(defun ll/test-get-missing (buffer)
|
|
(interactive
|
|
(list (current-buffer)))
|
|
(let ((r
|
|
(rx "Did not find "
|
|
(group (+ (any alphanumeric "-")))))
|
|
tools)
|
|
(with-current-buffer buffer
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(while (re-search-forward r nil t)
|
|
(let ((str (match-string 1) ))
|
|
(set-text-properties 0 (length str) nil str)
|
|
(push str tools)))))
|
|
(when (called-interactively-p)
|
|
(message (string-join tools ", ")))
|
|
tools))
|
|
|
|
(defun ll/test-ensure-missing (buffer msg)
|
|
(let ((tools (ll/test-get-missing buffer)))
|
|
(when tools
|
|
(-->
|
|
;; TODO: Assuming debug folder, (lls/get-llvm-build-dir) doesn't work
|
|
(lls/ninja-build-tools "/scratch/benson/tools3/llvm_cgt/build/Debug/llvm" (seq-uniq tools))
|
|
(compilation-start
|
|
it
|
|
nil
|
|
(lambda (_)
|
|
(format "*ensure-tools-%s*" (buffer-name buffer))))
|
|
(aprog1 it
|
|
(with-current-buffer it
|
|
(add-hook 'compilation-finish-local-transient
|
|
(lambda (buf msg)
|
|
(delete-window (get-buffer-window buf))
|
|
(display-buffer buffer)
|
|
(with-current-buffer buffer
|
|
(call-interactively #'recompile))))))))))
|
|
|
|
(defun ll/act-on-test-file (file)
|
|
(let* ((action (aml/read-action-map ll/test-file-action-map " | ")))
|
|
(--> (ll/build-test-command file action)
|
|
(compilation-start
|
|
it
|
|
nil
|
|
(lambda (_)
|
|
(format "*test-%s-%s*"
|
|
(file-name-nondirectory file)
|
|
(aml/get-map-prop ll/test-file-action-map action :buffer-string))))
|
|
(aprog1 it
|
|
(with-current-buffer it
|
|
(add-hook 'compilation-finish-local-sticky
|
|
#'ll/test-ensure-missing))))))
|
|
|
|
(provide 'act-on-test-file)
|
|
;;; act-on-test-file.el ends here
|