;;; -*-scheme-*-

;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(mes-use-module (srfi srfi-13))

(define-macro (cond-expand-provide . rest) #t)

(mes-use-module (mes catch))
(mes-use-module (mes posix))
(mes-use-module (srfi srfi-16))
(mes-use-module (mes display))

(if #t ;;(not (defined? 'read-string))
    (define (read-string)
      (define (read-string c)
        (if (eq? c #\*eof*) '()
            (cons c (read-string (read-char)))))
      (let ((string (list->string (read-string (read-char)))))
        (if (and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 3)) string->number))
            (core:display-error (string-append "drained: `" string "'\n")))
        string)))

(define (drain-input port) (read-string))

(define (make-string n . fill)
  (list->string (apply make-list n fill)))

(define (object->string x . rest)
  (with-output-to-string
    (lambda () ((if (pair? rest) (car rest) write) x))))

(define (port-filename p) "<stdin>")
(define (port-line p) 0)

(define (with-input-from-string string thunk)
  (let ((prev (set-current-input-port (open-input-string string)))
        (r (thunk)))
    (set-current-input-port prev)
    r))

(define (with-input-from-file file thunk)
  (let ((port (open-input-file file)))
    (if (= port -1)
        (error 'no-such-file file)
        (let* ((save (current-input-port))
               (foo (set-current-input-port port))
               (r (thunk)))
          (set-current-input-port save)
          r))))

(define (with-output-to-file file thunk)
  (let ((port (open-output-file file)))
    (if (= port -1)
        (error 'cannot-open file)
        (let* ((save (current-output-port))
               (foo (set-current-output-port port))
               (r (thunk)))
          (set-current-output-port save)
          r))))

(define (with-output-to-port port thunk)
  (let* ((save (current-output-port))
         (foo (set-current-output-port port))
         (r (thunk)))
    (set-current-output-port save)
    r))

(define core:open-input-file open-input-file)
(define (open-input-file file)
  (let ((port (core:open-input-file file))
        (debug (and=> (getenv "MES_DEBUG") string->number)))
    (when (and debug (> debug 1))
      (core:display-error (string-append "open-input-file: `" file "'"))
      (when (> debug 3)
        (core:display-error " port=")
        (core:display-error port)))
    (core:display-error "\n")
    port))

(define (dirname file-name)
  (let ((lst (filter (negate string-null?) (string-split file-name #\/))))
    (if (<= (length lst) 1) "."
        (string-join (list-head lst (1- (length lst))) "/"))))

;; FIXME: c&p from display
(define (with-output-to-string thunk)
  (define save-write-byte write-byte)
  (let ((stdout '()))
    (set! write-byte
          (lambda (x . rest)
            (let ((out? (or (null? rest) (eq? (car rest) (current-output-port)))))
              (if (not out?) (apply save-write-byte (cons x rest))
                  (begin
                    (set! stdout (append stdout (list (integer->char x))))
                    x)))))
    (thunk)
    (let ((r (apply string stdout)))
      (set! write-byte save-write-byte)
      r)))

;; FIXME: c&p from display
(define (simple-format destination format . rest)
  (let ((port (if (boolean? destination) (current-output-port) destination))
        (lst (string->list format)))
    (define (simple-format lst args)
      (if (pair? lst)
          (let ((c (car lst)))
            (if (not (eq? c #\~)) (begin (write-char (car lst) port)
                                         (simple-format (cdr lst) args))
                (let ((c (cadr lst)))
                  (case c
                    ((#\a) (display (car args) port))
                    ((#\s) (write (car args) port)))
                  (simple-format (cddr lst) (cdr args)))))))

    (if destination (simple-format lst rest)
        (with-output-to-string
          (lambda () (simple-format lst rest))))))
(define format simple-format)