Maybe monad module in Scheme

Updated: 20070714

monad.ss:

;; This module provides a set of Haskell's Maybe monad-like
;; computation constructs, all of which are implemented without
;; introducing additional containers as Haskell does.
;;
;; This is due to the observation that "#f or otherwise" dualism in
;; Scheme can easily be regarded as representing the semantics of this
;; particular type of monad (namely, "Nothing or Just").  This
;; implementation strategy also implies, however, that incorporating
;; other types of monads will be virtually impossible.
;;
;; See the bottom of this file for sample usages.

;; References:
;; http://www.haskell.org/onlinereport/monad.html
;; http://www.haskell.org/onlinelibrary/maybe.html

(module monad mzscheme

  (provide >>=
           =<<
           >>
           <<

           Just
           Nothing
           return
           fail

           >>*
           *<<

           >><

           fif
           flip
           ignore
           lookup

           mapM
           mapM_
           foldM
           foldM_

           fromMaybe
           mapMaybe

           liftM
           liftM2
           liftM3

           mplus
           mzero
           msum)

  (require (lib "etc.ss")                ;compose identity
           (lib "list.ss"))              ;foldr filter

  ;; >>= (bind): Simple translation of `>>=' of Haskell's Maybe monad,
  ;; fully utilizing the advantage of Lisp's prefix notation.
  ;;
  ;; Synopsis: (>>= x f1 f2 ...)
  ;;
  ;; This is essentially the same as the following definition:
  ;;
  ;;   ((apply compose (reverse (cons f fs))) x)
  ;;
  ;; with the ability of abrupt cancellation of function composition

  (define (>>= x f . fs)
    (and x (let ((x (if (promise? f)
                        (force f)
                        (f x))))
             (if (null? fs)
                 x
                 (apply >>= x fs)))))

  ;; >>: A variant of `>>=' which discards outcome of each computation
  ;; in the series.  Note that each argument (except the 1st) has to
  ;; be either thunk or promise, so as not to be evaluated all at
  ;; once.
  ;;
  ;; This is almost useless, since you can do the same thing simply
  ;; with `and'.

  (define (>> x . fs)
    (apply >>= x (map (lambda (f)
                        (if (promise? f)
                            f
                            (delay (f))))
                      fs)))

  ;; >>*: A variant of `>>=' which doesn't alter the initial input
  ;; during the series of computations.  This is experimental feature.

  (define (>>* x f . fs)
    (>>= x f
         (lambda (_)
           (if (null? fs)
               x
               (apply >>* x fs)))))

  (define (flip f)
    (lambda xs
      (apply f (reverse! xs))))

  (define =<< (flip >>=))
  (define <<  (flip >>))
  (define *<< (flip >>*))

  ;; >><: Splits `>>=' operation into multiple pipelines.  This is not
  ;; in Haskell.
  ;;
  ;; Synopsis:
  ;; (>><
  ;;   x              ; maybe value
  ;;   (f1 f2 ...)    ; pipeline 1:  (>>= (f1 x) f2 ...)
  ;;   (fa fb ...)    ; pipeline 2:  (>>= (fa x) fb ...)
  ;;   ...)           ; more pipelines...

  (define-syntax >><
    (syntax-rules ()
      ((_ x (p ...))
       (>>= x p ...))
      ((_ y (p1 ...) (p2 ...) ...)
       (let ((x y))
         (>>< x (p1 ...))
         (>>< x (p2 ...) ...)))))

  ;; fif: From _On Lisp_ (Paul Graham)
  ;; Seemingly irrelevant to monad at first, but notice that
  ;;
  ;;  (>>= x f)
  ;;
  ;; can be rewritten as
  ;;
  ;;  ((fif not ignore
  ;;        f)
  ;;    x)
  ;;
  ;; that is, it probably is in the same vein.  Let me also point out
  ;; that `when-bind' (this too in _On Lisp_) has nearly the same
  ;; functionality as `>>=', just as Haskell's `do' exactly does what
  ;; `>>=' does, only a bit verbosely.

  (define fif
    (case-lambda
     ((predicate consequence)
      (fif predicate consequence ignore))
     ((predicate consequence alternative)
      (lambda (x)
        (if (predicate x)
            (consequence x)
            (alternative x))))))

  (define (ignore . _) #f)

  (define Just identity)
  (define Nothing #f)

  (define return identity)
  (define fail   ignore)

  ;; http://www.shido.info/hs/haskell8.html
  ;; sequence       :: Monad m => [m a] -> m [a]
  ;; sequence       =  foldr mcons (return [])
  ;;                     where mcons p q = p >>= \x -> q >>= \y -> return (x:y)
  ;;
  ;; sequence_      :: Monad m => [m a] -> m ()
  ;; sequence_      =  foldr (>>) (return ())

  (define (sequence cs)
    (foldr mcons (return '()) cs))
  (define sequence_ void)

  (define (mcons p q)
    (>>= p
         (lambda (x)
           (>>= q
                (lambda (y)
                  (return (cons x y)))))))

  (define mapM  (compose sequence
                         (lambda (f xs)
                           (map f xs))))
  (define mapM_ (compose sequence_
                         (lambda (f xs)
                           (map f xs))))

  ;; (mapM (lambda (x)
  ;;         (if (> x 0)
  ;;             (sqrt x)
  ;;             (fail "i like positives")))
  ;;       '(1 2 3 4))

  (define (foldM f a xs)
    (if (null? xs)
        a
        (>>= (f a (car xs))
             (lambda (fax)
               (foldM f fax (cdr xs))))))

  (define (foldM_ f a xs)
    (>> (foldM f a xs) void))

  (define (fromMaybe y x)
    (or x y))

  ;; lookup :: a -> [(a . b)] -> Maybe b
  (define (lookup k al)
    (>>= (assoc k al) cdr))

  ;; Example:
  ;; (mapMaybe (cut lookup <> '((a . 1) (b . 2) (c . 3))) '(a b d))
  ;; => (1 2)
  (define (mapMaybe f lst)
    (filter identity (map f lst)))

  ;; http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Monad.html#7
  ;;   -- | Promote a function to a monad.
  ;; liftM   :: (Monad m) => (a1 -> r) -> m a1 -> m r
  ;; liftM f m1              = do { x1 <- m1; return (f x1) }

  (define (liftM f m)
    (>>= m (lambda (x)
              (return (f x)))))
  (define (liftM2 f m1 m2)
    (>>= m1 (lambda (x1)
              (>>= m2 (lambda (x2)
                        (return (f x1 x2)))))))
  (define (liftM3 f m1 m2 m3)
    (>>= m1 (lambda (x1)
              (>>= m2 (lambda (x2)
                        (>>= m3 (lambda (x3)
                                  (return (f x1 x2 x3)))))))))

  ;; TODO
  ;; http://www.haskell.org/all_about_monads/html/monadfns.html
  ;; ap                :: (Monad m) => m (a -> b) -> m a -> m b
  ;; ap                =  liftM2 id

  ;; http://www.haskell.org/haskellwiki/Monads_as_Containers
  ;; fmap :: (Functor f) => (a -> b) -> f a -> f b
  ;; join :: (Monad m) => m (m a) -> m a
  ;;
  ;; (>>=) :: (Monad m) => m a -> (a -> m b) -> m b
  ;; xs >>= f = join (fmap f xs)

  (define (fmap f x)
    (>>= x (compose return f)))

;;; Monad Plus

  (define mplus (flip fromMaybe))
  (define mzero #f)

  ;; msum  :: MonadPlus m => [m a] -> m a
  ;; msum xs  =  foldr mplus mzero xs

  (define (msum xs)
    (foldr mplus mzero xs))

  ;; More to come
  )

;;; Examples

;; ;; Obtaining Content-Length value from HTTP header
;;
;; (or (>>= (regexp-match #rx"(?mi:^content-length: +([0-9]+))"
;;                        header)
;;          cadr string->number)
;;     0)

;; ;; Displaying the whole content of file
;;
;; (with-input-from-file file
;;   (lambda ()
;;     (let loop ()
;;       (<< loop newline (>>= (read-line)
;;                             (fif eof-object?
;;                                  ignore
;;                                  display)))))

;; ;; port-for-each (Gauche)
;; ;; Note that `fn' can terminate the loop prematurely by returning #f
;;
;; (define (port-for-each fn read)
;;   ;; m-pass :: a -> Maybe a
;;   (let ((m-pass (fif eof-object? ignore identity)))
;;     (let loop ()
;;       (<< loop (>>= (read) m-pass fn)))))