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. | |
e87f0591 | 49 | %identity-monad)) |
b860f382 LC |
50 | |
51 | ;;; Commentary: | |
52 | ;;; | |
53 | ;;; This module implements the general mechanism of monads, and provides in | |
54 | ;;; particular an instance of the "store" monad. The API was inspired by that | |
55 | ;;; of Racket's "better-monads" module (see | |
56 | ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>). | |
57 | ;;; The implementation and use case were influenced by Oleg Kysielov's | |
58 | ;;; "Monadic Programming in Scheme" (see | |
59 | ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>). | |
60 | ;;; | |
61 | ;;; The store monad allows us to (1) build sequences of operations in the | |
62 | ;;; store, and (2) make the store an implicit part of the execution context, | |
63 | ;;; rather than a parameter of every single function. | |
64 | ;;; | |
65 | ;;; Code: | |
66 | ||
aeb7ec5c LC |
67 | ;; Record type for monads manipulated at run time. |
68 | (define-record-type <monad> | |
69 | (make-monad bind return) | |
b860f382 LC |
70 | monad? |
71 | (bind monad-bind) | |
72 | (return monad-return)) ; TODO: Add 'plus' and 'zero' | |
73 | ||
aeb7ec5c LC |
74 | (define-syntax define-monad |
75 | (lambda (s) | |
76 | "Define the monad under NAME, with the given bind and return methods." | |
77 | (define prefix (string->symbol "% ")) | |
78 | (define (make-rtd-name name) | |
79 | (datum->syntax name | |
80 | (symbol-append prefix (syntax->datum name) '-rtd))) | |
81 | ||
82 | (syntax-case s (bind return) | |
83 | ((_ name (bind b) (return r)) | |
84 | (with-syntax ((rtd (make-rtd-name #'name))) | |
85 | #`(begin | |
86 | (define rtd | |
87 | ;; The record type, for use at run time. | |
88 | (make-monad b r)) | |
89 | ||
90 | (define-syntax name | |
91 | ;; An "inlined record", for use at expansion time. The goal is | |
92 | ;; to allow 'bind' and 'return' to be resolved at expansion | |
93 | ;; time, in the common case where the monad is accessed | |
94 | ;; directly as NAME. | |
95 | (lambda (s) | |
96 | (syntax-case s (%bind %return) | |
97 | ((_ %bind) #'b) | |
98 | ((_ %return) #'r) | |
99 | (_ #'rtd)))))))))) | |
100 | ||
b860f382 LC |
101 | (define-syntax-parameter >>= |
102 | ;; The name 'bind' is already taken, so we choose this (obscure) symbol. | |
103 | (lambda (s) | |
104 | (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s))) | |
105 | ||
106 | (define-syntax-parameter return | |
107 | (lambda (s) | |
108 | (syntax-violation 'return "return used outside of 'with-monad'" s))) | |
109 | ||
110 | (define-syntax with-monad | |
111 | (lambda (s) | |
112 | "Evaluate BODY in the context of MONAD, and return its result." | |
113 | (syntax-case s () | |
114 | ((_ monad body ...) | |
aeb7ec5c LC |
115 | (eq? 'macro (syntax-local-binding #'monad)) |
116 | ;; MONAD is a syntax transformer, so we can obtain the bind and return | |
117 | ;; methods by directly querying it. | |
118 | #'(syntax-parameterize ((>>= (identifier-syntax (monad %bind))) | |
119 | (return (identifier-syntax (monad %return)))) | |
120 | body ...)) | |
121 | ((_ monad body ...) | |
122 | ;; MONAD refers to the <monad> record that represents the monad at run | |
123 | ;; time, so use the slow method. | |
b860f382 LC |
124 | #'(syntax-parameterize ((>>= (identifier-syntax |
125 | (monad-bind monad))) | |
126 | (return (identifier-syntax | |
127 | (monad-return monad)))) | |
128 | body ...))))) | |
129 | ||
130 | (define-syntax mlet* | |
131 | (syntax-rules (->) | |
132 | "Bind the given monadic values MVAL to the given variables VAR. When the | |
133 | form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as | |
134 | 'let'." | |
135 | ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'. | |
136 | ((_ monad () body ...) | |
137 | (with-monad monad body ...)) | |
138 | ((_ monad ((var mval) rest ...) body ...) | |
139 | (with-monad monad | |
140 | (>>= mval | |
141 | (lambda (var) | |
142 | (mlet* monad (rest ...) | |
143 | body ...))))) | |
144 | ((_ monad ((var -> val) rest ...) body ...) | |
145 | (let ((var val)) | |
146 | (mlet* monad (rest ...) | |
147 | body ...))))) | |
148 | ||
149 | (define-syntax mlet | |
150 | (lambda (s) | |
151 | (syntax-case s () | |
152 | ((_ monad ((var mval ...) ...) body ...) | |
153 | (with-syntax (((temp ...) (generate-temporaries #'(var ...)))) | |
154 | #'(mlet* monad ((temp mval ...) ...) | |
155 | (let ((var temp) ...) | |
156 | body ...))))))) | |
157 | ||
405a9d4e | 158 | (define-syntax mbegin |
21caa6de | 159 | (syntax-rules (%current-monad) |
405a9d4e LC |
160 | "Bind the given monadic expressions in sequence, returning the result of |
161 | the last one." | |
21caa6de LC |
162 | ((_ %current-monad mexp) |
163 | mexp) | |
164 | ((_ %current-monad mexp rest ...) | |
165 | (>>= mexp | |
166 | (lambda (unused-value) | |
167 | (mbegin %current-monad rest ...)))) | |
405a9d4e LC |
168 | ((_ monad mexp) |
169 | (with-monad monad | |
170 | mexp)) | |
171 | ((_ monad mexp rest ...) | |
172 | (with-monad monad | |
173 | (>>= mexp | |
174 | (lambda (unused-value) | |
175 | (mbegin monad rest ...))))))) | |
176 | ||
21caa6de LC |
177 | (define-syntax mwhen |
178 | (syntax-rules () | |
179 | "When CONDITION is true, evaluate EXP0..EXP* as in an 'mbegin'. When | |
180 | CONDITION is false, return *unspecified* in the current monad." | |
181 | ((_ condition exp0 exp* ...) | |
182 | (if condition | |
183 | (mbegin %current-monad | |
184 | exp0 exp* ...) | |
185 | (return *unspecified*))))) | |
186 | ||
187 | (define-syntax munless | |
188 | (syntax-rules () | |
189 | "When CONDITION is false, evaluate EXP0..EXP* as in an 'mbegin'. When | |
190 | CONDITION is true, return *unspecified* in the current monad." | |
191 | ((_ condition exp0 exp* ...) | |
192 | (if condition | |
193 | (return *unspecified*) | |
194 | (mbegin %current-monad | |
195 | exp0 exp* ...))))) | |
196 | ||
b860f382 LC |
197 | (define-syntax define-lift |
198 | (syntax-rules () | |
199 | ((_ liftn (args ...)) | |
200 | (define (liftn proc monad) | |
201 | "Lift PROC to MONAD---i.e., return a monadic function in MONAD." | |
202 | (lambda (args ...) | |
203 | (with-monad monad | |
204 | (return (proc args ...)))))))) | |
205 | ||
b307c064 | 206 | (define-lift lift0 ()) |
b860f382 LC |
207 | (define-lift lift1 (a)) |
208 | (define-lift lift2 (a b)) | |
209 | (define-lift lift3 (a b c)) | |
210 | (define-lift lift4 (a b c d)) | |
211 | (define-lift lift5 (a b c d e)) | |
212 | (define-lift lift6 (a b c d e f)) | |
213 | (define-lift lift7 (a b c d e f g)) | |
214 | ||
e4bed284 LC |
215 | (define (lift proc monad) |
216 | "Lift PROC, a procedure that accepts an arbitrary number of arguments, to | |
217 | MONAD---i.e., return a monadic function in MONAD." | |
b860f382 LC |
218 | (lambda args |
219 | (with-monad monad | |
220 | (return (apply proc args))))) | |
221 | ||
222 | (define (foldm monad mproc init lst) | |
223 | "Fold MPROC over LST, a list of monadic values in MONAD, and return a | |
224 | monadic value seeded by INIT." | |
225 | (with-monad monad | |
226 | (let loop ((lst lst) | |
227 | (result init)) | |
228 | (match lst | |
229 | (() | |
230 | (return result)) | |
231 | ((head tail ...) | |
232 | (mlet* monad ((item head) | |
233 | (result (mproc item result))) | |
234 | (loop tail result))))))) | |
235 | ||
236 | (define (mapm monad mproc lst) | |
237 | "Map MPROC over LST, a list of monadic values in MONAD, and return a monadic | |
f62435e2 LC |
238 | list. LST items are bound from left to right, so effects in MONAD are known |
239 | to happen in that order." | |
240 | (mlet monad ((result (foldm monad | |
241 | (lambda (item result) | |
242 | (mlet monad ((item (mproc item))) | |
243 | (return (cons item result)))) | |
244 | '() | |
245 | lst))) | |
246 | (return (reverse result)))) | |
b860f382 LC |
247 | |
248 | (define-inlinable (sequence monad lst) | |
249 | "Turn the list of monadic values LST into a monadic list of values, by | |
250 | evaluating each item of LST in sequence." | |
b860f382 LC |
251 | (with-monad monad |
252 | (mapm monad return lst))) | |
253 | ||
254 | (define (anym monad proc lst) | |
255 | "Apply PROC to the list of monadic values LST; return the first value, | |
256 | lifted in MONAD, for which PROC returns true." | |
257 | (with-monad monad | |
258 | (let loop ((lst lst)) | |
259 | (match lst | |
260 | (() | |
261 | (return #f)) | |
262 | ((head tail ...) | |
593c3fe6 LC |
263 | (mlet* monad ((value head) |
264 | (result -> (proc value))) | |
265 | (if result | |
266 | (return result) | |
b860f382 LC |
267 | (loop tail)))))))) |
268 | ||
269 | (define-syntax listm | |
270 | (lambda (s) | |
271 | "Return a monadic list in MONAD from the monadic values MVAL." | |
272 | (syntax-case s () | |
273 | ((_ monad mval ...) | |
274 | (with-syntax (((val ...) (generate-temporaries #'(mval ...)))) | |
275 | #'(mlet monad ((val mval) ...) | |
276 | (return (list val ...)))))))) | |
277 | ||
278 | ||
279 | \f | |
280 | ;;; | |
281 | ;;; Identity monad. | |
282 | ;;; | |
283 | ||
aeb7ec5c | 284 | (define-inlinable (identity-return value) |
b860f382 LC |
285 | value) |
286 | ||
aeb7ec5c | 287 | (define-inlinable (identity-bind mvalue mproc) |
b860f382 LC |
288 | (mproc mvalue)) |
289 | ||
aeb7ec5c LC |
290 | (define-monad %identity-monad |
291 | (bind identity-bind) | |
292 | (return identity-return)) | |
b860f382 | 293 | |
b860f382 | 294 | ;;; monads.scm end here |