; Haskell-like IO Monad
; Copyright 2005 Brian Alliet

(define (io:return x) (lambda () x))
(define (io:bind io f) (lambda () ((f (io)))))
(define (io:fail s) (lambda () (error s)))
(define io: (create-monad-dict io:return io:bind io:fail))
(define (unsafe-perform-io io) (io))

(define (h-get-char handle) (lambda() (read-char handle)))
(define (h-put-char handle c) (lambda () (write-char c handle) '()))
(define (h-is-eof? handle) (lambda () (eof-object? (peek-char handle))))
(define (h-put-str-list handle cs) (map-m_ io: (curry h-put-char handle) cs))
(define (h-get-contents-list handle) (do io:
    (b <- (h-is-eof? handle))
    (if b
        (io:return '())
        (do io:
            (c <- (h-get-char handle))
            (cs <- (h-get-contents-list handle))
            (io:return (cons c cs))))))

(define (h-put-str handle s) (h-put-str-list handle (string->list s)))
(define (h-put-str-ln handle s) (bind_ io: (h-put-str handle s) (h-put-char handle #\newline)))
(define (h-get-contents handle) ((lift-m io: list->string) (h-get-contents-list handle)))

(define (open-file name mode) (lambda ()
    (match mode
        ('read-mode (open-input-file name))
        ('write-mode (open-output-file name)))))

(define (h-close handle) (lambda ()
    (cond
        ((input-port? handle)  (close-input-port handle))
        ((output-port? handle) (close-output-port handle)))))

; Unlike haskell these have to be in the IO monad because they can be changed
(define stdin  (lambda () (current-input-port)))
(define stdout (lambda () (current-output-port)))

(define (read-file name) (do io:
    (h <- (open-file name 'read-mode))
    (cs <- (h-get-contents h))
    (h-close h)
    (io:return cs)))

(define (write-file name s) (do io:
    (h <- (open-file name 'write-mode))
    (h-put-str h s)
    (h-close h)))

(define get-char       (io:bind stdin  (lambda (h) (h-get-char h))))
(define (put-char c)   (io:bind stdout (lambda (h) (h-put-char c))))
(define is-eof?        (io:bind stdin  (lambda (h) (h-is-eof? h))))
(define (put-str s)    (io:bind stdout (lambda (h) (h-put-str h s))))
(define (put-str-ln s) (io:bind stdout (lambda (h) (h-put-str-ln h s))))