Mercurial > urweb

comparison src/rpcify.sml @ 607:0dd40b6bfdf3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start of RPCification
author Adam Chlipala <adamc@hcoop.net>
date Sat, 14 Feb 2009 14:07:56 -0500
parents
children 330a7de47914
comparison
equal deleted inserted replaced
606:5145181b02fa 607:0dd40b6bfdf3
1 (* Copyright (c) 2009, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 structure Rpcify :> RPCIFY = struct
29
30 open Core
31
32 structure U = CoreUtil
33 structure E = CoreEnv
34
35 structure IS = IntBinarySet
36 structure IM = IntBinaryMap
37
38 structure SS = BinarySetFn(struct
39 type ord_key = string
40 val compare = String.compare
41 end)
42
43 val ssBasis = SS.addList (SS.empty,
44 ["requestHeader",
45 "query",
46 "dml",
47 "nextval"])
48
49 val csBasis = SS.addList (SS.empty,
50 ["source",
51 "get",
52 "set",
53 "alert"])
54
55 type state = {
56 exps : int IM.map,
57 decls : (string * int * con * exp * string) list
58 }
59
60 fun frob file =
61 let
62 fun sideish (basis, ssids) =
63 U.Exp.exists {kind = fn _ => false,
64 con = fn _ => false,
65 exp = fn ENamed n => IS.member (ssids, n)
66 | EFfi ("Basis", x) => SS.member (basis, x)
67 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
68 | _ => false}
69
70 fun whichIds basis =
71 let
72 fun decl ((d, _), ssids) =
73 let
74 val impure = sideish (basis, ssids)
75 in
76 case d of
77 DVal (_, n, _, e, _) => if impure e then
78 IS.add (ssids, n)
79 else
80 ssids
81 | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then
82 foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n))
83 ssids xes
84 else
85 ssids
86 | _ => ssids
87 end
88 in
89 foldl decl IS.empty file
90 end
91
92 val ssids = whichIds ssBasis
93 val csids = whichIds csBasis
94
95 val serverSide = sideish (ssBasis, ssids)
96 val clientSide = sideish (csBasis, csids)
97
98 fun exp (e, st) =
99 case e of
100 EApp (
101 (EApp
102 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
103 (EFfi ("Basis", "transaction_monad"), _)), _),
104 trans1), _),
105 trans2) =>
106 (case (serverSide trans1, clientSide trans1, serverSide trans2, clientSide trans2) of
107 (true, false, false, _) =>
108 let
109 fun getApp (e, args) =
110 case #1 e of
111 ENamed n => (n, args)
112 | EApp (e1, e2) => getApp (e1, e2 :: args)
113 | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part";
114 (0, []))
115
116 val (n, args) = getApp (trans1, [])
117 in
118 (EServerCall (n, args, trans2), st)
119 end
120 | _ => (e, st))
121 | _ => (e, st)
122
123 fun decl (d, st : state) =
124 let
125 val (d, st) = U.Decl.foldMap {kind = fn x => x,
126 con = fn x => x,
127 exp = exp,
128 decl = fn x => x}
129 st d
130 in
131 (case #decls st of
132 [] => [d]
133 | ds =>
134 case d of
135 (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
136 | (_, loc) => [(DValRec ds, loc), d],
137 {decls = [],
138 exps = #exps st})
139 end
140
141 val (file, _) = ListUtil.foldlMapConcat decl
142 {decls = [],
143 exps = IM.empty}
144 file
145 in
146 file
147 end
148
149 end