monads.rkt

#lang racket

(struct functor (fmap))

(struct monad functor (unit bind then))

(define (make-monad unit bind (then #f))
  (monad (λ (f m) (bind m (λ (x) (unit (f x)))))
         unit
         bind
         (or then (λ (a b) (bind a (λ (_) b))))))

(define list-monad
  (make-monad list
              (λ (l f) (apply append (map f l)))))

((monad-bind list-monad) ((monad-unit list-monad) 1) (λ (x) (list x x)))

(define-syntax do
  (syntax-rules (<-)
    ((_ m e) (do-e m e))
    ((_ m (v <- e) es ...) ((monad-bind m) (do-e m e) (λ (v) (do m es ...))))
    ((_ m e es ...) ((monad-then m) (do-e m e) (do m es ...)))))

(define-syntax do-λ
  (syntax-rules ()
    ((_ p body ...) (λ (m . p) (do m body ...)))))

(define-syntax do-e
  (syntax-rules (return)
    ((_ m (return e)) ((monad-unit m) e))
    ((_ m e) e)))

(do list-monad
  (x <- '(1 2 3))
  (y <- '(3 4 5))
  (list x y))

(do list-monad
  (return 3)
  (return 2))

(define maybe
  (make-monad list
              (λ (m f)
                (and m (f (car m))))))

(do maybe
  (x <- (return 1))
  (y <- (return (+ x 1)))
  (return (+ x y)))

(do maybe
  (x <- #f)
  (y <- (return (+ x 1)))
  (return (+ x y)))

(define writer
  (make-monad (λ (x) (list x ""))
              (λ (m f)
                (let ((res (f (car m))))
                  (list (car res)
                        (string-append (cadr m) (cadr res)))))))

(do writer
  (x <- (list 1 "meep"))
  (list #f "moop")
  (y <- (return (+ x 1)))
  (z <- (list (+ x y) "maap"))
  (return (+ z z)))

(define lazy
  (make-monad (λ (x) (λ () x))
              (λ (m f) (λ () ((f (m)))))))

(do lazy
  (x <- (return 1))
  (y <- (return (+ x 1)))
  (return (+ x y)))

((do lazy
   (x <- (return 1))
   (y <- (return (+ x 1)))
   (return (+ x y))))

(define fun-do
  (do-λ (x)
    (x <- (return x))
    (y <- (return (+ x 1)))
    (return (+ x y))))

(fun-do maybe 2)
((fun-do lazy 3))

(define (fmap functor f fval)
  ((functor-fmap functor) f fval))

(define (double x) (+ x x))

(fmap list-monad double '(1 2 3 4))

(fmap maybe double '(2))

(fmap maybe double #f)

(fmap lazy double (λ () 2))

((fmap lazy double (λ () 2)))