(module-name 'Match)

(module-static #t)


; This module defines a 'match' macro
; for pattern matching.
;
; Usage is rather like 'case':
;   (match EXPR
;     (PATTERN EXPR0 EXPR1 ...)
;     ...
;     (else EXPR0 EXPR1 ...)
;   )
; e.g.
;   (match E
;     ( (= 1)
;         "The number 1"
;     )
;     ( (or (= 2) (= 3))
;         "The number 2 or 3"
;     )
;     ( (test > 10)
;         "A number greater than 10"
;     )
;     ( (and (test > 20) (test < 30))
;         "A number greater than 20 and less than 30"
;     )
;     ( (list (? h) (? h2) (?? t))
;         (string-append "A list of at least 2 elements: " h " " h2 " " t)
;     )
;     ( (list (= 'a) (?? t))
;         (string-append "A list starting with the symbol 'a: ... " t)
;     )
;     ( (list (or (= 'a) (= 'b)) (?? t))
;         (string-append "A list starting with the symbols 'a or 'b: ... " t)
;     )
;     ( (cons (? a) (? b))
;         (string-append "A cons: " a " " b)
;     )
;   )
;
; All patterns are lists starting with special keywords:
;   (? IDENTIFIER)
;     Declares IDENTIFIER and binds the current expression component
;     to it if the pattern matches.
;   (= EXPR)
;     Something which is equal? to EXPR.
;   (cons PATTERN1 PATTERN2)
;     A pair whose elements match PATTERN1 and PATTERN2.
;   (list) or ()
;     The empty list.
;   (list PATTERN1 PATTERN2 ...)
;     A list whose elements match PATTERN1, PATTERN2 and so on. Its
;     length must be no longer than the sum of the lengths matched
;     by all the pattern elements
;   (?? IDENTIFIER)
;     Only makes sense as the last element of a (list ...). Declares
;     IDENTIFIER and binds the unmatched portion of the list to it
;     if the pattern matches.
;   (or PATTERN ...)
;     Matches if at least one of the PATTERNs matches.
;   (and PATTERN ...)
;     Matches if all the PATTERNs match.
;   (type TYPE)
;     Matches if the current expression component is of type TYPE.
;   (test F ARG ...)
;     Matches if (F e ARG ...) is true, where e is the
;     current expression component.
;
; The macro 'match' is composed of two submacros, match-lets
; and 'match-trans'. match-lets runs through the pattern
; building a 'let' expression (actually, a lot of nested lets,
; because that's easier) which declares all the variables in the
; pattern, i.e. those occurring in (? V) and (?? V) subpatterns.
; match-trans converts the pattern into a function of one argument
; which, when applied to that argument, returns #t if it would
; match the pattern and #f otherwise. As a side-effect, it will
; bind the variables in the pattern.


(define-syntax match
  (syntax-rules (else)
    ((_ e
        (else Then0 Then1 ...)
     )
     (begin Then0 Then1 ...)
    )
    ((_ e
	(P Then0 Then1 ...)
        Else ...
     )
     (let ( (result 'result-not-set)
          )
       (if (match-lets P (if ((match-trans P) e)
                           (begin
                             (set! result (begin Then0 Then1 ...))
                             #t
                           )
                         ;else
                           #f
                         )
           )
         result
       ;else
         (match e Else ...)
       )
     )
    )
    ((_ e)
     e
    )
  )
)


; (match-lets P E) rewrites to an expression
; that evaluates E inside an environment 
; containing all the pattern variables in P.
;
(define-syntax match-lets
  (syntax-rules (? ?? = cons list type or and test)
    ((_ () E)
     E
    )
    ((_ (? V) E) 
     (let ( (V 'pattern-var-not-set) 
          )
       E
     ) 
    )
    ((_ (?? V) E) 
     (let ( (V 'pattern-var-not-set) 
          )
       E
     ) 
    )
    ((_ (= C) E)
     E
    )
    ((_ (cons P1 P2) E)
     (match-lets P1 (match-lets P2 E))
    )
    ((_ (list) E)
     E
    )
    ((_ (list P1 P2 ...) E)
     (match-lets P1 (match-lets (list P2 ...) E))
    )
    ((_ (type T) E)
     E
    )
    ((_ (or) E)
     E
    )
    ((_ (or P1 P2 ...) E)
     (match-lets P1 (match-lets (or P2 ...) E))
    )
    ((_ (and) E)
     E
    )
    ((_ (and P1 P2 ...) E)
     (match-lets P1 (match-lets (and P2 ...) E))
    )
    ((_ (test F Arg ...) E)
     E
    )
  )
)


; (match-trans P) rewrites to an expression
; returning a function that when applied to
; an expression e, returns #t if e matches P
; and #f otherwise. If P binds variables,
; the function will do this as a side-effect.
;
(define-syntax match-trans
  (syntax-rules (? ?? = cons list type or and test)
    ((_ ()) 
     null?
    )
    ((_ (? V))
     (lambda (e) (set! V e) #t)
    )
    ((_ (= C))
     (lambda (e) (equal? e C))
    )
    ((_ (cons P1 P2))
     (lambda (e) (and (pair? e)
                      ((match-trans P1) (car e))
                      ((match-trans P2) (cdr e))
                 )
     )
    )
    ((_ (list))
     null?
    )
    ((_ (list (?? V)))
     (lambda (e) (if (list? e)
                   (begin (set! V e) #t)
                 ;else
                   #f   
                 )
     )
    )
    ((_ (list P1 P2 ...))
     (lambda (e) (and (list? e)
                      ((match-trans P1) (car e))
                      ((match-trans (list P2 ...)) (cdr e))
                 )
     )
    )
    ((_ (type T))
     (lambda (e) (or (and (equal? T <int>) (integer? e))
                     (and (equal? T <boolean>) (boolean? e))
                     (instance? e T)
                 )
                 ; instance? doesn't work on integers and <int>,
                 ; or #f/#t and <boolean>.
     )
    )
    ((_ (or))
     (lambda (e) #f)
    )
    ((_ (or P1 P2 ...))
     (lambda (e) (or ((match-trans P1) e)
                     ((match-trans (or P2 ...)) e)
                 )
     )
    )
    ((_ (and))
     (lambda (e) #t)
    )
    ((_ (and P1 P2 ...))
     (lambda (e) (and ((match-trans P1) e)
                      ((match-trans (and P2 ...)) e)
                 )
     )
    )
    ((_ (test F Arg ...))
     (lambda (e) (F e Arg ...))
    ) 
  )
)