blob: f1f44d832405cb989cebc94dbb9d219f865ea063 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
;;; Commentary:
;;
;; Your classical optional (Maybe) monad.
;; It has the constructors @code{just} and @code{nothing}.
;;
;;; Code:
(define-module (monad optional)
#:use-module (oop goops)
#:use-module (monad)
#:export (from-just
from-maybe wrap-maybe
nothing just
nothing? just?)
#:re-export (>>= >> return))
(define-class <optional> ())
(define-class <nothing> (<optional>))
(define-class <just> (<optional>)
(slot #:init-keyword #:slot
#:getter from-just))
(define (nothing) (make <nothing>))
(define (just obj) (make <just> #:slot obj))
(define (nothing? this)
(is-a? this <nothing>))
(define (just? this)
(is-a? this <just>))
;; Returns default if maybe-val is nothing, otherwise
;; the value embedded in maybe-val
(define-method (from-maybe default (_ <nothing>)) default)
(define-method (from-maybe _ (m <just>)) (from-just m))
(define (wrap-maybe proc)
"Wraps a function in an optional monad, where #f returns are translated to
nothing."
(lambda values
(let ((v (apply proc values)))
(if v (just v) (nothing)))))
(define-method (write (this <just>) port)
(format port "#<just ~s>" (from-just this)))
(define-method (write (this <nothing>) port)
(format port "#<nothing>"))
(define-method (>>= (_ <nothing>) (f <procedure>)) (nothing))
(define-method (>>= (j <just>) (f <procedure>)) (f (from-just j)))
(define-method (return (a <optional>)) just)
(define (curry arg-count proc . collected)
(if (zero? arg-count)
(apply proc collected)
(lambda (x) (apply curry (1- arg-count) proc x collected))))
(define-method (equal? (a <optional>)
(b <optional>))
(or (and (nothing? a) (nothing? b))
(from-maybe #f #!curly-infix { {(curry 2 equal?) <$> a} <*> b })))
|
