[jackhill/guix/guix.git] / build-aux / build-self.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (build-self)
  #:use-module (gnu)
  #:use-module (guix)
  #:use-module (guix config)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (ice-9 match)
  #:export (build))

;;; Commentary:
;;;
;;; When loaded, this module returns a monadic procedure of at least one
;;; argument: the source tree to build.  It returns a derivation that
;;; builds it.
;;;
;;; This file uses modules provided by the already-installed Guix.  Those
;;; modules may be arbitrarily old compared to the version we want to
;;; build.  Because of that, it must rely on the smallest set of features
;;; that are likely to be provided by the (guix) and (gnu) modules, and by
;;; Guile itself, forever and ever.
;;;
;;; Code:

\f
;; The dependencies.  Don't refer explicitly to the variables because they
;; could be renamed or shuffled around in modules over time.  Conversely,
;; 'find-best-packages-by-name' is expected to always have the same semantics.

(define libgcrypt
  (first (find-best-packages-by-name "libgcrypt" #f)))

(define zlib
  (first (find-best-packages-by-name "zlib" #f)))

(define gzip
  (first (find-best-packages-by-name "gzip" #f)))

(define bzip2
  (first (find-best-packages-by-name "bzip2" #f)))

(define xz
  (first (find-best-packages-by-name "xz" #f)))

(define (false-if-wrong-guile package)
  "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g.,
2.0 instead of 2.2), otherwise return PACKAGE."
  (let ((guile (any (match-lambda
                      ((label (? package? dep) _ ...)
                       (and (string=? (package-name dep) "guile")
                            dep)))
                    (package-direct-inputs package))))
    (and (or (not guile)
             (string-prefix? (effective-version)
                             (package-version guile)))
         package)))

(define (package-for-current-guile . names)
  "Return the package with one of the given NAMES that depends on the current
Guile major version (2.0 or 2.2), or #f if none of the packages matches."
  (let loop ((names names))
    (match names
      (()
       #f)
      ((name rest ...)
       (match (find-best-packages-by-name name #f)
         (()
          (loop rest))
         ((first _ ...)
          (or (false-if-wrong-guile first)
              (loop rest))))))))

(define guile-json
  (package-for-current-guile "guile-json"
                             "guile2.2-json"
                             "guile2.0-json"))

(define guile-ssh
  (package-for-current-guile "guile-ssh"
                             "guile2.2-ssh"
                             "guile2.0-ssh"))

(define guile-git
  (package-for-current-guile "guile-git"
                             "guile2.0-git"))

(define guile-bytestructures
  (package-for-current-guile "guile-bytestructures"
                             "guile2.0-bytestructures"))
\f
;; The actual build procedure.

(define (top-source-directory)
  "Return the name of the top-level directory of this source tree."
  (and=> (assoc-ref (current-source-location) 'filename)
         (lambda (file)
           (string-append (dirname file) "/.."))))


(define (date-version-string)
  "Return the current date and hour in UTC timezone, for use as a poor
person's version identifier."
  ;; XXX: Replace with a Git commit id.
  (date->string (current-date 0) "~Y~m~d.~H"))

(define (guile-for-build)
  "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
running Guile."
  (package->derivation (cond-expand
                         (guile-2.2
                          (canonical-package
                           (specification->package "guile@2.2")))
                         (else
                          (canonical-package
                           (specification->package "guile@2.0"))))))

;; The procedure below is our return value.
(define* (build source
                #:key verbose? (version (date-version-string))
                #:allow-other-keys
                #:rest rest)
  "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
files."
  ;; The '%xxxdir' variables were added to (guix config) in July 2016 so we
  ;; cannot assume that they are defined.  Try to guess their value when
  ;; they're undefined (XXX: we get an incorrect guess when environment
  ;; variables such as 'NIX_STATE_DIR' are defined!).
  (define storedir
    (if (defined? '%storedir) %storedir %store-directory))
  (define localstatedir
    (if (defined? '%localstatedir) %localstatedir (dirname %state-directory)))
  (define sysconfdir
    (if (defined? '%sysconfdir) %sysconfdir (dirname %config-directory)))
  (define sbindir
    (if (defined? '%sbindir) %sbindir (dirname %guix-register-program)))

  (define builder
    #~(begin
        (use-modules (guix build pull))

        (letrec-syntax ((maybe-load-path
                         (syntax-rules ()
                           ((_ item rest ...)
                            (let ((tail (maybe-load-path rest ...)))
                              (if (string? item)
                                  (cons (string-append item
                                                       "/share/guile/site/"
                                                       #$(effective-version))
                                        tail)
                                  tail)))
                           ((_)
                            '()))))
          (set! %load-path
                (append
                 (maybe-load-path #$guile-json #$guile-ssh
                                  #$guile-git #$guile-bytestructures)
                 %load-path)))

        (letrec-syntax ((maybe-load-compiled-path
                         (syntax-rules ()
                           ((_ item rest ...)
                            (let ((tail (maybe-load-compiled-path rest ...)))
                              (if (string? item)
                                  (cons (string-append item
                                                       "/lib/guile/"
                                                       #$(effective-version)
                                                       "/site-ccache")
                                        tail)
                                  tail)))
                           ((_)
                            '()))))
          (set! %load-compiled-path
                (append
                 (maybe-load-compiled-path #$guile-json #$guile-ssh
                                           #$guile-git #$guile-bytestructures)
                 %load-compiled-path)))

        ;; XXX: The 'guile-ssh' package prior to Guix commit 92b7258 was
        ;; broken: libguile-ssh could not be found.  Work around that.
        ;; FIXME: We want Guile-SSH 0.10.2 or later anyway.
        #$(if (string-prefix? "0.9." (package-version guile-ssh))
              #~(setenv "LTDL_LIBRARY_PATH" (string-append #$guile-ssh "/lib"))
              #t)

        (build-guix #$output #$source

                    #:system #$%system
                    #:storedir #$storedir
                    #:localstatedir #$localstatedir
                    #:sysconfdir #$sysconfdir
                    #:sbindir #$sbindir

                    #:package-name #$%guix-package-name
                    #:package-version #$version
                    #:bug-report-address #$%guix-bug-report-address
                    #:home-page-url #$%guix-home-page-url

                    #:libgcrypt #$libgcrypt
                    #:zlib #$zlib
                    #:gzip #$gzip
                    #:bzip2 #$bzip2
                    #:xz #$xz

                    ;; XXX: This is not perfect, enabling VERBOSE? means
                    ;; building a different derivation.
                    #:debug-port (if #$verbose?
                                     (current-error-port)
                                     (%make-void-port "w")))))

  (mlet %store-monad ((guile (guile-for-build)))
    (gexp->derivation "guix-latest" builder
                      #:modules '((guix build pull)
                                  (guix build utils)

                                  ;; Closure of (guix modules).
                                  (guix modules)
                                  (guix memoization)
                                  (guix sets))

                      ;; Arrange so that our own (guix build …) modules are
                      ;; used.
                      #:module-path (list (top-source-directory))

                      #:guile-for-build guile)))

;; This file is loaded by 'guix pull'; return it the build procedure.
build

;; Local Variables:
;; eval: (put 'with-load-path 'scheme-indent-function 1)
;; End:

;;; build-self.scm ends here
Commit	Line	Data
f81ac34d	1	;;; GNU Guix --- Functional package management for GNU
838ba73d	2	;;; Copyright © 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
f81ac34d LC	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (build-self)
	20	#:use-module (gnu)
	21	#:use-module (guix)
13cee334	22	#:use-module (guix config)
f81ac34d	23	#:use-module (srfi srfi-1)
b006ba50	24	#:use-module (srfi srfi-19)
838ba73d	25	#:use-module (ice-9 match)
f81ac34d LC	26	#:export (build))
	27
	28	;;; Commentary:
	29	;;;
	30	;;; When loaded, this module returns a monadic procedure of at least one
	31	;;; argument: the source tree to build. It returns a derivation that
	32	;;; builds it.
	33	;;;
	34	;;; This file uses modules provided by the already-installed Guix. Those
	35	;;; modules may be arbitrarily old compared to the version we want to
	36	;;; build. Because of that, it must rely on the smallest set of features
	37	;;; that are likely to be provided by the (guix) and (gnu) modules, and by
	38	;;; Guile itself, forever and ever.
	39	;;;
	40	;;; Code:
	41
	42	\f
	43	;; The dependencies. Don't refer explicitly to the variables because they
	44	;; could be renamed or shuffled around in modules over time. Conversely,
	45	;; 'find-best-packages-by-name' is expected to always have the same semantics.
	46
	47	(define libgcrypt
	48	(first (find-best-packages-by-name "libgcrypt" #f)))
	49
13cee334 LC	50	(define zlib
	51	(first (find-best-packages-by-name "zlib" #f)))
	52
	53	(define gzip
	54	(first (find-best-packages-by-name "gzip" #f)))
	55
	56	(define bzip2
	57	(first (find-best-packages-by-name "bzip2" #f)))
	58
	59	(define xz
	60	(first (find-best-packages-by-name "xz" #f)))
	61
838ba73d LC	62	(define (false-if-wrong-guile package)
	63	"Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g.,
	64	2.0 instead of 2.2), otherwise return PACKAGE."
	65	(let ((guile (any (match-lambda
	66	((label (? package? dep) _ ...)
	67	(and (string=? (package-name dep) "guile")
	68	dep)))
	69	(package-direct-inputs package))))
	70	(and (or (not guile)
	71	(string-prefix? (effective-version)
	72	(package-version guile)))
	73	package)))
	74
	75	(define (package-for-current-guile . names)
	76	"Return the package with one of the given NAMES that depends on the current
	77	Guile major version (2.0 or 2.2), or #f if none of the packages matches."
	78	(let loop ((names names))
	79	(match names
	80	(()
	81	#f)
	82	((name rest ...)
	83	(match (find-best-packages-by-name name #f)
	84	(()
	85	(loop rest))
	86	((first _ ...)
	87	(or (false-if-wrong-guile first)
	88	(loop rest))))))))
	89
f81ac34d	90	(define guile-json
838ba73d LC	91	(package-for-current-guile "guile-json"
	92	"guile2.2-json"
	93	"guile2.0-json"))
f81ac34d	94
5aed7f10	95	(define guile-ssh
838ba73d LC	96	(package-for-current-guile "guile-ssh"
	97	"guile2.2-ssh"
	98	"guile2.0-ssh"))
f81ac34d	99
19c90e5f MO	100	(define guile-git
	101	(package-for-current-guile "guile-git"
	102	"guile2.0-git"))
	103
	104	(define guile-bytestructures
	105	(package-for-current-guile "guile-bytestructures"
	106	"guile2.0-bytestructures"))
f81ac34d LC	107	\f
	108	;; The actual build procedure.
	109
	110	(define (top-source-directory)
	111	"Return the name of the top-level directory of this source tree."
	112	(and=> (assoc-ref (current-source-location) 'filename)
	113	(lambda (file)
	114	(string-append (dirname file) "/.."))))
	115
b006ba50 LC	116
	117	(define (date-version-string)
	118	"Return the current date and hour in UTC timezone, for use as a poor
	119	person's version identifier."
	120	;; XXX: Replace with a Git commit id.
	121	(date->string (current-date 0) "~Y~m~d.~H"))
	122
838ba73d LC	123	(define (guile-for-build)
	124	"Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
	125	running Guile."
	126	(package->derivation (cond-expand
	127	(guile-2.2
	128	(canonical-package
	129	(specification->package "guile@2.2")))
	130	(else
	131	(canonical-package
	132	(specification->package "guile@2.0"))))))
	133
f81ac34d	134	;; The procedure below is our return value.
b006ba50 LC	135	(define* (build source
b006ba50 LC	136	#:key verbose? (version (date-version-string))
f81ac34d LC	137	#:allow-other-keys
	138	#:rest rest)
	139	"Return a derivation that unpacks SOURCE into STORE and compiles Scheme
	140	files."
13cee334 LC	141	;; The '%xxxdir' variables were added to (guix config) in July 2016 so we
	142	;; cannot assume that they are defined. Try to guess their value when
	143	;; they're undefined (XXX: we get an incorrect guess when environment
	144	;; variables such as 'NIX_STATE_DIR' are defined!).
	145	(define storedir
	146	(if (defined? '%storedir) %storedir %store-directory))
	147	(define localstatedir
	148	(if (defined? '%localstatedir) %localstatedir (dirname %state-directory)))
	149	(define sysconfdir
	150	(if (defined? '%sysconfdir) %sysconfdir (dirname %config-directory)))
	151	(define sbindir
	152	(if (defined? '%sbindir) %sbindir (dirname %guix-register-program)))
	153
f81ac34d LC	154	(define builder
	155	#~(begin
	156	(use-modules (guix build pull))
	157
19c90e5f MO	158	(letrec-syntax ((maybe-load-path
	159	(syntax-rules ()
	160	((_ item rest ...)
	161	(let ((tail (maybe-load-path rest ...)))
	162	(if (string? item)
	163	(cons (string-append item
	164	"/share/guile/site/"
	165	#$(effective-version))
	166	tail)
	167	tail)))
	168	((_)
	169	'()))))
5aed7f10	170	(set! %load-path
19c90e5f MO	171	(append
	172	(maybe-load-path #$guile-json #$guile-ssh
	173	#$guile-git #$guile-bytestructures)
	174	%load-path)))
	175
	176	(letrec-syntax ((maybe-load-compiled-path
	177	(syntax-rules ()
	178	((_ item rest ...)
	179	(let ((tail (maybe-load-compiled-path rest ...)))
	180	(if (string? item)
	181	(cons (string-append item
	182	"/lib/guile/"
	183	#$(effective-version)
	184	"/site-ccache")
	185	tail)
	186	tail)))
	187	((_)
	188	'()))))
5aed7f10	189	(set! %load-compiled-path
19c90e5f MO	190	(append
	191	(maybe-load-compiled-path #$guile-json #$guile-ssh
	192	#$guile-git #$guile-bytestructures)
	193	%load-compiled-path)))
f81ac34d	194
aa28ecc4 LC	195	;; XXX: The 'guile-ssh' package prior to Guix commit 92b7258 was
	196	;; broken: libguile-ssh could not be found. Work around that.
	197	;; FIXME: We want Guile-SSH 0.10.2 or later anyway.
	198	#$(if (string-prefix? "0.9." (package-version guile-ssh))
	199	#~(setenv "LTDL_LIBRARY_PATH" (string-append #$guile-ssh "/lib"))
	200	#t)
	201
f81ac34d LC	202	(build-guix #$output #$source
f81ac34d LC	203
13cee334 LC	204	#:system #$%system
	205	#:storedir #$storedir
	206	#:localstatedir #$localstatedir
	207	#:sysconfdir #$sysconfdir
	208	#:sbindir #$sbindir
	209
	210	#:package-name #$%guix-package-name
b006ba50	211	#:package-version #$version
13cee334 LC	212	#:bug-report-address #$%guix-bug-report-address
	213	#:home-page-url #$%guix-home-page-url
	214
	215	#:libgcrypt #$libgcrypt
	216	#:zlib #$zlib
	217	#:gzip #$gzip
	218	#:bzip2 #$bzip2
	219	#:xz #$xz
	220
f81ac34d LC	221	;; XXX: This is not perfect, enabling VERBOSE? means
	222	;; building a different derivation.
	223	#:debug-port (if #$verbose?
	224	(current-error-port)
13cee334	225	(%make-void-port "w")))))
f81ac34d	226
838ba73d LC	227	(mlet %store-monad ((guile (guile-for-build)))
	228	(gexp->derivation "guix-latest" builder
	229	#:modules '((guix build pull)
	230	(guix build utils)
	231
	232	;; Closure of (guix modules).
	233	(guix modules)
	234	(guix memoization)
	235	(guix sets))
	236
	237	;; Arrange so that our own (guix build …) modules are
	238	;; used.
	239	#:module-path (list (top-source-directory))
f81ac34d	240
838ba73d	241	#:guile-for-build guile)))
f81ac34d LC	242
	243	;; This file is loaded by 'guix pull'; return it the build procedure.
	244	build
	245
	246	;; Local Variables:
	247	;; eval: (put 'with-load-path 'scheme-indent-function 1)
	248	;; End:
	249
	250	;;; build-self.scm ends here