generic-monads.rkt

#lang racket
(require racket/generic)

(define (flip f)
  (λ (x y) (f y x)))

(define-generics monad
  (fmap f monad)
  (join monad))

(define bind (compose join (flip fmap)))

(struct Nothing ()
  #:transparent
  #:methods gen:monad
  ((define (fmap f m) m)
   (define (join m) m)))

(struct Just (value)
  #:transparent
  #:methods gen:monad
  ((define (fmap f m) (Just (f (Just-value m))))
   (define (join m) (match (Just-value m)
                        [(Just n) (Just n)]
                        [_ (Nothing)]))))

(struct ListM (list)
  #:transparent
  #:methods gen:monad
  ((define (fmap f m) (ListM (map f (ListM-list m))))
   (define (join m) (ListM (apply append (map ListM-list (ListM-list m)))))))

(struct State (function)
  #:transparent
  #:methods gen:monad
  ((define (fmap f m)
     (State (λ (s)
              (let ([res ((State-function m) s)])
                (cons (f (car res)) (cdr res))))))
   (define (join m)
     (State (λ (s)
              (match ((State-function m) s)
                [(cons (State f2) s2) (f2 s2)]))))))

(define (run-state m s)
  ((State-function m) s))

(define-syntax (monadic-do stx)  
  (syntax-case stx (<-)
    [(monadic-do expr1)
     #'expr1]
    [(monadic-do (x <- expr1)
                 rest ...)
     #'(bind expr1 (match-lambda [x (monadic-do rest ...)]))]
    [(monadic-do expr1
                 rest ...)
     #'(bind expr1 (match-lambda [_ (monadic-do rest ...)]))]))