Skip to content

Instantly share code, notes, and snippets.

Created June 26, 2010 05:06
  • Star 4 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
What would you like to do?
Monads for PLT Racket
(module monad scheme
(require "")
;; i'm too lazy to repeat this pattern for now.
(define-syntax init-public
(syntax-rules ()
((_) (begin))
((_ (m default) ms ...) (begin
(init-field (m default))
(public (internal-m m))
(define (internal-m . rest) (apply (get-field m this) rest))
(init-public ms ...)
((_ m ms ...) (begin
(init-field m)
(public (internal-m m))
(define (internal-m . rest) (apply (get-field m this) rest))
(init-public ms ...)
;; functors
(provide functor-interface functor% fmap)
(define functor-interface (interface () fmap))
(define functor% (class* object% (functor-interface)
(init-public fmap)
(define-curried (fmap f x m) (send m fmap f (x m)))
;; pointed functors
(provide pointed-interface pointed% return)
(define pointed-interface (interface (functor-interface) return))
(define pointed% (class* functor% (pointed-interface)
(init-public return)
(init fmap)
(super-new (fmap fmap))))
(define-curried (return x m) (send m return x))
;; applicative functors and idiom brackets
(provide applicative-interface applicative% ap idiom)
(define applicative-interface (interface (pointed-interface) ap))
(define applicative% (class* pointed% (applicative-interface)
(init-public ap)
(init return
(fmap (lambda (f x) (ap (return f) x))))
(super-new (fmap fmap) (return return))))
(define-curried (ap mf mx m) (send m ap (mf m) (mx m)))
(define-syntax idiom
(syntax-rules ()
((idiom f) (unit f))
((idiom f x) (fmap f x))
((idiom f x y ...) (fold-left ap (fmap f x) y ...))))
;; monads and do sugar
(provide monad-interface monad% bind then when unless do do*)
(define monad-interface (interface (applicative-interface) bind))
(define monad% (class* applicative% (monad-interface)
(init-public bind)
(init return)
(init (fmap (lambda (f mx) (bind (lambda (x) (return (f x))) mx)))
(ap (lambda (mf mx) (bind (lambda (f) (fmap f mx)) mf))))
(init-public (then (lambda (m n) (bind (lambda (_) n) m))))
(super-new (fmap fmap) (ap ap) (return return))))
(define-curried (bind f x m) (send m bind (lambda (a) ((f a) m)) (x m)))
(define-curried (then a b m) (send m then (a m) b m))
(define-curried (when p s m) (if p (s m) (return '() m)))
(define-curried (unless p s m) (if p (return '() m) (s m)))
;; join :: m (m a) -> m a -- before the reader transformation
;; join :: (monad m -> m (monad m -> m a) -> monad m -> m a
;; something closer to let*
(define-syntax do*
(syntax-rules ()
((do* comp-body) comp-body)
((do* ((x0 comp0)) comp-body) (bind (lambda (x0) comp-body) comp0))
((do* ((x0 comp0) (x comp) ...) comp-body)
(bind (lambda (x0) (do* ((x comp) ...) comp-body)) comp0))))
;; a richer, more haskell-like do sugar. todo: pmatch support for destructuring binds with monad-fail?
(define-syntax do
(syntax-rules (let let* letrec letrec* <-)
((do s) s)
((do (x <- s) ss ...) (bind (lambda (x) (do ss ...)) s))
((do (let bs) ss ...) (let bs (do ss ...)))
((do (let* bs) ss ...) (let* bs (do ss ...)))
((do (letrec bs) ss ...) (letrec bs (do ss ...)))
((do (letrec* bs) ss ...) (letrec* bs (do ss ...)))
((do s ss ...) (then s (do ss ...)))))
;; simple mixins
(define-syntax define-mixin
(syntax-rules ()
((_ mixin (interfaces ... ) (ip ...)) (define (mixin %) (class* % (interfaces ...)
(init-public ip ...)
;; functor-plus, alternative, monad-plus
;; unlike haskell plus is variadic, with zero arguments it defines zero.
(provide functor-plus-interface functor-plus-mixin plus guard)
(define functor-plus-interface (interface (functor-interface) plus))
(define-mixin functor-plus-mixin (functor-plus-interface) (plus))
(define zero (plus))
(define (plus . args) (lambda (m) (send/apply m plus (map (lambda (f) (f m)) args))))
(define-curried (guard b m) (if b (return '() m) (zero m)))
;; monad-transformer
(provide monad-trans-interface monad-trans-mixin lift base)
(define monad-trans-interface (interface (monad-interface) lift base))
(define-mixin monad-trans-mixin (monad-trans-interface) (lift base))
(define-curried (lift b m) (send m lift (b (send m base))))
(define-curried (base m) (send m base))
;; state monad
(provide monad-state-interface monad-state-mixin get put gets modify)
(define monad-state-interface (interface (monad-interface) get put))
(define-mixin monad-state-mixin (monad-state-interface) (get put))
(define (get m) (send m get))
(define-curried (put s m) (send m put s))
(define (modify f) (do (x <- get)
(put (f x))))
(define (gets f) (fmap f get))
;; reader monad
(provide monad-reader-interface monad-reader-mixin ask asks)
(define monad-reader-interface (interface (monad-interface) ask))
(define-mixin monad-reader-mixin (monad-reader-interface) (ask))
(define (ask m) (send m ask))
(define (asks f) (fmap f ask))
;; writer monad
(provide monad-writer-interface monad-writer-mixin tell)
(define monad-writer-interface (interface (monad-interface) tell))
(define-mixin monad-writer-mixin (monad-writer-interface) (tell))
(define-curried (tell x m) (send m tell x))
(module curry scheme
(provide curried-lambda define-curried)
(define-syntax curried-lambda
(syntax-rules ()
((_ () body)
(lambda args
(if (null? args)
apply body args)))
((_ (arg) body)
(lambda args
(if (null? args)
(let ((arg (car args))
(rest (cdr args)))
(if (null? rest)
(apply body rest)))))))
((_ (arg args ...) body)
(lambda all-args
(if (null? all-args)
(let ((arg (car all-args))
(rest (cdr all-args)))
(let ((next (curried-lambda (args ...) body)))
(if (null? rest)
(apply next rest))))))))
;; curried defines
(define-syntax define-curried
(syntax-rules ()
((define-curried (name args ...) body)
(define name (curried-lambda (args ...) body)))
((define-curried (name) body)
(define name (curried-lambda () body)))
((define-curried name body)
(define name body)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment