Welcome to the CHICKEN Scheme pasting service

(module
 mailbox-process
 ()
 (import scheme chicken)
 (use clot mailbox datatypes2)
 (use (prefix posix posix:))
 (use (only posix signal/stop))
 (use (only srfi-18 make-thread thread-start! thread-yield!))
 (use (only extras read-line))
 (use logging)
 (use/types ProcessEvent)

 (define-type (mb a) (struct mailbox (a)))

 (defn run-process
   (doc: "Sent messages:"
         "(Started pid)"
         "(StdOut line)"
         "(StdErr line)"
         "(Exit code)")
   clean:
   (: (pair (mb ProcessEvent) (struct mailbox)))
   [(cmd : string)]
   (let ([mb-in (make-mailbox)]
         [mb-out (make-mailbox)])
     (-> (make-thread (fn [] (run-process* mb-in mb-out cmd)))
         thread-start!)
     (cons mb-out mb-in)))

 (defn- run-process*
   [(mb-in : (mb *)) (mb-out : (mb ProcessEvent)) (cmd : string)]
   (receive (in-port out-port pid err-port) (posix:process* cmd)
     (mailbox-send! mb-out (Started pid))

     (define (do-line port f)
       (when (char-ready? port) ;; TODO: strictly wrong, we're reading lines
         (let ([l (read-line port)])
           (if (eof-object? l) #f (f l)))))

     (define (do-lines)
       (do-line in-port (fn [l] (mailbox-send! mb-out (StdOut l))))
       (do-line err-port (fn [l] (mailbox-send! mb-out (StdErr l)))))

     (loop ()
       (receive (pid2 ok? exit-status) (posix:process-wait pid #t)
         (cond [(not (= 0 pid2))
                (do-lines)
                (close-input-port in-port)
                (close-output-port out-port)
                (close-input-port err-port)
                (mailbox-send! mb-out (Exit exit-status))]
               [(not (mailbox-empty? mb-in))
                (let ([msg (mailbox-receive! mb-in)])
                  (when (eq? msg 'stop) ;; TODO: add proper datatype
                    (log-debug "Sending signal/stop for process" pid)
                    (posix:process-signal pid signal/stop)
                    (do-lines)
                    (recur)))]
               [else              ; not finished
                (do-lines)
                (thread-yield!)
                (recur)])))))

 )