Commit | Line | Data |
---|---|---|
b860f382 | 1 | ;;; GNU Guix --- Functional package management for GNU |
413d5351 | 2 | ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> |
b860f382 LC |
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 monads) | |
b860f382 LC |
20 | #:use-module (guix store) |
21 | #:use-module (guix derivations) | |
22 | #:use-module (guix packages) | |
aeb7ec5c LC |
23 | #:use-module ((system syntax) |
24 | #:select (syntax-local-binding)) | |
b860f382 | 25 | #:use-module (ice-9 match) |
45adbd62 | 26 | #:use-module (srfi srfi-1) |
aeb7ec5c | 27 | #:use-module (srfi srfi-9) |
b860f382 LC |
28 | #:use-module (srfi srfi-26) |
29 | #:export (;; Monads. | |
aeb7ec5c | 30 | define-monad |
b860f382 LC |
31 | monad? |
32 | monad-bind | |
33 | monad-return | |
34 | ||
35 | ;; Syntax. | |
36 | >>= | |
37 | return | |
38 | with-monad | |
39 | mlet | |
40 | mlet* | |
405a9d4e | 41 | mbegin |
21caa6de LC |
42 | mwhen |
43 | munless | |
b860f382 LC |
44 | lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift |
45 | listm | |
46 | foldm | |
47 | mapm | |
48 | sequence | |
49 | anym | |
50 | ||
51 | ;; Concrete monads. | |
52 | %identity-monad | |
53 | ||
54 | %store-monad | |
55 | store-bind | |
56 | store-return | |
57 | store-lift | |
58 | run-with-store | |
59 | text-file | |
45adbd62 | 60 | text-file* |
0a90af15 | 61 | interned-file |
b860f382 | 62 | package-file |
79c0c8cd | 63 | origin->derivation |
b860f382 | 64 | package->derivation |
4231f05b | 65 | package->cross-derivation |
ada3df03 | 66 | built-derivations) |
413d5351 LC |
67 | #:replace (imported-modules |
68 | compiled-modules)) | |
b860f382 LC |
69 | |
70 | ;;; Commentary: | |
71 | ;;; | |
72 | ;;; This module implements the general mechanism of monads, and provides in | |
73 | ;;; particular an instance of the "store" monad. The API was inspired by that | |
74 | ;;; of Racket's "better-monads" module (see | |
75 | ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>). | |
76 | ;;; The implementation and use case were influenced by Oleg Kysielov's | |
77 | ;;; "Monadic Programming in Scheme" (see | |
78 | ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>). | |
79 | ;;; | |
80 | ;;; The store monad allows us to (1) build sequences of operations in the | |
81 | ;;; store, and (2) make the store an implicit part of the execution context, | |
82 | ;;; rather than a parameter of every single function. | |
83 | ;;; | |
84 | ;;; Code: | |
85 | ||
aeb7ec5c LC |
86 | ;; Record type for monads manipulated at run time. |
87 | (define-record-type <monad> | |
88 | (make-monad bind return) | |
b860f382 LC |
89 | monad? |
90 | (bind monad-bind) | |
91 | (return monad-return)) ; TODO: Add 'plus' and 'zero' | |
92 | ||
aeb7ec5c LC |
93 | (define-syntax define-monad |
94 | (lambda (s) | |
95 | "Define the monad under NAME, with the given bind and return methods." | |
96 | (define prefix (string->symbol "% ")) | |
97 | (define (make-rtd-name name) | |
98 | (datum->syntax name | |
99 | (symbol-append prefix (syntax->datum name) '-rtd))) | |
100 | ||
101 | (syntax-case s (bind return) | |
102 | ((_ name (bind b) (return r)) | |
103 | (with-syntax ((rtd (make-rtd-name #'name))) | |
104 | #`(begin | |
105 | (define rtd | |
106 | ;; The record type, for use at run time. | |
107 | (make-monad b r)) | |
108 | ||
109 | (define-syntax name | |
110 | ;; An "inlined record", for use at expansion time. The goal is | |
111 | ;; to allow 'bind' and 'return' to be resolved at expansion | |
112 | ;; time, in the common case where the monad is accessed | |
113 | ;; directly as NAME. | |
114 | (lambda (s) | |
115 | (syntax-case s (%bind %return) | |
116 | ((_ %bind) #'b) | |
117 | ((_ %return) #'r) | |
118 | (_ #'rtd)))))))))) | |
119 | ||
b860f382 LC |
120 | (define-syntax-parameter >>= |
121 | ;; The name 'bind' is already taken, so we choose this (obscure) symbol. | |
122 | (lambda (s) | |
123 | (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) | |
124 | ||
125 | (define-syntax-parameter return | |
126 | (lambda (s) | |
127 | (syntax-violation 'return "return used outside of 'with-monad'" s))) | |
128 | ||
129 | (define-syntax with-monad | |
130 | (lambda (s) | |
131 | "Evaluate BODY in the context of MONAD, and return its result." | |
132 | (syntax-case s () | |
133 | ((_ monad body ...) | |
aeb7ec5c LC |
134 | (eq? 'macro (syntax-local-binding #'monad)) |
135 | ;; MONAD is a syntax transformer, so we can obtain the bind and return | |
136 | ;; methods by directly querying it. | |
137 | #'(syntax-parameterize ((>>= (identifier-syntax (monad %bind))) | |
138 | (return (identifier-syntax (monad %return)))) | |
139 | body ...)) | |
140 | ((_ monad body ...) | |
141 | ;; MONAD refers to the <monad> record that represents the monad at run | |
142 | ;; time, so use the slow method. | |
b860f382 LC |
143 | #'(syntax-parameterize ((>>= (identifier-syntax |
144 | (monad-bind monad))) | |
145 | (return (identifier-syntax | |
146 | (monad-return monad)))) | |
147 | body ...))))) | |
148 | ||
149 | (define-syntax mlet* | |
150 | (syntax-rules (->) | |
151 | "Bind the given monadic values MVAL to the given variables VAR. When the | |
152 | form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as | |
153 | 'let'." | |
154 | ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'. | |
155 | ((_ monad () body ...) | |
156 | (with-monad monad body ...)) | |
157 | ((_ monad ((var mval) rest ...) body ...) | |
158 | (with-monad monad | |
159 | (>>= mval | |
160 | (lambda (var) | |
161 | (mlet* monad (rest ...) | |
162 | body ...))))) | |
163 | ((_ monad ((var -> val) rest ...) body ...) | |
164 | (let ((var val)) | |
165 | (mlet* monad (rest ...) | |
166 | body ...))))) | |
167 | ||
168 | (define-syntax mlet | |
169 | (lambda (s) | |
170 | (syntax-case s () | |
171 | ((_ monad ((var mval ...) ...) body ...) | |
172 | (with-syntax (((temp ...) (generate-temporaries #'(var ...)))) | |
173 | #'(mlet* monad ((temp mval ...) ...) | |
174 | (let ((var temp) ...) | |
175 | body ...))))))) | |
176 | ||
405a9d4e | 177 | (define-syntax mbegin |
21caa6de | 178 | (syntax-rules (%current-monad) |
405a9d4e LC |
179 | "Bind the given monadic expressions in sequence, returning the result of |
180 | the last one." | |
21caa6de LC |
181 | ((_ %current-monad mexp) |
182 | mexp) | |
183 | ((_ %current-monad mexp rest ...) | |
184 | (>>= mexp | |
185 | (lambda (unused-value) | |
186 | (mbegin %current-monad rest ...)))) | |
405a9d4e LC |
187 | ((_ monad mexp) |
188 | (with-monad monad | |
189 | mexp)) | |
190 | ((_ monad mexp rest ...) | |
191 | (with-monad monad | |
192 | (>>= mexp | |
193 | (lambda (unused-value) | |
194 | (mbegin monad rest ...))))))) | |
195 | ||
21caa6de LC |
196 | (define-syntax mwhen |
197 | (syntax-rules () | |
198 | "When CONDITION is true, evaluate EXP0..EXP* as in an 'mbegin'. When | |
199 | CONDITION is false, return *unspecified* in the current monad." | |
200 | ((_ condition exp0 exp* ...) | |
201 | (if condition | |
202 | (mbegin %current-monad | |
203 | exp0 exp* ...) | |
204 | (return *unspecified*))))) | |
205 | ||
206 | (define-syntax munless | |
207 | (syntax-rules () | |
208 | "When CONDITION is false, evaluate EXP0..EXP* as in an 'mbegin'. When | |
209 | CONDITION is true, return *unspecified* in the current monad." | |
210 | ((_ condition exp0 exp* ...) | |
211 | (if condition | |
212 | (return *unspecified*) | |
213 | (mbegin %current-monad | |
214 | exp0 exp* ...))))) | |
215 | ||
b860f382 LC |
216 | (define-syntax define-lift |
217 | (syntax-rules () | |
218 | ((_ liftn (args ...)) | |
219 | (define (liftn proc monad) | |
220 | "Lift PROC to MONAD---i.e., return a monadic function in MONAD." | |
221 | (lambda (args ...) | |
222 | (with-monad monad | |
223 | (return (proc args ...)))))))) | |
224 | ||
225 | (define-lift lift1 (a)) | |
226 | (define-lift lift2 (a b)) | |
227 | (define-lift lift3 (a b c)) | |
228 | (define-lift lift4 (a b c d)) | |
229 | (define-lift lift5 (a b c d e)) | |
230 | (define-lift lift6 (a b c d e f)) | |
231 | (define-lift lift7 (a b c d e f g)) | |
232 | ||
e4bed284 LC |
233 | (define (lift proc monad) |
234 | "Lift PROC, a procedure that accepts an arbitrary number of arguments, to | |
235 | MONAD---i.e., return a monadic function in MONAD." | |
b860f382 LC |
236 | (lambda args |
237 | (with-monad monad | |
238 | (return (apply proc args))))) | |
239 | ||
240 | (define (foldm monad mproc init lst) | |
241 | "Fold MPROC over LST, a list of monadic values in MONAD, and return a | |
242 | monadic value seeded by INIT." | |
243 | (with-monad monad | |
244 | (let loop ((lst lst) | |
245 | (result init)) | |
246 | (match lst | |
247 | (() | |
248 | (return result)) | |
249 | ((head tail ...) | |
250 | (mlet* monad ((item head) | |
251 | (result (mproc item result))) | |
252 | (loop tail result))))))) | |
253 | ||
254 | (define (mapm monad mproc lst) | |
255 | "Map MPROC over LST, a list of monadic values in MONAD, and return a monadic | |
f62435e2 LC |
256 | list. LST items are bound from left to right, so effects in MONAD are known |
257 | to happen in that order." | |
258 | (mlet monad ((result (foldm monad | |
259 | (lambda (item result) | |
260 | (mlet monad ((item (mproc item))) | |
261 | (return (cons item result)))) | |
262 | '() | |
263 | lst))) | |
264 | (return (reverse result)))) | |
b860f382 LC |
265 | |
266 | (define-inlinable (sequence monad lst) | |
267 | "Turn the list of monadic values LST into a monadic list of values, by | |
268 | evaluating each item of LST in sequence." | |
b860f382 LC |
269 | (with-monad monad |
270 | (mapm monad return lst))) | |
271 | ||
272 | (define (anym monad proc lst) | |
273 | "Apply PROC to the list of monadic values LST; return the first value, | |
274 | lifted in MONAD, for which PROC returns true." | |
275 | (with-monad monad | |
276 | (let loop ((lst lst)) | |
277 | (match lst | |
278 | (() | |
279 | (return #f)) | |
280 | ((head tail ...) | |
593c3fe6 LC |
281 | (mlet* monad ((value head) |
282 | (result -> (proc value))) | |
283 | (if result | |
284 | (return result) | |
b860f382 LC |
285 | (loop tail)))))))) |
286 | ||
287 | (define-syntax listm | |
288 | (lambda (s) | |
289 | "Return a monadic list in MONAD from the monadic values MVAL." | |
290 | (syntax-case s () | |
291 | ((_ monad mval ...) | |
292 | (with-syntax (((val ...) (generate-temporaries #'(mval ...)))) | |
293 | #'(mlet monad ((val mval) ...) | |
294 | (return (list val ...)))))))) | |
295 | ||
296 | ||
297 | \f | |
298 | ;;; | |
299 | ;;; Identity monad. | |
300 | ;;; | |
301 | ||
aeb7ec5c | 302 | (define-inlinable (identity-return value) |
b860f382 LC |
303 | value) |
304 | ||
aeb7ec5c | 305 | (define-inlinable (identity-bind mvalue mproc) |
b860f382 LC |
306 | (mproc mvalue)) |
307 | ||
aeb7ec5c LC |
308 | (define-monad %identity-monad |
309 | (bind identity-bind) | |
310 | (return identity-return)) | |
b860f382 LC |
311 | |
312 | \f | |
313 | ;;; | |
314 | ;;; Store monad. | |
315 | ;;; | |
316 | ||
317 | ;; return:: a -> StoreM a | |
aeb7ec5c | 318 | (define-inlinable (store-return value) |
b860f382 LC |
319 | "Return VALUE from a monadic function." |
320 | ;; The monadic value is just this. | |
321 | (lambda (store) | |
322 | value)) | |
323 | ||
324 | ;; >>=:: StoreM a -> (a -> StoreM b) -> StoreM b | |
aeb7ec5c LC |
325 | (define-inlinable (store-bind mvalue mproc) |
326 | "Bind MVALUE in MPROC." | |
b860f382 LC |
327 | (lambda (store) |
328 | (let* ((value (mvalue store)) | |
329 | (mresult (mproc value))) | |
330 | (mresult store)))) | |
331 | ||
aeb7ec5c LC |
332 | (define-monad %store-monad |
333 | (bind store-bind) | |
334 | (return store-return)) | |
b860f382 LC |
335 | |
336 | ||
337 | (define (store-lift proc) | |
338 | "Lift PROC, a procedure whose first argument is a connection to the store, | |
339 | in the store monad." | |
340 | (define result | |
341 | (lambda args | |
342 | (lambda (store) | |
343 | (apply proc store args)))) | |
344 | ||
345 | (set-object-property! result 'documentation | |
346 | (procedure-property proc 'documentation)) | |
347 | result) | |
348 | ||
349 | ;;; | |
350 | ;;; Store monad operators. | |
351 | ;;; | |
352 | ||
353 | (define* (text-file name text) | |
354 | "Return as a monadic value the absolute file name in the store of the file | |
45adbd62 | 355 | containing TEXT, a string." |
b860f382 LC |
356 | (lambda (store) |
357 | (add-text-to-store store name text '()))) | |
358 | ||
45adbd62 LC |
359 | (define* (text-file* name #:rest text) |
360 | "Return as a monadic value a derivation that builds a text file containing | |
361 | all of TEXT. TEXT may list, in addition to strings, packages, derivations, | |
362 | and store file names; the resulting store file holds references to all these." | |
363 | (define inputs | |
364 | ;; Transform packages and derivations from TEXT into a valid input list. | |
365 | (filter-map (match-lambda | |
366 | ((? package? p) `("x" ,p)) | |
367 | ((? derivation? d) `("x" ,d)) | |
368 | ((x ...) `("x" ,@x)) | |
369 | ((? string? s) | |
370 | (and (direct-store-path? s) `("x" ,s))) | |
371 | (x x)) | |
372 | text)) | |
373 | ||
374 | (define (computed-text text inputs) | |
375 | ;; Using the lowered INPUTS, return TEXT with derivations replaced with | |
376 | ;; their output file name. | |
377 | (define (real-string? s) | |
378 | (and (string? s) (not (direct-store-path? s)))) | |
379 | ||
380 | (let loop ((inputs inputs) | |
381 | (text text) | |
382 | (result '())) | |
383 | (match text | |
384 | (() | |
385 | (string-concatenate-reverse result)) | |
386 | (((? real-string? head) rest ...) | |
387 | (loop inputs rest (cons head result))) | |
388 | ((_ rest ...) | |
389 | (match inputs | |
390 | (((_ (? derivation? drv) sub-drv ...) inputs ...) | |
391 | (loop inputs rest | |
392 | (cons (apply derivation->output-path drv | |
393 | sub-drv) | |
394 | result))) | |
395 | (((_ file) inputs ...) | |
396 | ;; FILE is the result of 'add-text-to-store' or so. | |
397 | (loop inputs rest (cons file result)))))))) | |
398 | ||
399 | (define (builder inputs) | |
400 | `(call-with-output-file (assoc-ref %outputs "out") | |
401 | (lambda (port) | |
402 | (display ,(computed-text text inputs) port)))) | |
403 | ||
ada3df03 | 404 | ;; TODO: Rewrite using 'gexp->derivation'. |
45adbd62 LC |
405 | (mlet %store-monad ((inputs (lower-inputs inputs))) |
406 | (derivation-expression name (builder inputs) | |
407 | #:inputs inputs))) | |
408 | ||
0a90af15 LC |
409 | (define* (interned-file file #:optional name |
410 | #:key (recursive? #t)) | |
411 | "Return the name of FILE once interned in the store. Use NAME as its store | |
412 | name, or the basename of FILE if NAME is omitted. | |
413 | ||
414 | When RECURSIVE? is true, the contents of FILE are added recursively; if FILE | |
415 | designates a flat file and RECURSIVE? is true, its contents are added, and its | |
416 | permission bits are kept." | |
417 | (lambda (store) | |
418 | (add-to-store store (or name (basename file)) | |
419 | recursive? "sha256" file))) | |
420 | ||
b860f382 LC |
421 | (define* (package-file package |
422 | #:optional file | |
4231f05b | 423 | #:key |
c90ddc8f | 424 | system (output "out") target) |
413d5351 | 425 | "Return as a monadic value the absolute file name of FILE within the |
b860f382 | 426 | OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the |
4231f05b LC |
427 | OUTPUT directory of PACKAGE. When TARGET is true, use it as a |
428 | cross-compilation target triplet." | |
b860f382 | 429 | (lambda (store) |
4231f05b LC |
430 | (define compute-derivation |
431 | (if target | |
432 | (cut package-cross-derivation <> <> target <>) | |
433 | package-derivation)) | |
434 | ||
435 | (let* ((system (or system (%current-system))) | |
436 | (drv (compute-derivation store package system)) | |
437 | (out (derivation->output-path drv output))) | |
b860f382 LC |
438 | (if file |
439 | (string-append out "/" file) | |
440 | out)))) | |
441 | ||
033adfe7 LC |
442 | (define (lower-inputs inputs) |
443 | "Turn any package from INPUTS into a derivation; return the corresponding | |
444 | input list as a monadic value." | |
ada3df03 | 445 | ;; XXX: This procedure is bound to disappear with 'derivation-expression'. |
033adfe7 LC |
446 | (with-monad %store-monad |
447 | (sequence %store-monad | |
448 | (map (match-lambda | |
449 | ((name (? package? package) sub-drv ...) | |
450 | (mlet %store-monad ((drv (package->derivation package))) | |
451 | (return `(,name ,drv ,@sub-drv)))) | |
452 | ((name (? string? file)) | |
453 | (return `(,name ,file))) | |
454 | (tuple | |
455 | (return tuple))) | |
456 | inputs)))) | |
457 | ||
b860f382 | 458 | (define derivation-expression |
ada3df03 | 459 | ;; XXX: This procedure is superseded by 'gexp->derivation'. |
b860f382 LC |
460 | (store-lift build-expression->derivation)) |
461 | ||
462 | (define package->derivation | |
463 | (store-lift package-derivation)) | |
464 | ||
4231f05b LC |
465 | (define package->cross-derivation |
466 | (store-lift package-cross-derivation)) | |
467 | ||
79c0c8cd LC |
468 | (define origin->derivation |
469 | (store-lift package-source-derivation)) | |
470 | ||
413d5351 LC |
471 | (define imported-modules |
472 | (store-lift (@ (guix derivations) imported-modules))) | |
473 | ||
474 | (define compiled-modules | |
475 | (store-lift (@ (guix derivations) compiled-modules))) | |
476 | ||
b860f382 LC |
477 | (define built-derivations |
478 | (store-lift build-derivations)) | |
479 | ||
480 | (define* (run-with-store store mval | |
481 | #:key | |
482 | (guile-for-build (%guile-for-build)) | |
483 | (system (%current-system))) | |
484 | "Run MVAL, a monadic value in the store monad, in STORE, an open store | |
485 | connection." | |
53e89b17 LC |
486 | (define (default-guile) |
487 | ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …) | |
488 | ;; modules directly, to avoid circular dependencies, hence this hack. | |
bdb36958 | 489 | (module-ref (resolve-interface '(gnu packages commencement)) |
53e89b17 LC |
490 | 'guile-final)) |
491 | ||
b860f382 LC |
492 | (parameterize ((%guile-for-build (or guile-for-build |
493 | (package-derivation store | |
53e89b17 | 494 | (default-guile) |
b860f382 LC |
495 | system))) |
496 | (%current-system system)) | |
497 | (mval store))) | |
498 | ||
499 | ;;; monads.scm end here |