;;; SCSH Process Syntax, part of Guile Facade

;;; Copyright (c) 1993 by Olin Shivers
;;; Copyright (c) 2010 Clinton Ebadi

;;;  'Ported' (or, perhaps, more or less a total rewrite) to
;;;  syntax-case

(define-module (scsh syntax-helpers)
  #:export (expand-process-form
	    define-simple-syntax))

;; This is used by the macro for the << redirection to prevent the temporary 
;; port from being closed by a GC before the process exec's
(define <<-port-holder)

(define-syntax define-simple-syntax
  (syntax-rules ()
    ((define-simple-syntax (name . pattern) result)
     (define-syntax name (syntax-rules () ((name . pattern) result))))))

;;; Debugging macro:
(define-simple-syntax (assert exp)
  (if (not exp) (error "Assertion failed" (quote exp))))

;;; Process forms are rewritten into code that causes them to execute
;;; in the current process.
;;; (BEGIN . scheme-code)	=> (STDIO->STDPORTS (LAMBDA () . scheme-code))
;;; (| pf1 pf2)			=> (BEGIN (FORK/PIPE (LAMBDA () pf1-code))
;;;                                       pf2-code)
;;; (|+ conns pf1 pf2)		=> (BEGIN
;;;                                  (FORK/PIPE+ `conns (LAMBDA () pf1-code))
;;;                                  pf2-code)
;;; (epf . epf)			=> epf-code
;;; (prog arg1 ... argn)	=> (APPLY EXEC-PATH `(prog arg1 ... argn))
;;; [note the implicit backquoting of PROG, ARG1, ...]

;;; NOTE: | and |+ won't read into many Scheme's as a symbol. If your
;;; Scheme doesn't handle it, kill them, and just use the PIPE, PIPE+
;;; aliases.

(define (expand-process-form expression)
  (syntax-case expression (begin epf pipe | |+ pipe+)
    ((begin forms ...)
     #'(with-stdio-ports* (lambda () forms ...)))
    ((epf (pf1 pf2 ...) redirection ...)
     #`(begin #,@(map expand-redirection #'(redirection ...))
	      #,(expand-process-form #'(pf1 pf2 ...))))
    ((pipe pf1 pf2 ... pfn)
     #`(begin #,@(map (lambda (chunk)
			#`(fork/pipe (lambda () #,(expand-process-form chunk))))
		      #'(pf1 pf2 ...))
	      #,(expand-process-form #'pfn)))
;;;    ((| forms ...)) ; b0rks paredit... ignore for a sec
;;;   ((|+ forms ...))
    ((pipe+ (connection ...) pf1 pf2 ... pfn)
     #`(begin #,@(map (lambda (chunk)
			#`(fork/pipe+ `(connection ...)
				      (lambda () #,(expand-process-form chunk))))
		      #'(pf1 pf2 ...))
	      #,(expand-process-form #'pfn)))
    ((command forms ...)
     (syntax (apply exec-path `(command forms ...))))))

(define (expand-redirection redirection)
  (syntax-case redirection (< > << >> = - stdports)
    ;; (REDIR FILE-NAME) -> expand again
    ((< file-name)
     (expand-redirection #'(< 0 file-name)))
    ((> file-name)
     (expand-redirection #'(> 1 file-name)))
    ((<< object)
     (expand-redirection #'(<< 0 object)))
    ((>> file-name)
     (expand-redirection #'(>> 1 file-name)))
    
    ((< fdes file-name)
     #'(shell-open `file-name 0 `fdes))
    ((> fdes file-name)
     #'(shell-open `file-name open/create+trunc `fdes))
    ((<< fdes object)
     #'(let ((port (open-string-source `object)))
	 (set! <<-port-holder port)
	 (move->fdes port `fdes)))
    ((>> fdes file-name)
     #'(shell-open `file-name open/write+append+create `fdes))
    ((= fdes fdes/port)
     #'(dup->fdes `fdes/port `fdes))
    ((- fdes)
     #'(close fdes))
    (stdports
     #'(stdports->stdio))))