01/02: guix: gexp: Define gexp->approximate-sexp.

[guix-commits]

mothacehe pushed a commit to branch master
in repository guix.

commit d9e0ae07db5cb9f949c11f4ee77146a070c2618c
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Mon Jun 28 19:24:44 2021 +0200

    guix: gexp: Define gexp->approximate-sexp.
    
    It will be used in the 'optional-tests' linter.
    
    * guix/gexp.scm (gexp->approximate-sexp): New procedure.
    * tests/gexp.scm
      ("no references", "unquoted gexp", "unquoted gexp (native)")
      ("spliced gexp", "unspliced gexp, approximated")
      ("unquoted gexp, approximated"): Test it.
    * doc/gexp.scm ("G-Expressions"): Document it.
    
    Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
---
 doc/guix.texi  | 10 ++++++++++
 guix/gexp.scm  | 19 +++++++++++++++++++
 tests/gexp.scm | 31 +++++++++++++++++++++++++++++++
 3 files changed, 60 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index e0668b1..e39e4eb 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10046,6 +10046,16 @@ corresponding to @var{obj} for @var{system}, 
cross-compiling for
 has an associated gexp compiler, such as a @code{<package>}.
 @end deffn
 
+@deffn {Procedure} gexp->approximate-sexp @var{gexp}
+Sometimes, it may be useful to convert a G-exp into a S-exp.  For
+example, some linters (@pxref{Invoking guix lint}) peek into the build
+phases of a package to detect potential problems.  This conversion can
+be achieved with this procedure.  However, some information can be lost
+in the process.  More specifically, lowerable objects will be silently
+replaced with some arbitrary object -- currently the list
+@code{(*approximate*)}, but this may change.
+@end deffn
+
 @node Invoking guix repl
 @section Invoking @command{guix repl}
 
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 187f5c5..f3d278b 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -42,6 +43,7 @@
             with-imported-modules
             with-extensions
             let-system
+            gexp->approximate-sexp
 
             gexp-input
             gexp-input?
@@ -157,6 +159,23 @@
   "Return the source code location of GEXP."
   (and=> (%gexp-location gexp) source-properties->location))
 
+(define* (gexp->approximate-sexp gexp)
+  "Return the S-expression corresponding to GEXP, but do not lower anything.
+As a result, the S-expression will be approximate if GEXP has references."
+  (define (gexp-like? thing)
+    (or (gexp? thing) (gexp-input? thing)))
+  (apply (gexp-proc gexp)
+         (map (lambda (reference)
+                (match reference
+                  (($ <gexp-input> thing output native)
+                   (if (gexp-like? thing)
+                       (gexp->approximate-sexp thing)
+                       ;; Simply returning 'thing' won't work in some
+                       ;; situations; see 'write-gexp' below.
+                       '(*approximate*)))
+                  (_ '(*approximate*))))
+              (gexp-references gexp))))
+
 (define (write-gexp gexp port)
   "Write GEXP on PORT."
   (display "#<gexp " port)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 834e78b..39a47d4 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès 
<ludo@gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -89,6 +90,36 @@
 
 (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))))
+
 (test-equal "no refs"
   '(display "hello!")
   (let ((exp (gexp (display "hello!"))))