guix/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 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                 #:select (direct-store-path?))
  22   #:use-module (guix monads)
  23   #:use-module ((guix derivations)
  24                 #:select (derivation? derivation->output-path
  25                           %guile-for-build derivation))
  26   #:use-module (guix packages)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-9)
  29   #:use-module (srfi srfi-9 gnu)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (ice-9 match)
  32   #:export (gexp
  33             gexp?
  34             gexp->derivation
  35             gexp->file
  36             gexp->script))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; This module implements "G-expressions", or "gexps".  Gexps are like
  41 ;;; S-expressions (sexps), with two differences:
  42 ;;;
  43 ;;;   1. References (un-quotations) to derivations or packages in a gexp are
  44 ;;;      replaced by the corresponding output file name; in addition, the
  45 ;;;      'ungexp-native' unquote-like form allows code to explicitly refer to
  46 ;;;      the native code of a given package, in case of cross-compilation;
  47 ;;;
  48 ;;;   2. Gexps embed information about the derivations they refer to.
  49 ;;;
  50 ;;; Gexps make it easy to write to files Scheme code that refers to store
  51 ;;; items, or to write Scheme code to build derivations.
  52 ;;;
  53 ;;; Code:
  54
  55 ;; "G expressions".
  56 (define-record-type <gexp>
  57   (make-gexp references natives proc)
  58   gexp?
  59   (references gexp-references)                    ; ((DRV-OR-PKG OUTPUT) ...)
  60   (natives    gexp-native-references)             ; ((DRV-OR-PKG OUTPUT) ...)
  61   (proc       gexp-proc))                         ; procedure
  62
  63 (define (write-gexp gexp port)
  64   "Write GEXP on PORT."
  65   (display "#<gexp " port)
  66
  67   ;; Try to write the underlying sexp.  Now, this trick doesn't work when
  68   ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
  69   ;; tries to use 'append' on that, which fails with wrong-type-arg.
  70   (false-if-exception
  71    (write (apply (gexp-proc gexp)
  72                  (append (gexp-references gexp)
  73                          (gexp-native-references gexp)))
  74           port))
  75   (format port " ~a>"
  76           (number->string (object-address gexp) 16)))
  77
  78 (set-record-type-printer! <gexp> write-gexp)
  79
  80 ;; Reference to one of the derivation's outputs, for gexps used in
  81 ;; derivations.
  82 (define-record-type <output-ref>
  83   (output-ref name)
  84   output-ref?
  85   (name output-ref-name))
  86
  87 (define raw-derivation
  88   (store-lift derivation))
  89
  90 (define* (lower-inputs inputs
  91                        #:key system target)
  92   "Turn any package from INPUTS into a derivation for SYSTEM; return the
  93 corresponding input list as a monadic value.  When TARGET is true, use it as
  94 the cross-compilation target triplet."
  95   (with-monad %store-monad
  96     (sequence %store-monad
  97               (map (match-lambda
  98                     (((? package? package) sub-drv ...)
  99                      (mlet %store-monad
 100                          ((drv (if target
 101                                    (package->cross-derivation package target
 102                                                               system)
 103                                    (package->derivation package system))))
 104                        (return `(,drv ,@sub-drv))))
 105                     (((? origin? origin) sub-drv ...)
 106                      (mlet %store-monad ((drv (origin->derivation origin)))
 107                        (return `(,drv ,@sub-drv))))
 108                     (input
 109                      (return input)))
 110                    inputs))))
 111
 112 (define* (gexp->derivation name exp
 113                            #:key
 114                            system (target 'current)
 115                            hash hash-algo recursive?
 116                            (env-vars '())
 117                            (modules '())
 118                            (guile-for-build (%guile-for-build))
 119                            references-graphs
 120                            local-build?)
 121   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
 122 derivation) on SYSTEM.  When TARGET is true, it is used as the
 123 cross-compilation target triplet for packages referred to by EXP.
 124
 125 Make MODULES available in the evaluation context of EXP; MODULES is a list of
 126 names of Guile modules from the current search path to be copied in the store,
 127 compiled, and made available in the load path during the execution of
 128 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 129
 130 The other arguments are as for 'derivation'."
 131   (define %modules modules)
 132   (define outputs (gexp-outputs exp))
 133
 134   (mlet* %store-monad (;; The following binding is here to force
 135                        ;; '%current-system' and '%current-target-system' to be
 136                        ;; looked up at >>= time.
 137                        (unused    (return #f))
 138
 139                        (system -> (or system (%current-system)))
 140                        (target -> (if (eq? target 'current)
 141                                       (%current-target-system)
 142                                       target))
 143                        (normals  (lower-inputs (gexp-inputs exp)
 144                                                #:system system
 145                                                #:target target))
 146                        (natives  (lower-inputs (gexp-native-inputs exp)
 147                                                #:system system
 148                                                #:target #f))
 149                        (inputs -> (append normals natives))
 150                        (sexp     (gexp->sexp exp
 151                                              #:system system
 152                                              #:target target))
 153                        (builder  (text-file (string-append name "-builder")
 154                                             (object->string sexp)))
 155                        (modules  (if (pair? %modules)
 156                                      (imported-modules %modules
 157                                                        #:system system
 158                                                        #:guile guile-for-build)
 159                                      (return #f)))
 160                        (compiled (if (pair? %modules)
 161                                      (compiled-modules %modules
 162                                                        #:system system
 163                                                        #:guile guile-for-build)
 164                                      (return #f)))
 165                        (guile    (if guile-for-build
 166                                      (return guile-for-build)
 167                                      (package->derivation (default-guile)
 168                                                           system))))
 169     (raw-derivation name
 170                     (string-append (derivation->output-path guile)
 171                                    "/bin/guile")
 172                     `("--no-auto-compile"
 173                       ,@(if (pair? %modules)
 174                             `("-L" ,(derivation->output-path modules)
 175                               "-C" ,(derivation->output-path compiled))
 176                             '())
 177                       ,builder)
 178                     #:outputs outputs
 179                     #:env-vars env-vars
 180                     #:system system
 181                     #:inputs `((,guile)
 182                                (,builder)
 183                                ,@(if modules
 184                                      `((,modules) (,compiled) ,@inputs)
 185                                      inputs))
 186                     #:hash hash #:hash-algo hash-algo #:recursive? recursive?
 187                     #:references-graphs references-graphs
 188                     #:local-build? local-build?)))
 189
 190 (define* (gexp-inputs exp #:optional (references gexp-references))
 191   "Return the input list for EXP, using REFERENCES to get its list of
 192 references."
 193   (define (add-reference-inputs ref result)
 194     (match ref
 195       (((? derivation?) (? string?))
 196        (cons ref result))
 197       (((? package?) (? string?))
 198        (cons ref result))
 199       (((? origin?) (? string?))
 200        (cons ref result))
 201       ((? gexp? exp)
 202        (append (gexp-inputs exp references) result))
 203       (((? string? file))
 204        (if (direct-store-path? file)
 205            (cons ref result)
 206            result))
 207       ((refs ...)
 208        (fold-right add-reference-inputs result refs))
 209       (_
 210        ;; Ignore references to other kinds of objects.
 211        result)))
 212
 213   (fold-right add-reference-inputs
 214               '()
 215               (references exp)))
 216
 217 (define gexp-native-inputs
 218   (cut gexp-inputs <> gexp-native-references))
 219
 220 (define (gexp-outputs exp)
 221   "Return the outputs referred to by EXP as a list of strings."
 222   (define (add-reference-output ref result)
 223     (match ref
 224       (($ <output-ref> name)
 225        (cons name result))
 226       ((? gexp? exp)
 227        (append (gexp-outputs exp) result))
 228       (_
 229        result)))
 230
 231   (fold-right add-reference-output
 232               '()
 233               (gexp-references exp)))
 234
 235 (define* (gexp->sexp exp #:key
 236                      (system (%current-system))
 237                      (target (%current-target-system)))
 238   "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
 239 and in the current monad setting (system type, etc.)"
 240   (define* (reference->sexp ref #:optional native?)
 241     (with-monad %store-monad
 242       (match ref
 243         (((? derivation? drv) (? string? output))
 244          (return (derivation->output-path drv output)))
 245         (((? package? p) (? string? output))
 246          (package-file p
 247                        #:output output
 248                        #:system system
 249                        #:target (if native? #f target)))
 250         (((? origin? o) (? string? output))
 251          (mlet %store-monad ((drv (origin->derivation o)))
 252            (return (derivation->output-path drv output))))
 253         (($ <output-ref> output)
 254          ;; Output file names are not known in advance but the daemon defines
 255          ;; an environment variable for each of them at build time, so use
 256          ;; that trick.
 257          (return `((@ (guile) getenv) ,output)))
 258         ((? gexp? exp)
 259          (gexp->sexp exp
 260                      #:system system
 261                      #:target (if native? #f target)))
 262         (((? string? str))
 263          (return (if (direct-store-path? str) str ref)))
 264         ((refs ...)
 265          (sequence %store-monad
 266                    (map (cut reference->sexp <> native?) refs)))
 267         (x
 268          (return x)))))
 269
 270   (mlet %store-monad
 271       ((args (sequence %store-monad
 272                        (append (map reference->sexp (gexp-references exp))
 273                                (map (cut reference->sexp <> #t)
 274                                     (gexp-native-references exp))))))
 275     (return (apply (gexp-proc exp) args))))
 276
 277 (define (canonicalize-reference ref)
 278   "Return a canonical variant of REF, which adds any missing output part in
 279 package/derivation references."
 280   (match ref
 281     ((? package? p)
 282      `(,p "out"))
 283     ((? origin? o)
 284      `(,o "out"))
 285     ((? derivation? d)
 286      `(,d "out"))
 287     (((? package?) (? string?))
 288      ref)
 289     (((? origin?) (? string?))
 290      ref)
 291     (((? derivation?) (? string?))
 292      ref)
 293     ((? string? s)
 294      (if (direct-store-path? s) `(,s) s))
 295     ((refs ...)
 296      (map canonicalize-reference refs))
 297     (x x)))
 298
 299 (define (syntax-location-string s)
 300   "Return a string representing the source code location of S."
 301   (let ((props (syntax-source s)))
 302     (if props
 303         (let ((file   (assoc-ref props 'filename))
 304               (line   (and=> (assoc-ref props 'line) 1+))
 305               (column (assoc-ref props 'column)))
 306           (if file
 307               (simple-format #f "~a:~a:~a"
 308                              file line column)
 309               (simple-format #f "~a:~a" line column)))
 310         "<unknown location>")))
 311
 312 (define-syntax gexp
 313   (lambda (s)
 314     (define (collect-escapes exp)
 315       ;; Return all the 'ungexp' present in EXP.
 316       (let loop ((exp    exp)
 317                  (result '()))
 318         (syntax-case exp (ungexp ungexp-splicing)
 319           ((ungexp _)
 320            (cons exp result))
 321           ((ungexp _ _)
 322            (cons exp result))
 323           ((ungexp-splicing _ ...)
 324            (cons exp result))
 325           ((exp0 exp ...)
 326            (let ((result (loop #'exp0 result)))
 327              (fold loop result #'(exp ...))))
 328           (_
 329            result))))
 330
 331     (define (collect-native-escapes exp)
 332       ;; Return all the 'ungexp-native' forms present in EXP.
 333       (let loop ((exp    exp)
 334                  (result '()))
 335         (syntax-case exp (ungexp-native ungexp-native-splicing)
 336           ((ungexp-native _)
 337            (cons exp result))
 338           ((ungexp-native _ _)
 339            (cons exp result))
 340           ((ungexp-native-splicing _ ...)
 341            (cons exp result))
 342           ((exp0 exp ...)
 343            (let ((result (loop #'exp0 result)))
 344              (fold loop result #'(exp ...))))
 345           (_
 346            result))))
 347
 348     (define (escape->ref exp)
 349       ;; Turn 'ungexp' form EXP into a "reference".
 350       (syntax-case exp (ungexp ungexp-splicing
 351                         ungexp-native ungexp-native-splicing
 352                         output)
 353         ((ungexp output)
 354          #'(output-ref "out"))
 355         ((ungexp output name)
 356          #'(output-ref name))
 357         ((ungexp thing)
 358          #'thing)
 359         ((ungexp drv-or-pkg out)
 360          #'(list drv-or-pkg out))
 361         ((ungexp-splicing lst)
 362          #'lst)
 363         ((ungexp-native thing)
 364          #'thing)
 365         ((ungexp-native drv-or-pkg out)
 366          #'(list drv-or-pkg out))
 367         ((ungexp-native-splicing lst)
 368          #'lst)))
 369
 370     (define (substitute-ungexp exp substs)
 371       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
 372       ;; the corresponding form in SUBSTS.
 373       (match (assoc exp substs)
 374         ((_ id)
 375          id)
 376         (_
 377          #'(syntax-error "error: no 'ungexp' substitution"
 378                          #'ref))))
 379
 380     (define (substitute-ungexp-splicing exp substs)
 381       (syntax-case exp ()
 382         ((exp rest ...)
 383          (match (assoc #'exp substs)
 384            ((_ id)
 385             (with-syntax ((id id))
 386               #`(append id
 387                         #,(substitute-references #'(rest ...) substs))))
 388            (_
 389             #'(syntax-error "error: no 'ungexp-splicing' substitution"
 390                             #'ref))))))
 391
 392     (define (substitute-references exp substs)
 393       ;; Return a variant of EXP where all the cars of SUBSTS have been
 394       ;; replaced by the corresponding cdr.
 395       (syntax-case exp (ungexp ungexp-native
 396                         ungexp-splicing ungexp-native-splicing)
 397         ((ungexp _ ...)
 398          (substitute-ungexp exp substs))
 399         ((ungexp-native _ ...)
 400          (substitute-ungexp exp substs))
 401         (((ungexp-splicing _ ...) rest ...)
 402          (substitute-ungexp-splicing exp substs))
 403         (((ungexp-native-splicing _ ...) rest ...)
 404          (substitute-ungexp-splicing exp substs))
 405         ((exp0 exp ...)
 406          #`(cons #,(substitute-references #'exp0 substs)
 407                  #,(substitute-references #'(exp ...) substs)))
 408         (x #''x)))
 409
 410     (syntax-case s (ungexp output)
 411       ((_ exp)
 412        (let* ((normals (delete-duplicates (collect-escapes #'exp)))
 413               (natives (delete-duplicates (collect-native-escapes #'exp)))
 414               (escapes (append normals natives))
 415               (formals (generate-temporaries escapes))
 416               (sexp    (substitute-references #'exp (zip escapes formals)))
 417               (refs    (map escape->ref normals))
 418               (nrefs   (map escape->ref natives)))
 419          #`(make-gexp (map canonicalize-reference (list #,@refs))
 420                       (map canonicalize-reference (list #,@nrefs))
 421                       (lambda #,formals
 422                         #,sexp)))))))
 423
 424 \f
 425 ;;;
 426 ;;; Convenience procedures.
 427 ;;;
 428
 429 (define (default-guile)
 430   ;; Lazily resolve 'guile-final'.  This module must not refer to (gnu …)
 431   ;; modules directly, to avoid circular dependencies, hence this hack.
 432   (module-ref (resolve-interface '(gnu packages commencement))
 433               'guile-final))
 434
 435 (define* (gexp->script name exp
 436                        #:key (modules '()) (guile (default-guile)))
 437   "Return an executable script NAME that runs EXP using GUILE with MODULES in
 438 its search path."
 439   (mlet %store-monad ((modules  (imported-modules modules))
 440                       (compiled (compiled-modules modules)))
 441     (gexp->derivation name
 442                       (gexp
 443                        (call-with-output-file (ungexp output)
 444                          (lambda (port)
 445                            ;; Note: that makes a long shebang.  When the store
 446                            ;; is /gnu/store, that fits within the 128-byte
 447                            ;; limit imposed by Linux, but that may go beyond
 448                            ;; when running tests.
 449                            (format port
 450                                    "#!~a/bin/guile --no-auto-compile~%!#~%"
 451                                    (ungexp guile))
 452                            (write
 453                             '(set! %load-path
 454                                    (cons (ungexp modules) %load-path))
 455                             port)
 456                            (write
 457                             '(set! %load-compiled-path
 458                                    (cons (ungexp compiled)
 459                                          %load-compiled-path))
 460                             port)
 461                            (write '(ungexp exp) port)
 462                            (chmod port #o555)))))))
 463
 464 (define (gexp->file name exp)
 465   "Return a derivation that builds a file NAME containing EXP."
 466   (gexp->derivation name
 467                     (gexp
 468                      (call-with-output-file (ungexp output)
 469                        (lambda (port)
 470                          (write '(ungexp exp) port))))
 471                     #:local-build? #t))
 472
 473 \f
 474 ;;;
 475 ;;; Syntactic sugar.
 476 ;;;
 477
 478 (eval-when (expand load eval)
 479   (define* (read-ungexp chr port #:optional native?)
 480     "Read an 'ungexp' or 'ungexp-splicing' form from PORT.  When NATIVE? is
 481 true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
 482     (define unquote-symbol
 483       (match (peek-char port)
 484         (#\@
 485          (read-char port)
 486          (if native?
 487              'ungexp-native-splicing
 488              'ungexp-splicing))
 489         (_
 490          (if native?
 491              'ungexp-native
 492              'ungexp))))
 493
 494     (match (read port)
 495       ((? symbol? symbol)
 496        (let ((str (symbol->string symbol)))
 497          (match (string-index-right str #\:)
 498            (#f
 499             `(,unquote-symbol ,symbol))
 500            (colon
 501             (let ((name   (string->symbol (substring str 0 colon)))
 502                   (output (substring str (+ colon 1))))
 503               `(,unquote-symbol ,name ,output))))))
 504       (x
 505        `(,unquote-symbol ,x))))
 506
 507   (define (read-gexp chr port)
 508     "Read a 'gexp' form from PORT."
 509     `(gexp ,(read port)))
 510
 511   ;; Extend the reader
 512   (read-hash-extend #\~ read-gexp)
 513   (read-hash-extend #\$ read-ungexp)
 514   (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
 515
 516 ;;; gexp.scm ends here