;; -*-theme-d-*-

;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

(define-body (standard-library text-file-io)


  (import (standard-library object-string-conversion)
	  (standard-library list-utilities)
	  (standard-library string-utilities))

  
  ;; Note that _write and _display are not exported.
  ;; If Scheme write or display is needed you can use it
  ;; with prim-proc.


  (define open-output-file
    (prim-proc theme-open-output-file
			 (<string>) <output-port> nonpure))

  (define open-input-file
    (prim-proc theme-open-input-file
			 (<string>) <input-port> nonpure))

  (define close-output-port
    (prim-proc theme-close-output-port
			 (<output-port>) <none> nonpure))

  (define close-input-port
    (prim-proc theme-close-input-port
			 (<input-port>) <none> nonpure))

  (define _write
    (unchecked-prim-proc theme-prim-write
				   (<object> <output-port>)
				   <none> nonpure))

  (define _display
    (unchecked-prim-proc theme-prim-display
				   (<object> <output-port>)
				   <none> nonpure))
 
  (define write-string
    (lambda (((output-port <output-port>) (str <string>)) <none> nonpure)
      (_write str output-port)))

  (define write-character
    (lambda (((output-port <output-port>) (char <character>)) <none> nonpure)
      (_write char output-port)))

  (define display-string
    (lambda (((output-port <output-port>) (str <string>)) <none> nonpure)
      (_display str output-port)))

  (define display-character
    (lambda (((output-port <output-port>) (char <character>)) <none> nonpure)
      (_display char output-port)))

  (define newline
    (unchecked-prim-proc theme-newline (<output-port>) <none> nonpure))

  (define read-character
    (prim-proc theme-read-character
	       (<input-port>)
	       (:union <character> <eof>)
	       nonpure))

  (define peek-character
    (prim-proc theme-peek-character
	       (<input-port>)
	       (:union <character> <eof>)
	       nonpure))

  (define read
    (prim-proc theme-read
	       (<input-port>)
	       <object>
	       nonpure))

  (define-simple-proc read-all (((ip <input-port>)) <list> nonpure)
    (let-mutable ((lst-result <list> null)
                  (stop? <boolean> #f))
      (until (stop? (reverse lst-result))
        (let ((x-cur (read ip)))
          (if (eof? x-cur)
              (set! stop? #t)
              (set! lst-result (cons x-cur lst-result)))))))

  (define read-string
    (prim-proc get-string-all (<input-port>) <string> pure))
  

  (define read-line
    (lambda (((ip <input-port>)) <string> nonpure)
      (let-mutable ((result <string> "")
                    (stop? <boolean> #f))
        (until (stop? result)
          (let ((ch-cur0 (read-character ip)))
            (if (or (eof? ch-cur0) (equal? ch-cur0 #\newline))
                (set! stop? #t)
                (let ((ch-cur (cast <character> ch-cur0)))
                  (set! result
                        (string-append result (string ch-cur))))))))))

  (define character-ready?
    (prim-proc theme-char-ready? (<input-port>) <boolean> pure))

  (define-simple-method write
      (((port <output-port>) (obj <object>)) <none> nonpure)
    (display port obj))

  (define-simple-method write
      (((port <output-port>) (obj <integer>)) <none> nonpure)
    (_write obj port))

  (define-simple-method write
      (((port <output-port>) (obj <real>)) <none> nonpure)
    (_write obj port))

  (define-simple-method write
      (((port <output-port>) (obj <symbol>)) <none> nonpure)
    (_write obj port))

  (define-simple-method write
      (((port <output-port>) (obj <string>)) <none> nonpure)
    (_write obj port))

  (define-simple-method write
      (((port <output-port>) (obj <character>)) <none> nonpure)
    (_write obj port))

  (define-simple-method write
      (((port <output-port>) (obj <boolean>)) <none> nonpure)
    (_write obj port))

  (define-simple-method write
      (((port <output-port>) (obj <null>)) <none> nonpure)
    (_write obj port))

  (define write-line
    (lambda (((port <output-port>) (obj <object>)) <none> nonpure)
      (write port obj)
      (newline port)))

  (define-simple-method display
      (((port <output-port>) (obj <object>)) <none> nonpure)
    (_display (object->string obj) port))

  (define-simple-method display
      (((port <output-port>) (obj <integer>)) <none> nonpure)
    (_display obj port))

  (define-simple-method display
      (((port <output-port>) (obj <real>)) <none> nonpure)
    (_display obj port))

  (define-simple-method display
      (((port <output-port>) (obj <symbol>)) <none> nonpure)
    (_display obj port))

  (define-simple-method display
      (((port <output-port>) (obj <string>)) <none> nonpure)
    (_display obj port))

  (define-simple-method display
      (((port <output-port>) (obj <character>)) <none> nonpure)
    (_display obj port))

  (define-simple-method display
      (((port <output-port>) (obj <boolean>)) <none> nonpure)
    (_display obj port))

  (define-simple-method display
      (((port <output-port>) (obj <null>)) <none> nonpure)
    (_display obj port))

  (define display-line
    (lambda (((port <output-port>) (obj <object>)) <none> nonpure)
      (display port obj)
      (newline port)))

  (define current-output-port
    (prim-proc theme-current-output-port () <output-port> pure))

  (define current-error-port
    (prim-proc theme-current-error-port () <output-port> pure))

  (define current-input-port
    (prim-proc theme-current-input-port () <input-port> pure))

  (define standard-output-port
    (prim-proc standard-output-port () <output-port> pure))

  (define standard-error-port
    (prim-proc standard-error-port () <output-port> pure))

  (define standard-input-port
    (prim-proc standard-input-port () <input-port> pure))

  (define call-with-input-string
    (prim-proc theme-call-with-input-string
	       (<string> (:procedure (<input-port>) <object> nonpure))
	       <object> nonpure))

  (define call-with-output-string
    (prim-proc theme-call-with-output-string
	       ((:procedure (<output-port>) <none> nonpure))
	       <string> nonpure))

  (define-simple-proc write-pair-contents
      (((port <output-port>) (p <pair>) (repr? <boolean>)
	(l-visited <list>)) <none> nonpure)
    (if (member-objects? (static-cast <object> p) l-visited)
	(display port "...")
	(let ((l-new-visited (cons p l-visited)))
	  (write-general-object port (car p) repr? l-new-visited)
	  (let ((x-tail (cdr p)))
	    (match-type-strong x-tail
	      ((<null>) null)
	      ((p2 <pair>)
	       (display port " ")
	       (write-pair-contents port p2 repr? l-new-visited))
	      (else
	       (display port " . ")
	       (write-general-object port x-tail repr? l-new-visited)))))))
    
  (define-simple-proc write-general-object
      (((port <output-port>) (x <object>) (repr? <boolean>)
	(l-visited <list>)) <none> nonpure)
    (match-type-strong x
      ((p <pair>)
       (display port "(")
       (write-pair-contents port p repr? l-visited)
       (display port ")"))
      (else (if repr? (write port x) (display port x)))))

  (define-simple-method write
      (((port <output-port>) (x <pair>)) <none> nonpure)
    (write-general-object port x #t null))

  (define-simple-method display
      (((port <output-port>) (x <pair>)) <none> nonpure)
    (write-general-object port x #f null)))
