mes/mes/module/mes/guile.mes

;;; -*-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))

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

(define (read-line . rest)
  (let* ((port (if (pair? rest) (car rest) (current-input-port)))
         (handle-delim (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 'trim))
         (c (read-char port)))
    (if (eof-object? c) c
        (list->string
         (let loop ((c c))
           (if (or (eof-object? c) (eq? c #\newline)) (case handle-delim
                                                        ((trim) '())
                                                        ((concat) '(#\newline))
                                                        (else (error (format #f "not supported: handle-delim=~a" handle-delim))))
               (cons c (loop (read-char port)))))))))

(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-error-to-file file thunk)
  (let ((port (open-output-file file)))
    (if (= port -1)
        (error 'cannot-open file)
        (let* ((save (current-error-port))
               (foo (set-current-error-port port))
               (r (thunk)))
          (set-current-error-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 (string-split file-name #\/))
         (lst (filter (negate string-null?) lst)))
    (if (null? lst) (if (string-prefix? "/" file-name) "/" ".")
        (let ((dir (string-join (list-head lst (1- (length lst))) "/")))
          (if (string-prefix? "/" file-name) (string-append "/" dir)
              (if (string-null? dir) "."
                  dir))))))

;; 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)

(define (file-exists? o)
  (access? o R_OK))