;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il>
+ ;;; Copyright © 2021 Andrew Whatson <whatson@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (gnu packages perl)
#:use-module (gnu packages python)
#:use-module (gnu packages base)
+ #:use-module (gnu packages web-browsers)
#:use-module (gnu packages xml)
- #:use-module (guix licenses)
+ #:use-module ((guix licenses) #:prefix license:)
#:use-module (guix packages)
#:use-module (guix download)
#:use-module ((guix build utils) #:select (alist-replace))
(inputs (alist-replace "imagemagick" `(,imagemagick/stable)
(package-inputs dblatex))))))
- (license gpl2+)))
+(define-public docbook-utils
+ (package
+ (name "docbook-utils")
+ (version "0.6.14")
+ (source (origin
+ (method url-fetch)
+ ;; The original sources are not accessible anymore.
+ (uri (string-append "http://deb.debian.org/debian/pool/main/"
+ "d/docbook-utils/docbook-utils_"
+ version ".orig.tar.gz"))
+ (sha256
+ (base32
+ "1scj5vgw1xz872pq54a89blcxqqm11p90yzv8a9mqq57x27apyj8"))))
+ (build-system gnu-build-system)
+ (arguments
+ `(#:phases (modify-phases %standard-phases
+ (add-after 'unpack 'patch-build-system
+ (lambda _
+ (substitute* (find-files "." "\\.in$")
+ ;; Do not hard-code SGML_CATALOG_FILES.
+ ((".*SGML_CATALOG_FILES=/etc/sgml/catalog.*") "")
+ ;; Use OpenSP and OpenJade.
+ (("\\bjade\\b")
+ "openjade")
+ (("\\bnsgmls\\b")
+ "onsgmls"))
+ #t))
+ (add-after 'unpack 'patch-jw.in
+ ;; Do not override the SGML_CATALOG_FILES environment
+ ;; variable.
+ (lambda _
+ (substitute* "bin/jw.in"
+ ((".*SGML_CATALOG_FILES=`find.*")
+ "")
+ (("SGML_CATALOG_FILES=`echo.*")
+ ":\n")
+ (("SGML_CATALOG_FILES=\"\"")
+ ":")
+ (("\\bwhich\\b")
+ "command -v"))
+ #t))
+ (add-after 'unpack 'patch-txt-backend
+ (lambda _
+ ;; Locate lynx, links or w3m from the PATH, not from
+ ;; /usr/bin.
+ (substitute* "backends/txt"
+ (("CONVERT=/usr/bin/")
+ "CONVERT=")
+ (("\\[ -x /usr/bin/([^ ]+) \\]" dummy command)
+ (string-append "command -v " command " > /dev/null")))
+ #t)))))
+ ;; Propagated for convenience. All these tools are used at run time to
+ ;; provide the complete functionality of the docbook-utils commands.
+ (propagated-inputs
+ `(("texlive-jadetex" ,texlive-jadetex)
+ ("docbook-sgml" ,docbook-sgml-3.1)
+ ("docbook-dsssl" ,docbook-dsssl)
+ ("openjade" ,openjade)
+ ("opensp" ,opensp)
+ ("lynx" ,lynx)
+ ("perl-sgmls" ,perl-sgmls)))
+ (home-page "https://packages.debian.org/sid/docbook-utils")
+ (synopsis "DocBook converter to other formats")
+ (description "The docbook-utils package is a collection of utilities
+intended to ease the use of SGML and XML.
+@table @command
+@item jw
+Convert a SGML DocBook file to other formats such as Hyper Text Markup
+Language (HTML), Rich Text Format (RTF), PostScript (PS), man, Portable
+Document Format (PDF), TeX, Texinfo or plain text (txt). It can be used
+more conveniently via the following wrappers:
+@itemx docbook2dvi Convert a SGML DocBook file to the DVI format.
+@itemx docbook2html Convert a SGML DocBook file to an HTML document.
+@itemx docbook2man Convert a SGML DocBook file a man page.
+@itemx docbook2pdf Convert a SGML DocBook file to a PDF document.
+@itemx docbook2ps Convert a SGML DocBook file to a PS document.
+@itemx docbook2rtf Convert a SGML DocBook file to a RTF document.
+@itemx docbook2tex Convert a SGML DocBook file to a TeX document.
+@itemx docbook2texi Convert a SGML DocBook file to a Texinfo document.
+@itemx docbook2txt Convert a SGML DocBook file to a plain text document.
+@item sgmldiff
+Detect the differences in markup between two SGML files.
+@end table")
++ (license license:gpl2+)))
++
+ (define-public docbook2x
+ (package
+ (name "docbook2x")
+ (version "0.8.8")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://sourceforge/docbook2x/docbook2x/"
+ version "/docbook2X-" version ".tar.gz"))
+ (sha256
+ (base32
+ "0ifwzk99rzjws0ixzimbvs83x6cxqk1xzmg84wa1p7bs6rypaxs0"))))
+ (build-system gnu-build-system)
+ (inputs
+ `(("bash-minimal" ,bash-minimal)
+ ("docbook-xml" ,docbook-xml)
+ ("perl" ,perl)
+ ("perl-xml-namespacesupport" ,perl-xml-namespacesupport)
+ ("perl-xml-parser" ,perl-xml-parser)
+ ("perl-xml-sax" ,perl-xml-sax)
+ ("perl-xml-sax-base" ,perl-xml-sax-base)
+ ("texinfo" ,texinfo)
+ ("xsltproc" ,libxslt)))
+ (arguments
+ `(#:phases
+ (modify-phases %standard-phases
+ (add-after 'configure 'patch-sources
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ ;; Fix failed substitution in config.pl
+ (substitute* "perl/config.pl"
+ (("\\$\\{prefix\\}")
+ (assoc-ref outputs "out")))
+ ;; Fix a failing test (maybe it worked with old texinfo?)
+ (substitute* "test/complete-manuals/at1.xml"
+ (("<bridgehead>")
+ "<bridgehead renderas=\"sect2\">"))
+ ;; Patch all the tests use DocBook 4.5
+ (substitute* (find-files "test" "\\.xml$")
+ (("\"-//OASIS//DTD DocBook XML V4\\..+//EN\"")
+ "\"-//OASIS//DTD DocBook XML V4.5//EN\"")
+ (("\"http://www\\.oasis-open\\.org/docbook/xml/4\\..+/docbookx.dtd\"")
+ "\"http://www.oasis-open.org/docbook/xml/4.5/docbookx.dtd\""))
+ ;; Set XML catalogs for tests to pass
+ (setenv "XML_CATALOG_FILES"
+ (string-append (assoc-ref inputs "docbook-xml")
+ "/xml/dtd/docbook/catalog.xml"))))
+ (add-after 'install 'wrap-programs
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (programs
+ (map (lambda (p)
+ (string-append out "/bin/" p))
+ '("db2x_manxml" "db2x_texixml" "db2x_xsltproc"
+ "docbook2man" "docbook2texi")))
+ (perl5lib
+ (map (lambda (i)
+ (string-append (assoc-ref inputs i)
+ "/lib/perl5/site_perl"))
+ '("perl-xml-namespacesupport"
+ "perl-xml-parser"
+ "perl-xml-sax"
+ "perl-xml-sax-base")))
+ (xml-catalog-files
+ (list (string-append (assoc-ref inputs "docbook-xml")
+ "/xml/dtd/docbook/catalog.xml"))))
+ (map (lambda (program)
+ (wrap-program program
+ `("PERL5LIB" ":" prefix
+ ,perl5lib)
+ `("XML_CATALOG_FILES" " " prefix
+ ,xml-catalog-files)))
+ programs))))
+ (add-after 'install 'create-symlinks
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let ((out (assoc-ref outputs "out")))
+ ;; Create db2x_* symlinks to satisfy some configure scripts
+ ;; which use these names to differentiate from an older
+ ;; docbook2man script provided by docbook-utils.
+ (map (lambda (prog)
+ (symlink prog (string-append out "/bin/db2x_" prog)))
+ '("docbook2man" "docbook2texi"))))))))
+ (home-page "http://docbook2x.sourceforge.net")
+ (synopsis "Convert DocBook to man page and Texinfo format")
+ (description
+ "docbook2X is a software package that converts DocBook documents into the
+ traditional Unix man page format and the GNU Texinfo format. Notable features
+ include table support for man pages, internationalization support, and easy
+ customization of the output using XSLT.")
+ (license license:expat)))
`("LD_LIBRARY_PATH" ":" prefix (,libmagic-path))
`("GI_TYPELIB_PATH" ":" prefix (,gi-typelib-path))
`("GST_PLUGIN_SYSTEM_PATH" ":" prefix (,gst-plugin-path))
- `("GUIX_PYTHONPATH" ":" prefix (,python-path ,pylib))))
- #t)))))
- `("PYTHONPATH" ":" prefix (,python-path ,pylib)))))))))
++ `("GUIX_PYTHONPATH" ":" prefix (,python-path ,pylib)))))))))
(native-inputs
`(("desktop-file-utils" ,desktop-file-utils)
("gettext" ,gettext-minimal)
(lambda* (#:key inputs outputs #:allow-other-keys)
(substitute* "telega-server.el"
(("@TELEGA_SERVER_BIN@")
- (string-append (assoc-ref inputs "emacs-telega-server")
- "/bin/telega-server")))
+ (search-input-file inputs "/bin/telega-server")))
(substitute* "telega-util.el"
(("@TELEGA_SHARE@")
- (string-append (assoc-ref outputs "out")
- "/share/emacs-telega")))))
- (add-after 'install 'install-share-files
- (lambda* (#:key outputs #:allow-other-keys)
- (define install-plan
- '("langs" "sounds" "emojis.alist"
- "verified.svg" "telega-logo.svg"))
-
- (define prefix (string-append (assoc-ref outputs "out")
- "/share/emacs-telega"))
- (with-directory-excursion "etc"
- (for-each (lambda (file)
- (if (file-is-directory? file)
- (let ((dest (string-append prefix "/" file)))
- (copy-recursively file dest))
- (install-file file prefix)))
- install-plan))
- #t)))))
+ (string-append (elpa-directory (assoc-ref outputs "out"))
+ "/etc"))))))))
(inputs
`(("emacs-telega-server" ,emacs-telega-server)
("ffmpeg" ,ffmpeg)))
(package-version python))
"/site-packages")))
(wrap-program prog
- `("PYTHONPATH" = (,(getenv "PYTHONPATH") ,pylib))
+ `("PYTHONPATH" = (,(getenv "GUIX_PYTHONPATH") ,pylib))
- `("GI_TYPELIB_PATH" = (,(getenv "GI_TYPELIB_PATH"))))
- #t))))))
+ `("GI_TYPELIB_PATH" = (,(getenv "GI_TYPELIB_PATH"))))))))))
(native-inputs
`(("desktop-file-utils" ,desktop-file-utils)
("gettext" ,gettext-minimal)
;;; Copyright © 2016, 2018 Rene Saavedra <pacoon@protonmail.com>
;;; Copyright © 2016 Carlos Sánchez de La Lama <csanchezdll@gmail.com>
;;; Copyright © 2016, 2017 Nikita <nikita@n0.is>
- ;;; Copyright © 2017, 2018, 2020 Leo Famulari <leo@famulari.name>
+ ;;; Copyright © 2017, 2018, 2020, 2021 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 José Miguel Sánchez GarcÃa <jmi2k@openmailbox.com>
;;; Copyright © 2017 Gábor Boskovits <boskovits@gmail.com>
-;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2019, 2021 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017, 2018, 2019 Rutger Helling <rhelling@mykolab.com>
;;; Copyright © 2017 nee <nee-git@hidamari.blue>
;; The following package is used in the early bootstrap, and thus must be kept
;; stable and with minimal build requirements.
-(define-public linux-libre-headers-5.4.20
- (make-linux-libre-headers "5.4.20" "gnu"
- "1qxhf6dmcwjblzx8fgn6vr10p38xw10iwh6d1y1v1mxb25y30b47"))
+(define-public linux-libre-headers-5.10.35
- (make-linux-libre-headers "5.10.35"
++ (make-linux-libre-headers "5.10.35" "gnu"
+ "0q2rnchad55d49f3rajrkazz0fcjv1irwrdb1hwjnl01fzm2gjk3"))
-(define-public linux-libre-headers linux-libre-headers-5.4.20)
+(define-public linux-libre-headers linux-libre-headers-5.10.35)
\f
;;;
;;; Copyright © 2021 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2021 Justin Veilleux <terramorpha@cock.li>
;;; Copyright © 2021 Vinicius Monego <monego@posteo.net>
+;;; Copyright © 2021 Felix Gruber <felgru@posteo.net>
+ ;;; Copyright © 2021 Milkey Mouse <milkeymouse@meme.institute>
;;;
;;; This file is part of GNU Guix.
;;;
"test/unit/module/maintenance/test_update_documentation.py")
(delete-file
"test/unit/module/maintenance/test_update_resource_specs.py")
- (invoke "python" "-m" "unittest" "discover"
- (setenv "PYTHONPATH"
- (string-append "./build/lib:"
- (getenv "PYTHONPATH")))
- (setenv "PATH" (string-append out "/bin:"
- (getenv "PATH")))
+ (invoke "python" "-m" "unittest" "discover" "-v"
"-s" "test")))))))
(native-inputs
`(("python-pydot" ,python-pydot)
(uri (pypi-uri "natsort" version))
(sha256
(base32
- "1ksqfai72dbcfbwx43pxl658j59mx2rvqypjy1fk0ax2qd6lccx6"))))
+ "00y49bfsi7rrsd1s42gc2w95a6arl9ipdsx2493hr0v54fj07ih0"))))
(build-system python-build-system)
(arguments
- `(#:modules ((guix build utils)
- (guix build python-build-system)
- (srfi srfi-1)
- (srfi srfi-26)
- (ice-9 ftw))
- #:phases
+ `(#:phases
(modify-phases %standard-phases
- (add-before 'check 'set-cachedir
- ;; Tests require write access to $HOME by default
- (lambda _ (setenv "PYTHON_EGG_CACHE" "/tmp") #t))
(replace 'check
(lambda _
- (let ((cwd (getcwd)))
- (setenv "PYTHONPATH"
- (string-append
- cwd "/build/"
- (find (cut string-prefix? "lib" <>)
- (scandir (string-append cwd "/build")))
- ":"
- (getenv "PYTHONPATH")))
- (invoke "pytest" "-v")))))))
+ (invoke "pytest" "-v"))))))
(native-inputs
`(("python-hypothesis" ,python-hypothesis)
("python-pytest-cov" ,python-pytest-cov)
"/doc/man/man1/mtx-watch.1"
"/doc/man/man1/mtx-youless.1"
-
-
"/bibtex/bst/context/"
"/context/"
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME."
+
+ ;; Flags that put dune into reproducible build mode.
+ (define dune-release-flags
+ (if (version>=? (package-version dune) "2.5.0")
+ ;; For dune >= 2.5.0 this is just --release.
+ ''("--release")
+ ;; --release does not exist before 2.5.0. Replace with flags compatible
+ ;; with our old ocaml4.07-dune (1.11.3)
+ ''("--root" "." "--ignore-promoted-rules" "--no-config"
+ "--profile" "release")))
+
(define private-keywords
- '(#:source #:target #:dune #:findlib #:ocaml #:inputs #:native-inputs))
+ '(#:target #:dune #:findlib #:ocaml #:inputs #:native-inputs))
(and (not target) ;XXX: no cross-compilation
(let ((base (ocaml:lower name
(build-inputs `(("dune" ,dune)
,@(bag-build-inputs base)))
(build dune-build)
- (arguments (strip-keyword-arguments private-keywords arguments))))))
+ (arguments (append
+ `(#:dune-release-flags ,dune-release-flags)
+ (strip-keyword-arguments private-keywords arguments)))))))
-(define* (dune-build store name inputs
- #:key (guile #f)
+(define* (dune-build name inputs
+ #:key
+ guile source
(outputs '("out"))
(search-paths '())
(build-flags ''())
"Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE
provides a 'setup.ml' file as its build system."
(define builder
- `(begin
- (use-modules ,@modules)
- (dune-build #:source ,(match (assoc-ref inputs "source")
- (((? derivation? source))
- (derivation->output-path source))
- ((source)
- source)
- (source
- source))
- #:system ,system
- #:outputs %outputs
- #:inputs %build-inputs
- #:search-paths ',(map search-path-specification->sexp
- search-paths)
- #:phases ,phases
- #:test-flags ,test-flags
- #:build-flags ,build-flags
- #:out-of-source? ,out-of-source?
- #:jbuild? ,jbuild?
- #:package ,package
- #:dune-release-flags ,dune-release-flags
- #:tests? ,tests?
- #:test-target ,test-target
- #:install-target ,install-target
- #:validate-runpath? ,validate-runpath?
- #:patch-shebangs? ,patch-shebangs?
- #:strip-binaries? ,strip-binaries?
- #:strip-flags ,strip-flags
- #:strip-directories ,strip-directories)))
+ (with-imported-modules imported-modules
+ #~(begin
+ (use-modules #$@modules)
+ (dune-build #:source #$source
+ #:system #$system
+ #:outputs (list #$@(map (lambda (name)
+ #~(cons #$name
+ (ungexp output name)))
+ outputs))
+ #:inputs (map (lambda (tuple)
+ (apply cons tuple))
+ '#$inputs)
+ #:search-paths '#$(map search-path-specification->sexp
+ search-paths)
+ #:phases #$phases
+ #:test-flags #$test-flags
+ #:build-flags #$build-flags
+ #:out-of-source? #$out-of-source?
+ #:jbuild? #$jbuild?
+ #:package #$package
- #:profile #$profile
++ #:dune-release-flags #$dune-release-flags
+ #:tests? #$tests?
+ #:test-target #$test-target
+ #:install-target #$install-target
+ #:validate-runpath? #$validate-runpath?
+ #:patch-shebangs? #$patch-shebangs?
+ #:strip-binaries? #$strip-binaries?
+ #:strip-flags #$strip-flags
+ #:strip-directories #$strip-directories))))
- (define guile-for-build
- (match guile
- ((? package?)
- (package-derivation store guile system #:graft? #f))
- (#f ; the default
- (let* ((distro (resolve-interface '(gnu packages commencement)))
- (guile (module-ref distro 'guile-final)))
- (package-derivation store guile system #:graft? #f)))))
-
- (build-expression->derivation store name builder
- #:system system
- #:inputs inputs
- #:modules imported-modules
- #:outputs outputs
- #:guile-for-build guile-for-build))
+ (gexp->derivation name builder
+ #:system system
+ #:target #f
+ #:guile-for-build guile))
(define dune-build-system
(build-system
;;; Copyright © 2016 Petter <petter@mykolab.ch>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+ ;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
#:rest arguments)
"Return a bag for NAME."
(define private-keywords
- '(#:source #:target #:go #:inputs #:native-inputs))
+ '(#:target #:go #:inputs #:native-inputs))
- (and (not target) ;XXX: no cross-compilation
- (bag
- (name name)
- (system system)
- (host-inputs `(,@(if source
- `(("source" ,source))
- '())
- ,@inputs
-
- ;; Keep the standard inputs of 'gnu-build-system'.
- ,@(standard-packages)))
- (build-inputs `(("go" ,go)
- ,@native-inputs))
- (outputs outputs)
- (build go-build)
- (arguments (strip-keyword-arguments private-keywords arguments)))))
+ (bag
+ (name name)
+ (system system)
+ (target target)
+ (build-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@`(("go" ,go))
+ ,@native-inputs
+ ,@(if target '() inputs)
+ ,@(if target
+ ;; Use the standard cross inputs of
+ ;; 'gnu-build-system'.
+ (standard-cross-packages target 'host)
+ '())
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (host-inputs (if target inputs '()))
+
+ ;; The cross-libc is really a target package, but for bootstrapping
+ ;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a
+ ;; native package, so it would end up using a "native" variant of
+ ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages
+ ;; would use a target variant (built with 'gnu-cross-build'.)
+ (target-inputs (if target
+ (standard-cross-packages target 'target)
+ '()))
+
+ (outputs outputs)
+ (build (if target go-cross-build go-build))
+ (arguments (strip-keyword-arguments private-keywords arguments))))
-(define* (go-build store name inputs
+(define* (go-build name inputs
#:key
- (phases '(@ (guix build go-build-system)
- %standard-phases))
+ source
+ (phases '%standard-phases)
(outputs '("out"))
(search-paths '())
(install-source? #t)
(guix build union)
(guix build utils))))
(define builder
- `(begin
- (use-modules ,@modules)
- (go-build #:name ,name
- #:source ,(match (assoc-ref inputs "source")
- (((? derivation? source))
- (derivation->output-path source))
- ((source)
- source)
- (source
- source))
- #:system ,system
- #:phases ,phases
- #:outputs %outputs
- #:goarch ,goarch
- #:goos ,goos
- #:search-paths ',(map search-path-specification->sexp
- search-paths)
- #:install-source? ,install-source?
- #:import-path ,import-path
- #:unpack-path ,unpack-path
- #:build-flags ,build-flags
- #:tests? ,tests?
- #:allow-go-reference? ,allow-go-reference?
- #:inputs %build-inputs)))
-
- (define guile-for-build
- (match guile
- ((? package?)
- (package-derivation store guile system #:graft? #f))
- (#f ; the default
- (let* ((distro (resolve-interface '(gnu packages commencement)))
- (guile (module-ref distro 'guile-final)))
- (package-derivation store guile system
- #:graft? #f)))))
-
- (build-expression->derivation store name builder
- #:inputs inputs
- #:system system
- #:modules imported-modules
- #:outputs outputs
- #:guile-for-build guile-for-build))
+ (with-imported-modules imported-modules
+ #~(begin
+ (use-modules #$@modules)
+ (go-build #:name #$name
+ #:source #+source
+ #:system #$system
+ #:phases #$phases
+ #:outputs #$(outputs->gexp outputs)
++ #:goarch #$goarch
++ #:goos #$goos
+ #:search-paths '#$(sexp->gexp
+ (map search-path-specification->sexp
+ search-paths))
+ #:install-source? #$install-source?
+ #:import-path #$import-path
+ #:unpack-path #$unpack-path
+ #:build-flags #$build-flags
+ #:tests? #$tests?
+ #:allow-go-reference? #$allow-go-reference?
+ #:inputs #$(input-tuples->gexp inputs)))))
+
+ (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
+ system #:graft? #f)))
+ (gexp->derivation name builder
+ #:system system
+ #:guile-for-build guile)))
+ (define* (go-cross-build store name
+ #:key
+ target native-drvs target-drvs
+ (phases '(@ (guix build go-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (native-search-paths '())
+ (install-source? #t)
+ (import-path "")
+ (unpack-path "")
+ (build-flags ''())
+ (tests? #f) ; nothing can be done
+ (allow-go-reference? #f)
+ (system (%current-system))
+ (goarch (first (go-target target)))
+ (goos (last (go-target target)))
+ (guile #f)
+ (imported-modules %go-build-system-modules)
+ (modules '((guix build go-build-system)
+ (guix build union)
+ (guix build utils))))
+ "Cross-build NAME using GO, where TARGET is a GNU triplet and with INPUTS."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (let ()
+ (define %build-host-inputs
+ ',(map (match-lambda
+ ((name (? derivation? drv) sub ...)
+ `(,name . ,(apply derivation->output-path drv sub)))
+ ((name path)
+ `(,name . ,path)))
+ native-drvs))
+
+ (define %build-target-inputs
+ ',(map (match-lambda
+ ((name (? derivation? drv) sub ...)
+ `(,name . ,(apply derivation->output-path drv sub)))
+ ((name (? package? pkg) sub ...)
+ (let ((drv (package-cross-derivation store pkg
+ target system)))
+ `(,name . ,(apply derivation->output-path drv sub))))
+ ((name path)
+ `(,name . ,path)))
+ target-drvs))
+
+ (go-build #:name ,name
+ #:source ,(match (assoc-ref native-drvs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:phases ,phases
+ #:outputs %outputs
+ #:target ,target
+ #:goarch ,goarch
+ #:goos ,goos
+ #:inputs %build-target-inputs
+ #:native-inputs %build-host-inputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:native-search-paths ',(map
+ search-path-specification->sexp
+ native-search-paths)
+ #:install-source? ,install-source?
+ #:import-path ,import-path
+ #:unpack-path ,unpack-path
+ #:build-flags ,build-flags
+ #:tests? ,tests?
+ #:allow-go-reference? ,allow-go-reference?
+ #:inputs %build-inputs))))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f ; the default
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:system system
+ #:inputs (append native-drvs target-drvs)
+ #:outputs outputs
+ #:modules imported-modules
+ #:guile-for-build guile-for-build))
+
(define go-build-system
(build-system
(name 'go)
(guix build utils))))
"Build SOURCE using LINUX, and with INPUTS."
(define builder
- `(begin
- (use-modules ,@modules)
- (linux-module-build #:name ,name
- #:source ,(match (assoc-ref inputs "source")
- (((? derivation? source))
- (derivation->output-path source))
- ((source)
- source)
- (source
- source))
- #:source-directory ,source-directory
- #:search-paths ',(map search-path-specification->sexp
- search-paths)
- #:phases ,phases
- #:system ,system
- #:target ,target
- #:arch ,(system->arch (or target system))
- #:tests? ,tests?
- #:outputs %outputs
- #:make-flags ,make-flags
- #:inputs %build-inputs)))
+ (with-imported-modules imported-modules
+ #~(begin
+ (use-modules #$@(sexp->gexp modules))
+ (linux-module-build #:name #$name
+ #:source #+source
++ #:source-directory #$source-directory
+ #:search-paths '#$(sexp->gexp
+ (map search-path-specification->sexp
+ search-paths))
+ #:phases #$phases
+ #:system #$system
+ #:target #$target
+ #:arch #$(system->arch (or target system))
+ #:tests? #$tests?
+ #:outputs #$(outputs->gexp outputs)
+ #:make-flags #$make-flags
+ #:inputs #$(input-tuples->gexp inputs)))))
- (define guile-for-build
- (match guile
- ((? package?)
- (package-derivation store guile system #:graft? #f))
- (#f ; the default
- (let* ((distro (resolve-interface '(gnu packages commencement)))
- (guile (module-ref distro 'guile-final)))
- (package-derivation store guile system #:graft? #f)))))
-
- (build-expression->derivation store name builder
- #:system system
- #:inputs inputs
- #:modules imported-modules
- #:outputs outputs
- #:guile-for-build guile-for-build
- #:substitutable? substitutable?))
+ (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
+ system #:graft? #f)))
+ (gexp->derivation name builder
+ #:system system
+ #:guile-for-build guile
+ #:substitutable? substitutable?)))
(define* (linux-module-build-cross
- store name
+ name
#:key
- target native-drvs target-drvs
+ source target
+ build-inputs target-inputs host-inputs
(guile #f)
(outputs '("out"))
(make-flags ''())
#:re-export (%current-system
%current-target-system
search-path-specification) ;for convenience
+ #:re-export-and-replace (delete) ;used as syntactic keyword
+ #:replace ((define-public* . define-public))
#:export (content-hash
content-hash?
content-hash-algorithm
;;
;; XXX: MIPS is unavailable in CI:
;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
- (fold delete %supported-systems '("mips64el-linux")))
+ (fold delete %supported-systems '("mips64el-linux" "powerpc-linux")))
+
+(define-inlinable (sanitize-inputs inputs)
+ "Sanitize INPUTS by turning it into a list of name/package tuples if it's
+not already the case."
+ (cond ((null? inputs) inputs)
+ ((and (pair? (car inputs))
+ (string? (caar inputs)))
+ inputs)
+ (else (map add-input-label inputs))))
+ (define-syntax current-location-vector
+ (lambda (s)
+ "Like 'current-source-location' but expand to a literal vector with
+ one-indexed line numbers."
+ ;; Storing a literal vector in .go files is more efficient than storing an
+ ;; alist: less initialization code, fewer relocations, etc.
+ (syntax-case s ()
+ ((_)
+ (match (syntax-source s)
+ (#f #f)
+ (properties
+ (let ((file (assq-ref properties 'filename))
+ (line (assq-ref properties 'line))
+ (column (assq-ref properties 'column)))
+ (and file line column
+ #`#(#,file #,(+ 1 line) #,column)))))))))
+
+ (define-inlinable (sanitize-location loc)
+ ;; Convert LOC to a vector or to #f.
+ (cond ((vector? loc) loc)
+ ((not loc) loc)
+ (else (vector (location-file loc)
+ (location-line loc)
+ (location-column loc)))))
+
+ (define-syntax-parameter current-definition-location
+ ;; Location of the encompassing 'define-public'.
+ (const #f))
+
+ (define-syntax define-public*
+ (lambda (s)
+ "Like 'define-public' but set 'current-definition-location' for the
+ lexical scope of its body."
+ (define location
+ (match (syntax-source s)
+ (#f #f)
+ (properties
+ (let ((line (assq-ref properties 'line))
+ (column (assq-ref properties 'column)))
+ ;; Don't repeat the file name since it's redundant with 'location'.
+ ;; Encode the whole thing so that it fits in a fixnum on 32-bit
+ ;; platforms, which leaves us 29 bits: 7 bits for COLUMN (which is
+ ;; almost always zero), and 22 bits for LINE.
+ (and line column
+ (logior (ash (logand #x7f column) 22)
+ (logand (- (expt 2 22) 1) (+ 1 line))))))))
+
+ (syntax-case s ()
+ ((_ prototype body ...)
+ #`(define-public prototype
+ (syntax-parameterize ((current-definition-location
+ (lambda (s) #,location)))
+ body ...))))))
+
;; A package.
(define-record-type* <package>
package make-package
(properties package-properties (default '())) ; alist for anything else
- (location package-location
- (default (and=> (current-source-location)
- source-properties->location))
- (innate)))
+ (location package-location-vector
+ (default (current-location-vector))
+ (innate) (sanitize sanitize-location))
+ (definition-location package-definition-location-code
+ (default (current-definition-location))
+ (innate)))
+(define (add-input-label input)
+ "Add an input label to INPUT."
+ (match input
+ ((? package? package)
+ (list (package-name package) package))
+ (((? package? package) output) ;XXX: ugly?
+ (list (package-name package) package output))
+ ((? gexp-input?) ;XXX: misplaced because 'native?' field is ignored?
+ (let ((obj (gexp-input-thing input))
+ (output (gexp-input-output input)))
+ `(,(if (package? obj)
+ (package-name obj)
+ "_")
+ ,obj
+ ,@(if (string=? output "out") '() (list output)))))
+ (x
+ `("_" ,x))))
+
(set-record-type-printer! <package>
(lambda (package port)
(let ((loc (package-location package))