Commit | Line | Data |
---|---|---|
b860f382 | 1 | ;;; GNU Guix --- Functional package management for GNU |
dcb95c1f | 2 | ;;; Copyright © 2013, 2014, 2015, 2017 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 | ||
dcb95c1f LC |
32 | template-directory |
33 | ||
b860f382 LC |
34 | ;; Syntax. |
35 | >>= | |
36 | return | |
37 | with-monad | |
38 | mlet | |
39 | mlet* | |
405a9d4e | 40 | mbegin |
21caa6de LC |
41 | mwhen |
42 | munless | |
b307c064 | 43 | lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift |
b860f382 LC |
44 | listm |
45 | foldm | |
46 | mapm | |
47 | sequence | |
48 | anym | |
49 | ||
50 | ;; Concrete monads. | |
81a97734 LC |
51 | %identity-monad |
52 | ||
53 | %state-monad | |
54 | state-return | |
55 | state-bind | |
56 | current-state | |
57 | set-current-state | |
58 | state-push | |
59 | state-pop | |
60 | run-with-state)) | |
b860f382 LC |
61 | |
62 | ;;; Commentary: | |
63 | ;;; | |
64 | ;;; This module implements the general mechanism of monads, and provides in | |
561fb6c3 | 65 | ;;; particular an instance of the "state" monad. The API was inspired by that |
b860f382 LC |
66 | ;;; of Racket's "better-monads" module (see |
67 | ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>). | |
68 | ;;; The implementation and use case were influenced by Oleg Kysielov's | |
69 | ;;; "Monadic Programming in Scheme" (see | |
70 | ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>). | |
71 | ;;; | |
b860f382 LC |
72 | ;;; Code: |
73 | ||
aeb7ec5c LC |
74 | ;; Record type for monads manipulated at run time. |
75 | (define-record-type <monad> | |
76 | (make-monad bind return) | |
b860f382 LC |
77 | monad? |
78 | (bind monad-bind) | |
79 | (return monad-return)) ; TODO: Add 'plus' and 'zero' | |
80 | ||
aeb7ec5c LC |
81 | (define-syntax define-monad |
82 | (lambda (s) | |
83 | "Define the monad under NAME, with the given bind and return methods." | |
84 | (define prefix (string->symbol "% ")) | |
85 | (define (make-rtd-name name) | |
86 | (datum->syntax name | |
87 | (symbol-append prefix (syntax->datum name) '-rtd))) | |
88 | ||
89 | (syntax-case s (bind return) | |
90 | ((_ name (bind b) (return r)) | |
91 | (with-syntax ((rtd (make-rtd-name #'name))) | |
92 | #`(begin | |
93 | (define rtd | |
94 | ;; The record type, for use at run time. | |
95 | (make-monad b r)) | |
96 | ||
dcb95c1f LC |
97 | ;; Instantiate all the templates, specialized for this monad. |
98 | (template-directory instantiations name) | |
99 | ||
aeb7ec5c LC |
100 | (define-syntax name |
101 | ;; An "inlined record", for use at expansion time. The goal is | |
102 | ;; to allow 'bind' and 'return' to be resolved at expansion | |
103 | ;; time, in the common case where the monad is accessed | |
104 | ;; directly as NAME. | |
105 | (lambda (s) | |
106 | (syntax-case s (%bind %return) | |
107 | ((_ %bind) #'b) | |
108 | ((_ %return) #'r) | |
109 | (_ #'rtd)))))))))) | |
110 | ||
dcb95c1f LC |
111 | ;; Expansion- and run-time state of the template directory. This needs to be |
112 | ;; available at run time (and not just at expansion time) so we can | |
113 | ;; instantiate templates defined in other modules, or use instances defined | |
114 | ;; elsewhere. | |
115 | (eval-when (load expand eval) | |
116 | ;; Mapping of syntax objects denoting the template to a pair containing (1) | |
117 | ;; the syntax object of the parameter over which it is templated, and (2) | |
118 | ;; the syntax of its body. | |
119 | (define-once %templates (make-hash-table)) | |
120 | ||
121 | (define (register-template! name param body) | |
122 | (hash-set! %templates name (cons param body))) | |
123 | ||
124 | ;; List of template instances, where each entry is a triplet containing the | |
125 | ;; syntax of the name, the actual parameter for which the template is | |
126 | ;; specialized, and the syntax object referring to this specialization (the | |
127 | ;; procedure's identifier.) | |
128 | (define-once %template-instances '()) | |
129 | ||
130 | (define (register-template-instance! name actual instance) | |
131 | (set! %template-instances | |
132 | (cons (list name actual instance) %template-instances)))) | |
133 | ||
134 | (define-syntax template-directory | |
135 | (lambda (s) | |
136 | "This is a \"stateful macro\" to register and lookup templates and | |
137 | template instances." | |
138 | (define location | |
139 | (syntax-source s)) | |
140 | ||
141 | (define current-info-port | |
142 | ;; Port for debugging info. | |
143 | (const (%make-void-port "w"))) | |
144 | ||
145 | (define location-string | |
146 | (format #f "~a:~a:~a" | |
147 | (assq-ref location 'filename) | |
148 | (and=> (assq-ref location 'line) 1+) | |
149 | (assq-ref location 'column))) | |
150 | ||
151 | (define (matching-instance? name actual) | |
152 | (match-lambda | |
153 | ((name* instance-param proc) | |
154 | (and (free-identifier=? name name*) | |
155 | (or (equal? actual instance-param) | |
156 | (and (identifier? actual) | |
157 | (identifier? instance-param) | |
158 | (free-identifier=? instance-param | |
159 | actual))) | |
160 | proc)))) | |
161 | ||
162 | (define (instance-identifier name actual) | |
163 | (define stem | |
164 | (string-append | |
165 | " " | |
166 | (symbol->string (syntax->datum name)) | |
167 | (if (identifier? actual) | |
168 | (string-append " " (symbol->string (syntax->datum actual))) | |
169 | "") | |
170 | " instance")) | |
171 | (datum->syntax actual (string->symbol stem))) | |
172 | ||
173 | (define (instance-definition name template actual) | |
174 | (match template | |
175 | ((formal . body) | |
176 | (let ((instance (instance-identifier name actual))) | |
177 | (format (current-info-port) | |
178 | "~a: info: specializing '~a' for '~a' as '~a'~%" | |
179 | location-string | |
180 | (syntax->datum name) (syntax->datum actual) | |
181 | (syntax->datum instance)) | |
182 | ||
183 | (register-template-instance! name actual instance) | |
184 | ||
185 | #`(begin | |
186 | (define #,instance | |
187 | (let-syntax ((#,formal (identifier-syntax #,actual))) | |
188 | #,body)) | |
189 | ||
190 | ;; Generate code to register the thing at run time. | |
191 | (register-template-instance! #'#,name #'#,actual | |
192 | #'#,instance)))))) | |
193 | ||
194 | (syntax-case s (register! lookup exists? instantiations) | |
195 | ((_ register! name param body) | |
196 | ;; Register NAME as a template on PARAM with the given BODY. | |
197 | (begin | |
198 | (register-template! #'name #'param #'body) | |
199 | ||
200 | ;; Generate code to register the template at run time. XXX: Because | |
201 | ;; of this, BODY must not contain ellipses. | |
202 | #'(register-template! #'name #'param #'body))) | |
203 | ((_ lookup name actual) | |
204 | ;; Search for an instance of template NAME for this ACTUAL parameter. | |
205 | ;; On success, expand to the identifier of the instance; otherwise | |
206 | ;; expand to #f. | |
207 | (any (matching-instance? #'name #'actual) %template-instances)) | |
208 | ((_ exists? name actual) | |
209 | ;; Likewise, but return a Boolean. | |
210 | (let ((result (->bool | |
211 | (any (matching-instance? #'name #'actual) | |
212 | %template-instances)))) | |
213 | (unless result | |
214 | (format (current-warning-port) | |
215 | "~a: warning: no specialization of template '~a' for '~a'~%" | |
216 | location-string | |
217 | (syntax->datum #'name) (syntax->datum #'actual))) | |
218 | result)) | |
219 | ((_ instantiations actual) | |
220 | ;; Expand to the definitions of all the existing templates | |
221 | ;; specialized for ACTUAL. | |
222 | #`(begin | |
223 | #,@(hash-map->list (cut instance-definition <> <> #'actual) | |
224 | %templates)))))) | |
225 | ||
226 | (define-syntax define-template | |
227 | (lambda (s) | |
228 | "Define a template, which is a procedure that can be specialized over its | |
229 | first argument. In our case, the first argument is typically the identifier | |
230 | of a monad. | |
231 | ||
232 | Defining templates for procedures like 'mapm' allows us to make have a | |
233 | specialized version of those procedures for each monad that we define, such | |
234 | that calls to: | |
235 | ||
236 | (mapm %state-monad proc lst) | |
237 | ||
238 | automatically expand to: | |
239 | ||
240 | (#{ mapm %state-monad instance}# proc lst) | |
241 | ||
242 | Here, #{ mapm %state-monad instance}# is specialized for %state-monad, and | |
243 | thus it contains inline calls to %state-bind and %state-return. This avoids | |
244 | repeated calls to 'struct-ref' to get the 'bind' and 'return' procedure of the | |
245 | monad, and allows 'bind' and 'return' to be inlined, which in turn allows for | |
246 | more optimizations." | |
247 | (syntax-case s () | |
248 | ((_ (name arg0 args ...) body ...) | |
249 | (with-syntax ((generic-name (datum->syntax | |
250 | #'name | |
251 | (symbol-append '#{ %}# | |
252 | (syntax->datum #'name) | |
253 | '-generic))) | |
254 | (original-name #'name)) | |
255 | #`(begin | |
256 | (template-directory register! name arg0 | |
257 | (lambda (args ...) | |
258 | body ...)) | |
259 | (define (generic-name arg0 args ...) | |
260 | ;; The generic instance of NAME, for when no specialization was | |
261 | ;; found. | |
262 | body ...) | |
263 | ||
264 | (define-syntax name | |
265 | (lambda (s) | |
266 | (syntax-case s () | |
267 | ((_ arg0* args ...) | |
268 | ;; Expand to either the specialized instance or the | |
269 | ;; generic instance of template ORIGINAL-NAME. | |
270 | #'(if (template-directory exists? original-name arg0*) | |
271 | ((template-directory lookup original-name arg0*) | |
272 | args ...) | |
273 | (generic-name arg0* args ...))) | |
274 | (_ | |
275 | #'generic-name)))))))))) | |
276 | ||
8245bb74 LC |
277 | (define-syntax-rule (define-syntax-parameter-once name proc) |
278 | ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME | |
279 | ;; does not get redefined. This works around a race condition in a | |
280 | ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>. | |
281 | (eval-when (load eval expand compile) | |
282 | (define name | |
283 | (if (module-locally-bound? (current-module) 'name) | |
284 | (module-ref (current-module) 'name) | |
285 | (make-syntax-transformer 'name 'syntax-parameter | |
286 | (list proc)))))) | |
287 | ||
288 | (define-syntax-parameter-once >>= | |
b860f382 LC |
289 | ;; The name 'bind' is already taken, so we choose this (obscure) symbol. |
290 | (lambda (s) | |
291 | (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) | |
292 | ||
8245bb74 | 293 | (define-syntax-parameter-once return |
b860f382 LC |
294 | (lambda (s) |
295 | (syntax-violation 'return "return used outside of 'with-monad'" s))) | |
296 | ||
751630c9 LC |
297 | (define-syntax-rule (bind-syntax bind) |
298 | "Return a macro transformer that handles the expansion of '>>=' expressions | |
299 | using BIND as the binary bind operator. | |
300 | ||
301 | This macro exists to allow the expansion of n-ary '>>=' expressions, even | |
302 | though BIND is simply binary, as in: | |
303 | ||
304 | (with-monad %state-monad | |
305 | (>>= (return 1) | |
306 | (lift 1+ %state-monad) | |
307 | (lift 1+ %state-monad))) | |
308 | " | |
309 | (lambda (stx) | |
310 | (define (expand body) | |
311 | (syntax-case body () | |
312 | ((_ mval mproc) | |
313 | #'(bind mval mproc)) | |
314 | ((x mval mproc0 mprocs (... ...)) | |
315 | (expand #'(>>= (>>= mval mproc0) | |
316 | mprocs (... ...)))))) | |
317 | ||
318 | (expand stx))) | |
319 | ||
b860f382 LC |
320 | (define-syntax with-monad |
321 | (lambda (s) | |
322 | "Evaluate BODY in the context of MONAD, and return its result." | |
323 | (syntax-case s () | |
324 | ((_ monad body ...) | |
aeb7ec5c LC |
325 | (eq? 'macro (syntax-local-binding #'monad)) |
326 | ;; MONAD is a syntax transformer, so we can obtain the bind and return | |
327 | ;; methods by directly querying it. | |
751630c9 | 328 | #'(syntax-parameterize ((>>= (bind-syntax (monad %bind))) |
aeb7ec5c LC |
329 | (return (identifier-syntax (monad %return)))) |
330 | body ...)) | |
331 | ((_ monad body ...) | |
332 | ;; MONAD refers to the <monad> record that represents the monad at run | |
333 | ;; time, so use the slow method. | |
751630c9 | 334 | #'(syntax-parameterize ((>>= (bind-syntax |
b860f382 LC |
335 | (monad-bind monad))) |
336 | (return (identifier-syntax | |
337 | (monad-return monad)))) | |
338 | body ...))))) | |
339 | ||
340 | (define-syntax mlet* | |
341 | (syntax-rules (->) | |
342 | "Bind the given monadic values MVAL to the given variables VAR. When the | |
343 | form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as | |
344 | 'let'." | |
345 | ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'. | |
346 | ((_ monad () body ...) | |
347 | (with-monad monad body ...)) | |
348 | ((_ monad ((var mval) rest ...) body ...) | |
349 | (with-monad monad | |
350 | (>>= mval | |
351 | (lambda (var) | |
352 | (mlet* monad (rest ...) | |
353 | body ...))))) | |
354 | ((_ monad ((var -> val) rest ...) body ...) | |
355 | (let ((var val)) | |
356 | (mlet* monad (rest ...) | |
357 | body ...))))) | |
358 | ||
359 | (define-syntax mlet | |
360 | (lambda (s) | |
361 | (syntax-case s () | |
362 | ((_ monad ((var mval ...) ...) body ...) | |
363 | (with-syntax (((temp ...) (generate-temporaries #'(var ...)))) | |
364 | #'(mlet* monad ((temp mval ...) ...) | |
365 | (let ((var temp) ...) | |
366 | body ...))))))) | |
367 | ||
405a9d4e | 368 | (define-syntax mbegin |
21caa6de | 369 | (syntax-rules (%current-monad) |
8bc2183f CM |
370 | "Bind MEXP and the following monadic expressions in sequence, returning |
371 | the result of the last expression. Every expression in the sequence must be a | |
372 | monadic expression." | |
21caa6de LC |
373 | ((_ %current-monad mexp) |
374 | mexp) | |
375 | ((_ %current-monad mexp rest ...) | |
376 | (>>= mexp | |
377 | (lambda (unused-value) | |
378 | (mbegin %current-monad rest ...)))) | |
405a9d4e LC |
379 | ((_ monad mexp) |
380 | (with-monad monad | |
381 | mexp)) | |
382 | ((_ monad mexp rest ...) | |
383 | (with-monad monad | |
384 | (>>= mexp | |
385 | (lambda (unused-value) | |
386 | (mbegin monad rest ...))))))) | |
387 | ||
21caa6de LC |
388 | (define-syntax mwhen |
389 | (syntax-rules () | |
60a9fcb1 CM |
390 | "When CONDITION is true, evaluate the sequence of monadic expressions |
391 | MEXP0..MEXP* as in an 'mbegin'. When CONDITION is false, return *unspecified* | |
392 | in the current monad. Every expression in the sequence must be a monadic | |
393 | expression." | |
d922c8e4 | 394 | ((_ condition mexp0 mexp* ...) |
21caa6de LC |
395 | (if condition |
396 | (mbegin %current-monad | |
d922c8e4 | 397 | mexp0 mexp* ...) |
21caa6de LC |
398 | (return *unspecified*))))) |
399 | ||
400 | (define-syntax munless | |
401 | (syntax-rules () | |
60a9fcb1 CM |
402 | "When CONDITION is false, evaluate the sequence of monadic expressions |
403 | MEXP0..MEXP* as in an 'mbegin'. When CONDITION is true, return *unspecified* | |
404 | in the current monad. Every expression in the sequence must be a monadic | |
405 | expression." | |
d922c8e4 | 406 | ((_ condition mexp0 mexp* ...) |
21caa6de LC |
407 | (if condition |
408 | (return *unspecified*) | |
409 | (mbegin %current-monad | |
d922c8e4 | 410 | mexp0 mexp* ...))))) |
21caa6de | 411 | |
b860f382 LC |
412 | (define-syntax define-lift |
413 | (syntax-rules () | |
414 | ((_ liftn (args ...)) | |
b6c6105c LC |
415 | (define-syntax liftn |
416 | (lambda (s) | |
417 | "Lift PROC to MONAD---i.e., return a monadic function in MONAD." | |
418 | (syntax-case s () | |
419 | ((liftn proc monad) | |
420 | ;; Inline the result of lifting PROC, such that 'return' can in | |
421 | ;; turn be open-coded. | |
422 | #'(lambda (args ...) | |
423 | (with-monad monad | |
424 | (return (proc args ...))))) | |
425 | (id | |
426 | (identifier? #'id) | |
427 | ;; Slow path: Return a closure-returning procedure (we don't | |
428 | ;; guarantee (eq? LIFTN LIFTN), but that's fine.) | |
dbbc248a LC |
429 | #'(lambda (proc monad) |
430 | (lambda (args ...) | |
431 | (with-monad monad | |
432 | (return (proc args ...)))))))))))) | |
b860f382 | 433 | |
b307c064 | 434 | (define-lift lift0 ()) |
b860f382 LC |
435 | (define-lift lift1 (a)) |
436 | (define-lift lift2 (a b)) | |
437 | (define-lift lift3 (a b c)) | |
438 | (define-lift lift4 (a b c d)) | |
439 | (define-lift lift5 (a b c d e)) | |
440 | (define-lift lift6 (a b c d e f)) | |
441 | (define-lift lift7 (a b c d e f g)) | |
442 | ||
e4bed284 LC |
443 | (define (lift proc monad) |
444 | "Lift PROC, a procedure that accepts an arbitrary number of arguments, to | |
445 | MONAD---i.e., return a monadic function in MONAD." | |
b860f382 LC |
446 | (lambda args |
447 | (with-monad monad | |
448 | (return (apply proc args))))) | |
449 | ||
dcb95c1f | 450 | (define-template (foldm monad mproc init lst) |
b734996f LC |
451 | "Fold MPROC over LST and return a monadic value seeded by INIT. |
452 | ||
453 | (foldm %state-monad (lift2 cons %state-monad) '() '(a b c)) | |
454 | => '(c b a) ;monadic | |
455 | " | |
b860f382 LC |
456 | (with-monad monad |
457 | (let loop ((lst lst) | |
458 | (result init)) | |
459 | (match lst | |
460 | (() | |
461 | (return result)) | |
dcb95c1f | 462 | ((head . tail) |
b734996f LC |
463 | (>>= (mproc head result) |
464 | (lambda (result) | |
465 | (loop tail result)))))))) | |
b860f382 | 466 | |
dcb95c1f | 467 | (define-template (mapm monad mproc lst) |
b734996f LC |
468 | "Map MPROC over LST and return a monadic list. |
469 | ||
470 | (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2)) | |
471 | => (1 2 3) ;monadic | |
472 | " | |
dcb95c1f LC |
473 | ;; XXX: We don't use 'foldm' because template specialization wouldn't work |
474 | ;; in this context. | |
475 | (with-monad monad | |
476 | (let mapm ((lst lst) | |
477 | (result '())) | |
478 | (match lst | |
479 | (() | |
480 | (return (reverse result))) | |
481 | ((head . tail) | |
482 | (>>= (mproc head) | |
483 | (lambda (head) | |
484 | (mapm tail (cons head result))))))))) | |
485 | ||
486 | (define-template (sequence monad lst) | |
b860f382 LC |
487 | "Turn the list of monadic values LST into a monadic list of values, by |
488 | evaluating each item of LST in sequence." | |
b860f382 | 489 | (with-monad monad |
8d7dc5d9 LC |
490 | (let seq ((lstx lst) |
491 | (result '())) | |
492 | (match lstx | |
493 | (() | |
494 | (return (reverse result))) | |
495 | ((head . tail) | |
496 | (>>= head | |
497 | (lambda (item) | |
498 | (seq tail (cons item result))))))))) | |
b860f382 | 499 | |
dcb95c1f | 500 | (define-template (anym monad mproc lst) |
b734996f LC |
501 | "Apply MPROC to the list of values LST; return as a monadic value the first |
502 | value for which MPROC returns a true monadic value or #f. For example: | |
503 | ||
504 | (anym %state-monad (lift1 odd? %state-monad) '(0 1 2)) | |
505 | => #t ;monadic | |
506 | " | |
b860f382 LC |
507 | (with-monad monad |
508 | (let loop ((lst lst)) | |
509 | (match lst | |
510 | (() | |
511 | (return #f)) | |
dcb95c1f | 512 | ((head . tail) |
b734996f LC |
513 | (>>= (mproc head) |
514 | (lambda (result) | |
515 | (if result | |
516 | (return result) | |
517 | (loop tail))))))))) | |
b860f382 LC |
518 | |
519 | (define-syntax listm | |
520 | (lambda (s) | |
521 | "Return a monadic list in MONAD from the monadic values MVAL." | |
522 | (syntax-case s () | |
523 | ((_ monad mval ...) | |
524 | (with-syntax (((val ...) (generate-temporaries #'(mval ...)))) | |
525 | #'(mlet monad ((val mval) ...) | |
526 | (return (list val ...)))))))) | |
527 | ||
528 | ||
529 | \f | |
530 | ;;; | |
531 | ;;; Identity monad. | |
532 | ;;; | |
533 | ||
aeb7ec5c | 534 | (define-inlinable (identity-return value) |
b860f382 LC |
535 | value) |
536 | ||
aeb7ec5c | 537 | (define-inlinable (identity-bind mvalue mproc) |
b860f382 LC |
538 | (mproc mvalue)) |
539 | ||
aeb7ec5c LC |
540 | (define-monad %identity-monad |
541 | (bind identity-bind) | |
542 | (return identity-return)) | |
b860f382 | 543 | |
81a97734 LC |
544 | \f |
545 | ;;; | |
546 | ;;; State monad. | |
547 | ;;; | |
548 | ||
549 | (define-inlinable (state-return value) | |
550 | (lambda (state) | |
551 | (values value state))) | |
552 | ||
553 | (define-inlinable (state-bind mvalue mproc) | |
554 | "Bind MVALUE, a value in the state monad, and pass it to MPROC." | |
555 | (lambda (state) | |
556 | (call-with-values | |
557 | (lambda () | |
558 | (mvalue state)) | |
559 | (lambda (value state) | |
560 | ;; Note: as of Guile 2.0.11, declaring a variable to hold the result | |
561 | ;; of (mproc value) prevents a bit of unfolding/inlining. | |
562 | ((mproc value) state))))) | |
563 | ||
564 | (define-monad %state-monad | |
565 | (bind state-bind) | |
566 | (return state-return)) | |
567 | ||
568 | (define* (run-with-state mval #:optional (state '())) | |
569 | "Run monadic value MVAL starting with STATE as the initial state. Return | |
570 | two values: the resulting value, and the resulting state." | |
571 | (mval state)) | |
572 | ||
573 | (define-inlinable (current-state) | |
574 | "Return the current state as a monadic value." | |
575 | (lambda (state) | |
576 | (values state state))) | |
577 | ||
578 | (define-inlinable (set-current-state value) | |
579 | "Set the current state to VALUE and return the previous state as a monadic | |
580 | value." | |
581 | (lambda (state) | |
582 | (values state value))) | |
583 | ||
584 | (define (state-pop) | |
585 | "Pop a value from the current state and return it as a monadic value. The | |
586 | state is assumed to be a list." | |
587 | (lambda (state) | |
588 | (match state | |
589 | ((head . tail) | |
590 | (values head tail))))) | |
591 | ||
592 | (define (state-push value) | |
593 | "Push VALUE to the current state, which is assumed to be a list, and return | |
594 | the previous state as a monadic value." | |
595 | (lambda (state) | |
596 | (values state (cons value state)))) | |
597 | ||
b860f382 | 598 | ;;; monads.scm end here |