smalltalk-tng

view experiments/unipat.scm @ 321:c4a0718c2d3c

find changesets by author, revision, files, or words in the commit message
Sketch of dependencies
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Sat Oct 08 15:36:03 2011 -0400 (7 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)))