(define-library (csc match)
  (export match)
  (import (scheme base))
  (begin


    ; From https://cookbook.scheme.org/check-for-symbol-in-syntax-rules/
    (define-syntax symbol??
      (syntax-rules ()
        ((symbol?? (_ . _) _ kf) kf)  ; It's a pair, not a symbol.
        ((symbol?? #(_ ...) _ kf) kf)  ; It's a vector, not a symbol.
        ((symbol?? maybe-symbol kt kf)
         (let-syntax
           ((test
              (syntax-rules ()
                ((test maybe-symbol t _) t)
                ((test _ _ f) f))))
           (test abracadabra kt kf)))))


    (define-syntax matches?
      (syntax-rules (_)
        ((matches? x _) #t)
        ((matches? x '())
         (null? x))
        ((matches? x (pattern))
         (and (= 1 (length x))
              (matches? (car x) pattern)))
        ((matches? x (pattern1 . pattern2))
         (and (pair? x)
              (matches? (car x) pattern1)
              (matches? (cdr x) pattern2)))
        ((matches? x lit)
         (symbol?? lit
           #t
           (equal? x lit)))))


    (define-syntax bind-pattern
      (syntax-rules (_)
        ((bind-pattern x _ result1 result2 ...)
         (begin result1 result2 ...))
        ((bind-pattern x '() result1 result2 ...)
         (begin result1 result2 ...))
        ((bind-pattern x (pattern) result1 result2 ...)
         (bind-pattern (car x) pattern result1 result2 ...))
        ((bind-pattern x (pattern1 . pattern2) result1 result2 ...)
         (bind-pattern (car x) pattern1
           (bind-pattern (cdr x) pattern2 result1 result2 ...)))
        ((bind-pattern x lit result1 result2 ...)
         (symbol?? lit
           (let ((lit x))
             result1 result2 ...)
           (begin result1 result2 ...)))))


    (define-syntax match
      (syntax-rules ()
        ((match x (pattern result1 result2 ...))
         (if (matches? x pattern)
           (bind-pattern x pattern result1 result2 ...)))
        ((match x (pattern result1 result2 ...) clause1 clause2 ...)
         (if (matches? x pattern)
           (bind-pattern x pattern result1 result2 ...)
           (match x clause1 clause2 ...)))))))