Commit | Line | Data |
---|---|---|
b860f382 | 1 | ;;; GNU Guix --- Functional package management for GNU |
462a3fa3 | 2 | ;;; Copyright © 2013, 2014, 2015 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) | |
aeb7ec5c LC |
20 | #:use-module ((system syntax) |
21 | #:select (syntax-local-binding)) | |
b860f382 | 22 | #:use-module (ice-9 match) |
45adbd62 | 23 | #:use-module (srfi srfi-1) |
aeb7ec5c | 24 | #:use-module (srfi srfi-9) |
b860f382 LC |
25 | #:use-module (srfi srfi-26) |
26 | #:export (;; Monads. | |
aeb7ec5c | 27 | define-monad |
b860f382 LC |
28 | monad? |
29 | monad-bind | |
30 | monad-return | |
31 | ||
32 | ;; Syntax. | |
33 | >>= | |
34 | return | |
35 | with-monad | |
36 | mlet | |
37 | mlet* | |
405a9d4e | 38 | mbegin |
21caa6de LC |
39 | mwhen |
40 | munless | |
b307c064 | 41 | lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift |
b860f382 LC |
42 | listm |
43 | foldm | |
44 | mapm | |
45 | sequence | |
46 | anym | |
47 | ||
48 | ;; Concrete monads. | |
81a97734 LC |
49 | %identity-monad |
50 | ||
51 | %state-monad | |
52 | state-return | |
53 | state-bind | |
54 | current-state | |
55 | set-current-state | |
56 | state-push | |
57 | state-pop | |
58 | run-with-state)) | |
b860f382 LC |
59 | |
60 | ;;; Commentary: | |
61 | ;;; | |
62 | ;;; This module implements the general mechanism of monads, and provides in | |
561fb6c3 | 63 | ;;; particular an instance of the "state" monad. The API was inspired by that |
b860f382 LC |
64 | ;;; of Racket's "better-monads" module (see |
65 | ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>). | |
66 | ;;; The implementation and use case were influenced by Oleg Kysielov's | |
67 | ;;; "Monadic Programming in Scheme" (see | |
68 | ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>). | |
69 | ;;; | |
b860f382 LC |
70 | ;;; Code: |
71 | ||
aeb7ec5c LC |
72 | ;; Record type for monads manipulated at run time. |
73 | (define-record-type <monad> | |
74 | (make-monad bind return) | |
b860f382 LC |
75 | monad? |
76 | (bind monad-bind) | |
77 | (return monad-return)) ; TODO: Add 'plus' and 'zero' | |
78 | ||
aeb7ec5c LC |
79 | (define-syntax define-monad |
80 | (lambda (s) | |
81 | "Define the monad under NAME, with the given bind and return methods." | |
82 | (define prefix (string->symbol "% ")) | |
83 | (define (make-rtd-name name) | |
84 | (datum->syntax name | |
85 | (symbol-append prefix (syntax->datum name) '-rtd))) | |
86 | ||
87 | (syntax-case s (bind return) | |
88 | ((_ name (bind b) (return r)) | |
89 | (with-syntax ((rtd (make-rtd-name #'name))) | |
90 | #`(begin | |
91 | (define rtd | |
92 | ;; The record type, for use at run time. | |
93 | (make-monad b r)) | |
94 | ||
95 | (define-syntax name | |
96 | ;; An "inlined record", for use at expansion time. The goal is | |
97 | ;; to allow 'bind' and 'return' to be resolved at expansion | |
98 | ;; time, in the common case where the monad is accessed | |
99 | ;; directly as NAME. | |
100 | (lambda (s) | |
101 | (syntax-case s (%bind %return) | |
102 | ((_ %bind) #'b) | |
103 | ((_ %return) #'r) | |
104 | (_ #'rtd)))))))))) | |
105 | ||
b860f382 LC |
106 | (define-syntax-parameter >>= |
107 | ;; The name 'bind' is already taken, so we choose this (obscure) symbol. | |
108 | (lambda (s) | |
109 | (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) | |
110 | ||
111 | (define-syntax-parameter return | |
112 | (lambda (s) | |
113 | (syntax-violation 'return "return used outside of 'with-monad'" s))) | |
114 | ||
751630c9 LC |
115 | (define-syntax-rule (bind-syntax bind) |
116 | "Return a macro transformer that handles the expansion of '>>=' expressions | |
117 | using BIND as the binary bind operator. | |
118 | ||
119 | This macro exists to allow the expansion of n-ary '>>=' expressions, even | |
120 | though BIND is simply binary, as in: | |
121 | ||
122 | (with-monad %state-monad | |
123 | (>>= (return 1) | |
124 | (lift 1+ %state-monad) | |
125 | (lift 1+ %state-monad))) | |
126 | " | |
127 | (lambda (stx) | |
128 | (define (expand body) | |
129 | (syntax-case body () | |
130 | ((_ mval mproc) | |
131 | #'(bind mval mproc)) | |
132 | ((x mval mproc0 mprocs (... ...)) | |
133 | (expand #'(>>= (>>= mval mproc0) | |
134 | mprocs (... ...)))))) | |
135 | ||
136 | (expand stx))) | |
137 | ||
b860f382 LC |
138 | (define-syntax with-monad |
139 | (lambda (s) | |
140 | "Evaluate BODY in the context of MONAD, and return its result." | |
141 | (syntax-case s () | |
142 | ((_ monad body ...) | |
aeb7ec5c LC |
143 | (eq? 'macro (syntax-local-binding #'monad)) |
144 | ;; MONAD is a syntax transformer, so we can obtain the bind and return | |
145 | ;; methods by directly querying it. | |
751630c9 | 146 | #'(syntax-parameterize ((>>= (bind-syntax (monad %bind))) |
aeb7ec5c LC |
147 | (return (identifier-syntax (monad %return)))) |
148 | body ...)) | |
149 | ((_ monad body ...) | |
150 | ;; MONAD refers to the <monad> record that represents the monad at run | |
151 | ;; time, so use the slow method. | |
751630c9 | 152 | #'(syntax-parameterize ((>>= (bind-syntax |
b860f382 LC |
153 | (monad-bind monad))) |
154 | (return (identifier-syntax | |
155 | (monad-return monad)))) | |
156 | body ...))))) | |
157 | ||
158 | (define-syntax mlet* | |
159 | (syntax-rules (->) | |
160 | "Bind the given monadic values MVAL to the given variables VAR. When the | |
161 | form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as | |
162 | 'let'." | |
163 | ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'. | |
164 | ((_ monad () body ...) | |
165 | (with-monad monad body ...)) | |
166 | ((_ monad ((var mval) rest ...) body ...) | |
167 | (with-monad monad | |
168 | (>>= mval | |
169 | (lambda (var) | |
170 | (mlet* monad (rest ...) | |
171 | body ...))))) | |
172 | ((_ monad ((var -> val) rest ...) body ...) | |
173 | (let ((var val)) | |
174 | (mlet* monad (rest ...) | |
175 | body ...))))) | |
176 | ||
177 | (define-syntax mlet | |
178 | (lambda (s) | |
179 | (syntax-case s () | |
180 | ((_ monad ((var mval ...) ...) body ...) | |
181 | (with-syntax (((temp ...) (generate-temporaries #'(var ...)))) | |
182 | #'(mlet* monad ((temp mval ...) ...) | |
183 | (let ((var temp) ...) | |
184 | body ...))))))) | |
185 | ||
405a9d4e | 186 | (define-syntax mbegin |
21caa6de | 187 | (syntax-rules (%current-monad) |
405a9d4e LC |
188 | "Bind the given monadic expressions in sequence, returning the result of |
189 | the last one." | |
21caa6de LC |
190 | ((_ %current-monad mexp) |
191 | mexp) | |
192 | ((_ %current-monad mexp rest ...) | |
193 | (>>= mexp | |
194 | (lambda (unused-value) | |
195 | (mbegin %current-monad rest ...)))) | |
405a9d4e LC |
196 | ((_ monad mexp) |
197 | (with-monad monad | |
198 | mexp)) | |
199 | ((_ monad mexp rest ...) | |
200 | (with-monad monad | |
201 | (>>= mexp | |
202 | (lambda (unused-value) | |
203 | (mbegin monad rest ...))))))) | |
204 | ||
21caa6de LC |
205 | (define-syntax mwhen |
206 | (syntax-rules () | |
d922c8e4 | 207 | "When CONDITION is true, evaluate MEXP0..MEXP* as in an 'mbegin'. When |
21caa6de | 208 | CONDITION is false, return *unspecified* in the current monad." |
d922c8e4 | 209 | ((_ condition mexp0 mexp* ...) |
21caa6de LC |
210 | (if condition |
211 | (mbegin %current-monad | |
d922c8e4 | 212 | mexp0 mexp* ...) |
21caa6de LC |
213 | (return *unspecified*))))) |
214 | ||
215 | (define-syntax munless | |
216 | (syntax-rules () | |
d922c8e4 | 217 | "When CONDITION is false, evaluate MEXP0..MEXP* as in an 'mbegin'. When |
21caa6de | 218 | CONDITION is true, return *unspecified* in the current monad." |
d922c8e4 | 219 | ((_ condition mexp0 mexp* ...) |
21caa6de LC |
220 | (if condition |
221 | (return *unspecified*) | |
222 | (mbegin %current-monad | |
d922c8e4 | 223 | mexp0 mexp* ...))))) |
21caa6de | 224 | |
b860f382 LC |
225 | (define-syntax define-lift |
226 | (syntax-rules () | |
227 | ((_ liftn (args ...)) | |
b6c6105c LC |
228 | (define-syntax liftn |
229 | (lambda (s) | |
230 | "Lift PROC to MONAD---i.e., return a monadic function in MONAD." | |
231 | (syntax-case s () | |
232 | ((liftn proc monad) | |
233 | ;; Inline the result of lifting PROC, such that 'return' can in | |
234 | ;; turn be open-coded. | |
235 | #'(lambda (args ...) | |
236 | (with-monad monad | |
237 | (return (proc args ...))))) | |
238 | (id | |
239 | (identifier? #'id) | |
240 | ;; Slow path: Return a closure-returning procedure (we don't | |
241 | ;; guarantee (eq? LIFTN LIFTN), but that's fine.) | |
dbbc248a LC |
242 | #'(lambda (proc monad) |
243 | (lambda (args ...) | |
244 | (with-monad monad | |
245 | (return (proc args ...)))))))))))) | |
b860f382 | 246 | |
b307c064 | 247 | (define-lift lift0 ()) |
b860f382 LC |
248 | (define-lift lift1 (a)) |
249 | (define-lift lift2 (a b)) | |
250 | (define-lift lift3 (a b c)) | |
251 | (define-lift lift4 (a b c d)) | |
252 | (define-lift lift5 (a b c d e)) | |
253 | (define-lift lift6 (a b c d e f)) | |
254 | (define-lift lift7 (a b c d e f g)) | |
255 | ||
e4bed284 LC |
256 | (define (lift proc monad) |
257 | "Lift PROC, a procedure that accepts an arbitrary number of arguments, to | |
258 | MONAD---i.e., return a monadic function in MONAD." | |
b860f382 LC |
259 | (lambda args |
260 | (with-monad monad | |
261 | (return (apply proc args))))) | |
262 | ||
263 | (define (foldm monad mproc init lst) | |
b734996f LC |
264 | "Fold MPROC over LST and return a monadic value seeded by INIT. |
265 | ||
266 | (foldm %state-monad (lift2 cons %state-monad) '() '(a b c)) | |
267 | => '(c b a) ;monadic | |
268 | " | |
b860f382 LC |
269 | (with-monad monad |
270 | (let loop ((lst lst) | |
271 | (result init)) | |
272 | (match lst | |
273 | (() | |
274 | (return result)) | |
275 | ((head tail ...) | |
b734996f LC |
276 | (>>= (mproc head result) |
277 | (lambda (result) | |
278 | (loop tail result)))))))) | |
b860f382 LC |
279 | |
280 | (define (mapm monad mproc lst) | |
b734996f LC |
281 | "Map MPROC over LST and return a monadic list. |
282 | ||
283 | (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2)) | |
284 | => (1 2 3) ;monadic | |
285 | " | |
f62435e2 LC |
286 | (mlet monad ((result (foldm monad |
287 | (lambda (item result) | |
b734996f LC |
288 | (>>= (mproc item) |
289 | (lambda (item) | |
290 | (return (cons item result))))) | |
f62435e2 LC |
291 | '() |
292 | lst))) | |
293 | (return (reverse result)))) | |
b860f382 | 294 | |
8d7dc5d9 | 295 | (define-syntax-rule (sequence monad lst) |
b860f382 LC |
296 | "Turn the list of monadic values LST into a monadic list of values, by |
297 | evaluating each item of LST in sequence." | |
8d7dc5d9 LC |
298 | ;; XXX: Making it a macro is a bit brutal as it leads to a lot of code |
299 | ;; duplication. However, it allows >>= and return to be open-coded, which | |
300 | ;; avoids struct-ref's to MONAD and a few closure allocations when using | |
301 | ;; %STATE-MONAD. | |
b860f382 | 302 | (with-monad monad |
8d7dc5d9 LC |
303 | (let seq ((lstx lst) |
304 | (result '())) | |
305 | (match lstx | |
306 | (() | |
307 | (return (reverse result))) | |
308 | ((head . tail) | |
309 | (>>= head | |
310 | (lambda (item) | |
311 | (seq tail (cons item result))))))))) | |
b860f382 | 312 | |
b734996f LC |
313 | (define (anym monad mproc lst) |
314 | "Apply MPROC to the list of values LST; return as a monadic value the first | |
315 | value for which MPROC returns a true monadic value or #f. For example: | |
316 | ||
317 | (anym %state-monad (lift1 odd? %state-monad) '(0 1 2)) | |
318 | => #t ;monadic | |
319 | " | |
b860f382 LC |
320 | (with-monad monad |
321 | (let loop ((lst lst)) | |
322 | (match lst | |
323 | (() | |
324 | (return #f)) | |
325 | ((head tail ...) | |
b734996f LC |
326 | (>>= (mproc head) |
327 | (lambda (result) | |
328 | (if result | |
329 | (return result) | |
330 | (loop tail))))))))) | |
b860f382 LC |
331 | |
332 | (define-syntax listm | |
333 | (lambda (s) | |
334 | "Return a monadic list in MONAD from the monadic values MVAL." | |
335 | (syntax-case s () | |
336 | ((_ monad mval ...) | |
337 | (with-syntax (((val ...) (generate-temporaries #'(mval ...)))) | |
338 | #'(mlet monad ((val mval) ...) | |
339 | (return (list val ...)))))))) | |
340 | ||
341 | ||
342 | \f | |
343 | ;;; | |
344 | ;;; Identity monad. | |
345 | ;;; | |
346 | ||
aeb7ec5c | 347 | (define-inlinable (identity-return value) |
b860f382 LC |
348 | value) |
349 | ||
aeb7ec5c | 350 | (define-inlinable (identity-bind mvalue mproc) |
b860f382 LC |
351 | (mproc mvalue)) |
352 | ||
aeb7ec5c LC |
353 | (define-monad %identity-monad |
354 | (bind identity-bind) | |
355 | (return identity-return)) | |
b860f382 | 356 | |
81a97734 LC |
357 | \f |
358 | ;;; | |
359 | ;;; State monad. | |
360 | ;;; | |
361 | ||
362 | (define-inlinable (state-return value) | |
363 | (lambda (state) | |
364 | (values value state))) | |
365 | ||
366 | (define-inlinable (state-bind mvalue mproc) | |
367 | "Bind MVALUE, a value in the state monad, and pass it to MPROC." | |
368 | (lambda (state) | |
369 | (call-with-values | |
370 | (lambda () | |
371 | (mvalue state)) | |
372 | (lambda (value state) | |
373 | ;; Note: as of Guile 2.0.11, declaring a variable to hold the result | |
374 | ;; of (mproc value) prevents a bit of unfolding/inlining. | |
375 | ((mproc value) state))))) | |
376 | ||
377 | (define-monad %state-monad | |
378 | (bind state-bind) | |
379 | (return state-return)) | |
380 | ||
381 | (define* (run-with-state mval #:optional (state '())) | |
382 | "Run monadic value MVAL starting with STATE as the initial state. Return | |
383 | two values: the resulting value, and the resulting state." | |
384 | (mval state)) | |
385 | ||
386 | (define-inlinable (current-state) | |
387 | "Return the current state as a monadic value." | |
388 | (lambda (state) | |
389 | (values state state))) | |
390 | ||
391 | (define-inlinable (set-current-state value) | |
392 | "Set the current state to VALUE and return the previous state as a monadic | |
393 | value." | |
394 | (lambda (state) | |
395 | (values state value))) | |
396 | ||
397 | (define (state-pop) | |
398 | "Pop a value from the current state and return it as a monadic value. The | |
399 | state is assumed to be a list." | |
400 | (lambda (state) | |
401 | (match state | |
402 | ((head . tail) | |
403 | (values head tail))))) | |
404 | ||
405 | (define (state-push value) | |
406 | "Push VALUE to the current state, which is assumed to be a list, and return | |
407 | the previous state as a monadic value." | |
408 | (lambda (state) | |
409 | (values state (cons value state)))) | |
410 | ||
b860f382 | 411 | ;;; monads.scm end here |