#lang scheme

(define-syntax :: (lambda (stx) (raise-syntax-error ':: "dont use this")))

#|
x :: bs -> (list x . bs)
x :: a :: b -> (list x a . b)
|#

(define-syntax (list-match stx)
  (define (fixup-pattern pattern)
    (syntax-case pattern (::)
      [(head :: tail)
       (with-syntax ([head (fixup-pattern #'head)]
                     [tail (fixup-pattern #'tail)])
       #'(list-rest head tail))]
      [(head :: tail :: rest ...)
       (with-syntax ([head (fixup-pattern #'head)]
                     [tail (fixup-pattern #'tail)]
                     [(_ rest ...) (fixup-pattern #'(rest ...))])
         #'(list-rest head tail rest ...))]
      [(x) #'(list-rest x)]
      [x (identifier? #'x) #'x]
      [else (raise-syntax-error 'fixup-pattern "unknown pattern" (syntax->datum pattern))]
      ))
  (syntax-case stx ()
    [(_ expr (pattern result) ...)
     (with-syntax ([(updated-pattern ...)
                    (map fixup-pattern (syntax->list #'(pattern ...)))])
     #'(match expr
              (updated-pattern result) ...))]))

(list-match '(1 2 3)
  [(a :: b) (and
              (equal? a 1)
              (equal? b '(2 3)))])
(list-match '(1 2 3 4)
  [(a :: b :: c) (and
                   (equal? a 1)
                   (equal? b 2)
                   (equal? c '(3 4)))])

(list-match '((1 2) (3 4))
  [((a :: b) :: c) (and
                     (equal? a 1)
                     (equal? b '(2))
                     (equal? c '((3 4))))])

(list-match '(1 2 3)
  [(a :: b :: c :: null) (and
                           (equal? a 1)
                           (equal? b 2)
                           (equal? c 3))])

(list-match 1
  [(a) (and (equal? a 1))])