#!/usr/bin/env -S guile -e main -s !# ;;; coding: utf-8 (use-modules (ice-9 control) (ice-9 ftw) (ice-9 getopt-long) (ice-9 popen) (ice-9 rdelim) (ice-9 regex) (srfi srfi-1) ; List libray (srfi srfi-43) ; Vector library (yaml)) (define %prog-name "run-gdb-precommit-hooks") ;; All my GDB working trees have a path starting with this string. (define %gdb-repo-prefix (string-append (getenv "HOME") "/src/binutils-gdb")) (define *ignore-tool-checks?* #f) (define *use-container?* #f) (define (message message . arguments) (apply format (current-output-port) (string-append %prog-name ": " message "\n") arguments) #t) (define (error-message message . arguments) (apply format (current-error-port) (string-append %prog-name ": Error: " message "\n") arguments) #f) (define (warning-message message . arguments) (apply format (current-error-port) (string-append %prog-name ": Warning: " message "\n") arguments) #t) (define (error-or-warning message . arguments) (apply (if *ignore-tool-checks?* warning-message error-message) message arguments)) (define (get-gdb-repo-path) "Assuming CWD is in a GDB repo, return its root." (let* ((cwd (getcwd)) (first-/ (string-index cwd #\/ (string-length %gdb-repo-prefix)))) (substring cwd 0 (or first-/ (string-length cwd))))) (define* (run-cmd args #:key (output #f) (guix-packages #f) (container? #t)) "Run given command — inside a container if CONTAINER? is #t. If OUTPUT is a string, it's the path of a file to which output will be redirected. The return value depends on the OUTPUT parameter: - if it's #t, return command output as a string. - Otherwise, return boolean indicating whether the command succeeded or failed." (when (and *use-container?* container?) (set! args (append (list "guix" "shell" "--container" "--emulate-fhs" (string-append "--expose=" (get-gdb-repo-path)) ;; Many local hooks use the folowing packages, so just make ;; them always available in the container. "bash" "coreutils" "git" "python") guix-packages (list "--") args))) (false-if-exception (if (boolean? output) (if output ;; Return command output as a string. (call-with-port (apply open-pipe* OPEN_READ args) read-line) ;; Return boolean indicating success or failure. (eq? (status:exit-val (cdr (waitpid (spawn (list-ref args 0) args)))) 0)) (if (string? output) ;; Save command output to file. (eq? (status:exit-val (call-with-output-file output (lambda (output-port) (cdr (waitpid (spawn (list-ref args 0) args #:output output-port)))))) 0) ;; OUTPUT is an invalid value. #f)))) (define (read-pre-commit-config file) "Read .pre-commit-config.yaml. Returns list of association lists describing each hook, or #f if an unrecognized hook is found and *ignore-tool-checks?* is false." (define (get-hook-info id) "Obtain information about hook ID. The pre-commit tools gets most of this information from each hook's .pre-commit-hooks.yaml. We simply hard-code it here." (define hook-infos (list `((id . "black") (get-version . ,(λ () ;; Example output: ;; .black-real, 25.1.0 (compiled: no) (list-ref (string-tokenize (run-cmd '("black" "--version") #:guix-packages '("python-black") #:output #t)) 1))) (entry . "black") (guix-packages . ("python-black"))) `((id . "flake8") (get-version . ,(λ () ;; Example output: ;; 7.1.1 (mccabe: 0.7.0, pycodestyle: 2.12.1, pyflakes: 3.2.0) CPython 3.11.14 on Linux (list-ref (string-tokenize (run-cmd '("flake8" "--version") #:guix-packages '("python-flake8") #:output #t)) 0))) (entry . "flake8") (guix-packages . ("python-flake8"))) `((id . "isort") (get-version . ,(λ () ;; Example output: ;; 6.0.1 (run-cmd '("isort" "--version-number") #:guix-packages '("python-isort") #:output #t))) (entry . "isort") (args . ,(if *use-container?* ;; Use --check-only because the container can't write to the repo. '("--check-only" "--filter-files") '("--filter-files"))) (guix-packages . ("python-isort"))) `((id . "codespell") (get-version . ,(λ () ;; Example output: ;; 2.3.0 (string-append "v" (run-cmd '("codespell" "--version") #:guix-packages '("python-codespell") #:output #t)))) (entry . "codespell") (guix-packages . ("python-codespell"))) `((id . "tclint") (get-version . ,(λ () ;; FIXME: For some reason, my tclint Guix package has this output for ;; tclint --version: "tclint (unknown version)", so for now get the ;; version number from Guix. ;; The yaml's rev field has a v in the beginning. ;; Example output: ;; tclint 0.8.0 out /gnu/store/…-tclint-0.8.0 (string-append "v" (list-ref (string-tokenize (run-cmd '("guix" "package" "-I" "tclint") #:guix-packages '("tclint") ;; There's no Guix inside the ;; container. #:container? #f #:output #t)) 1)))) (entry . "tclint") (guix-packages . ("tclint"))) `((id . "check-file-mode") (guix-packages . ("grep"))) `((id . "check-gnu-style") (guix-packages . ("python-termcolor" "python-unidiff"))))) (fold (λ (hook-info result) (or result (if (equal? (assoc-ref hook-info 'id) id) hook-info #f))) #f hook-infos)) (define (yaml-vector->symbols-list types-from-yaml) "Convert vector of strings to list of symbols." (if types-from-yaml (vector-fold (λ (_ result string) (cons (string->symbol string) result)) '() types-from-yaml) '())) (let* ((yaml-file (read-yaml-file file)) (default-stages (yaml-vector->symbols-list (assoc-ref yaml-file "default_stages")))) ;; Loop through the vector of repos, building the list of association lists on the way. (vector-fold (λ (_ result repo) ;; Loop through the repo's vector of hooks, building the list of ;; association lists on the way. (vector-fold (λ (_ hooks-result hook) (let* ((id (assoc-ref hook "id")) (hook-info (get-hook-info id)) (local? (string=? (assoc-ref repo "repo") "local")) (rev (assoc-ref repo "rev"))) (if (and hooks-result (or hook-info local?)) (let* ((get-version (assoc-ref hook-info 'get-version)) (entry (or (assoc-ref hook "entry") (assoc-ref hook-info 'entry))) (types-or (yaml-vector->symbols-list (assoc-ref hook "types_or"))) (files (assoc-ref hook "files")) (exclude (assoc-ref hook "exclude")) (info-args (or (assoc-ref hook-info 'args) '())) (hook-args (vector->list (or (assoc-ref hook "args") (make-vector 0)))) (guix-packages (or (assoc-ref hook-info 'guix-packages) '())) (hook-stages (assoc-ref hook "stages")) (stages (or (and hook-stages (yaml-vector->symbols-list hook-stages)) default-stages))) ;; Append this hook's association list to the result list. (append hooks-result (list (list (cons 'id id) (cons 'version-required rev) (cons 'get-version get-version) (cons 'entry entry) (cons 'types-or types-or) (cons 'files files) (cons 'args (append info-args hook-args)) (cons 'guix-packages guix-packages) (cons 'stages stages) (cons 'exclude exclude))))) (begin (unless hook-info (error-or-warning "Unknown hook ~a." id)) (if *ignore-tool-checks?* hooks-result #f))))) result (assoc-ref repo "hooks"))) '() (assoc-ref yaml-file "repos")))) (define* (filter-repo-files #:key (files #f) (exclude #f) (types-or '())) "Arguments: - If provided, FILES and EXCLUDE should be compiled regexp structures. Returns list of files matching constraints." ;; Always enter subdirectories. (define (enter-dir? path stat result) result) (define (leaf path stat result) "Call FUNCTION on PATH if the filters allow it." (let ((adjusted-path (if (string-prefix? "./" path) ;; Remove "./" from beginning of path. (substring path 2) path))) (if (and (or (not (member 'file types-or)) (eq? (stat:type stat) 'regular)) (or (not files) (not (null? (list-matches files adjusted-path)))) (or (not exclude) (null? (list-matches exclude adjusted-path)))) (cons adjusted-path result) result))) ;; Don't do anything with directories, skipped or otherwise. (define (down path stat result) result) (define (up path stat result) result) (define (skip path stat result) result) ;; Report unreadable files/directories, but keep going. (define (error path stat errno result) (warning-message "~a: ~a" path (strerror errno)) result) (file-system-fold enter-dir? leaf down up skip error '() ".")) (define (print-help) (display "\ Run the GDB pre-commit hooks without using the pre-commit tool. Options: -h, --help Show this help message. -i, --ignore-tool-checks Ignore required tool versions or unknown tools (still prints a warning). -n, --no-container Don't run hooks in isolated containers.\n")) (define (main args) (exit (let/ec return (let* ((option-spec '((help (single-char #\h)) (ignore-tool-checks (single-char #\i)) (no-container (single-char #\n)))) (options (getopt-long args option-spec)) (help? (option-ref options 'help #f)) (ignore-tool-checks? (option-ref options 'ignore-tool-checks #f)) (container? (not (option-ref options 'no-container #f))) (non-options (option-ref options '() '()))) (when (or help? (> (length non-options) 0)) (print-help) (return (if help? 0 3))) (unless (string-prefix? %gdb-repo-prefix (getcwd)) (error-message "Needs to be run inside a GDB repository.") (return 3)) (set! *ignore-tool-checks?* ignore-tool-checks?) (set! *use-container?* (and container? ;; We can only use containers if the guix command is ;; available. (run-cmd '("guix" "--version") #:output "/dev/null" #:container? #f))) ;; If Guix isn't available, fail unless "--no-container" has been given. (when (and container? (not *use-container?*)) (error-message "Use of containers requested but Guix isn't available.") (return 3)) ;; Run hooks from the root of the GDB repository. (chdir (get-gdb-repo-path)) (let ((hooks (read-pre-commit-config ".pre-commit-config.yaml"))) (unless hooks (return 3)) (fold (λ (hook previous) (let/ec return-hook ;; Skip hook if it should only run on commit-msg stage. ;; This is for one of the codespell hooks, which would otherwise run on ;; all the repo's files. ;; Also skip the pre-commit-setup hook, which isn't relevant since ;; we're not using the pre-commit tool. (when (or (equal? (assoc-ref hook 'stages) '(commit-msg)) (string=? (assoc-ref hook 'id) "pre-commit-setup")) (return-hook previous)) (message "Running hook ~a ..." (or (assoc-ref hook 'name) (assoc-ref hook 'id))) (let* ((version-required (assoc-ref hook 'version-required)) (current-version (and version-required ((assoc-ref hook 'get-version))))) (unless (or (not version-required) (string=? current-version version-required)) (error-or-warning "We need ~a version ~a, but we have ~a." (assoc-ref hook 'id) version-required current-version) (unless *ignore-tool-checks?* (return-hook 3)))) (let* ((entry (assoc-ref hook 'entry)) (types-or (assoc-ref hook 'types-or)) (files (assoc-ref hook 'files)) (files-regexp (and files (make-regexp files))) (exclude (assoc-ref hook 'exclude)) (exclude-regexp (and exclude (make-regexp exclude))) (args (or (assoc-ref hook 'args) '())) (guix-packages (assoc-ref hook 'guix-packages)) (result (run-cmd (append (list entry) args (filter-repo-files #:types-or types-or #:files files-regexp #:exclude exclude-regexp)) #:guix-packages guix-packages))) (max previous (if result 0 1))))) 0 hooks))))))