; A simple syntax-rules based patterm matching facility for Scheme based somewhat on Haskell
; Copyright 2005 Brian Alliet

; The expr argument to match-singe WILL be evaluated multiple times
; it shouldn't have side effects
(define-syntax match-single
    (syntax-rules (cons list quote @ _)
        ; Wildcard pattern (_ in haskell)
        ((match-single _   expr success fail) success)
        ; AS patterns (x@pat in haskell)
        ((match-single (var @ pat) expr success fail)
            (match-single pat expr (let ((var expr)) success) fail))
        ; Cons cell pattern (x:xs or (x,y) in haskell)
        ((match-single (cons p1 p2) expr success fail)
            (if (pair? expr)
                (let 
                    ((x (car expr)) (xs (cdr expr)))
                    (match-single p1 x
                        (match-single p2 xs success fail)
                        fail))
                fail))
        ; Zero length list ([] in haskell)
        ((match-single (quote ()) expr success fail) (if (null? expr) success fail))
        ; Fixed length lists ([x1,x2,...xn] in haskell)
        ((match-single (list) expr success fail) (match-single '() expr success fail))
        ((match-single (list x y ...) expr success fail)
            (match-single (cons x (list y ...)) expr success fail))
        ; True and false constants, we know we can test these with eq? (True and False in haskell)
        ((match-single (quote #t) expr success fail) (if (eq? #t expr) success fail))
        ((match-single (quote #f) expr success fail) (if (eq? #f expr) success fail))
        ; Other quoted items are compared for equality with equal?
        ((match-single (quote pat) expr success fail) (if (equal? 'pat expr) success fail))
        ; Anything else MUST be a variable pattern
        ((match-single pat expr success fail) 
            (symbol?? pat
                ; If it is a variable bind the value to it and succeed
                (let ((pat expr)) success)
                ; If not, it is something weird we can't handle, blow up
                (syntax-error "invalid pattern" 'pat)
            ))
    ))

; expr WILL be evaluated multiple times
(define-syntax match-helper
    (syntax-rules ()
        ((match-helper expr) (error "pattern match failure"))
        ((match-helper expr (pat body) r ...)
            (let
                ; Is there a better way to do this?
                ; If the match fails we need to get back up to this scope
                ((fail (lambda () (match-helper expr r ...))))
                (match-single pat expr body (fail))))
    ))

(define-syntax match
    (syntax-rules ()
        ((match expr clauses ...) (let ((e expr)) (match-helper e clauses ...)))
    ))

(define-syntax lambda-match
    (syntax-rules ()
        ((lambda-match clauses ...) (lambda (x) (match x clauses ...)))
    ))

(define-syntax define-match
    (syntax-rules ()
        ((define-match f clauses ...) (define f (lambda-match clauses ...)))
    ))