Monadic Operators in Scheme

monads.scm

;;; Monadic Operators

;;; List Monad
(define (mappend fn . lists)
  (apply append (apply map fn lists)))

(define (bind monad . funcs)
  (fold mappend monad funcs))

(define unit list)

(define fail ())


;;; Example
(define (double x)
  (unit x x))

(bind '(1 2 3) double double)
; => (1 1 1 1 2 2 2 2 3 3 3 3)


;;; Maybe Monad
(define (just x)
  (unit x))

(define none fail)

(define (collatz x)
  (if (= x 1)
      none
      (just (if (zero? (mod x 2))
		(/ x 2)
	   (- (* x 3) 1)))))

;;; collatz(3) : 3 -> 8 -> 4 -> 2 -> 1 -> none -> none -> ...
(bind '(3) collatz)
(bind '(3) collatz collatz)
(bind '(3) collatz collatz collatz)
(bind '(3) collatz collatz collatz collatz)
(bind '(3) collatz collatz collatz collatz collatz)
(bind '(3) collatz collatz collatz collatz collatz collatz)


;;; IO Monad
(define (printM x)
  (print x)
  (unit '()))

(define (getArgs)
  (unit '("arg1" "arg2")))

(define (getContents)
  (unit (port->string (standard-input-port))))

(define (nobind m f)
  (f))

;;; Example from http://ha6.seikyou.ne.jp/home/yamanose/haskell/DO.HTML

; import System
; 
; a = 0
; 
; run = a
; 
; main = do
;     print a 
;     a <- getArgs
;     print a
;     a <- getContents
;     print a
;     print run 

(define a 0)

(define run a)

(nobind (printM a)
	(lambda ()
	  (bind (getArgs)
		(lambda (a)
		  (nobind (printM a)
			  (lambda ()
			    (bind (getContents)
				  (lambda (a)
				    (nobind (printM a)
					    (lambda ()
					      (printM run)))))))))))


;;; Perform annotation
(define (single? list)
  (= 1 (length list)))

(define third caddr)
(define second cadr)

(define-macro (perform . commands)
  (cond ((single? commands) (car commands)) 
	((eq? (caar commands) 'var)
	 `(bind ,(third (car commands))
		(lambda (,(second (car commands)))
		  (perform ,@(cdr commands)))))
	(else
	 `(nobind ,(car commands)
		  (lambda ()
		    (perform ,@(cdr commands)))))))

; main = print a

(perform
 (printM a))

; main = do
;     args <- getArgs
;     print args

(perform
 (var args (getArgs))
 (printM args))

; main = do
;     print a 
;     a <- getArgs
;     print a
;     a <- getContents
;     print a
;     print run 

(perform
 (printM a)
 (var a (getArgs))
 (printM a)
 (var a (getContents))
 (printM a)
 (printM run))