You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

566 lines
22 KiB

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