すごいH本の13章をSchemeで

hs-do.scm

(define nothing '())
(define (just x) (list x))
(define (value maybe) (car maybe))

(define nothing? null?)

(define return just)

(define (>> m1 m2)
  (>>= m1 (lambda (_) m2)))

(define (>>= maybe f)
  (cond
    ((nothing? maybe) nothing)
    (else (f (value maybe)))))

(define (difference a b) (abs (- a b)))

(define (foldl f init seqs)
  (if (null? seqs)
    init
    (foldl f (f init (car seqs)) (cdr seqs))))

(define (make-pole l r) (cons l r))
(define left car)
(define right cdr)

(define (landleft birds pole)
  (let ((rt (right pole)) (lt (left pole)))
    (if (< 4 (difference (+ birds lt) rt))
      nothing
      (just (make-pole (+ birds lt) rt)))))
(define (landL birds) (cut landleft birds <>))

(define (landright birds pole)
  (let ((rt (right pole)) (lt (left pole)))
    (if (< 4 (difference (+ birds rt) lt))
      nothing
      (just (make-pole lt (+ birds rt))))))
(define (landR birds) (cut landright birds <>))

(define (>- x f) (f x))

(>>= (just "3") (lambda (x) (just (string-append x "!"))))

(>>= (just "3") (lambda (x) 
(>>= (just "!") (lambda (y)
(just (string-append x y))))))

(define-syntax hs-do
  (syntax-rules (<-)
    ((_ x) x)
    ((_ (x <- expr) remain ...) (>>= expr (lambda (x) (hs-do remain ...))))
    ((_ x remain ...) (>> (hs-do remain ...) x))))

;(hs-do
;  (x <- (just 3))
;  (y <- (just 4))
;  (just (+ x y)))
; => (7) // Just 7

;(hs-do
;  (x <- (just 3))
;  nothing
;  (y <- (just 4))
;  (just (+ x y)))
; => () // nothing