Skip to content

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
...
  • 5 commits
  • 3 files changed
  • 0 commit comments
  • 1 contributor
Showing with 81 additions and 43 deletions.
  1. +1 −1 monad.release-info
  2. +79 −41 monad.scm
  3. +1 −1 monad.setup
View
2 monad.release-info
@@ -1,3 +1,3 @@
(repo git "git@github.com:dleslie/monad-egg.git")
(uri targz "https://github.com/dleslie/monad-egg/tarball/{egg-release}")
-(release "2.4")
+(release "2.5")
View
120 monad.scm
@@ -31,13 +31,13 @@
(fail ,(symbol-append name '-fail)))
(define-syntax :
(lambda (f r c)
- (let* ((f* (symbol-append ',name '- (cadr f)))
- (rest (cddr f)))
+ (let* ((f* (symbol-append ',name '- (cadr f))))
f*)))
- (define-syntax :!
- (syntax-rules ()
- ((_ f ...)
- ((: f) ...))))
+ (define-syntax :!
+ (lambda (f r c)
+ (let* ((f* (symbol-append ',name- (cadr f)))
+ (rest (cddr f)))
+ `(,f* . ,rest))))
,@body))))
(define-syntax fail
@@ -63,21 +63,18 @@
(failf (symbol-append name '-fail))
(name- (symbol-append name '-)))
`((,(r 'lambda) ()
- (define (return . rest)
- (apply ,unitf rest))
- (define (fail . rest)
- (apply ,failf rest))
- (define (>>= . rest)
- (apply ,bindf rest))
+ (define return ,unitf)
+ (define fail ,failf)
+ (define >>= ,bindf)
(define-syntax :
(lambda (f r c)
- (let* ((f* (symbol-append ',name- (cadr f)))
- (rest (cddr f)))
+ (let* ((f* (symbol-append ',name- (cadr f))))
f*)))
(define-syntax :!
- (syntax-rules ()
- ((_ f ...)
- ((: f) ...))))
+ (lambda (f r c)
+ (let* ((f* (symbol-append ',name- (cadr f)))
+ (rest (cddr f)))
+ `(,f* . ,rest))))
(define-syntax bound-do
(syntax-rules (<-)
((_ m) m)
@@ -87,6 +84,11 @@
(,bindf m (lambda (_) (bound-do m* m** ...))))))
(bound-do ,@body))))))
+ (define-syntax do
+ (syntax-rules ()
+ ((do m ...)
+ (do-using m ...))))
+
(define-monad
<id>
(lambda (a) a)
@@ -119,19 +121,35 @@
(define (<state>-put new-state)
(lambda (s)
- `(_ . ,new-state)))
+ `(() . ,new-state)))
+
+ (define (<state>-gets f)
+ (do-using
+ <state>
+ (s <- (: get))
+ (return (f s))))
+
+ (define (<state>-modify f)
+ (do-using
+ <state>
+ (s <- (: get))
+ (: put (f s))))
(define-monad
<reader>
(lambda (a) (lambda (v) a))
(lambda (a f) (lambda (v) ((f (a v)) v))))
- (define (<reader>-ask)
- (lambda (a) a))
+ (define (<reader>-ask a) a)
+
+ (define (<reader>-asks f)
+ (do-using <reader>
+ (x <- (: ask))
+ (return (f x))))
- (define (<reader>-local f)
+ (define (<reader>-local f r)
(lambda (a)
- (f a)))
+ (r (f a))))
(define-monad
<cps>
@@ -149,27 +167,47 @@
(case-lambda (() `(failure))
((a . b) `(failure ,a . ,b))))
+ (define (<exception>-throw e)
+ (do-using
+ <exception>
+ (:! fail e)))
+
+ (define (<exception>-catch m f)
+ (if (eq? (car m) 'failure)
+ (f m)
+ m))
+
(define-monad
<writer>
(lambda (a) `(,a . ()))
(lambda (a f)
- (let ((b (f (car a))))
- `(,(car b) . ,(append (cdr a) (cdr b))))))
-
- (define (<writer>-tell v)
- `(_ . (,v)))
-
- (define (<writer>-listen)
- (lambda (a)
- (let ((a* (car a))
- (w* (cdr a)))
- `(,a . ,w*))))
-
- (define (<writer>-pass)
- (lambda (a)
- (let* ((p (car a))
- (w (cdr a))
- (a* (car p))
- (f (cadr p)))
- `(,a* . ,(f w)))))
+ (let* ((b (f (car a)))
+ (w* (if (list? (cdr b)) (cdr b) (list (cdr b))))
+ (aw* (if (list? (cdr a)) (cdr a) (list (cdr a)))))
+ `(,(car b) . ,(append aw* w*)))))
+
+ (define (<writer>-tell v)
+ `(() . ,v))
+
+ (define (<writer>-listen a)
+ `(,a . ,(cdr a)))
+
+ (define (<writer>-pass a) ; expects ((v . f) . w)
+ (let ((v (caar a))
+ (f (cdar a))
+ (w (cdr a)))
+ (begin
+ (f w)
+ `(() . ,v))))
+
+ (define (<writer>-listens f a)
+ (do-using <writer>
+ (w <- (:! listen a))
+ (return `(,(car w) . ,(f (cdr w))))))
+
+ (define (<writer>-censor f a)
+ (<writer>-pass
+ (do-using <writer>
+ (w <- a)
+ (return `(,w . ,f)))))
)
View
2 monad.setup
@@ -8,7 +8,7 @@
'("monad.so" "monad.import.so")
'((syntax)
(import-only)
- (version 2.4)
+ (version 2.5)
(static "monad.o")))

No commit comments for this range

Something went wrong with that request. Please try again.