1;;;
2;;; srfi-189 - Maybe and Either
3;;;
4;;;   Copyright (c) 2020  Shiro Kawai  <shiro@acm.org>
5;;;
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34(define-module srfi-189
35  (use srfi-1)
36  (use util.match)
37  (export just nothing right left either-swap
38          maybe? either? just? nothing? right? left? maybe-ref-error?
39          maybe= either=
40          maybe-ref either-ref maybe-ref/default either-ref/default
41          maybe-join either-join
42          maybe-compose either-compose
43          maybe-bind either-bind
44          maybe-length either-length
45          maybe-filter maybe-remove either-filter either-remove
46          maybe-sequence either-sequence
47          maybe->either either->maybe list->just list->right list->left
48          maybe->list either->list list->maybe list->either
49          maybe->truth either->truth truth->maybe truth->either
50          maybe->list-truth either->list-truth
51          list-truth->maybe list-truth->either
52          maybe->generation generation->maybe
53          either->generation generation->either
54          maybe->values either->values
55          values->maybe values->either
56          maybe->two-values two-values->maybe
57          exception->either
58          maybe-map either-map maybe-for-each either-for-each
59          maybe-fold either-fold maybe-unfold either-unfold
60          maybe-if
61          maybe-and maybe-or maybe-let* maybe-let*-values
62          either-and either-or either-let* either-let*-values
63          either-guard
64
65          tri-not tri=? tri-and tri-or tri-merge
66          )
67  ;; The followings are Gauche-specific.
68  (export <maybe> <just> <nothing>
69          <either> <left> <right>)
70  )
71(select-module srfi-189)
72
73(define-class <maybe> () ())
74(define-method initialize ((obj <maybe>) initargs)
75  (when (eq? (class-of obj) <maybe>)
76    (error "You can't instantiate <maybe> directly."))
77  (next-method))
78
79(define-class <just> (<maybe>)
80  ((objs :init-keyword :objs)))
81(define-class <nothing> (<maybe>) ())
82
83(define-class <either> () ())
84(define-method initialize ((obj <either>) initargs)
85  (when (eq? (class-of obj) <either>)
86    (error "You can't instantiate <either> directly."))
87  (next-method))
88
89(define-class <right> (<either>)
90  ((objs :init-keyword :objs)))
91(define-class <left> (<either>)
92  ((objs :init-keyword :objs)))
93
94(define-condition-type <maybe-ref-error> <error>
95  maybe-ref-error?)
96
97(define-method write-object ((obj <just>) port)
98  (format port "#<Just ~a>"
99          (string-join (map write-to-string (~ obj'objs)) " ")))
100(define-method write-object ((obj <nothing>) port)
101  (display "#<Nothing>" port))
102(define-method write-object ((obj <right>) port)
103  (format port "#<Right ~a>"
104          (string-join (map write-to-string (~ obj'objs)) " ")))
105(define-method write-object ((obj <left>) port)
106  (format port "#<Left ~a>"
107          (string-join (map write-to-string (~ obj'objs)) " ")))
108
109
110(define *nothing* (make <nothing>))
111
112;;; Constructors
113(define (just . objs) (make <just> :objs objs))
114(define (nothing) *nothing*)
115(define (right . objs) (make <right> :objs objs))
116(define (left . objs) (make <left> :objs objs))
117
118(define (list->just lis) (make <just> :objs lis))
119(define (list->right lis) (make <right> :objs lis))
120(define (list->left lis) (make <left> :objs lis))
121
122(define (maybe->either maybe . objs)
123  (assume-type maybe <maybe>)
124  (if (just? maybe)
125    (list->right (~ maybe'objs))
126    (list->left objs)))
127
128(define (either->maybe either)
129  (assume-type either <either>)
130  (if (right? either)
131    (list->just (~ either'objs))
132    (nothing)))
133
134(define (either-swap either)
135  (assume-type either <either>)
136  (make (if (left? either) <right> <left>) :objs (~ either'objs)))
137
138;;; Predicates
139
140(define (maybe? x) (is-a? x <maybe>))
141(define (just? x) (is-a? x <just>))
142(define (nothing? x) (is-a? x <nothing>))
143(define (either? x) (is-a? x <either>))
144(define (right? x) (is-a? x <right>))
145(define (left? x) (is-a? x <left>))
146
147(define (maybe= eqproc x . xs)
148  (or (null? xs)
149      (let1 y (car xs)
150        (and (or (and (nothing? x) (nothing? y))
151                 (and (just? x) (just? y)
152                      (list= eqproc (~ x'objs) (~ y'objs))))
153             (or (null? (cdr xs))
154                 (apply maybe= eqproc xs))))))
155
156(define (either= eqproc x . xs)
157  (or (null? xs)
158      (let1 y (car xs)
159        (and (or (and (right? x) (right? y)
160                      (list= eqproc (~ x'objs) (~ y'objs)))
161                 (and (left? x) (left? y)
162                      (list= eqproc (~ x'objs) (~ y'objs))))
163             (or (null? (cdr xs))
164                 (apply either= eqproc xs))))))
165
166;;; Accessors
167
168;; returns one value in container; raises an error if container doesn't have
169;; exactly one value.
170(define (%ref1 container)
171  (match (~ container'objs)
172    [(x) x]
173    [_ (error "~a with exactly one value expected, but got: ~s"
174              (class-of container) container)]))
175
176(define (maybe-ref maybe failure :optional (success values))
177  (assume-type maybe <maybe>)
178  (if (nothing? maybe)
179    (failure)
180    (apply success (~ maybe'objs))))
181
182(define (either-ref either failure :optional (success values))
183  (assume-type either <either>)
184  (if (left? either)
185    (apply failure (~ either'objs))
186    (apply success (~ either'objs))))
187
188(define (maybe-ref/default maybe . defaults)
189  (assume-type maybe <maybe>)
190  (apply values (if (just? maybe) (~ maybe'objs) defaults)))
191
192(define (either-ref/default either . defaults)
193  (assume-type either <either>)
194  (apply values (if (right? either) (~ either'objs) defaults)))
195
196;;; Join and bind
197
198(define (maybe-join maybe)
199  (assume-type maybe <maybe>)
200  (if (nothing? maybe)
201    maybe
202    (match (~ maybe'objs)
203      [((? maybe? val)) val]
204      [x (error "invalid payload" x)])))
205
206(define (either-join either)
207  (assume-type either <either>)
208  (if (left? either)
209    either
210    (match (~ either'objs)
211      [((? either? val)) val]
212      [x (error "invalid payload" x)])))
213
214(define (maybe-bind maybe proc . procs)
215  (assume-type maybe <maybe>)
216  (if (nothing? maybe)
217    maybe
218    (if (null? procs)
219      (apply proc (~ maybe'objs))       ;tail call
220      (apply maybe-bind (apply proc (~ maybe'objs)) procs))))
221
222(define (maybe-compose proc . procs)
223  (if (null? procs)
224    proc
225    (let1 p (apply maybe-compose procs)
226      (^ args
227        (let1 m (apply proc args)
228          (if (nothing? m)
229            m
230            (apply p (~ m'objs))))))))
231
232(define (either-bind either proc . procs)
233  (assume-type either <either>)
234  (if (left? either)
235    either
236    (if (null? procs)
237      (apply proc (~ either'objs))      ;tail call
238      (apply either-bind (apply proc (~ either'objs)) procs))))
239
240(define (either-compose proc . procs)
241  (if (null? procs)
242    proc
243    (let1 p (apply either-compose procs)
244      (^ args
245        (let1 e (apply proc args)
246          (unless (either? e)
247            (error "mproc returned non-either object:" e))
248          (if (left? e)
249            e
250            (apply p (~ e'objs))))))))
251
252;;; Sequence operations
253
254(define (maybe-length maybe)
255  (assume-type maybe <maybe>)
256  (if (nothing? maybe) 0 1))
257
258(define (either-length either)
259  (assume-type either <either>)
260  (if (left? either) 0 1))
261
262(define (maybe-filter pred maybe)
263  (assume-type maybe <maybe>)
264  (if (and (just? maybe) (apply pred (~ maybe'objs)))
265    maybe
266    (nothing)))
267
268(define (maybe-remove pred maybe)
269  (assume-type maybe <maybe>)
270  (if (and (just? maybe) (not (apply pred (~ maybe'objs))))
271    maybe
272    (nothing)))
273
274(define (either-filter pred either . objs)
275  (assume-type either <either>)
276  (if (and (right? either) (apply pred (~ either'objs)))
277    either
278    (list->left objs)))
279
280(define (either-remove pred either . objs)
281  (assume-type either <either>)
282  (if (and (right? either) (not (apply pred (~ either'objs))))
283    either
284    (list->left objs)))
285
286;; input :: Container Maybe a*
287;; cmap :: Container Maybe a* -> (Maybe a* -> b) -> Container b
288;; aggregator :: a* -> b
289;; Returns Maybe Container b
290(define (maybe-sequence input cmap :optional (aggregator list))
291  (let/cc return
292    (just (cmap (^[me] (maybe-ref me (^[] (return (nothing))) aggregator))
293                input))))
294
295;; input :: Container Either a*
296;; cmap :: Container Either a* -> (Either a -> b) -> Container b
297;; aggregator :: a* -> b
298;; returns Either Container b
299(define (either-sequence input cmap :optional (aggregator list))
300  (let/cc return
301    (right (cmap (^[ee] (either-ref ee (^ _ (return ee)) aggregator))
302                 input))))
303
304;;; Protocol conversion
305
306(define (maybe->list maybe)
307  (assume-type maybe <maybe>)
308  (if (nothing? maybe) '() (~ maybe'objs)))
309(define (list->maybe lis)
310  (if (null? lis)
311    (nothing)
312    (apply just lis)))
313(define (either->list either)
314  (assume-type either <either>)
315  (~ either'objs))
316(define (list->either lis . objs)
317  (if (null? lis)
318    (apply left objs)
319    (apply right lis)))
320
321(define (maybe->truth maybe)
322  (assume-type maybe <maybe>)
323  (and (just? maybe) (%ref1 maybe)))
324(define (truth->maybe obj)
325  (if obj (just obj) (nothing)))
326(define (either->truth either)
327  (assume-type either <either>)
328  (and (right? either) (%ref1 either)))
329(define (truth->either obj . fail-objs)
330  (if obj (right obj) (apply left fail-objs)))
331
332(define (maybe->list-truth maybe)
333  (assume-type maybe <maybe>)
334  (and (just? maybe) (~ maybe'objs)))
335(define (list-truth->maybe lis-or-false)
336  (if lis-or-false (apply just lis-or-false) (nothing)))
337(define (either->list-truth either)
338  (assume-type either <either>)
339  (and (right? either) (~ either'objs)))
340(define (list-truth->either lis-or-false . fail-objs)
341  (if lis-or-false (apply right lis-or-false) (apply left fail-objs)))
342
343(define (maybe->generation maybe)
344  (assume-type maybe <maybe>)
345  (if (just? maybe)
346    (%ref1 maybe)
347    (eof-object)))
348(define (generation->maybe obj)
349  (if (eof-object? obj)
350    (nothing)
351    (just obj)))
352(define (either->generation either)
353  (assume-type either <either>)
354  (if (right? either)
355    (%ref1 either)
356    (eof-object)))
357(define (generation->either obj . objs)
358  (if (eof-object? obj)
359    (apply left objs)
360    (right obj)))
361
362(define (maybe->values maybe)
363  (assume-type maybe <maybe>)
364  (if (nothing? maybe) (values) (apply values (~ maybe'objs))))
365(define (either->values either)
366  (assume-type either <either>)
367  (if (left? either) (values) (apply values (~ either'objs))))
368
369(define (values->maybe producer)
370  (call-with-values producer
371    (^ xs (if (null? xs) (nothing) (apply just xs)))))
372(define (values->either producer . objs)
373  (call-with-values producer
374    (^ xs (if (null? xs) (apply left objs) (apply right xs)))))
375
376(define (maybe->two-values maybe)
377  (assume-type maybe <maybe>)
378  (if (nothing? maybe)
379    (values #f #f)
380    (values (%ref1 maybe) #t)))
381
382(define (two-values->maybe producer)
383  (receive (val has-val?) (producer)
384    (if has-val? (just val) (nothing))))
385
386(define (exception->either pred thunk)
387  (guard (e [(pred e) (left e)])
388    (call-with-values thunk right)))
389
390;;; Map, fold and unfold
391
392(define (maybe-map proc maybe)
393  (assume-type maybe <maybe>)
394  (if (nothing? maybe)
395    maybe
396    (list->just (values->list (apply proc (~ maybe'objs))))))
397(define (either-map proc either)
398  (assume-type either <either>)
399  (if (left? either)
400    either
401    (list->right (values->list (apply proc (~ either'objs))))))
402
403(define (maybe-for-each proc maybe)
404  (assume-type maybe <maybe>)
405  (when (just? maybe)
406    (apply proc (~ maybe'objs)))
407  (undefined))
408(define (either-for-each proc either)
409  (assume-type either <either>)
410  (when (right? either)
411    (apply proc (~ either'objs)))
412  (undefined))
413
414(define (maybe-fold kons knil maybe)
415  (assume-type maybe <maybe>)
416  (if (nothing? maybe)
417    knil
418    (apply kons (append (~ maybe'objs) (list knil)))))
419(define (either-fold kons knil either)
420  (assume-type either <either>)
421  (if (right? either)
422    (apply kons (append (~ either'objs) (list knil)))
423    knil))
424
425(define (maybe-unfold stop? mapper successor . seeds)
426  (if (apply stop? seeds)
427    (nothing)
428    (if (call-with-values (cut apply successor seeds) stop?)
429      (list->just (values->list (apply mapper seeds)))
430      (error "unstoppable unfold"))))
431
432(define (either-unfold stop? mapper successor . seeds)
433  (if (apply stop? seeds)
434    (list->left seeds)
435    (if (call-with-values (cut apply successor seeds) stop?)
436      (list->right (values->list (apply mapper seeds)))
437      (error "unstoppable unfold"))))
438
439;;; Conditional syntax
440
441(define-syntax maybe-if
442  (syntax-rules ()
443    [(_ expr justx nothingx)
444     (if (just? (assume-type expr <maybe>)) justx nothingx)]))
445
446(define-syntax maybe-and
447  (syntax-rules ()
448    [(_) (just "empty maybe-and")]
449    [(_ x) (assume-type x <maybe>)]
450    [(_ x . xs) (let1 t (assume-type x <maybe>)
451                  (if (nothing? t) t (maybe-and . xs)))]))
452
453(define-syntax either-and
454  (syntax-rules ()
455    [(_) (right "empty either-and")]
456    [(_ x) (assume-type x <either>)]
457    [(_ x . xs) (let1 t (assume-type x <either>)
458                  (if (left? t) t (either-and . xs)))]))
459
460(define-syntax maybe-or
461  (syntax-rules ()
462    [(_) (nothing)]
463    [(_ x) (assume-type x <maybe>)]
464    [(_ x . xs) (let1 t (assume-type x <maybe>)
465                  (if (just? t) t (maybe-or . xs)))]))
466
467(define-syntax either-or
468  (syntax-rules ()
469    [(_) (left "empty either-or")]
470    [(_ x) (assume-type x <either>)]
471    [(_ x . xs) (let1 t (assume-type x <either>)
472                  (if (right? t) t (either-or . xs)))]))
473
474(define-syntax maybe-let*
475  (syntax-rules ()
476    ;; empty body case
477    [(_ ()) (just #t)]
478    [(_ ((var expr))) (assume-type expr <maybe>)]
479    [(_ ((expr)))     (assume-type expr <maybe>)]
480    [(_ (var))        (assume-type var <maybe>)]
481    ;; normal case
482    [(_ () . body) (receive xs (let () . body) (list->just xs))]
483    [(_ ((var expr) . claws) . body)
484     (let1 t (assume-type expr <maybe>)
485       (if (nothing? t)
486         t
487         (let ((var (%ref1 t)))
488           (maybe-let* claws . body))))]
489    [(_ ((expr) . claws) . body)
490     (if (nothing? (assume-type expr <maybe>))
491       (nothing)
492       (maybe-let* claws . body))]
493    [(_ (var . claws) . body)
494     (if (nothing? (assume-type var <maybe>))
495       (nothing)
496       (maybe-let* claws . body))]))
497
498(define-syntax maybe-let*-values
499  (syntax-rules ()
500    ;; empty body case
501    [(_ ()) (just #t)]
502    [(_ ((formals expr))) (rlet1 t expr
503                            ;; Just make sure formals match the contained values
504                            (maybe-ref t nothing (^ formals #f)))]
505    [(_ ((expr)))     (assume-type expr <maybe>)]
506    [(_ (var))        (assume-type var <maybe>)]
507    ;; normal case
508    [(_ () . body) (receive xs (let () . body) (list->just xs))]
509    [(_ ((formals expr) . claws) . body)
510     (maybe-ref expr nothing
511                (^ formals (maybe-let*-values claws . body)))]
512    [(_ ((expr) . claws) . body)
513     (if (nothing? (assume-type expr <maybe>))
514       (nothing)
515       (maybe-let*-values claws . body))]
516    [(_ (var . claws) . body)
517     (if (nothing? (assume-type var <maybe>))
518       (nothing)
519       (maybe-let*-values claws . body))]))
520
521(define-syntax either-let*
522  (syntax-rules ()
523    ;; empty body case
524    [(_ ()) (right #t)]
525    [(_ ((var expr))) (assume-type expr <either>)]
526    [(_ ((expr)))     (assume-type expr <either>)]
527    [(_ (var))        (assume-type var <either>)]
528    ;; normal case
529    [(_ () . body) (receive xs (let () . body) (list->right xs))]
530    [(_ ((var expr) . claws) . body)
531     (let1 t (assume-type expr <either>)
532       (if (left? t) t (let ((var (%ref1 t)))
533                         (either-let* claws . body))))]
534    [(_ ((expr) . claws) . body)
535     (let1 t (assume-type expr <either>)
536       (if (left? t) t (either-let* claws . body)))]
537    [(_ (var . claws) . body)
538     (let1 t (assume-type var <either>)
539       (if (left? t) t (either-let* claws . body)))]))
540
541(define-syntax either-let*-values
542  (syntax-rules ()
543    ;; empty body case
544    [(_ ()) (right #t)]
545    [(_ ((formal expr))) (rlet1 t expr
546                           ;; just to check the values match formals
547                           (either-ref t (^ _ #f) (^ formals #f)))]
548    [(_ ((expr)))     (rlet1 t expr
549                        (assume-type t <either>))]
550    [(_ (var))        (assume-type var <either>)]
551    ;; normal case
552    [(_ () . body) (receive xs (let () . body) (list->right xs))]
553    [(_ ((formals expr) . claws) . body)
554     (either-ref expr left
555                 (^ formals (either-let*-values claws . body)))]
556    [(_ ((expr) . claws) . body)
557     (let1 t (assume-type expr <either>)
558       (if (left? t) t (either-let*-values claws . body)))]
559    [(_ (var . claws) . body)
560     (if (left? (assume-type var <either>))
561       var
562       (either-let*-values claws . body))]))
563
564(define-syntax either-guard
565  (syntax-rules ()
566    [(_ (pred-expr) . body)
567     (guard (e [(pred-expr e) (left e)])
568       (receive xs (begin . body)
569         (list->right xs)))]))
570
571;;; Trivalent logic
572
573(define (tri-not maybe)
574  (assume-type maybe <maybe>)
575  (if (nothing? maybe)
576    maybe
577    (just (not (%ref1 maybe)))))
578
579(define (tri=? maybe . maybes)
580  (define (rec val maybe maybes)
581    (if (nothing? (assume-type maybe <maybe>))
582      (just #f)
583      (if (boolean=? val (boolean (%ref1 maybe)))
584        (if (null? maybes)
585          (just #t)
586          (rec val (car maybes) (cdr maybes)))
587        (just #f))))
588
589  (if (nothing? (assume-type maybe <maybe>))
590    (just #f)
591    (let1 v (%ref1 maybe)
592      (if (null? maybes)
593        (just #t)
594        (rec v (car maybes) (cdr maybes))))))
595
596(define (tri-and . maybes)
597  (define (rec maybes)
598    (if (null? maybes)
599      (just #t)
600      (let ([maybe (car maybes)]
601            [maybes (cdr maybes)])
602        (if (nothing? (assume-type maybe <maybe>))
603          maybe
604          (if-let1 v (%ref1 maybe)
605            (rec maybes)
606            maybe)))))                  ; this must be #<just #f>
607  (rec maybes))
608
609(define (tri-or . maybes)
610  (define (rec maybes)
611    (if (null? maybes)
612      (just #f)
613      (let ([maybe (car maybes)]
614            [maybes (cdr maybes)])
615        (if (nothing? (assume-type maybe <maybe>))
616          maybe
617          (if-let1 v (%ref1 maybe)
618            maybe
619            (rec maybes))))))
620  (rec maybes))
621
622(define (tri-merge . maybes)
623  (define (rec maybes)
624    (if (null? maybes)
625      (nothing)
626      (let ([maybe (car maybes)]
627            [maybes (cdr maybes)])
628        (if (nothing? (assume-type maybe <maybe>))
629          (rec maybes)
630          maybe))))
631  (rec maybes))
632