lambda-papers-match/match.rkt at master · carld/lambda-papers-match · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
#lang racket

(define-syntax test
  (syntax-rules ()
    ((_ expr res)
     (let ((r expr))
       (if (equal? (if (list? r) (car r) r) res)
           (printf "pass~%")
           (printf "fail~%"))))))

(define (? s) (eq? #\? (string-ref (symbol->string s) 0)))
(define (! s) (eq? #\! (string-ref (symbol->string s) 0)))

(define (match pattern expression)
  (define (matchfun p e res cont)
    (cond
      ((null? p)
       (if (null? e)
           `[,res ,cont]
           (cont)))
      (else
       (cond
         ; one match, but can be anything (provided it can be unified with prior matches)
         ((? (car p))
          (if (> (length e) 0)
              (if (hash-has-key? res (car p))
                  (if (eq? (car e) (hash-ref res (car p)))
                      (matchfun (cdr p) (cdr e) res cont)
                      (cont))
                  (matchfun (cdr p) (cdr e) (hash-set res (car p) (car e)) cont))
              (cont)))
         ; zero or more matches (provided it can be unified with prior match)
         ((! (car p))
          (if (hash-has-key? res (car p))
              (let ((to-match (hash-ref res (car p))))
                (if (and (>= (length e) (length to-match)) (equal? to-match (take e (length to-match))))
                    (matchfun (cdr p) (drop e (length to-match)) res cont)
                    (cont)))
              (letrec ((matchn (lambda (n)
                                 (if (>= (length e) n)
                                     (matchfun (cdr p)
                                               (drop e n)
                                               (hash-set res (car p) (take e n))
                                               (lambda () (matchn (+ n 1))))
                                     (cont)))))
                (matchn 0))))
         ; a literal match
         (else
          (if (eq? (car p) (car e))
              (matchfun (cdr p) (cdr e) res cont)
              (cont)))))))

  (matchfun pattern expression #hash() (lambda () #f)))

(test
 (match '(A) '(A))
 #hash())

(test
 (match '() '(A))
 #f)

(test
 (match '(?A) '(B))
 #hash((?A . B)))

(test
 (match '(!A) '(B C))
 #hash((!A . (B C))))

(test
 (match '(!A !A) '(B C B C))
 #hash((!A . (B C))))