nonguix: Update binary build system to return a monadic procedure.

Fixes https://gitlab.com/nonguix/nonguix/-/issues/146.

* nonguix/build-system/binary.scm (binary-build): Update it.

Signed-off-by: Jonathan Brielmaier <jonathan.brielmaier@web.de>
This commit is contained in:
Josselin Poiret 2021-11-11 15:14:40 +00:00 committed by Jonathan Brielmaier
parent 01608562fb
commit 7b13acb514
No known key found for this signature in database
GPG key ID: ECFC83988B4E4B9F

View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2021 Josselin Poiret <dev@jpoiret.xyz>
;;; ;;;
;;; This file is not part of GNU Guix. ;;; This file is not part of GNU Guix.
;;; ;;;
@ -19,6 +20,8 @@
(define-module (nonguix build-system binary) (define-module (nonguix build-system binary)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix search-paths) #:use-module (guix search-paths)
#:use-module (guix build-system) #:use-module (guix build-system)
@ -90,8 +93,9 @@
(build binary-build) (build binary-build)
(arguments (strip-keyword-arguments private-keywords arguments))))) (arguments (strip-keyword-arguments private-keywords arguments)))))
(define* (binary-build store name inputs (define* (binary-build name inputs
#:key (guile #f) #:key
guile source
(outputs '("out")) (outputs '("out"))
(patchelf-plan ''()) (patchelf-plan ''())
(install-plan ''(("." "./"))) (install-plan ''(("." "./")))
@ -109,49 +113,43 @@
(imported-modules %binary-build-system-modules) (imported-modules %binary-build-system-modules)
(modules '((nonguix build binary-build-system) (modules '((nonguix build binary-build-system)
(guix build utils) (guix build utils)
(nonguix build utils)))) (nonguix build utils)))
(substitutable? #t)
allowed-references
disallowed-references)
"Build SOURCE using PATCHELF, and with INPUTS. This assumes that SOURCE "Build SOURCE using PATCHELF, and with INPUTS. This assumes that SOURCE
provides its own binaries." provides its own binaries."
(define builder (define builder
`(begin (with-imported-modules imported-modules
(use-modules ,@modules) #~(begin
(binary-build #:source ,(match (assoc-ref inputs "source") (use-modules #$@modules)
(((? derivation? source))
(derivation->output-path source))
((source)
source)
(source
source))
#:system ,system
#:outputs %outputs
#:inputs %build-inputs
#:patchelf-plan ,patchelf-plan
#:install-plan ,install-plan
#:search-paths ',(map search-path-specification->sexp
search-paths)
#:phases ,phases
#:out-of-source? ,out-of-source?
#:validate-runpath? ,validate-runpath?
#:patch-shebangs? ,patch-shebangs?
#:strip-binaries? ,strip-binaries?
#:strip-flags ,strip-flags
#:strip-directories ,strip-directories)))
(define guile-for-build #$(with-build-variables inputs outputs
(match guile #~(binary-build #:source #+source
((? package?) #:system #$system
(package-derivation store guile system #:graft? #f)) #:outputs %outputs
(#f ; the default #:inputs %build-inputs
(let* ((distro (resolve-interface '(gnu packages commencement))) #:patchelf-plan #$patchelf-plan
(guile (module-ref distro 'guile-final))) #:install-plan #$install-plan
(package-derivation store guile system #:graft? #f))))) #:search-paths '#$(map search-path-specification->sexp
search-paths)
#:phases #$phases
#:out-of-source? #$out-of-source?
#:validate-runpath? #$validate-runpath?
#:patch-shebangs? #$patch-shebangs?
#:strip-binaries? #$strip-binaries?
#:strip-flags #$strip-flags
#:strip-directories #$strip-directories)))))
(build-expression->derivation store name builder (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
#:system system system #:graft? #f)))
#:inputs inputs (gexp->derivation name builder
#:modules imported-modules #:system system
#:outputs outputs #:target #f
#:guile-for-build guile-for-build)) #:substitutable? substitutable?
#:allowed-references allowed-references
#:disallowed-references disallowed-references
#:guile-for-build guile)))
(define binary-build-system (define binary-build-system
(build-system (build-system