;;
;; SCSH process form notation
;;
;; See http://www.scsh.net/docu/html/man-Z-H-3.html#node_chap_2
;;
;; Some minor changes due to Chicken- and R7RS-incompatible identifiers:
;; | was changed to pipe, |+ was changed to pipe+
;;
;; || wasn't changed, but it's really the zero-length symbol
;;
;; BIG FAT WARNING: Don't mix this with threading, or Bad Things will happen

(module scsh-process
  (;; procedures
   exec-path fork/pipe %fork/pipe fork/pipe+ %fork/pipe+
   run/collecting* run/string* run/strings* run/port* run/file* run/sexp* run/sexps*

   ;; macros
   run/collecting run/string run/strings run/port run/file run/sexp run/sexps
   (& maybe-symbol->string) (run maybe-symbol->string) (exec-epf maybe-symbol->string))

(import chicken scheme data-structures)

(use extras utils files ports posix srfi-1)

;; TODO: Perhaps expose environment, and mess around with the path so that
;; execve can be used in a sensible way?  Scsh has its own PATH, so we could
;; use something similar to that, but it's more work.
(define (exec-path prog . args)
  ;; Args can include numbers and such, too!  That's why we're using ->string
  (process-execute (maybe-symbol->string prog) (map ->string args)))

;; TODO: continue-threads argument
(define (fork/pipe #!optional thunk)
  (fork/pipe+ '((1 2 0)) thunk))

(define (fork/pipe+ conns #!optional thunk)
  ;; Blergh, this is silly overhead we don't really need
  (let* ((from-fds (map (lambda (x) (drop-right x 1)) conns))
         (to-fds (map last conns))
         (pipe-pairs (map (lambda _ (receive (create-pipe))) to-fds))
         (pid (process-fork)))
    (if (zero? pid)                     ; Child
        (begin
          (for-each (lambda (p from-fds-for-this-p)
                      ;; Close receiving ends of pipes in child.
                      (file-close (car p))
                      ;; Set up linkage from output fds to created pipes.
                      (for-each (lambda (from-fd)
                                  (duplicate-fileno (cadr p) from-fd))
                                from-fds-for-this-p))
                    pipe-pairs from-fds)
          (if thunk (thunk) pid))
        (begin                          ; Parent
          (for-each (lambda (p to-fd)
                      ;; Close sending end in parent.
                      (file-close (cadr p))
                      ;; Set up linkage from created pipes to the input fds.
                      (duplicate-fileno (car p) to-fd))
                    pipe-pairs to-fds)
          pid))))

;; TODO: Differentiate between fork and %fork
(define %fork/pipe fork/pipe)
(define %fork/pipe+ fork/pipe+)

(define (maybe-symbol->string s)
  (if (symbol? s) (symbol->string s) s))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Baroque procedural interface ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Documented under http://www.scsh.net/docu/html/man-Z-H-3.html#node_sec_2.4.2
(define (run/collecting* fds thunk)
  (let* ((temp-files (map (lambda () (open-input-file (create-temporary-file)))
                          fds))
         (conns (map (lambda (temp-fd from-fd)
                       (list from-fd (open-input-file* temp-fd)))
                     temp-files fds)))
    (apply values (fork/pipe+ conns thunk) temp-files)))

(define (run/port* thunk)
  (fork/pipe (lambda () (with-output-to-port (open-output-file* 1) thunk)))
  (open-input-file* 0))
(define (run/file* thunk)
  (error "not yet implemented"))
(define (run/string* thunk)
  (read-string #f (run/port* thunk)))
(define (run/strings* thunk)
  (read-lines (run/port* thunk)))
(define (run/sexp* thunk)
  (read (run/port* thunk)))
(define (run/sexps* thunk)
  (read-all (run/port* thunk)))

;;;;;;;;;;;;
;; Syntax ;;
;;;;;;;;;;;;

(define-syntax run/collecting
  (syntax-rules ()
    ((_ ?fds ?epf ...) (run/collecting* `?fds (lambda () (exec-epf ?epf ...))))))
(define-syntax run/file
  (syntax-rules ()
    ((_ ?epf ...) (run/file* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/port
  (syntax-rules ()
    ((_ ?epf ...) (run/port* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/string
  (syntax-rules ()
    ((_ ?epf ...) (run/string* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/strings
  (syntax-rules ()
    ((_ ?epf ...) (run/strings* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/sexp
  (syntax-rules ()
    ((_ ?epf ...) (run/sexp* (lambda () (exec-epf ?epf ...))))))
(define-syntax run/sexps
  (syntax-rules ()
    ((_ ?epf ...) (run/sexps* (lambda () (exec-epf ?epf ...))))))

(define-syntax &
  (syntax-rules ()
    ((_ ?epf ...)
     (process-fork (lambda ()
                     (handle-exceptions exn
                       ;; TODO: Figure out how SCSH does this.  It shows the error
                       ;; on stderr in the REPL, but then still quits it.
                       ;; If we just invoke current-handler, it'll get a second REPL
                       (begin (print-error-message exn) (exit 1))
                       (exec-epf ?epf ...)))))))

(define-syntax run
  (syntax-rules ()
    ((_ ?epf ...)
     ;; We reorder the values as they make more sense this way for SCSH compat:
     ;; scsh returns just the exit code, and conveniently we allow MV in single
     ;; value continuations, which makes it compatible.
     (receive (pid normal-exit? exit-status)
       (process-wait (& ?epf ...))
       (values exit-status normal-exit? pid)))))

;; Perhaps this should really be a procedure?
(define-syntax setup-redirection
  (syntax-rules (< > << >> = - stdports)
    ((_ (< ?file-name)) (setup-redirection (< 0 ?file-name)))
    ((_ (> ?file-name)) (setup-redirection (> 1 ?file-name)))
    ((_ (<< ?object)) (setup-redirection (<< 0 ?object)))
    ((_ (>> ?object)) (setup-redirection (>> 1 ?object)))
    ((_ (< ?fd ?file-name))
     (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
                                  open/rdonly)
                       `?fd))
    ((_ (> ?fd ?file-name))
     (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
                                  (fx+ open/wronly open/creat))
                       `?fd))
    ((_ (<< ?fd ?object)) (error "<< currently not implemented"))
    ((_ (>> ?fd ?object)) (error ">> currently not implemented"))
    ((_ (= ?fd-from ?fd/port-to))
     (let* ((fd/port-to ?fd/port-to)    ; Evaluate once
            (fd-to (if (port? fd/port-to)
                       (port->fileno fd/port-to)
                       fd/port-to)))
       (duplicate-fileno ?fd-from fd-to)))
    ((_ (- ?fd/port))
     (let ((o `?fd/port))
       (cond
        ((fixnum? ?fd/port) (file-close o))
        ((output-port? ?fd/port) (close-output-port o))
        ((input-port? ?fd/port) (close-input-port o))
        (else (error "Can only close i/o-ports and file descriptor numbers" o)))))
    ((_ stdports)
     (begin (setup-redirection (= 0 (current-input-port)))
            (setup-redirection (= 1 (current-output-port)))
            (setup-redirection (= 2 (current-error-port)))))
    ((_ ?arg0 ...)
     (syntax-error "Invalid redirection pattern: " `?arg0 ...))))

;; The most "core" syntax form
(define-syntax exec-epf
  ;; The nested let-syntaxes exist to let us pre-empt the fallthrough
  ;; whenever we see one of the recognised special rules so we don't end up
  ;; with the generic one if we happen to make a small mistake
  (syntax-rules (pipe pipe+ begin epf)
    ((_ (pipe ?pf0 ...) ?redir0 ...)
     (exec-epf (pipe+ ((1 2 0)) ?pf0 ...) ?redir0 ...))
    ((_ (pipe+ ?args ...) ?redir0 ...)
     (let-syntax
         ((pipe+
           (syntax-rules ___ ()
             ((_ ((?from0 ?from1 ___ ?to) ___) ?pf0 ___ ?last-pf)
              (let ((conns `((?from0 ?from1 ___ ?to) ___)))
                 (setup-redirection ?redir0) ...
                (begin (fork/pipe+ conns (lambda () (exec-epf (epf ?pf0))))
                       ___
                       (exec-epf (epf ?last-pf))))))))
       (pipe+ ?args ...)))
    ((_ (begin ?expr0 ...))
     (begin (setup-redirection (= 0 (current-input-port)))
            (setup-redirection (= 1 (current-output-port)))
            (setup-redirection (= 2 (current-error-port)))
            ?expr0 ...))
    ;; epf can be used if you happen to have a program called
    ;; "epf", "begin", "pipe", etc which you'd like to run.
    ((_ (epf ?args ...))
     (let-syntax ((exec-epf
                   (syntax-rules ___ ()
                     ((_ (?prog ?arg0 ___) ?redir0 ___)
                      (begin
                        (setup-redirection ?redir0) ___
                        (exec-path `?prog `?arg0 ___))))))
       (exec-epf ?args ...)))
    ;; This is purely for convenience, so you don't need the (epf ...) wrapper
    ((_ (?prog ?arg0 ...) ?redir0 ...)
     (exec-epf (epf (?prog ?arg0 ...) ?redir0 ...)))))

)