;;; 61.ss  --  SRFI 61  --  Jens Axel Soegaard  -- 23 july 2005

; This is an implementation of SRFI-61 "A more general cond clause". 
;     <http://srfi.schemers.org/srfi-61/srfi-61.html>
; The implementation provides better error messages than the provided 
; reference implementation.

(module |61| mzscheme
  (provide (rename my-cond cond))
  
  (define-syntax (non-spliceable-begin stx)
    (syntax-case stx ()
      [(_ expr ...)
       #'(if #t (begin expr ...))]))
  
  (define-syntax (my-cond stx)
    (syntax-case stx ()
      [(cond)
       (raise-syntax-error #f "expected a list of clauses after 'cond' but got nothing" stx)]
      [(cond clause ...)
       (let loop ([clauses #'(clause ...)])
         (syntax-case clauses ()
           [()   
            #'(void)]
           [_
            (with-syntax ([(clause . more-clauses) clauses])
              (syntax-case #'clause (=> else)
                [(else expr1 expr2 ...)
                 (if (null? (syntax-e #'more-clauses))
                     #'(non-spliceable-begin expr1 expr2 ...)
                     (raise-syntax-error 'cond 
                                         "found an 'else' clause that isn't the last clause in its 'cond' expression"
                                         #'clause))]
                [(test => expr)
                 #`(let ([val test])
                     (if val
                         (let ((proc expr))
                           #,(syntax/loc #'clause (proc val)))          ; location: e.g. (cond (1 => 2))
                         #,(loop #'more-clauses)))]
                [(generator guard => receiver)
                 #`(call-with-values 
                    (lambda () generator)
                    (lambda vals  
                      (if #,(syntax/loc #'clause (apply guard vals))    ; location: e.g (cond (1 2 => 3))
                          #,(syntax/loc #'clause (apply receiver vals)) ; location: e.g (cond (1 + => 3)) 
                          #,(loop #'more-clauses))))]
                [(test expr1 expr2 ...)
                 #`(if test
                       (non-spliceable-begin expr1 expr2 ...)
                       #,(loop #'more-clauses))]
                [_
                 (raise-syntax-error 'cond 
                                     (string-append
                                      "a clause must have one of these forms (<test> <expr> ...), (<test> => <expr>),"
                                      "(<test> <guard> => <expr> or (else <expr> ...) " )
                                     #'clause)]))]))]
      [_
       (raise-syntax-error #f "found a use of 'cond' that does not follow an open parenthesis" stx)]))
  )