#lang scheme/base

(require (for-syntax scheme/base)
         scheme/list)

(provide lift-channel? (rename-out [build-lift-channel lift-channel]) lift-channel-live?
         lift capture)

(define-struct lift-channel (parameter))

(define (lift-channel-live? ch)
  (and ((lift-channel-parameter ch)) #t))

(define (lift channel value)
  (let ([p (lift-channel-parameter channel)])
    (cond
      [(p) => (lambda (previous)
                (p (cons value previous)))]
      [else (error 'lift "channel is not live")])))

(define-syntax (capture stx)
  (syntax-case stx ()
    [(capture (handler ...) e0 es ...)
     (with-syntax ([(ch ...) (for/list ([handler (syntax->list #'(handler ...))])
                               (syntax-case handler ()
                                 [[ch #:when pred?] #'ch]
                                 [[ch] #'ch]))])
       (with-syntax ([(ch-v ...) (generate-temporaries #'(ch ...))]
                     [(ch-p ...) (generate-temporaries #'(ch ...))]
                     [(ch-captured ...) (generate-temporaries #'(ch ...))]
                     [(ch-escaped ...) (generate-temporaries #'(ch ...))])
         (with-syntax ([(partition-e ...)
                        (for/list ([handler (syntax->list #'(handler ...))]
                                   [ch-p-id (syntax->list #'(ch-p ...))])
                          (with-syntax ([ch-p ch-p-id])
                            (syntax-case handler ()
                              [[_ #:when pred?] #'(partition pred? (ch-p))]
                              [[_] #'(values (ch-p) null)])))])
           #'(let ([ch-v ch] ...)
               (let ([ch-p (lift-channel-parameter ch-v)] ...)
                 (let-values ([(results ch-escaped ...)
                               (parameterize ([ch-p null] ...)
                                 (call-with-values
                                  (lambda () e0 es ...)
                                  (lambda results
                                    (let-values ([(ch-captured ch-escaped) partition-e] ...)
                                      (apply values (append results (list (reverse ch-captured) ...)) (list ch-escaped ...))))))])
                   (escape! ch-p ch-escaped) ...
                   (apply values results)))))))]))

(define (escape! parameter escaped-values)
  (cond
    [(parameter) => (lambda (previous)
                      (parameter (append escaped-values previous)))]))

(define build-lift-channel
  (let ([lift-channel (lambda ()
                        (make-lift-channel (make-parameter #f)))])
    lift-channel))