#lang racket

(provide lispblock0
         systemout
         systemout*)

(require (for-syntax racket/port
                     racket/system)
         scribble/manual)

(define-for-syntax (exn->str exn)
  (if (exn? exn) (exn-message exn) exn))

(define-for-syntax (sf:path->string path)
  (let ((fis #f)
        (result #f))
    (call-with-exception-handler
     (lambda (exn)
       (close-input-port fis)
       (set! result (format "Error: ~a~n" (exn->str exn))))
     (lambda ()
       (set! fis (open-input-file #:mode 'text path))
       (set! result (port->string fis))))
    (close-input-port fis)
    result))

(define-syntax (lispblock0 stx) 
  (syntax-case stx ()
    [(_ option ... path)
     (with-syntax ([contents (datum->syntax #'_ (sf:path->string (syntax->datum #'path)))])
       #'(codeblock0 option ... contents))]))

(define-for-syntax (system-call command)
  (let ((cop (open-output-string))
        (cep (open-output-string)))
    (parameterize ((current-output-port cop)
                   (current-error-port cep))
      (call-with-exception-handler 
       (lambda (exn) (printf "Error: ~a~n" (exn->str exn)))
       (lambda () (system command))))
    (map get-output-string (list cop cep))))

(define-syntax (systemout stx)
  (syntax-case stx ()
    [(_ command)
     (with-syntax ([(out err) 
                    (map (lambda (dtm) (datum->syntax #'_ dtm)) 
                         (system-call (syntax->datum #'command)))])
       #'(verbatim out err))]))

(define-for-syntax (system*-call command stx-args)
  (let ((cop (open-output-string))
        (cep (open-output-string))
        (args (map (lambda (stx) (syntax->datum stx)) stx-args)))
    (parameterize ((current-output-port cop)
                   (current-error-port cep))  
      (call-with-exception-handler
       (lambda (exn) (printf "Error: ~a~n" (exn->str exn)))
       (lambda () (apply system* command args))))
    (let ((result (map get-output-string (list cop cep))))
      (display result)
      result)))

(define-syntax (systemout* stx)
  (syntax-case stx ()
    [(_ command arg ...)
     (with-syntax ([(out err) 
                    (map (lambda (dtm) (datum->syntax #'_ dtm)) 
                         (system*-call (syntax->datum #'command) (syntax->list #'(arg ...))))])
       #'(verbatim out err))]))