guix/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
   4 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix gexp)
  22   #:use-module (guix store)
  23   #:use-module (guix monads)
  24   #:use-module (guix derivations)
  25   #:use-module (guix grafts)
  26   #:use-module (guix utils)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-9)
  30   #:use-module (srfi srfi-9 gnu)
  31   #:use-module (srfi srfi-26)
  32   #:use-module (srfi srfi-34)
  33   #:use-module (srfi srfi-35)
  34   #:use-module (ice-9 match)
  35   #:export (gexp
  36             gexp?
  37             with-imported-modules
  38             with-extensions
  39
  40             gexp-input
  41             gexp-input?
  42
  43             local-file
  44             local-file?
  45             local-file-file
  46             local-file-absolute-file-name
  47             local-file-name
  48             local-file-recursive?
  49
  50             plain-file
  51             plain-file?
  52             plain-file-name
  53             plain-file-content
  54
  55             computed-file
  56             computed-file?
  57             computed-file-name
  58             computed-file-gexp
  59             computed-file-options
  60
  61             program-file
  62             program-file?
  63             program-file-name
  64             program-file-gexp
  65             program-file-guile
  66             program-file-module-path
  67
  68             scheme-file
  69             scheme-file?
  70             scheme-file-name
  71             scheme-file-gexp
  72
  73             file-append
  74             file-append?
  75             file-append-base
  76             file-append-suffix
  77
  78             load-path-expression
  79             gexp-modules
  80
  81             gexp->derivation
  82             gexp->file
  83             gexp->script
  84             text-file*
  85             mixed-text-file
  86             file-union
  87             directory-union
  88             imported-files
  89             imported-modules
  90             compiled-modules
  91
  92             define-gexp-compiler
  93             gexp-compiler?
  94             file-like?
  95             lower-object
  96
  97             lower-inputs
  98
  99             &gexp-error
 100             gexp-error?
 101             &gexp-input-error
 102             gexp-input-error?
 103             gexp-error-invalid-input))
 104
 105 ;;; Commentary:
 106 ;;;
 107 ;;; This module implements "G-expressions", or "gexps".  Gexps are like
 108 ;;; S-expressions (sexps), with two differences:
 109 ;;;
 110 ;;;   1. References (un-quotations) to derivations or packages in a gexp are
 111 ;;;      replaced by the corresponding output file name; in addition, the
 112 ;;;      'ungexp-native' unquote-like form allows code to explicitly refer to
 113 ;;;      the native code of a given package, in case of cross-compilation;
 114 ;;;
 115 ;;;   2. Gexps embed information about the derivations they refer to.
 116 ;;;
 117 ;;; Gexps make it easy to write to files Scheme code that refers to store
 118 ;;; items, or to write Scheme code to build derivations.
 119 ;;;
 120 ;;; Code:
 121
 122 ;; "G expressions".
 123 (define-record-type <gexp>
 124   (make-gexp references modules extensions proc)
 125   gexp?
 126   (references gexp-references)                    ;list of <gexp-input>
 127   (modules    gexp-self-modules)                  ;list of module names
 128   (extensions gexp-self-extensions)               ;list of lowerable things
 129   (proc       gexp-proc))                         ;procedure
 130
 131 (define (write-gexp gexp port)
 132   "Write GEXP on PORT."
 133   (display "#<gexp " port)
 134
 135   ;; Try to write the underlying sexp.  Now, this trick doesn't work when
 136   ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
 137   ;; tries to use 'append' on that, which fails with wrong-type-arg.
 138   (false-if-exception
 139    (write (apply (gexp-proc gexp)
 140                  (gexp-references gexp))
 141           port))
 142   (format port " ~a>"
 143           (number->string (object-address gexp) 16)))
 144
 145 (set-record-type-printer! <gexp> write-gexp)
 146
 147 \f
 148 ;;;
 149 ;;; Methods.
 150 ;;;
 151
 152 ;; Compiler for a type of objects that may be introduced in a gexp.
 153 (define-record-type <gexp-compiler>
 154   (gexp-compiler type lower expand)
 155   gexp-compiler?
 156   (type       gexp-compiler-type)                 ;record type descriptor
 157   (lower      gexp-compiler-lower)
 158   (expand     gexp-compiler-expand))              ;#f | DRV -> sexp
 159
 160 (define-condition-type &gexp-error &error
 161   gexp-error?)
 162
 163 (define-condition-type &gexp-input-error &gexp-error
 164   gexp-input-error?
 165   (input gexp-error-invalid-input))
 166
 167
 168 (define %gexp-compilers
 169   ;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
 170   (make-hash-table 20))
 171
 172 (define (default-expander thing obj output)
 173   "This is the default expander for \"things\" that appear in gexps.  It
 174 returns its output file name of OBJ's OUTPUT."
 175   (match obj
 176     ((? derivation? drv)
 177      (derivation->output-path drv output))
 178     ((? string? file)
 179      file)))
 180
 181 (define (register-compiler! compiler)
 182   "Register COMPILER as a gexp compiler."
 183   (hashq-set! %gexp-compilers
 184               (gexp-compiler-type compiler) compiler))
 185
 186 (define (lookup-compiler object)
 187   "Search for a compiler for OBJECT.  Upon success, return the three argument
 188 procedure to lower it; otherwise return #f."
 189   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
 190          gexp-compiler-lower))
 191
 192 (define (file-like? object)
 193   "Return #t if OBJECT leads to a file in the store once unquoted in a
 194 G-expression; otherwise return #f."
 195   (and (struct? object) (->bool (lookup-compiler object))))
 196
 197 (define (lookup-expander object)
 198   "Search for an expander for OBJECT.  Upon success, return the three argument
 199 procedure to expand it; otherwise return #f."
 200   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
 201          gexp-compiler-expand))
 202
 203 (define* (lower-object obj
 204                        #:optional (system (%current-system))
 205                        #:key target)
 206   "Return as a value in %STORE-MONAD the derivation or store item
 207 corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
 208 OBJ must be an object that has an associated gexp compiler, such as a
 209 <package>."
 210   (match (lookup-compiler obj)
 211     (#f
 212      (raise (condition (&gexp-input-error (input obj)))))
 213     (lower
 214      (lower obj system target))))
 215
 216 (define-syntax define-gexp-compiler
 217   (syntax-rules (=> compiler expander)
 218     "Define NAME as a compiler for objects matching PREDICATE encountered in
 219 gexps.
 220
 221 In the simplest form of the macro, BODY must return a derivation for PARAM, an
 222 object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
 223 #f except when cross-compiling.)
 224
 225 The more elaborate form allows you to specify an expander:
 226
 227   (define-gexp-compiler something something?
 228     compiler => (lambda (param system target) ...)
 229     expander => (lambda (param drv output) ...))
 230
 231 The expander specifies how an object is converted to its sexp representation."
 232     ((_ (name (param record-type) system target) body ...)
 233      (define-gexp-compiler name record-type
 234        compiler => (lambda (param system target) body ...)
 235        expander => default-expander))
 236     ((_ name record-type
 237         compiler => compile
 238         expander => expand)
 239      (begin
 240        (define name
 241          (gexp-compiler record-type compile expand))
 242        (register-compiler! name)))))
 243
 244 (define-gexp-compiler (derivation-compiler (drv <derivation>) system target)
 245   ;; Derivations are the lowest-level representation, so this is the identity
 246   ;; compiler.
 247   (with-monad %store-monad
 248     (return drv)))
 249
 250 \f
 251 ;;;
 252 ;;; File declarations.
 253 ;;;
 254
 255 ;; A local file name.  FILE is the file name the user entered, which can be a
 256 ;; relative file name, and ABSOLUTE is a promise that computes its canonical
 257 ;; absolute file name.  We keep it in a promise to compute it lazily and avoid
 258 ;; repeated 'stat' calls.
 259 (define-record-type <local-file>
 260   (%%local-file file absolute name recursive? select?)
 261   local-file?
 262   (file       local-file-file)                    ;string
 263   (absolute   %local-file-absolute-file-name)     ;promise string
 264   (name       local-file-name)                    ;string
 265   (recursive? local-file-recursive?)              ;Boolean
 266   (select?    local-file-select?))                ;string stat -> Boolean
 267
 268 (define (true file stat) #t)
 269
 270 (define* (%local-file file promise #:optional (name (basename file))
 271                       #:key recursive? (select? true))
 272   ;; This intermediate procedure is part of our ABI, but the underlying
 273   ;; %%LOCAL-FILE is not.
 274   (%%local-file file promise name recursive? select?))
 275
 276 (define (absolute-file-name file directory)
 277   "Return the canonical absolute file name for FILE, which lives in the
 278 vicinity of DIRECTORY."
 279   (canonicalize-path
 280    (cond ((string-prefix? "/" file) file)
 281          ((not directory) file)
 282          ((string-prefix? "/" directory)
 283           (string-append directory "/" file))
 284          (else file))))
 285
 286 (define-syntax local-file
 287   (lambda (s)
 288     "Return an object representing local file FILE to add to the store; this
 289 object can be used in a gexp.  If FILE is a relative file name, it is looked
 290 up relative to the source file where this form appears.  FILE will be added to
 291 the store under NAME--by default the base name of FILE.
 292
 293 When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
 294 designates a flat file and RECURSIVE? is true, its contents are added, and its
 295 permission bits are kept.
 296
 297 When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
 298 where FILE is the entry's absolute file name and STAT is the result of
 299 'lstat'; exclude entries for which SELECT? does not return true.
 300
 301 This is the declarative counterpart of the 'interned-file' monadic procedure.
 302 It is implemented as a macro to capture the current source directory where it
 303 appears."
 304     (syntax-case s ()
 305       ((_ file rest ...)
 306        #'(%local-file file
 307                       (delay (absolute-file-name file (current-source-directory)))
 308                       rest ...))
 309       ((_)
 310        #'(syntax-error "missing file name"))
 311       (id
 312        (identifier? #'id)
 313        ;; XXX: We could return #'(lambda (file . rest) ...).  However,
 314        ;; (syntax-source #'id) is #f so (current-source-directory) would not
 315        ;; work.  Thus, simply forbid this form.
 316        #'(syntax-error
 317           "'local-file' is a macro and cannot be used like this")))))
 318
 319 (define (local-file-absolute-file-name file)
 320   "Return the absolute file name for FILE, a <local-file> instance.  A
 321 'system-error' exception is raised if FILE could not be found."
 322   (force (%local-file-absolute-file-name file)))
 323
 324 (define-gexp-compiler (local-file-compiler (file <local-file>) system target)
 325   ;; "Compile" FILE by adding it to the store.
 326   (match file
 327     (($ <local-file> file (= force absolute) name recursive? select?)
 328      ;; Canonicalize FILE so that if it's a symlink, it is resolved.  Failing
 329      ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling
 330      ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would
 331      ;; just throw an error, both of which are inconvenient.
 332      (interned-file absolute name
 333                     #:recursive? recursive? #:select? select?))))
 334
 335 (define-record-type <plain-file>
 336   (%plain-file name content references)
 337   plain-file?
 338   (name        plain-file-name)                   ;string
 339   (content     plain-file-content)                ;string or bytevector
 340   (references  plain-file-references))            ;list (currently unused)
 341
 342 (define (plain-file name content)
 343   "Return an object representing a text file called NAME with the given
 344 CONTENT (a string) to be added to the store.
 345
 346 This is the declarative counterpart of 'text-file'."
 347   ;; XXX: For now just ignore 'references' because it's not clear how to use
 348   ;; them in a declarative context.
 349   (%plain-file name content '()))
 350
 351 (define-gexp-compiler (plain-file-compiler (file <plain-file>) system target)
 352   ;; "Compile" FILE by adding it to the store.
 353   (match file
 354     (($ <plain-file> name (and (? string?) content) references)
 355      (text-file name content references))
 356     (($ <plain-file> name (and (? bytevector?) content) references)
 357      (binary-file name content references))))
 358
 359 (define-record-type <computed-file>
 360   (%computed-file name gexp guile options)
 361   computed-file?
 362   (name       computed-file-name)                 ;string
 363   (gexp       computed-file-gexp)                 ;gexp
 364   (guile      computed-file-guile)                ;<package>
 365   (options    computed-file-options))             ;list of arguments
 366
 367 (define* (computed-file name gexp
 368                         #:key guile (options '(#:local-build? #t)))
 369   "Return an object representing the store item NAME, a file or directory
 370 computed by GEXP.  OPTIONS is a list of additional arguments to pass
 371 to 'gexp->derivation'.
 372
 373 This is the declarative counterpart of 'gexp->derivation'."
 374   (%computed-file name gexp guile options))
 375
 376 (define-gexp-compiler (computed-file-compiler (file <computed-file>)
 377                                               system target)
 378   ;; Compile FILE by returning a derivation whose build expression is its
 379   ;; gexp.
 380   (match file
 381     (($ <computed-file> name gexp guile options)
 382      (if guile
 383          (mlet %store-monad ((guile (lower-object guile system
 384                                                   #:target target)))
 385            (apply gexp->derivation name gexp #:guile-for-build guile
 386                   options))
 387          (apply gexp->derivation name gexp options)))))
 388
 389 (define-record-type <program-file>
 390   (%program-file name gexp guile path)
 391   program-file?
 392   (name       program-file-name)                  ;string
 393   (gexp       program-file-gexp)                  ;gexp
 394   (guile      program-file-guile)                 ;package
 395   (path       program-file-module-path))          ;list of strings
 396
 397 (define* (program-file name gexp #:key (guile #f) (module-path %load-path))
 398   "Return an object representing the executable store item NAME that runs
 399 GEXP.  GUILE is the Guile package used to execute that script.  Imported
 400 modules of GEXP are looked up in MODULE-PATH.
 401
 402 This is the declarative counterpart of 'gexp->script'."
 403   (%program-file name gexp guile module-path))
 404
 405 (define-gexp-compiler (program-file-compiler (file <program-file>)
 406                                              system target)
 407   ;; Compile FILE by returning a derivation that builds the script.
 408   (match file
 409     (($ <program-file> name gexp guile module-path)
 410      (gexp->script name gexp
 411                    #:module-path module-path
 412                    #:guile (or guile (default-guile))))))
 413
 414 (define-record-type <scheme-file>
 415   (%scheme-file name gexp splice?)
 416   scheme-file?
 417   (name       scheme-file-name)                  ;string
 418   (gexp       scheme-file-gexp)                  ;gexp
 419   (splice?    scheme-file-splice?))              ;Boolean
 420
 421 (define* (scheme-file name gexp #:key splice?)
 422   "Return an object representing the Scheme file NAME that contains GEXP.
 423
 424 This is the declarative counterpart of 'gexp->file'."
 425   (%scheme-file name gexp splice?))
 426
 427 (define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
 428                                             system target)
 429   ;; Compile FILE by returning a derivation that builds the file.
 430   (match file
 431     (($ <scheme-file> name gexp splice?)
 432      (gexp->file name gexp #:splice? splice?))))
 433
 434 ;; Appending SUFFIX to BASE's output file name.
 435 (define-record-type <file-append>
 436   (%file-append base suffix)
 437   file-append?
 438   (base   file-append-base)                    ;<package> | <derivation> | ...
 439   (suffix file-append-suffix))                 ;list of strings
 440
 441 (define (write-file-append file port)
 442   (match file
 443     (($ <file-append> base suffix)
 444      (format port "#<file-append ~s ~s>" base
 445              (string-join suffix)))))
 446
 447 (set-record-type-printer! <file-append> write-file-append)
 448
 449 (define (file-append base . suffix)
 450   "Return a <file-append> object that expands to the concatenation of BASE and
 451 SUFFIX."
 452   (%file-append base suffix))
 453
 454 (define-gexp-compiler file-append-compiler <file-append>
 455   compiler => (lambda (obj system target)
 456                 (match obj
 457                   (($ <file-append> base _)
 458                    (lower-object base system #:target target))))
 459   expander => (lambda (obj lowered output)
 460                 (match obj
 461                   (($ <file-append> base suffix)
 462                    (let* ((expand (lookup-expander base))
 463                           (base   (expand base lowered output)))
 464                      (string-append base (string-concatenate suffix)))))))
 465
 466 \f
 467 ;;;
 468 ;;; Inputs & outputs.
 469 ;;;
 470
 471 ;; The input of a gexp.
 472 (define-record-type <gexp-input>
 473   (%gexp-input thing output native?)
 474   gexp-input?
 475   (thing     gexp-input-thing)       ;<package> | <origin> | <derivation> | ...
 476   (output    gexp-input-output)      ;string
 477   (native?   gexp-input-native?))    ;Boolean
 478
 479 (define (write-gexp-input input port)
 480   (match input
 481     (($ <gexp-input> thing output #f)
 482      (format port "#<gexp-input ~s:~a>" thing output))
 483     (($ <gexp-input> thing output #t)
 484      (format port "#<gexp-input native ~s:~a>" thing output))))
 485
 486 (set-record-type-printer! <gexp-input> write-gexp-input)
 487
 488 (define* (gexp-input thing                        ;convenience procedure
 489                      #:optional (output "out")
 490                      #:key native?)
 491   "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines
 492 whether this should be considered a \"native\" input or not."
 493   (%gexp-input thing output native?))
 494
 495 ;; Reference to one of the derivation's outputs, for gexps used in
 496 ;; derivations.
 497 (define-record-type <gexp-output>
 498   (gexp-output name)
 499   gexp-output?
 500   (name gexp-output-name))
 501
 502 (define (write-gexp-output output port)
 503   (match output
 504     (($ <gexp-output> name)
 505      (format port "#<gexp-output ~a>" name))))
 506
 507 (set-record-type-printer! <gexp-output> write-gexp-output)
 508
 509 (define* (gexp-attribute gexp self-attribute #:optional (equal? equal?))
 510   "Recurse on GEXP and the expressions it refers to, summing the items
 511 returned by SELF-ATTRIBUTE, a procedure that takes a gexp.  Use EQUAL? as the
 512 second argument to 'delete-duplicates'."
 513   (if (gexp? gexp)
 514       (delete-duplicates
 515        (append (self-attribute gexp)
 516                (append-map (match-lambda
 517                              (($ <gexp-input> (? gexp? exp))
 518                               (gexp-attribute exp self-attribute))
 519                              (($ <gexp-input> (lst ...))
 520                               (append-map (lambda (item)
 521                                             (if (gexp? item)
 522                                                 (gexp-attribute item
 523                                                                 self-attribute)
 524                                                 '()))
 525                                           lst))
 526                              (_
 527                               '()))
 528                            (gexp-references gexp)))
 529        equal?)
 530       '()))                                       ;plain Scheme data type
 531
 532 (define (gexp-modules gexp)
 533   "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
 534 false, meaning that GEXP is a plain Scheme object, return the empty list."
 535   (define (module=? m1 m2)
 536     ;; Return #t when M1 equals M2.  Special-case '=>' specs because their
 537     ;; right-hand side may not be comparable with 'equal?': it's typically a
 538     ;; file-like object that embeds a gexp, which in turn embeds closure;
 539     ;; those closures may be 'eq?' when running compiled code but are unlikely
 540     ;; to be 'eq?' when running on 'eval'.  Ignore the right-hand side to
 541     ;; avoid this discrepancy.
 542     (match m1
 543       (((name1 ...) '=> _)
 544        (match m2
 545          (((name2 ...) '=> _) (equal? name1 name2))
 546          (_ #f)))
 547       (_
 548        (equal? m1 m2))))
 549
 550   (gexp-attribute gexp gexp-self-modules module=?))
 551
 552 (define (gexp-extensions gexp)
 553   "Return the list of Guile extensions (packages) GEXP relies on.  If (gexp?
 554 GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
 555 list."
 556   (gexp-attribute gexp gexp-self-extensions))
 557
 558 (define* (lower-inputs inputs
 559                        #:key system target)
 560   "Turn any package from INPUTS into a derivation for SYSTEM; return the
 561 corresponding input list as a monadic value.  When TARGET is true, use it as
 562 the cross-compilation target triplet."
 563   (with-monad %store-monad
 564     (sequence %store-monad
 565               (map (match-lambda
 566                      (((? struct? thing) sub-drv ...)
 567                       (mlet %store-monad ((drv (lower-object
 568                                                 thing system #:target target)))
 569                         (return `(,drv ,@sub-drv))))
 570                      (input
 571                       (return input)))
 572                    inputs))))
 573
 574 (define* (lower-reference-graphs graphs #:key system target)
 575   "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
 576 #:reference-graphs argument, lower it such that each INPUT is replaced by the
 577 corresponding derivation."
 578   (match graphs
 579     (((file-names . inputs) ...)
 580      (mlet %store-monad ((inputs (lower-inputs inputs
 581                                                #:system system
 582                                                #:target target)))
 583        (return (map cons file-names inputs))))))
 584
 585 (define* (lower-references lst #:key system target)
 586   "Based on LST, a list of output names and packages, return a list of output
 587 names and file names suitable for the #:allowed-references argument to
 588 'derivation'."
 589   (with-monad %store-monad
 590     (define lower
 591       (match-lambda
 592        ((? string? output)
 593         (return output))
 594        (($ <gexp-input> thing output native?)
 595         (mlet %store-monad ((drv (lower-object thing system
 596                                                #:target (if native?
 597                                                             #f target))))
 598           (return (derivation->output-path drv output))))
 599        (thing
 600         (mlet %store-monad ((drv (lower-object thing system
 601                                                #:target target)))
 602           (return (derivation->output-path drv))))))
 603
 604     (sequence %store-monad (map lower lst))))
 605
 606 (define default-guile-derivation
 607   ;; Here we break the abstraction by talking to the higher-level layer.
 608   ;; Thus, do the resolution lazily to hide the circular dependency.
 609   (let ((proc (delay
 610                 (let ((iface (resolve-interface '(guix packages))))
 611                   (module-ref iface 'default-guile-derivation)))))
 612     (lambda (system)
 613       ((force proc) system))))
 614
 615 (define* (gexp->derivation name exp
 616                            #:key
 617                            system (target 'current)
 618                            hash hash-algo recursive?
 619                            (env-vars '())
 620                            (modules '())
 621                            (module-path %load-path)
 622                            (guile-for-build (%guile-for-build))
 623                            (effective-version "2.2")
 624                            (graft? (%graft?))
 625                            references-graphs
 626                            allowed-references disallowed-references
 627                            leaked-env-vars
 628                            local-build? (substitutable? #t)
 629
 630                            ;; TODO: This parameter is transitional; it's here
 631                            ;; to avoid a full rebuild.  Remove it on the next
 632                            ;; rebuild cycle.
 633                            import-creates-derivation?
 634
 635                            deprecation-warnings
 636                            (script-name (string-append name "-builder")))
 637   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
 638 derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME.  When
 639 TARGET is true, it is used as the cross-compilation target triplet for
 640 packages referred to by EXP.
 641
 642 MODULES is deprecated in favor of 'with-imported-modules'.  Its meaning is to
 643 make MODULES available in the evaluation context of EXP; MODULES is a list of
 644 names of Guile modules searched in MODULE-PATH to be copied in the store,
 645 compiled, and made available in the load path during the execution of
 646 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 647
 648 EFFECTIVE-VERSION determines the string to use when adding extensions of
 649 EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
 650
 651 GRAFT? determines whether packages referred to by EXP should be grafted when
 652 applicable.
 653
 654 When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
 655 following forms:
 656
 657   (FILE-NAME PACKAGE)
 658   (FILE-NAME PACKAGE OUTPUT)
 659   (FILE-NAME DERIVATION)
 660   (FILE-NAME DERIVATION OUTPUT)
 661   (FILE-NAME STORE-ITEM)
 662
 663 The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
 664 an input of the build process of EXP.  In the build environment, each
 665 FILE-NAME contains the reference graph of the corresponding item, in a simple
 666 text format.
 667
 668 ALLOWED-REFERENCES must be either #f or a list of output names and packages.
 669 In the latter case, the list denotes store items that the result is allowed to
 670 refer to.  Any reference to another store item will lead to a build error.
 671 Similarly for DISALLOWED-REFERENCES, which can list items that must not be
 672 referenced by the outputs.
 673
 674 DEPRECATION-WARNINGS determines whether to show deprecation warnings while
 675 compiling modules.  It can be #f, #t, or 'detailed.
 676
 677 The other arguments are as for 'derivation'."
 678   (define %modules
 679     (delete-duplicates
 680      (append modules (gexp-modules exp))))
 681   (define outputs (gexp-outputs exp))
 682
 683   (define (graphs-file-names graphs)
 684     ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
 685     (map (match-lambda
 686            ;; TODO: Remove 'derivation?' special cases.
 687            ((file-name (? derivation? drv))
 688             (cons file-name (derivation->output-path drv)))
 689            ((file-name (? derivation? drv) sub-drv)
 690             (cons file-name (derivation->output-path drv sub-drv)))
 691            ((file-name thing)
 692             (cons file-name thing)))
 693          graphs))
 694
 695   (define (extension-flags extension)
 696     `("-L" ,(string-append (derivation->output-path extension)
 697                            "/share/guile/site/" effective-version)
 698       "-C" ,(string-append (derivation->output-path extension)
 699                            "/lib/guile/" effective-version "/site-ccache")))
 700
 701   (mlet* %store-monad ( ;; The following binding forces '%current-system' and
 702                        ;; '%current-target-system' to be looked up at >>=
 703                        ;; time.
 704                        (graft?    (set-grafting graft?))
 705
 706                        (system -> (or system (%current-system)))
 707                        (target -> (if (eq? target 'current)
 708                                       (%current-target-system)
 709                                       target))
 710                        (normals  (lower-inputs (gexp-inputs exp)
 711                                                #:system system
 712                                                #:target target))
 713                        (natives  (lower-inputs (gexp-native-inputs exp)
 714                                                #:system system
 715                                                #:target #f))
 716                        (inputs -> (append normals natives))
 717                        (sexp     (gexp->sexp exp
 718                                              #:system system
 719                                              #:target target))
 720                        (builder  (text-file script-name
 721                                             (object->string sexp)))
 722                        (extensions -> (gexp-extensions exp))
 723                        (exts     (mapm %store-monad
 724                                        (lambda (obj)
 725                                          (lower-object obj system))
 726                                        extensions))
 727                        (modules  (if (pair? %modules)
 728                                      (imported-modules %modules
 729                                                        #:derivation?
 730                                                        import-creates-derivation?
 731                                                        #:system system
 732                                                        #:module-path module-path
 733                                                        #:guile guile-for-build
 734                                                        #:deprecation-warnings
 735                                                        deprecation-warnings)
 736                                      (return #f)))
 737                        (compiled (if (pair? %modules)
 738                                      (compiled-modules %modules
 739                                                        #:derivation?
 740                                                        import-creates-derivation?
 741                                                        #:system system
 742                                                        #:module-path module-path
 743                                                        #:extensions extensions
 744                                                        #:guile guile-for-build
 745                                                        #:deprecation-warnings
 746                                                        deprecation-warnings)
 747                                      (return #f)))
 748                        (graphs   (if references-graphs
 749                                      (lower-reference-graphs references-graphs
 750                                                              #:system system
 751                                                              #:target target)
 752                                      (return #f)))
 753                        (allowed  (if allowed-references
 754                                      (lower-references allowed-references
 755                                                        #:system system
 756                                                        #:target target)
 757                                      (return #f)))
 758                        (disallowed (if disallowed-references
 759                                        (lower-references disallowed-references
 760                                                          #:system system
 761                                                          #:target target)
 762                                        (return #f)))
 763                        (guile    (if guile-for-build
 764                                      (return guile-for-build)
 765                                      (default-guile-derivation system))))
 766     (mbegin %store-monad
 767       (set-grafting graft?)                       ;restore the initial setting
 768       (raw-derivation name
 769                       (string-append (derivation->output-path guile)
 770                                      "/bin/guile")
 771                       `("--no-auto-compile"
 772                         ,@(if (pair? %modules)
 773                               `("-L" ,(if (derivation? modules)
 774                                           (derivation->output-path modules)
 775                                           modules)
 776                                 "-C" ,(derivation->output-path compiled))
 777                               '())
 778                         ,@(append-map extension-flags exts)
 779                         ,builder)
 780                       #:outputs outputs
 781                       #:env-vars env-vars
 782                       #:system system
 783                       #:inputs `((,guile)
 784                                  (,builder)
 785                                  ,@(if modules
 786                                        `((,modules) (,compiled) ,@inputs)
 787                                        inputs)
 788                                  ,@(map list exts)
 789                                  ,@(match graphs
 790                                      (((_ . inputs) ...) inputs)
 791                                      (_ '())))
 792                       #:hash hash #:hash-algo hash-algo #:recursive? recursive?
 793                       #:references-graphs (and=> graphs graphs-file-names)
 794                       #:allowed-references allowed
 795                       #:disallowed-references disallowed
 796                       #:leaked-env-vars leaked-env-vars
 797                       #:local-build? local-build?
 798                       #:substitutable? substitutable?))))
 799
 800 (define* (gexp-inputs exp #:key native?)
 801   "Return the input list for EXP.  When NATIVE? is true, return only native
 802 references; otherwise, return only non-native references."
 803   (define (add-reference-inputs ref result)
 804     (match ref
 805       (($ <gexp-input> (? gexp? exp) _ #t)
 806        (if native?
 807            (append (gexp-inputs exp)
 808                    (gexp-inputs exp #:native? #t)
 809                    result)
 810            result))
 811       (($ <gexp-input> (? gexp? exp) _ #f)
 812        (append (gexp-inputs exp #:native? native?)
 813                result))
 814       (($ <gexp-input> (? string? str))
 815        (if (direct-store-path? str)
 816            (cons `(,str) result)
 817            result))
 818       (($ <gexp-input> (? struct? thing) output n?)
 819        (if (and (eqv? n? native?) (lookup-compiler thing))
 820            ;; THING is a derivation, or a package, or an origin, etc.
 821            (cons `(,thing ,output) result)
 822            result))
 823       (($ <gexp-input> (lst ...) output n?)
 824        (fold-right add-reference-inputs result
 825                    ;; XXX: For now, automatically convert LST to a list of
 826                    ;; gexp-inputs.  Inherit N?.
 827                    (map (match-lambda
 828                           ((? gexp-input? x)
 829                            (%gexp-input (gexp-input-thing x)
 830                                         (gexp-input-output x)
 831                                         n?))
 832                           (x
 833                            (%gexp-input x "out" n?)))
 834                         lst)))
 835       (_
 836        ;; Ignore references to other kinds of objects.
 837        result)))
 838
 839   (fold-right add-reference-inputs
 840               '()
 841               (gexp-references exp)))
 842
 843 (define gexp-native-inputs
 844   (cut gexp-inputs <> #:native? #t))
 845
 846 (define (gexp-outputs exp)
 847   "Return the outputs referred to by EXP as a list of strings."
 848   (define (add-reference-output ref result)
 849     (match ref
 850       (($ <gexp-output> name)
 851        (cons name result))
 852       (($ <gexp-input> (? gexp? exp))
 853        (append (gexp-outputs exp) result))
 854       (($ <gexp-input> (lst ...) output native?)
 855        ;; XXX: Automatically convert LST.
 856        (add-reference-output (map (match-lambda
 857                                    ((? gexp-input? x) x)
 858                                    (x (%gexp-input x "out" native?)))
 859                                   lst)
 860                              result))
 861       ((lst ...)
 862        (fold-right add-reference-output result lst))
 863       (_
 864        result)))
 865
 866   (delete-duplicates
 867    (add-reference-output (gexp-references exp) '())))
 868
 869 (define* (gexp->sexp exp #:key
 870                      (system (%current-system))
 871                      (target (%current-target-system)))
 872   "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
 873 and in the current monad setting (system type, etc.)"
 874   (define* (reference->sexp ref #:optional native?)
 875     (with-monad %store-monad
 876       (match ref
 877         (($ <gexp-output> output)
 878          ;; Output file names are not known in advance but the daemon defines
 879          ;; an environment variable for each of them at build time, so use
 880          ;; that trick.
 881          (return `((@ (guile) getenv) ,output)))
 882         (($ <gexp-input> (? gexp? exp) output n?)
 883          (gexp->sexp exp
 884                      #:system system
 885                      #:target (if (or n? native?) #f target)))
 886         (($ <gexp-input> (refs ...) output n?)
 887          (sequence %store-monad
 888                    (map (lambda (ref)
 889                           ;; XXX: Automatically convert REF to an gexp-input.
 890                           (reference->sexp
 891                            (if (gexp-input? ref)
 892                                ref
 893                                (%gexp-input ref "out" n?))
 894                            (or n? native?)))
 895                         refs)))
 896         (($ <gexp-input> (? struct? thing) output n?)
 897          (let ((target (if (or n? native?) #f target))
 898                (expand (lookup-expander thing)))
 899            (mlet %store-monad ((obj (lower-object thing system
 900                                                   #:target target)))
 901              ;; OBJ must be either a derivation or a store file name.
 902              (return (expand thing obj output)))))
 903         (($ <gexp-input> x)
 904          (return x))
 905         (x
 906          (return x)))))
 907
 908   (mlet %store-monad
 909       ((args (sequence %store-monad
 910                        (map reference->sexp (gexp-references exp)))))
 911     (return (apply (gexp-proc exp) args))))
 912
 913 (define (syntax-location-string s)
 914   "Return a string representing the source code location of S."
 915   (let ((props (syntax-source s)))
 916     (if props
 917         (let ((file   (assoc-ref props 'filename))
 918               (line   (and=> (assoc-ref props 'line) 1+))
 919               (column (assoc-ref props 'column)))
 920           (if file
 921               (simple-format #f "~a:~a:~a"
 922                              file line column)
 923               (simple-format #f "~a:~a" line column)))
 924         "<unknown location>")))
 925
 926 (define-syntax-parameter current-imported-modules
 927   ;; Current list of imported modules.
 928   (identifier-syntax '()))
 929
 930 (define-syntax-rule (with-imported-modules modules body ...)
 931   "Mark the gexps defined in BODY... as requiring MODULES in their execution
 932 environment."
 933   (syntax-parameterize ((current-imported-modules
 934                          (identifier-syntax modules)))
 935     body ...))
 936
 937 (define-syntax-parameter current-imported-extensions
 938   ;; Current list of extensions.
 939   (identifier-syntax '()))
 940
 941 (define-syntax-rule (with-extensions extensions body ...)
 942   "Mark the gexps defined in BODY... as requiring EXTENSIONS in their
 943 execution environment."
 944   (syntax-parameterize ((current-imported-extensions
 945                          (identifier-syntax extensions)))
 946     body ...))
 947
 948 (define-syntax gexp
 949   (lambda (s)
 950     (define (collect-escapes exp)
 951       ;; Return all the 'ungexp' present in EXP.
 952       (let loop ((exp    exp)
 953                  (result '()))
 954         (syntax-case exp (ungexp
 955                           ungexp-splicing
 956                           ungexp-native
 957                           ungexp-native-splicing)
 958           ((ungexp _)
 959            (cons exp result))
 960           ((ungexp _ _)
 961            (cons exp result))
 962           ((ungexp-splicing _ ...)
 963            (cons exp result))
 964           ((ungexp-native _ ...)
 965            (cons exp result))
 966           ((ungexp-native-splicing _ ...)
 967            (cons exp result))
 968           ((exp0 . exp)
 969            (let ((result (loop #'exp0 result)))
 970              (loop  #'exp result)))
 971           (_
 972            result))))
 973
 974     (define (escape->ref exp)
 975       ;; Turn 'ungexp' form EXP into a "reference".
 976       (syntax-case exp (ungexp ungexp-splicing
 977                         ungexp-native ungexp-native-splicing
 978                         output)
 979         ((ungexp output)
 980          #'(gexp-output "out"))
 981         ((ungexp output name)
 982          #'(gexp-output name))
 983         ((ungexp thing)
 984          #'(%gexp-input thing "out" #f))
 985         ((ungexp drv-or-pkg out)
 986          #'(%gexp-input drv-or-pkg out #f))
 987         ((ungexp-splicing lst)
 988          #'(%gexp-input lst "out" #f))
 989         ((ungexp-native thing)
 990          #'(%gexp-input thing "out" #t))
 991         ((ungexp-native drv-or-pkg out)
 992          #'(%gexp-input drv-or-pkg out #t))
 993         ((ungexp-native-splicing lst)
 994          #'(%gexp-input lst "out" #t))))
 995
 996     (define (substitute-ungexp exp substs)
 997       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
 998       ;; the corresponding form in SUBSTS.
 999       (match (assoc exp substs)
1000         ((_ id)
1001          id)
1002         (_                                        ;internal error
1003          (with-syntax ((exp exp))
1004            #'(syntax-error "error: no 'ungexp' substitution" exp)))))
1005
1006     (define (substitute-ungexp-splicing exp substs)
1007       (syntax-case exp ()
1008         ((exp rest ...)
1009          (match (assoc #'exp substs)
1010            ((_ id)
1011             (with-syntax ((id id))
1012               #`(append id
1013                         #,(substitute-references #'(rest ...) substs))))
1014            (_
1015             #'(syntax-error "error: no 'ungexp-splicing' substitution"
1016                             exp))))))
1017
1018     (define (substitute-references exp substs)
1019       ;; Return a variant of EXP where all the cars of SUBSTS have been
1020       ;; replaced by the corresponding cdr.
1021       (syntax-case exp (ungexp ungexp-native
1022                         ungexp-splicing ungexp-native-splicing)
1023         ((ungexp _ ...)
1024          (substitute-ungexp exp substs))
1025         ((ungexp-native _ ...)
1026          (substitute-ungexp exp substs))
1027         (((ungexp-splicing _ ...) rest ...)
1028          (substitute-ungexp-splicing exp substs))
1029         (((ungexp-native-splicing _ ...) rest ...)
1030          (substitute-ungexp-splicing exp substs))
1031         ((exp0 . exp)
1032          #`(cons #,(substitute-references #'exp0 substs)
1033                  #,(substitute-references #'exp substs)))
1034         (x #''x)))
1035
1036     (syntax-case s (ungexp output)
1037       ((_ exp)
1038        (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
1039               (formals (generate-temporaries escapes))
1040               (sexp    (substitute-references #'exp (zip escapes formals)))
1041               (refs    (map escape->ref escapes)))
1042          #`(make-gexp (list #,@refs)
1043                       current-imported-modules
1044                       current-imported-extensions
1045                       (lambda #,formals
1046                         #,sexp)))))))
1047
1048 \f
1049 ;;;
1050 ;;; Module handling.
1051 ;;;
1052
1053 (define %not-slash
1054   (char-set-complement (char-set #\/)))
1055
1056 (define (file-mapping->tree mapping)
1057   "Convert MAPPING, an alist like:
1058
1059   ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
1060
1061 to a tree suitable for 'interned-file-tree'."
1062   (let ((mapping (map (match-lambda
1063                         ((destination . source)
1064                          (cons (string-tokenize destination
1065                                                 %not-slash)
1066                                source)))
1067                       mapping)))
1068     (fold (lambda (pair result)
1069             (match pair
1070               ((destination . source)
1071                (let loop ((destination destination)
1072                           (result result))
1073                  (match destination
1074                    ((file)
1075                     (let* ((mode (stat:mode (stat source)))
1076                            (type (if (zero? (logand mode #o100))
1077                                      'regular
1078                                      'executable)))
1079                       (alist-cons file
1080                                   `(,type (file ,source))
1081                                   result)))
1082                    ((file rest ...)
1083                     (let ((directory (assoc-ref result file)))
1084                       (alist-cons file
1085                                   `(directory
1086                                     ,@(loop rest
1087                                             (match directory
1088                                               (('directory . entries) entries)
1089                                               (#f '()))))
1090                                   (if directory
1091                                       (alist-delete file result)
1092                                       result)))))))))
1093           '()
1094           mapping)))
1095
1096 (define %utils-module
1097   ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
1098   ;; other primitives below.  Note: We give the file name relative to this
1099   ;; file you are currently reading; 'search-path' could return a file name
1100   ;; relative to the current working directory.
1101   (local-file "build/utils.scm"
1102               "build-utils.scm"))
1103
1104 (define* (imported-files/derivation files
1105                                     #:key (name "file-import")
1106                                     (symlink? #f)
1107                                     (system (%current-system))
1108                                     (guile (%guile-for-build))
1109
1110                                     ;; XXX: The only reason we have
1111                                     ;; #:deprecation-warnings is because (guix
1112                                     ;; build utils), which we use here, relies
1113                                     ;; on _IO*, which is deprecated in 2.2.  On
1114                                     ;; the next full-rebuild cycle, we should
1115                                     ;; disable such warnings unconditionally.
1116                                     (deprecation-warnings #f))
1117   "Return a derivation that imports FILES into STORE.  FILES must be a list
1118 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
1119 resulting store path.  FILE can be either a file name, or a file-like object,
1120 as returned by 'local-file' for example.  If SYMLINK? is true, create symlinks
1121 to the source files instead of copying them."
1122   (define file-pair
1123     (match-lambda
1124      ((final-path . (? string? file-name))
1125       (mlet %store-monad ((file (interned-file file-name
1126                                                (basename final-path))))
1127         (return (list final-path file))))
1128      ((final-path . file-like)
1129       (mlet %store-monad ((file (lower-object file-like system)))
1130         (return (list final-path file))))))
1131
1132   (mlet %store-monad ((files (sequence %store-monad
1133                                        (map file-pair files))))
1134     (define build
1135       (gexp
1136        (begin
1137          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
1138          (use-modules (ice-9 match))
1139
1140          (mkdir (ungexp output)) (chdir (ungexp output))
1141          (for-each (match-lambda
1142                     ((final-path store-path)
1143                      (mkdir-p (dirname final-path))
1144                      ((ungexp (if symlink? 'symlink 'copy-file))
1145                       store-path final-path)))
1146                    '(ungexp files)))))
1147
1148     ;; TODO: Pass FILES as an environment variable so that BUILD remains
1149     ;; exactly the same regardless of FILES: less disk space, and fewer
1150     ;; 'add-to-store' RPCs.
1151     (gexp->derivation name build
1152                       #:system system
1153                       #:guile-for-build guile
1154                       #:local-build? #t
1155
1156                       ;; TODO: On the next rebuild cycle, set to "no"
1157                       ;; unconditionally.
1158                       #:env-vars
1159                       (case deprecation-warnings
1160                         ((#f)
1161                          '(("GUILE_WARN_DEPRECATED" . "no")))
1162                         ((detailed)
1163                          '(("GUILE_WARN_DEPRECATED" . "detailed")))
1164                         (else
1165                          '())))))
1166
1167 (define* (imported-files files
1168                          #:key (name "file-import")
1169
1170                          ;; TODO: Remove this parameter on the next rebuild
1171                          ;; cycle.
1172                          (derivation? #f)
1173
1174                          ;; The following parameters make sense when creating
1175                          ;; an actual derivation.
1176                          (system (%current-system))
1177                          (guile (%guile-for-build))
1178                          (deprecation-warnings #f))
1179   "Import FILES into the store and return the resulting derivation or store
1180 file name (a derivation is created if and only if some elements of FILES are
1181 file-like objects and not local file names.)  FILES must be a list
1182 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
1183 resulting store path.  FILE can be either a file name, or a file-like object,
1184 as returned by 'local-file' for example."
1185   (if (or derivation?
1186           (any (match-lambda
1187                  ((_ . (? struct? source)) #t)
1188                  (_ #f))
1189                files))
1190       (imported-files/derivation files #:name name
1191                                  #:symlink? derivation?
1192                                  #:system system #:guile guile
1193                                  #:deprecation-warnings deprecation-warnings)
1194       (interned-file-tree `(,name directory
1195                                   ,@(file-mapping->tree files)))))
1196
1197 (define* (imported-modules modules
1198                            #:key (name "module-import")
1199                            (derivation? #f)      ;TODO: remove on next rebuild
1200                            (system (%current-system))
1201                            (guile (%guile-for-build))
1202                            (module-path %load-path)
1203                            (deprecation-warnings #f))
1204   "Return a derivation that contains the source files of MODULES, a list of
1205 module names such as `(ice-9 q)'.  All of MODULES must be either names of
1206 modules to be found in the MODULE-PATH search path, or a module name followed
1207 by an arrow followed by a file-like object.  For example:
1208
1209   (imported-modules `((guix build utils)
1210                       (guix gcrypt)
1211                       ((guix config) => ,(scheme-file …))))
1212
1213 In this example, the first two modules are taken from MODULE-PATH, and the
1214 last one is created from the given <scheme-file> object."
1215   (let ((files (map (match-lambda
1216                       (((module ...) '=> file)
1217                        (cons (module->source-file-name module)
1218                              file))
1219                       ((module ...)
1220                        (let ((f (module->source-file-name module)))
1221                          (cons f (search-path* module-path f)))))
1222                     modules)))
1223     (imported-files files #:name name
1224                     #:derivation? derivation?
1225                     #:system system
1226                     #:guile guile
1227                     #:deprecation-warnings deprecation-warnings)))
1228
1229 (define* (compiled-modules modules
1230                            #:key (name "module-import-compiled")
1231                            (derivation? #f)      ;TODO: remove on next rebuild
1232                            (system (%current-system))
1233                            (guile (%guile-for-build))
1234                            (module-path %load-path)
1235                            (extensions '())
1236                            (deprecation-warnings #f))
1237   "Return a derivation that builds a tree containing the `.go' files
1238 corresponding to MODULES.  All the MODULES are built in a context where
1239 they can refer to each other."
1240   (define total (length modules))
1241
1242   (define build-utils-hack?
1243     ;; To avoid a full rebuild, we limit the fix below to the case where
1244     ;; MODULE-PATH is different from %LOAD-PATH.  This happens when building
1245     ;; modules for 'compute-guix-derivation' upon 'guix pull'.  TODO: Make
1246     ;; this unconditional on the next rebuild cycle.
1247     (and (member '(guix build utils) modules)
1248          (not (equal? module-path %load-path))))
1249
1250   (mlet %store-monad ((modules (imported-modules modules
1251                                                  #:derivation? derivation?
1252                                                  #:system system
1253                                                  #:guile guile
1254                                                  #:module-path
1255                                                  module-path
1256                                                  #:deprecation-warnings
1257                                                  deprecation-warnings)))
1258     (define build
1259       (gexp
1260        (begin
1261          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
1262
1263          (use-modules (ice-9 ftw)
1264                       (ice-9 format)
1265                       (srfi srfi-1)
1266                       (srfi srfi-26)
1267                       (system base compile))
1268
1269          (define (regular? file)
1270            (not (member file '("." ".."))))
1271
1272          (define (process-entry entry output processed)
1273            (if (file-is-directory? entry)
1274                (let ((output (string-append output "/" (basename entry))))
1275                  (mkdir-p output)
1276                  (process-directory entry output processed))
1277                (let* ((base   (basename entry ".scm"))
1278                       (output (string-append output "/" base ".go")))
1279                  (format #t "[~2@a/~2@a] Compiling '~a'...~%"
1280                          (+ 1 processed) (ungexp total) entry)
1281                  (compile-file entry
1282                                #:output-file output
1283                                #:opts %auto-compilation-options)
1284                  (+ 1 processed))))
1285
1286          (define (process-directory directory output processed)
1287            (let ((entries (map (cut string-append directory "/" <>)
1288                                (scandir directory regular?))))
1289              (fold (cut process-entry <> output <>)
1290                    processed
1291                    entries)))
1292
1293          (setvbuf (current-output-port)
1294                   (cond-expand (guile-2.2 'line) (else _IOLBF)))
1295
1296          (ungexp-splicing
1297           (if build-utils-hack?
1298               (gexp ((define mkdir-p
1299                        ;; Capture 'mkdir-p'.
1300                        (@ (guix build utils) mkdir-p))))
1301               '()))
1302
1303          ;; Add EXTENSIONS to the search path.
1304          ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle.
1305          (ungexp-splicing
1306           (if (null? extensions)
1307               '()
1308               (gexp ((set! %load-path
1309                        (append (map (lambda (extension)
1310                                       (string-append extension
1311                                                      "/share/guile/site/"
1312                                                      (effective-version)))
1313                                     '((ungexp-native-splicing extensions)))
1314                                %load-path))
1315                      (set! %load-compiled-path
1316                        (append (map (lambda (extension)
1317                                       (string-append extension "/lib/guile/"
1318                                                      (effective-version)
1319                                                      "/site-ccache"))
1320                                     '((ungexp-native-splicing extensions)))
1321                                %load-compiled-path))))))
1322
1323          (set! %load-path (cons (ungexp modules) %load-path))
1324
1325          (ungexp-splicing
1326           (if build-utils-hack?
1327               ;; Above we loaded our own (guix build utils) but now we may
1328               ;; need to load a compile a different one.  Thus, force a
1329               ;; reload.
1330               (gexp ((let ((utils (ungexp
1331                                    (file-append modules
1332                                                 "/guix/build/utils.scm"))))
1333                        (when (file-exists? utils)
1334                          (load utils)))))
1335               '()))
1336
1337          (mkdir (ungexp output))
1338          (chdir (ungexp modules))
1339          (process-directory "." (ungexp output) 0))))
1340
1341     ;; TODO: Pass MODULES as an environment variable.
1342     (gexp->derivation name build
1343                       #:system system
1344                       #:guile-for-build guile
1345                       #:local-build? #t
1346                       #:env-vars
1347                       (case deprecation-warnings
1348                         ((#f)
1349                          '(("GUILE_WARN_DEPRECATED" . "no")))
1350                         ((detailed)
1351                          '(("GUILE_WARN_DEPRECATED" . "detailed")))
1352                         (else
1353                          '())))))
1354
1355 \f
1356 ;;;
1357 ;;; Convenience procedures.
1358 ;;;
1359
1360 (define (default-guile)
1361   ;; Lazily resolve 'guile-2.2' (not 'guile-final' because this is for
1362   ;; programs returned by 'program-file' and we don't want to keep references
1363   ;; to several Guile packages).  This module must not refer to (gnu …)
1364   ;; modules directly, to avoid circular dependencies, hence this hack.
1365   (module-ref (resolve-interface '(gnu packages guile))
1366               'guile-2.2))
1367
1368 (define* (load-path-expression modules #:optional (path %load-path)
1369                                #:key (extensions '()))
1370   "Return as a monadic value a gexp that sets '%load-path' and
1371 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
1372 are searched for in PATH."
1373   (mlet %store-monad ((modules  (imported-modules modules
1374                                                   #:module-path path))
1375                       (compiled (compiled-modules modules
1376                                                   #:extensions extensions
1377                                                   #:module-path path)))
1378     (return (gexp (eval-when (expand load eval)
1379                     (set! %load-path
1380                       (cons (ungexp modules)
1381                             (append (map (lambda (extension)
1382                                            (string-append extension
1383                                                           "/share/guile/site/"
1384                                                           (effective-version)))
1385                                          '((ungexp-native-splicing extensions)))
1386                                     %load-path)))
1387                     (set! %load-compiled-path
1388                       (cons (ungexp compiled)
1389                             (append (map (lambda (extension)
1390                                            (string-append extension
1391                                                           "/lib/guile/"
1392                                                           (effective-version)
1393                                                           "/site-ccache"))
1394                                          '((ungexp-native-splicing extensions)))
1395                                     %load-compiled-path))))))))
1396
1397 (define* (gexp->script name exp
1398                        #:key (guile (default-guile))
1399                        (module-path %load-path))
1400   "Return an executable script NAME that runs EXP using GUILE, with EXP's
1401 imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
1402   (mlet %store-monad ((set-load-path
1403                        (load-path-expression (gexp-modules exp)
1404                                              module-path
1405                                              #:extensions
1406                                              (gexp-extensions exp))))
1407     (gexp->derivation name
1408                       (gexp
1409                        (call-with-output-file (ungexp output)
1410                          (lambda (port)
1411                            ;; Note: that makes a long shebang.  When the store
1412                            ;; is /gnu/store, that fits within the 128-byte
1413                            ;; limit imposed by Linux, but that may go beyond
1414                            ;; when running tests.
1415                            (format port
1416                                    "#!~a/bin/guile --no-auto-compile~%!#~%"
1417                                    (ungexp guile))
1418
1419                            (write '(ungexp set-load-path) port)
1420                            (write '(ungexp exp) port)
1421                            (chmod port #o555))))
1422                       #:module-path module-path)))
1423
1424 (define* (gexp->file name exp #:key
1425                      (set-load-path? #t)
1426                      (module-path %load-path)
1427                      (splice? #f))
1428   "Return a derivation that builds a file NAME containing EXP.  When SPLICE?
1429 is true, EXP is considered to be a list of expressions that will be spliced in
1430 the resulting file.
1431
1432 When SET-LOAD-PATH? is true, emit code in the resulting file to set
1433 '%load-path' and '%load-compiled-path' to honor EXP's imported modules.
1434 Lookup EXP's modules in MODULE-PATH."
1435   (define modules (gexp-modules exp))
1436   (define extensions (gexp-extensions exp))
1437
1438   (if (or (not set-load-path?)
1439           (and (null? modules) (null? extensions)))
1440       (gexp->derivation name
1441                         (gexp
1442                          (call-with-output-file (ungexp output)
1443                            (lambda (port)
1444                              (for-each (lambda (exp)
1445                                          (write exp port))
1446                                        '(ungexp (if splice?
1447                                                     exp
1448                                                     (gexp ((ungexp exp)))))))))
1449                         #:local-build? #t
1450                         #:substitutable? #f)
1451       (mlet %store-monad ((set-load-path
1452                            (load-path-expression modules module-path
1453                                                  #:extensions extensions)))
1454         (gexp->derivation name
1455                           (gexp
1456                            (call-with-output-file (ungexp output)
1457                              (lambda (port)
1458                                (write '(ungexp set-load-path) port)
1459                                (for-each (lambda (exp)
1460                                            (write exp port))
1461                                          '(ungexp (if splice?
1462                                                       exp
1463                                                       (gexp ((ungexp exp)))))))))
1464                           #:module-path module-path
1465                           #:local-build? #t
1466                           #:substitutable? #f))))
1467
1468 (define* (text-file* name #:rest text)
1469   "Return as a monadic value a derivation that builds a text file containing
1470 all of TEXT.  TEXT may list, in addition to strings, objects of any type that
1471 can be used in a gexp: packages, derivations, local file objects, etc.  The
1472 resulting store file holds references to all these."
1473   (define builder
1474     (gexp (call-with-output-file (ungexp output "out")
1475             (lambda (port)
1476               (display (string-append (ungexp-splicing text)) port)))))
1477
1478   (gexp->derivation name builder
1479                     #:local-build? #t
1480                     #:substitutable? #f))
1481
1482 (define* (mixed-text-file name #:rest text)
1483   "Return an object representing store file NAME containing TEXT.  TEXT is a
1484 sequence of strings and file-like objects, as in:
1485
1486   (mixed-text-file \"profile\"
1487                    \"export PATH=\" coreutils \"/bin:\" grep \"/bin\")
1488
1489 This is the declarative counterpart of 'text-file*'."
1490   (define build
1491     (gexp (call-with-output-file (ungexp output "out")
1492             (lambda (port)
1493               (display (string-append (ungexp-splicing text)) port)))))
1494
1495   (computed-file name build))
1496
1497 (define (file-union name files)
1498   "Return a <computed-file> that builds a directory containing all of FILES.
1499 Each item in FILES must be a two-element list where the first element is the
1500 file name to use in the new directory, and the second element is a gexp
1501 denoting the target file.  Here's an example:
1502
1503   (file-union \"etc\"
1504               `((\"hosts\" ,(plain-file \"hosts\"
1505                                         \"127.0.0.1 localhost\"))
1506                 (\"bashrc\" ,(plain-file \"bashrc\"
1507                                          \"alias ls='ls --color'\"))
1508                 (\"libvirt/qemu.conf\" ,(plain-file \"qemu.conf\" \"\"))))
1509
1510 This yields an 'etc' directory containing these two files."
1511   (computed-file name
1512                  (with-imported-modules '((guix build utils))
1513                    (gexp
1514                     (begin
1515                       (use-modules (guix build utils))
1516
1517                       (mkdir (ungexp output))
1518                       (chdir (ungexp output))
1519                       (ungexp-splicing
1520                        (map (match-lambda
1521                               ((target source)
1522                                (gexp
1523                                 (begin
1524                                   ;; Stat the source to abort early if it does
1525                                   ;; not exist.
1526                                   (stat (ungexp source))
1527
1528                                   (mkdir-p (dirname (ungexp target)))
1529                                   (symlink (ungexp source)
1530                                            (ungexp target))))))
1531                             files)))))))
1532
1533 (define* (directory-union name things
1534                           #:key (copy? #f) (quiet? #f)
1535                           (resolve-collision 'warn-about-collision))
1536   "Return a directory that is the union of THINGS, where THINGS is a list of
1537 file-like objects denoting directories.  For example:
1538
1539   (directory-union \"guile+emacs\" (list guile emacs))
1540
1541 yields a directory that is the union of the 'guile' and 'emacs' packages.
1542
1543 Call RESOLVE-COLLISION when several files collide, passing it the list of
1544 colliding files.  RESOLVE-COLLISION must return the chosen file or #f, in
1545 which case the colliding entry is skipped altogether.
1546
1547 When HARD-LINKS? is true, create hard links instead of symlinks.  When QUIET?
1548 is true, the derivation will not print anything."
1549   (define symlink
1550     (if copy?
1551         (gexp (lambda (old new)
1552                 (if (file-is-directory? old)
1553                     (symlink old new)
1554                     (copy-file old new))))
1555         (gexp symlink)))
1556
1557   (define log-port
1558     (if quiet?
1559         (gexp (%make-void-port "w"))
1560         (gexp (current-error-port))))
1561
1562   (match things
1563     ((one)
1564      ;; Only one thing; return it.
1565      one)
1566     (_
1567      (computed-file name
1568                     (with-imported-modules '((guix build union))
1569                       (gexp (begin
1570                               (use-modules (guix build union)
1571                                            (srfi srfi-1)) ;for 'first' and 'last'
1572
1573                               (union-build (ungexp output)
1574                                            '(ungexp things)
1575
1576                                            #:log-port (ungexp log-port)
1577                                            #:symlink (ungexp symlink)
1578                                            #:resolve-collision
1579                                            (ungexp resolve-collision)))))))))
1580
1581 \f
1582 ;;;
1583 ;;; Syntactic sugar.
1584 ;;;
1585
1586 (eval-when (expand load eval)
1587   (define* (read-ungexp chr port #:optional native?)
1588     "Read an 'ungexp' or 'ungexp-splicing' form from PORT.  When NATIVE? is
1589 true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
1590     (define unquote-symbol
1591       (match (peek-char port)
1592         (#\@
1593          (read-char port)
1594          (if native?
1595              'ungexp-native-splicing
1596              'ungexp-splicing))
1597         (_
1598          (if native?
1599              'ungexp-native
1600              'ungexp))))
1601
1602     (match (read port)
1603       ((? symbol? symbol)
1604        (let ((str (symbol->string symbol)))
1605          (match (string-index-right str #\:)
1606            (#f
1607             `(,unquote-symbol ,symbol))
1608            (colon
1609             (let ((name   (string->symbol (substring str 0 colon)))
1610                   (output (substring str (+ colon 1))))
1611               `(,unquote-symbol ,name ,output))))))
1612       (x
1613        `(,unquote-symbol ,x))))
1614
1615   (define (read-gexp chr port)
1616     "Read a 'gexp' form from PORT."
1617     `(gexp ,(read port)))
1618
1619   ;; Extend the reader
1620   (read-hash-extend #\~ read-gexp)
1621   (read-hash-extend #\$ read-ungexp)
1622   (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
1623
1624 ;;; gexp.scm ends here