36 val max: ('a * 'a -> bool) -> ('b -> 'a * 'b) -> ('b -> 'a * 'b) -> 'b -> 'a * 'b |
36 val max: ('a * 'a -> bool) -> ('b -> 'a * 'b) -> ('b -> 'a * 'b) -> 'b -> 'a * 'b |
37 val ahead: ('a -> 'b * 'c) -> 'a -> 'b * 'a |
37 val ahead: ('a -> 'b * 'c) -> 'a -> 'b * 'a |
38 val depend: ('a -> 'b -> ('c * 'd) * 'e) -> 'a * 'b -> 'd * ('c * 'e) |
38 val depend: ('a -> 'b -> ('c * 'd) * 'e) -> 'a * 'b -> 'd * ('c * 'e) |
39 val lift: ('a -> 'b * 'c) -> 'd * 'a -> 'b * ('d * 'c) |
39 val lift: ('a -> 'b * 'c) -> 'd * 'a -> 'b * ('d * 'c) |
40 val pass: 'a -> ('a * 'b -> 'c * ('d * 'e)) -> 'b -> 'c * 'e |
40 val pass: 'a -> ('a * 'b -> 'c * ('d * 'e)) -> 'b -> 'c * 'e |
|
41 val try: ('a -> 'b) -> 'a -> 'b |
41 val force: ('a -> 'b) -> 'a -> 'b |
42 val force: ('a -> 'b) -> 'a -> 'b |
|
43 val prompt: string -> ('a -> 'b) -> 'a -> 'b |
42 val finite': ''a -> ('b * ''a list -> 'c * ('d * ''a list)) |
44 val finite': ''a -> ('b * ''a list -> 'c * ('d * ''a list)) |
43 -> 'b * ''a list -> 'c * ('d * ''a list) |
45 -> 'b * ''a list -> 'c * ('d * ''a list) |
44 val finite: ''a -> (''a list -> 'b * ''a list) -> ''a list -> 'b * ''a list |
46 val finite: ''a -> (''a list -> 'b * ''a list) -> ''a list -> 'b * ''a list |
45 val error: ('a -> 'b) -> 'a -> 'b |
47 val error: ('a -> 'b) -> 'a -> 'b |
46 val source: ('a -> 'b list * 'a) -> ('b list * 'a -> 'c) |
48 val source: string -> (string -> 'a -> 'b list * 'a) |
47 -> ('b list -> 'd * 'b list) -> 'a -> 'd list * 'c |
49 -> ('c * 'a -> 'd) -> ('b list -> 'e * 'c) -> 'a -> 'e * 'd |
|
50 val single: ('a -> 'b * 'c) -> 'a -> 'b list * 'c |
|
51 val many: ('a -> 'b * 'a) -> 'a -> 'b list * 'a |
48 type lexicon |
52 type lexicon |
49 val dest_lexicon: lexicon -> string list list |
53 val dest_lexicon: lexicon -> string list list |
50 val make_lexicon: string list list -> lexicon |
54 val make_lexicon: string list list -> lexicon |
51 val empty_lexicon: lexicon |
55 val empty_lexicon: lexicon |
52 val extend_lexicon: lexicon -> string list list -> lexicon |
56 val extend_lexicon: lexicon -> string list list -> lexicon |
58 struct |
62 struct |
59 |
63 |
60 |
64 |
61 (** scanners **) |
65 (** scanners **) |
62 |
66 |
63 exception MORE; (*need more input*) |
67 exception MORE of string option; (*need more input (use prompt)*) |
64 exception FAIL; (*try alternatives*) |
68 exception FAIL; (*try alternatives*) |
65 exception ABORT of string; (*dead end*) |
69 exception ABORT of string; (*dead end*) |
66 |
70 |
67 |
71 |
68 (* scanner combinators *) |
72 (* scanner combinators *) |
69 |
73 |
70 fun (scan >> f) xs = apfst f (scan xs); |
74 fun (scan >> f) xs = apfst f (scan xs); |
86 (* generic scanners *) |
90 (* generic scanners *) |
87 |
91 |
88 fun fail _ = raise FAIL; |
92 fun fail _ = raise FAIL; |
89 fun succeed y xs = (y, xs); |
93 fun succeed y xs = (y, xs); |
90 |
94 |
91 fun one _ [] = raise MORE |
95 fun one _ [] = raise MORE None |
92 | one pred (x :: xs) = |
96 | one pred (x :: xs) = |
93 if pred x then (x, xs) else raise FAIL; |
97 if pred x then (x, xs) else raise FAIL; |
94 |
98 |
95 fun $$ _ [] = raise MORE |
99 fun $$ _ [] = raise MORE None |
96 | $$ a (x :: xs) = |
100 | $$ a (x :: xs) = |
97 if a = x then (x, xs) else raise FAIL; |
101 if a = x then (x, xs) else raise FAIL; |
98 |
102 |
99 fun any _ [] = raise MORE |
103 fun any _ [] = raise MORE None |
100 | any pred (lst as x :: xs) = |
104 | any pred (lst as x :: xs) = |
101 if pred x then apfst (cons x) (any pred xs) |
105 if pred x then apfst (cons x) (any pred xs) |
102 else ([], lst); |
106 else ([], lst); |
103 |
107 |
104 fun any1 pred = one pred -- any pred >> op ::; |
108 fun any1 pred = one pred -- any pred >> op ::; |
136 |
140 |
137 |
141 |
138 (* exception handling *) |
142 (* exception handling *) |
139 |
143 |
140 fun !! err scan xs = scan xs handle FAIL => raise ABORT (err xs); |
144 fun !! err scan xs = scan xs handle FAIL => raise ABORT (err xs); |
141 fun force scan xs = scan xs handle MORE => raise FAIL; |
145 fun try scan xs = scan xs handle MORE _ => raise FAIL | ABORT _ => raise FAIL; |
|
146 fun force scan xs = scan xs handle MORE _ => raise FAIL; |
|
147 fun prompt str scan xs = scan xs handle MORE None => raise MORE (Some str); |
142 fun error scan xs = scan xs handle ABORT msg => Library.error msg; |
148 fun error scan xs = scan xs handle ABORT msg => Library.error msg; |
143 |
149 |
144 |
150 |
145 (* finite scans *) |
151 (* finite scans *) |
146 |
152 |
161 fun finite stopper scan xs = |
167 fun finite stopper scan xs = |
162 let val (y, ((), xs')) = finite' stopper (lift scan) ((), xs) |
168 let val (y, ((), xs')) = finite' stopper (lift scan) ((), xs) |
163 in (y, xs') end; |
169 in (y, xs') end; |
164 |
170 |
165 |
171 |
166 (* infinite scans *) (* FIXME state based!? *) |
172 (* infinite scans *) |
167 |
173 |
168 fun source get unget scan src = |
174 fun source def_prmpt get unget scan src = |
169 let |
175 let |
170 fun try_more x = |
|
171 scan x handle MORE => raise FAIL | ABORT _ => raise FAIL; |
|
172 |
|
173 fun drain (xs, s) = |
176 fun drain (xs, s) = |
174 (((scan -- repeat try_more) >> op ::) xs, s) |
177 (scan xs, s) |
175 handle MORE => |
178 handle MORE prmpt => |
176 let val (more_xs, s') = get s in |
179 let val (more_xs, s') = get (if_none prmpt def_prmpt) s in |
177 if null more_xs then raise ABORT "Input source exhausted" |
180 if null more_xs then raise ABORT "Input source exhausted" |
178 else drain (xs @ more_xs, s') |
181 else drain (xs @ more_xs, s') |
179 end; |
182 end; |
180 |
183 val ((ys, xs'), src') = drain (get def_prmpt src); |
181 val ((ys, xs'), src') = drain (get src); |
|
182 in (ys, unget (xs', src')) end; |
184 in (ys, unget (xs', src')) end; |
183 |
185 |
|
186 fun single scan = scan >> (fn x => [x]); |
|
187 fun many scan = scan -- repeat (try scan) >> (op ::); |
184 |
188 |
185 |
189 |
186 |
190 |
187 (** datatype lexicon **) |
191 (** datatype lexicon **) |
188 |
192 |
238 (* scan literal *) |
242 (* scan literal *) |
239 |
243 |
240 fun literal lex chrs = |
244 fun literal lex chrs = |
241 let |
245 let |
242 fun lit Empty res _ = res |
246 fun lit Empty res _ = res |
243 | lit (Branch _) _ [] = raise MORE |
247 | lit (Branch _) _ [] = raise MORE None |
244 | lit (Branch (d, a, lt, eq, gt)) res (chs as c :: cs) = |
248 | lit (Branch (d, a, lt, eq, gt)) res (chs as c :: cs) = |
245 if c < d then lit lt res chs |
249 if c < d then lit lt res chs |
246 else if c > d then lit gt res chs |
250 else if c > d then lit gt res chs |
247 else lit eq (if a = no_literal then res else Some (a, cs)) cs; |
251 else lit eq (if a = no_literal then res else Some (a, cs)) cs; |
248 in |
252 in |