;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021-2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 (test-gexp)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module ((guix grafts) #:select (%graft-with-utf8-locale?))
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix build-system trivial)
#:use-module (guix tests)
#:use-module ((guix build utils) #:select (with-directory-excursion))
#:use-module ((guix utils) #:select (call-with-temporary-directory))
#:use-module ((guix ui) #:select (load*))
#:use-module (gnu packages)
#:use-module (gnu packages base)
#:use-module (gnu packages bootstrap)
#:use-module ((guix diagnostics) #:select (guix-warning-port))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 popen)
#:use-module (ice-9 ftw))
;; Test the (guix gexp) module.
(define %store
(open-connection-for-tests))
(define (bootstrap-guile-effective-version)
;; TODO The package version of %bootstrap-guile is incorrect for
;; riscv64-linux
(if (string=? "riscv64-linux" (%current-system))
"3.0"
(package-version %bootstrap-guile)))
;; Globally disable grafts because they can trigger early builds.
(%graft? #f)
;; When grafting, do not add dependency on 'glibc-utf8-locales'.
(%graft-with-utf8-locale? #f)
;; For white-box testing.
(define (gexp-inputs x)
((@@ (guix gexp) gexp-inputs) x))
(define (gexp-outputs x)
((@@ (guix gexp) gexp-outputs) x))
(define (gexp->sexp . x)
(apply (@@ (guix gexp) gexp->sexp) x))
(define* (gexp->sexp* exp #:optional target)
(run-with-store %store (gexp->sexp exp (%current-system) target)
#:guile-for-build (%guile-for-build)))
(define (gexp-input->tuple input)
(list (gexp-input-thing input) (gexp-input-output input)
(gexp-input-native? input)))
(define %extension-package
;; Example of a package to use when testing 'with-extensions'.
(dummy-package "extension"
(build-system trivial-build-system)
(arguments
`(#:guile ,%bootstrap-guile
#:modules ((guix build utils))
#:builder
(begin
(use-modules (guix build utils))
(let* ((out (string-append (assoc-ref %outputs "out")
"/share/guile/site/"
(effective-version))))
(mkdir-p out)
(call-with-output-file (string-append out "/hg2g.scm")
(lambda (port)
(define defmod 'define-module) ;fool Geiser
(write `(,defmod (hg2g)
#:export (the-answer))
port)
(write '(define the-answer 42) port)))))))))
(test-begin "gexp")
(test-equal "no references"
'(display "hello gexp->approximate-sexp!")
(gexp->approximate-sexp #~(display "hello gexp->approximate-sexp!")))
(test-equal "unquoted gexp"
'(display "hello")
(let ((inside #~"hello"))
(gexp->approximate-sexp #~(display #$inside))))
(test-equal "unquoted gexp (native)"
'(display "hello")
(let ((inside #~"hello"))
(gexp->approximate-sexp #~(display #+inside))))
(test-equal "spliced gexp"
'(display '(fresh vegetables))
(let ((inside #~(fresh vegetables)))
(gexp->approximate-sexp #~(display '(#$@inside)))))
(test-equal "unspliced gexp, approximated"
;; (*approximate*) is really an implementation detail
'(display '(*approximate*))
(let ((inside (file-append coreutils "/bin/hello")))
(gexp->approximate-sexp #~(display '(#$@inside)))))
(test-equal "unquoted gexp, approximated"
'(display '(*approximate*))
(let ((inside (file-append coreutils "/bin/hello")))
(gexp->approximate-sexp #~(display '#$inside))))
;; See <https://issues.guix.gnu.org/54236>.
(test-equal "unquoted sexp (not a gexp!)"
'(list #(foo) (foo) () "foo" foo #xf00)
(let ((inside/vector #(foo))
(inside/list '(foo))
(inside/empty '())
(inside/string "foo")
(inside/symbol 'foo)
(inside/number #xf00))
(gexp->approximate-sexp
#~(list #$inside/vector #$inside/list #$inside/empty #$inside/string
#$inside/symbol #$inside/number))))
(test-equal "no refs"
'(display "hello!")
(let ((exp (gexp (display "hello!"))))
(and (gexp? exp)
(null? (gexp-inputs exp))
(gexp->sexp* exp))))
(test-equal "sexp->gexp"
'(a b (c d) e)
(let ((exp (sexp->gexp '(a b (c d) e))))
(and (gexp? exp)
(null? (gexp-inputs exp))
(gexp->sexp* exp))))
(test-equal "gexp->approximate-sexp, outputs"
'(list 'out:foo (*approximate*) 'out:bar (*approximate*))
(gexp->approximate-sexp
#~(list 'out:foo #$output:foo 'out:bar #$output:bar)))
(test-equal "unquote"
'(display `(foo ,(+ 2 3)))
(let ((exp (gexp (display `(foo ,(+ 2 3))))))
(and (gexp? exp)
(null? (gexp-inputs exp))
(gexp->sexp* exp))))
(test-assert "one input package"
(let ((exp (gexp (display (ungexp coreutils)))))
(and (gexp? exp)
(match (gexp-inputs exp)
((input)
(eq? (gexp-input-thing input) coreutils)))
(equal? `(display ,(derivation->output-path
(package-derivation %store coreutils)))
(gexp->sexp* exp)))))
(test-assert "one input package, dotted list"
(let ((exp (gexp (coreutils . (ungexp coreutils)))))
(and (gexp? exp)
(match (gexp-inputs exp)
((input)
(eq? (gexp-input-thing input) coreutils)))
(equal? `(coreutils . ,(derivation->output-path
(package-derivation %store coreutils)))
(gexp->sexp* exp)))))
(test-assert "one input origin"
(let ((exp (gexp (display (ungexp (package-source coreutils))))))
(and (gexp? exp)
(match (gexp-inputs exp)
((input)
(and (eq? (gexp-input-thing input) (package-source coreutils))
(string=? (gexp-input-output input) "out"))))
(equal? `(display ,(derivation->output-path
(package-source-derivation
%store (package-source coreutils))))
(gexp->sexp* exp)))))
(test-assert "one local file"
(let* ((file (search-path %load-path "guix.scm"))
(local (local-file file))
(exp (gexp (display (ungexp local))))
(intd (add-to-store %store (basename file) #f
"sha256" file)))
(and (gexp? exp)
(match (gexp-inputs exp)
((input)
(and (eq? (gexp-input-thing input) local)
(string=? (gexp-input-output input) "out"))))
(equal? `(display ,intd) (gexp->sexp* exp)))))
(test-assert "one local file, symlink"
(let ((file (search-path %load-path "guix.scm"))
(link (tmpnam)))
(dynamic-wind
(const #t)
(lambda ()
(symlink (canonicalize-path file) link)
(let* ((local (local-file link "my-file" #:recursive? #f))
(exp (gexp (display (ungexp local))))
(intd (add-to-store %store "my-file" #f
"sha256" file)))
(and (gexp? exp)
(match (gexp-inputs exp)
((input)
(and (eq? (gexp-input-thing input) local)
(string=? (gexp-input-output input) "out"))))
(equal? `(display ,intd) (gexp->sexp* exp)))))
(lambda ()
(false-if-exception (delete-file link))))))
(test-equal "local-file, relative file name"
(canonicalize-path (search-path %load-path "guix/base32.scm"))
(let ((directory (dirname (search-path %load-path
"guix/build-system/gnu.scm"))))
(with-directory-excursion directory
(let (
