;;; These are the IO primitives used by PreludeIOPrims
 
 ;;; Note: the box in write-string-stdout, write-string-file, and
 ;;;  append-string-file are due to the NoConversion in the .hi file.
 ;;; The problem is that NoConversion applies to everything, not just
 ;;; the input arg that the conversion is not needed or.
 
 
 (predefine (notify-input-request))
 
 (define *emacs-notified* '#f)
 (define *stdin-read* '#f)
 
 (define (initialize-io-system)
   (setf *emacs-notified* '#f)
   (setf *stdin-read* '#f))
 
 (define (io-success . res)
   (make-tagged-data 0
     (if (null? res)
 	(box 0)
 	(box (make-haskell-string (car res))))))
 
 (define (io-success/bin res)
   (make-tagged-data 0 (box res)))
 
 (define (io-success/lazy res)
   (make-tagged-data 0 res))
 
 (define (io-failure string)
   (make-tagged-data 1 (box (make-haskell-string string))))
 
 ; primReadStringFile
 (define (prim.read-string-file filename)
   (if (file-exists? filename)
       (let ((str (call-with-input-file filename
 		   (lambda (port)
 		     (port->string port)))))
 	(io-success str))
       (io-failure (format '#f "File not found: ~A~%" filename))))
 
 (define (port->string port)
   (call-with-output-string
    (lambda (string-port)
      (copy-till-eof port string-port))))
 
 (define (copy-till-eof in-port out-port)
   (do ((ch (read-char in-port) (read-char in-port)))
       ((eof-object? ch))
     (write-char ch out-port)))
 
 ; primWriteStringFile
 (define (prim.write-string-file filename contents state)
  (declare (ignore state))
  (box
   (let ((stream (lisp:open (haskell-string->string filename)
 			   :direction :output 
 			   :if-exists :overwrite
 			   :if-does-not-exist :create)))
     (print-haskell-string contents stream)
     (close-output-port stream)
     (io-success))))
         
 ;primAppendStringFile
 (define (prim.append-string-file filename contents state)
  (declare (ignore state))
  (box
   (let ((stream (lisp:open (haskell-string->string filename)
 			   :direction :output 
 			   :if-exists :append
 			   :if-does-not-exist '())))
     (cond ((not (eq? stream '()))
            (print-haskell-string contents stream)
            (close-output-port stream)
 	   (io-success))
           (else
 	   (io-failure "Can't open file"))))))
 
 ; primReadBinFile
 (define (prim.read-bin-file name)
   (let ((bin (lisp-read name)))
     (if (and (pair? bin) (eq? (car bin) ':binary))
 	(io-success/bin bin)
 	(io-failure "Not a bin file"))))
 
 ; primWriteBinFile
 (define (prim.write-bin-file name contents)
   (let ((stream (lisp:open name :direction :output 
 			   :if-exists :overwrite
 			   :if-does-not-exist :create)))
     (write (cons ':binary contents) stream)
     (close-output-port stream)
     (io-success)))
 
 ; primAppendBinFile
 (define (prim.append-bin-file name contents)
  (let ((bin (lisp-read name)))
    (if (and (pair? bin) (eq? (car bin) ':binary))
        (let ((stream (lisp:open name :direction :output :if-exists :overwrite)))
 	 (write (append bin contents) stream)
 	 (io-success))
        (io-failure "Can't open Bin file"))))
 
 ; primDeleteFile
 (define (prim.delete-file name)
   (if (file-exists? name)
       (if (lisp:delete-file name)
 	  (io-success)
 	  (io-failure "Can't delete file"))
       (io-failure "File not found")))
 
 ; primStatusFile
 (define (prim.status-file name)
   (if (file-exists? name)
       (io-success "frw")
       (io-failure (format '#f "File ~A not found" name))))
 
 ;primReadStdin
 (define (prim.read-string-stdin state)
   (declare (ignore state))
   (cond (*stdin-read*
 	 (haskell-runtime-error "Multiple ReadChan from stdin"))
 	(else
 	 (setf *stdin-read* '#t)
 	 (delay (read-next-char)))))
 
 (define (read-next-char)
   (when (and *emacs-mode* (not *emacs-notified*))
     (setf *emacs-notified* '#t)
     (notify-input-request))
   (let ((ch (read-char)))
     (if (eof-object? ch)
 	'()
 	(cons (box (char->integer ch))
 	      (delay (read-next-char))))))
 
 ; primWriteStdout
 (define (prim.write-string-stdout string state)
   (declare (ignore state))
   (print-haskell-string string (current-output-port))
   (box (io-success)))
 
 ; primReadBinStdin
 (define (prim.read-bin-stdin)
   (haskell-runtime-error  "ReadBinChan not implemented"))
 
 ; primWriteBinStdout
 (define (prim.write-bin-stdout bin)
   (declare (ignore bin))
   (haskell-runtime-error  "WriteBinChan not implemented"))
 
 ;;; %%% probably bogus
 ; primGetEnv
 (define (prim.getenv name)
   (io-success (getenv name)))
 
 (define (lisp-read file)
   (if (not (file-exists? file))
       'error
       (call-with-input-file file
         (lambda (port)
 	  (lisp:read port '#f 'error '#f)))))
 
 (define-integrable (prim.returnio x s)
   (declare (ignore s))
   x)
 
 (define-integrable (prim.getstate x)
   (declare (ignore x))
   'state)
 
 (define-integrable (prim.getres x)
   (force x))