haskell-fetishism.clj

(define-module define-monad
  :doc "Defines vars with the definitions provided for '>>= and 'return 
        (and 'zero and 'plus when provided) and creates namespace-local
        versions of the generic monadic functions. By default all of the
        monadic functions in combinatrix.monad are defined.
        If 'syntax is provided a monad-comprehension macro with the given
        name will also be defined. The examples in combinatrix.monad.*
        probably offer the clearest demonstration of usage."
  
  :required [>>= return]
  :optional [zero plus syntax include exclude rename]

  (require 'combinatrix.util)
  (combinatrix.util/definitions

    ;; this is possibly taking the haskell syntax theme too far
    ;; ... but its so tidy ...
    
    >> ma mb       := (>>= ma (fn [_] mb))
    >> ma mb & mbs := (>> ma (apply >> mb mbs))
    
    lift f         := (fn [mv] (>>= mv (fn [x] (return (f x)))))
    lift2 f        := (fn [m n] (>>= m (fn [x]
                                 (>>= n (fn [y]
                                   (return (f x y)))))))
    
    fmap f mv      := (>>= mv (fn [x] (return (f x))))

    m-map f xs     := (m-seq (map f xs))
    
    m-seq mvs :=
    (letfn [(m-seq* [xs acc]
                    (if-let [[y & ys] (seq xs)]
                      (>>= y (fn [z] (m-seq* ys (conj acc z))))
                      (return (seq acc))))]
      (m-seq* mvs []))
  
    chain steps :=
    (letfn [(link [expr step]
                  (fn [v] (>>= (expr v) step)))]
      (reduce link return steps))
    
    until p f x :=
    (if (p x)
      (return x)
      (>>= (f x)
            (fn [y] (>>= (until p f y)
                        (fn [z] (return z)))))))

  (when syntax
    (eval (do-monad-template syntax))))