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@51
|
148 | EFfi _ => S.return2 eAll
|
adamc@51
|
149 | EFfiApp (m, x, es) =>
|
adamc@51
|
150 S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es,
|
adamc@51
|
151 fn es' =>
|
adamc@51
|
152 (EFfiApp (m, x, es'), loc))
|
adamc@26
|
153 | EApp (e1, e2) =>
|
adamc@26
|
154 S.bind2 (mfe ctx e1,
|
adamc@26
|
155 fn e1' =>
|
adamc@26
|
156 S.map2 (mfe ctx e2,
|
adamc@26
|
157 fn e2' =>
|
adamc@26
|
158 (EApp (e1', e2'), loc)))
|
adamc@26
|
159 | EAbs (x, dom, ran, e) =>
|
adamc@26
|
160 S.bind2 (mft dom,
|
adamc@26
|
161 fn dom' =>
|
adamc@26
|
162 S.bind2 (mft ran,
|
adamc@26
|
163 fn ran' =>
|
adamc@26
|
164 S.map2 (mfe (bind (ctx, RelE (x, dom'))) e,
|
adamc@26
|
165 fn e' =>
|
adamc@26
|
166 (EAbs (x, dom', ran', e'), loc))))
|
adamc@26
|
167
|
adamc@26
|
168 | ERecord xes =>
|
adamc@29
|
169 S.map2 (ListUtil.mapfold (fn (x, e, t) =>
|
adamc@29
|
170 S.bind2 (mfe ctx e,
|
adamc@26
|
171 fn e' =>
|
adamc@29
|
172 S.map2 (mft t,
|
adamc@29
|
173 fn t' =>
|
adamc@29
|
174 (x, e', t'))))
|
adamc@26
|
175 xes,
|
adamc@26
|
176 fn xes' =>
|
adamc@26
|
177 (ERecord xes', loc))
|
adamc@26
|
178 | EField (e, x) =>
|
adamc@26
|
179 S.map2 (mfe ctx e,
|
adamc@26
|
180 fn e' =>
|
adamc@26
|
181 (EField (e', x), loc))
|
adamc@94
|
182
|
adamc@182
|
183 | ECase (e, pes, {disc, result}) =>
|
adamc@178
|
184 S.bind2 (mfe ctx e,
|
adamc@178
|
185 fn e' =>
|
adamc@178
|
186 S.bind2 (ListUtil.mapfold (fn (p, e) =>
|
adamc@179
|
187 let
|
adamc@179
|
188 fun pb ((p, _), ctx) =
|
adamc@179
|
189 case p of
|
adamc@179
|
190 PWild => ctx
|
adamc@182
|
191 | PVar (x, t) => bind (ctx, RelE (x, t))
|
adamc@179
|
192 | PPrim _ => ctx
|
adamc@188
|
193 | PCon (_, _, NONE) => ctx
|
adamc@188
|
194 | PCon (_, _, SOME p) => pb (p, ctx)
|
adamc@182
|
195 | PRecord xps => foldl (fn ((_, p, _), ctx) =>
|
adamc@179
|
196 pb (p, ctx)) ctx xps
|
adamc@288
|
197 | PNone _ => ctx
|
adamc@288
|
198 | PSome (_, p) => pb (p, ctx)
|
adamc@179
|
199 in
|
adamc@179
|
200 S.map2 (mfe (pb (p, ctx)) e,
|
adamc@179
|
201 fn e' => (p, e'))
|
adamc@179
|
202 end) pes,
|
adamc@178
|
203 fn pes' =>
|
adamc@182
|
204 S.bind2 (mft disc,
|
adamc@182
|
205 fn disc' =>
|
adamc@182
|
206 S.map2 (mft result,
|
adamc@182
|
207 fn result' =>
|
adamc@182
|
208 (ECase (e', pes', {disc = disc', result = result'}), loc)))))
|
adamc@178
|
209
|
adamc@283
|
210 | EError (e, t) =>
|
adamc@283
|
211 S.bind2 (mfe ctx e,
|
adamc@283
|
212 fn e' =>
|
adamc@283
|
213 S.map2 (mft t,
|
adamc@283
|
214 fn t' =>
|
adamc@283
|
215 (EError (e', t'), loc)))
|
adamc@283
|
216
|
adamc@94
|
217 | EStrcat (e1, e2) =>
|
adamc@94
|
218 S.bind2 (mfe ctx e1,
|
adamc@94
|
219 fn e1' =>
|
adamc@94
|
220 S.map2 (mfe ctx e2,
|
adamc@94
|
221 fn e2' =>
|
adamc@94
|
222 (EStrcat (e1', e2'), loc)))
|
adamc@102
|
223
|
adamc@102
|
224 | EWrite e =>
|
adamc@102
|
225 S.map2 (mfe ctx e,
|
adamc@102
|
226 fn e' =>
|
adamc@102
|
227 (EWrite e', loc))
|
adamc@106
|
228
|
adamc@106
|
229 | ESeq (e1, e2) =>
|
adamc@106
|
230 S.bind2 (mfe ctx e1,
|
adamc@106
|
231 fn e1' =>
|
adamc@106
|
232 S.map2 (mfe ctx e2,
|
adamc@106
|
233 fn e2' =>
|
adamc@106
|
234 (ESeq (e1', e2'), loc)))
|
adamc@251
|
235 | ELet (x, t, e1, e2) =>
|
adamc@251
|
236 S.bind2 (mft t,
|
adamc@251
|
237 fn t' =>
|
adamc@251
|
238 S.bind2 (mfe ctx e1,
|
adamc@251
|
239 fn e1' =>
|
adamc@252
|
240 S.map2 (mfe (bind (ctx, RelE (x, t'))) e2,
|
adamc@251
|
241 fn e2' =>
|
adamc@251
|
242 (ELet (x, t', e1', e2'), loc))))
|
adamc@111
|
243
|
adamc@111
|
244 | EClosure (n, es) =>
|
adamc@111
|
245 S.map2 (ListUtil.mapfold (mfe ctx) es,
|
adamc@111
|
246 fn es' =>
|
adamc@111
|
247 (EClosure (n, es'), loc))
|
adamc@252
|
248
|
adamc@252
|
249 | EQuery {exps, tables, state, query, body, initial} =>
|
adamc@252
|
250 S.bind2 (ListUtil.mapfold (fn (x, t) =>
|
adamc@252
|
251 S.map2 (mft t,
|
adamc@252
|
252 fn t' => (x, t'))) exps,
|
adamc@252
|
253 fn exps' =>
|
adamc@252
|
254 S.bind2 (ListUtil.mapfold (fn (x, xts) =>
|
adamc@252
|
255 S.map2 (ListUtil.mapfold
|
adamc@252
|
256 (fn (x, t) =>
|
adamc@252
|
257 S.map2 (mft t,
|
adamc@252
|
258 fn t' => (x, t'))) xts,
|
adamc@252
|
259 fn xts' => (x, xts'))) tables,
|
adamc@252
|
260 fn tables' =>
|
adamc@252
|
261 S.bind2 (mft state,
|
adamc@252
|
262 fn state' =>
|
adamc@252
|
263 S.bind2 (mfe ctx query,
|
adamc@252
|
264 fn query' =>
|
adamc@267
|
265 S.bind2 (mfe (bind (bind (ctx, RelE ("r", dummyt)),
|
adamc@267
|
266 RelE ("acc", dummyt)))
|
adamc@267
|
267 body,
|
adamc@267
|
268 fn body' =>
|
adamc@267
|
269 S.map2 (mfe ctx initial,
|
adamc@267
|
270 fn initial' =>
|
adamc@267
|
271 (EQuery {exps = exps',
|
adamc@267
|
272 tables = tables',
|
adamc@267
|
273 state = state',
|
adamc@267
|
274 query = query',
|
adamc@267
|
275 body = body',
|
adamc@267
|
276 initial = initial'},
|
adamc@267
|
277 loc)))))))
|
adamc@26
|
278 in
|
adamc@26
|
279 mfe
|
adamc@26
|
280 end
|
adamc@26
|
281
|
adamc@26
|
282 fun mapfold {typ = fc, exp = fe} =
|
adamc@26
|
283 mapfoldB {typ = fc,
|
adamc@26
|
284 exp = fn () => fe,
|
adamc@26
|
285 bind = fn ((), _) => ()} ()
|
adamc@26
|
286
|
adamc@26
|
287 fun mapB {typ, exp, bind} ctx e =
|
adamc@26
|
288 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
|
adamc@26
|
289 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
|
adamc@26
|
290 bind = bind} ctx e () of
|
adamc@26
|
291 S.Continue (e, ()) => e
|
adamc@26
|
292 | S.Return _ => raise Fail "MonoUtil.Exp.mapB: Impossible"
|
adamc@26
|
293
|
adamc@26
|
294 fun map {typ, exp} e =
|
adamc@26
|
295 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
|
adamc@26
|
296 exp = fn e => fn () => S.Continue (exp e, ())} e () of
|
adamc@26
|
297 S.Return () => raise Fail "Mono_util.Exp.map"
|
adamc@26
|
298 | S.Continue (e, ()) => e
|
adamc@26
|
299
|
adamc@26
|
300 fun fold {typ, exp} s e =
|
adamc@26
|
301 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
|
adamc@26
|
302 exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
|
adamc@26
|
303 S.Continue (_, s) => s
|
adamc@26
|
304 | S.Return _ => raise Fail "MonoUtil.Exp.fold: Impossible"
|
adamc@26
|
305
|
adamc@26
|
306 fun exists {typ, exp} k =
|
adamc@26
|
307 case mapfold {typ = fn c => fn () =>
|
adamc@26
|
308 if typ c then
|
adamc@26
|
309 S.Return ()
|
adamc@26
|
310 else
|
adamc@26
|
311 S.Continue (c, ()),
|
adamc@26
|
312 exp = fn e => fn () =>
|
adamc@26
|
313 if exp e then
|
adamc@26
|
314 S.Return ()
|
adamc@26
|
315 else
|
adamc@26
|
316 S.Continue (e, ())} k () of
|
adamc@26
|
317 S.Return _ => true
|
adamc@26
|
318 | S.Continue _ => false
|
adamc@26
|
319
|
adamc@26
|
320 end
|
adamc@26
|
321
|
adamc@26
|
322 structure Decl = struct
|
adamc@26
|
323
|
adamc@26
|
324 datatype binder = datatype Exp.binder
|
adamc@26
|
325
|
adamc@26
|
326 fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
|
adamc@26
|
327 let
|
adamc@26
|
328 val mft = Typ.mapfold fc
|
adamc@26
|
329
|
adamc@26
|
330 val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind}
|
adamc@26
|
331
|
adamc@26
|
332 fun mfd ctx d acc =
|
adamc@26
|
333 S.bindP (mfd' ctx d acc, fd ctx)
|
adamc@26
|
334
|
adamc@26
|
335 and mfd' ctx (dAll as (d, loc)) =
|
adamc@26
|
336 case d of
|
adamc@164
|
337 DDatatype (x, n, xncs) =>
|
adamc@164
|
338 S.map2 (ListUtil.mapfold (fn (x, n, c) =>
|
adamc@164
|
339 case c of
|
adamc@164
|
340 NONE => S.return2 (x, n, c)
|
adamc@164
|
341 | SOME c =>
|
adamc@164
|
342 S.map2 (mft c,
|
adamc@164
|
343 fn c' => (x, n, SOME c'))) xncs,
|
adamc@164
|
344 fn xncs' =>
|
adamc@164
|
345 (DDatatype (x, n, xncs'), loc))
|
adamc@164
|
346 | DVal vi =>
|
adamc@126
|
347 S.map2 (mfvi ctx vi,
|
adamc@126
|
348 fn vi' =>
|
adamc@126
|
349 (DVal vi', loc))
|
adamc@126
|
350 | DValRec vis =>
|
adamc@196
|
351 let
|
adamc@196
|
352 val ctx' = foldl (fn ((x, n, t, _, s), ctx') => bind (ctx', NamedE (x, n, t, NONE, s))) ctx vis
|
adamc@196
|
353 in
|
adamc@196
|
354 S.map2 (ListUtil.mapfold (mfvi ctx') vis,
|
adamc@196
|
355 fn vis' =>
|
adamc@196
|
356 (DValRec vis', loc))
|
adamc@196
|
357 end
|
adamc@144
|
358 | DExport (ek, s, n, ts) =>
|
adamc@120
|
359 S.map2 (ListUtil.mapfold mft ts,
|
adamc@120
|
360 fn ts' =>
|
adamc@144
|
361 (DExport (ek, s, n, ts'), loc))
|
adamc@273
|
362 | DTable _ => S.return2 dAll
|
adamc@271
|
363 | DDatabase _ => S.return2 dAll
|
adamc@126
|
364
|
adamc@126
|
365 and mfvi ctx (x, n, t, e, s) =
|
adamc@126
|
366 S.bind2 (mft t,
|
adamc@126
|
367 fn t' =>
|
adamc@126
|
368 S.map2 (mfe ctx e,
|
adamc@126
|
369 fn e' =>
|
adamc@126
|
370 (x, n, t', e', s)))
|
adamc@26
|
371 in
|
adamc@26
|
372 mfd
|
adamc@26
|
373 end
|
adamc@26
|
374
|
adamc@26
|
375 fun mapfold {typ = fc, exp = fe, decl = fd} =
|
adamc@26
|
376 mapfoldB {typ = fc,
|
adamc@26
|
377 exp = fn () => fe,
|
adamc@26
|
378 decl = fn () => fd,
|
adamc@26
|
379 bind = fn ((), _) => ()} ()
|
adamc@26
|
380
|
adamc@26
|
381 fun fold {typ, exp, decl} s d =
|
adamc@26
|
382 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
|
adamc@26
|
383 exp = fn e => fn s => S.Continue (e, exp (e, s)),
|
adamc@26
|
384 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
|
adamc@26
|
385 S.Continue (_, s) => s
|
adamc@26
|
386 | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible"
|
adamc@26
|
387
|
adamc@26
|
388 end
|
adamc@26
|
389
|
adamc@26
|
390 structure File = struct
|
adamc@26
|
391
|
adamc@26
|
392 datatype binder = datatype Exp.binder
|
adamc@26
|
393
|
adamc@26
|
394 fun mapfoldB (all as {bind, ...}) =
|
adamc@26
|
395 let
|
adamc@26
|
396 val mfd = Decl.mapfoldB all
|
adamc@26
|
397
|
adamc@26
|
398 fun mff ctx ds =
|
adamc@26
|
399 case ds of
|
adamc@26
|
400 nil => S.return2 nil
|
adamc@26
|
401 | d :: ds' =>
|
adamc@26
|
402 S.bind2 (mfd ctx d,
|
adamc@26
|
403 fn d' =>
|
adamc@26
|
404 let
|
adamc@100
|
405 val ctx' =
|
adamc@26
|
406 case #1 d' of
|
adamc@164
|
407 DDatatype (x, n, xncs) =>
|
adamc@164
|
408 let
|
adamc@168
|
409 val ctx = bind (ctx, Datatype (x, n, xncs))
|
adamc@198
|
410 val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), #2 d')
|
adamc@164
|
411 in
|
adamc@164
|
412 foldl (fn ((x, n, to), ctx) =>
|
adamc@164
|
413 let
|
adamc@164
|
414 val t = case to of
|
adamc@164
|
415 NONE => t
|
adamc@164
|
416 | SOME t' => (TFun (t', t), #2 d')
|
adamc@164
|
417 in
|
adamc@164
|
418 bind (ctx, NamedE (x, n, t, NONE, ""))
|
adamc@164
|
419 end)
|
adamc@164
|
420 ctx xncs
|
adamc@164
|
421 end
|
adamc@164
|
422 | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
|
adamc@126
|
423 | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
|
adamc@196
|
424 bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis
|
adamc@109
|
425 | DExport _ => ctx
|
adamc@273
|
426 | DTable _ => ctx
|
adamc@271
|
427 | DDatabase _ => ctx
|
adamc@26
|
428 in
|
adamc@26
|
429 S.map2 (mff ctx' ds',
|
adamc@26
|
430 fn ds' =>
|
adamc@26
|
431 d' :: ds')
|
adamc@26
|
432 end)
|
adamc@26
|
433 in
|
adamc@26
|
434 mff
|
adamc@26
|
435 end
|
adamc@26
|
436
|
adamc@26
|
437 fun mapfold {typ = fc, exp = fe, decl = fd} =
|
adamc@26
|
438 mapfoldB {typ = fc,
|
adamc@26
|
439 exp = fn () => fe,
|
adamc@26
|
440 decl = fn () => fd,
|
adamc@26
|
441 bind = fn ((), _) => ()} ()
|
adamc@26
|
442
|
adamc@26
|
443 fun mapB {typ, exp, decl, bind} ctx ds =
|
adamc@26
|
444 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
|
adamc@26
|
445 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
|
adamc@26
|
446 decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
|
adamc@26
|
447 bind = bind} ctx ds () of
|
adamc@26
|
448 S.Continue (ds, ()) => ds
|
adamc@26
|
449 | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible"
|
adamc@26
|
450
|
adamc@96
|
451 fun map {typ, exp, decl} e =
|
adamc@96
|
452 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
|
adamc@96
|
453 exp = fn e => fn () => S.Continue (exp e, ()),
|
adamc@96
|
454 decl = fn d => fn () => S.Continue (decl d, ())} e () of
|
adamc@96
|
455 S.Return () => raise Fail "Mono_util.File.map"
|
adamc@96
|
456 | S.Continue (e, ()) => e
|
adamc@96
|
457
|
adamc@26
|
458 fun fold {typ, exp, decl} s d =
|
adamc@26
|
459 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
|
adamc@26
|
460 exp = fn e => fn s => S.Continue (e, exp (e, s)),
|
adamc@26
|
461 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
|
adamc@26
|
462 S.Continue (_, s) => s
|
adamc@26
|
463 | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
|
adamc@26
|
464
|
adamc@26
|
465 end
|
adamc@26
|
466
|
adamc@26
|
467 end
|