cargoless-rust-experiments/antioxidant-workspaces.scm

;;; Antioxidant --- Building Rust without cargo
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of Antioxidant.
;;;
;;; Antioxidant 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.
;;;
;;; Antioxidant 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
(define-module (antioxidant-workspaces)
  #:use-module (antioxidant)
  #:use-module (guix build gnu-build-system)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (topological-sort)
  #:use-module (ice-9 match)
  #:export (*members*
	    expand-glob
	    load-members
	    member-dependencies
	    build-workspace-members
	    extra-member-phases
	    %antioxidant-member-main-phases
	    %antioxidant-member-extra-phases
	    %antioxidant-workspaces-phases
	    call-with-member
	    with-member
	    capture-per-member-environment))

;;;
;;; Workspaces are built recursively -- each member is built in turn and
;;; installed, in topological ordering to satisfy dependencies.
;;;
;;; To resolve dev-dependencies cycles within a workspace,
;;; first each workspace member is built without tests,
;;; then the tests are built and run for each member.
;;;

;; An association list of 'member name' (directory name) → their manifest.
;; If the workspace itself is a Rust crate, it is included as ".".
(define *members* (make-parameter #false))

(define (capture-per-member-environment)
  "Return an association list of environment variable names / values
considered specific to the current workspace member.  These should
be restored when the member is entered again and unset when the
member is exited."
  (define %precious
    ;; Required for libsequoia
    '("OUT_DIR" "CARGO_MANIFEST_DIR"
      ;; No known cases where preserving them is required, but seems
      ;; potentially needed in theoru.
      "CARGO_PKG_VERSION_MAJOR" "CARGO_PKG_VESION_MINOR"
      "CARGO_PKG_VERSION_PATCH" "CARGO_PKG_VERSION_PRE" "CARGO_PKG_VERSION"
      "CARGO_PKG_AUTHORS" "CARGO_PKG_NAME" "CARGO_PKG_DESCRIPTION"
      "CARGO_PKG_HOMEPAGE" "CARGO_PKG_REPOSITORY" "CARGO_PKG_LICENSE"
      "CARGO_PKG_LICENSE_FILE"))
  (define (preserve? v)
    (define =-index (string-index v #\=))
    (define key (substring v 0 =-index))
    (define value (substring v (+ 1 =-index)))
    (and (member key %precious)
	 (cons key value)))
  (filter-map preserve? (environ)))

(define (call-with-member-environment-excursion to-restore thunk)
  ;; TODO: would be nice if 'environ' was a parameter object
  (dynamic-wind
      (lambda ()
	(for-each (lambda (v)
		    (setenv (car v) (cdr v)))
		  to-restore))
      thunk
      (lambda ()
	(for-each (lambda (v)
		    (unsetenv (car v)))
		  (capture-per-member-environment)))))

;; Head: environment variables alist.
;; Tail: argument for 'call-with-reset-state'
(define *member-state* (make-hash-table))

(define (call-with-member member thunk)
  "Call THUNK in an environment where the state arguments for MEMBER are set.
If they are not defined yet, they are set to their initial values.  After
a normal return, the new values of the state arguments are saved for the
next call to call-with-member."
  (define old-state (hash-ref *member-state* member #false))
  (define-values (old-environment optional-arguments)
    (if old-state
	(values (car old-state) (list (cdr old-state)))
	(values '() '())))
  (with-directory-excursion member
    (apply call-with-reset-state
	   (lambda ()
	     (call-with-member-environment-excursion
	      old-environment
	      (lambda ()
		(thunk)
		;; Save the new state, as the member might need to be re-entered
		;; later.
		(hash-set! *member-state* member
			   (cons (capture-per-member-environment) (capture-state))))))
	   optional-arguments)))

(define-syntax-rule (with-member member code code* ...)
  (call-with-member member (lambda () code code* ...)))

(define (load-members . _)
  "Populate *members*."
  (define (proc member-directory accumulated)
    `((,member-directory . ,(open-manifest
			     (in-vicinity member-directory "/Cargo.toml")
			     (in-vicinity member-directory "/Cargo.json")))
      . ,accumulated))
  (*members* (fold proc '()
		   (all-workspace-members (*manifest*)))))

(define* (member-dependencies member-manifest #:optional
			     (kinds '(dependency build)))
  "Return the list of members that MEMBER-MANIFEST depends upon.
Only the dependency kinds in KINDS are listed, as understood by
manifest-all-dependencies.  The dependencies are returned as a
list of (DIRECTORY . MANIFEST) pairs."
  (define crates
    (manifest-all-dependencies member-manifest kinds))
  (define* (find-matching-members crate)
    (define (check member)
      (and (string=? (normalise-crate-name
		      (package-name (manifest-package (cdr member))))
		     (crate-mapping-dependency-name crate))
	   member))
    (filter-map check (*members*)))
  (define (maybe-find-matching-member crate)
    (define members (find-matching-members crate))
    (match (length members)
      (0 #false) ; looks like an external dependency
      (1 (car members)) ; unique match
      (_ (scm-error 'ambigious-workspace-dependency "member-dependencies"
		    "~s is ambigious, multiple hits: ~s"
		    (list crate members) #false))))
  (filter-map maybe-find-matching-member crates))

(define* (expand-glob text)
  ;; TODO: find reference documentation for glob patterns in Rust.
  ;; TODO: does this need to check if a Cargo.toml file exists in
  ;; the directory?
  (match (string-index text #\*)
    ((? number? i)
     (let ((before-star (substring text 0 i))
	   (after-star (substring text (+ i 1))))
       (unless (member after-star '("" "/"))
	 ;; e.g. *baz
	 (error "this kind of glob pattern is not supported yet"))
       (unless (or (string-null? before-star)
		   (string-suffix? "/" before-star))
	 ;; e.g. foo*
	 (error "this kind of glob pattern is not supported yet"))
       (define (recurse potential-member)
	 (define where (in-vicinity before-star (car potential-member)))
	 (if (and (not (member (car potential-member) '("." "..")))
		  (case (assq-ref (cdr potential-member) 'type)
		    ((directory) #true)
		    ((unknown) (eq? 'directory (stat:type (lstat where))))
		    (else #false)))
	     (expand-glob (string-append where after-star))
	     ;; Not a proper subdirectory, not a member.
	     '()))
       (append-map recurse (scandir* before-star))))
    (#false (list text)))) ; base case

(define (all-workspace-members manifest)
  "Return a list of directory names corresponding to each workspace members,
relative to the current working directory and without additional
  preceding \"./\".
If the workspace itself is a package, it is included as \".\"."
  ;; TODO: handle 'if the workspace itself is a package'.
  ;; TODO: what to do in case of duplicates?
  (append-map expand-glob
	      (append (if (manifest-package manifest)
			  '(".")
			  '())
		      (workspace-members (manifest-workspace manifest)))))

(define* (build-workspace-members #:key
				  (member-phases %antioxidant-member-main-phases)
				  (override-member-crate-type '())
				  #:allow-other-keys
				  #:rest arguments)
  "Build all the workspace members, excluding anything that might need
'dev-dependencies' like examples and tests."
  (define (build-workspace-member member-directory+manifest)
    (format #t "Building the member ~a ...~%" (car member-directory+manifest))
    (define directory (car member-directory+manifest))
    (define member-crate-type
      (match (assoc directory override-member-crate-type)
        ((_ . crate-type) crate-type)
        (#false #false)))
    (with-member directory
      (apply gnu-build
	     ;; #:phases must be set after 'arguments' to override it.
	     (append arguments
		     ;; The embedded tests may have dev-dependencies.
		     ;; TODO: adjust 'build' to support building _only_
		     ;; the embedded tests and call it from
		     ;; %antioxidant-member-extra-phases, such that
		     ;; embedded tests can be run for workspace builds.
		     (list #:tests? #false
			   #:phases member-phases
			   #:rust-crate-type member-crate-type
			   #:member directory)))))
  (define ordered-members
    (reverse
     (topological-sort* (*members*)
			(lambda (+manifest) (member-dependencies (cdr +manifest)))
			car)))
  (format #t "The workspace members will be built in the following order:~%")
  (for-each (lambda (m)
	      (format #t "* ~a~%" (car m))) ordered-members)
  (for-each build-workspace-member ordered-members))

(define* (extra-member-phases #:key
			      (member-extra-phases %antioxidant-member-extra-phases)
			      #:allow-other-keys
			      #:rest arguments)
  (define (do-workspace-member member-directory+manifest)
    (format #t "Building remainder of member ~a ...~%"
	    (car member-directory+manifest))
    (define directory (car member-directory+manifest))
    (with-member directory
		 (apply gnu-build
			(append arguments
				(list #:phases member-extra-phases
				      #:member directory)))))
  (format #t "Doing per-workspace member things that might require dev-dependencies~%")
  (for-each do-workspace-member (*members*)))

;; Some workspaces use a Makefile, but not all.
(define (phase-if-makefile phase-name phase)
  (lambda arguments
    (if (file-exists? "Makefile")
	(apply phase arguments)
	(format #t "No Makefile exists, skipping ~a phase.~%" phase-name))))

(define %antioxidant-member-main-phases
  (modify-phases %standard-antioxidant-phases
    ;; Delete phases that don't need to be done on a per-member basis.
    (delete 'set-SOURCE-DATE-EPOCH)
    (delete 'set-paths)
    (delete 'install-locale)
    (delete 'unpack)
    (delete 'bootstrap)
    (delete 'patch-usr-bin-file)
    (delete 'patch-source-shebangs)
    (delete 'patch-generated-file-shebangs)
    (delete 'patch-shebangs)
    ;; Requires 'dev-dependencies'
    (delete 'build-tests)
    (delete 'check)
    (delete 'strip)
    (delete 'validate-runpath)
    (delete 'validate-documentation-location)
    (delete 'delete-info-dir-file)
    (delete 'patch-dot-desktop-files)
    (delete 'make-dynamic-linker-cache)
    (delete 'install-license-files)
    (delete 'reset-gzip-timestamps)
    (delete 'compress-documentation)))

;; Phases requiring 'dev-dependencies', which may need to be built
;; at the end to resolve test cycles.  TODO: use it.
(define %antioxidant-member-extra-phases
  `(,(assq 'build-tests %standard-antioxidant-phases)
    ,(assq 'check %standard-antioxidant-phases)))

(define %antioxidant-workspaces-phases
  (modify-phases %standard-phases
    (add-after 'unpack 'load-members load-members)
    (add-after 'unpack 'load-manifest load-manifest)
    (delete 'patch-usr-bin-file)
    (delete 'configure) ; Cargo has a different setup for build scripts
    (delete 'patch-generated-file-shebangs)
    (add-after 'build 'build-workspace-members build-workspace-members)
    (add-after 'build-workspace-members 'extra-member-phases extra-member-phases)
    (delete 'build)
    (replace 'check (phase-if-makefile
		     'check
		     (assoc-ref %standard-phases 'check)))
    (replace 'install (phase-if-makefile
		       'install
		       (assoc-ref %standard-phases 'install)))))