Monads for PLT Racket

monads for plt-racket

(module monad scheme
  (require "curry.ss")
  ;; 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)
                     (super-new)))
  (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 ...)
                                                                 (super-new))))))
  
  ;; 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)
             body
             apply body args)))
      ((_ (arg) body)
       (letrec 
           ((partial-application 
             (lambda args  
               (if (null? args) 
                   partial-application
                   (let ((arg (car args)) 
                         (rest (cdr args)))
                     (if (null? rest)
                         body 
                         (apply body rest)))))))
         partial-application))
      ((_ (arg args ...) body)
       (letrec
           ((partial-application 
             (lambda all-args
               (if (null? all-args) 
                   partial-application
                   (let ((arg (car all-args))
                         (rest (cdr all-args)))
                     (let ((next (curried-lambda (args ...) body)))
                       (if (null? rest)
                           next
                           (apply next rest))))))))
         partial-application))))
  
  ;; 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)))))