packages: Rewrite 'patch-and-repack' using gexps.

* guix/packages.scm (patch-and-repack): Remove 'store' parameter and
  change default value of #:inputs to (%standard-patch-inputs).
  [lookup-input, instantiate-patch]: New procedures.
  [patch-inputs]: Remove.
  [builder]: Rename to...
  [build]: ... this.  Use gexps instead of sexps.
  (patch-and-repack*): Remove.
  (origin->derivation): Use 'patch-and-repack' instead of
  'patch-and-repack*'.
* tests/packages.scm ("package-source-derivation,
  snippet")[source](snippet): Remove references to '%build-inputs' and
  '%outputs'.

1 files changed, 103 insertions, 123 deletions

diff --git a/guix/packages.scm b/guix/packages.scm
index ec0e79d08b..f12ef99b3e 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -26,6 +26,7 @@
   #:use-module (guix base32)
   #:use-module (guix derivations)
   #:use-module (guix build-system)
+  #:use-module (guix gexp)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
@@ -349,10 +350,9 @@ the build code of derivation."
   (package->derivation (default-guile) system
                        #:graft? #f))
 
-;; TODO: Rewrite using %STORE-MONAD and gexps.
-(define* (patch-and-repack store source patches
+(define* (patch-and-repack source patches
                            #:key
-                           (inputs '())
+                           (inputs (%standard-patch-inputs))
                            (snippet #f)
                            (flags '("-p1"))
                            (modules '())
@@ -370,6 +370,11 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
         (derivation->output-path source)
         source))
 
+  (define (lookup-input name)
+    (match (assoc-ref inputs name)
+      ((package) package)
+      (#f        #f)))
+
   (define decompression-type
     (cond ((string-suffix? "gz" source-file-name)  "gzip")
           ((string-suffix? "bz2" source-file-name) "bzip2")
@@ -398,115 +403,93 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
                          ".xz"
                          ".tar.xz"))))
 
-  (define patch-inputs
-    (map (lambda (number patch)
-           (list (string-append "patch" (number->string number))
-                 (match patch
-                   ((? string?)
-                    (add-to-store store (basename patch) #t
-                                  "sha256" patch))
-                   ((? origin?)
-                    (package-source-derivation store patch system)))))
-         (iota (length patches))
-
-         patches))
-
-  (define builder
-    `(begin
-       (use-modules (ice-9 ftw)
-                    (srfi srfi-1)
-                    (guix build utils))
-
-       ;; Encoding/decoding errors shouldn't be silent.
-       (fluid-set! %default-port-conversion-strategy 'error)
-
-       (let ((locales (assoc-ref %build-inputs "locales"))
-             (out     (assoc-ref %outputs "out"))
-             (xz      (assoc-ref %build-inputs "xz"))
-             (decomp  (assoc-ref %build-inputs ,decompression-type))
-             (source  (assoc-ref %build-inputs "source"))
-             (tar     (string-append (assoc-ref %build-inputs "tar")
-                                     "/bin/tar"))
-             (patch   (string-append (assoc-ref %build-inputs "patch")
-                                     "/bin/patch")))
-         (define (apply-patch input)
-           (let ((patch* (assoc-ref %build-inputs input)))
-             (format (current-error-port) "applying '~a'...~%" patch*)
-
-             ;; Use '--force' so that patches that do not apply perfectly are
-             ;; rejected.
-             (zero? (system* patch "--force" ,@flags "--input" patch*))))
-
-         (define (first-file directory)
-           ;; Return the name of the first file in DIRECTORY.
-           (car (scandir directory
-                         (lambda (name)
-                           (not (member name '("." "..")))))))
-
-         (when locales
-           ;; First of all, install a UTF-8 locale so that UTF-8 file names
-           ;; are correctly interpreted.  During bootstrap, LOCALES is #f.
-           (setenv "LOCPATH" (string-append locales "/lib/locale"))
-           (setlocale LC_ALL "en_US.UTF-8"))
-
-         (setenv "PATH" (string-append xz "/bin" ":"
-                                       decomp "/bin"))
-
-         ;; SOURCE may be either a directory or a tarball.
-         (and (if (file-is-directory? source)
-                  (let* ((store     (or (getenv "NIX_STORE") "/gnu/store"))
-                         (len       (+ 1 (string-length store)))
-                         (base      (string-drop source len))
-                         (dash      (string-index base #\-))
-                         (directory (string-drop base (+ 1 dash))))
-                    (mkdir directory)
-                    (copy-recursively source directory)
-                    #t)
-                  (zero? (system* tar "xvf" source)))
-              (let ((directory (first-file ".")))
-                (format (current-error-port)
-                        "source is under '~a'~%" directory)
-                (chdir directory)
-
-                (and (every apply-patch ',(map car patch-inputs))
-
-                     ,@(if snippet
-                           `((let ((module (make-fresh-user-module)))
-                               (module-use-interfaces! module
-                                                       (map resolve-interface
-                                                            ',modules))
-                               (module-define! module '%build-inputs
-                                               %build-inputs)
-                               (module-define! module '%outputs %outputs)
-                               ((@ (system base compile) compile)
-                                ',snippet
-                                #:to 'value
-                                #:opts %auto-compilation-options
-                                #:env module)))
-                           '())
-
-                     (begin (chdir "..") #t)
-                     (zero? (system* tar "cvfa" out directory))))))))
-
-
-  (let ((name    (tarxz-name original-file-name))
-        (inputs  (filter-map (match-lambda
-                              ((name (? package? p))
-                               (and (member name (cons decompression-type
-                                                       '("tar" "xz" "patch")))
-                                    (list name
-                                          (package-derivation store p system
-                                                              #:graft? #f)))))
-                             (or inputs (%standard-patch-inputs))))
-        (modules (delete-duplicates (cons '(guix build utils) modules))))
-
-    (build-expression->derivation store name builder
-                                 #:inputs `(("source" ,source)
-                                            ,@inputs
-                                            ,@patch-inputs)
-                                 #:system system
-                                 #:modules modules
-                                 #:guile-for-build guile-for-build)))
+  (define instantiate-patch
+    (match-lambda
+      ((? string? patch)
+       (interned-file patch #:recursive? #t))
+      ((? origin? patch)
+       (origin->derivation patch system))))
+
+  (mlet %store-monad ((tar ->     (lookup-input "tar"))
+                      (xz ->      (lookup-input "xz"))
+                      (patch ->   (lookup-input "patch"))
+                      (locales -> (lookup-input "locales"))
+                      (decomp ->  (lookup-input decompression-type))
+                      (patches    (sequence %store-monad
+                                            (map instantiate-patch patches))))
+    (define build
+      #~(begin
+          (use-modules (ice-9 ftw)
+                       (srfi srfi-1)
+                       (guix build utils))
+
+          (define (apply-patch patch)
+            (format (current-error-port) "applying '~a'...~%" patch)
+
+            ;; Use '--force' so that patches that do not apply perfectly are
+            ;; rejected.
+            (zero? (system* (string-append #$patch "/bin/patch")
+                            "--force" #$@flags "--input" patch)))
+
+          (define (first-file directory)
+            ;; Return the name of the first file in DIRECTORY.
+            (car (scandir directory
+                          (lambda (name)
+                            (not (member name '("." "..")))))))
+
+          ;; Encoding/decoding errors shouldn't be silent.
+          (fluid-set! %default-port-conversion-strategy 'error)
+
+          (when #$locales
+            ;; First of all, install a UTF-8 locale so that UTF-8 file names
+            ;; are correctly interpreted.  During bootstrap, LOCALES is #f.
+            (setenv "LOCPATH" (string-append #$locales "/lib/locale"))
+            (setlocale LC_ALL "en_US.UTF-8"))
+
+          (setenv "PATH" (string-append #$xz "/bin" ":"
+                                        #$decomp "/bin"))
+
+          ;; SOURCE may be either a directory or a tarball.
+          (and (if (file-is-directory? #$source)
+                   (let* ((store     (or (getenv "NIX_STORE") "/gnu/store"))
+                          (len       (+ 1 (string-length store)))
+                          (base      (string-drop #$source len))
+                          (dash      (string-index base #\-))
+                          (directory (string-drop base (+ 1 dash))))
+                     (mkdir directory)
+                     (copy-recursively #$source directory)
+                     #t)
+                   (zero? (system* (string-append #$tar "/bin/tar")
+                                   "xvf" #$source)))
+               (let ((directory (first-file ".")))
+                 (format (current-error-port)
+                         "source is under '~a'~%" directory)
+                 (chdir directory)
+
+                 (and (every apply-patch '#$patches)
+                      #$@(if snippet
+                             #~((let ((module (make-fresh-user-module)))
+                                  (module-use-interfaces! module
+                                                          (map resolve-interface
+                                                               '#$modules))
+                                  ((@ (system base compile) compile)
+                                   '#$snippet
+                                   #:to 'value
+                                   #:opts %auto-compilation-options
+                                   #:env module)))
+                             #~())
+
+                      (begin (chdir "..") #t)
+                      (zero? (system* (string-append #$tar "/bin/tar")
+                                      "cvfa" #$output directory)))))))
+
+    (let ((name    (tarxz-name original-file-name))
+          (modules (delete-duplicates (cons '(guix build utils) modules))))
+      (gexp->derivation name build
+                        #:graft? #f
+                        #:system system
+                        #:modules modules
+                        #:guile-for-build guile-for-build))))
 
 (define (transitive-inputs inputs)
   (let loop ((inputs  inputs)
@@ -954,9 +937,6 @@ cross-compilation target triplet."
       (package->cross-derivation package target system)
       (package->derivation package system)))
 
-(define patch-and-repack*
-  (store-lift patch-and-repack))
-
 (define* (origin->derivation source
                              #:optional (system (%current-system)))
   "When SOURCE is an <origin> object, return its derivation for SYSTEM.  When
@@ -976,14 +956,14 @@ outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
                                                           (default-guile))
                                                       system
                                                       #:graft? #f)))
-       (patch-and-repack* source patches
-                          #:inputs inputs
-                          #:snippet snippet
-                          #:flags flags
-                          #:system system
-                          #:modules modules
-                          #:imported-modules modules
-                          #:guile-for-build guile)))
+       (patch-and-repack source patches
+                         #:inputs inputs
+                         #:snippet snippet
+                         #:flags flags
+                         #:system system
+                         #:modules modules
+                         #:imported-modules modules
+                         #:guile-for-build guile)))
     ((and (? string?) (? direct-store-path?) file)
      (with-monad %store-monad
        (return file)))