;;; act-on-test-file.el --- -*- lexical-binding: t -*- ;; Copyright (C) 2022 Benson Chu ;; Author: Benson Chu ;; 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 . ;;; 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/run-build-command dir tools))) (defun ll/build-lit-command (file action) (format "%s %s %s" (lls/prompt-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/run-build-command "/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