10/11: guix system: De-monadify bootloader installation script.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 52ee4479ef26826a53b9929cd00ca7738be687b1
Author: Ludovic Courtès <address@hidden>
Date:   Fri Nov 16 09:25:56 2018 +0100

    guix system: De-monadify bootloader installation script.
    
    * guix/scripts/system.scm (bootloader-installer-derivation): Rename
    to...
    (bootloader-installer-script): ... this.  Use 'scheme-file' instead of
    'gexp->file'.
    (perform-action): Adjust accordingly.  Move 'lower-object' call to the
    point where DRVS is computed.
---
 guix/scripts/system.scm | 65 ++++++++++++++++++++++++++-----------------------
 1 file changed, 34 insertions(+), 31 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 1448810..6f00f12 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -175,12 +175,16 @@ TARGET, and register them."
 
     (return *unspecified*)))
 
-(define* (install-bootloader installer-drv
+(define* (install-bootloader installer
                              #:key
                              bootcfg bootcfg-file
                              target)
-  "Call INSTALLER-DRV with error handling, in %STORE-MONAD."
-  (with-monad %store-monad
+  "Run INSTALLER, a bootloader installation script, with error handling, in
+%STORE-MONAD."
+  (mlet %store-monad ((installer-drv (if installer
+                                         (lower-object installer)
+                                         (return #f)))
+                      (bootcfg       (lower-object bootcfg)))
     (let* ((gc-root      (string-append target %gc-roots-directory
                                         "/bootcfg"))
            (temp-gc-root (string-append gc-root ".new"))
@@ -790,19 +794,18 @@ checking this by themselves in their 'check' procedure."
     (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%"))
     (warning (G_ "Failing to do that may downgrade your system!~%"))))
 
-(define (bootloader-installer-derivation installer
-                                         bootloader device target)
+(define (bootloader-installer-script installer
+                                     bootloader device target)
   "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE
 and TARGET arguments."
-  (with-monad %store-monad
-    (gexp->file "bootloader-installer"
-                (with-imported-modules '((gnu build bootloader)
-                                         (guix build utils))
-                  #~(begin
-                      (use-modules (gnu build bootloader)
-                                   (guix build utils)
-                                   (ice-9 binary-ports))
-                      (#$installer #$bootloader #$device #$target))))))
+  (scheme-file "bootloader-installer"
+               (with-imported-modules '((gnu build bootloader)
+                                        (guix build utils))
+                 #~(begin
+                     (use-modules (gnu build bootloader)
+                                  (guix build utils)
+                                  (ice-9 binary-ports))
+                     (#$installer #$bootloader #$device #$target)))))
 
 (define* (perform-action action os
                          #:key skip-safety-checks?
@@ -851,31 +854,31 @@ static checks."
                                                 #:mappings mappings))
        (bootloader -> (bootloader-configuration-bootloader
                        (operating-system-bootloader os)))
-       (bootcfg  (if (eq? 'container action)
-                     (return #f)
-                     (lower-object
-                      (operating-system-bootcfg
-                       os
-                       (if (eq? 'init action)
-                           '()
-                           (map boot-parameters->menu-entry
-                                (profile-boot-parameters)))))))
+       (bootcfg -> (and (not (eq? 'container action))
+                        (operating-system-bootcfg
+                         os
+                         (if (eq? 'init action)
+                             '()
+                             (map boot-parameters->menu-entry
+                                  (profile-boot-parameters))))))
        (bootcfg-file -> (bootloader-configuration-file bootloader))
        (bootloader-installer
+        ->
         (let ((installer (bootloader-installer bootloader))
               (target    (or target "/")))
-          (bootloader-installer-derivation installer
-                                           (bootloader-package bootloader)
-                                           bootloader-target target)))
+          (bootloader-installer-script installer
+                                       (bootloader-package bootloader)
+                                       bootloader-target target)))
 
        ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
        ;; --no-bootloader is passed, because we then use it as a GC root.
        ;; See <http://bugs.gnu.org/21068>.
-       (drvs   -> (if (memq action '(init reconfigure))
-                      (if install-bootloader?
-                          (list sys bootcfg bootloader-installer)
-                          (list sys bootcfg))
-                      (list sys)))
+       (drvs      (mapm %store-monad lower-object
+                        (if (memq action '(init reconfigure))
+                            (if install-bootloader?
+                                (list sys bootcfg bootloader-installer)
+                                (list sys bootcfg))
+                            (list sys))))
        (%         (if derivations-only?
                       (return (for-each (compose println derivation-file-name)
                                         drvs))