adamc@26
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@26
|
2 * All rights reserved.
|
adamc@26
|
3 *
|
adamc@26
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@26
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@26
|
6 *
|
adamc@26
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@26
|
8 * this list of conditions and the following disclaimer.
|
adamc@26
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@26
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@26
|
11 * and/or other materials provided with the distribution.
|
adamc@26
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@26
|
13 * derived from this software without specific prior written permission.
|
adamc@26
|
14 *
|
adamc@26
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@26
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@26
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@26
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@26
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@26
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@26
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@26
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@26
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@26
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@26
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@26
|
26 *)
|
adamc@26
|
27
|
adamc@26
|
28 structure MonoUtil :> MONO_UTIL = struct
|
adamc@26
|
29
|
adamc@26
|
30 open Mono
|
adamc@26
|
31
|
adamc@26
|
32 structure S = Search
|
adamc@26
|
33
|
adamc@267
|
34 val dummyt = (TRecord [], ErrorMsg.dummySpan)
|
adamc@267
|
35
|
adamc@26
|
36 structure Typ = struct
|
adamc@26
|
37
|
adamc@193
|
38 open Order
|
adamc@109
|
39
|
adamc@109
|
40 fun compare ((t1, _), (t2, _)) =
|
adamc@109
|
41 case (t1, t2) of
|
adamc@109
|
42 (TFun (d1, r1), TFun (d2, r2)) =>
|
adamc@109
|
43 join (compare (d1, d2), fn () => compare (r1, r2))
|
adamc@109
|
44 | (TRecord xts1, TRecord xts2) =>
|
adamc@109
|
45 let
|
adamc@109
|
46 val xts1 = sortFields xts1
|
adamc@109
|
47 val xts2 = sortFields xts2
|
adamc@109
|
48 in
|
adamc@109
|
49 joinL compareFields (xts1, xts2)
|
adamc@109
|
50 end
|
adamc@196
|
51 | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
|
adamc@109
|
52 | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
|
adamc@288
|
53 | (TOption t1, TOption t2) => compare (t1, t2)
|
adamc@109
|
54
|
adamc@109
|
55 | (TFun _, _) => LESS
|
adamc@109
|
56 | (_, TFun _) => GREATER
|
adamc@109
|
57
|
adamc@109
|
58 | (TRecord _, _) => LESS
|
adamc@109
|
59 | (_, TRecord _) => GREATER
|
adamc@109
|
60
|
adamc@168
|
61 | (TDatatype _, _) => LESS
|
adamc@168
|
62 | (_, TDatatype _) => GREATER
|
adamc@109
|
63
|
adamc@288
|
64 | (TFfi _, _) => LESS
|
adamc@288
|
65 | (_, TFfi _) => GREATER
|
adamc@288
|
66
|
adamc@109
|
67 and compareFields ((x1, t1), (x2, t2)) =
|
adamc@109
|
68 join (String.compare (x1, x2),
|
adamc@109
|
69 fn () => compare (t1, t2))
|
adamc@109
|
70
|
adamc@109
|
71 and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts
|
adamc@109
|
72
|
adamc@26
|
73 fun mapfold fc =
|
adamc@26
|
74 let
|
adamc@26
|
75 fun mft c acc =
|
adamc@26
|
76 S.bindP (mft' c acc, fc)
|
adamc@26
|
77
|
adamc@26
|
78 and mft' (cAll as (c, loc)) =
|
adamc@26
|
79 case c of
|
adamc@26
|
80 TFun (t1, t2) =>
|
adamc@26
|
81 S.bind2 (mft t1,
|
adamc@26
|
82 fn t1' =>
|
adamc@26
|
83 S.map2 (mft t2,
|
adamc@26
|
84 fn t2' =>
|
adamc@26
|
85 (TFun (t1', t2'), loc)))
|
adamc@26
|
86 | TRecord xts =>
|
adamc@26
|
87 S.map2 (ListUtil.mapfold (fn (x, t) =>
|
adamc@26
|
88 S.map2 (mft t,
|
adamc@26
|
89 fn t' =>
|
adamc@26
|
90 (x, t')))
|
adamc@26
|
91 xts,
|
adamc@26
|
92 fn xts' => (TRecord xts', loc))
|
adamc@168
|
93 | TDatatype _ => S.return2 cAll
|
adamc@51
|
94 | TFfi _ => S.return2 cAll
|
adamc@288
|
95 | TOption t =>
|
adamc@288
|
96 S.map2 (mft t,
|
adamc@288
|
97 fn t' =>
|
adamc@288
|
98 (TOption t, loc))
|
adamc@26
|
99 in
|
adamc@26
|
100 mft
|
adamc@26
|
101 end
|
adamc@26
|
102
|
adamc@26
|
103 fun map typ c =
|
adamc@26
|
104 case mapfold (fn c => fn () => S.Continue (typ c, ())) c () of
|
adamc@26
|
105 S.Return () => raise Fail "Mono_util.Typ.map"
|
adamc@26
|
106 | S.Continue (c, ()) => c
|
adamc@26
|
107
|
adamc@26
|
108 fun fold typ s c =
|
adamc@26
|
109 case mapfold (fn c => fn s => S.Continue (c, typ (c, s))) c s of
|
adamc@26
|
110 S.Continue (_, s) => s
|
adamc@26
|
111 | S.Return _ => raise Fail "MonoUtil.Typ.fold: Impossible"
|
adamc@26
|
112
|
adamc@26
|
113 fun exists typ k =
|
adamc@26
|
114 case mapfold (fn c => fn () =>
|
adamc@26
|
115 if typ c then
|
adamc@26
|
116 S.Return ()
|
adamc@26
|
117 else
|
adamc@26
|
118 S.Continue (c, ())) k () of
|
adamc@26
|
119 S.Return _ => true
|
adamc@26
|
120 | S.Continue _ => false
|
adamc@26
|
121
|
adamc@26
|
122 end
|
adamc@26
|
123
|
adamc@26
|
124 structure Exp = struct
|
adamc@26
|
125
|
adamc@26
|
126 datatype binder =
|
adamc@168
|
127 Datatype of string * int * (string * int * typ option) list
|
adamc@26
|
128 | RelE of string * typ
|
adamc@109
|
129 | NamedE of string * int * typ * exp option * string
|
adamc@26
|
130
|
adamc@26
|
131 fun mapfoldB {typ = fc, exp = fe, bind} =
|
adamc@26
|
132 let
|
adamc@26
|
133 val mft = Typ.mapfold fc
|
adamc@26
|
134
|
adamc@26
|
135 fun mfe ctx e acc =
|
adamc@26
|
136 S.bindP (mfe' ctx e acc, fe ctx)
|
adamc@26
|
137
|
adamc@26
|
138 and mfe' ctx (eAll as (e, loc)) =
|
adamc@26
|
139 case e of
|
adamc@26
|
140 EPrim _ => S.return2 eAll
|
adamc@26
|
141 | ERel _ => S.return2 eAll
|
adamc@26
|
142 | ENamed _ => S.return2 eAll
|
adamc@188
|
143 | ECon (_, _, NONE) => S.return2 eAll
|
adamc@188
|
144 | ECon (dk, n, SOME e) =>
|
adamc@178
|
145 S.map2 (mfe ctx e,
|
adamc@178
|
146 fn e' =>
|
adamc@188
|
147 (ECon (dk, n, SOME e'), loc))
|
adamc@297
|
148 | ENone t =>
|
adamc@297
|
149 S.map2 (mft t,
|
adamc@297
|
150 fn t' =>
|
adamc@297
|
151 (ENone t', loc))
|
adamc@290
|
152 | ESome (t, e) =>
|
adamc@290
|
153 S.bind2 (mft t,
|
adamc@290
|
154 fn t' =>
|
adamc@290
|
155 S.map2 (mfe ctx e,
|
adamc@290
|
156 fn e' =>
|
adamc@290
|
157 (ESome (t', e'), loc)))
|
adamc@51
|
158 | EFfi _ => S.return2 eAll
|
adamc@51
|
159 | EFfiApp (m, x, es) =>
|
adamc@51
|
160 S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es,
|
adamc@51
|
161 fn es' =>
|
adamc@51
|
162 (EFfiApp (m, x, es'), loc))
|
adamc@26
|
163 | EApp (e1, e2) =>
|
adamc@26
|
164 S.bind2 (mfe ctx e1,
|
adamc@26
|
165 fn e1' =>
|
adamc@26
|
166 S.map2 (mfe ctx e2,
|
adamc@26
|
167 fn e2' =>
|
adamc@26
|
168 (EApp (e1', e2'), loc)))
|
adamc@26
|
169 | EAbs (x, dom, ran, e) =>
|
adamc@26
|
170 S.bind2 (mft dom,
|
adamc@26
|
171 fn dom' =>
|
adamc@26
|
172 S.bind2 (mft ran,
|
adamc@26
|
173 fn ran' =>
|
adamc@26
|
174 S.map2 (mfe (bind (ctx, RelE (x, dom'))) e,
|
adamc@26
|
175 fn e' =>
|
adamc@26
|
176 (EAbs (x, dom', ran', e'), loc))))
|
adamc@26
|
177
|
adamc@26
|
178 | ERecord xes =>
|
adamc@29
|
179 S.map2 (ListUtil.mapfold (fn (x, e, t) =>
|
adamc@29
|
180 S.bind2 (mfe ctx e,
|
adamc@26
|
181 fn e' =>
|
adamc@29
|
182 S.map2 (mft t,
|
adamc@29
|
183 fn t' =>
|
adamc@29
|
184 (x, e', t'))))
|
adamc@26
|
185 xes,
|
adamc@26
|
186 fn xes' =>
|
adamc@26
|
187 (ERecord xes', loc))
|
adamc@26
|
188 | EField (e, x) =>
|
adamc@26
|
189 S.map2 (mfe ctx e,
|
adamc@26
|
190 fn e' =>
|
adamc@26
|
191 (EField (e', x), loc))
|
adamc@94
|
192
|
adamc@182
|
193 | ECase (e, pes, {disc, result}) =>
|
adamc@178
|
194 S.bind2 (mfe ctx e,
|
adamc@178
|
195 fn e' =>
|
adamc@178
|
196 S.bind2 (ListUtil.mapfold (fn (p, e) =>
|
adamc@179
|
197 let
|
adamc@179
|
198 fun pb ((p, _), ctx) =
|
adamc@179
|
199 case p of
|
adamc@179
|
200 PWild => ctx
|
adamc@182
|
201 | PVar (x, t) => bind (ctx, RelE (x, t))
|
adamc@179
|
202 | PPrim _ => ctx
|
adamc@188
|
203 | PCon (_, _, NONE) => ctx
|
adamc@188
|
204 | PCon (_, _, SOME p) => pb (p, ctx)
|
adamc@182
|
205 | PRecord xps => foldl (fn ((_, p, _), ctx) =>
|
adamc@179
|
206 pb (p, ctx)) ctx xps
|
adamc@288
|
207 | PNone _ => ctx
|
adamc@288
|
208 | PSome (_, p) => pb (p, ctx)
|
adamc@179
|
209 in
|
adamc@179
|
210 S.map2 (mfe (pb (p, ctx)) e,
|
adamc@179
|
211 fn e' => (p, e'))
|
adamc@179
|
212 end) pes,
|
adamc@178
|
213 fn pes' =>
|
adamc@182
|
214 S.bind2 (mft disc,
|
adamc@182
|
215 fn disc' =>
|
adamc@182
|
216 S.map2 (mft result,
|
adamc@182
|
217 fn result' =>
|
adamc@182
|
218 (ECase (e', pes', {disc = disc', result = result'}), loc)))))
|
adamc@178
|
219
|
adamc@283
|
220 | EError (e, t) =>
|
adamc@283
|
221 S.bind2 (mfe ctx e,
|
adamc@283
|
222 fn e' =>
|
adamc@283
|
223 S.map2 (mft t,
|
adamc@283
|
224 fn t' =>
|
adamc@283
|
225 (EError (e', t'), loc)))
|
adamc@283
|
226
|
adamc@94
|
227 | EStrcat (e1, e2) =>
|
adamc@94
|
228 S.bind2 (mfe ctx e1,
|
adamc@94
|
229 fn e1' =>
|
adamc@94
|
230 S.map2 (mfe ctx e2,
|
adamc@94
|
231 fn e2' =>
|
adamc@94
|
232 (EStrcat (e1', e2'), loc)))
|
adamc@102
|
233
|
adamc@102
|
234 | EWrite e =>
|
adamc@102
|
235 S.map2 (mfe ctx e,
|
adamc@102
|
236 fn e' =>
|
adamc@102
|
237 (EWrite e', loc))
|
adamc@106
|
238
|
adamc@106
|
239 | ESeq (e1, e2) =>
|
adamc@106
|
240 S.bind2 (mfe ctx e1,
|
adamc@106
|
241 fn e1' =>
|
adamc@106
|
242 S.map2 (mfe ctx e2,
|
adamc@106
|
243 fn e2' =>
|
adamc@106
|
244 (ESeq (e1', e2'), loc)))
|
adamc@251
|
245 | ELet (x, t, e1, e2) =>
|
adamc@251
|
246 S.bind2 (mft t,
|
adamc@251
|
247 fn t' =>
|
adamc@251
|
248 S.bind2 (mfe ctx e1,
|
adamc@251
|
249 fn e1' =>
|
adamc@252
|
250 S.map2 (mfe (bind (ctx, RelE (x, t'))) e2,
|
adamc@251
|
251 fn e2' =>
|
adamc@251
|
252 (ELet (x, t', e1', e2'), loc))))
|
adamc@111
|
253
|
adamc@111
|
254 | EClosure (n, es) =>
|
adamc@111
|
255 S.map2 (ListUtil.mapfold (mfe ctx) es,
|
adamc@111
|
256 fn es' =>
|
adamc@111
|
257 (EClosure (n, es'), loc))
|
adamc@252
|
258
|
adamc@252
|
259 | EQuery {exps, tables, state, query, body, initial} =>
|
adamc@252
|
260 S.bind2 (ListUtil.mapfold (fn (x, t) =>
|
adamc@252
|
261 S.map2 (mft t,
|
adamc@252
|
262 fn t' => (x, t'))) exps,
|
adamc@252
|
263 fn exps' =>
|
adamc@252
|
264 S.bind2 (ListUtil.mapfold (fn (x, xts) =>
|
adamc@252
|
265 S.map2 (ListUtil.mapfold
|
adamc@252
|
266 (fn (x, t) =>
|
adamc@252
|
267 S.map2 (mft t,
|
adamc@252
|
268 fn t' => (x, t'))) xts,
|
adamc@252
|
269 fn xts' => (x, xts'))) tables,
|
adamc@252
|
270 fn tables' =>
|
adamc@252
|
271 S.bind2 (mft state,
|
adamc@252
|
272 fn state' =>
|
adamc@252
|
273 S.bind2 (mfe ctx query,
|
adamc@252
|
274 fn query' =>
|
adamc@267
|
275 S.bind2 (mfe (bind (bind (ctx, RelE ("r", dummyt)),
|
adamc@267
|
276 RelE ("acc", dummyt)))
|
adamc@267
|
277 body,
|
adamc@267
|
278 fn body' =>
|
adamc@267
|
279 S.map2 (mfe ctx initial,
|
adamc@267
|
280 fn initial' =>
|
adamc@267
|
281 (EQuery {exps = exps',
|
adamc@267
|
282 tables = tables',
|
adamc@267
|
283 state = state',
|
adamc@267
|
284 query = query',
|
adamc@267
|
285 body = body',
|
adamc@267
|
286 initial = initial'},
|
adamc@267
|
287 loc)))))))
|
adamc@307
|
288
|
adamc@307
|
289 | EDml e =>
|
adamc@307
|
290 S.map2 (mfe ctx e,
|
adamc@307
|
291 fn e' =>
|
adamc@307
|
292 (EDml e', loc))
|
adamc@26
|
293 in
|
adamc@26
|
294 mfe
|
adamc@26
|
295 end
|
adamc@26
|
296
|
adamc@26
|
297 fun mapfold {typ = fc, exp = fe} =
|
adamc@26
|
298 mapfoldB {typ = fc,
|
adamc@26
|
299 exp = fn () => fe,
|
adamc@26
|
300 bind = fn ((), _) => ()} ()
|
adamc@26
|
301
|
adamc@26
|
302 fun mapB {typ, exp, bind} ctx e =
|
adamc@26
|
303 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
|
adamc@26
|
304 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
|
adamc@26
|
305 bind = bind} ctx e () of
|
adamc@26
|
306 S.Continue (e, ()) => e
|
adamc@26
|
307 | S.Return _ => raise Fail "MonoUtil.Exp.mapB: Impossible"
|
adamc@26
|
308
|
adamc@26
|
309 fun map {typ, exp} e =
|
adamc@26
|
310 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
|
adamc@26
|
311 exp = fn e => fn () => S.Continue (exp e, ())} e () of
|
adamc@26
|
312 S.Return () => raise Fail "Mono_util.Exp.map"
|
adamc@26
|
313 | S.Continue (e, ()) => e
|
adamc@26
|
314
|
adamc@26
|
315 fun fold {typ, exp} s e =
|
adamc@26
|
316 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
|
adamc@26
|
317 exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
|
adamc@26
|
318 S.Continue (_, s) => s
|
adamc@26
|
319 | S.Return _ => raise Fail "MonoUtil.Exp.fold: Impossible"
|
adamc@26
|
320
|
adamc@26
|
321 fun exists {typ, exp} k =
|
adamc@26
|
322 case mapfold {typ = fn c => fn () =>
|
adamc@26
|
323 if typ c then
|
adamc@26
|
324 S.Return ()
|
adamc@26
|
325 else
|
adamc@26
|
326 S.Continue (c, ()),
|
adamc@26
|
327 exp = fn e => fn () =>
|
adamc@26
|
328 if exp e then
|
adamc@26
|
329 S.Return ()
|
adamc@26
|
330 else
|
adamc@26
|
331 S.Continue (e, ())} k () of
|
adamc@26
|
332 S.Return _ => true
|
adamc@26
|
333 | S.Continue _ => false
|
adamc@26
|
334
|
adamc@26
|
335 end
|
adamc@26
|
336
|
adamc@26
|
337 structure Decl = struct
|
adamc@26
|
338
|
adamc@26
|
339 datatype binder = datatype Exp.binder
|
adamc@26
|
340
|
adamc@26
|
341 fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
|
adamc@26
|
342 let
|
adamc@26
|
343 val mft = Typ.mapfold fc
|
adamc@26
|
344
|
adamc@26
|
345 val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind}
|
adamc@26
|
346
|
adamc@26
|
347 fun mfd ctx d acc =
|
adamc@26
|
348 S.bindP (mfd' ctx d acc, fd ctx)
|
adamc@26
|
349
|
adamc@26
|
350 and mfd' ctx (dAll as (d, loc)) =
|
adamc@26
|
351 case d of
|
adamc@164
|
352 DDatatype (x, n, xncs) =>
|
adamc@164
|
353 S.map2 (ListUtil.mapfold (fn (x, n, c) =>
|
adamc@164
|
354 case c of
|
adamc@164
|
355 NONE => S.return2 (x, n, c)
|
adamc@164
|
356 | SOME c =>
|
adamc@164
|
357 S.map2 (mft c,
|
adamc@164
|
358 fn c' => (x, n, SOME c'))) xncs,
|
adamc@164
|
359 fn xncs' =>
|
adamc@164
|
360 (DDatatype (x, n, xncs'), loc))
|
adamc@164
|
361 | DVal vi =>
|
adamc@126
|
362 S.map2 (mfvi ctx vi,
|
adamc@126
|
363 fn vi' =>
|
adamc@126
|
364 (DVal vi', loc))
|
adamc@126
|
365 | DValRec vis =>
|
adamc@196
|
366 let
|
adamc@196
|
367 val ctx' = foldl (fn ((x, n, t, _, s), ctx') => bind (ctx', NamedE (x, n, t, NONE, s))) ctx vis
|
adamc@196
|
368 in
|
adamc@196
|
369 S.map2 (ListUtil.mapfold (mfvi ctx') vis,
|
adamc@196
|
370 fn vis' =>
|
adamc@196
|
371 (DValRec vis', loc))
|
adamc@196
|
372 end
|
adamc@144
|
373 | DExport (ek, s, n, ts) =>
|
adamc@120
|
374 S.map2 (ListUtil.mapfold mft ts,
|
adamc@120
|
375 fn ts' =>
|
adamc@144
|
376 (DExport (ek, s, n, ts'), loc))
|
adamc@273
|
377 | DTable _ => S.return2 dAll
|
adamc@271
|
378 | DDatabase _ => S.return2 dAll
|
adamc@126
|
379
|
adamc@126
|
380 and mfvi ctx (x, n, t, e, s) =
|
adamc@126
|
381 S.bind2 (mft t,
|
adamc@126
|
382 fn t' =>
|
adamc@126
|
383 S.map2 (mfe ctx e,
|
adamc@126
|
384 fn e' =>
|
adamc@126
|
385 (x, n, t', e', s)))
|
adamc@26
|
386 in
|
adamc@26
|
387 mfd
|
adamc@26
|
388 end
|
adamc@26
|
389
|
adamc@26
|
390 fun mapfold {typ = fc, exp = fe, decl = fd} =
|
adamc@26
|
391 mapfoldB {typ = fc,
|
adamc@26
|
392 exp = fn () => fe,
|
adamc@26
|
393 decl = fn () => fd,
|
adamc@26
|
394 bind = fn ((), _) => ()} ()
|
adamc@26
|
395
|
adamc@26
|
396 fun fold {typ, exp, decl} s d =
|
adamc@26
|
397 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
|
adamc@26
|
398 exp = fn e => fn s => S.Continue (e, exp (e, s)),
|
adamc@26
|
399 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
|
adamc@26
|
400 S.Continue (_, s) => s
|
adamc@26
|
401 | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible"
|
adamc@26
|
402
|
adamc@26
|
403 end
|
adamc@26
|
404
|
adamc@26
|
405 structure File = struct
|
adamc@26
|
406
|
adamc@26
|
407 datatype binder = datatype Exp.binder
|
adamc@26
|
408
|
adamc@26
|
409 fun mapfoldB (all as {bind, ...}) =
|
adamc@26
|
410 let
|
adamc@26
|
411 val mfd = Decl.mapfoldB all
|
adamc@26
|
412
|
adamc@26
|
413 fun mff ctx ds =
|
adamc@26
|
414 case ds of
|
adamc@26
|
415 nil => S.return2 nil
|
adamc@26
|
416 | d :: ds' =>
|
adamc@26
|
417 S.bind2 (mfd ctx d,
|
adamc@26
|
418 fn d' =>
|
adamc@26
|
419 let
|
adamc@100
|
420 val ctx' =
|
adamc@26
|
421 case #1 d' of
|
adamc@164
|
422 DDatatype (x, n, xncs) =>
|
adamc@164
|
423 let
|
adamc@168
|
424 val ctx = bind (ctx, Datatype (x, n, xncs))
|
adamc@198
|
425 val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), #2 d')
|
adamc@164
|
426 in
|
adamc@164
|
427 foldl (fn ((x, n, to), ctx) =>
|
adamc@164
|
428 let
|
adamc@164
|
429 val t = case to of
|
adamc@164
|
430 NONE => t
|
adamc@164
|
431 | SOME t' => (TFun (t', t), #2 d')
|
adamc@164
|
432 in
|
adamc@164
|
433 bind (ctx, NamedE (x, n, t, NONE, ""))
|
adamc@164
|
434 end)
|
adamc@164
|
435 ctx xncs
|
adamc@164
|
436 end
|
adamc@164
|
437 | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
|
adamc@126
|
438 | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
|
adamc@196
|
439 bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
|
adamc@109
|
440 | DExport _ => ctx
|
adamc@273
|
441 | DTable _ => ctx
|
adamc@271
|
442 | DDatabase _ => ctx
|
adamc@26
|
443 in
|
adamc@26
|
444 S.map2 (mff ctx' ds',
|
adamc@26
|
445 fn ds' =>
|
adamc@26
|
446 d' :: ds')
|
adamc@26
|
447 end)
|
adamc@26
|
448 in
|
adamc@26
|
449 mff
|
adamc@26
|
450 end
|
adamc@26
|
451
|
adamc@26
|
452 fun mapfold {typ = fc, exp = fe, decl = fd} =
|
adamc@26
|
453 mapfoldB {typ = fc,
|
adamc@26
|
454 exp = fn () => fe,
|
adamc@26
|
455 decl = fn () => fd,
|
adamc@26
|
456 bind = fn ((), _) => ()} ()
|
adamc@26
|
457
|
adamc@26
|
458 fun mapB {typ, exp, decl, bind} ctx ds =
|
adamc@26
|
459 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
|
adamc@26
|
460 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
|
adamc@26
|
461 decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
|
adamc@26
|
462 bind = bind} ctx ds () of
|
adamc@26
|
463 S.Continue (ds, ()) => ds
|
adamc@26
|
464 | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible"
|
adamc@26
|
465
|
adamc@96
|
466 fun map {typ, exp, decl} e =
|
adamc@96
|
467 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
|
adamc@96
|
468 exp = fn e => fn () => S.Continue (exp e, ()),
|
adamc@96
|
469 decl = fn d => fn () => S.Continue (decl d, ())} e () of
|
adamc@96
|
470 S.Return () => raise Fail "Mono_util.File.map"
|
adamc@96
|
471 | S.Continue (e, ()) => e
|
adamc@96
|
472
|
adamc@26
|
473 fun fold {typ, exp, decl} s d =
|
adamc@26
|
474 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
|
adamc@26
|
475 exp = fn e => fn s => S.Continue (e, exp (e, s)),
|
adamc@26
|
476 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
|
adamc@26
|
477 S.Continue (_, s) => s
|
adamc@26
|
478 | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
|
adamc@26
|
479
|
adamc@26
|
480 end
|
adamc@26
|
481
|
adamc@26
|
482 end
|