Skip to content

Instantly share code, notes, and snippets.

@pasberth
Forked from anonymous/monad.scm
Last active October 3, 2020 21:48
Show Gist options
  • Save pasberth/5056645 to your computer and use it in GitHub Desktop.
Save pasberth/5056645 to your computer and use it in GitHub Desktop.
(define (then m k)
(bind m (lambda (_) k)))
(define (state-unit a)
(lambda (s) `(,a ,s)))
(define (state-bind m k)
(lambda (s)
(let* { [r (m s)]
[a (car r)]
[s- (cadr r)] }
((k a) s- ))))
(define (state-get s)
`(,s ,s))
(define (state-put s)
(lambda (_) `(() ,s)))
(define-syntax monad-context
(syntax-rules (<- @ =)
[(_ unit bind m) m]
[(_ unit bind @ a) (unit a)]
[(_ unit bind x = a k ...)
(bind (unit a) (lambda (x) (monad-context unit bind k ...)))]
[(_ unit bind x <- m k ...)
(bind m (lambda (x) (monad-context unit bind k ...)))]
[(_ unit bind @ a k ...)
(bind (unit a) (lambda (_) (monad-context unit bind k ...)))]
[(_ unit bind m k ...)
(bind m (lambda (_) (monad-context unit bind k ...)))]))
(define state
(monad-context state-unit state-bind
x <- state-get
@ (display x)
@ (newline)
(state-put (* x x))
y <- state-get
@ (display y)
@ (newline)))
(state 42)
(use srfi-9)
;polymorphic >>=
(define-record-type <just>
(just a) just?
(a just-a))
(define-record-type <nothing>
(nothing) nothing?)
(define (maybe-unit a)
(just a))
(define-method >>= ([x <just>] f)
(f (just-a x)))
(define-method >>= ([x <nothing>] f)
x)
(define (fail)
(nothing))
(define maybe
(monad-context maybe-unit >>=
x <- (just 52)
y = (* x x)
@ (display y)
@ (newline)))
;=> just 2704
(define maybe
(monad-context maybe-unit >>=
x <- (just 52)
y = (* x x)
(nothing)
z = (* y y)
@ (display z)))
;=>nothing
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment