add do macro

dbian · Dec 26, 2023 · b555602 · b555602
1 parent 9de9fc3
commit b555602
Show file tree

Hide file tree

Showing 2 changed files with 95 additions and 71 deletions.
diff --git a/src/maybe.rkt b/src/maybe.rkt
@@ -1,30 +1,42 @@
-#lang racket
-(provide (all-defined-out))
-
-(struct maybe-type-just [value])
-(struct maybe-type-nothing [])
-
-(define (make-just value)
-  (maybe-type-just value))
-
-(define (make-nothing)
-  (maybe-type-nothing))
-
-(define (maybe-type? x)
-  (or (maybe-type-just? x)
-      (maybe-type-nothing? x)))
-
-(define (maybe-map maybe f)
-  (cond ((maybe-type-just? maybe)
-         (make-just (f (maybe-type-just-value maybe))))
-        ((maybe-type-nothing? maybe)
-         maybe)))
-
-(define (maybe-bind maybe f)
-  (cond ((maybe-type-just? maybe)
-         (f (maybe-type-just-value maybe)))
-        ((maybe-type-nothing? maybe)
-         maybe)))
-
-(define (maybe-just-value maybe)
-  (maybe-type-just-value maybe))
+#lang racket
+(provide (all-defined-out))
+
+(struct maybe-type-just [value])
+(struct maybe-type-nothing [])
+
+(define (make-just value)
+  (maybe-type-just value))
+
+(define (make-nothing)
+  (maybe-type-nothing))
+
+(define (maybe-type? x)
+  (or (maybe-type-just? x)
+      (maybe-type-nothing? x)))
+
+(define (maybe-map maybe f)
+  (cond ((maybe-type-just? maybe)
+         (make-just (f (maybe-type-just-value maybe))))
+        ((maybe-type-nothing? maybe)
+         maybe)))
+
+(define (maybe-bind maybe f)
+  (cond ((maybe-type-just? maybe)
+         (f (maybe-type-just-value maybe)))
+        ((maybe-type-nothing? maybe)
+         maybe)))
+
+(define (maybe-just-value maybe)
+  (maybe-type-just-value maybe))
+
+(define-syntax maybe/do
+  (syntax-rules (<-)
+    ((_ (val1 <- maybe1) exp1 exp2 ...)
+     (maybe-bind maybe1
+                 (λ (val1) (maybe/do exp1 exp2 ...))))
+    ((_ exp1 exp2 exp3 ...)
+     (maybe-bind exp1 (λ (_) (maybe/do exp2 exp3 ...)))
+     )
+    ((_ exp1) exp1
+              )
+    ))
diff --git a/src/result.rkt b/src/result.rkt
@@ -1,41 +1,53 @@
-
-#lang racket
-(require "maybe.rkt")
-(struct result-type-success [value])
-(struct result-type-error [message])
-
-(define (make-success value)
-  (result-type-success value))
-
-(define (make-error message)
-  (result-type-error message))
-
-(define (result-type? x)
-  (or (result-type-success? x)
-      (result-type-error? x)))
-
-(define (result-map result f)
-  (cond ((result-type-success? result)
-         (make-success (f (result-type-success-value result))))
-        ((result-type-error? result)
-         result)))
-
-(define (result-bind result f)
-  (cond ((result-type-success? result)
-         (f (result-type-success-value result)))
-        ((result-type-error? result)
-         result)))
-
-(define (result2maybe result)
-  (cond ((result-type-success? result)
-         (make-just (result-type-success-value result)))
-        ((result-type-error? result)
-         (make-nothing))))
-
-(define (result-success-val result)
-  (result-type-success-value result))
-
-(define (result-error-val result)
-  (result-type-error-message result))
-
-(provide (all-defined-out))
+
+#lang racket
+(require "maybe.rkt")
+(struct result-type-success [value])
+(struct result-type-error [message])
+
+(define (make-success value)
+  (result-type-success value))
+
+(define (make-error message)
+  (result-type-error message))
+
+(define (result-type? x)
+  (or (result-type-success? x)
+      (result-type-error? x)))
+
+(define (result-map result f)
+  (cond ((result-type-success? result)
+         (make-success (f (result-type-success-value result))))
+        ((result-type-error? result)
+         result)))
+
+(define (result-bind result f)
+  (cond ((result-type-success? result)
+         (f (result-type-success-value result)))
+        ((result-type-error? result)
+         result)))
+
+(define (result2maybe result)
+  (cond ((result-type-success? result)
+         (make-just (result-type-success-value result)))
+        ((result-type-error? result)
+         (make-nothing))))
+
+(define (result-success-val result)
+  (result-type-success-value result))
+
+(define (result-error-val result)
+  (result-type-error-message result))
+
+(define-syntax result/do
+  (syntax-rules (<-)
+    ((_ (val1 <- result1) exp1 exp2 ...)
+     (result-bind result1
+                  (λ (val1) (result/do exp1 exp2 ...))))
+    ((_ exp1 exp2 exp3 ...)
+     (result-bind exp1 (λ (_) (result/do exp2 exp3 ...)))
+     )
+    ((_ exp1) exp1
+              )
+    ))
+
+(provide (all-defined-out))