smalltalk-tng

view experiments/unipat.scm @ 323:454c18798969

find changesets by author, revision, files, or words in the commit message
merger
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Tue Feb 07 11:34:20 2012 -0500 (3 months ago)
parents
children
line source
1 ;; Unifying pattern-matching, parsing, and method dispatch
2
3 (define (alt p1 p2)
4 (lambda (msg kt kf)
5 (p1 msg
6 kt
7 (lambda () (p2 msg kt kf)))))
8
9 ;; { .foo (x, 2, y) -> .ok }
10 ;;
11 ;; seq(literal("foo"), seq(tuple(3, [bind(x, discard()), literal(2), bind(y, discard())]),
12 ;; cut( ... )))
13
14 (define (p . xs)
15 (write xs)
16 (newline)
17 (last xs))
18
19 (define (seq p1 p2)
20 (lambda (msg kt kf)
21 (p 'seq msg)
22 (if (null? msg)
23 (kt (seq p1 p2) msg)
24 (p1 (car msg)
25 (lambda (sv remainder) (p2 (cdr msg) kt kf))
26 kf))))
27
28 (define (empty-seq)
29 (literal '()))
30
31 (define (tuple n pats)
32 (let ((tp (fold-right seq (empty-seq) pats)))
33 (lambda (msg kt kf)
34 (p `(tuple ,n) msg)
35 (if (and (vector? msg)
36 (= (vector-length msg) n))
37 (tp (vector->list msg) kt kf)
38 (kf)))))
39
40 (define (discard)
41 (lambda (msg kt kf)
42 (p 'discard msg)
43 (kt msg '())))
44
45 (define (literal v)
46 (lambda (msg kt kf)
47 (p `(literal ,v) msg)
48 (if (eqv? msg v)
49 (kt msg '())
50 (kf))))
51
52 (define (cut obj-producer-thunk)
53 (lambda (msg kt kf)
54 (p 'cut msg)
55 (kt (obj-producer-thunk) msg)))
56
57 (define (fail)
58 (lambda (msg kt kf)
59 (p 'fail msg)
60 (kf)))
61
62
63 (define (feed parser msg)
64 (parser msg
65 (lambda (sv remainder)
66 (p 'SUCCESS sv remainder)
67 (if (null? remainder)
68 'complete
69 (feed sv remainder)))
70 (lambda ()
71 (p 'FAILURE)
72 'incomplete)))
73
74
75 ;; { .x -> { .y -> 1 } ;
76 ;; .x -> { .z -> 2 } ;
77 ;; .z -> { _ -> 3 } }
78
79 (define (t)
80 (alt (seq (literal 'x) (cut (lambda () (seq (literal 'y) (cut (lambda () 1))))))
81 (alt (seq (literal 'x) (cut (lambda () (seq (literal 'z) (cut (lambda () 2))))))
82 (alt (seq (literal 'z) (cut (lambda () (seq (discard) (cut (lambda () 3))))))
83 (fail)))))
84
85 ;; { .x .y -> 1 ;
86 ;; .x .z -> 2 ;
87 ;; .z _ -> 3 }
88
89 (define (t2)
90 (alt (seq (literal 'x) (seq (literal 'y) (cut (lambda () 1))))
91 (alt (seq (literal 'x) (seq (literal 'z) (cut (lambda () 2))))
92 (alt (seq (literal 'z) (seq (discard) (cut (lambda () 3))))
93 (fail)))))
94
95 (define (drive name parser msg)
96 (p '------------DRIVE name msg)
97 (p '--> (feed parser msg))
98 (newline))
99
100 (define (drive4 name parser)
101 (drive name parser '(x y))
102 (drive name parser '(x z))
103 (drive name parser '(x x))
104 (drive name parser '(z z)))
105
106 (define (run)
107 (drive4 't (t))
108 (drive4 't2 (t2)))