From dfe3b875267731006512b8a9803aaa56f07db12e Mon Sep 17 00:00:00 2001
From: Federico Beffa <address@hidden>
Date: Sat, 4 Apr 2015 22:51:13 +0200
Subject: [PATCH] profiles: Generate GHC's package database cache.

* guix/profiles.scm (ghc-package-cache-file): New procedure.
  (profile-derivation): Add 'ghc-package-cache?' keyword argument.  If true
  (the default), add the result of 'ghc-package-cache-file' to 'inputs'.
* guix/scripts/package.scm (guix-package)[process-actions]: Pass
  #:ghc-package-cache? to 'profile-generation'.
* tests/packages.scm ("--search-paths with pattern"): Likewise.
* tests/profiles.scm ("profile-derivation"): Likewise.
---
 guix/profiles.scm        | 59 ++++++++++++++++++++++++++++++++++++++++++++++--
 guix/scripts/package.scm |  1 +
 tests/packages.scm       |  1 +
 tests/profiles.scm       |  2 ++
 4 files changed, 61 insertions(+), 2 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 465aaf9..74e8390 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -404,6 +404,54 @@ MANIFEST."
       (gexp->derivation "info-dir" build
                         #:modules '((guix build utils)))))
 
+(define (ghc-package-cache-file manifest)
+  "Return a derivation that builds the GHC 'package.cache' file for all the
+entries of MANIFEST."
+  (define ghc                                 ;lazy reference
+    (module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
+
+  (define build
+    #~(begin 
+        (use-modules (guix build utils)
+                     (srfi srfi-1) (srfi srfi-26)
+                     (ice-9 ftw))
+
+        (define ghc-name-version
+          (let* ((base (basename #+ghc)))
+            (string-drop base
+                         (+ 1 (string-index base #\-)))))
+        
+        (define db-subdir
+          (string-append "lib/" ghc-name-version "/package.conf.d"))
+
+        (define db-dir
+          (string-append #$output "/" db-subdir))
+        
+        (define (conf-files top)
+          (find-files (string-append top "/" db-subdir) "\\.conf$"))
+
+        (define (copy-conf-file conf)
+          (let ((base (basename conf)))
+            (copy-file conf (string-append db-dir "/" base))))
+        
+        (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
+        (for-each copy-conf-file
+                  (append-map conf-files
+                              '#$(manifest-inputs manifest)))
+        (let ((success
+               (zero?
+                (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
+                         (string-append "--package-db=" db-dir)))))
+          (for-each delete-file (find-files db-dir "\\.conf$"))
+          success)))
+
+  ;; Don't depend on GHC when there's nothing to do.
+  (if (null? (manifest-entries manifest))
+      (gexp->derivation "ghc-package-cache" #~(mkdir #$output))
+      (gexp->derivation "ghc-package-cache" build
+                        #:modules '((guix build utils))
+                        #:local-build? #t)))
+
 (define (ca-certificate-bundle manifest)
   "Return a derivation that builds a single-file bundle containing the CA
 certificates in the /etc/ssl/certs sub-directories of the packages in
@@ -465,14 +513,18 @@ MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
 (define* (profile-derivation manifest
                              #:key
                              (info-dir? #t)
+                             (ghc-package-cache? #t)
                              (ca-certificate-bundle? #t))
   "Return a derivation that builds a profile (aka. 'user environment') with
 the given MANIFEST.  The profile includes a top-level Info 'dir' file unless
-INFO-DIR? is #f, and a single-file CA certificate bundle unless
-CA-CERTIFICATE-BUNDLE? is #f."
+INFO-DIR? is #f, a GHC 'package.cache' file unless GHC-PACKAGE-CACHE? is #f
+and a single-file CA certificate bundle unless CA-CERTIFICATE-BUNDLE? is #f."
   (mlet %store-monad ((info-dir (if info-dir?
                                     (info-dir-file manifest)
                                     (return #f)))
+                      (ghc-package-cache (if ghc-package-cache?
+                                             (ghc-package-cache-file manifest)
+                                             (return #f)))
                       (ca-cert-bundle (if ca-certificate-bundle?
                                           (ca-certificate-bundle manifest)
                                           (return #f))))
@@ -480,6 +532,9 @@ CA-CERTIFICATE-BUNDLE? is #f."
       (append (if info-dir
                   (list (gexp-input info-dir))
                   '())
+              (if ghc-package-cache
+                  (list (gexp-input ghc-package-cache))
+                  '())
               (if ca-cert-bundle
                   (list (gexp-input ca-cert-bundle))
                   '())
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 3cc7ae7..e7fe879 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -829,6 +829,7 @@ more information.~%"))
                                   (profile-derivation
                                    new
                                    #:info-dir? (not bootstrap?)
+                                   #:ghc-package-cache? (not bootstrap?)
                                    #:ca-certificate-bundle? (not bootstrap?))))
                       (prof     (derivation->output-path prof-drv)))
                  (show-manifest-transaction (%store) manifest transaction
diff --git a/tests/packages.scm b/tests/packages.scm
index c9dd5d8..4e3a116 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -600,6 +600,7 @@
                   (manifest (map package->manifest-entry
                                  (list p1 p2)))
                   #:info-dir? #f
+                  #:ghc-package-cache? #f
                   #:ca-certificate-bundle? #f)
                  #:guile-for-build (%guile-for-build))))
     (build-derivations %store (list prof))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 7b942e3..d20cb9d 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -184,6 +184,7 @@
        (guile      (package->derivation %bootstrap-guile))
        (drv        (profile-derivation (manifest (list entry))
                                        #:info-dir? #f
+                                       #:ghc-package-cache? #f
                                        #:ca-certificate-bundle? #f))
        (profile -> (derivation->output-path drv))
        (bindir ->  (string-append profile "/bin"))
@@ -197,6 +198,7 @@
       ((entry ->   (package->manifest-entry packages:glibc "debug"))
        (drv        (profile-derivation (manifest (list entry))
                                        #:info-dir? #f
+                                       #:ghc-package-cache? #f
                                        #:ca-certificate-bundle? #f)))
     (return (derivation-inputs drv))))
 
-- 
2.2.1