adamc@607
|
1 (* Copyright (c) 2009, Adam Chlipala
|
adamc@607
|
2 * All rights reserved.
|
adamc@607
|
3 *
|
adamc@607
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@607
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@607
|
6 *
|
adamc@607
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@607
|
8 * this list of conditions and the following disclaimer.
|
adamc@607
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@607
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@607
|
11 * and/or other materials provided with the distribution.
|
adamc@607
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@607
|
13 * derived from this software without specific prior written permission.
|
adamc@607
|
14 *
|
adamc@607
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@607
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@607
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@607
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@607
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@607
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@607
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@607
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@607
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@607
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@607
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@607
|
26 *)
|
adamc@607
|
27
|
adamc@607
|
28 structure Rpcify :> RPCIFY = struct
|
adamc@607
|
29
|
adamc@607
|
30 open Core
|
adamc@607
|
31
|
adamc@607
|
32 structure U = CoreUtil
|
adamc@607
|
33 structure E = CoreEnv
|
adamc@607
|
34
|
adamc@607
|
35 structure IS = IntBinarySet
|
adamc@607
|
36 structure IM = IntBinaryMap
|
adamc@607
|
37
|
adamc@607
|
38 structure SS = BinarySetFn(struct
|
adamc@607
|
39 type ord_key = string
|
adamc@607
|
40 val compare = String.compare
|
adamc@607
|
41 end)
|
adamc@607
|
42
|
adamc@642
|
43 fun multiLiftExpInExp n e =
|
adamc@642
|
44 if n = 0 then
|
adamc@642
|
45 e
|
adamc@642
|
46 else
|
adamc@642
|
47 multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
|
adamc@642
|
48
|
adamc@607
|
49 val ssBasis = SS.addList (SS.empty,
|
adamc@607
|
50 ["requestHeader",
|
adamc@607
|
51 "query",
|
adamc@607
|
52 "dml",
|
adamc@668
|
53 "nextval",
|
adamc@679
|
54 "channel",
|
adamc@668
|
55 "subscribe",
|
adamc@668
|
56 "send"])
|
adamc@607
|
57
|
adamc@607
|
58 val csBasis = SS.addList (SS.empty,
|
adamc@679
|
59 ["get",
|
adamc@607
|
60 "set",
|
adamc@670
|
61 "alert",
|
adamc@670
|
62 "recv"])
|
adamc@607
|
63
|
adamc@607
|
64 type state = {
|
adamc@608
|
65 cpsed : int IM.map,
|
adamc@642
|
66 cpsed_range : con IM.map,
|
adamc@608
|
67 cps_decls : (string * int * con * exp * string) list,
|
adamc@608
|
68
|
adamc@608
|
69 exported : IS.set,
|
adamc@642
|
70 export_decls : decl list,
|
adamc@642
|
71
|
adamc@642
|
72 maxName : int
|
adamc@607
|
73 }
|
adamc@607
|
74
|
adamc@607
|
75 fun frob file =
|
adamc@607
|
76 let
|
adamc@650
|
77 fun sideish (basis, ssids) e =
|
adamc@679
|
78 U.Exp.exists {kind = fn _ => false,
|
adamc@679
|
79 con = fn _ => false,
|
adamc@679
|
80 exp = fn ENamed n => IS.member (ssids, n)
|
adamc@679
|
81 | EFfi ("Basis", x) => SS.member (basis, x)
|
adamc@679
|
82 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
|
adamc@679
|
83 | _ => false}
|
adamc@679
|
84 (U.Exp.map {kind = fn x => x,
|
adamc@679
|
85 con = fn x => x,
|
adamc@679
|
86 exp = fn ERecord _ => ERecord []
|
adamc@679
|
87 | x => x} e)
|
adamc@607
|
88
|
adamc@607
|
89 fun whichIds basis =
|
adamc@607
|
90 let
|
adamc@607
|
91 fun decl ((d, _), ssids) =
|
adamc@607
|
92 let
|
adamc@607
|
93 val impure = sideish (basis, ssids)
|
adamc@607
|
94 in
|
adamc@607
|
95 case d of
|
adamc@607
|
96 DVal (_, n, _, e, _) => if impure e then
|
adamc@607
|
97 IS.add (ssids, n)
|
adamc@607
|
98 else
|
adamc@607
|
99 ssids
|
adamc@607
|
100 | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then
|
adamc@607
|
101 foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n))
|
adamc@607
|
102 ssids xes
|
adamc@607
|
103 else
|
adamc@607
|
104 ssids
|
adamc@607
|
105 | _ => ssids
|
adamc@607
|
106 end
|
adamc@607
|
107 in
|
adamc@607
|
108 foldl decl IS.empty file
|
adamc@607
|
109 end
|
adamc@607
|
110
|
adamc@607
|
111 val ssids = whichIds ssBasis
|
adamc@607
|
112 val csids = whichIds csBasis
|
adamc@607
|
113
|
adamc@642
|
114 fun sideish' (basis, ids) extra =
|
adamc@642
|
115 sideish (basis, IM.foldli (fn (id, _, ids) => IS.add (ids, id)) ids extra)
|
adamc@642
|
116
|
adamc@642
|
117 val serverSide = sideish' (ssBasis, ssids)
|
adamc@642
|
118 val clientSide = sideish' (csBasis, csids)
|
adamc@607
|
119
|
adamc@609
|
120 val tfuncs = foldl
|
adamc@609
|
121 (fn ((d, _), tfuncs) =>
|
adamc@609
|
122 let
|
adamc@642
|
123 fun doOne ((x, n, t, e, _), tfuncs) =
|
adamc@609
|
124 let
|
adamc@642
|
125 val loc = #2 e
|
adamc@642
|
126
|
adamc@642
|
127 fun crawl (t, e, args) =
|
adamc@642
|
128 case (#1 t, #1 e) of
|
adamc@642
|
129 (CApp (_, ran), _) =>
|
adamc@642
|
130 SOME (x, rev args, ran, e)
|
adamc@642
|
131 | (TFun (arg, rest), EAbs (x, _, _, e)) =>
|
adamc@642
|
132 crawl (rest, e, (x, arg) :: args)
|
adamc@642
|
133 | (TFun (arg, rest), _) =>
|
adamc@642
|
134 crawl (rest, (EApp (e, (ERel (length args), loc)), loc), ("x", arg) :: args)
|
adamc@609
|
135 | _ => NONE
|
adamc@609
|
136 in
|
adamc@642
|
137 case crawl (t, e, []) of
|
adamc@609
|
138 NONE => tfuncs
|
adamc@609
|
139 | SOME sg => IM.insert (tfuncs, n, sg)
|
adamc@609
|
140 end
|
adamc@609
|
141 in
|
adamc@609
|
142 case d of
|
adamc@609
|
143 DVal vi => doOne (vi, tfuncs)
|
adamc@609
|
144 | DValRec vis => foldl doOne tfuncs vis
|
adamc@609
|
145 | _ => tfuncs
|
adamc@609
|
146 end)
|
adamc@609
|
147 IM.empty file
|
adamc@609
|
148
|
adamc@607
|
149 fun exp (e, st) =
|
adamc@649
|
150 let
|
adamc@649
|
151 fun getApp (e', args) =
|
adamc@649
|
152 let
|
adamc@649
|
153 val loc = #2 e'
|
adamc@649
|
154 in
|
adamc@642
|
155 case #1 e' of
|
adamc@642
|
156 ENamed n => (n, args)
|
adamc@642
|
157 | EApp (e1, e2) => getApp (e1, e2 :: args)
|
adamc@642
|
158 | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part";
|
adamc@679
|
159 (*Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*)
|
adamc@642
|
160 (0, []))
|
adamc@649
|
161 end
|
adamc@642
|
162
|
adamc@649
|
163 fun newRpc (trans1, trans2, st : state) =
|
adamc@649
|
164 let
|
adamc@649
|
165 val loc = #2 trans1
|
adamc@642
|
166
|
adamc@649
|
167 val (n, args) = getApp (trans1, [])
|
adamc@642
|
168
|
adamc@649
|
169 val (exported, export_decls) =
|
adamc@649
|
170 if IS.member (#exported st, n) then
|
adamc@649
|
171 (#exported st, #export_decls st)
|
adamc@649
|
172 else
|
adamc@649
|
173 (IS.add (#exported st, n),
|
adamc@649
|
174 (DExport (Rpc, n), loc) :: #export_decls st)
|
adamc@642
|
175
|
adamc@649
|
176 val st = {cpsed = #cpsed st,
|
adamc@649
|
177 cpsed_range = #cpsed_range st,
|
adamc@649
|
178 cps_decls = #cps_decls st,
|
adamc@642
|
179
|
adamc@649
|
180 exported = exported,
|
adamc@649
|
181 export_decls = export_decls,
|
adamc@642
|
182
|
adamc@649
|
183 maxName = #maxName st}
|
adamc@642
|
184
|
adamc@649
|
185 val ran =
|
adamc@649
|
186 case IM.find (tfuncs, n) of
|
adamc@679
|
187 NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*)
|
adamc@649
|
188 raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
|
adamc@649
|
189 | SOME (_, _, ran, _) => ran
|
adamc@649
|
190
|
adamc@649
|
191 val e' = EServerCall (n, args, trans2, ran)
|
adamc@649
|
192 in
|
adamc@649
|
193 (e', st)
|
adamc@649
|
194 end
|
adamc@651
|
195
|
adamc@651
|
196 fun newCps (t1, t2, trans1, trans2, st) =
|
adamc@651
|
197 let
|
adamc@651
|
198 val loc = #2 trans1
|
adamc@651
|
199
|
adamc@651
|
200 val (n, args) = getApp (trans1, [])
|
adamc@651
|
201
|
adamc@651
|
202 fun makeCall n' =
|
adamc@651
|
203 let
|
adamc@651
|
204 val e = (ENamed n', loc)
|
adamc@651
|
205 val e = (EApp (e, trans2), loc)
|
adamc@651
|
206 in
|
adamc@651
|
207 #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args)
|
adamc@651
|
208 end
|
adamc@651
|
209 in
|
adamc@651
|
210 case IM.find (#cpsed_range st, n) of
|
adamc@651
|
211 SOME kdom =>
|
adamc@651
|
212 (case args of
|
adamc@651
|
213 [] => raise Fail "Rpcify: cps'd function lacks first argument"
|
adamc@651
|
214 | ke :: args =>
|
adamc@651
|
215 let
|
adamc@651
|
216 val ke' = (EFfi ("Basis", "bind"), loc)
|
adamc@651
|
217 val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@651
|
218 val ke' = (ECApp (ke', kdom), loc)
|
adamc@651
|
219 val ke' = (ECApp (ke', t2), loc)
|
adamc@651
|
220 val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@651
|
221 val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
|
adamc@651
|
222 val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc)
|
adamc@651
|
223 val ke' = (EAbs ("x", kdom,
|
adamc@651
|
224 (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc),
|
adamc@651
|
225 ke'), loc)
|
adamc@651
|
226
|
adamc@651
|
227 val e' = (ENamed n, loc)
|
adamc@651
|
228 val e' = (EApp (e', ke'), loc)
|
adamc@651
|
229 val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args
|
adamc@651
|
230 val (e', st) = doExp (e', st)
|
adamc@651
|
231 in
|
adamc@651
|
232 (#1 e', st)
|
adamc@651
|
233 end)
|
adamc@651
|
234 | NONE =>
|
adamc@651
|
235 case IM.find (#cpsed st, n) of
|
adamc@651
|
236 SOME n' => (makeCall n', st)
|
adamc@651
|
237 | NONE =>
|
adamc@651
|
238 let
|
adamc@651
|
239 val (name, fargs, ran, e) =
|
adamc@651
|
240 case IM.find (tfuncs, n) of
|
adamc@651
|
241 NONE => (Print.prefaces "BAD" [("e",
|
adamc@651
|
242 CorePrint.p_exp CoreEnv.empty (e, loc))];
|
adamc@651
|
243 raise Fail "Rpcify: Undetected transaction function [2]")
|
adamc@651
|
244 | SOME x => x
|
adamc@651
|
245
|
adamc@651
|
246 val n' = #maxName st
|
adamc@651
|
247
|
adamc@651
|
248 val st = {cpsed = IM.insert (#cpsed st, n, n'),
|
adamc@651
|
249 cpsed_range = IM.insert (#cpsed_range st, n', ran),
|
adamc@651
|
250 cps_decls = #cps_decls st,
|
adamc@651
|
251 exported = #exported st,
|
adamc@651
|
252 export_decls = #export_decls st,
|
adamc@651
|
253 maxName = n' + 1}
|
adamc@651
|
254
|
adamc@651
|
255 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
|
adamc@651
|
256 val body = (EFfi ("Basis", "bind"), loc)
|
adamc@651
|
257 val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@651
|
258 val body = (ECApp (body, t1), loc)
|
adamc@651
|
259 val body = (ECApp (body, unit), loc)
|
adamc@651
|
260 val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@651
|
261 val body = (EApp (body, e), loc)
|
adamc@651
|
262 val body = (EApp (body, (ERel (length args), loc)), loc)
|
adamc@651
|
263 val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc)
|
adamc@651
|
264 val (body, bt) = foldr (fn ((x, t), (body, bt)) =>
|
adamc@651
|
265 ((EAbs (x, t, bt, body), loc),
|
adamc@651
|
266 (TFun (t, bt), loc)))
|
adamc@651
|
267 (body, bt) fargs
|
adamc@651
|
268 val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc),
|
adamc@651
|
269 unit),
|
adamc@651
|
270 loc)), loc)
|
adamc@651
|
271 val body = (EAbs ("k", kt, bt, body), loc)
|
adamc@651
|
272 val bt = (TFun (kt, bt), loc)
|
adamc@651
|
273
|
adamc@651
|
274 val (body, st) = doExp (body, st)
|
adamc@651
|
275
|
adamc@651
|
276 val vi = (name ^ "_cps",
|
adamc@651
|
277 n',
|
adamc@651
|
278 bt,
|
adamc@651
|
279 body,
|
adamc@651
|
280 "")
|
adamc@651
|
281
|
adamc@651
|
282 val st = {cpsed = #cpsed st,
|
adamc@651
|
283 cpsed_range = #cpsed_range st,
|
adamc@651
|
284 cps_decls = vi :: #cps_decls st,
|
adamc@651
|
285 exported = #exported st,
|
adamc@651
|
286 export_decls = #export_decls st,
|
adamc@651
|
287 maxName = #maxName st}
|
adamc@651
|
288 in
|
adamc@651
|
289 (makeCall n', st)
|
adamc@651
|
290 end
|
adamc@651
|
291 end
|
adamc@651
|
292
|
adamc@651
|
293 fun dummyK loc =
|
adamc@651
|
294 let
|
adamc@651
|
295 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
|
adamc@651
|
296
|
adamc@651
|
297 val k = (EFfi ("Basis", "return"), loc)
|
adamc@651
|
298 val k = (ECApp (k, (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@651
|
299 val k = (ECApp (k, unit), loc)
|
adamc@651
|
300 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@651
|
301 val k = (EApp (k, (ERecord [], loc)), loc)
|
adamc@651
|
302 in
|
adamc@651
|
303 (EAbs ("_", unit, unit, k), loc)
|
adamc@651
|
304 end
|
adamc@649
|
305 in
|
adamc@649
|
306 case e of
|
adamc@649
|
307 EApp (
|
adamc@649
|
308 (EApp
|
adamc@649
|
309 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
|
adamc@649
|
310 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
311 (ECase (ed, pes, {disc, ...}), _)), _),
|
adamc@649
|
312 trans2) =>
|
adamc@649
|
313 let
|
adamc@649
|
314 val e' = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
315 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
316 val e' = (ECApp (e', t1), loc)
|
adamc@649
|
317 val e' = (ECApp (e', t2), loc)
|
adamc@649
|
318 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
319
|
adamc@649
|
320 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
|
adamc@649
|
321 let
|
adamc@649
|
322 val e' = (EApp (e', e), loc)
|
adamc@649
|
323 val e' = (EApp (e',
|
adamc@649
|
324 multiLiftExpInExp (E.patBindsN p)
|
adamc@649
|
325 trans2), loc)
|
adamc@649
|
326 val (e', st) = doExp (e', st)
|
adamc@649
|
327 in
|
adamc@649
|
328 ((p, e'), st)
|
adamc@649
|
329 end) st pes
|
adamc@649
|
330 in
|
adamc@649
|
331 (ECase (ed, pes, {disc = disc,
|
adamc@649
|
332 result = (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc)}),
|
adamc@649
|
333 st)
|
adamc@649
|
334 end
|
adamc@649
|
335
|
adamc@649
|
336 | EApp (
|
adamc@649
|
337 (EApp
|
adamc@649
|
338 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
|
adamc@649
|
339 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
340 (EServerCall (n, es, ke, t), _)), _),
|
adamc@649
|
341 trans2) =>
|
adamc@649
|
342 let
|
adamc@649
|
343 val e' = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
344 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
345 val e' = (ECApp (e', t), loc)
|
adamc@649
|
346 val e' = (ECApp (e', t2), loc)
|
adamc@649
|
347 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
348 val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
|
adamc@649
|
349 val e' = (EApp (e', E.liftExpInExp 0 trans2), loc)
|
adamc@649
|
350 val e' = (EAbs ("x", t, t2, e'), loc)
|
adamc@649
|
351 val e' = (EServerCall (n, es, e', t), loc)
|
adamc@649
|
352 val (e', st) = doExp (e', st)
|
adamc@649
|
353 in
|
adamc@649
|
354 (#1 e', st)
|
adamc@649
|
355 end
|
adamc@649
|
356
|
adamc@649
|
357 | EApp (
|
adamc@649
|
358 (EApp
|
adamc@649
|
359 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _),
|
adamc@649
|
360 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
361 (EApp ((EApp
|
adamc@649
|
362 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
|
adamc@649
|
363 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
364 trans1), _), trans2), _)), _),
|
adamc@649
|
365 trans3) =>
|
adamc@649
|
366 let
|
adamc@649
|
367 val e'' = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
368 val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
369 val e'' = (ECApp (e'', t2), loc)
|
adamc@649
|
370 val e'' = (ECApp (e'', t3), loc)
|
adamc@649
|
371 val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
372 val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
|
adamc@649
|
373 val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
|
adamc@649
|
374 val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc)
|
adamc@649
|
375
|
adamc@649
|
376 val e' = (EFfi ("Basis", "bind"), loc)
|
adamc@649
|
377 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@649
|
378 val e' = (ECApp (e', t1), loc)
|
adamc@649
|
379 val e' = (ECApp (e', t3), loc)
|
adamc@649
|
380 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@649
|
381 val e' = (EApp (e', trans1), loc)
|
adamc@649
|
382 val e' = (EApp (e', e''), loc)
|
adamc@649
|
383 val (e', st) = doExp (e', st)
|
adamc@649
|
384 in
|
adamc@649
|
385 (#1 e', st)
|
adamc@649
|
386 end
|
adamc@649
|
387
|
adamc@649
|
388 | EApp (
|
adamc@649
|
389 (EApp
|
adamc@649
|
390 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), _), _), _), _),
|
adamc@649
|
391 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
392 _), loc),
|
adamc@649
|
393 (EAbs (_, _, _, (EWrite _, _)), _)) => (e, st)
|
adamc@649
|
394
|
adamc@649
|
395 | EApp (
|
adamc@649
|
396 (EApp
|
adamc@649
|
397 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
|
adamc@649
|
398 (EFfi ("Basis", "transaction_monad"), _)), _),
|
adamc@649
|
399 trans1), loc),
|
adamc@649
|
400 trans2) =>
|
adamc@649
|
401 (case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1,
|
adamc@649
|
402 serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of
|
adamc@649
|
403 (true, false, _, true) => newRpc (trans1, trans2, st)
|
adamc@651
|
404 | (_, true, true, false) =>
|
adamc@651
|
405 (case #1 trans2 of
|
adamc@651
|
406 EAbs (x, dom, ran, trans2) =>
|
adamc@651
|
407 let
|
adamc@651
|
408 val (trans2, st) = newRpc (trans2, dummyK loc, st)
|
adamc@651
|
409 val trans2 = (EAbs (x, dom, ran, (trans2, loc)), loc)
|
adamc@649
|
410
|
adamc@651
|
411 val e = (EFfi ("Basis", "bind"), loc)
|
adamc@651
|
412 val e = (ECApp (e, (CFfi ("Basis", "transaction"), loc)), loc)
|
adamc@651
|
413 val e = (ECApp (e, t1), loc)
|
adamc@651
|
414 val e = (ECApp (e, t2), loc)
|
adamc@651
|
415 val e = (EApp (e, (EFfi ("Basis", "transaction_monad"), loc)), loc)
|
adamc@651
|
416 val e = (EApp (e, trans1), loc)
|
adamc@651
|
417 val e = EApp (e, trans2)
|
adamc@651
|
418 in
|
adamc@651
|
419 (e, st)
|
adamc@651
|
420 end
|
adamc@651
|
421 | _ => (e, st))
|
adamc@651
|
422 | (true, true, _, _) => newCps (t1, t2, trans1, trans2, st)
|
adamc@649
|
423
|
adamc@649
|
424 | _ => (e, st))
|
adamc@642
|
425
|
adamc@649
|
426 | ERecord xes =>
|
adamc@649
|
427 let
|
adamc@649
|
428 val loc = case xes of
|
adamc@649
|
429 [] => ErrorMsg.dummySpan
|
adamc@649
|
430 | (_, (_, loc), _) :: _ => loc
|
adamc@642
|
431
|
adamc@649
|
432 fun candidate (x, e) =
|
adamc@649
|
433 String.isPrefix "On" x
|
adamc@649
|
434 andalso serverSide (#cpsed_range st) e
|
adamc@649
|
435 andalso not (clientSide (#cpsed_range st) e)
|
adamc@649
|
436 in
|
adamc@649
|
437 if List.exists (fn ((CName x, _), e, _) => candidate (x, e)
|
adamc@649
|
438 | _ => false) xes then
|
adamc@649
|
439 let
|
adamc@649
|
440 val (xes, st) = ListUtil.foldlMap
|
adamc@649
|
441 (fn (y as (nm as (CName x, _), e, t), st) =>
|
adamc@649
|
442 if candidate (x, e) then
|
adamc@649
|
443 let
|
adamc@651
|
444 val (e, st) = newRpc (e, dummyK loc, st)
|
adamc@649
|
445 in
|
adamc@649
|
446 ((nm, (e, loc), t), st)
|
adamc@649
|
447 end
|
adamc@649
|
448 else
|
adamc@649
|
449 (y, st)
|
adamc@649
|
450 | y => y)
|
adamc@649
|
451 st xes
|
adamc@649
|
452 in
|
adamc@649
|
453 (ERecord xes, st)
|
adamc@649
|
454 end
|
adamc@649
|
455 else
|
adamc@649
|
456 (e, st)
|
adamc@649
|
457 end
|
adamc@642
|
458
|
adamc@649
|
459 | _ => (e, st)
|
adamc@649
|
460 end
|
adamc@607
|
461
|
adamc@642
|
462 and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
|
adamc@642
|
463 con = fn x => x,
|
adamc@642
|
464 exp = exp} st (ReduceLocal.reduceExp e)
|
adamc@642
|
465
|
adamc@607
|
466 fun decl (d, st : state) =
|
adamc@607
|
467 let
|
adamc@607
|
468 val (d, st) = U.Decl.foldMap {kind = fn x => x,
|
adamc@607
|
469 con = fn x => x,
|
adamc@607
|
470 exp = exp,
|
adamc@607
|
471 decl = fn x => x}
|
adamc@607
|
472 st d
|
adamc@607
|
473 in
|
adamc@608
|
474 (List.revAppend (case #cps_decls st of
|
adamc@608
|
475 [] => [d]
|
adamc@608
|
476 | ds =>
|
adamc@608
|
477 case d of
|
adamc@608
|
478 (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
|
adamc@608
|
479 | (_, loc) => [d, (DValRec ds, loc)],
|
adamc@608
|
480 #export_decls st),
|
adamc@608
|
481 {cpsed = #cpsed st,
|
adamc@642
|
482 cpsed_range = #cpsed_range st,
|
adamc@608
|
483 cps_decls = [],
|
adamc@608
|
484
|
adamc@608
|
485 exported = #exported st,
|
adamc@642
|
486 export_decls = [],
|
adamc@642
|
487
|
adamc@642
|
488 maxName = #maxName st})
|
adamc@607
|
489 end
|
adamc@607
|
490
|
adamc@607
|
491 val (file, _) = ListUtil.foldlMapConcat decl
|
adamc@608
|
492 {cpsed = IM.empty,
|
adamc@642
|
493 cpsed_range = IM.empty,
|
adamc@608
|
494 cps_decls = [],
|
adamc@608
|
495
|
adamc@608
|
496 exported = IS.empty,
|
adamc@642
|
497 export_decls = [],
|
adamc@642
|
498
|
adamc@642
|
499 maxName = U.File.maxName file + 1}
|
adamc@607
|
500 file
|
adamc@607
|
501 in
|
adamc@607
|
502 file
|
adamc@607
|
503 end
|
adamc@607
|
504
|
adamc@607
|
505 end
|