Haskell I/O monad in Scheme

io.scm

;;;; Monads

(define (return x) (make-result x))
(define (bind m k)
  (make-thunk (lambda () (execute! (k (execute! m))))))

(define (execute! m)
  (cond ((result? m) (result-value m))
        ((thunk? m) (execute-thunk! m))))

;;;; Haskell 'do' syntax

(define-syntax io-begin
  (syntax-rules (let)
    ((io-begin exp) exp)
    ((io-begin (let var exp) exps ...)
     (bind exp (lambda (var) (io-begin exps ...))))
    ((io-begin exp exps ...)
     (bind exp (lambda (x) (io-begin exps ...))))))

(define (io-monad? obj)
  (or (result? obj) (action? obj)))

;;;; Data representation

(define (make-result x) (cons 'result x))
(define (make-thunk p) (cons 'thunk p))
(define (result? obj) (tagged-list? obj 'result))
(define (thunk? obj) (tagged-list? obj 'thunk))
(define (result-value m) (cdr m))
(define (execute-thunk! m) ((cdr m)))

(define (tagged-list? obj tag)
  (and (pair? obj)
       (eq? (car obj) tag)))

;;;; I/O operations

(define (io-write obj)
  (make-thunk (lambda () (write obj))))

(define (io-write-char char)
  (make-thunk (lambda () (write-char obj))))

(define (io-display str)
  (make-thunk (lambda () (display str))))

(define io-read (make-thunk read))
(define io-read-char (make-thunk read-char))

;; (define (read-line)
;;   (let loop ((accum '()))
;;     (let ((char (read-char)))
;;       (if (or (eof-object? char) (char=? char #\newline))
;;           (list->string (reverse accum))
;;           (loop (cons char accum))))))

;; (define io-read-line (make-thunk read-line))

(define io-read-line
  (let loop ((accum '()))
    (io-begin
       (let char io-read-char)
       (if (or (eof-object? char) (char=? char #\newline))
           (return (list->string (reverse accum)))
           (loop (cons char accum))))))