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.

769 lines
30 KiB

monads: Move '%store-monad' and related procedures where they belong. This turns (guix monads) into a generic module for monads, and moves the store monad and related monadic procedures in their corresponding module. * guix/monads.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file, package-file, package->derivation, package->cross-derivation, origin->derivation, imported-modules, compiled, modules, built-derivations, run-with-store): Move to... * guix/store.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file): ... here. (%guile-for-build): New variable. (run-with-store): Moved from monads.scm. Remove default value for #:guile-for-build. * guix/packages.scm (default-guile): Export. (set-guile-for-build): New procedure. (package-file, package->derivation, package->cross-derivation, origin->derivation): Moved from monads.scm. * guix/derivations.scm (%guile-for-build): Remove. (imported-modules): Rename to... (%imported-modules): ... this. (compiled-modules): Rename to... (%compiled-modules): ... this. (built-derivations, imported-modules, compiled-modules): New procedures. * gnu/services/avahi.scm, gnu/services/base.scm, gnu/services/dbus.scm, gnu/services/dmd.scm, gnu/services/networking.scm, gnu/services/ssh.scm, gnu/services/xorg.scm, gnu/system/install.scm, gnu/system/linux-initrd.scm, gnu/system/shadow.scm, guix/download.scm, guix/gexp.scm, guix/git-download.scm, guix/profiles.scm, guix/svn-download.scm, tests/monads.scm: Adjust imports accordingly. * guix/monad-repl.scm (default-guile-derivation): New procedure. (store-monad-language, run-in-store): Use it. * build-aux/hydra/gnu-system.scm (qemu-jobs): Add explicit 'set-guile-for-build' call. * guix/scripts/archive.scm (derivation-from-expression): Likewise. * guix/scripts/build.scm (options/resolve-packages): Likewise. * guix/scripts/environment.scm (guix-environment): Likewise. * guix/scripts/system.scm (guix-system): Likewise. * doc/guix.texi (The Store Monad): Adjust module names accordingly.
7 years ago
monads: Move '%store-monad' and related procedures where they belong. This turns (guix monads) into a generic module for monads, and moves the store monad and related monadic procedures in their corresponding module. * guix/monads.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file, package-file, package->derivation, package->cross-derivation, origin->derivation, imported-modules, compiled, modules, built-derivations, run-with-store): Move to... * guix/store.scm (store-return, store-bind, %store-monad, store-lift, text-file, interned-file): ... here. (%guile-for-build): New variable. (run-with-store): Moved from monads.scm. Remove default value for #:guile-for-build. * guix/packages.scm (default-guile): Export. (set-guile-for-build): New procedure. (package-file, package->derivation, package->cross-derivation, origin->derivation): Moved from monads.scm. * guix/derivations.scm (%guile-for-build): Remove. (imported-modules): Rename to... (%imported-modules): ... this. (compiled-modules): Rename to... (%compiled-modules): ... this. (built-derivations, imported-modules, compiled-modules): New procedures. * gnu/services/avahi.scm, gnu/services/base.scm, gnu/services/dbus.scm, gnu/services/dmd.scm, gnu/services/networking.scm, gnu/services/ssh.scm, gnu/services/xorg.scm, gnu/system/install.scm, gnu/system/linux-initrd.scm, gnu/system/shadow.scm, guix/download.scm, guix/gexp.scm, guix/git-download.scm, guix/profiles.scm, guix/svn-download.scm, tests/monads.scm: Adjust imports accordingly. * guix/monad-repl.scm (default-guile-derivation): New procedure. (store-monad-language, run-in-store): Use it. * build-aux/hydra/gnu-system.scm (qemu-jobs): Add explicit 'set-guile-for-build' call. * guix/scripts/archive.scm (derivation-from-expression): Likewise. * guix/scripts/build.scm (options/resolve-packages): Likewise. * guix/scripts/environment.scm (guix-environment): Likewise. * guix/scripts/system.scm (guix-system): Likewise. * doc/guix.texi (The Store Monad): Adjust module names accordingly.
7 years ago
gnu: Split (gnu packages base), adding (gnu packages commencement). * gnu/packages/base.scm (gnu-make-boot0, diffutils-boot0, findutils-boot0, %boot0-inputs, nix-system->gnu-triplet, boot-triplet, binutils-boot0, gcc-boot0, perl-boot0, linux-libre-headers-boot0, texinfo-boot0, %boot1-inputs, glibc-final-with-bootstrap-bash, cross-gcc-wrapper, static-bash-for-glibc, glibc-final, gcc-boot0-wrapped, %boot2-inputs, binutils-final, libstdc++, gcc-final, ld-wrapper-boot3, %boot3-inputs, bash-final, %boot4-inputs, guile-final, gnu-make-final, ld-wrapper, coreutils-final, grep-final, %boot5-inputs, %final-inputs, canonical-package, gcc-toolchain, gcc-toolchain-4.8, gcc-toolchain-4.9): Move to... * gnu/packages/commencement.scm: ... here. New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add it. * build-aux/check-final-inputs-self-contained.scm: Adjust accordingly. * gnu/packages/cross-base.scm: Likewise. * gnu/packages/make-bootstrap.scm: Likewise. * guix/build-system/cmake.scm (cmake-build): Likewise. * guix/build-system/gnu.scm (standard-packages, gnu-build, gnu-cross-build): Likewise. * guix/build-system/perl.scm (perl-build): Likewise. * guix/build-system/python.scm (python-build): Likewise. * guix/build-system/trivial.scm (guile-for-build): Likewise. * guix/download.scm (url-fetch): Likewise. * guix/gexp.scm (default-guile): Likewise. * guix/git-download.scm (git-fetch): Likewise. * guix/monads.scm (run-with-store): Likewise. * guix/packages.scm (default-guile): Likewise. * guix/scripts/package.scm (guix-package): Likewise. * guix/scripts/refresh.scm: Likewise. * guix/svn-download.scm (svn-fetch): Likewise. * tests/builders.scm (%bootstrap-inputs, %bootstrap-search-paths): Likewise. * tests/packages.scm ("GNU Make, bootstrap"): Likewise. * tests/guix-package.sh: Likewise. * gnu/services/base.scm: Use 'canonical-package' instead of xxx-final. * gnu/services/xorg.scm: Likewise. * gnu/system/vm.scm: Likewise. * guix/scripts/pull.scm (guix-pull): Likewise.
7 years ago
  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. (define-module (guix gexp)
  19. #:use-module (guix store)
  20. #:use-module (guix monads)
  21. #:use-module (guix derivations)
  22. #:use-module (guix packages)
  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. gexp->derivation
  32. gexp->file
  33. gexp->script
  34. text-file*
  35. imported-files
  36. imported-modules
  37. compiled-modules))
  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. ;; "G expressions".
  55. (define-record-type <gexp>
  56. (make-gexp references natives proc)
  57. gexp?
  58. (references gexp-references) ; ((DRV-OR-PKG OUTPUT) ...)
  59. (natives gexp-native-references) ; ((DRV-OR-PKG OUTPUT) ...)
  60. (proc gexp-proc)) ; procedure
  61. (define (write-gexp gexp port)
  62. "Write GEXP on PORT."
  63. (display "#<gexp " port)
  64. ;; Try to write the underlying sexp. Now, this trick doesn't work when
  65. ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
  66. ;; tries to use 'append' on that, which fails with wrong-type-arg.
  67. (false-if-exception
  68. (write (apply (gexp-proc gexp)
  69. (append (gexp-references gexp)
  70. (gexp-native-references gexp)))
  71. port))
  72. (format port " ~a>"
  73. (number->string (object-address gexp) 16)))
  74. (set-record-type-printer! <gexp> write-gexp)
  75. ;; Reference to one of the derivation's outputs, for gexps used in
  76. ;; derivations.
  77. (define-record-type <output-ref>
  78. (output-ref name)
  79. output-ref?
  80. (name output-ref-name))
  81. (define raw-derivation
  82. (store-lift derivation))
  83. (define* (lower-inputs inputs
  84. #:key system target)
  85. "Turn any package from INPUTS into a derivation for SYSTEM; return the
  86. corresponding input list as a monadic value. When TARGET is true, use it as
  87. the cross-compilation target triplet."
  88. (with-monad %store-monad
  89. (sequence %store-monad
  90. (map (match-lambda
  91. (((? package? package) sub-drv ...)
  92. (mlet %store-monad
  93. ((drv (if target
  94. (package->cross-derivation package target
  95. system)
  96. (package->derivation package system))))
  97. (return `(,drv ,@sub-drv))))
  98. (((? origin? origin) sub-drv ...)
  99. (mlet %store-monad ((drv (origin->derivation origin)))
  100. (return `(,drv ,@sub-drv))))
  101. (input
  102. (return input)))
  103. inputs))))
  104. (define* (lower-reference-graphs graphs #:key system target)
  105. "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
  106. #:reference-graphs argument, lower it such that each INPUT is replaced by the
  107. corresponding derivation."
  108. (match graphs
  109. (((file-names . inputs) ...)
  110. (mlet %store-monad ((inputs (lower-inputs inputs
  111. #:system system
  112. #:target target)))
  113. (return (map cons file-names inputs))))))
  114. (define* (lower-references lst #:key system target)
  115. "Based on LST, a list of output names and packages, return a list of output
  116. names and file names suitable for the #:allowed-references argument to
  117. 'derivation'."
  118. ;; XXX: Currently outputs other than "out" are not supported, and things
  119. ;; other than packages aren't either.
  120. (with-monad %store-monad
  121. (define lower
  122. (match-lambda
  123. ((? string? output)
  124. (return output))
  125. ((? package? package)
  126. (mlet %store-monad ((drv
  127. (if target
  128. (package->cross-derivation package target
  129. #:system system
  130. #:graft? #f)
  131. (package->derivation package system
  132. #:graft? #f))))
  133. (return (derivation->output-path drv))))))
  134. (sequence %store-monad (map lower lst))))
  135. (define* (gexp->derivation name exp
  136. #:key
  137. system (target 'current)
  138. hash hash-algo recursive?
  139. (env-vars '())
  140. (modules '())
  141. (module-path %load-path)
  142. (guile-for-build (%guile-for-build))
  143. (graft? (%graft?))
  144. references-graphs
  145. allowed-references
  146. local-build?)
  147. "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
  148. derivation) on SYSTEM. When TARGET is true, it is used as the
  149. cross-compilation target triplet for packages referred to by EXP.
  150. Make MODULES available in the evaluation context of EXP; MODULES is a list of
  151. names of Guile modules searched in MODULE-PATH to be copied in the store,
  152. compiled, and made available in the load path during the execution of
  153. EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
  154. GRAFT? determines whether packages referred to by EXP should be grafted when
  155. applicable.
  156. When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
  157. following forms:
  158. (FILE-NAME PACKAGE)
  159. (FILE-NAME PACKAGE OUTPUT)
  160. (FILE-NAME DERIVATION)
  161. (FILE-NAME DERIVATION OUTPUT)
  162. (FILE-NAME STORE-ITEM)
  163. The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
  164. an input of the build process of EXP. In the build environment, each
  165. FILE-NAME contains the reference graph of the corresponding item, in a simple
  166. text format.
  167. ALLOWED-REFERENCES must be either #f or a list of output names and packages.
  168. In the latter case, the list denotes store items that the result is allowed to
  169. refer to. Any reference to another store item will lead to a build error.
  170. The other arguments are as for 'derivation'."
  171. (define %modules modules)
  172. (define outputs (gexp-outputs exp))
  173. (define (graphs-file-names graphs)
  174. ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
  175. (map (match-lambda
  176. ((file-name (? derivation? drv))
  177. (cons file-name (derivation->output-path drv)))
  178. ((file-name (? derivation? drv) sub-drv)
  179. (cons file-name (derivation->output-path drv sub-drv)))
  180. ((file-name thing)
  181. (cons file-name thing)))
  182. graphs))
  183. (mlet* %store-monad (;; The following binding forces '%current-system' and
  184. ;; '%current-target-system' to be looked up at >>=
  185. ;; time.
  186. (graft? (set-grafting graft?))
  187. (system -> (or system (%current-system)))
  188. (target -> (if (eq? target 'current)
  189. (%current-target-system)
  190. target))
  191. (normals (lower-inputs (gexp-inputs exp)
  192. #:system system
  193. #:target target))
  194. (natives (lower-inputs (gexp-native-inputs exp)
  195. #:system system
  196. #:target #f))
  197. (inputs -> (append normals natives))
  198. (sexp (gexp->sexp exp
  199. #:system system
  200. #:target target))
  201. (builder (text-file (string-append name "-builder")
  202. (object->string sexp)))
  203. (modules (if (pair? %modules)
  204. (imported-modules %modules
  205. #:system system
  206. #:module-path module-path
  207. #:guile guile-for-build)
  208. (return #f)))
  209. (compiled (if (pair? %modules)
  210. (compiled-modules %modules
  211. #:system system
  212. #:module-path module-path
  213. #:guile guile-for-build)
  214. (return #f)))
  215. (graphs (if references-graphs
  216. (lower-reference-graphs references-graphs
  217. #:system system
  218. #:target target)
  219. (return #f)))
  220. (allowed (if allowed-references
  221. (lower-references allowed-references
  222. #:system system
  223. #:target target)
  224. (return #f)))
  225. (guile (if guile-for-build
  226. (return guile-for-build)
  227. (package->derivation (default-guile)
  228. system))))
  229. (mbegin %store-monad
  230. (set-grafting graft?) ;restore the initial setting
  231. (raw-derivation name
  232. (string-append (derivation->output-path guile)
  233. "/bin/guile")
  234. `("--no-auto-compile"
  235. ,@(if (pair? %modules)
  236. `("-L" ,(derivation->output-path modules)
  237. "-C" ,(derivation->output-path compiled))
  238. '())
  239. ,builder)
  240. #:outputs outputs
  241. #:env-vars env-vars
  242. #:system system
  243. #:inputs `((,guile)
  244. (,builder)
  245. ,@(if modules
  246. `((,modules) (,compiled) ,@inputs)
  247. inputs)
  248. ,@(match graphs
  249. (((_ . inputs) ...) inputs)
  250. (_ '())))
  251. #:hash hash #:hash-algo hash-algo #:recursive? recursive?
  252. #:references-graphs (and=> graphs graphs-file-names)
  253. #:allowed-references allowed
  254. #:local-build? local-build?))))
  255. (define* (gexp-inputs exp #:optional (references gexp-references))
  256. "Return the input list for EXP, using REFERENCES to get its list of
  257. references."
  258. (define (add-reference-inputs ref result)
  259. (match ref
  260. (((? derivation?) (? string?))
  261. (cons ref result))
  262. (((? package?) (? string?))
  263. (cons ref result))
  264. (((? origin?) (? string?))
  265. (cons ref result))
  266. ((? gexp? exp)
  267. (append (gexp-inputs exp references) result))
  268. (((? string? file))
  269. (if (direct-store-path? file)
  270. (cons ref result)
  271. result))
  272. ((refs ...)
  273. (fold-right add-reference-inputs result refs))
  274. (_
  275. ;; Ignore references to other kinds of objects.
  276. result)))
  277. (fold-right add-reference-inputs
  278. '()
  279. (references exp)))
  280. (define gexp-native-inputs
  281. (cut gexp-inputs <> gexp-native-references))
  282. (define (gexp-outputs exp)
  283. "Return the outputs referred to by EXP as a list of strings."
  284. (define (add-reference-output ref result)
  285. (match ref
  286. (($ <output-ref> name)
  287. (cons name result))
  288. ((? gexp? exp)
  289. (append (gexp-outputs exp) result))
  290. (_
  291. result)))
  292. (fold-right add-reference-output
  293. '()
  294. (gexp-references exp)))
  295. (define* (gexp->sexp exp #:key
  296. (system (%current-system))
  297. (target (%current-target-system)))
  298. "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
  299. and in the current monad setting (system type, etc.)"
  300. (define* (reference->sexp ref #:optional native?)
  301. (with-monad %store-monad
  302. (match ref
  303. (((? derivation? drv) (? string? output))
  304. (return (derivation->output-path drv output)))
  305. (((? package? p) (? string? output))
  306. (package-file p
  307. #:output output
  308. #:system system
  309. #:target (if native? #f target)))
  310. (((? origin? o) (? string? output))
  311. (mlet %store-monad ((drv (origin->derivation o)))
  312. (return (derivation->output-path drv output))))
  313. (($ <output-ref> output)
  314. ;; Output file names are not known in advance but the daemon defines
  315. ;; an environment variable for each of them at build time, so use
  316. ;; that trick.
  317. (return `((@ (guile) getenv) ,output)))
  318. ((? gexp? exp)
  319. (gexp->sexp exp
  320. #:system system
  321. #:target (if native? #f target)))
  322. (((? string? str))
  323. (return (if (direct-store-path? str) str ref)))
  324. ((refs ...)
  325. (sequence %store-monad
  326. (map (cut reference->sexp <> native?) refs)))
  327. (x
  328. (return x)))))
  329. (mlet %store-monad
  330. ((args (sequence %store-monad
  331. (append (map reference->sexp (gexp-references exp))
  332. (map (cut reference->sexp <> #t)
  333. (gexp-native-references exp))))))
  334. (return (apply (gexp-proc exp) args))))
  335. (define (canonicalize-reference ref)
  336. "Return a canonical variant of REF, which adds any missing output part in
  337. package/derivation references."
  338. (match ref
  339. ((? package? p)
  340. `(,p "out"))
  341. ((? origin? o)
  342. `(,o "out"))
  343. ((? derivation? d)
  344. `(,d "out"))
  345. (((? package?) (? string?))
  346. ref)
  347. (((? origin?) (? string?))
  348. ref)
  349. (((? derivation?) (? string?))
  350. ref)
  351. ((? string? s)
  352. (if (direct-store-path? s) `(,s) s))
  353. ((refs ...)
  354. (map canonicalize-reference refs))
  355. (x x)))
  356. (define (syntax-location-string s)
  357. "Return a string representing the source code location of S."
  358. (let ((props (syntax-source s)))
  359. (if props
  360. (let ((file (assoc-ref props 'filename))
  361. (line (and=> (assoc-ref props 'line) 1+))
  362. (column (assoc-ref props 'column)))
  363. (if file
  364. (simple-format #f "~a:~a:~a"
  365. file line column)
  366. (simple-format #f "~a:~a" line column)))
  367. "<unknown location>")))
  368. (define-syntax gexp
  369. (lambda (s)
  370. (define (collect-escapes exp)
  371. ;; Return all the 'ungexp' present in EXP.
  372. (let loop ((exp exp)
  373. (result '()))
  374. (syntax-case exp (ungexp ungexp-splicing)
  375. ((ungexp _)
  376. (cons exp result))
  377. ((ungexp _ _)
  378. (cons exp result))
  379. ((ungexp-splicing _ ...)
  380. (cons exp result))
  381. ((exp0 exp ...)
  382. (let ((result (loop #'exp0 result)))
  383. (fold loop result #'(exp ...))))
  384. (_
  385. result))))
  386. (define (collect-native-escapes exp)
  387. ;; Return all the 'ungexp-native' forms present in EXP.
  388. (let loop ((exp exp)
  389. (result '()))
  390. (syntax-case exp (ungexp-native ungexp-native-splicing)
  391. ((ungexp-native _)
  392. (cons exp result))
  393. ((ungexp-native _ _)
  394. (cons exp result))
  395. ((ungexp-native-splicing _ ...)
  396. (cons exp result))
  397. ((exp0 exp ...)
  398. (let ((result (loop #'exp0 result)))
  399. (fold loop result #'(exp ...))))
  400. (_
  401. result))))
  402. (define (escape->ref exp)
  403. ;; Turn 'ungexp' form EXP into a "reference".
  404. (syntax-case exp (ungexp ungexp-splicing
  405. ungexp-native ungexp-native-splicing
  406. output)
  407. ((ungexp output)
  408. #'(output-ref "out"))
  409. ((ungexp output name)
  410. #'(output-ref name))
  411. ((ungexp thing)
  412. #'thing)
  413. ((ungexp drv-or-pkg out)
  414. #'(list drv-or-pkg out))
  415. ((ungexp-splicing lst)
  416. #'lst)
  417. ((ungexp-native thing)
  418. #'thing)
  419. ((ungexp-native drv-or-pkg out)
  420. #'(list drv-or-pkg out))
  421. ((ungexp-native-splicing lst)
  422. #'lst)))
  423. (define (substitute-ungexp exp substs)
  424. ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
  425. ;; the corresponding form in SUBSTS.
  426. (match (assoc exp substs)
  427. ((_ id)
  428. id)
  429. (_
  430. #'(syntax-error "error: no 'ungexp' substitution"
  431. #'ref))))
  432. (define (substitute-ungexp-splicing exp substs)
  433. (syntax-case exp ()
  434. ((exp rest ...)
  435. (match (assoc #'exp substs)
  436. ((_ id)
  437. (with-syntax ((id id))
  438. #`(append id
  439. #,(substitute-references #'(rest ...) substs))))
  440. (_
  441. #'(syntax-error "error: no 'ungexp-splicing' substitution"
  442. #'ref))))))
  443. (define (substitute-references exp substs)
  444. ;; Return a variant of EXP where all the cars of SUBSTS have been
  445. ;; replaced by the corresponding cdr.
  446. (syntax-case exp (ungexp ungexp-native
  447. ungexp-splicing ungexp-native-splicing)
  448. ((ungexp _ ...)
  449. (substitute-ungexp exp substs))
  450. ((ungexp-native _ ...)
  451. (substitute-ungexp exp substs))
  452. (((ungexp-splicing _ ...) rest ...)
  453. (substitute-ungexp-splicing exp substs))
  454. (((ungexp-native-splicing _ ...) rest ...)
  455. (substitute-ungexp-splicing exp substs))
  456. ((exp0 exp ...)
  457. #`(cons #,(substitute-references #'exp0 substs)
  458. #,(substitute-references #'(exp ...) substs)))
  459. (x #''x)))
  460. (syntax-case s (ungexp output)
  461. ((_ exp)
  462. (let* ((normals (delete-duplicates (collect-escapes #'exp)))
  463. (natives (delete-duplicates (collect-native-escapes #'exp)))
  464. (escapes (append normals natives))
  465. (formals (generate-temporaries escapes))
  466. (sexp (substitute-references #'exp (zip escapes formals)))
  467. (refs (map escape->ref normals))
  468. (nrefs (map escape->ref natives)))
  469. #`(make-gexp (map canonicalize-reference (list #,@refs))
  470. (map canonicalize-reference (list #,@nrefs))
  471. (lambda #,formals
  472. #,sexp)))))))
  473. ;;;
  474. ;;; Module handling.
  475. ;;;
  476. (define %mkdir-p-definition
  477. ;; The code for 'mkdir-p' is copied from (guix build utils). We use it in
  478. ;; derivations that cannot use the #:modules argument of 'gexp->derivation'
  479. ;; precisely because they implement that functionality.
  480. (gexp
  481. (define (mkdir-p dir)
  482. (define absolute?
  483. (string-prefix? "/" dir))
  484. (define not-slash
  485. (char-set-complement (char-set #\/)))
  486. (let loop ((components (string-tokenize dir not-slash))
  487. (root (if absolute? "" ".")))
  488. (match components
  489. ((head tail ...)
  490. (let ((path (string-append root "/" head)))
  491. (catch 'system-error
  492. (lambda ()
  493. (mkdir path)
  494. (loop tail path))
  495. (lambda args
  496. (if (= EEXIST (system-error-errno args))
  497. (loop tail path)
  498. (apply throw args))))))
  499. (() #t))))))
  500. (define* (imported-files files
  501. #:key (name "file-import")
  502. (system (%current-system))
  503. (guile (%guile-for-build)))
  504. "Return a derivation that imports FILES into STORE. FILES must be a list
  505. of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
  506. system, imported, and appears under FINAL-PATH in the resulting store path."
  507. (define file-pair
  508. (match-lambda
  509. ((final-path . file-name)
  510. (mlet %store-monad ((file (interned-file file-name
  511. (basename final-path))))
  512. (return (list final-path file))))))
  513. (mlet %store-monad ((files (sequence %store-monad
  514. (map file-pair files))))
  515. (define build
  516. (gexp
  517. (begin
  518. (use-modules (ice-9 match))
  519. (ungexp %mkdir-p-definition)
  520. (mkdir (ungexp output)) (chdir (ungexp output))
  521. (for-each (match-lambda
  522. ((final-path store-path)
  523. (mkdir-p (dirname final-path))
  524. (symlink store-path final-path)))
  525. '(ungexp files)))))
  526. ;; TODO: Pass FILES as an environment variable so that BUILD remains
  527. ;; exactly the same regardless of FILES: less disk space, and fewer
  528. ;; 'add-to-store' RPCs.
  529. (gexp->derivation name build
  530. #:system system
  531. #:guile-for-build guile
  532. #:local-build? #t)))
  533. (define search-path*
  534. ;; A memoizing version of 'search-path' so 'imported-modules' does not end
  535. ;; up looking for the same files over and over again.
  536. (memoize search-path))
  537. (define* (imported-modules modules
  538. #:key (name "module-import")
  539. (system (%current-system))
  540. (guile (%guile-for-build))
  541. (module-path %load-path))
  542. "Return a derivation that contains the source files of MODULES, a list of
  543. module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH
  544. search path."
  545. ;; TODO: Determine the closure of MODULES, build the `.go' files,
  546. ;; canonicalize the source files through read/write, etc.
  547. (let ((files (map (lambda (m)
  548. (let ((f (string-append
  549. (string-join (map symbol->string m) "/")
  550. ".scm")))
  551. (cons f (search-path* module-path f))))
  552. modules)))
  553. (imported-files files #:name name #:system system
  554. #:guile guile)))
  555. (define* (compiled-modules modules
  556. #:key (name "module-import-compiled")
  557. (system (%current-system))
  558. (guile (%guile-for-build))
  559. (module-path %load-path))
  560. "Return a derivation that builds a tree containing the `.go' files
  561. corresponding to MODULES. All the MODULES are built in a context where
  562. they can refer to each other."
  563. (mlet %store-monad ((modules (imported-modules modules
  564. #:system system
  565. #:guile guile
  566. #:module-path
  567. module-path)))
  568. (define build
  569. (gexp
  570. (begin
  571. (use-modules (ice-9 ftw)
  572. (ice-9 match)
  573. (srfi srfi-26)
  574. (system base compile))
  575. (ungexp %mkdir-p-definition)
  576. (define (regular? file)
  577. (not (member file '("." ".."))))
  578. (define (process-directory directory output)
  579. (let ((entries (map (cut string-append directory "/" <>)
  580. (scandir directory regular?))))
  581. (for-each (lambda (entry)
  582. (if (file-is-directory? entry)
  583. (let ((output (string-append output "/"
  584. (basename entry))))
  585. (mkdir-p output)
  586. (process-directory entry output))
  587. (let* ((base (string-drop-right
  588. (basename entry)
  589. 4)) ;.scm
  590. (output (string-append output "/" base
  591. ".go")))
  592. (compile-file entry
  593. #:output-file output
  594. #:opts
  595. %auto-compilation-options))))
  596. entries)))
  597. (set! %load-path (cons (ungexp modules) %load-path))
  598. (mkdir (ungexp output))
  599. (chdir (ungexp modules))
  600. (process-directory "." (ungexp output)))))
  601. ;; TODO: Pass MODULES as an environment variable.
  602. (gexp->derivation name build
  603. #:system system
  604. #:guile-for-build guile
  605. #:local-build? #t)))
  606. ;;;
  607. ;;; Convenience procedures.
  608. ;;;
  609. (define (default-guile)
  610. ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …)
  611. ;; modules directly, to avoid circular dependencies, hence this hack.
  612. (module-ref (resolve-interface '(gnu packages commencement))
  613. 'guile-final))
  614. (define* (gexp->script name exp
  615. #:key (modules '()) (guile (default-guile)))
  616. "Return an executable script NAME that runs EXP using GUILE with MODULES in
  617. its search path."
  618. (mlet %store-monad ((modules (imported-modules modules))
  619. (compiled (compiled-modules modules)))
  620. (gexp->derivation name
  621. (gexp
  622. (call-with-output-file (ungexp output)
  623. (lambda (port)
  624. ;; Note: that makes a long shebang. When the store
  625. ;; is /gnu/store, that fits within the 128-byte
  626. ;; limit imposed by Linux, but that may go beyond
  627. ;; when running tests.
  628. (format port
  629. "#!~a/bin/guile --no-auto-compile~%!#~%"
  630. (ungexp guile))
  631. ;; Write the 'eval-when' form so that it can be
  632. ;; compiled.
  633. (write
  634. '(eval-when (expand load eval)
  635. (set! %load-path
  636. (cons (ungexp modules) %load-path))
  637. (set! %load-compiled-path
  638. (cons (ungexp compiled)
  639. %load-compiled-path)))
  640. port)
  641. (write '(ungexp exp) port)
  642. (chmod port #o555)))))))
  643. (define (gexp->file name exp)
  644. "Return a derivation that builds a file NAME containing EXP."
  645. (gexp->derivation name
  646. (gexp
  647. (call-with-output-file (ungexp output)
  648. (lambda (port)
  649. (write '(ungexp exp) port))))
  650. #:local-build? #t))
  651. (define* (text-file* name #:rest text)
  652. "Return as a monadic value a derivation that builds a text file containing
  653. all of TEXT. TEXT may list, in addition to strings, packages, derivations,
  654. and store file names; the resulting store file holds references to all these."
  655. (define builder
  656. (gexp (call-with-output-file (ungexp output "out")
  657. (lambda (port)
  658. (display (string-append (ungexp-splicing text)) port)))))
  659. (gexp->derivation name builder))
  660. ;;;
  661. ;;; Syntactic sugar.
  662. ;;;
  663. (eval-when (expand load eval)
  664. (define* (read-ungexp chr port #:optional native?)
  665. "Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is
  666. true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
  667. (define unquote-symbol
  668. (match (peek-char port)
  669. (#\@
  670. (read-char port)
  671. (if native?
  672. 'ungexp-native-splicing
  673. 'ungexp-splicing))
  674. (_
  675. (if native?
  676. 'ungexp-native
  677. 'ungexp))))
  678. (match (read port)
  679. ((? symbol? symbol)
  680. (let ((str (symbol->string symbol)))
  681. (match (string-index-right str #\:)
  682. (#f
  683. `(,unquote-symbol ,symbol))
  684. (colon
  685. (let ((name (string->symbol (substring str 0 colon)))
  686. (output (substring str (+ colon 1))))
  687. `(,unquote-symbol ,name ,output))))))
  688. (x
  689. `(,unquote-symbol ,x))))
  690. (define (read-gexp chr port)
  691. "Read a 'gexp' form from PORT."
  692. `(gexp ,(read port)))
  693. ;; Extend the reader
  694. (read-hash-extend #\~ read-gexp)
  695. (read-hash-extend #\$ read-ungexp)
  696. (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
  697. ;;; gexp.scm ends here