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) |
aeb7ec5c | 26 | #:use-module (srfi srfi-9) |
b860f382 LC |
27 | #:use-module (srfi srfi-26) |
28 | #:export (;; Monads. | |
aeb7ec5c | 29 | define-monad |
b860f382 LC |
30 | monad? |
31 | monad-bind | |
32 | monad-return | |
33 | ||
34 | ;; Syntax. | |
35 | >>= | |
36 | return | |
37 | with-monad | |
38 | mlet | |
39 | mlet* | |
40 | lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift | |
41 | listm | |
42 | foldm | |
43 | mapm | |
44 | sequence | |
45 | anym | |
46 | ||
47 | ;; Concrete monads. | |
48 | %identity-monad | |
49 | ||
50 | %store-monad | |
51 | store-bind | |
52 | store-return | |
53 | store-lift | |
54 | run-with-store | |
55 | text-file | |
56 | package-file | |
57 | package->derivation | |
58 | built-derivations | |
033adfe7 | 59 | derivation-expression |
413d5351 LC |
60 | lower-inputs) |
61 | #:replace (imported-modules | |
62 | compiled-modules)) | |
b860f382 LC |
63 | |
64 | ;;; Commentary: | |
65 | ;;; | |
66 | ;;; This module implements the general mechanism of monads, and provides in | |
67 | ;;; particular an instance of the "store" monad. The API was inspired by that | |
68 | ;;; of Racket's "better-monads" module (see | |
69 | ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>). | |
70 | ;;; The implementation and use case were influenced by Oleg Kysielov's | |
71 | ;;; "Monadic Programming in Scheme" (see | |
72 | ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>). | |
73 | ;;; | |
74 | ;;; The store monad allows us to (1) build sequences of operations in the | |
75 | ;;; store, and (2) make the store an implicit part of the execution context, | |
76 | ;;; rather than a parameter of every single function. | |
77 | ;;; | |
78 | ;;; Code: | |
79 | ||
aeb7ec5c LC |
80 | ;; Record type for monads manipulated at run time. |
81 | (define-record-type <monad> | |
82 | (make-monad bind return) | |
b860f382 LC |
83 | monad? |
84 | (bind monad-bind) | |
85 | (return monad-return)) ; TODO: Add 'plus' and 'zero' | |
86 | ||
aeb7ec5c LC |
87 | (define-syntax define-monad |
88 | (lambda (s) | |
89 | "Define the monad under NAME, with the given bind and return methods." | |
90 | (define prefix (string->symbol "% ")) | |
91 | (define (make-rtd-name name) | |
92 | (datum->syntax name | |
93 | (symbol-append prefix (syntax->datum name) '-rtd))) | |
94 | ||
95 | (syntax-case s (bind return) | |
96 | ((_ name (bind b) (return r)) | |
97 | (with-syntax ((rtd (make-rtd-name #'name))) | |
98 | #`(begin | |
99 | (define rtd | |
100 | ;; The record type, for use at run time. | |
101 | (make-monad b r)) | |
102 | ||
103 | (define-syntax name | |
104 | ;; An "inlined record", for use at expansion time. The goal is | |
105 | ;; to allow 'bind' and 'return' to be resolved at expansion | |
106 | ;; time, in the common case where the monad is accessed | |
107 | ;; directly as NAME. | |
108 | (lambda (s) | |
109 | (syntax-case s (%bind %return) | |
110 | ((_ %bind) #'b) | |
111 | ((_ %return) #'r) | |
112 | (_ #'rtd)))))))))) | |
113 | ||
b860f382 LC |
114 | (define-syntax-parameter >>= |
115 | ;; The name 'bind' is already taken, so we choose this (obscure) symbol. | |
116 | (lambda (s) | |
117 | (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) | |
118 | ||
119 | (define-syntax-parameter return | |
120 | (lambda (s) | |
121 | (syntax-violation 'return "return used outside of 'with-monad'" s))) | |
122 | ||
123 | (define-syntax with-monad | |
124 | (lambda (s) | |
125 | "Evaluate BODY in the context of MONAD, and return its result." | |
126 | (syntax-case s () | |
127 | ((_ monad body ...) | |
aeb7ec5c LC |
128 | (eq? 'macro (syntax-local-binding #'monad)) |
129 | ;; MONAD is a syntax transformer, so we can obtain the bind and return | |
130 | ;; methods by directly querying it. | |
131 | #'(syntax-parameterize ((>>= (identifier-syntax (monad %bind))) | |
132 | (return (identifier-syntax (monad %return)))) | |
133 | body ...)) | |
134 | ((_ monad body ...) | |
135 | ;; MONAD refers to the <monad> record that represents the monad at run | |
136 | ;; time, so use the slow method. | |
b860f382 LC |
137 | #'(syntax-parameterize ((>>= (identifier-syntax |
138 | (monad-bind monad))) | |
139 | (return (identifier-syntax | |
140 | (monad-return monad)))) | |
141 | body ...))))) | |
142 | ||
143 | (define-syntax mlet* | |
144 | (syntax-rules (->) | |
145 | "Bind the given monadic values MVAL to the given variables VAR. When the | |
146 | form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as | |
147 | 'let'." | |
148 | ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'. | |
149 | ((_ monad () body ...) | |
150 | (with-monad monad body ...)) | |
151 | ((_ monad ((var mval) rest ...) body ...) | |
152 | (with-monad monad | |
153 | (>>= mval | |
154 | (lambda (var) | |
155 | (mlet* monad (rest ...) | |
156 | body ...))))) | |
157 | ((_ monad ((var -> val) rest ...) body ...) | |
158 | (let ((var val)) | |
159 | (mlet* monad (rest ...) | |
160 | body ...))))) | |
161 | ||
162 | (define-syntax mlet | |
163 | (lambda (s) | |
164 | (syntax-case s () | |
165 | ((_ monad ((var mval ...) ...) body ...) | |
166 | (with-syntax (((temp ...) (generate-temporaries #'(var ...)))) | |
167 | #'(mlet* monad ((temp mval ...) ...) | |
168 | (let ((var temp) ...) | |
169 | body ...))))))) | |
170 | ||
171 | (define-syntax define-lift | |
172 | (syntax-rules () | |
173 | ((_ liftn (args ...)) | |
174 | (define (liftn proc monad) | |
175 | "Lift PROC to MONAD---i.e., return a monadic function in MONAD." | |
176 | (lambda (args ...) | |
177 | (with-monad monad | |
178 | (return (proc args ...)))))))) | |
179 | ||
180 | (define-lift lift1 (a)) | |
181 | (define-lift lift2 (a b)) | |
182 | (define-lift lift3 (a b c)) | |
183 | (define-lift lift4 (a b c d)) | |
184 | (define-lift lift5 (a b c d e)) | |
185 | (define-lift lift6 (a b c d e f)) | |
186 | (define-lift lift7 (a b c d e f g)) | |
187 | ||
188 | (define (lift nargs proc monad) | |
189 | "Lift PROC, a procedure that accepts NARGS arguments, to MONAD---i.e., | |
190 | return a monadic function in MONAD." | |
191 | (lambda args | |
192 | (with-monad monad | |
193 | (return (apply proc args))))) | |
194 | ||
195 | (define (foldm monad mproc init lst) | |
196 | "Fold MPROC over LST, a list of monadic values in MONAD, and return a | |
197 | monadic value seeded by INIT." | |
198 | (with-monad monad | |
199 | (let loop ((lst lst) | |
200 | (result init)) | |
201 | (match lst | |
202 | (() | |
203 | (return result)) | |
204 | ((head tail ...) | |
205 | (mlet* monad ((item head) | |
206 | (result (mproc item result))) | |
207 | (loop tail result))))))) | |
208 | ||
209 | (define (mapm monad mproc lst) | |
210 | "Map MPROC over LST, a list of monadic values in MONAD, and return a monadic | |
211 | list." | |
212 | (foldm monad | |
213 | (lambda (item result) | |
214 | (mlet monad ((item (mproc item))) | |
215 | (return (cons item result)))) | |
216 | '() | |
217 | (reverse lst))) | |
218 | ||
219 | (define-inlinable (sequence monad lst) | |
220 | "Turn the list of monadic values LST into a monadic list of values, by | |
221 | evaluating each item of LST in sequence." | |
b860f382 LC |
222 | (with-monad monad |
223 | (mapm monad return lst))) | |
224 | ||
225 | (define (anym monad proc lst) | |
226 | "Apply PROC to the list of monadic values LST; return the first value, | |
227 | lifted in MONAD, for which PROC returns true." | |
228 | (with-monad monad | |
229 | (let loop ((lst lst)) | |
230 | (match lst | |
231 | (() | |
232 | (return #f)) | |
233 | ((head tail ...) | |
593c3fe6 LC |
234 | (mlet* monad ((value head) |
235 | (result -> (proc value))) | |
236 | (if result | |
237 | (return result) | |
b860f382 LC |
238 | (loop tail)))))))) |
239 | ||
240 | (define-syntax listm | |
241 | (lambda (s) | |
242 | "Return a monadic list in MONAD from the monadic values MVAL." | |
243 | (syntax-case s () | |
244 | ((_ monad mval ...) | |
245 | (with-syntax (((val ...) (generate-temporaries #'(mval ...)))) | |
246 | #'(mlet monad ((val mval) ...) | |
247 | (return (list val ...)))))))) | |
248 | ||
249 | ||
250 | \f | |
251 | ;;; | |
252 | ;;; Identity monad. | |
253 | ;;; | |
254 | ||
aeb7ec5c | 255 | (define-inlinable (identity-return value) |
b860f382 LC |
256 | value) |
257 | ||
aeb7ec5c | 258 | (define-inlinable (identity-bind mvalue mproc) |
b860f382 LC |
259 | (mproc mvalue)) |
260 | ||
aeb7ec5c LC |
261 | (define-monad %identity-monad |
262 | (bind identity-bind) | |
263 | (return identity-return)) | |
b860f382 LC |
264 | |
265 | \f | |
266 | ;;; | |
267 | ;;; Store monad. | |
268 | ;;; | |
269 | ||
270 | ;; return:: a -> StoreM a | |
aeb7ec5c | 271 | (define-inlinable (store-return value) |
b860f382 LC |
272 | "Return VALUE from a monadic function." |
273 | ;; The monadic value is just this. | |
274 | (lambda (store) | |
275 | value)) | |
276 | ||
277 | ;; >>=:: StoreM a -> (a -> StoreM b) -> StoreM b | |
aeb7ec5c LC |
278 | (define-inlinable (store-bind mvalue mproc) |
279 | "Bind MVALUE in MPROC." | |
b860f382 LC |
280 | (lambda (store) |
281 | (let* ((value (mvalue store)) | |
282 | (mresult (mproc value))) | |
283 | (mresult store)))) | |
284 | ||
aeb7ec5c LC |
285 | (define-monad %store-monad |
286 | (bind store-bind) | |
287 | (return store-return)) | |
b860f382 LC |
288 | |
289 | ||
290 | (define (store-lift proc) | |
291 | "Lift PROC, a procedure whose first argument is a connection to the store, | |
292 | in the store monad." | |
293 | (define result | |
294 | (lambda args | |
295 | (lambda (store) | |
296 | (apply proc store args)))) | |
297 | ||
298 | (set-object-property! result 'documentation | |
299 | (procedure-property proc 'documentation)) | |
300 | result) | |
301 | ||
302 | ;;; | |
303 | ;;; Store monad operators. | |
304 | ;;; | |
305 | ||
306 | (define* (text-file name text) | |
307 | "Return as a monadic value the absolute file name in the store of the file | |
308 | containing TEXT." | |
309 | (lambda (store) | |
310 | (add-text-to-store store name text '()))) | |
311 | ||
312 | (define* (package-file package | |
313 | #:optional file | |
314 | #:key (system (%current-system)) (output "out")) | |
413d5351 | 315 | "Return as a monadic value the absolute file name of FILE within the |
b860f382 LC |
316 | OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the |
317 | OUTPUT directory of PACKAGE." | |
318 | (lambda (store) | |
319 | (let* ((drv (package-derivation store package system)) | |
320 | (out (derivation->output-path drv output))) | |
321 | (if file | |
322 | (string-append out "/" file) | |
323 | out)))) | |
324 | ||
033adfe7 LC |
325 | (define (lower-inputs inputs) |
326 | "Turn any package from INPUTS into a derivation; return the corresponding | |
327 | input list as a monadic value." | |
328 | ;; XXX: Should probably be in (guix packages). | |
329 | (with-monad %store-monad | |
330 | (sequence %store-monad | |
331 | (map (match-lambda | |
332 | ((name (? package? package) sub-drv ...) | |
333 | (mlet %store-monad ((drv (package->derivation package))) | |
334 | (return `(,name ,drv ,@sub-drv)))) | |
335 | ((name (? string? file)) | |
336 | (return `(,name ,file))) | |
337 | (tuple | |
338 | (return tuple))) | |
339 | inputs)))) | |
340 | ||
b860f382 LC |
341 | (define derivation-expression |
342 | (store-lift build-expression->derivation)) | |
343 | ||
344 | (define package->derivation | |
345 | (store-lift package-derivation)) | |
346 | ||
413d5351 LC |
347 | (define imported-modules |
348 | (store-lift (@ (guix derivations) imported-modules))) | |
349 | ||
350 | (define compiled-modules | |
351 | (store-lift (@ (guix derivations) compiled-modules))) | |
352 | ||
b860f382 LC |
353 | (define built-derivations |
354 | (store-lift build-derivations)) | |
355 | ||
356 | (define* (run-with-store store mval | |
357 | #:key | |
358 | (guile-for-build (%guile-for-build)) | |
359 | (system (%current-system))) | |
360 | "Run MVAL, a monadic value in the store monad, in STORE, an open store | |
361 | connection." | |
362 | (parameterize ((%guile-for-build (or guile-for-build | |
363 | (package-derivation store | |
364 | (@ (gnu packages base) | |
365 | guile-final) | |
366 | system))) | |
367 | (%current-system system)) | |
368 | (mval store))) | |
369 | ||
370 | ;;; monads.scm end here |