guix/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   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 (guix gexp)
  20   #:use-module (guix store)
  21   #:use-module (guix monads)
  22   #:use-module (guix derivations)
  23   #:use-module (guix utils)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-9)
  26   #:use-module (srfi srfi-9 gnu)
  27   #:use-module (srfi srfi-26)
  28   #:use-module (ice-9 match)
  29   #:export (gexp
  30             gexp?
  31
  32             gexp-input
  33             gexp-input?
  34
  35             local-file
  36             local-file?
  37             local-file-file
  38             local-file-name
  39             local-file-recursive?
  40
  41             plain-file
  42             plain-file?
  43             plain-file-name
  44             plain-file-content
  45
  46             gexp->derivation
  47             gexp->file
  48             gexp->script
  49             text-file*
  50             imported-files
  51             imported-modules
  52             compiled-modules
  53
  54             define-gexp-compiler
  55             gexp-compiler?
  56             lower-object
  57
  58             lower-inputs))
  59
  60 ;;; Commentary:
  61 ;;;
  62 ;;; This module implements "G-expressions", or "gexps".  Gexps are like
  63 ;;; S-expressions (sexps), with two differences:
  64 ;;;
  65 ;;;   1. References (un-quotations) to derivations or packages in a gexp are
  66 ;;;      replaced by the corresponding output file name; in addition, the
  67 ;;;      'ungexp-native' unquote-like form allows code to explicitly refer to
  68 ;;;      the native code of a given package, in case of cross-compilation;
  69 ;;;
  70 ;;;   2. Gexps embed information about the derivations they refer to.
  71 ;;;
  72 ;;; Gexps make it easy to write to files Scheme code that refers to store
  73 ;;; items, or to write Scheme code to build derivations.
  74 ;;;
  75 ;;; Code:
  76
  77 ;; "G expressions".
  78 (define-record-type <gexp>
  79   (make-gexp references natives proc)
  80   gexp?
  81   (references gexp-references)                    ; ((DRV-OR-PKG OUTPUT) ...)
  82   (natives    gexp-native-references)             ; ((DRV-OR-PKG OUTPUT) ...)
  83   (proc       gexp-proc))                         ; procedure
  84
  85 (define (write-gexp gexp port)
  86   "Write GEXP on PORT."
  87   (display "#<gexp " port)
  88
  89   ;; Try to write the underlying sexp.  Now, this trick doesn't work when
  90   ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
  91   ;; tries to use 'append' on that, which fails with wrong-type-arg.
  92   (false-if-exception
  93    (write (apply (gexp-proc gexp)
  94                  (append (gexp-references gexp)
  95                          (gexp-native-references gexp)))
  96           port))
  97   (format port " ~a>"
  98           (number->string (object-address gexp) 16)))
  99
 100 (set-record-type-printer! <gexp> write-gexp)
 101
 102 \f
 103 ;;;
 104 ;;; Methods.
 105 ;;;
 106
 107 ;; Compiler for a type of objects that may be introduced in a gexp.
 108 (define-record-type <gexp-compiler>
 109   (gexp-compiler predicate lower)
 110   gexp-compiler?
 111   (predicate  gexp-compiler-predicate)
 112   (lower      gexp-compiler-lower))
 113
 114 (define %gexp-compilers
 115   ;; List of <gexp-compiler>.
 116   '())
 117
 118 (define (register-compiler! compiler)
 119   "Register COMPILER as a gexp compiler."
 120   (set! %gexp-compilers (cons compiler %gexp-compilers)))
 121
 122 (define (lookup-compiler object)
 123   "Search a compiler for OBJECT.  Upon success, return the three argument
 124 procedure to lower it; otherwise return #f."
 125   (any (match-lambda
 126         (($ <gexp-compiler> predicate lower)
 127          (and (predicate object) lower)))
 128        %gexp-compilers))
 129
 130 (define* (lower-object obj
 131                        #:optional (system (%current-system))
 132                        #:key target)
 133   "Return as a value in %STORE-MONAD the derivation or store item
 134 corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
 135 OBJ must be an object that has an associated gexp compiler, such as a
 136 <package>."
 137   (let ((lower (lookup-compiler obj)))
 138     (lower obj system target)))
 139
 140 (define-syntax-rule (define-gexp-compiler (name (param predicate)
 141                                                 system target)
 142                       body ...)
 143   "Define NAME as a compiler for objects matching PREDICATE encountered in
 144 gexps.  BODY must return a derivation for PARAM, an object that matches
 145 PREDICATE, for SYSTEM and TARGET (the latter of which is #f except when
 146 cross-compiling.)"
 147   (begin
 148     (define name
 149       (gexp-compiler predicate
 150                      (lambda (param system target)
 151                        body ...)))
 152     (register-compiler! name)))
 153
 154 (define-gexp-compiler (derivation-compiler (drv derivation?) system target)
 155   ;; Derivations are the lowest-level representation, so this is the identity
 156   ;; compiler.
 157   (with-monad %store-monad
 158     (return drv)))
 159
 160 \f
 161 ;;;
 162 ;;; File declarations.
 163 ;;;
 164
 165 (define-record-type <local-file>
 166   (%local-file file name recursive?)
 167   local-file?
 168   (file       local-file-file)                    ;string
 169   (name       local-file-name)                    ;string
 170   (recursive? local-file-recursive?))             ;Boolean
 171
 172 (define* (local-file file #:optional (name (basename file))
 173                      #:key recursive?)
 174   "Return an object representing local file FILE to add to the store; this
 175 object can be used in a gexp.  FILE will be added to the store under NAME--by
 176 default the base name of FILE.
 177
 178 When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
 179 designates a flat file and RECURSIVE? is true, its contents are added, and its
 180 permission bits are kept.
 181
 182 This is the declarative counterpart of the 'interned-file' monadic procedure."
 183   ;; Canonicalize FILE so that if it's a symlink, it is resolved.  Failing to
 184   ;; do that, when RECURSIVE? is #t, we could end up creating a dangling
 185   ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would just
 186   ;; throw an error, both of which are inconvenient.
 187   (%local-file (canonicalize-path file) name recursive?))
 188
 189 (define-gexp-compiler (local-file-compiler (file local-file?) system target)
 190   ;; "Compile" FILE by adding it to the store.
 191   (match file
 192     (($ <local-file> file name recursive?)
 193      (interned-file file name #:recursive? recursive?))))
 194
 195 (define-record-type <plain-file>
 196   (%plain-file name content references)
 197   plain-file?
 198   (name        plain-file-name)                   ;string
 199   (content     plain-file-content)                ;string
 200   (references  plain-file-references))            ;list (currently unused)
 201
 202 (define (plain-file name content)
 203   "Return an object representing a text file called NAME with the given
 204 CONTENT (a string) to be added to the store.
 205
 206 This is the declarative counterpart of 'text-file'."
 207   ;; XXX: For now just ignore 'references' because it's not clear how to use
 208   ;; them in a declarative context.
 209   (%plain-file name content '()))
 210
 211 (define-gexp-compiler (plain-file-compiler (file plain-file?) system target)
 212   ;; "Compile" FILE by adding it to the store.
 213   (match file
 214     (($ <plain-file> name content references)
 215      (text-file name content references))))
 216
 217 \f
 218 ;;;
 219 ;;; Inputs & outputs.
 220 ;;;
 221
 222 ;; The input of a gexp.
 223 (define-record-type <gexp-input>
 224   (%gexp-input thing output native?)
 225   gexp-input?
 226   (thing     gexp-input-thing)       ;<package> | <origin> | <derivation> | ...
 227   (output    gexp-input-output)      ;string
 228   (native?   gexp-input-native?))    ;Boolean
 229
 230 (define (write-gexp-input input port)
 231   (match input
 232     (($ <gexp-input> thing output #f)
 233      (format port "#<gexp-input ~s:~a>" thing output))
 234     (($ <gexp-input> thing output #t)
 235      (format port "#<gexp-input native ~s:~a>" thing output))))
 236
 237 (set-record-type-printer! <gexp-input> write-gexp-input)
 238
 239 (define* (gexp-input thing                        ;convenience procedure
 240                      #:optional (output "out")
 241                      #:key native?)
 242   "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines
 243 whether this should be considered a \"native\" input or not."
 244   (%gexp-input thing output native?))
 245
 246 ;; Reference to one of the derivation's outputs, for gexps used in
 247 ;; derivations.
 248 (define-record-type <gexp-output>
 249   (gexp-output name)
 250   gexp-output?
 251   (name gexp-output-name))
 252
 253 (define (write-gexp-output output port)
 254   (match output
 255     (($ <gexp-output> name)
 256      (format port "#<gexp-output ~a>" name))))
 257
 258 (set-record-type-printer! <gexp-output> write-gexp-output)
 259
 260 (define raw-derivation
 261   (store-lift derivation))
 262
 263 (define* (lower-inputs inputs
 264                        #:key system target)
 265   "Turn any package from INPUTS into a derivation for SYSTEM; return the
 266 corresponding input list as a monadic value.  When TARGET is true, use it as
 267 the cross-compilation target triplet."
 268   (with-monad %store-monad
 269     (sequence %store-monad
 270               (map (match-lambda
 271                      (((? struct? thing) sub-drv ...)
 272                       (mlet %store-monad ((drv (lower-object
 273                                                 thing system #:target target)))
 274                         (return `(,drv ,@sub-drv))))
 275                      (input
 276                       (return input)))
 277                    inputs))))
 278
 279 (define* (lower-reference-graphs graphs #:key system target)
 280   "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
 281 #:reference-graphs argument, lower it such that each INPUT is replaced by the
 282 corresponding derivation."
 283   (match graphs
 284     (((file-names . inputs) ...)
 285      (mlet %store-monad ((inputs (lower-inputs inputs
 286                                                #:system system
 287                                                #:target target)))
 288        (return (map cons file-names inputs))))))
 289
 290 (define* (lower-references lst #:key system target)
 291   "Based on LST, a list of output names and packages, return a list of output
 292 names and file names suitable for the #:allowed-references argument to
 293 'derivation'."
 294   ;; XXX: Currently outputs other than "out" are not supported, and things
 295   ;; other than packages aren't either.
 296   (with-monad %store-monad
 297     (define lower
 298       (match-lambda
 299        ((? string? output)
 300         (return output))
 301        (($ <gexp-input> thing output native?)
 302         (mlet %store-monad ((drv (lower-object thing system
 303                                                #:target (if native?
 304                                                             #f target))))
 305           (return (derivation->output-path drv output))))
 306        (thing
 307         (mlet %store-monad ((drv (lower-object thing system
 308                                                #:target target)))
 309           (return (derivation->output-path drv))))))
 310
 311     (sequence %store-monad (map lower lst))))
 312
 313 (define default-guile-derivation
 314   ;; Here we break the abstraction by talking to the higher-level layer.
 315   ;; Thus, do the resolution lazily to hide the circular dependency.
 316   (let ((proc (delay
 317                 (let ((iface (resolve-interface '(guix packages))))
 318                   (module-ref iface 'default-guile-derivation)))))
 319     (lambda (system)
 320       ((force proc) system))))
 321
 322 (define* (gexp->derivation name exp
 323                            #:key
 324                            system (target 'current)
 325                            hash hash-algo recursive?
 326                            (env-vars '())
 327                            (modules '())
 328                            (module-path %load-path)
 329                            (guile-for-build (%guile-for-build))
 330                            (graft? (%graft?))
 331                            references-graphs
 332                            allowed-references
 333                            leaked-env-vars
 334                            local-build? (substitutable? #t)
 335                            (script-name (string-append name "-builder")))
 336   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
 337 derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME.  When
 338 TARGET is true, it is used as the cross-compilation target triplet for
 339 packages referred to by EXP.
 340
 341 Make MODULES available in the evaluation context of EXP; MODULES is a list of
 342 names of Guile modules searched in MODULE-PATH to be copied in the store,
 343 compiled, and made available in the load path during the execution of
 344 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 345
 346 GRAFT? determines whether packages referred to by EXP should be grafted when
 347 applicable.
 348
 349 When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
 350 following forms:
 351
 352   (FILE-NAME PACKAGE)
 353   (FILE-NAME PACKAGE OUTPUT)
 354   (FILE-NAME DERIVATION)
 355   (FILE-NAME DERIVATION OUTPUT)
 356   (FILE-NAME STORE-ITEM)
 357
 358 The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
 359 an input of the build process of EXP.  In the build environment, each
 360 FILE-NAME contains the reference graph of the corresponding item, in a simple
 361 text format.
 362
 363 ALLOWED-REFERENCES must be either #f or a list of output names and packages.
 364 In the latter case, the list denotes store items that the result is allowed to
 365 refer to.  Any reference to another store item will lead to a build error.
 366
 367 The other arguments are as for 'derivation'."
 368   (define %modules modules)
 369   (define outputs (gexp-outputs exp))
 370
 371   (define (graphs-file-names graphs)
 372     ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
 373     (map (match-lambda
 374           ;; TODO: Remove 'derivation?' special cases.
 375            ((file-name (? derivation? drv))
 376             (cons file-name (derivation->output-path drv)))
 377            ((file-name (? derivation? drv) sub-drv)
 378             (cons file-name (derivation->output-path drv sub-drv)))
 379            ((file-name thing)
 380             (cons file-name thing)))
 381          graphs))
 382
 383   (mlet* %store-monad (;; The following binding forces '%current-system' and
 384                        ;; '%current-target-system' to be looked up at >>=
 385                        ;; time.
 386                        (graft?    (set-grafting graft?))
 387
 388                        (system -> (or system (%current-system)))
 389                        (target -> (if (eq? target 'current)
 390                                       (%current-target-system)
 391                                       target))
 392                        (normals  (lower-inputs (gexp-inputs exp)
 393                                                #:system system
 394                                                #:target target))
 395                        (natives  (lower-inputs (gexp-native-inputs exp)
 396                                                #:system system
 397                                                #:target #f))
 398                        (inputs -> (append normals natives))
 399                        (sexp     (gexp->sexp exp
 400                                              #:system system
 401                                              #:target target))
 402                        (builder  (text-file script-name
 403                                             (object->string sexp)))
 404                        (modules  (if (pair? %modules)
 405                                      (imported-modules %modules
 406                                                        #:system system
 407                                                        #:module-path module-path
 408                                                        #:guile guile-for-build)
 409                                      (return #f)))
 410                        (compiled (if (pair? %modules)
 411                                      (compiled-modules %modules
 412                                                        #:system system
 413                                                        #:module-path module-path
 414                                                        #:guile guile-for-build)
 415                                      (return #f)))
 416                        (graphs   (if references-graphs
 417                                      (lower-reference-graphs references-graphs
 418                                                              #:system system
 419                                                              #:target target)
 420                                      (return #f)))
 421                        (allowed  (if allowed-references
 422                                      (lower-references allowed-references
 423                                                        #:system system
 424                                                        #:target target)
 425                                      (return #f)))
 426                        (guile    (if guile-for-build
 427                                      (return guile-for-build)
 428                                      (default-guile-derivation system))))
 429     (mbegin %store-monad
 430       (set-grafting graft?)                       ;restore the initial setting
 431       (raw-derivation name
 432                       (string-append (derivation->output-path guile)
 433                                      "/bin/guile")
 434                       `("--no-auto-compile"
 435                         ,@(if (pair? %modules)
 436                               `("-L" ,(derivation->output-path modules)
 437                                 "-C" ,(derivation->output-path compiled))
 438                               '())
 439                         ,builder)
 440                       #:outputs outputs
 441                       #:env-vars env-vars
 442                       #:system system
 443                       #:inputs `((,guile)
 444                                  (,builder)
 445                                  ,@(if modules
 446                                        `((,modules) (,compiled) ,@inputs)
 447                                        inputs)
 448                                  ,@(match graphs
 449                                      (((_ . inputs) ...) inputs)
 450                                      (_ '())))
 451                       #:hash hash #:hash-algo hash-algo #:recursive? recursive?
 452                       #:references-graphs (and=> graphs graphs-file-names)
 453                       #:allowed-references allowed
 454                       #:leaked-env-vars leaked-env-vars
 455                       #:local-build? local-build?
 456                       #:substitutable? substitutable?))))
 457
 458 (define* (gexp-inputs exp #:key native?)
 459   "Return the input list for EXP.  When NATIVE? is true, return only native
 460 references; otherwise, return only non-native references."
 461   (define (add-reference-inputs ref result)
 462     (match ref
 463       (($ <gexp-input> (? gexp? exp) _ #t)
 464        (if native?
 465            (append (gexp-inputs exp)
 466                    (gexp-inputs exp #:native? #t)
 467                    result)
 468            result))
 469       (($ <gexp-input> (? gexp? exp) _ #f)
 470        (if native?
 471            (append (gexp-inputs exp #:native? #t)
 472                    result)
 473            (append (gexp-inputs exp)
 474                    result)))
 475       (($ <gexp-input> (? string? str))
 476        (if (direct-store-path? str)
 477            (cons `(,str) result)
 478            result))
 479       (($ <gexp-input> (? struct? thing) output)
 480        (if (lookup-compiler thing)
 481            ;; THING is a derivation, or a package, or an origin, etc.
 482            (cons `(,thing ,output) result)
 483            result))
 484       (($ <gexp-input> (lst ...) output n?)
 485        (fold-right add-reference-inputs result
 486                    ;; XXX: For now, automatically convert LST to a list of
 487                    ;; gexp-inputs.
 488                    (map (match-lambda
 489                          ((? gexp-input? x) x)
 490                          (x (%gexp-input x "out" (or n? native?))))
 491                         lst)))
 492       (_
 493        ;; Ignore references to other kinds of objects.
 494        result)))
 495
 496   (fold-right add-reference-inputs
 497               '()
 498               (if native?
 499                   (gexp-native-references exp)
 500                   (gexp-references exp))))
 501
 502 (define gexp-native-inputs
 503   (cut gexp-inputs <> #:native? #t))
 504
 505 (define (gexp-outputs exp)
 506   "Return the outputs referred to by EXP as a list of strings."
 507   (define (add-reference-output ref result)
 508     (match ref
 509       (($ <gexp-output> name)
 510        (cons name result))
 511       (($ <gexp-input> (? gexp? exp))
 512        (append (gexp-outputs exp) result))
 513       (($ <gexp-input> (lst ...) output native?)
 514        ;; XXX: Automatically convert LST.
 515        (add-reference-output (map (match-lambda
 516                                    ((? gexp-input? x) x)
 517                                    (x (%gexp-input x "out" native?)))
 518                                   lst)
 519                              result))
 520       ((lst ...)
 521        (fold-right add-reference-output result lst))
 522       (_
 523        result)))
 524
 525   (delete-duplicates
 526    (add-reference-output (gexp-references exp) '())))
 527
 528 (define* (gexp->sexp exp #:key
 529                      (system (%current-system))
 530                      (target (%current-target-system)))
 531   "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
 532 and in the current monad setting (system type, etc.)"
 533   (define* (reference->sexp ref #:optional native?)
 534     (with-monad %store-monad
 535       (match ref
 536         (($ <gexp-output> output)
 537          ;; Output file names are not known in advance but the daemon defines
 538          ;; an environment variable for each of them at build time, so use
 539          ;; that trick.
 540          (return `((@ (guile) getenv) ,output)))
 541         (($ <gexp-input> (? gexp? exp) output n?)
 542          (gexp->sexp exp
 543                      #:system system
 544                      #:target (if (or n? native?) #f target)))
 545         (($ <gexp-input> (refs ...) output n?)
 546          (sequence %store-monad
 547                    (map (lambda (ref)
 548                           ;; XXX: Automatically convert REF to an gexp-input.
 549                           (reference->sexp
 550                            (if (gexp-input? ref)
 551                                ref
 552                                (%gexp-input ref "out" n?))
 553                            native?))
 554                         refs)))
 555         (($ <gexp-input> (? struct? thing) output n?)
 556          (let ((target (if (or n? native?) #f target)))
 557            (mlet %store-monad ((obj (lower-object thing system
 558                                                   #:target target)))
 559              ;; OBJ must be either a derivation or a store file name.
 560              (return (match obj
 561                        ((? derivation? drv)
 562                         (derivation->output-path drv output))
 563                        ((? string? file)
 564                         file))))))
 565         (($ <gexp-input> x)
 566          (return x))
 567         (x
 568          (return x)))))
 569
 570   (mlet %store-monad
 571       ((args (sequence %store-monad
 572                        (append (map reference->sexp (gexp-references exp))
 573                                (map (cut reference->sexp <> #t)
 574                                     (gexp-native-references exp))))))
 575     (return (apply (gexp-proc exp) args))))
 576
 577 (define (syntax-location-string s)
 578   "Return a string representing the source code location of S."
 579   (let ((props (syntax-source s)))
 580     (if props
 581         (let ((file   (assoc-ref props 'filename))
 582               (line   (and=> (assoc-ref props 'line) 1+))
 583               (column (assoc-ref props 'column)))
 584           (if file
 585               (simple-format #f "~a:~a:~a"
 586                              file line column)
 587               (simple-format #f "~a:~a" line column)))
 588         "<unknown location>")))
 589
 590 (define-syntax gexp
 591   (lambda (s)
 592     (define (collect-escapes exp)
 593       ;; Return all the 'ungexp' present in EXP.
 594       (let loop ((exp    exp)
 595                  (result '()))
 596         (syntax-case exp (ungexp
 597                           ungexp-splicing
 598                           ungexp-native
 599                           ungexp-native-splicing)
 600           ((ungexp _)
 601            (cons exp result))
 602           ((ungexp _ _)
 603            (cons exp result))
 604           ((ungexp-splicing _ ...)
 605            (cons exp result))
 606           ((ungexp-native _ ...)
 607            result)
 608           ((ungexp-native-splicing _ ...)
 609            result)
 610           ((exp0 exp ...)
 611            (let ((result (loop #'exp0 result)))
 612              (fold loop result #'(exp ...))))
 613           (_
 614            result))))
 615
 616     (define (collect-native-escapes exp)
 617       ;; Return all the 'ungexp-native' forms present in EXP.
 618       (let loop ((exp    exp)
 619                  (result '()))
 620         (syntax-case exp (ungexp
 621                           ungexp-splicing
 622                           ungexp-native
 623                           ungexp-native-splicing)
 624           ((ungexp-native _)
 625            (cons exp result))
 626           ((ungexp-native _ _)
 627            (cons exp result))
 628           ((ungexp-native-splicing _ ...)
 629            (cons exp result))
 630           ((ungexp _ ...)
 631            result)
 632           ((ungexp-splicing _ ...)
 633            result)
 634           ((exp0 exp ...)
 635            (let ((result (loop #'exp0 result)))
 636              (fold loop result #'(exp ...))))
 637           (_
 638            result))))
 639
 640     (define (escape->ref exp)
 641       ;; Turn 'ungexp' form EXP into a "reference".
 642       (syntax-case exp (ungexp ungexp-splicing
 643                         ungexp-native ungexp-native-splicing
 644                         output)
 645         ((ungexp output)
 646          #'(gexp-output "out"))
 647         ((ungexp output name)
 648          #'(gexp-output name))
 649         ((ungexp thing)
 650          #'(%gexp-input thing "out" #f))
 651         ((ungexp drv-or-pkg out)
 652          #'(%gexp-input drv-or-pkg out #f))
 653         ((ungexp-splicing lst)
 654          #'(%gexp-input lst "out" #f))
 655         ((ungexp-native thing)
 656          #'(%gexp-input thing "out" #t))
 657         ((ungexp-native drv-or-pkg out)
 658          #'(%gexp-input drv-or-pkg out #t))
 659         ((ungexp-native-splicing lst)
 660          #'(%gexp-input lst "out" #t))))
 661
 662     (define (substitute-ungexp exp substs)
 663       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
 664       ;; the corresponding form in SUBSTS.
 665       (match (assoc exp substs)
 666         ((_ id)
 667          id)
 668         (_
 669          #'(syntax-error "error: no 'ungexp' substitution"
 670                          #'ref))))
 671
 672     (define (substitute-ungexp-splicing exp substs)
 673       (syntax-case exp ()
 674         ((exp rest ...)
 675          (match (assoc #'exp substs)
 676            ((_ id)
 677             (with-syntax ((id id))
 678               #`(append id
 679                         #,(substitute-references #'(rest ...) substs))))
 680            (_
 681             #'(syntax-error "error: no 'ungexp-splicing' substitution"
 682                             #'ref))))))
 683
 684     (define (substitute-references exp substs)
 685       ;; Return a variant of EXP where all the cars of SUBSTS have been
 686       ;; replaced by the corresponding cdr.
 687       (syntax-case exp (ungexp ungexp-native
 688                         ungexp-splicing ungexp-native-splicing)
 689         ((ungexp _ ...)
 690          (substitute-ungexp exp substs))
 691         ((ungexp-native _ ...)
 692          (substitute-ungexp exp substs))
 693         (((ungexp-splicing _ ...) rest ...)
 694          (substitute-ungexp-splicing exp substs))
 695         (((ungexp-native-splicing _ ...) rest ...)
 696          (substitute-ungexp-splicing exp substs))
 697         ((exp0 exp ...)
 698          #`(cons #,(substitute-references #'exp0 substs)
 699                  #,(substitute-references #'(exp ...) substs)))
 700         (x #''x)))
 701
 702     (syntax-case s (ungexp output)
 703       ((_ exp)
 704        (let* ((normals (delete-duplicates (collect-escapes #'exp)))
 705               (natives (delete-duplicates (collect-native-escapes #'exp)))
 706               (escapes (append normals natives))
 707               (formals (generate-temporaries escapes))
 708               (sexp    (substitute-references #'exp (zip escapes formals)))
 709               (refs    (map escape->ref normals))
 710               (nrefs   (map escape->ref natives)))
 711          #`(make-gexp (list #,@refs) (list #,@nrefs)
 712                       (lambda #,formals
 713                         #,sexp)))))))
 714
 715 \f
 716 ;;;
 717 ;;; Module handling.
 718 ;;;
 719
 720 (define %utils-module
 721   ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
 722   ;; other primitives below.
 723   (local-file (search-path %load-path "guix/build/utils.scm")
 724               "build-utils.scm"))
 725
 726 (define* (imported-files files
 727                          #:key (name "file-import")
 728                          (system (%current-system))
 729                          (guile (%guile-for-build)))
 730   "Return a derivation that imports FILES into STORE.  FILES must be a list
 731 of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
 732 system, imported, and appears under FINAL-PATH in the resulting store path."
 733   (define file-pair
 734     (match-lambda
 735      ((final-path . file-name)
 736       (mlet %store-monad ((file (interned-file file-name
 737                                                (basename final-path))))
 738         (return (list final-path file))))))
 739
 740   (mlet %store-monad ((files (sequence %store-monad
 741                                        (map file-pair files))))
 742     (define build
 743       (gexp
 744        (begin
 745          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
 746          (use-modules (ice-9 match))
 747
 748          (mkdir (ungexp output)) (chdir (ungexp output))
 749          (for-each (match-lambda
 750                     ((final-path store-path)
 751                      (mkdir-p (dirname final-path))
 752                      (symlink store-path final-path)))
 753                    '(ungexp files)))))
 754
 755     ;; TODO: Pass FILES as an environment variable so that BUILD remains
 756     ;; exactly the same regardless of FILES: less disk space, and fewer
 757     ;; 'add-to-store' RPCs.
 758     (gexp->derivation name build
 759                       #:system system
 760                       #:guile-for-build guile
 761                       #:local-build? #t)))
 762
 763 (define search-path*
 764   ;; A memoizing version of 'search-path' so 'imported-modules' does not end
 765   ;; up looking for the same files over and over again.
 766   (memoize search-path))
 767
 768 (define* (imported-modules modules
 769                            #:key (name "module-import")
 770                            (system (%current-system))
 771                            (guile (%guile-for-build))
 772                            (module-path %load-path))
 773   "Return a derivation that contains the source files of MODULES, a list of
 774 module names such as `(ice-9 q)'.  All of MODULES must be in the MODULE-PATH
 775 search path."
 776   ;; TODO: Determine the closure of MODULES, build the `.go' files,
 777   ;; canonicalize the source files through read/write, etc.
 778   (let ((files (map (lambda (m)
 779                       (let ((f (string-append
 780                                 (string-join (map symbol->string m) "/")
 781                                 ".scm")))
 782                         (cons f (search-path* module-path f))))
 783                     modules)))
 784     (imported-files files #:name name #:system system
 785                     #:guile guile)))
 786
 787 (define* (compiled-modules modules
 788                            #:key (name "module-import-compiled")
 789                            (system (%current-system))
 790                            (guile (%guile-for-build))
 791                            (module-path %load-path))
 792   "Return a derivation that builds a tree containing the `.go' files
 793 corresponding to MODULES.  All the MODULES are built in a context where
 794 they can refer to each other."
 795   (mlet %store-monad ((modules (imported-modules modules
 796                                                  #:system system
 797                                                  #:guile guile
 798                                                  #:module-path
 799                                                  module-path)))
 800     (define build
 801       (gexp
 802        (begin
 803          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
 804
 805          (use-modules (ice-9 ftw)
 806                       (srfi srfi-26)
 807                       (system base compile))
 808
 809          (define (regular? file)
 810            (not (member file '("." ".."))))
 811
 812          (define (process-directory directory output)
 813            (let ((entries (map (cut string-append directory "/" <>)
 814                                (scandir directory regular?))))
 815              (for-each (lambda (entry)
 816                          (if (file-is-directory? entry)
 817                              (let ((output (string-append output "/"
 818                                                           (basename entry))))
 819                                (mkdir-p output)
 820                                (process-directory entry output))
 821                              (let* ((base   (string-drop-right
 822                                              (basename entry)
 823                                              4)) ;.scm
 824                                     (output (string-append output "/" base
 825                                                            ".go")))
 826                                (compile-file entry
 827                                              #:output-file output
 828                                              #:opts
 829                                              %auto-compilation-options))))
 830                        entries)))
 831
 832          (set! %load-path (cons (ungexp modules) %load-path))
 833          (mkdir (ungexp output))
 834          (chdir (ungexp modules))
 835          (process-directory "." (ungexp output)))))
 836
 837     ;; TODO: Pass MODULES as an environment variable.
 838     (gexp->derivation name build
 839                       #:system system
 840                       #:guile-for-build guile
 841                       #:local-build? #t)))
 842
 843 \f
 844 ;;;
 845 ;;; Convenience procedures.
 846 ;;;
 847
 848 (define (default-guile)
 849   ;; Lazily resolve 'guile-final'.  This module must not refer to (gnu …)
 850   ;; modules directly, to avoid circular dependencies, hence this hack.
 851   (module-ref (resolve-interface '(gnu packages commencement))
 852               'guile-final))
 853
 854 (define* (gexp->script name exp
 855                        #:key (modules '()) (guile (default-guile)))
 856   "Return an executable script NAME that runs EXP using GUILE with MODULES in
 857 its search path."
 858   (mlet %store-monad ((modules  (imported-modules modules))
 859                       (compiled (compiled-modules modules)))
 860     (gexp->derivation name
 861                       (gexp
 862                        (call-with-output-file (ungexp output)
 863                          (lambda (port)
 864                            ;; Note: that makes a long shebang.  When the store
 865                            ;; is /gnu/store, that fits within the 128-byte
 866                            ;; limit imposed by Linux, but that may go beyond
 867                            ;; when running tests.
 868                            (format port
 869                                    "#!~a/bin/guile --no-auto-compile~%!#~%"
 870                                    (ungexp guile))
 871
 872                            ;; Write the 'eval-when' form so that it can be
 873                            ;; compiled.
 874                            (write
 875                             '(eval-when (expand load eval)
 876                                (set! %load-path
 877                                     (cons (ungexp modules) %load-path))
 878                                (set! %load-compiled-path
 879                                      (cons (ungexp compiled)
 880                                            %load-compiled-path)))
 881                             port)
 882                            (write '(ungexp exp) port)
 883                            (chmod port #o555)))))))
 884
 885 (define (gexp->file name exp)
 886   "Return a derivation that builds a file NAME containing EXP."
 887   (gexp->derivation name
 888                     (gexp
 889                      (call-with-output-file (ungexp output)
 890                        (lambda (port)
 891                          (write '(ungexp exp) port))))
 892                     #:local-build? #t))
 893
 894 (define* (text-file* name #:rest text)
 895   "Return as a monadic value a derivation that builds a text file containing
 896 all of TEXT.  TEXT may list, in addition to strings, objects of any type that
 897 can be used in a gexp: packages, derivations, local file objects, etc.  The
 898 resulting store file holds references to all these."
 899   (define builder
 900     (gexp (call-with-output-file (ungexp output "out")
 901             (lambda (port)
 902               (display (string-append (ungexp-splicing text)) port)))))
 903
 904   (gexp->derivation name builder))
 905
 906 \f
 907 ;;;
 908 ;;; Syntactic sugar.
 909 ;;;
 910
 911 (eval-when (expand load eval)
 912   (define* (read-ungexp chr port #:optional native?)
 913     "Read an 'ungexp' or 'ungexp-splicing' form from PORT.  When NATIVE? is
 914 true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
 915     (define unquote-symbol
 916       (match (peek-char port)
 917         (#\@
 918          (read-char port)
 919          (if native?
 920              'ungexp-native-splicing
 921              'ungexp-splicing))
 922         (_
 923          (if native?
 924              'ungexp-native
 925              'ungexp))))
 926
 927     (match (read port)
 928       ((? symbol? symbol)
 929        (let ((str (symbol->string symbol)))
 930          (match (string-index-right str #\:)
 931            (#f
 932             `(,unquote-symbol ,symbol))
 933            (colon
 934             (let ((name   (string->symbol (substring str 0 colon)))
 935                   (output (substring str (+ colon 1))))
 936               `(,unquote-symbol ,name ,output))))))
 937       (x
 938        `(,unquote-symbol ,x))))
 939
 940   (define (read-gexp chr port)
 941     "Read a 'gexp' form from PORT."
 942     `(gexp ,(read port)))
 943
 944   ;; Extend the reader
 945   (read-hash-extend #\~ read-gexp)
 946   (read-hash-extend #\$ read-ungexp)
 947   (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
 948
 949 ;;; gexp.scm ends here