adam@2008
|
1 (* Copyright (c) 2008-2014, Adam Chlipala
|
adamc@25
|
2 * All rights reserved.
|
adamc@25
|
3 *
|
adamc@25
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@25
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@25
|
6 *
|
adamc@25
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@25
|
8 * this list of conditions and the following disclaimer.
|
adamc@25
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@25
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@25
|
11 * and/or other materials provided with the distribution.
|
adamc@25
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@25
|
13 * derived from this software without specific prior written permission.
|
adamc@25
|
14 *
|
adamc@25
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@25
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@25
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@25
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adam@1682
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@25
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@25
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@25
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@25
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@25
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@25
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@25
|
26 *)
|
adamc@25
|
27
|
adamc@25
|
28 structure Monoize :> MONOIZE = struct
|
adamc@25
|
29
|
adamc@25
|
30 structure E = ErrorMsg
|
adamc@25
|
31 structure Env = CoreEnv
|
adamc@25
|
32
|
adamc@25
|
33 structure L = Core
|
adamc@25
|
34 structure L' = Mono
|
adamc@25
|
35
|
adamc@196
|
36 structure IM = IntBinaryMap
|
adamc@735
|
37 structure IS = IntBinarySet
|
adamc@196
|
38
|
adam@1287
|
39 structure SK = struct
|
adam@1287
|
40 type ord_key = string
|
adam@1287
|
41 val compare = String.compare
|
adam@1287
|
42 end
|
adam@1287
|
43
|
adam@1287
|
44 structure SS = BinarySetFn(SK)
|
adam@1287
|
45 structure SM = BinaryMapFn(SK)
|
adam@1287
|
46
|
adam@1287
|
47 structure RM = BinaryMapFn(struct
|
adam@1287
|
48 type ord_key = (string * L'.typ) list
|
adam@1287
|
49 fun compare (r1, r2) = MonoUtil.Typ.compare ((L'.TRecord r1, E.dummySpan),
|
adam@1287
|
50 (L'.TRecord r2, E.dummySpan))
|
adamc@984
|
51 end)
|
adamc@984
|
52
|
adam@1287
|
53 val nextPvar = ref 0
|
adam@1287
|
54 val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map)
|
adam@1713
|
55 val pvarDefs = ref ([] : (string * int * (string * int * L'.typ option) list) list)
|
adam@1288
|
56 val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list)
|
adam@1287
|
57
|
adam@1287
|
58 fun choosePvar () =
|
adam@1287
|
59 let
|
adam@1287
|
60 val n = !nextPvar
|
adam@1287
|
61 in
|
adam@1287
|
62 nextPvar := n + 1;
|
adam@1287
|
63 n
|
adam@1287
|
64 end
|
adam@1287
|
65
|
adam@1288
|
66 fun pvar (r, r', loc) =
|
adam@1288
|
67 case RM.find (!pvars, r') of
|
adam@1287
|
68 NONE =>
|
adam@1287
|
69 let
|
adam@1287
|
70 val n = choosePvar ()
|
adam@1288
|
71 val fs = map (fn (x, t) => (x, choosePvar (), t)) r'
|
adam@1734
|
72 val r = ListMergeSort.sort (fn (((L.CName x, _), _), ((L.CName y, _), _)) => String.compare (x, y) = GREATER
|
adam@1734
|
73 | _ => raise Fail "Monoize: pvar, not CName") r
|
adam@1288
|
74 val (r, fs') = ListPair.foldr (fn ((_, t), (x, n, _), (r, fs')) =>
|
adam@1288
|
75 ((x, n, SOME t) :: r,
|
adam@1288
|
76 SM.insert (fs', x, n))) ([], SM.empty) (r, fs)
|
adam@1287
|
77 in
|
adam@1288
|
78 pvars := RM.insert (!pvars, r', (n, fs));
|
adam@1713
|
79 pvarDefs := ("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs)
|
adam@1287
|
80 :: !pvarDefs;
|
adam@1288
|
81 pvarOldDefs := (n, r) :: !pvarOldDefs;
|
adam@1287
|
82 (n, fs)
|
adam@1287
|
83 end
|
adam@1287
|
84 | SOME v => v
|
adam@1287
|
85
|
adamc@984
|
86 val singletons = SS.addList (SS.empty,
|
adamc@984
|
87 ["link",
|
adamc@984
|
88 "br",
|
adamc@984
|
89 "p",
|
adamc@984
|
90 "hr",
|
adamc@984
|
91 "input",
|
adamc@1129
|
92 "button",
|
adam@1841
|
93 "img",
|
adam@1841
|
94 "base",
|
adam@1841
|
95 "meta",
|
adam@1841
|
96 "param",
|
adam@1841
|
97 "area",
|
adam@1841
|
98 "col"])
|
adamc@984
|
99
|
adamc@196
|
100 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
|
adamc@25
|
101
|
adamc@252
|
102 structure U = MonoUtil
|
adamc@252
|
103
|
adamc@252
|
104 val liftExpInExp =
|
adamc@252
|
105 U.Exp.mapB {typ = fn t => t,
|
adamc@252
|
106 exp = fn bound => fn e =>
|
adamc@252
|
107 case e of
|
adamc@252
|
108 L'.ERel xn =>
|
adamc@252
|
109 if xn < bound then
|
adamc@252
|
110 e
|
adamc@252
|
111 else
|
adamc@252
|
112 L'.ERel (xn + 1)
|
adamc@252
|
113 | _ => e,
|
adamc@252
|
114 bind = fn (bound, U.Exp.RelE _) => bound + 1
|
adamc@252
|
115 | (bound, _) => bound}
|
adamc@252
|
116
|
adamc@25
|
117 fun monoName env (all as (c, loc)) =
|
adamc@25
|
118 let
|
adamc@25
|
119 fun poly () =
|
adamc@25
|
120 (E.errorAt loc "Unsupported name constructor";
|
adamc@25
|
121 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
|
adamc@25
|
122 "")
|
adamc@25
|
123 in
|
adamc@25
|
124 case c of
|
adamc@25
|
125 L.CName s => s
|
adamc@25
|
126 | _ => poly ()
|
adamc@25
|
127 end
|
adamc@25
|
128
|
adamc@877
|
129 fun lowercaseFirst "" = ""
|
adamc@877
|
130 | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0)))
|
adamc@877
|
131 ^ String.extract (s, 1, NONE)
|
adamc@877
|
132
|
adamc@877
|
133 fun monoNameLc env c = lowercaseFirst (monoName env c)
|
adamc@877
|
134
|
adamc@292
|
135 fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
|
adamc@292
|
136 (L'.TOption t, loc)), loc)
|
adamc@292
|
137 fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
|
adamc@292
|
138 t), loc)
|
adamc@292
|
139 fun readType (t, loc) =
|
adamc@292
|
140 (L'.TRecord [("Read", readType' (t, loc)),
|
adamc@292
|
141 ("ReadError", readErrType (t, loc))],
|
adamc@292
|
142 loc)
|
adamc@292
|
143
|
adamc@196
|
144 fun monoType env =
|
adamc@25
|
145 let
|
adamc@196
|
146 fun mt env dtmap (all as (c, loc)) =
|
adamc@196
|
147 let
|
adamc@196
|
148 fun poly () =
|
adamc@196
|
149 (E.errorAt loc "Unsupported type constructor";
|
adamc@196
|
150 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
|
adamc@196
|
151 dummyTyp)
|
adamc@196
|
152 in
|
adamc@196
|
153 case c of
|
adamc@196
|
154 L.TFun (c1, c2) => (L'.TFun (mt env dtmap c1, mt env dtmap c2), loc)
|
adamc@196
|
155 | L.TCFun _ => poly ()
|
adamc@196
|
156 | L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
|
adamc@905
|
157 let
|
adamc@905
|
158 val xcs = map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs
|
adamc@905
|
159 val xcs = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xcs
|
adamc@905
|
160 in
|
adamc@905
|
161 (L'.TRecord xcs, loc)
|
adamc@905
|
162 end
|
adamc@196
|
163 | L.TRecord _ => poly ()
|
adamc@196
|
164
|
adamc@288
|
165 | L.CApp ((L.CFfi ("Basis", "option"), _), t) =>
|
adamc@288
|
166 (L'.TOption (mt env dtmap t), loc)
|
adamc@757
|
167 | L.CApp ((L.CFfi ("Basis", "list"), _), t) =>
|
adamc@757
|
168 (L'.TList (mt env dtmap t), loc)
|
adamc@288
|
169
|
adam@1287
|
170 | L.CApp ((L.CFfi ("Basis", "variant"), _), (L.CRecord ((L.KType, _), xts), _)) =>
|
adam@1287
|
171 let
|
adam@1288
|
172 val xts' = map (fn (x, t) => (monoName env x, mt env dtmap t)) xts
|
adam@1288
|
173 val xts' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts'
|
adam@1288
|
174 val (n, cs) = pvar (xts, xts', loc)
|
adam@1287
|
175 val cs = map (fn (x, n, t) => (x, n, SOME t)) cs
|
adam@1287
|
176 in
|
adam@1287
|
177 (L'.TDatatype (n, ref (ElabUtil.classifyDatatype cs, cs)), loc)
|
adam@1287
|
178 end
|
adam@1287
|
179
|
adamc@820
|
180 | L.CApp ((L.CFfi ("Basis", "monad"), _), _) =>
|
adamc@820
|
181 (L'.TRecord [], loc)
|
adamc@820
|
182
|
adamc@387
|
183 | L.CApp ((L.CFfi ("Basis", "eq"), _), t) =>
|
adamc@387
|
184 let
|
adamc@387
|
185 val t = mt env dtmap t
|
adamc@387
|
186 in
|
adamc@387
|
187 (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)
|
adamc@387
|
188 end
|
adamc@389
|
189 | L.CApp ((L.CFfi ("Basis", "num"), _), t) =>
|
adamc@389
|
190 let
|
adamc@389
|
191 val t = mt env dtmap t
|
adamc@389
|
192 in
|
adamc@417
|
193 (L'.TRecord [("Zero", t),
|
adamc@417
|
194 ("Neg", (L'.TFun (t, t), loc)),
|
adamc@389
|
195 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adamc@389
|
196 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adamc@389
|
197 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adamc@389
|
198 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
mad@1831
|
199 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adam@1832
|
200 ("Pow", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))],
|
adamc@389
|
201 loc)
|
adamc@389
|
202 end
|
adamc@391
|
203 | L.CApp ((L.CFfi ("Basis", "ord"), _), t) =>
|
adamc@391
|
204 let
|
adamc@391
|
205 val t = mt env dtmap t
|
adamc@391
|
206 in
|
adamc@391
|
207 (L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
|
adamc@391
|
208 ("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))],
|
adamc@391
|
209 loc)
|
adamc@391
|
210 end
|
adamc@286
|
211 | L.CApp ((L.CFfi ("Basis", "show"), _), t) =>
|
adamc@286
|
212 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
|
adamc@290
|
213 | L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
|
adamc@292
|
214 readType (mt env dtmap t, loc)
|
adamc@286
|
215
|
adamc@1176
|
216 | L.CFfi ("Basis", "unit") => (L'.TRecord [], loc)
|
adamc@1176
|
217 | L.CFfi ("Basis", "page") => (L'.TFfi ("Basis", "string"), loc)
|
adam@1921
|
218 | L.CFfi ("Basis", "xhead") => (L'.TFfi ("Basis", "string"), loc)
|
adamc@1176
|
219 | L.CFfi ("Basis", "xbody") => (L'.TFfi ("Basis", "string"), loc)
|
kkallio@1475
|
220 | L.CFfi ("Basis", "xtable") => (L'.TFfi ("Basis", "string"), loc)
|
adamc@1176
|
221 | L.CFfi ("Basis", "xtr") => (L'.TFfi ("Basis", "string"), loc)
|
adamc@1176
|
222 | L.CFfi ("Basis", "xform") => (L'.TFfi ("Basis", "string"), loc)
|
adamc@1176
|
223
|
adamc@717
|
224 | L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc)
|
adamc@741
|
225 | L.CFfi ("Basis", "mimeType") => (L'.TFfi ("Basis", "string"), loc)
|
adamc@720
|
226 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
|
adamc@196
|
227 (L'.TFfi ("Basis", "string"), loc)
|
adamc@196
|
228 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
|
adamc@196
|
229 (L'.TFfi ("Basis", "string"), loc)
|
adamc@721
|
230 | L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc)
|
adam@1750
|
231 | L.CFfi ("Basis", "css_value") => (L'.TFfi ("Basis", "string"), loc)
|
adam@1750
|
232 | L.CFfi ("Basis", "css_property") => (L'.TFfi ("Basis", "string"), loc)
|
adam@1750
|
233 | L.CFfi ("Basis", "css_style") => (L'.TFfi ("Basis", "string"), loc)
|
adam@1556
|
234 | L.CFfi ("Basis", "id") => (L'.TFfi ("Basis", "string"), loc)
|
adam@1799
|
235 | L.CFfi ("Basis", "requestHeader") => (L'.TFfi ("Basis", "string"), loc)
|
adam@1799
|
236 | L.CFfi ("Basis", "responseHeader") => (L'.TFfi ("Basis", "string"), loc)
|
adam@1799
|
237 | L.CFfi ("Basis", "envVar") => (L'.TFfi ("Basis", "string"), loc)
|
adam@2047
|
238 | L.CFfi ("Basis", "data_attr_kind") => (L'.TFfi ("Basis", "string"), loc)
|
adam@2008
|
239 | L.CFfi ("Basis", "data_attr") => (L'.TFfi ("Basis", "string"), loc)
|
adamc@196
|
240
|
adamc@1104
|
241 | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
|
adamc@1104
|
242 (L'.TFfi ("Basis", "string"), loc)
|
adamc@1104
|
243
|
adamc@251
|
244 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
|
adamc@252
|
245 (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
|
adamc@565
|
246 | L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
|
adamc@577
|
247 (L'.TSource, loc)
|
adamc@568
|
248 | L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
|
adamc@568
|
249 (L'.TSignal (mt env dtmap t), loc)
|
adamc@462
|
250 | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
|
adamc@462
|
251 (L'.TFfi ("Basis", "string"), loc)
|
adamc@705
|
252 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_table"), _), _), _), _) =>
|
adamc@252
|
253 (L'.TFfi ("Basis", "string"), loc)
|
adamc@823
|
254 | L.CApp ((L.CFfi ("Basis", "sql_view"), _), _) =>
|
adamc@823
|
255 (L'.TFfi ("Basis", "string"), loc)
|
adamc@338
|
256 | L.CFfi ("Basis", "sql_sequence") =>
|
adamc@338
|
257 (L'.TFfi ("Basis", "string"), loc)
|
adam@1394
|
258 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _) =>
|
adamc@252
|
259 (L'.TFfi ("Basis", "string"), loc)
|
adam@1394
|
260 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _), _), _), _), _) =>
|
adamc@252
|
261 (L'.TFfi ("Basis", "string"), loc)
|
adamc@1191
|
262 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_from_items"), _), _), _), _) =>
|
adamc@748
|
263 (L'.TFfi ("Basis", "string"), loc)
|
adam@1778
|
264 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
|
adam@1778
|
265 (L'.TFfi ("Basis", "string"), loc)
|
adam@1778
|
266 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_expw"), _), _), _), _), _), _), _), _) =>
|
adam@1778
|
267 (L'.TFfi ("Basis", "string"), loc)
|
adam@1778
|
268 | L.CApp ((L.CFfi ("Basis", "sql_window"), _), _) =>
|
adam@1778
|
269 (L'.TRecord [], loc)
|
adam@1778
|
270 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window_function"), _), _), _), _), _), _), _), _) =>
|
adamc@252
|
271 (L'.TFfi ("Basis", "string"), loc)
|
adamc@707
|
272 | L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) =>
|
adamc@707
|
273 (L'.TFfi ("Basis", "string"), loc)
|
adamc@704
|
274 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) =>
|
adamc@704
|
275 (L'.TFfi ("Basis", "sql_constraints"), loc)
|
adamc@705
|
276 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) =>
|
adamc@704
|
277 (L'.TFfi ("Basis", "string"), loc)
|
adamc@712
|
278 | L.CApp ((L.CApp ((L.CFfi ("Basis", "linkable"), _), _), _), _) =>
|
adamc@712
|
279 (L'.TRecord [], loc)
|
adamc@709
|
280 | L.CApp ((L.CApp ((L.CFfi ("Basis", "matching"), _), _), _), _) =>
|
adamc@709
|
281 let
|
adamc@709
|
282 val string = (L'.TFfi ("Basis", "string"), loc)
|
adamc@709
|
283 in
|
adamc@709
|
284 (L'.TRecord [("1", string), ("2", string)], loc)
|
adamc@709
|
285 end
|
adamc@709
|
286 | L.CApp ((L.CFfi ("Basis", "propagation_mode"), _), _) =>
|
adamc@709
|
287 (L'.TFfi ("Basis", "string"), loc)
|
adam@1870
|
288 | L.CFfi ("Basis", "dml") =>
|
adam@1870
|
289 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
290
|
adamc@252
|
291 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
|
adamc@252
|
292 (L'.TRecord [], loc)
|
adamc@252
|
293 | L.CFfi ("Basis", "sql_relop") =>
|
adamc@252
|
294 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
295 | L.CFfi ("Basis", "sql_direction") =>
|
adamc@252
|
296 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
297 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_order_by"), _), _), _), _) =>
|
adamc@252
|
298 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
299 | L.CFfi ("Basis", "sql_limit") =>
|
adamc@252
|
300 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
301 | L.CFfi ("Basis", "sql_offset") =>
|
adamc@252
|
302 (L'.TFfi ("Basis", "string"), loc)
|
adamc@753
|
303 | L.CApp ((L.CApp ((L.CFfi ("Basis", "fieldsOf"), _), _), _), _) =>
|
adamc@753
|
304 (L'.TRecord [], loc)
|
adamc@252
|
305
|
adamc@676
|
306 | L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) =>
|
adamc@676
|
307 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
|
adamc@252
|
308 | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
|
adamc@252
|
309 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
|
adamc@750
|
310 | L.CApp ((L.CApp ((L.CFfi ("Basis", "nullify"), _), _), _), _) =>
|
adamc@750
|
311 (L'.TRecord [], loc)
|
adamc@252
|
312 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
|
adamc@252
|
313 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
314 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) =>
|
adamc@252
|
315 (L'.TFfi ("Basis", "string"), loc)
|
adamc@1187
|
316 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_aggregate"), _), _), _), _) =>
|
adamc@252
|
317 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
318 | L.CApp ((L.CFfi ("Basis", "sql_summable"), _), _) =>
|
adamc@252
|
319 (L'.TRecord [], loc)
|
adamc@252
|
320 | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
|
adamc@252
|
321 (L'.TRecord [], loc)
|
adamc@559
|
322 | L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) =>
|
adamc@559
|
323 (L'.TRecord [], loc)
|
adamc@441
|
324 | L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) =>
|
adamc@441
|
325 (L'.TFfi ("Basis", "string"), loc)
|
adamc@746
|
326 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) =>
|
adamc@746
|
327 (L'.TFfi ("Basis", "string"), loc)
|
adam@1778
|
328 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) =>
|
adam@1778
|
329 (L'.TFfi ("Basis", "string"), loc)
|
adam@1778
|
330 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) =>
|
adam@1778
|
331 (L'.TFfi ("Basis", "string"), loc)
|
adamc@251
|
332
|
adamc@668
|
333 | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
|
adamc@668
|
334 (L'.TFfi ("Basis", "channel"), loc)
|
adamc@668
|
335
|
adamc@196
|
336 | L.CRel _ => poly ()
|
adamc@196
|
337 | L.CNamed n =>
|
adamc@196
|
338 (case IM.find (dtmap, n) of
|
adamc@196
|
339 SOME r => (L'.TDatatype (n, r), loc)
|
adamc@196
|
340 | NONE =>
|
adamc@196
|
341 let
|
adamc@196
|
342 val r = ref (L'.Default, [])
|
adamc@196
|
343 val (_, xs, xncs) = Env.lookupDatatype env n
|
adam@1682
|
344
|
adamc@196
|
345 val dtmap' = IM.insert (dtmap, n, r)
|
adam@1682
|
346
|
adamc@196
|
347 val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs
|
adamc@196
|
348 in
|
adamc@196
|
349 case xs of
|
adamc@198
|
350 [] =>(r := (ElabUtil.classifyDatatype xncs, xncs);
|
adamc@196
|
351 (L'.TDatatype (n, r), loc))
|
adamc@196
|
352 | _ => poly ()
|
adamc@196
|
353 end)
|
adamc@196
|
354 | L.CFfi mx => (L'.TFfi mx, loc)
|
adamc@196
|
355 | L.CApp _ => poly ()
|
adamc@196
|
356 | L.CAbs _ => poly ()
|
adamc@196
|
357
|
adamc@196
|
358 | L.CName _ => poly ()
|
adamc@196
|
359
|
adamc@196
|
360 | L.CRecord _ => poly ()
|
adamc@196
|
361 | L.CConcat _ => poly ()
|
adamc@621
|
362 | L.CMap _ => poly ()
|
adamc@196
|
363 | L.CUnit => poly ()
|
adamc@214
|
364
|
adamc@214
|
365 | L.CTuple _ => poly ()
|
adamc@214
|
366 | L.CProj _ => poly ()
|
adamc@626
|
367
|
adamc@626
|
368 | L.CKAbs _ => poly ()
|
adamc@626
|
369 | L.CKApp _ => poly ()
|
adamc@626
|
370 | L.TKFun _ => poly ()
|
adamc@196
|
371 end
|
adamc@25
|
372 in
|
adamc@196
|
373 mt env IM.empty
|
adamc@25
|
374 end
|
adamc@25
|
375
|
adamc@25
|
376 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
|
adamc@25
|
377
|
adamc@179
|
378 structure IM = IntBinaryMap
|
adamc@179
|
379
|
adamc@179
|
380 datatype foo_kind =
|
adamc@179
|
381 Attr
|
adamc@179
|
382 | Url
|
adamc@179
|
383
|
adamc@179
|
384 fun fk2s fk =
|
adamc@179
|
385 case fk of
|
adamc@179
|
386 Attr => "attr"
|
adamc@179
|
387 | Url => "url"
|
adamc@179
|
388
|
adam@1730
|
389 type vr = string * int * L'.typ * L'.exp * string
|
adam@1730
|
390
|
adamc@179
|
391 structure Fm :> sig
|
adamc@179
|
392 type t
|
adamc@179
|
393
|
adamc@179
|
394 val empty : int -> t
|
adamc@179
|
395
|
adam@1730
|
396 val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int
|
adam@1730
|
397 val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> vr * t) -> t * int
|
adamc@179
|
398 val enter : t -> t
|
adamc@179
|
399 val decls : t -> L'.decl list
|
adamc@683
|
400
|
adamc@683
|
401 val freshName : t -> int * t
|
adamc@179
|
402 end = struct
|
adamc@179
|
403
|
adamc@179
|
404 structure M = BinaryMapFn(struct
|
adamc@179
|
405 type ord_key = foo_kind
|
adamc@179
|
406 fun compare x =
|
adamc@179
|
407 case x of
|
adamc@179
|
408 (Attr, Attr) => EQUAL
|
adamc@179
|
409 | (Attr, _) => LESS
|
adamc@179
|
410 | (_, Attr) => GREATER
|
adamc@179
|
411
|
adamc@179
|
412 | (Url, Url) => EQUAL
|
adamc@179
|
413 end)
|
adamc@179
|
414
|
adamc@758
|
415 structure TM = BinaryMapFn(struct
|
adamc@758
|
416 type ord_key = L'.typ
|
adamc@758
|
417 val compare = MonoUtil.Typ.compare
|
adamc@758
|
418 end)
|
adamc@758
|
419
|
adamc@179
|
420 type t = {
|
adamc@179
|
421 count : int,
|
adamc@179
|
422 map : int IM.map M.map,
|
adamc@758
|
423 listMap : int TM.map M.map,
|
adam@1730
|
424 decls : vr list
|
adamc@179
|
425 }
|
adamc@179
|
426
|
adamc@179
|
427 fun empty count = {
|
adamc@179
|
428 count = count,
|
adamc@179
|
429 map = M.empty,
|
adamc@758
|
430 listMap = M.empty,
|
adamc@179
|
431 decls = []
|
adamc@179
|
432 }
|
adamc@179
|
433
|
adam@1287
|
434 fun chooseNext count =
|
adam@1287
|
435 let
|
adam@1287
|
436 val n = !nextPvar
|
adam@1287
|
437 in
|
adam@1287
|
438 if count < n then
|
adam@1287
|
439 (count, count+1)
|
adam@1287
|
440 else
|
adam@1287
|
441 (nextPvar := n + 1;
|
adam@1287
|
442 (n, n+1))
|
adam@1287
|
443 end
|
adam@1287
|
444
|
adamc@758
|
445 fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
|
adam@1287
|
446 fun freshName {count, map, listMap, decls} =
|
adam@1287
|
447 let
|
adam@1287
|
448 val (next, count) = chooseNext count
|
adam@1287
|
449 in
|
adam@1287
|
450 (next, {count = count , map = map, listMap = listMap, decls = decls})
|
adam@1287
|
451 end
|
adam@1730
|
452 fun decls ({decls, ...} : t) =
|
adam@1730
|
453 case decls of
|
adam@1730
|
454 [] => []
|
adam@1730
|
455 | _ => [(L'.DValRec decls, ErrorMsg.dummySpan)]
|
adamc@179
|
456
|
adamc@758
|
457 fun lookup (t as {count, map, listMap, decls}) k n thunk =
|
adamc@120
|
458 let
|
adamc@179
|
459 val im = Option.getOpt (M.find (map, k), IM.empty)
|
adamc@179
|
460 in
|
adamc@179
|
461 case IM.find (im, n) of
|
adamc@179
|
462 NONE =>
|
adamc@179
|
463 let
|
adamc@179
|
464 val n' = count
|
adamc@758
|
465 val (d, {count, map, listMap, decls}) =
|
adamc@758
|
466 thunk count {count = count + 1,
|
adamc@758
|
467 map = M.insert (map, k, IM.insert (im, n, n')),
|
adamc@758
|
468 listMap = listMap,
|
adamc@758
|
469 decls = decls}
|
adamc@179
|
470 in
|
adamc@179
|
471 ({count = count,
|
adamc@179
|
472 map = map,
|
adamc@758
|
473 listMap = listMap,
|
adamc@758
|
474 decls = d :: decls}, n')
|
adamc@758
|
475 end
|
adamc@758
|
476 | SOME n' => (t, n')
|
adamc@758
|
477 end
|
adamc@758
|
478
|
adamc@758
|
479 fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
|
adamc@758
|
480 let
|
adamc@758
|
481 val tm = Option.getOpt (M.find (listMap, k), TM.empty)
|
adamc@758
|
482 in
|
adamc@758
|
483 case TM.find (tm, tp) of
|
adamc@758
|
484 NONE =>
|
adamc@758
|
485 let
|
adamc@758
|
486 val n' = count
|
adamc@758
|
487 val (d, {count, map, listMap, decls}) =
|
adamc@758
|
488 thunk count {count = count + 1,
|
adamc@758
|
489 map = map,
|
adamc@758
|
490 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
|
adamc@758
|
491 decls = decls}
|
adamc@758
|
492 in
|
adamc@758
|
493 ({count = count,
|
adamc@758
|
494 map = map,
|
adamc@758
|
495 listMap = listMap,
|
adamc@179
|
496 decls = d :: decls}, n')
|
adamc@179
|
497 end
|
adamc@179
|
498 | SOME n' => (t, n')
|
adamc@179
|
499 end
|
adamc@179
|
500
|
adamc@179
|
501 end
|
adamc@185
|
502
|
adamc@185
|
503
|
adamc@185
|
504 fun capitalize s =
|
adamc@185
|
505 if s = "" then
|
adamc@185
|
506 s
|
adamc@185
|
507 else
|
adamc@185
|
508 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@179
|
509
|
adamc@179
|
510 fun fooifyExp fk env =
|
adamc@179
|
511 let
|
adamc@179
|
512 fun fooify fm (e, tAll as (t, loc)) =
|
adamc@120
|
513 case #1 e of
|
adamc@120
|
514 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
|
adamc@120
|
515 let
|
adamc@120
|
516 val (_, _, _, s) = Env.lookupENamed env fnam
|
adamc@120
|
517 in
|
adamc@764
|
518 ((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
|
adamc@120
|
519 end
|
adamc@120
|
520 | L'.EClosure (fnam, args) =>
|
adamc@120
|
521 let
|
adamc@120
|
522 val (_, ft, _, s) = Env.lookupENamed env fnam
|
adamc@120
|
523 val ft = monoType env ft
|
adamc@111
|
524
|
adamc@179
|
525 fun attrify (args, ft, e, fm) =
|
adamc@120
|
526 case (args, ft) of
|
adamc@179
|
527 ([], _) => (e, fm)
|
adamc@120
|
528 | (arg :: args, (L'.TFun (t, ft), _)) =>
|
adamc@179
|
529 let
|
adamc@179
|
530 val (arg', fm) = fooify fm (arg, t)
|
adamc@179
|
531 in
|
adamc@179
|
532 attrify (args, ft,
|
adamc@179
|
533 (L'.EStrcat (e,
|
adamc@179
|
534 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
|
adamc@179
|
535 arg'), loc)), loc),
|
adamc@179
|
536 fm)
|
adamc@179
|
537 end
|
adamc@120
|
538 | _ => (E.errorAt loc "Type mismatch encoding attribute";
|
adamc@179
|
539 (e, fm))
|
adamc@120
|
540 in
|
adamc@764
|
541 attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
|
adamc@120
|
542 end
|
adamc@120
|
543 | _ =>
|
adamc@120
|
544 case t of
|
adamc@1109
|
545 L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm)
|
adam@1663
|
546 | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
|
adamc@200
|
547
|
adamc@179
|
548 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
|
adamc@200
|
549 | L'.TRecord ((x, t) :: xts) =>
|
adamc@200
|
550 let
|
adamc@200
|
551 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
|
adamc@200
|
552 in
|
adamc@200
|
553 foldl (fn ((x, t), (se, fm)) =>
|
adamc@200
|
554 let
|
adamc@200
|
555 val (se', fm) = fooify fm ((L'.EField (e, x), loc), t)
|
adamc@200
|
556 in
|
adamc@200
|
557 ((L'.EStrcat (se,
|
adamc@200
|
558 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
|
adamc@200
|
559 se'), loc)), loc),
|
adamc@200
|
560 fm)
|
adamc@200
|
561 end) (se, fm) xts
|
adamc@200
|
562 end
|
adamc@111
|
563
|
adamc@196
|
564 | L'.TDatatype (i, ref (dk, _)) =>
|
adamc@179
|
565 let
|
adamc@179
|
566 fun makeDecl n fm =
|
adamc@179
|
567 let
|
adam@1655
|
568 val (x, xncs) =
|
adam@1713
|
569 case ListUtil.search (fn (x, i', xncs) =>
|
adam@1655
|
570 if i' = i then
|
adam@1655
|
571 SOME (x, xncs)
|
adam@1655
|
572 else
|
adam@1713
|
573 NONE) (!pvarDefs) of
|
adam@1655
|
574 NONE =>
|
adam@1655
|
575 let
|
adam@1655
|
576 val (x, _, xncs) = Env.lookupDatatype env i
|
adam@1655
|
577 in
|
adam@1655
|
578 (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs)
|
adam@1655
|
579 end
|
adam@1655
|
580 | SOME v => v
|
adamc@179
|
581
|
adamc@179
|
582 val (branches, fm) =
|
adamc@179
|
583 ListUtil.foldlMap
|
adamc@179
|
584 (fn ((x, n, to), fm) =>
|
adamc@179
|
585 case to of
|
adamc@179
|
586 NONE =>
|
adamc@188
|
587 (((L'.PCon (dk, L'.PConVar n, NONE), loc),
|
adamc@179
|
588 (L'.EPrim (Prim.String x), loc)),
|
adamc@179
|
589 fm)
|
adamc@179
|
590 | SOME t =>
|
adamc@179
|
591 let
|
adamc@182
|
592 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
|
adamc@179
|
593 in
|
adamc@188
|
594 (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
|
adamc@179
|
595 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
|
adamc@179
|
596 arg), loc)),
|
adamc@179
|
597 fm)
|
adamc@179
|
598 end)
|
adamc@179
|
599 fm xncs
|
adamc@179
|
600
|
adamc@179
|
601 val dom = tAll
|
adamc@179
|
602 val ran = (L'.TFfi ("Basis", "string"), loc)
|
adamc@179
|
603 in
|
adam@1730
|
604 ((fk2s fk ^ "ify_" ^ x,
|
adam@1730
|
605 n,
|
adam@1730
|
606 (L'.TFun (dom, ran), loc),
|
adam@1730
|
607 (L'.EAbs ("x",
|
adam@1730
|
608 dom,
|
adam@1730
|
609 ran,
|
adam@1730
|
610 (L'.ECase ((L'.ERel 0, loc),
|
adam@1730
|
611 branches,
|
adam@1730
|
612 {disc = dom,
|
adam@1730
|
613 result = ran}), loc)), loc),
|
adam@1730
|
614 ""),
|
adamc@179
|
615 fm)
|
adam@1682
|
616 end
|
adamc@179
|
617
|
adamc@179
|
618 val (fm, n) = Fm.lookup fm fk i makeDecl
|
adamc@179
|
619 in
|
adamc@179
|
620 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
|
adamc@179
|
621 end
|
adamc@164
|
622
|
adamc@471
|
623 | L'.TOption t =>
|
adamc@471
|
624 let
|
adamc@471
|
625 val (body, fm) = fooify fm ((L'.ERel 0, loc), t)
|
adamc@471
|
626 in
|
adamc@471
|
627 ((L'.ECase (e,
|
adamc@471
|
628 [((L'.PNone t, loc),
|
adamc@471
|
629 (L'.EPrim (Prim.String "None"), loc)),
|
adam@1682
|
630
|
adamc@471
|
631 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
|
adamc@471
|
632 (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc),
|
adamc@471
|
633 body), loc))],
|
adamc@471
|
634 {disc = tAll,
|
adamc@471
|
635 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
|
adamc@471
|
636 fm)
|
adamc@471
|
637 end
|
adamc@471
|
638
|
adamc@758
|
639 | L'.TList t =>
|
adamc@758
|
640 let
|
adamc@758
|
641 fun makeDecl n fm =
|
adamc@758
|
642 let
|
adamc@758
|
643 val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc)
|
adamc@758
|
644 val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt)
|
adamc@758
|
645
|
adamc@758
|
646 val branches = [((L'.PNone rt, loc),
|
adamc@758
|
647 (L'.EPrim (Prim.String "Nil"), loc)),
|
adamc@758
|
648 ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc),
|
adamc@758
|
649 (L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc),
|
adamc@758
|
650 arg), loc))]
|
adamc@758
|
651
|
adamc@758
|
652 val dom = tAll
|
adamc@758
|
653 val ran = (L'.TFfi ("Basis", "string"), loc)
|
adamc@758
|
654 in
|
adam@1730
|
655 ((fk2s fk ^ "ify_list",
|
adam@1730
|
656 n,
|
adam@1730
|
657 (L'.TFun (dom, ran), loc),
|
adam@1730
|
658 (L'.EAbs ("x",
|
adam@1730
|
659 dom,
|
adam@1730
|
660 ran,
|
adam@1730
|
661 (L'.ECase ((L'.ERel 0, loc),
|
adam@1730
|
662 branches,
|
adam@1730
|
663 {disc = dom,
|
adam@1730
|
664 result = ran}), loc)), loc),
|
adam@1730
|
665 ""),
|
adamc@758
|
666 fm)
|
adamc@758
|
667 end
|
adamc@758
|
668
|
adamc@758
|
669 val (fm, n) = Fm.lookupList fm fk t makeDecl
|
adamc@758
|
670 in
|
adamc@758
|
671 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
|
adamc@758
|
672 end
|
adamc@758
|
673
|
adamc@490
|
674 | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
|
adamc@120
|
675 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
|
adamc@179
|
676 (dummyExp, fm))
|
adamc@120
|
677 in
|
adamc@120
|
678 fooify
|
adamc@120
|
679 end
|
adamc@120
|
680
|
adamc@179
|
681 val attrifyExp = fooifyExp Attr
|
adamc@179
|
682 val urlifyExp = fooifyExp Url
|
adamc@105
|
683
|
adamc@143
|
684 datatype 'a failable_search =
|
adamc@143
|
685 Found of 'a
|
adamc@143
|
686 | NotFound
|
adamc@143
|
687 | Error
|
adamc@143
|
688
|
adamc@153
|
689 structure St :> sig
|
adamc@153
|
690 type t
|
adamc@153
|
691
|
adamc@153
|
692 val empty : t
|
adamc@153
|
693
|
adamc@153
|
694 val radioGroup : t -> string option
|
adamc@153
|
695 val setRadioGroup : t * string -> t
|
adamc@153
|
696 end = struct
|
adamc@153
|
697
|
adamc@153
|
698 type t = {
|
adamc@153
|
699 radioGroup : string option
|
adamc@153
|
700 }
|
adamc@153
|
701
|
adamc@153
|
702 val empty = {radioGroup = NONE}
|
adamc@153
|
703
|
adamc@153
|
704 fun radioGroup (t : t) = #radioGroup t
|
adamc@153
|
705
|
adamc@153
|
706 fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
|
adamc@153
|
707
|
adamc@153
|
708 end
|
adamc@153
|
709
|
adamc@186
|
710 fun monoPatCon env pc =
|
adamc@178
|
711 case pc of
|
adamc@178
|
712 L.PConVar n => L'.PConVar n
|
adamc@188
|
713 | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
|
adamc@188
|
714 arg = Option.map (monoType env) arg}
|
adamc@178
|
715
|
adamc@193
|
716 val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
|
adamc@193
|
717
|
adamc@757
|
718
|
adamc@757
|
719 fun listify t = (L'.TRecord [("1", t), ("2", (L'.TList t, #2 t))], #2 t)
|
adamc@757
|
720
|
adamc@193
|
721 fun monoPat env (all as (p, loc)) =
|
adamc@193
|
722 let
|
adamc@193
|
723 fun poly () =
|
adamc@193
|
724 (E.errorAt loc "Unsupported pattern";
|
adamc@193
|
725 Print.eprefaces' [("Pattern", CorePrint.p_pat env all)];
|
adamc@193
|
726 dummyPat)
|
adamc@193
|
727 in
|
adamc@193
|
728 case p of
|
adamc@193
|
729 L.PWild => (L'.PWild, loc)
|
adamc@193
|
730 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
|
adamc@193
|
731 | L.PPrim p => (L'.PPrim p, loc)
|
adamc@193
|
732 | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
|
adamc@757
|
733 | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
|
adamc@757
|
734 (L'.PNone (listify (monoType env t)), loc)
|
adamc@757
|
735 | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME p) =>
|
adamc@757
|
736 (L'.PSome (listify (monoType env t), monoPat env p), loc)
|
adamc@288
|
737 | L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc)
|
adamc@757
|
738 | L.PCon (L.Option, pc, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc)
|
adamc@193
|
739 | L.PCon _ => poly ()
|
adamc@193
|
740 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
|
adamc@193
|
741 end
|
adamc@178
|
742
|
adamc@252
|
743 fun strcat loc es =
|
adamc@252
|
744 case es of
|
adamc@252
|
745 [] => (L'.EPrim (Prim.String ""), loc)
|
adamc@252
|
746 | [e] => e
|
adamc@252
|
747 | _ =>
|
adamc@252
|
748 let
|
adamc@252
|
749 val e2 = List.last es
|
adamc@252
|
750 val es = List.take (es, length es - 1)
|
adamc@252
|
751 val e1 = List.last es
|
adamc@252
|
752 val es = List.take (es, length es - 1)
|
adamc@252
|
753 in
|
adamc@252
|
754 foldr (fn (e, e') => (L'.EStrcat (e, e'), loc))
|
adamc@252
|
755 (L'.EStrcat (e1, e2), loc) es
|
adamc@252
|
756 end
|
adamc@252
|
757
|
adamc@252
|
758 fun strcatComma loc es =
|
adamc@252
|
759 case es of
|
adamc@252
|
760 [] => (L'.EPrim (Prim.String ""), loc)
|
adamc@252
|
761 | [e] => e
|
adamc@252
|
762 | _ =>
|
adamc@252
|
763 let
|
adamc@252
|
764 val e1 = List.last es
|
adamc@252
|
765 val es = List.take (es, length es - 1)
|
adamc@252
|
766 in
|
adamc@252
|
767 foldr (fn (e, e') =>
|
adamc@265
|
768 case (e, e') of
|
adamc@265
|
769 ((L'.EPrim (Prim.String ""), _), _) => e'
|
adamc@265
|
770 | (_, (L'.EPrim (Prim.String ""), _)) => e
|
adamc@252
|
771 | _ =>
|
adamc@252
|
772 (L'.EStrcat (e,
|
adamc@252
|
773 (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc))
|
adamc@252
|
774 e1 es
|
adamc@252
|
775 end
|
adamc@252
|
776
|
adamc@252
|
777 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
|
adamc@252
|
778
|
adamc@735
|
779 val readCookie = ref IS.empty
|
adamc@735
|
780
|
adamc@877
|
781 fun isBlobby (t : L.con) =
|
adamc@877
|
782 case #1 t of
|
adamc@877
|
783 L.CFfi ("Basis", "string") => true
|
adamc@877
|
784 | L.CFfi ("Basis", "blob") => true
|
adamc@877
|
785 | _ => false
|
adamc@877
|
786
|
adamc@179
|
787 fun monoExp (env, st, fm) (all as (e, loc)) =
|
adamc@25
|
788 let
|
adamc@598
|
789 val strcat = strcat loc
|
adamc@598
|
790 val strcatComma = strcatComma loc
|
adamc@598
|
791 fun str s = (L'.EPrim (Prim.String s), loc)
|
adamc@598
|
792
|
adamc@25
|
793 fun poly () =
|
adamc@25
|
794 (E.errorAt loc "Unsupported expression";
|
adamc@25
|
795 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
|
adamc@179
|
796 (dummyExp, fm))
|
adamc@389
|
797
|
adamc@389
|
798 fun numTy t =
|
adamc@417
|
799 (L'.TRecord [("Zero", t),
|
adamc@417
|
800 ("Neg", (L'.TFun (t, t), loc)),
|
adamc@389
|
801 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adamc@389
|
802 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adamc@389
|
803 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adamc@389
|
804 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
mad@1831
|
805 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adam@1832
|
806 ("Pow", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc)
|
mad@1831
|
807 fun numEx (t, zero, neg, plus, minus, times, dv, md, ex) =
|
adamc@417
|
808 ((L'.ERecord [("Zero", (L'.EPrim zero, loc), t),
|
adamc@417
|
809 ("Neg", neg, (L'.TFun (t, t), loc)),
|
adamc@389
|
810 ("Plus", plus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adamc@389
|
811 ("Minus", minus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adamc@389
|
812 ("Times", times, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adamc@389
|
813 ("Div", dv, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
mad@1831
|
814 ("Mod", md, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
|
adam@1832
|
815 ("Pow", ex, (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc), fm)
|
adamc@391
|
816
|
adamc@391
|
817 fun ordTy t =
|
adamc@391
|
818 (L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
|
adamc@391
|
819 ("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))], loc)
|
adamc@391
|
820 fun ordEx (t, lt, le) =
|
adamc@391
|
821 ((L'.ERecord [("Lt", lt, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
|
adamc@391
|
822 ("Le", le, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))],
|
adamc@391
|
823 loc), fm)
|
adamc@750
|
824
|
adamc@750
|
825 fun outerRec xts =
|
adamc@750
|
826 (L'.TRecord (map (fn ((L.CName x, _), (L.CRecord (_, xts), _)) =>
|
adamc@750
|
827 (x, (L'.TRecord (map (fn (x', _) => (x, (L'.TRecord [], loc))) xts), loc))
|
adamc@750
|
828 | (x, all as (_, loc)) =>
|
adamc@750
|
829 (E.errorAt loc "Unsupported record field constructor";
|
adamc@750
|
830 Print.eprefaces' [("Name", CorePrint.p_con env x),
|
adamc@750
|
831 ("Constructor", CorePrint.p_con env all)];
|
adamc@750
|
832 ("", dummyTyp))) xts), loc)
|
adamc@25
|
833 in
|
adamc@25
|
834 case e of
|
adamc@179
|
835 L.EPrim p => ((L'.EPrim p, loc), fm)
|
adamc@179
|
836 | L.ERel n => ((L'.ERel n, loc), fm)
|
adamc@179
|
837 | L.ENamed n => ((L'.ENamed n, loc), fm)
|
adamc@193
|
838 | L.ECon (dk, pc, [], eo) =>
|
adamc@193
|
839 let
|
adamc@179
|
840 val (eo, fm) =
|
adamc@179
|
841 case eo of
|
adamc@179
|
842 NONE => (NONE, fm)
|
adamc@179
|
843 | SOME e =>
|
adamc@179
|
844 let
|
adamc@179
|
845 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
846 in
|
adamc@179
|
847 (SOME e, fm)
|
adamc@179
|
848 end
|
adamc@179
|
849 in
|
adamc@188
|
850 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
|
adamc@193
|
851 end
|
adamc@757
|
852 | L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
|
adamc@757
|
853 ((L'.ENone (listify (monoType env t)), loc), fm)
|
adamc@757
|
854 | L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME e) =>
|
adamc@757
|
855 let
|
adamc@757
|
856 val (e, fm) = monoExp (env, st, fm) e
|
adamc@757
|
857 in
|
adamc@757
|
858 ((L'.ESome (listify (monoType env t), e), loc), fm)
|
adamc@757
|
859 end
|
adamc@297
|
860 | L.ECon (L.Option, _, [t], NONE) =>
|
adamc@297
|
861 ((L'.ENone (monoType env t), loc), fm)
|
adamc@297
|
862 | L.ECon (L.Option, _, [t], SOME e) =>
|
adamc@297
|
863 let
|
adamc@297
|
864 val (e, fm) = monoExp (env, st, fm) e
|
adamc@297
|
865 in
|
adamc@297
|
866 ((L'.ESome (monoType env t, e), loc), fm)
|
adamc@297
|
867 end
|
adamc@193
|
868 | L.ECon _ => poly ()
|
adamc@94
|
869
|
adam@1287
|
870 | L.ECApp (
|
adam@1287
|
871 (L.ECApp (
|
adam@1288
|
872 (L.ECApp ((L.EFfi ("Basis", "make"), _), nmC as (L.CName nm, _)), _),
|
adam@1287
|
873 t), _),
|
adam@1287
|
874 (L.CRecord (_, xts), _)) =>
|
adam@1287
|
875 let
|
adam@1288
|
876 val t' = monoType env t
|
adam@1288
|
877 val xts' = map (fn (x, t) => (monoName env x, monoType env t)) xts
|
adam@1288
|
878 val xts' = (nm, t') :: xts'
|
adam@1288
|
879 val xts' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts'
|
adam@1288
|
880 val (n, cs) = pvar ((nmC, t) :: xts, xts', loc)
|
adam@1287
|
881 val cs' = map (fn (x, n, t) => (x, n, SOME t)) cs
|
adam@1287
|
882 val cl = ElabUtil.classifyDatatype cs'
|
adam@1287
|
883 in
|
adam@1287
|
884 case List.find (fn (nm', _, _) => nm' = nm) cs of
|
adam@1287
|
885 NONE => raise Fail "Monoize: Polymorphic variant tag mismatch for 'make'"
|
adam@1288
|
886 | SOME (_, n', _) => ((L'.EAbs ("x", t', (L'.TDatatype (n, ref (cl, cs')), loc),
|
adam@1287
|
887 (L'.ECon (cl, L'.PConVar n', SOME (L'.ERel 0, loc)), loc)), loc),
|
adam@1287
|
888 fm)
|
adam@1287
|
889 end
|
adam@1287
|
890
|
adam@1287
|
891 | L.ECApp (
|
adam@1287
|
892 (L.ECApp ((L.EFfi ("Basis", "match"), _), (L.CRecord (_, xts), _)), _),
|
adam@1287
|
893 t) =>
|
adam@1287
|
894 let
|
adam@1287
|
895 val t = monoType env t
|
adam@1288
|
896 val xts' = map (fn (x, t) => (monoName env x, monoType env t)) xts
|
adam@1288
|
897 val xts' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts'
|
adam@1288
|
898 val (n, cs) = pvar (xts, xts', loc)
|
adam@1287
|
899 val cs' = map (fn (x, n, t) => (x, n, SOME t)) cs
|
adam@1287
|
900 val cl = ElabUtil.classifyDatatype cs'
|
adam@1288
|
901 val fs = (L'.TRecord (map (fn (x, t') => (x, (L'.TFun (t', t), loc))) xts'), loc)
|
adam@1287
|
902 val dt = (L'.TDatatype (n, ref (cl, cs')), loc)
|
adam@1287
|
903 in
|
adam@1287
|
904 ((L'.EAbs ("v",
|
adam@1287
|
905 dt,
|
adam@1287
|
906 (L'.TFun (fs, t), loc),
|
adam@1287
|
907 (L'.EAbs ("fs", fs, t,
|
adam@1287
|
908 (L'.ECase ((L'.ERel 1, loc),
|
adam@1287
|
909 map (fn (x, n', t') =>
|
adam@1287
|
910 ((L'.PCon (cl, L'.PConVar n', SOME (L'.PVar ("x", t'), loc)), loc),
|
adam@1287
|
911 (L'.EApp ((L'.EField ((L'.ERel 1, loc), x), loc),
|
adam@1287
|
912 (L'.ERel 0, loc)), loc))) cs,
|
adam@1287
|
913 {disc = dt, result = t}), loc)), loc)), loc),
|
adam@1287
|
914 fm)
|
adam@1287
|
915 end
|
adam@1287
|
916
|
adamc@387
|
917 | L.ECApp ((L.EFfi ("Basis", "eq"), _), t) =>
|
adamc@387
|
918 let
|
adamc@387
|
919 val t = monoType env t
|
adamc@387
|
920 val b = (L'.TFfi ("Basis", "bool"), loc)
|
adamc@387
|
921 val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
|
adamc@387
|
922 in
|
adamc@387
|
923 ((L'.EAbs ("f", dom, dom,
|
adamc@387
|
924 (L'.ERel 0, loc)), loc), fm)
|
adamc@387
|
925 end
|
adamc@387
|
926 | L.ECApp ((L.EFfi ("Basis", "ne"), _), t) =>
|
adamc@387
|
927 let
|
adamc@387
|
928 val t = monoType env t
|
adamc@387
|
929 val b = (L'.TFfi ("Basis", "bool"), loc)
|
adamc@387
|
930 val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
|
adamc@387
|
931 in
|
adamc@387
|
932 ((L'.EAbs ("f", dom, dom,
|
adamc@387
|
933 (L'.EAbs ("x", t, (L'.TFun (t, b), loc),
|
adamc@387
|
934 (L'.EAbs ("y", t, b,
|
adamc@387
|
935 (L'.EUnop ("!", (L'.EApp ((L'.EApp ((L'.ERel 2, loc),
|
adamc@387
|
936 (L'.ERel 1, loc)), loc),
|
adamc@387
|
937 (L'.ERel 0, loc)), loc)), loc)),
|
adamc@387
|
938 loc)),
|
adamc@387
|
939 loc)),
|
adamc@387
|
940 loc), fm)
|
adamc@387
|
941 end
|
adamc@387
|
942 | L.EFfi ("Basis", "eq_int") =>
|
adamc@387
|
943 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
|
adamc@387
|
944 (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@387
|
945 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
|
adamc@387
|
946 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1360
|
947 (L'.EBinop (L'.Int, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
|
adamc@387
|
948 fm)
|
adamc@394
|
949 | L.EFfi ("Basis", "eq_float") =>
|
adamc@394
|
950 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
|
adamc@394
|
951 (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@394
|
952 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
|
adamc@394
|
953 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1360
|
954 (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
|
adamc@394
|
955 fm)
|
adamc@388
|
956 | L.EFfi ("Basis", "eq_bool") =>
|
adamc@388
|
957 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc),
|
adamc@388
|
958 (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@388
|
959 (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc),
|
adamc@388
|
960 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1360
|
961 (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
|
adamc@388
|
962 fm)
|
adamc@388
|
963 | L.EFfi ("Basis", "eq_string") =>
|
adamc@388
|
964 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc),
|
adamc@388
|
965 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@388
|
966 (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc),
|
adamc@388
|
967 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1360
|
968 (L'.EBinop (L'.NotInt, "!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
|
adamc@388
|
969 fm)
|
adamc@821
|
970 | L.EFfi ("Basis", "eq_char") =>
|
adamc@821
|
971 ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc),
|
adamc@821
|
972 (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@821
|
973 (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc),
|
adamc@821
|
974 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1360
|
975 (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
|
adamc@821
|
976 fm)
|
adamc@437
|
977 | L.EFfi ("Basis", "eq_time") =>
|
adamc@437
|
978 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
|
adamc@437
|
979 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@437
|
980 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
|
adamc@437
|
981 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1663
|
982 (L'.EFfiApp ("Basis", "eq_time", [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)),
|
adam@1663
|
983 ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc),
|
adamc@437
|
984 fm)
|
adamc@844
|
985
|
adamc@422
|
986 | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) =>
|
adamc@422
|
987 let
|
adamc@422
|
988 val t = monoType env t
|
adamc@422
|
989 val b = (L'.TFfi ("Basis", "bool"), loc)
|
adamc@422
|
990 val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc)
|
adamc@422
|
991 in
|
adamc@422
|
992 ((L'.EAbs ("f", dom, dom,
|
adamc@422
|
993 (L'.ERel 0, loc)), loc), fm)
|
adamc@422
|
994 end
|
adamc@387
|
995
|
adamc@417
|
996 | L.ECApp ((L.EFfi ("Basis", "zero"), _), t) =>
|
adamc@417
|
997 let
|
adamc@417
|
998 val t = monoType env t
|
adamc@417
|
999 in
|
adamc@417
|
1000 ((L'.EAbs ("r", numTy t, t,
|
adamc@417
|
1001 (L'.EField ((L'.ERel 0, loc), "Zero"), loc)), loc), fm)
|
adamc@417
|
1002 end
|
adamc@389
|
1003 | L.ECApp ((L.EFfi ("Basis", "neg"), _), t) =>
|
adamc@389
|
1004 let
|
adamc@389
|
1005 val t = monoType env t
|
adamc@389
|
1006 in
|
adamc@389
|
1007 ((L'.EAbs ("r", numTy t, (L'.TFun (t, t), loc),
|
adamc@389
|
1008 (L'.EField ((L'.ERel 0, loc), "Neg"), loc)), loc), fm)
|
adamc@389
|
1009 end
|
adamc@389
|
1010 | L.ECApp ((L.EFfi ("Basis", "plus"), _), t) =>
|
adamc@389
|
1011 let
|
adamc@389
|
1012 val t = monoType env t
|
adamc@389
|
1013 in
|
adamc@389
|
1014 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
|
adamc@389
|
1015 (L'.EField ((L'.ERel 0, loc), "Plus"), loc)), loc), fm)
|
adamc@389
|
1016 end
|
adamc@389
|
1017 | L.ECApp ((L.EFfi ("Basis", "minus"), _), t) =>
|
adamc@389
|
1018 let
|
adamc@389
|
1019 val t = monoType env t
|
adamc@389
|
1020 in
|
adamc@389
|
1021 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
|
adamc@389
|
1022 (L'.EField ((L'.ERel 0, loc), "Minus"), loc)), loc), fm)
|
adamc@389
|
1023 end
|
adamc@389
|
1024 | L.ECApp ((L.EFfi ("Basis", "times"), _), t) =>
|
adamc@389
|
1025 let
|
adamc@389
|
1026 val t = monoType env t
|
adamc@389
|
1027 in
|
adamc@389
|
1028 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
|
adamc@389
|
1029 (L'.EField ((L'.ERel 0, loc), "Times"), loc)), loc), fm)
|
adamc@389
|
1030 end
|
adamc@775
|
1031 | L.ECApp ((L.EFfi ("Basis", "divide"), _), t) =>
|
adamc@389
|
1032 let
|
adamc@389
|
1033 val t = monoType env t
|
adamc@389
|
1034 in
|
adamc@389
|
1035 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
|
adamc@389
|
1036 (L'.EField ((L'.ERel 0, loc), "Div"), loc)), loc), fm)
|
adamc@389
|
1037 end
|
adamc@389
|
1038 | L.ECApp ((L.EFfi ("Basis", "mod"), _), t) =>
|
adamc@389
|
1039 let
|
adamc@389
|
1040 val t = monoType env t
|
adamc@389
|
1041 in
|
adamc@389
|
1042 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
|
adamc@389
|
1043 (L'.EField ((L'.ERel 0, loc), "Mod"), loc)), loc), fm)
|
adamc@389
|
1044 end
|
adam@1832
|
1045 | L.ECApp ((L.EFfi ("Basis", "pow"), _), t) =>
|
mad@1831
|
1046 let
|
mad@1831
|
1047 val t = monoType env t
|
mad@1831
|
1048 in
|
mad@1831
|
1049 ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc),
|
adam@1832
|
1050 (L'.EField ((L'.ERel 0, loc), "Pow"), loc)), loc), fm)
|
mad@1831
|
1051 end
|
adamc@389
|
1052 | L.EFfi ("Basis", "num_int") =>
|
adamc@389
|
1053 let
|
adamc@389
|
1054 fun intBin s =
|
adamc@389
|
1055 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
|
adamc@389
|
1056 (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc)), loc),
|
adamc@389
|
1057 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
|
adamc@389
|
1058 (L'.TFfi ("Basis", "int"), loc),
|
adam@1360
|
1059 (L'.EBinop (L'.Int, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
|
adamc@389
|
1060 in
|
adamc@389
|
1061 numEx ((L'.TFfi ("Basis", "int"), loc),
|
adamc@417
|
1062 Prim.Int (Int64.fromInt 0),
|
adamc@389
|
1063 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
|
adamc@389
|
1064 (L'.TFfi ("Basis", "int"), loc),
|
adamc@389
|
1065 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
|
adamc@389
|
1066 intBin "+",
|
adamc@389
|
1067 intBin "-",
|
adamc@389
|
1068 intBin "*",
|
adamc@389
|
1069 intBin "/",
|
mad@1831
|
1070 intBin "%",
|
mad@1831
|
1071 intBin "powl"
|
mad@1831
|
1072 )
|
adamc@389
|
1073 end
|
adamc@390
|
1074 | L.EFfi ("Basis", "num_float") =>
|
adamc@390
|
1075 let
|
adamc@390
|
1076 fun floatBin s =
|
adamc@390
|
1077 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
|
adamc@390
|
1078 (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc)), loc),
|
adamc@390
|
1079 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
|
adamc@390
|
1080 (L'.TFfi ("Basis", "float"), loc),
|
adam@1360
|
1081 (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
|
adamc@390
|
1082 in
|
adamc@390
|
1083 numEx ((L'.TFfi ("Basis", "float"), loc),
|
adamc@417
|
1084 Prim.Float 0.0,
|
adamc@390
|
1085 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
|
adamc@390
|
1086 (L'.TFfi ("Basis", "float"), loc),
|
adamc@390
|
1087 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
|
adamc@390
|
1088 floatBin "+",
|
adamc@390
|
1089 floatBin "-",
|
adamc@390
|
1090 floatBin "*",
|
adam@1619
|
1091 floatBin "fdiv",
|
mad@1831
|
1092 floatBin "fmod",
|
mad@1831
|
1093 floatBin "powf"
|
mad@1831
|
1094 )
|
adamc@390
|
1095 end
|
adamc@391
|
1096
|
adamc@391
|
1097 | L.ECApp ((L.EFfi ("Basis", "lt"), _), t) =>
|
adamc@391
|
1098 let
|
adamc@391
|
1099 val t = monoType env t
|
adamc@391
|
1100 in
|
adamc@391
|
1101 ((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc),
|
adamc@391
|
1102 (L'.EField ((L'.ERel 0, loc), "Lt"), loc)), loc), fm)
|
adamc@391
|
1103 end
|
adamc@391
|
1104 | L.ECApp ((L.EFfi ("Basis", "le"), _), t) =>
|
adamc@391
|
1105 let
|
adamc@391
|
1106 val t = monoType env t
|
adamc@391
|
1107 in
|
adamc@391
|
1108 ((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc),
|
adamc@391
|
1109 (L'.EField ((L'.ERel 0, loc), "Le"), loc)), loc), fm)
|
adamc@391
|
1110 end
|
adamc@392
|
1111 | L.ECApp ((L.EFfi ("Basis", "gt"), _), t) =>
|
adamc@392
|
1112 let
|
adamc@392
|
1113 val t = monoType env t
|
adamc@392
|
1114 val b = (L'.TFfi ("Basis", "bool"), loc)
|
adamc@392
|
1115 in
|
adamc@392
|
1116 ((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc),
|
adamc@392
|
1117 (L'.EAbs ("x", t, (L'.TFun (t, b), loc),
|
adamc@392
|
1118 (L'.EAbs ("y", t, b,
|
adamc@392
|
1119 (L'.EUnop ("!",
|
adamc@392
|
1120 (L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc),
|
adamc@392
|
1121 "Le"), loc),
|
adamc@392
|
1122 (L'.ERel 1, loc)), loc),
|
adamc@392
|
1123 (L'.ERel 0, loc)), loc)), loc)), loc)),
|
adamc@392
|
1124 loc)),
|
adamc@392
|
1125 loc), fm)
|
adamc@392
|
1126 end
|
adamc@392
|
1127 | L.ECApp ((L.EFfi ("Basis", "ge"), _), t) =>
|
adamc@392
|
1128 let
|
adamc@392
|
1129 val t = monoType env t
|
adamc@392
|
1130 val b = (L'.TFfi ("Basis", "bool"), loc)
|
adamc@392
|
1131 in
|
adamc@392
|
1132 ((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc),
|
adamc@392
|
1133 (L'.EAbs ("x", t, (L'.TFun (t, b), loc),
|
adamc@392
|
1134 (L'.EAbs ("y", t, b,
|
adamc@392
|
1135 (L'.EUnop ("!",
|
adamc@392
|
1136 (L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc),
|
adamc@392
|
1137 "Lt"), loc),
|
adamc@392
|
1138 (L'.ERel 1, loc)), loc),
|
adamc@392
|
1139 (L'.ERel 0, loc)), loc)), loc)), loc)),
|
adamc@392
|
1140 loc)),
|
adamc@392
|
1141 loc), fm)
|
adamc@392
|
1142 end
|
adamc@391
|
1143 | L.EFfi ("Basis", "ord_int") =>
|
adamc@391
|
1144 let
|
adamc@391
|
1145 fun intBin s =
|
adamc@391
|
1146 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
|
adamc@391
|
1147 (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@391
|
1148 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
|
adamc@391
|
1149 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1360
|
1150 (L'.EBinop (L'.Int, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
|
adamc@391
|
1151 in
|
adamc@391
|
1152 ordEx ((L'.TFfi ("Basis", "int"), loc),
|
adamc@391
|
1153 intBin "<",
|
adamc@391
|
1154 intBin "<=")
|
adamc@391
|
1155 end
|
adamc@394
|
1156 | L.EFfi ("Basis", "ord_float") =>
|
adamc@394
|
1157 let
|
adamc@394
|
1158 fun floatBin s =
|
adamc@394
|
1159 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
|
adamc@394
|
1160 (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@394
|
1161 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
|
adamc@394
|
1162 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1360
|
1163 (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
|
adamc@394
|
1164 in
|
adamc@394
|
1165 ordEx ((L'.TFfi ("Basis", "float"), loc),
|
adamc@394
|
1166 floatBin "<",
|
adamc@394
|
1167 floatBin "<=")
|
adamc@394
|
1168 end
|
adamc@394
|
1169 | L.EFfi ("Basis", "ord_bool") =>
|
adamc@394
|
1170 let
|
adamc@394
|
1171 fun boolBin s =
|
adamc@394
|
1172 (L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc),
|
adamc@394
|
1173 (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@394
|
1174 (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc),
|
adamc@394
|
1175 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1371
|
1176 (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
|
adamc@394
|
1177 in
|
adamc@394
|
1178 ordEx ((L'.TFfi ("Basis", "bool"), loc),
|
adam@1371
|
1179 boolBin "<",
|
adam@1371
|
1180 boolBin "<=")
|
adamc@394
|
1181 end
|
adamc@395
|
1182 | L.EFfi ("Basis", "ord_string") =>
|
adamc@395
|
1183 let
|
adamc@395
|
1184 fun boolBin s =
|
adamc@395
|
1185 (L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc),
|
adamc@395
|
1186 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@395
|
1187 (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc),
|
adamc@395
|
1188 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1360
|
1189 (L'.EBinop (L'.NotInt, s,
|
adam@1360
|
1190 (L'.EBinop (L'.NotInt, "strcmp",
|
adamc@395
|
1191 (L'.ERel 1, loc),
|
adamc@395
|
1192 (L'.ERel 0, loc)), loc),
|
adamc@395
|
1193 (L'.EPrim (Prim.Int (Int64.fromInt 0)), loc)), loc)), loc)), loc)
|
adamc@395
|
1194 in
|
adamc@395
|
1195 ordEx ((L'.TFfi ("Basis", "string"), loc),
|
adamc@395
|
1196 boolBin "<",
|
adamc@395
|
1197 boolBin "<=")
|
adamc@395
|
1198 end
|
adamc@821
|
1199 | L.EFfi ("Basis", "ord_char") =>
|
adamc@821
|
1200 let
|
adamc@821
|
1201 fun charBin s =
|
adamc@821
|
1202 (L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc),
|
adamc@821
|
1203 (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@821
|
1204 (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc),
|
adamc@821
|
1205 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1360
|
1206 (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
|
adamc@821
|
1207 in
|
adamc@821
|
1208 ordEx ((L'.TFfi ("Basis", "char"), loc),
|
adamc@821
|
1209 charBin "<",
|
adamc@821
|
1210 charBin "<=")
|
adamc@821
|
1211 end
|
adamc@437
|
1212 | L.EFfi ("Basis", "ord_time") =>
|
adamc@437
|
1213 let
|
adamc@437
|
1214 fun boolBin s =
|
adamc@437
|
1215 (L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
|
adamc@437
|
1216 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
|
adamc@437
|
1217 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
|
adamc@437
|
1218 (L'.TFfi ("Basis", "bool"), loc),
|
adam@1663
|
1219 (L'.EFfiApp ("Basis", s, [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)),
|
adam@1663
|
1220 ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc)
|
adamc@437
|
1221 in
|
adamc@437
|
1222 ordEx ((L'.TFfi ("Basis", "time"), loc),
|
adam@1365
|
1223 boolBin "lt_time",
|
adam@1365
|
1224 boolBin "le_time")
|
adamc@437
|
1225 end
|
adamc@961
|
1226 | L.ECApp ((L.EFfi ("Basis", "mkOrd"), _), t) =>
|
adamc@961
|
1227 let
|
adamc@961
|
1228 val t = monoType env t
|
adamc@961
|
1229 val b = (L'.TFfi ("Basis", "bool"), loc)
|
adamc@961
|
1230 val dom = ordTy t
|
adamc@961
|
1231 in
|
adamc@961
|
1232 ((L'.EAbs ("f", dom, dom,
|
adamc@961
|
1233 (L'.ERel 0, loc)), loc), fm)
|
adamc@961
|
1234 end
|
adam@1682
|
1235
|
adamc@286
|
1236 | L.ECApp ((L.EFfi ("Basis", "show"), _), t) =>
|
adamc@286
|
1237 let
|
adamc@286
|
1238 val t = monoType env t
|
adamc@286
|
1239 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@286
|
1240 in
|
adamc@286
|
1241 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
|
adamc@286
|
1242 (L'.ERel 0, loc)), loc), fm)
|
adamc@286
|
1243 end
|
adamc@286
|
1244 | L.EFfi ("Basis", "show_int") =>
|
adamc@286
|
1245 ((L'.EFfi ("Basis", "intToString"), loc), fm)
|
adamc@286
|
1246 | L.EFfi ("Basis", "show_float") =>
|
adamc@286
|
1247 ((L'.EFfi ("Basis", "floatToString"), loc), fm)
|
adamc@286
|
1248 | L.EFfi ("Basis", "show_string") =>
|
adamc@286
|
1249 let
|
adamc@286
|
1250 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@286
|
1251 in
|
adamc@286
|
1252 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
|
adamc@286
|
1253 end
|
adam@1370
|
1254 | L.EFfi ("Basis", "show_queryString") =>
|
adam@1370
|
1255 let
|
adam@1370
|
1256 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1370
|
1257 in
|
adam@1370
|
1258 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
|
adam@1370
|
1259 end
|
adamc@1065
|
1260 | L.EFfi ("Basis", "show_url") =>
|
adamc@1065
|
1261 let
|
adamc@1065
|
1262 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@1065
|
1263 in
|
adamc@1065
|
1264 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
|
adamc@1065
|
1265 end
|
adam@1477
|
1266 | L.EFfi ("Basis", "show_css_class") =>
|
adam@1477
|
1267 let
|
adam@1477
|
1268 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1477
|
1269 in
|
adam@1477
|
1270 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
|
adam@1477
|
1271 end
|
grrwlf@1929
|
1272 | L.EFfi ("Basis", "show_id") =>
|
grrwlf@1929
|
1273 let
|
grrwlf@1929
|
1274 val s = (L'.TFfi ("Basis", "string"), loc)
|
grrwlf@1929
|
1275 in
|
grrwlf@1929
|
1276 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
|
grrwlf@1929
|
1277 end
|
adamc@821
|
1278 | L.EFfi ("Basis", "show_char") =>
|
adamc@821
|
1279 ((L'.EFfi ("Basis", "charToString"), loc), fm)
|
adamc@286
|
1280 | L.EFfi ("Basis", "show_bool") =>
|
adamc@286
|
1281 ((L'.EFfi ("Basis", "boolToString"), loc), fm)
|
adamc@436
|
1282 | L.EFfi ("Basis", "show_time") =>
|
adamc@436
|
1283 ((L'.EFfi ("Basis", "timeToString"), loc), fm)
|
adamc@727
|
1284 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "show_xml"), _), _),_), _), _), _) =>
|
adamc@727
|
1285 let
|
adamc@727
|
1286 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@727
|
1287 in
|
adamc@727
|
1288 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
|
adamc@727
|
1289 end
|
adam@1810
|
1290 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "show_sql_query"), _), _), _), _), _), _), _), _) =>
|
adam@1810
|
1291 let
|
adam@1810
|
1292 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1810
|
1293 in
|
adam@1810
|
1294 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
|
adam@1810
|
1295 end
|
adamc@452
|
1296 | L.ECApp ((L.EFfi ("Basis", "mkShow"), _), t) =>
|
adamc@452
|
1297 let
|
adamc@452
|
1298 val t = monoType env t
|
adamc@452
|
1299 val b = (L'.TFfi ("Basis", "string"), loc)
|
adamc@452
|
1300 val dom = (L'.TFun (t, b), loc)
|
adamc@452
|
1301 in
|
adamc@452
|
1302 ((L'.EAbs ("f", dom, dom,
|
adamc@452
|
1303 (L'.ERel 0, loc)), loc), fm)
|
adamc@452
|
1304 end
|
adamc@286
|
1305
|
adamc@290
|
1306 | L.ECApp ((L.EFfi ("Basis", "read"), _), t) =>
|
adamc@290
|
1307 let
|
adamc@290
|
1308 val t = monoType env t
|
adamc@290
|
1309 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@290
|
1310 in
|
adamc@292
|
1311 ((L'.EAbs ("f", readType (t, loc), readType' (t, loc),
|
adamc@292
|
1312 (L'.EField ((L'.ERel 0, loc), "Read"), loc)), loc), fm)
|
adamc@292
|
1313 end
|
adamc@292
|
1314 | L.ECApp ((L.EFfi ("Basis", "readError"), _), t) =>
|
adamc@292
|
1315 let
|
adamc@292
|
1316 val t = monoType env t
|
adamc@292
|
1317 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@292
|
1318 in
|
adamc@292
|
1319 ((L'.EAbs ("f", readType (t, loc), readErrType (t, loc),
|
adamc@292
|
1320 (L'.EField ((L'.ERel 0, loc), "ReadError"), loc)), loc), fm)
|
adamc@290
|
1321 end
|
adamc@777
|
1322 | L.ECApp ((L.EFfi ("Basis", "mkRead"), _), t) =>
|
adamc@777
|
1323 let
|
adamc@777
|
1324 val t = monoType env t
|
adamc@777
|
1325 val b = (L'.TFfi ("Basis", "string"), loc)
|
adamc@777
|
1326 val b' = (L'.TOption b, loc)
|
adamc@777
|
1327 val dom = (L'.TFun (t, b), loc)
|
adamc@777
|
1328 val dom' = (L'.TFun (t, b'), loc)
|
adamc@777
|
1329 in
|
adamc@777
|
1330 ((L'.EAbs ("f", dom, (L'.TFun (dom', readType (t, loc)), loc),
|
adamc@777
|
1331 (L'.EAbs ("f'", dom', readType (t, loc),
|
adamc@777
|
1332 (L'.ERecord [("Read", (L'.ERel 0, loc), dom),
|
adamc@777
|
1333 ("ReadError", (L'.ERel 1, loc), dom')], loc)), loc)), loc),
|
adamc@777
|
1334 fm)
|
adamc@777
|
1335 end
|
adamc@290
|
1336 | L.EFfi ("Basis", "read_int") =>
|
adamc@292
|
1337 let
|
adamc@292
|
1338 val t = (L'.TFfi ("Basis", "int"), loc)
|
adamc@292
|
1339 in
|
adamc@292
|
1340 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToInt"), loc), readType' (t, loc)),
|
adamc@292
|
1341 ("ReadError", (L'.EFfi ("Basis", "stringToInt_error"), loc), readErrType (t, loc))],
|
adamc@292
|
1342 loc),
|
adamc@292
|
1343 fm)
|
adamc@292
|
1344 end
|
adamc@290
|
1345 | L.EFfi ("Basis", "read_float") =>
|
adamc@292
|
1346 let
|
adamc@292
|
1347 val t = (L'.TFfi ("Basis", "float"), loc)
|
adamc@292
|
1348 in
|
adamc@292
|
1349 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToFloat"), loc), readType' (t, loc)),
|
adamc@292
|
1350 ("ReadError", (L'.EFfi ("Basis", "stringToFloat_error"), loc), readErrType (t, loc))],
|
adamc@292
|
1351 loc),
|
adamc@292
|
1352 fm)
|
adamc@292
|
1353 end
|
adamc@290
|
1354 | L.EFfi ("Basis", "read_string") =>
|
adamc@290
|
1355 let
|
adamc@290
|
1356 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@290
|
1357 in
|
adamc@292
|
1358 ((L'.ERecord [("Read", (L'.EAbs ("s", s, (L'.TOption s, loc),
|
adamc@292
|
1359 (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), readType' (s, loc)),
|
adamc@292
|
1360 ("ReadError", (L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), readErrType (s, loc))], loc),
|
adamc@292
|
1361 fm)
|
adamc@290
|
1362 end
|
adamc@821
|
1363 | L.EFfi ("Basis", "read_char") =>
|
adamc@821
|
1364 let
|
adamc@821
|
1365 val t = (L'.TFfi ("Basis", "char"), loc)
|
adamc@821
|
1366 in
|
adamc@821
|
1367 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToChar"), loc), readType' (t, loc)),
|
adamc@821
|
1368 ("ReadError", (L'.EFfi ("Basis", "stringToChar_error"), loc), readErrType (t, loc))],
|
adamc@821
|
1369 loc),
|
adamc@821
|
1370 fm)
|
adamc@821
|
1371 end
|
adamc@290
|
1372 | L.EFfi ("Basis", "read_bool") =>
|
adamc@292
|
1373 let
|
adamc@292
|
1374 val t = (L'.TFfi ("Basis", "bool"), loc)
|
adamc@292
|
1375 in
|
adamc@292
|
1376 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToBool"), loc), readType' (t, loc)),
|
adamc@292
|
1377 ("ReadError", (L'.EFfi ("Basis", "stringToBool_error"), loc), readErrType (t, loc))],
|
adamc@292
|
1378 loc),
|
adamc@292
|
1379 fm)
|
adamc@292
|
1380 end
|
adamc@436
|
1381 | L.EFfi ("Basis", "read_time") =>
|
adamc@436
|
1382 let
|
adamc@436
|
1383 val t = (L'.TFfi ("Basis", "time"), loc)
|
adamc@436
|
1384 in
|
adamc@436
|
1385 ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToTime"), loc), readType' (t, loc)),
|
adamc@436
|
1386 ("ReadError", (L'.EFfi ("Basis", "stringToTime_error"), loc), readErrType (t, loc))],
|
adamc@436
|
1387 loc),
|
adamc@436
|
1388 fm)
|
adamc@436
|
1389 end
|
adamc@290
|
1390
|
adam@1544
|
1391 | L.ECApp ((L.EFfi ("Basis", "transaction_return"), _), t) =>
|
adamc@252
|
1392 let
|
adamc@252
|
1393 val t = monoType env t
|
adamc@252
|
1394 in
|
adam@1544
|
1395 ((L'.EAbs ("x", t,
|
adamc@820
|
1396 (L'.TFun ((L'.TRecord [], loc), t), loc),
|
adamc@820
|
1397 (L'.EAbs ("_", (L'.TRecord [], loc), t,
|
adam@1544
|
1398 (L'.ERel 1, loc)), loc)), loc),
|
adamc@820
|
1399 fm)
|
adamc@252
|
1400 end
|
adam@1544
|
1401 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "transaction_bind"), _), t1), _), t2) =>
|
adamc@251
|
1402 let
|
adamc@251
|
1403 val t1 = monoType env t1
|
adamc@251
|
1404 val t2 = monoType env t2
|
adamc@251
|
1405 val un = (L'.TRecord [], loc)
|
adamc@252
|
1406 val mt1 = (L'.TFun (un, t1), loc)
|
adamc@252
|
1407 val mt2 = (L'.TFun (un, t2), loc)
|
adamc@251
|
1408 in
|
adam@1544
|
1409 ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc),
|
adam@1544
|
1410 (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
|
adam@1544
|
1411 (L'.EAbs ("_", un, un,
|
adam@1544
|
1412 (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
|
adam@1544
|
1413 (L'.ERecord [], loc)), loc),
|
adam@1544
|
1414 (L'.EApp (
|
adam@1544
|
1415 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
|
adam@1544
|
1416 (L'.ERecord [], loc)),
|
adam@1544
|
1417 loc)), loc)), loc)), loc)), loc),
|
adamc@251
|
1418 fm)
|
adamc@251
|
1419 end
|
adamc@697
|
1420
|
adamc@1021
|
1421 | L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _), ch) =>
|
adamc@670
|
1422 let
|
adamc@1021
|
1423 val un = (L'.TRecord [], loc)
|
adamc@670
|
1424 val t1 = monoType env t1
|
adamc@670
|
1425 val (ch, fm) = monoExp (env, st, fm) ch
|
adamc@670
|
1426 in
|
adamc@1021
|
1427 ((L'.EAbs ("_", un, un, (L'.ERecv (liftExpInExp 0 ch, t1), loc)), loc), fm)
|
adamc@670
|
1428 end
|
adamc@697
|
1429 | L.EFfiApp ("Basis", "recv", _) => poly ()
|
adamc@697
|
1430
|
adam@1663
|
1431 | L.EFfiApp ("Basis", "float", [(e, t)]) =>
|
adam@1571
|
1432 let
|
adam@1571
|
1433 val (e, fm) = monoExp (env, st, fm) e
|
adam@1571
|
1434 in
|
adam@1663
|
1435 ((L'.EFfiApp ("Basis", "floatFromInt", [(e, monoType env t)]), loc), fm)
|
adam@1571
|
1436 end
|
adam@1571
|
1437
|
adam@1663
|
1438 | L.EFfiApp ("Basis", "sleep", [(n, _)]) =>
|
adamc@695
|
1439 let
|
adamc@695
|
1440 val (n, fm) = monoExp (env, st, fm) n
|
adamc@695
|
1441 in
|
adamc@1021
|
1442 ((L'.ESleep n, loc), fm)
|
adamc@695
|
1443 end
|
adamc@697
|
1444 | L.EFfiApp ("Basis", "sleep", _) => poly ()
|
adamc@251
|
1445
|
adamc@565
|
1446 | L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
|
adamc@565
|
1447 let
|
adamc@565
|
1448 val t = monoType env t
|
adamc@565
|
1449 in
|
adamc@577
|
1450 ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
|
adamc@577
|
1451 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
|
adamc@577
|
1452 (L'.EFfiApp ("Basis", "new_client_source",
|
adam@1663
|
1453 [((L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc),
|
adam@1663
|
1454 (L'.TSource, loc))]),
|
adamc@578
|
1455 loc)), loc)),
|
adamc@565
|
1456 loc),
|
adamc@565
|
1457 fm)
|
adamc@565
|
1458 end
|
adamc@575
|
1459 | L.ECApp ((L.EFfi ("Basis", "set"), _), t) =>
|
adamc@575
|
1460 let
|
adamc@575
|
1461 val t = monoType env t
|
adamc@575
|
1462 in
|
adamc@577
|
1463 ((L'.EAbs ("src", (L'.TSource, loc),
|
adamc@575
|
1464 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
|
adamc@575
|
1465 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
|
adamc@575
|
1466 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
adamc@575
|
1467 (L'.EFfiApp ("Basis", "set_client_source",
|
adam@1663
|
1468 [((L'.ERel 2, loc), (L'.TSource, loc)),
|
adam@1663
|
1469 ((L'.EJavaScript (L'.Source t,
|
adam@1663
|
1470 (L'.ERel 1, loc)), loc),
|
adam@1664
|
1471 (L'.TFfi ("Basis", "string"), loc))]),
|
adamc@575
|
1472 loc)), loc)), loc)), loc),
|
adamc@575
|
1473 fm)
|
adamc@575
|
1474 end
|
adamc@601
|
1475 | L.ECApp ((L.EFfi ("Basis", "get"), _), t) =>
|
adamc@601
|
1476 let
|
adamc@601
|
1477 val t = monoType env t
|
adamc@601
|
1478 in
|
adamc@601
|
1479 ((L'.EAbs ("src", (L'.TSource, loc),
|
adamc@601
|
1480 (L'.TFun ((L'.TRecord [], loc), t), loc),
|
adamc@601
|
1481 (L'.EAbs ("_", (L'.TRecord [], loc), t,
|
adamc@601
|
1482 (L'.EFfiApp ("Basis", "get_client_source",
|
adam@1663
|
1483 [((L'.ERel 1, loc), (L'.TSource, loc))]),
|
adamc@601
|
1484 loc)), loc)), loc),
|
adamc@601
|
1485 fm)
|
adamc@601
|
1486 end
|
adamc@841
|
1487 | L.ECApp ((L.EFfi ("Basis", "current"), _), t) =>
|
adamc@841
|
1488 let
|
adamc@841
|
1489 val t = monoType env t
|
adamc@841
|
1490 in
|
adamc@841
|
1491 ((L'.EAbs ("src", (L'.TSource, loc),
|
adamc@841
|
1492 (L'.TFun ((L'.TRecord [], loc), t), loc),
|
adamc@841
|
1493 (L'.EAbs ("_", (L'.TRecord [], loc), t,
|
adamc@841
|
1494 (L'.EFfiApp ("Basis", "current",
|
adam@1663
|
1495 [((L'.ERel 1, loc), (L'.TSource, loc))]),
|
adamc@841
|
1496 loc)), loc)), loc),
|
adamc@841
|
1497 fm)
|
adamc@841
|
1498 end
|
adamc@565
|
1499
|
adam@1663
|
1500 | L.EFfiApp ("Basis", "spawn", [(e, _)]) =>
|
adamc@694
|
1501 let
|
adamc@694
|
1502 val (e, fm) = monoExp (env, st, fm) e
|
adamc@694
|
1503 in
|
adamc@1021
|
1504 ((L'.ESpawn e, loc), fm)
|
adamc@694
|
1505 end
|
adamc@694
|
1506
|
adam@1544
|
1507 | L.ECApp ((L.EFfi ("Basis", "signal_return"), _), t) =>
|
adamc@568
|
1508 let
|
adamc@568
|
1509 val t = monoType env t
|
adamc@568
|
1510 in
|
adam@1544
|
1511 ((L'.EAbs ("x", t, (L'.TSignal t, loc),
|
adam@1544
|
1512 (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc),
|
adamc@568
|
1513 fm)
|
adamc@568
|
1514 end
|
adam@1544
|
1515 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "signal_bind"), _), t1), _), t2) =>
|
adamc@572
|
1516 let
|
adamc@572
|
1517 val t1 = monoType env t1
|
adamc@572
|
1518 val t2 = monoType env t2
|
adamc@572
|
1519 val un = (L'.TRecord [], loc)
|
adamc@572
|
1520 val mt1 = (L'.TSignal t1, loc)
|
adamc@572
|
1521 val mt2 = (L'.TSignal t2, loc)
|
adamc@572
|
1522 in
|
adam@1544
|
1523 ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc),
|
adam@1544
|
1524 (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2,
|
adam@1544
|
1525 (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
|
adamc@572
|
1526 fm)
|
adamc@572
|
1527 end
|
adamc@574
|
1528 | L.ECApp ((L.EFfi ("Basis", "signal"), _), t) =>
|
adamc@574
|
1529 let
|
adamc@574
|
1530 val t = monoType env t
|
adamc@574
|
1531 in
|
adamc@574
|
1532 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TSignal t, loc),
|
adamc@574
|
1533 (L'.ESignalSource (L'.ERel 0, loc), loc)), loc),
|
adamc@574
|
1534 fm)
|
adamc@574
|
1535 end
|
adamc@568
|
1536
|
adamc@462
|
1537 | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
|
adamc@462
|
1538 let
|
adamc@462
|
1539 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@462
|
1540 val un = (L'.TRecord [], loc)
|
adamc@462
|
1541 val t = monoType env t
|
adamc@462
|
1542 in
|
adamc@462
|
1543 ((L'.EAbs ("c", s, (L'.TFun (un, s), loc),
|
adamc@462
|
1544 (L'.EAbs ("_", un, s,
|
adam@1663
|
1545 (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [((L'.ERel 1, loc), s)]), loc),
|
adamc@1112
|
1546 t, true),
|
adamc@463
|
1547 loc)), loc)), loc),
|
adamc@462
|
1548 fm)
|
adamc@462
|
1549 end
|
adamc@462
|
1550
|
adamc@462
|
1551 | L.ECApp ((L.EFfi ("Basis", "setCookie"), _), t) =>
|
adamc@462
|
1552 let
|
adamc@462
|
1553 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@462
|
1554 val un = (L'.TRecord [], loc)
|
adamc@462
|
1555 val t = monoType env t
|
adamc@1050
|
1556 val rt = (L'.TRecord [("Value", t),
|
adamc@1050
|
1557 ("Expires", (L'.TOption (L'.TFfi ("Basis", "time"),
|
adamc@1050
|
1558 loc), loc)),
|
adamc@1050
|
1559 ("Secure", (L'.TFfi ("Basis", "bool"), loc))], loc)
|
adamc@1050
|
1560
|
adamc@1050
|
1561 fun fd x = (L'.EField ((L'.ERel 1, loc), x), loc)
|
adamc@1050
|
1562 val (e, fm) = urlifyExp env fm (fd "Value", t)
|
adamc@462
|
1563 in
|
adamc@1050
|
1564 ((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc),
|
adamc@1050
|
1565 (L'.EAbs ("r", rt, (L'.TFun (un, un), loc),
|
adamc@462
|
1566 (L'.EAbs ("_", un, un,
|
adam@1663
|
1567 (L'.EFfiApp ("Basis", "set_cookie", [((L'.EPrim (Prim.String
|
adam@1663
|
1568 (Settings.getUrlPrefix ())),
|
adam@1663
|
1569 loc), s),
|
adam@1663
|
1570 ((L'.ERel 2, loc), s),
|
adam@1663
|
1571 (e, s),
|
adam@1663
|
1572 (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)),
|
adam@1663
|
1573 (fd "Secure", (L'.TFfi ("Basis", "bool"), loc))])
|
adamc@1050
|
1574 , loc)), loc)), loc)), loc),
|
adamc@1050
|
1575 fm)
|
adamc@1050
|
1576 end
|
adamc@1050
|
1577
|
adamc@1050
|
1578 | L.ECApp ((L.EFfi ("Basis", "clearCookie"), _), t) =>
|
adamc@1050
|
1579 let
|
adamc@1050
|
1580 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@1050
|
1581 val un = (L'.TRecord [], loc)
|
adamc@1050
|
1582 in
|
adamc@1050
|
1583 ((L'.EAbs ("c", s, (L'.TFun (un, un), loc),
|
adamc@1050
|
1584 (L'.EAbs ("_", un, un,
|
adamc@1050
|
1585 (L'.EFfiApp ("Basis", "clear_cookie",
|
adam@1663
|
1586 [((L'.EPrim (Prim.String
|
adam@1663
|
1587 (Settings.getUrlPrefix ())),
|
adam@1663
|
1588 loc), s),
|
adam@1663
|
1589 ((L'.ERel 1, loc), s)]),
|
adamc@462
|
1590 loc)), loc)), loc),
|
adamc@462
|
1591 fm)
|
adamc@1050
|
1592 end
|
adamc@462
|
1593
|
adamc@668
|
1594 | L.ECApp ((L.EFfi ("Basis", "channel"), _), t) =>
|
adamc@668
|
1595 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc),
|
adam@1663
|
1596 (L'.EFfiApp ("Basis", "new_channel", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)), loc),
|
adamc@668
|
1597 fm)
|
adamc@668
|
1598 | L.ECApp ((L.EFfi ("Basis", "send"), _), t) =>
|
adamc@668
|
1599 let
|
adamc@668
|
1600 val t = monoType env t
|
adamc@668
|
1601 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t)
|
adamc@668
|
1602 in
|
adamc@668
|
1603 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "channel"), loc),
|
adamc@668
|
1604 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
|
adamc@668
|
1605 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
|
adamc@668
|
1606 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
adamc@668
|
1607 (L'.EFfiApp ("Basis", "send",
|
adam@1663
|
1608 [((L'.ERel 2, loc), (L'.TFfi ("Basis", "channel"), loc)),
|
adam@1663
|
1609 (e, (L'.TFfi ("Basis", "string"), loc))]),
|
adamc@668
|
1610 loc)), loc)), loc)), loc),
|
adamc@668
|
1611 fm)
|
adamc@668
|
1612 end
|
adamc@668
|
1613
|
adamc@707
|
1614 | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) =>
|
adamc@707
|
1615 ((L'.EPrim (Prim.String ""), loc),
|
adamc@707
|
1616 fm)
|
adamc@707
|
1617 | L.ECApp (
|
adamc@707
|
1618 (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _),
|
adamc@707
|
1619 nm), _),
|
adamc@707
|
1620 (L.CRecord (_, unique), _)) =>
|
adamc@707
|
1621 let
|
adamc@707
|
1622 val unique = (nm, t) :: unique
|
adamc@707
|
1623 val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc)
|
adamc@707
|
1624 in
|
adamc@707
|
1625 ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc),
|
adamc@707
|
1626 (L'.EPrim (Prim.String
|
adamc@707
|
1627 (String.concatWith ", "
|
adamc@877
|
1628 (map (fn (x, _) =>
|
adam@1953
|
1629 Settings.mangleSql (monoNameLc env x)
|
adamc@877
|
1630 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
|
adamc@877
|
1631 andalso isBlobby t then
|
adamc@877
|
1632 "(767)"
|
adamc@877
|
1633 else
|
adamc@877
|
1634 "")) unique))),
|
adamc@707
|
1635 loc)), loc),
|
adamc@707
|
1636 fm)
|
adamc@707
|
1637 end
|
adamc@707
|
1638
|
adamc@704
|
1639 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
|
adamc@704
|
1640 ((L'.ERecord [], loc),
|
adamc@704
|
1641 fm)
|
adamc@705
|
1642 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), _), _), (L.CName name, _)) =>
|
adamc@704
|
1643 ((L'.EAbs ("c",
|
adamc@704
|
1644 (L'.TFfi ("Basis", "string"), loc),
|
adamc@704
|
1645 (L'.TFfi ("Basis", "sql_constraints"), loc),
|
adamc@704
|
1646 (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc),
|
adamc@704
|
1647 fm)
|
adamc@705
|
1648 | L.ECApp (
|
adamc@705
|
1649 (L.ECApp (
|
adamc@705
|
1650 (L.ECApp (
|
adamc@705
|
1651 (L.EFfi ("Basis", "join_constraints"), _),
|
adamc@705
|
1652 _), _),
|
adamc@705
|
1653 _), _),
|
adamc@705
|
1654 _) =>
|
adamc@704
|
1655 let
|
adamc@704
|
1656 val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc)
|
adamc@704
|
1657 in
|
adamc@704
|
1658 ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc),
|
adamc@704
|
1659 (L'.EAbs ("cs2", constraints, constraints,
|
adamc@704
|
1660 (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
|
adamc@704
|
1661 fm)
|
adamc@704
|
1662 end
|
adamc@704
|
1663
|
adamc@705
|
1664 | L.ECApp (
|
adamc@705
|
1665 (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), t), _),
|
adamc@705
|
1666 nm), _),
|
adamc@705
|
1667 (L.CRecord (_, unique), _)) =>
|
adamc@705
|
1668 let
|
adamc@705
|
1669 val unique = (nm, t) :: unique
|
adamc@705
|
1670 in
|
adamc@705
|
1671 ((L'.EPrim (Prim.String ("UNIQUE ("
|
adamc@877
|
1672 ^ String.concatWith ", "
|
adam@1953
|
1673 (map (fn (x, t) => Settings.mangleSql (monoNameLc env x)
|
adamc@877
|
1674 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
|
adamc@877
|
1675 andalso isBlobby t then
|
adamc@877
|
1676 "(767)"
|
adamc@877
|
1677 else
|
adamc@877
|
1678 "")) unique)
|
adamc@705
|
1679 ^ ")")), loc),
|
adamc@705
|
1680 fm)
|
adamc@705
|
1681 end
|
adamc@704
|
1682
|
adamc@712
|
1683 | L.ECApp ((L.EFfi ("Basis", "linkable_same"), loc), _) =>
|
adamc@712
|
1684 ((L'.ERecord [], loc), fm)
|
adamc@712
|
1685 | L.ECApp ((L.EFfi ("Basis", "linkable_from_nullable"), loc), _) =>
|
adamc@712
|
1686 ((L'.ERecord [], loc), fm)
|
adamc@712
|
1687 | L.ECApp ((L.EFfi ("Basis", "linkable_to_nullable"), loc), _) =>
|
adamc@712
|
1688 ((L'.ERecord [], loc), fm)
|
adamc@712
|
1689
|
adamc@709
|
1690 | L.EFfi ("Basis", "mat_nil") =>
|
adamc@709
|
1691 let
|
adamc@709
|
1692 val string = (L'.TFfi ("Basis", "string"), loc)
|
adamc@709
|
1693 val stringE = (L'.EPrim (Prim.String ""), loc)
|
adamc@709
|
1694 in
|
adamc@709
|
1695 ((L'.ERecord [("1", stringE, string),
|
adamc@709
|
1696 ("2", stringE, string)], loc), fm)
|
adamc@709
|
1697 end
|
adamc@709
|
1698 | L.ECApp (
|
adamc@709
|
1699 (L.ECApp (
|
adamc@709
|
1700 (L.ECApp (
|
adamc@709
|
1701 (L.ECApp (
|
adamc@709
|
1702 (L.ECApp (
|
adamc@712
|
1703 (L.ECApp (
|
adamc@712
|
1704 (L.EFfi ("Basis", "mat_cons"), _),
|
adamc@712
|
1705 _), _),
|
adamc@709
|
1706 _), _),
|
adamc@709
|
1707 _), _),
|
adamc@709
|
1708 _), _),
|
adamc@709
|
1709 (L.CName nm1, _)), _),
|
adamc@709
|
1710 (L.CName nm2, _)) =>
|
adamc@709
|
1711 let
|
adamc@709
|
1712 val string = (L'.TFfi ("Basis", "string"), loc)
|
adamc@709
|
1713 val mat = (L'.TRecord [("1", string), ("2", string)], loc)
|
adamc@709
|
1714 in
|
adamc@712
|
1715 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc),
|
adamc@712
|
1716 (L'.EAbs ("m", mat, mat,
|
adamc@712
|
1717 (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
|
adamc@712
|
1718 [((L'.PPrim (Prim.String ""), loc),
|
adam@1953
|
1719 (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))),
|
adamc@712
|
1720 loc), string),
|
adam@1953
|
1721 ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))),
|
adamc@712
|
1722 loc), string)], loc)),
|
adamc@712
|
1723 ((L'.PWild, loc),
|
adamc@712
|
1724 (L'.ERecord [("1", (L'.EStrcat (
|
adam@1953
|
1725 (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1)
|
adamc@877
|
1726 ^ ", ")),
|
adamc@712
|
1727 loc),
|
adamc@712
|
1728 (L'.EField ((L'.ERel 0, loc), "1"), loc)),
|
adamc@712
|
1729 loc), string),
|
adamc@712
|
1730 ("2", (L'.EStrcat (
|
adam@1953
|
1731 (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2)
|
adamc@877
|
1732 ^ ", ")), loc),
|
adamc@712
|
1733 (L'.EField ((L'.ERel 0, loc), "2"), loc)),
|
adamc@712
|
1734 loc), string)],
|
adamc@712
|
1735 loc))],
|
adamc@712
|
1736 {disc = string,
|
adamc@712
|
1737 result = mat}), loc)), loc)), loc),
|
adamc@709
|
1738 fm)
|
adamc@709
|
1739 end
|
adamc@709
|
1740
|
adamc@709
|
1741 | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => ((L'.EPrim (Prim.String "RESTRICT"), loc), fm)
|
adamc@709
|
1742 | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => ((L'.EPrim (Prim.String "CASCADE"), loc), fm)
|
adamc@709
|
1743 | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => ((L'.EPrim (Prim.String "NO ACTION"), loc), fm)
|
adamc@709
|
1744 | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => ((L'.EPrim (Prim.String "SET NULL"), loc), fm)
|
adamc@709
|
1745
|
adamc@709
|
1746 | L.ECApp (
|
adamc@709
|
1747 (L.ECApp (
|
adamc@709
|
1748 (L.ECApp (
|
adamc@709
|
1749 (L.ECApp (
|
adamc@709
|
1750 (L.ECApp (
|
adamc@709
|
1751 (L.ECApp (
|
adamc@709
|
1752 (L.ECApp (
|
adamc@709
|
1753 (L.ECApp (
|
adamc@709
|
1754 (L.EFfi ("Basis", "foreign_key"), _),
|
adamc@709
|
1755 _), _),
|
adamc@709
|
1756 _), _),
|
adamc@709
|
1757 _), _),
|
adamc@709
|
1758 _), _),
|
adamc@709
|
1759 _), _),
|
adamc@709
|
1760 _), _),
|
adamc@709
|
1761 _), _),
|
adamc@709
|
1762 _) =>
|
adamc@709
|
1763 let
|
adamc@709
|
1764 val unit = (L'.TRecord [], loc)
|
adamc@709
|
1765 val string = (L'.TFfi ("Basis", "string"), loc)
|
adamc@709
|
1766 val mat = (L'.TRecord [("1", string), ("2", string)], loc)
|
adamc@709
|
1767 val recd = (L'.TRecord [("OnDelete", string),
|
adamc@709
|
1768 ("OnUpdate", string)], loc)
|
adamc@709
|
1769
|
adamc@709
|
1770 fun strcat [] = raise Fail "Monoize.strcat"
|
adamc@709
|
1771 | strcat [e] = e
|
adamc@709
|
1772 | strcat (e1 :: es) = (L'.EStrcat (e1, strcat es), loc)
|
adamc@709
|
1773
|
adamc@709
|
1774 fun prop (fd, kw) =
|
adamc@709
|
1775 (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc),
|
adamc@709
|
1776 [((L'.PPrim (Prim.String "NO ACTION"), loc),
|
adamc@709
|
1777 (L'.EPrim (Prim.String ""), loc)),
|
adamc@709
|
1778 ((L'.PWild, loc),
|
adamc@709
|
1779 strcat [(L'.EPrim (Prim.String (" ON " ^ kw ^ " ")), loc),
|
adamc@709
|
1780 (L'.EField ((L'.ERel 0, loc), fd), loc)])],
|
adamc@709
|
1781 {disc = string,
|
adamc@709
|
1782 result = string}), loc)
|
adamc@709
|
1783 in
|
adamc@709
|
1784 ((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc),
|
adamc@709
|
1785 (L'.EAbs ("tab", string, (L'.TFun (recd, string), loc),
|
adamc@709
|
1786 (L'.EAbs ("pr", recd, string,
|
adamc@709
|
1787 strcat [(L'.EPrim (Prim.String "FOREIGN KEY ("), loc),
|
adamc@709
|
1788 (L'.EField ((L'.ERel 2, loc), "1"), loc),
|
adamc@709
|
1789 (L'.EPrim (Prim.String ") REFERENCES "), loc),
|
adamc@709
|
1790 (L'.ERel 1, loc),
|
adamc@709
|
1791 (L'.EPrim (Prim.String " ("), loc),
|
adamc@709
|
1792 (L'.EField ((L'.ERel 2, loc), "2"), loc),
|
adamc@709
|
1793 (L'.EPrim (Prim.String ")"), loc),
|
adamc@709
|
1794 prop ("OnDelete", "DELETE"),
|
adamc@709
|
1795 prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc),
|
adamc@709
|
1796 fm)
|
adamc@709
|
1797 end
|
adamc@709
|
1798
|
adamc@1072
|
1799 | L.ECApp (
|
adamc@1072
|
1800 (L.ECApp (
|
adamc@1072
|
1801 (L.ECApp (
|
adamc@1072
|
1802 (L.ECApp (
|
adamc@1072
|
1803 (L.ECApp (
|
adamc@1072
|
1804 (L.ECApp (
|
adamc@1072
|
1805 (L.ECApp (
|
adamc@1072
|
1806 (L.EFfi ("Basis", "sql_exp_weaken"), _),
|
adamc@1072
|
1807 _), _),
|
adamc@1072
|
1808 _), _),
|
adamc@1072
|
1809 _), _),
|
adamc@1072
|
1810 _), _),
|
adamc@1072
|
1811 _), _),
|
adamc@1072
|
1812 _), _),
|
adamc@1072
|
1813 _) =>
|
adamc@1072
|
1814 let
|
adamc@1072
|
1815 val string = (L'.TFfi ("Basis", "string"), loc)
|
adamc@1072
|
1816 in
|
adamc@1072
|
1817 ((L'.EAbs ("e", string, string, (L'.ERel 0, loc)), loc),
|
adamc@1072
|
1818 fm)
|
adamc@1072
|
1819 end
|
adamc@1072
|
1820
|
adamc@714
|
1821 | L.ECApp ((L.EFfi ("Basis", "check"), _), _) =>
|
adamc@714
|
1822 let
|
adamc@714
|
1823 val string = (L'.TFfi ("Basis", "string"), loc)
|
adamc@714
|
1824 in
|
adamc@714
|
1825 ((L'.EAbs ("e", string, string,
|
adamc@714
|
1826 (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc),
|
adamc@714
|
1827 (L'.EFfiApp ("Basis", "checkString",
|
adam@1663
|
1828 [((L'.ERel 0, loc), string)]), loc)), loc)), loc),
|
adamc@714
|
1829 fm)
|
adamc@714
|
1830 end
|
adamc@714
|
1831
|
adam@1663
|
1832 | L.EFfiApp ("Basis", "dml", [(e, _)]) =>
|
adamc@307
|
1833 let
|
adamc@307
|
1834 val (e, fm) = monoExp (env, st, fm) e
|
adamc@307
|
1835 in
|
adam@1293
|
1836 ((L'.EDml (e, L'.Error), loc),
|
adam@1293
|
1837 fm)
|
adam@1293
|
1838 end
|
adam@1293
|
1839
|
adam@1663
|
1840 | L.EFfiApp ("Basis", "tryDml", [(e, _)]) =>
|
adam@1293
|
1841 let
|
adam@1293
|
1842 val (e, fm) = monoExp (env, st, fm) e
|
adam@1293
|
1843 in
|
adam@1293
|
1844 ((L'.EDml (e, L'.None), loc),
|
adamc@307
|
1845 fm)
|
adamc@307
|
1846 end
|
adamc@308
|
1847
|
adamc@705
|
1848 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "insert"), _), fields), _), _) =>
|
adamc@307
|
1849 (case monoType env (L.TRecord fields, loc) of
|
adamc@307
|
1850 (L'.TRecord fields, _) =>
|
adamc@307
|
1851 let
|
adamc@307
|
1852 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@307
|
1853 val fields = map (fn (x, _) => (x, s)) fields
|
adamc@307
|
1854 val rt = (L'.TRecord fields, loc)
|
adamc@307
|
1855 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@307
|
1856 in
|
adamc@307
|
1857 ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc),
|
adamc@307
|
1858 (L'.EAbs ("fs", rt, s,
|
adamc@598
|
1859 strcat [sc "INSERT INTO ",
|
adamc@598
|
1860 (L'.ERel 1, loc),
|
adamc@598
|
1861 sc " (",
|
adam@1953
|
1862 strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields),
|
adamc@598
|
1863 sc ") VALUES (",
|
adamc@598
|
1864 strcatComma (map (fn (x, _) =>
|
adamc@598
|
1865 (L'.EField ((L'.ERel 0, loc),
|
adamc@598
|
1866 x), loc)) fields),
|
adamc@598
|
1867 sc ")"]), loc)), loc),
|
adamc@307
|
1868 fm)
|
adamc@307
|
1869 end
|
adamc@307
|
1870 | _ => poly ())
|
adamc@307
|
1871
|
adamc@705
|
1872 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) =>
|
adamc@308
|
1873 (case monoType env (L.TRecord changed, loc) of
|
adamc@308
|
1874 (L'.TRecord changed, _) =>
|
adamc@308
|
1875 let
|
adamc@308
|
1876 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@308
|
1877 val changed = map (fn (x, _) => (x, s)) changed
|
adamc@308
|
1878 val rt = (L'.TRecord changed, loc)
|
adamc@308
|
1879 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@308
|
1880 in
|
adamc@308
|
1881 ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@308
|
1882 (L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
|
adamc@308
|
1883 (L'.EAbs ("e", s, s,
|
adamc@886
|
1884 if #supportsUpdateAs (Settings.currentDbms ()) then
|
adamc@886
|
1885 strcat [sc "UPDATE ",
|
adamc@886
|
1886 (L'.ERel 1, loc),
|
adamc@986
|
1887 sc " AS T_T SET ",
|
adamc@886
|
1888 strcatComma (map (fn (x, _) =>
|
adam@1953
|
1889 strcat [sc (Settings.mangleSql x
|
adamc@886
|
1890 ^ " = "),
|
adamc@886
|
1891 (L'.EField
|
adamc@886
|
1892 ((L'.ERel 2,
|
adamc@886
|
1893 loc),
|
adamc@886
|
1894 x), loc)])
|
adamc@886
|
1895 changed),
|
adamc@886
|
1896 sc " WHERE ",
|
adamc@886
|
1897 (L'.ERel 0, loc)]
|
adamc@886
|
1898 else
|
adamc@886
|
1899 strcat [sc "UPDATE ",
|
adamc@886
|
1900 (L'.ERel 1, loc),
|
adamc@886
|
1901 sc " SET ",
|
adamc@886
|
1902 strcatComma (map (fn (x, _) =>
|
adam@1953
|
1903 strcat [sc (Settings.mangleSql x
|
adamc@886
|
1904 ^ " = "),
|
adam@1466
|
1905 (L'.EFfiApp ("Basis", "unAs",
|
adam@1663
|
1906 [((L'.EField
|
adam@1663
|
1907 ((L'.ERel 2,
|
adam@1663
|
1908 loc),
|
adam@1663
|
1909 x), loc),
|
adam@1663
|
1910 s)]), loc)])
|
adamc@886
|
1911 changed),
|
adamc@886
|
1912 sc " WHERE ",
|
adam@1663
|
1913 (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]),
|
adamc@886
|
1914 loc)), loc)), loc),
|
adamc@308
|
1915 fm)
|
adamc@308
|
1916 end
|
adamc@308
|
1917 | _ => poly ())
|
adamc@308
|
1918
|
adamc@705
|
1919 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) =>
|
adamc@309
|
1920 let
|
adamc@309
|
1921 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@309
|
1922 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@309
|
1923 in
|
adamc@309
|
1924 ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
|
adamc@309
|
1925 (L'.EAbs ("e", s, s,
|
adamc@874
|
1926 if #supportsDeleteAs (Settings.currentDbms ()) then
|
adamc@874
|
1927 strcat [sc "DELETE FROM ",
|
adamc@874
|
1928 (L'.ERel 1, loc),
|
adamc@986
|
1929 sc " AS T_T WHERE ",
|
adamc@874
|
1930 (L'.ERel 0, loc)]
|
adamc@874
|
1931 else
|
adamc@874
|
1932 strcat [sc "DELETE FROM ",
|
adamc@874
|
1933 (L'.ERel 1, loc),
|
adamc@874
|
1934 sc " WHERE ",
|
adam@1663
|
1935 (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc),
|
adamc@309
|
1936 fm)
|
adamc@309
|
1937 end
|
adamc@309
|
1938
|
adamc@252
|
1939 | L.ECApp (
|
adamc@252
|
1940 (L.ECApp (
|
adamc@252
|
1941 (L.ECApp ((L.EFfi ("Basis", "query"), _), (L.CRecord (_, tables), _)), _),
|
adamc@252
|
1942 exps), _),
|
adamc@252
|
1943 state) =>
|
adamc@252
|
1944 (case monoType env (L.TRecord exps, loc) of
|
adamc@252
|
1945 (L'.TRecord exps, _) =>
|
adamc@252
|
1946 let
|
adamc@252
|
1947 val tables = map (fn ((L.CName x, _), xts) =>
|
adamc@252
|
1948 (case monoType env (L.TRecord xts, loc) of
|
adamc@252
|
1949 (L'.TRecord xts, _) => SOME (x, xts)
|
adamc@252
|
1950 | _ => NONE)
|
adamc@252
|
1951 | _ => NONE) tables
|
adamc@252
|
1952 in
|
adamc@252
|
1953 if List.exists (fn x => x = NONE) tables then
|
adamc@252
|
1954 poly ()
|
adamc@252
|
1955 else
|
adamc@252
|
1956 let
|
adamc@252
|
1957 val tables = List.mapPartial (fn x => x) tables
|
adamc@252
|
1958 val state = monoType env state
|
adamc@252
|
1959 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
1960 val un = (L'.TRecord [], loc)
|
adamc@252
|
1961
|
adamc@252
|
1962 val rt = exps @ map (fn (x, xts) => (x, (L'.TRecord xts, loc))) tables
|
adamc@252
|
1963 val ft = (L'.TFun ((L'.TRecord rt, loc),
|
adamc@252
|
1964 (L'.TFun (state,
|
adamc@252
|
1965 (L'.TFun (un, state), loc)),
|
adamc@252
|
1966 loc)), loc)
|
adamc@252
|
1967
|
adamc@267
|
1968 val body' = (L'.EApp (
|
adamc@267
|
1969 (L'.EApp (
|
adamc@267
|
1970 (L'.EApp ((L'.ERel 4, loc),
|
adamc@267
|
1971 (L'.ERel 1, loc)), loc),
|
adamc@267
|
1972 (L'.ERel 0, loc)), loc),
|
adamc@267
|
1973 (L'.ERecord [], loc)), loc)
|
adamc@252
|
1974
|
adamc@252
|
1975 val body = (L'.EQuery {exps = exps,
|
adamc@252
|
1976 tables = tables,
|
adamc@252
|
1977 state = state,
|
adamc@252
|
1978 query = (L'.ERel 3, loc),
|
adamc@252
|
1979 body = body',
|
adamc@252
|
1980 initial = (L'.ERel 1, loc)},
|
adamc@252
|
1981 loc)
|
adamc@252
|
1982 in
|
adamc@252
|
1983 ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
|
adamc@252
|
1984 (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
|
adamc@252
|
1985 (L'.EAbs ("i", state, (L'.TFun (un, state), loc),
|
adamc@252
|
1986 (L'.EAbs ("_", un, state,
|
adamc@252
|
1987 body), loc)), loc)), loc)), loc), fm)
|
adamc@252
|
1988 end
|
adamc@252
|
1989 end
|
adamc@252
|
1990 | _ => poly ())
|
adamc@252
|
1991
|
adam@1394
|
1992 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) =>
|
adamc@252
|
1993 let
|
adamc@252
|
1994 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@252
|
1995 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
1996 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
|
adamc@252
|
1997 in
|
adamc@252
|
1998 ((L'.EAbs ("r",
|
adamc@252
|
1999 (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc),
|
adamc@252
|
2000 s,
|
adamc@598
|
2001 strcat [gf "Rows",
|
adamc@598
|
2002 (L'.ECase (gf "OrderBy",
|
adamc@598
|
2003 [((L'.PPrim (Prim.String ""), loc), sc ""),
|
adamc@598
|
2004 ((L'.PWild, loc),
|
adamc@598
|
2005 strcat [sc " ORDER BY ",
|
adamc@598
|
2006 gf "OrderBy"])],
|
adamc@598
|
2007 {disc = s, result = s}), loc),
|
adamc@598
|
2008 gf "Limit",
|
adamc@598
|
2009 gf "Offset"]), loc), fm)
|
adamc@252
|
2010 end
|
adamc@252
|
2011
|
adamc@252
|
2012 | L.ECApp (
|
adamc@252
|
2013 (L.ECApp (
|
adamc@252
|
2014 (L.ECApp (
|
adamc@252
|
2015 (L.ECApp (
|
adamc@1070
|
2016 (L.ECApp (
|
adamc@1191
|
2017 (L.ECApp (
|
adam@1394
|
2018 (L.ECApp (
|
adam@1394
|
2019 (L.EFfi ("Basis", "sql_query1"), _),
|
adam@1394
|
2020 _), _),
|
adamc@1191
|
2021 _), _),
|
adamc@1070
|
2022 (L.CRecord (_, tables), _)), _),
|
adamc@1070
|
2023 (L.CRecord (_, grouped), _)), _),
|
adamc@1070
|
2024 (L.CRecord (_, stables), _)), _),
|
adamc@1070
|
2025 sexps), _),
|
adamc@1070
|
2026 _) =>
|
adamc@252
|
2027 let
|
adamc@252
|
2028 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@252
|
2029 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@993
|
2030 val b = (L'.TFfi ("Basis", "bool"), loc)
|
adamc@252
|
2031 val un = (L'.TRecord [], loc)
|
adamc@252
|
2032 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
|
adamc@252
|
2033
|
adamc@252
|
2034 fun doTables tables =
|
adamc@252
|
2035 let
|
adamc@252
|
2036 val tables = map (fn ((L.CName x, _), xts) =>
|
adamc@252
|
2037 (case monoType env (L.TRecord xts, loc) of
|
adamc@252
|
2038 (L'.TRecord xts, _) => SOME (x, xts)
|
adamc@252
|
2039 | _ => NONE)
|
adamc@252
|
2040 | _ => NONE) tables
|
adamc@252
|
2041 in
|
adamc@252
|
2042 if List.exists (fn x => x = NONE) tables then
|
adamc@252
|
2043 NONE
|
adamc@252
|
2044 else
|
adamc@260
|
2045 let
|
adamc@260
|
2046 val tables = List.mapPartial (fn x => x) tables
|
adamc@260
|
2047 val tables = ListMergeSort.sort
|
adamc@260
|
2048 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
|
adamc@260
|
2049 tables
|
adamc@260
|
2050 val tables = map (fn (x, xts) =>
|
adamc@260
|
2051 (x, ListMergeSort.sort
|
adamc@260
|
2052 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
|
adamc@260
|
2053 xts)) tables
|
adamc@260
|
2054 in
|
adamc@260
|
2055 SOME tables
|
adamc@260
|
2056 end
|
adamc@252
|
2057 end
|
adamc@252
|
2058 in
|
adamc@252
|
2059 case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of
|
adamc@252
|
2060 (SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) =>
|
adamc@441
|
2061 let
|
adamc@441
|
2062 val sexps = ListMergeSort.sort
|
adamc@441
|
2063 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps
|
adamc@441
|
2064 in
|
adamc@441
|
2065 ((L'.EAbs ("r",
|
adamc@993
|
2066 (L'.TRecord [("Distinct", b),
|
adamc@993
|
2067 ("From", s),
|
adamc@441
|
2068 ("Where", s),
|
adamc@441
|
2069 ("GroupBy", un),
|
adamc@441
|
2070 ("Having", s),
|
adamc@441
|
2071 ("SelectFields", un),
|
adamc@441
|
2072 ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
|
adamc@441
|
2073 loc),
|
adamc@441
|
2074 s,
|
adamc@598
|
2075 strcat [sc "SELECT ",
|
adamc@993
|
2076 (L'.ECase (gf "Distinct",
|
adamc@993
|
2077 [((L'.PCon (L'.Enum,
|
adamc@993
|
2078 L'.PConFfi {mod = "Basis",
|
adamc@993
|
2079 datatyp = "bool",
|
adamc@993
|
2080 con = "True",
|
adamc@993
|
2081 arg = NONE},
|
adamc@993
|
2082 NONE), loc),
|
adamc@993
|
2083 (L'.EPrim (Prim.String "DISTINCT "), loc)),
|
adamc@993
|
2084 ((L'.PCon (L'.Enum,
|
adamc@993
|
2085 L'.PConFfi {mod = "Basis",
|
adamc@993
|
2086 datatyp = "bool",
|
adamc@993
|
2087 con = "False",
|
adamc@993
|
2088 arg = NONE},
|
adamc@993
|
2089 NONE), loc),
|
adamc@993
|
2090 (L'.EPrim (Prim.String ""), loc))],
|
adamc@993
|
2091 {disc = b, result = s}), loc),
|
adamc@598
|
2092 strcatComma (map (fn (x, t) =>
|
adamc@598
|
2093 strcat [
|
adamc@598
|
2094 (L'.EField (gf "SelectExps", x), loc),
|
adam@1953
|
2095 sc (" AS " ^ Settings.mangleSql x)
|
adamc@598
|
2096 ]) sexps
|
adamc@598
|
2097 @ map (fn (x, xts) =>
|
adamc@598
|
2098 strcatComma
|
adamc@598
|
2099 (map (fn (x', _) =>
|
adamc@986
|
2100 sc ("T_" ^ x
|
adam@1953
|
2101 ^ "."
|
adam@1953
|
2102 ^ Settings.mangleSql x'))
|
adamc@598
|
2103 xts)) stables),
|
adamc@1195
|
2104 (L'.ECase (gf "From",
|
adamc@1195
|
2105 [((L'.PPrim (Prim.String ""), loc),
|
adamc@1195
|
2106 sc ""),
|
adamc@1195
|
2107 ((L'.PVar ("x", s), loc),
|
adamc@1195
|
2108 strcat [sc " FROM ",
|
adamc@1195
|
2109 (L'.ERel 0, loc)])],
|
adamc@1195
|
2110 {disc = s,
|
adamc@1195
|
2111 result = s}), loc),
|
adamc@598
|
2112 (L'.ECase (gf "Where",
|
adamc@1266
|
2113 [((L'.PPrim (Prim.String (#trueString (Settings.currentDbms ()))),
|
adamc@1266
|
2114 loc),
|
adamc@598
|
2115 sc ""),
|
adamc@598
|
2116 ((L'.PWild, loc),
|
adamc@598
|
2117 strcat [sc " WHERE ", gf "Where"])],
|
adamc@598
|
2118 {disc = s,
|
adamc@598
|
2119 result = s}), loc),
|
adam@1682
|
2120
|
adamc@598
|
2121 if List.all (fn (x, xts) =>
|
adamc@598
|
2122 case List.find (fn (x', _) => x' = x) grouped of
|
adamc@598
|
2123 NONE => List.null xts
|
adamc@598
|
2124 | SOME (_, xts') =>
|
adamc@598
|
2125 List.all (fn (x, _) =>
|
adamc@598
|
2126 List.exists (fn (x', _) => x' = x)
|
adamc@598
|
2127 xts') xts) tables then
|
adamc@598
|
2128 sc ""
|
adamc@598
|
2129 else
|
adamc@598
|
2130 strcat [
|
adamc@598
|
2131 sc " GROUP BY ",
|
adamc@598
|
2132 strcatComma (map (fn (x, xts) =>
|
adamc@598
|
2133 strcatComma
|
adamc@598
|
2134 (map (fn (x', _) =>
|
adamc@986
|
2135 sc ("T_" ^ x
|
adam@2004
|
2136 ^ "."
|
adam@1953
|
2137 ^ Settings.mangleSql x'))
|
adamc@598
|
2138 xts)) grouped)
|
adamc@598
|
2139 ],
|
adamc@259
|
2140
|
adamc@598
|
2141 (L'.ECase (gf "Having",
|
adamc@1014
|
2142 [((L'.PPrim (Prim.String
|
adamc@1014
|
2143 (#trueString (Settings.currentDbms ()))), loc),
|
adamc@598
|
2144 sc ""),
|
adamc@598
|
2145 ((L'.PWild, loc),
|
adamc@598
|
2146 strcat [sc " HAVING ", gf "Having"])],
|
adamc@598
|
2147 {disc = s,
|
adamc@598
|
2148 result = s}), loc)
|
adamc@441
|
2149 ]), loc),
|
adamc@441
|
2150 fm)
|
adamc@441
|
2151 end
|
adamc@252
|
2152 | _ => poly ()
|
adamc@252
|
2153 end
|
adamc@252
|
2154
|
adamc@252
|
2155 | L.ECApp (
|
adamc@252
|
2156 (L.ECApp (
|
adamc@252
|
2157 (L.ECApp (
|
adamc@252
|
2158 (L.ECApp (
|
adam@1778
|
2159 (L.EFfi ("Basis", "sql_inject"), _),
|
adamc@252
|
2160 _), _),
|
adamc@252
|
2161 _), _),
|
adamc@252
|
2162 _), _),
|
adamc@252
|
2163 t) =>
|
adamc@252
|
2164 let
|
adamc@252
|
2165 val t = monoType env t
|
adamc@252
|
2166 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
2167 in
|
adamc@252
|
2168 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
|
adamc@252
|
2169 (L'.ERel 0, loc)), loc), fm)
|
adamc@252
|
2170 end
|
adamc@252
|
2171
|
adamc@253
|
2172 | L.EFfi ("Basis", "sql_int") =>
|
adamc@253
|
2173 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2174 (L'.EFfiApp ("Basis", "sqlifyInt", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "int"), loc))]), loc)), loc),
|
adamc@253
|
2175 fm)
|
adamc@253
|
2176 | L.EFfi ("Basis", "sql_float") =>
|
adamc@253
|
2177 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2178 (L'.EFfiApp ("Basis", "sqlifyFloat", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "float"), loc))]), loc)), loc),
|
adamc@253
|
2179 fm)
|
adamc@253
|
2180 | L.EFfi ("Basis", "sql_bool") =>
|
adamc@253
|
2181 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2182 (L'.EFfiApp ("Basis", "sqlifyBool", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "bool"), loc))]), loc)), loc),
|
adamc@253
|
2183 fm)
|
adamc@253
|
2184 | L.EFfi ("Basis", "sql_string") =>
|
adamc@253
|
2185 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2186 (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc),
|
adamc@253
|
2187 fm)
|
adamc@1011
|
2188 | L.EFfi ("Basis", "sql_char") =>
|
adamc@1011
|
2189 ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2190 (L'.EFfiApp ("Basis", "sqlifyChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc),
|
adamc@1011
|
2191 fm)
|
adamc@439
|
2192 | L.EFfi ("Basis", "sql_time") =>
|
adamc@439
|
2193 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2194 (L'.EFfiApp ("Basis", "sqlifyTime", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc),
|
adamc@439
|
2195 fm)
|
adamc@737
|
2196 | L.EFfi ("Basis", "sql_blob") =>
|
adamc@737
|
2197 ((L'.EAbs ("x", (L'.TFfi ("Basis", "blob"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2198 (L'.EFfiApp ("Basis", "sqlifyBlob", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "blob"), loc))]), loc)), loc),
|
adamc@737
|
2199 fm)
|
adamc@678
|
2200 | L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) =>
|
adamc@678
|
2201 ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2202 (L'.EFfiApp ("Basis", "sqlifyChannel", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "channel"), loc))]), loc)), loc),
|
adamc@678
|
2203 fm)
|
adamc@682
|
2204 | L.EFfi ("Basis", "sql_client") =>
|
adamc@682
|
2205 ((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2206 (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)), loc),
|
adamc@682
|
2207 fm)
|
adamc@1104
|
2208 | L.ECApp ((L.EFfi ("Basis", "sql_serialized"), _), _) =>
|
adamc@1104
|
2209 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
2210 (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc),
|
adamc@1104
|
2211 fm)
|
adam@2029
|
2212 | L.EFfi ("Basis", "sql_url") =>
|
adam@2029
|
2213 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@2029
|
2214 (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc),
|
adam@2029
|
2215 fm)
|
adamc@676
|
2216 | L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
|
adamc@676
|
2217 let
|
adamc@676
|
2218 val t = monoType env t
|
adamc@676
|
2219 val tf = (L'.TFun (t, (L'.TFfi ("Basis", "string"), loc)), loc)
|
adamc@676
|
2220 in
|
adamc@676
|
2221 ((L'.EAbs ("f", tf, tf, (L'.ERel 0, loc)), loc),
|
adamc@676
|
2222 fm)
|
adamc@676
|
2223 end
|
adamc@676
|
2224 | L.ECApp ((L.EFfi ("Basis", "sql_option_prim"), _), t) =>
|
adamc@676
|
2225 let
|
adamc@676
|
2226 val t = monoType env t
|
adamc@676
|
2227 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@676
|
2228 in
|
adamc@676
|
2229 ((L'.EAbs ("f",
|
adamc@676
|
2230 (L'.TFun (t, s), loc),
|
adamc@676
|
2231 (L'.TFun ((L'.TOption t, loc), s), loc),
|
adamc@676
|
2232 (L'.EAbs ("x",
|
adamc@676
|
2233 (L'.TOption t, loc),
|
adamc@676
|
2234 s,
|
adamc@676
|
2235 (L'.ECase ((L'.ERel 0, loc),
|
adamc@676
|
2236 [((L'.PNone t, loc),
|
adamc@676
|
2237 (L'.EPrim (Prim.String "NULL"), loc)),
|
adamc@676
|
2238 ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
|
adamc@676
|
2239 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
|
adamc@676
|
2240 {disc = (L'.TOption t, loc),
|
adamc@676
|
2241 result = s}), loc)), loc)), loc),
|
adamc@676
|
2242 fm)
|
adamc@676
|
2243 end
|
adamc@253
|
2244
|
adamc@750
|
2245 | L.ECApp ((L.EFfi ("Basis", "nullify_option"), _), _) =>
|
adamc@750
|
2246 ((L'.ERecord [], loc), fm)
|
adamc@750
|
2247 | L.ECApp ((L.EFfi ("Basis", "nullify_prim"), _), _) =>
|
adamc@750
|
2248 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
adamc@750
|
2249 (L'.ERecord [], loc)), loc),
|
adamc@750
|
2250 fm)
|
adamc@750
|
2251
|
adamc@252
|
2252 | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
|
adamc@252
|
2253 ((L'.ERecord [], loc), fm)
|
adamc@252
|
2254 | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
|
adamc@252
|
2255 ((L'.ERecord [], loc), fm)
|
adamc@1072
|
2256 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_subset_concat"),
|
adamc@1072
|
2257 _), _), _), _), _), _), _), _) =>
|
adamc@1072
|
2258 let
|
adam@1682
|
2259 val un = (L'.TRecord [], loc)
|
adamc@1072
|
2260 in
|
adamc@1072
|
2261 ((L'.EAbs ("_", un, (L'.TFun (un, un), loc),
|
adamc@1072
|
2262 (L'.EAbs ("_", un, un,
|
adamc@1072
|
2263 (L'.ERecord [], loc)), loc)), loc),
|
adamc@1072
|
2264 fm)
|
adamc@1072
|
2265 end
|
adamc@252
|
2266
|
adamc@753
|
2267 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "fieldsOf_table"), _), _), _), _) =>
|
adamc@753
|
2268 ((L'.ERecord [], loc), fm)
|
adamc@753
|
2269 | L.ECApp ((L.EFfi ("Basis", "fieldsOf_view"), _), _) =>
|
adamc@753
|
2270 ((L'.ERecord [], loc), fm)
|
adamc@753
|
2271
|
adamc@1195
|
2272 | L.ECApp ((L.EFfi ("Basis", "sql_from_nil"), _), _) =>
|
adamc@1195
|
2273 ((L'.EPrim (Prim.String ""), loc), fm)
|
adamc@1191
|
2274 | L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _),
|
adamc@1191
|
2275 _), _), _), _), _), _), _),
|
adamc@753
|
2276 (L.CName name, _)) =>
|
adamc@748
|
2277 let
|
adamc@748
|
2278 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@748
|
2279 in
|
adamc@748
|
2280 ((L'.EAbs ("tab", s, s,
|
adamc@748
|
2281 strcat [(L'.ERel 0, loc),
|
adamc@986
|
2282 (L'.EPrim (Prim.String (" AS T_" ^ name)), loc)]), loc),
|
adamc@748
|
2283 fm)
|
adamc@748
|
2284 end
|
adamc@1192
|
2285 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_query"), _), _),
|
adamc@1192
|
2286 _), _), _),
|
adamc@1192
|
2287 (L.CName name, _)) =>
|
adamc@1192
|
2288 let
|
adamc@1192
|
2289 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@1192
|
2290 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@1192
|
2291 in
|
adamc@1192
|
2292 ((L'.EAbs ("q", s, s,
|
adamc@1192
|
2293 strcat [sc "(",
|
adamc@1192
|
2294 (L'.ERel 0, loc),
|
adamc@1192
|
2295 sc (") AS T_" ^ name)]), loc),
|
adamc@1192
|
2296 fm)
|
adamc@1192
|
2297 end
|
adamc@1191
|
2298 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) =>
|
adamc@748
|
2299 let
|
adamc@748
|
2300 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@748
|
2301 in
|
adamc@748
|
2302 ((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc),
|
adamc@748
|
2303 (L'.EAbs ("tab2", s, s,
|
adamc@1195
|
2304 (L'.ECase ((L'.ERecord [("1", (L'.ERel 1, loc), s),
|
adamc@1195
|
2305 ("2", (L'.ERel 0, loc), s)], loc),
|
adamc@1195
|
2306 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc),
|
adamc@1195
|
2307 (L'.ERel 0, loc)),
|
adamc@1195
|
2308 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc),
|
adamc@1195
|
2309 (L'.ERel 1, loc)),
|
adamc@1195
|
2310 ((L'.PWild, loc),
|
adamc@1195
|
2311 strcat [(L'.ERel 1, loc),
|
adamc@1195
|
2312 (L'.EPrim (Prim.String ", "), loc),
|
adamc@1195
|
2313 (L'.ERel 0, loc)])],
|
adamc@1195
|
2314 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
|
adamc@1195
|
2315 result = s}), loc)), loc)), loc),
|
adamc@748
|
2316 fm)
|
adamc@748
|
2317 end
|
adamc@1191
|
2318 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_inner_join"), _), _), _), _), _), _) =>
|
adamc@749
|
2319 let
|
adamc@749
|
2320 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@749
|
2321 in
|
adamc@749
|
2322 ((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@749
|
2323 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
|
adamc@749
|
2324 (L'.EAbs ("on", s, s,
|
adamc@1195
|
2325 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
|
adamc@1195
|
2326 ("2", (L'.ERel 1, loc), s)], loc),
|
adamc@1195
|
2327 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc),
|
adamc@1195
|
2328 (L'.ERel 1, loc)),
|
adamc@1195
|
2329 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc),
|
adamc@1195
|
2330 (L'.ERel 2, loc)),
|
adamc@1195
|
2331 ((L'.PWild, loc),
|
adamc@1266
|
2332 strcat ((if #nestedRelops
|
adamc@1266
|
2333 (Settings.currentDbms ()) then
|
adamc@1266
|
2334 [(L'.EPrim (Prim.String "("), loc)]
|
adamc@1266
|
2335 else
|
adamc@1266
|
2336 [])
|
adamc@1266
|
2337 @ [(L'.ERel 2, loc),
|
adamc@1266
|
2338 (L'.EPrim (Prim.String " JOIN "), loc),
|
adamc@1266
|
2339 (L'.ERel 1, loc),
|
adamc@1266
|
2340 (L'.EPrim (Prim.String " ON "), loc),
|
adamc@1266
|
2341 (L'.ERel 0, loc)]
|
adamc@1266
|
2342 @ (if #nestedRelops
|
adamc@1266
|
2343 (Settings.currentDbms ()) then
|
adamc@1266
|
2344 [(L'.EPrim (Prim.String ")"), loc)]
|
adamc@1266
|
2345 else
|
adamc@1266
|
2346 [])))],
|
adamc@1195
|
2347 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
|
adamc@1195
|
2348 result = s}), loc)), loc)), loc)), loc),
|
adamc@749
|
2349 fm)
|
adamc@749
|
2350 end
|
adamc@1191
|
2351 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_left_join"), _), _), _), _), _),
|
adamc@1191
|
2352 (L.CRecord (_, right), _)) =>
|
adamc@750
|
2353 let
|
adamc@750
|
2354 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@750
|
2355 in
|
adamc@750
|
2356 ((L'.EAbs ("_", outerRec right,
|
adamc@750
|
2357 (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
|
adamc@750
|
2358 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@750
|
2359 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
|
adamc@750
|
2360 (L'.EAbs ("on", s, s,
|
adamc@1195
|
2361 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
|
adamc@1195
|
2362 ("2", (L'.ERel 1, loc), s)], loc),
|
adamc@1195
|
2363 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""),
|
adamc@1195
|
2364 loc), s)], loc),
|
adamc@1195
|
2365 (L'.ERel 1, loc)),
|
adamc@1195
|
2366 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""),
|
adamc@1195
|
2367 loc), s)], loc),
|
adamc@1195
|
2368 (L'.ERel 2, loc)),
|
adamc@1195
|
2369 ((L'.PWild, loc),
|
adamc@1266
|
2370 strcat ((if #nestedRelops
|
adamc@1266
|
2371 (Settings.currentDbms ()) then
|
adamc@1266
|
2372 [(L'.EPrim (Prim.String "("), loc)]
|
adamc@1266
|
2373 else
|
adamc@1266
|
2374 [])
|
adamc@1266
|
2375 @ [(L'.ERel 2, loc),
|
adamc@1266
|
2376 (L'.EPrim (Prim.String " LEFT JOIN "),
|
adamc@1266
|
2377 loc),
|
adamc@1266
|
2378 (L'.ERel 1, loc),
|
adamc@1266
|
2379 (L'.EPrim (Prim.String " ON "), loc),
|
adamc@1266
|
2380 (L'.ERel 0, loc)]
|
adamc@1266
|
2381 @ (if #nestedRelops
|
adamc@1266
|
2382 (Settings.currentDbms ()) then
|
adamc@1266
|
2383 [(L'.EPrim (Prim.String ")"), loc)]
|
adamc@1266
|
2384 else
|
adamc@1266
|
2385 [])))],
|
adamc@1195
|
2386 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
|
adamc@1195
|
2387 result = s}), loc)), loc)), loc)), loc)), loc),
|
adamc@750
|
2388 fm)
|
adamc@750
|
2389 end
|
adamc@1191
|
2390 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_right_join"), _), (L.CRecord (_, left), _)),
|
adamc@1191
|
2391 _), _), _), _) =>
|
adamc@751
|
2392 let
|
adamc@751
|
2393 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@751
|
2394 in
|
adamc@751
|
2395 ((L'.EAbs ("_", outerRec left,
|
adamc@751
|
2396 (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
|
adamc@751
|
2397 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@751
|
2398 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
|
adamc@751
|
2399 (L'.EAbs ("on", s, s,
|
adamc@1195
|
2400 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
|
adamc@1195
|
2401 ("2", (L'.ERel 1, loc), s)], loc),
|
adamc@1195
|
2402 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""),
|
adamc@1195
|
2403 loc), s)], loc),
|
adamc@1195
|
2404 (L'.ERel 1, loc)),
|
adamc@1195
|
2405 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""),
|
adamc@1195
|
2406 loc), s)], loc),
|
adamc@1195
|
2407 (L'.ERel 2, loc)),
|
adamc@1195
|
2408 ((L'.PWild, loc),
|
adamc@1266
|
2409 strcat ((if #nestedRelops
|
adamc@1266
|
2410 (Settings.currentDbms ()) then
|
adamc@1266
|
2411 [(L'.EPrim (Prim.String "("), loc)]
|
adamc@1266
|
2412 else
|
adamc@1266
|
2413 [])
|
adamc@1266
|
2414 @ [(L'.ERel 2, loc),
|
adamc@1266
|
2415 (L'.EPrim (Prim.String " RIGHT JOIN "),
|
adamc@1266
|
2416 loc),
|
adamc@1266
|
2417 (L'.ERel 1, loc),
|
adamc@1266
|
2418 (L'.EPrim (Prim.String " ON "), loc),
|
adamc@1266
|
2419 (L'.ERel 0, loc)]
|
adamc@1266
|
2420 @ (if #nestedRelops
|
adamc@1266
|
2421 (Settings.currentDbms ()) then
|
adamc@1266
|
2422 [(L'.EPrim (Prim.String ")"), loc)]
|
adamc@1266
|
2423 else
|
adamc@1266
|
2424 [])))],
|
adamc@1195
|
2425 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
|
adamc@1195
|
2426 result = s}), loc)), loc)), loc)), loc)), loc),
|
adamc@751
|
2427 fm)
|
adamc@751
|
2428 end
|
adamc@1191
|
2429 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_full_join"), _), (L.CRecord (_, left), _)), _),
|
adamc@1191
|
2430 (L.CRecord (_, right), _)), _), _) =>
|
adamc@751
|
2431 let
|
adamc@751
|
2432 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@751
|
2433 in
|
adamc@751
|
2434 ((L'.EAbs ("_", outerRec (left @ right),
|
adamc@751
|
2435 (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
|
adamc@751
|
2436 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@751
|
2437 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
|
adamc@751
|
2438 (L'.EAbs ("on", s, s,
|
adamc@1195
|
2439 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
|
adamc@1195
|
2440 ("2", (L'.ERel 1, loc), s)], loc),
|
adamc@1195
|
2441 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""),
|
adamc@1195
|
2442 loc), s)], loc),
|
adamc@1195
|
2443 (L'.ERel 1, loc)),
|
adamc@1195
|
2444 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""),
|
adamc@1195
|
2445 loc), s)], loc),
|
adamc@1195
|
2446 (L'.ERel 2, loc)),
|
adamc@1195
|
2447 ((L'.PWild, loc),
|
adamc@1266
|
2448 strcat ((if #nestedRelops
|
adamc@1266
|
2449 (Settings.currentDbms ()) then
|
adamc@1266
|
2450 [(L'.EPrim (Prim.String "("), loc)]
|
adamc@1266
|
2451 else
|
adamc@1266
|
2452 [])
|
adamc@1266
|
2453 @ [(L'.ERel 2, loc),
|
adamc@1266
|
2454 (L'.EPrim (Prim.String " FULL JOIN "),
|
adamc@1266
|
2455 loc),
|
adamc@1266
|
2456 (L'.ERel 1, loc),
|
adamc@1266
|
2457 (L'.EPrim (Prim.String " ON "), loc),
|
adamc@1266
|
2458 (L'.ERel 0, loc)]
|
adamc@1266
|
2459 @ (if #nestedRelops
|
adamc@1266
|
2460 (Settings.currentDbms ()) then
|
adamc@1266
|
2461 [(L'.EPrim (Prim.String ")"), loc)]
|
adamc@1266
|
2462 else
|
adamc@1266
|
2463 [])))],
|
adamc@1195
|
2464 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
|
adamc@1195
|
2465 result = s}), loc)), loc)), loc)), loc)), loc),
|
adamc@751
|
2466 fm)
|
adamc@751
|
2467 end
|
adamc@748
|
2468
|
adamc@252
|
2469 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
|
adamc@252
|
2470 ((L'.EPrim (Prim.String ""), loc), fm)
|
adam@1682
|
2471 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) =>
|
adam@1682
|
2472 ((L'.EPrim (Prim.String (#randomFunction (Settings.currentDbms ()) ^ "()")), loc), fm)
|
adamc@261
|
2473 | L.ECApp (
|
adamc@261
|
2474 (L.ECApp (
|
adamc@261
|
2475 (L.ECApp (
|
adam@1778
|
2476 (L.ECApp (
|
adam@1778
|
2477 (L.EFfi ("Basis", "sql_order_by_Cons"), _),
|
adam@1778
|
2478 _), _),
|
adamc@261
|
2479 _), _),
|
adamc@261
|
2480 _), _),
|
adamc@261
|
2481 _) =>
|
adamc@261
|
2482 let
|
adamc@261
|
2483 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@261
|
2484 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@261
|
2485 in
|
adam@1778
|
2486 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
|
adam@1778
|
2487 (L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adam@1778
|
2488 (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
|
adam@1778
|
2489 (L'.EAbs ("e2", s, s,
|
adam@1778
|
2490 (L'.ECase ((L'.ERel 0, loc),
|
adam@1778
|
2491 [((L'.PPrim (Prim.String ""), loc),
|
adam@1778
|
2492 strcat [(L'.ERel 2, loc),
|
adam@1778
|
2493 (L'.ERel 1, loc)]),
|
adam@1778
|
2494 ((L'.PWild, loc),
|
adam@1778
|
2495 strcat [(L'.ERel 2, loc),
|
adam@1778
|
2496 (L'.ERel 1, loc),
|
adam@1778
|
2497 sc ", ",
|
adam@1778
|
2498 (L'.ERel 0, loc)])],
|
adam@1778
|
2499 {disc = s, result = s}), loc)), loc)), loc)), loc)), loc),
|
adamc@261
|
2500 fm)
|
adamc@261
|
2501 end
|
adamc@252
|
2502
|
adamc@252
|
2503 | L.EFfi ("Basis", "sql_no_limit") =>
|
adamc@252
|
2504 ((L'.EPrim (Prim.String ""), loc), fm)
|
adam@1663
|
2505 | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) =>
|
adamc@262
|
2506 let
|
adamc@262
|
2507 val (e, fm) = monoExp (env, st, fm) e
|
adamc@262
|
2508 in
|
adamc@598
|
2509 (strcat [
|
adamc@262
|
2510 (L'.EPrim (Prim.String " LIMIT "), loc),
|
adam@1663
|
2511 (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
|
adamc@262
|
2512 ],
|
adamc@262
|
2513 fm)
|
adamc@262
|
2514 end
|
adamc@262
|
2515
|
adamc@252
|
2516 | L.EFfi ("Basis", "sql_no_offset") =>
|
adamc@252
|
2517 ((L'.EPrim (Prim.String ""), loc), fm)
|
adam@1663
|
2518 | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) =>
|
adamc@263
|
2519 let
|
adamc@263
|
2520 val (e, fm) = monoExp (env, st, fm) e
|
adamc@263
|
2521 in
|
adamc@598
|
2522 (strcat [
|
adamc@263
|
2523 (L'.EPrim (Prim.String " OFFSET "), loc),
|
adam@1663
|
2524 (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
|
adamc@263
|
2525 ],
|
adamc@263
|
2526 fm)
|
adamc@263
|
2527 end
|
adamc@253
|
2528
|
adamc@559
|
2529 | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) =>
|
adamc@253
|
2530 ((L'.EPrim (Prim.String "="), loc), fm)
|
adamc@559
|
2531 | L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) =>
|
adamc@253
|
2532 ((L'.EPrim (Prim.String "<>"), loc), fm)
|
adamc@559
|
2533 | L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) =>
|
adamc@253
|
2534 ((L'.EPrim (Prim.String "<"), loc), fm)
|
adamc@559
|
2535 | L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) =>
|
adamc@253
|
2536 ((L'.EPrim (Prim.String "<="), loc), fm)
|
adamc@559
|
2537 | L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) =>
|
adamc@253
|
2538 ((L'.EPrim (Prim.String ">"), loc), fm)
|
adamc@559
|
2539 | L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) =>
|
adamc@253
|
2540 ((L'.EPrim (Prim.String ">="), loc), fm)
|
adamc@253
|
2541
|
adamc@559
|
2542 | L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) =>
|
adamc@559
|
2543 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@559
|
2544 (L'.EPrim (Prim.String "+"), loc)), loc), fm)
|
adamc@559
|
2545 | L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) =>
|
adamc@559
|
2546 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@559
|
2547 (L'.EPrim (Prim.String "-"), loc)), loc), fm)
|
adamc@559
|
2548 | L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) =>
|
adamc@559
|
2549 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@559
|
2550 (L'.EPrim (Prim.String "*"), loc)), loc), fm)
|
adamc@559
|
2551 | L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) =>
|
adamc@559
|
2552 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@559
|
2553 (L'.EPrim (Prim.String "/"), loc)), loc), fm)
|
adamc@559
|
2554 | L.EFfi ("Basis", "sql_mod") =>
|
adamc@559
|
2555 ((L'.EPrim (Prim.String "%"), loc), fm)
|
adamc@559
|
2556
|
kkallio@1607
|
2557 | L.EFfi ("Basis", "sql_like") =>
|
kkallio@1607
|
2558 ((L'.EPrim (Prim.String "LIKE"), loc), fm)
|
kkallio@1607
|
2559
|
adamc@253
|
2560 | L.ECApp (
|
adamc@253
|
2561 (L.ECApp (
|
adamc@253
|
2562 (L.ECApp (
|
adamc@253
|
2563 (L.ECApp (
|
adamc@254
|
2564 (L.ECApp (
|
adamc@264
|
2565 (L.EFfi ("Basis", "sql_unary"), _),
|
adamc@264
|
2566 _), _),
|
adamc@264
|
2567 _), _),
|
adamc@264
|
2568 _), _),
|
adamc@264
|
2569 _), _),
|
adamc@264
|
2570 _) =>
|
adamc@264
|
2571 let
|
adamc@264
|
2572 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@264
|
2573 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@264
|
2574 in
|
adamc@264
|
2575 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@264
|
2576 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
adamc@598
|
2577 strcat [sc "(",
|
adamc@598
|
2578 (L'.ERel 1, loc),
|
adamc@598
|
2579 sc " ",
|
adamc@598
|
2580 (L'.ERel 0, loc),
|
adamc@598
|
2581 sc ")"]), loc)), loc),
|
adamc@264
|
2582 fm)
|
adamc@264
|
2583 end
|
adamc@264
|
2584 | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm)
|
adamc@559
|
2585 | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) =>
|
adamc@559
|
2586 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@559
|
2587 (L'.EPrim (Prim.String "-"), loc)), loc), fm)
|
adamc@264
|
2588
|
adamc@264
|
2589 | L.ECApp (
|
adamc@264
|
2590 (L.ECApp (
|
adamc@264
|
2591 (L.ECApp (
|
adamc@264
|
2592 (L.ECApp (
|
adamc@264
|
2593 (L.ECApp (
|
adamc@254
|
2594 (L.ECApp (
|
adam@1778
|
2595 (L.EFfi ("Basis", "sql_binary"), _),
|
adamc@254
|
2596 _), _),
|
adamc@254
|
2597 _), _),
|
adamc@254
|
2598 _), _),
|
adamc@254
|
2599 _), _),
|
adamc@254
|
2600 _), _),
|
adamc@254
|
2601 _) =>
|
adamc@254
|
2602 let
|
adamc@254
|
2603 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@254
|
2604 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@254
|
2605 in
|
adamc@254
|
2606 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@254
|
2607 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
adamc@254
|
2608 (L'.EAbs ("e2", s, s,
|
adamc@598
|
2609 strcat [sc "(",
|
adamc@598
|
2610 (L'.ERel 1, loc),
|
adamc@598
|
2611 sc " ",
|
adamc@598
|
2612 (L'.ERel 2, loc),
|
adamc@598
|
2613 sc " ",
|
adamc@598
|
2614 (L'.ERel 0, loc),
|
adamc@598
|
2615 sc ")"]), loc)), loc)), loc),
|
adamc@254
|
2616 fm)
|
adamc@254
|
2617 end
|
adamc@254
|
2618 | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm)
|
adamc@254
|
2619 | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm)
|
adamc@254
|
2620
|
adamc@254
|
2621 | L.ECApp (
|
adamc@254
|
2622 (L.ECApp (
|
adamc@254
|
2623 (L.ECApp (
|
adamc@254
|
2624 (L.ECApp (
|
adamc@253
|
2625 (L.ECApp (
|
adamc@253
|
2626 (L.ECApp (
|
adamc@253
|
2627 (L.ECApp (
|
adam@1778
|
2628 (L.EFfi ("Basis", "sql_field"), _),
|
adamc@253
|
2629 _), _),
|
adamc@253
|
2630 _), _),
|
adamc@253
|
2631 _), _),
|
adamc@253
|
2632 _), _),
|
adamc@253
|
2633 _), _),
|
adamc@253
|
2634 (L.CName tab, _)), _),
|
adam@1953
|
2635 (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm)
|
adamc@260
|
2636
|
adamc@260
|
2637 | L.ECApp (
|
adamc@260
|
2638 (L.ECApp (
|
adamc@260
|
2639 (L.ECApp (
|
adamc@260
|
2640 (L.ECApp (
|
adamc@261
|
2641 (L.ECApp (
|
adam@1778
|
2642 (L.EFfi ("Basis", "sql_exp"), _),
|
adamc@261
|
2643 _), _),
|
adamc@261
|
2644 _), _),
|
adamc@261
|
2645 _), _),
|
adamc@261
|
2646 _), _),
|
adam@1953
|
2647 (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm)
|
adamc@261
|
2648
|
adamc@261
|
2649 | L.ECApp (
|
adamc@261
|
2650 (L.ECApp (
|
adamc@261
|
2651 (L.ECApp (
|
adamc@261
|
2652 (L.ECApp (
|
adamc@1191
|
2653 (L.ECApp (
|
adam@1416
|
2654 (L.ECApp (
|
adam@1416
|
2655 (L.EFfi ("Basis", "sql_relop"), _),
|
adam@1416
|
2656 _), _),
|
adamc@1191
|
2657 _), _),
|
adamc@260
|
2658 _), _),
|
adamc@260
|
2659 _), _),
|
adamc@260
|
2660 _), _),
|
adamc@260
|
2661 _) =>
|
adamc@260
|
2662 let
|
adamc@260
|
2663 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@260
|
2664 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@260
|
2665 in
|
adamc@1196
|
2666 (if #nestedRelops (Settings.currentDbms ()) then
|
adam@1427
|
2667 (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
|
adam@1427
|
2668 (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adam@1427
|
2669 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
adam@1427
|
2670 (L'.EAbs ("e2", s, s,
|
adam@1427
|
2671 strcat [sc "((",
|
adam@1427
|
2672 (L'.ERel 1, loc),
|
adam@1427
|
2673 sc ") ",
|
adam@1427
|
2674 (L'.ERel 3, loc),
|
adam@1427
|
2675 (L'.ECase ((L'.ERel 2, loc),
|
adam@1427
|
2676 [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis",
|
adam@1427
|
2677 datatyp = "bool",
|
adam@1427
|
2678 con = "True",
|
adam@1427
|
2679 arg = NONE}, NONE), loc),
|
adam@1427
|
2680 sc " ALL"),
|
adam@1427
|
2681 ((L'.PWild, loc),
|
adam@1427
|
2682 sc "")],
|
adam@1427
|
2683 {disc = (L'.TFfi ("Basis", "bool"), loc),
|
adam@1427
|
2684 result = s}), loc),
|
adam@1427
|
2685 sc " (",
|
adam@1427
|
2686 (L'.ERel 0, loc),
|
adam@1427
|
2687 sc "))"]), loc)), loc)), loc)), loc)
|
adamc@1196
|
2688 else
|
adam@1427
|
2689 (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
|
adam@1427
|
2690 (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adam@1427
|
2691 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
adam@1427
|
2692 (L'.EAbs ("e2", s, s,
|
adam@1427
|
2693 strcat [(L'.ERel 1, loc),
|
adam@1427
|
2694 sc " ",
|
adam@1427
|
2695 (L'.ERel 3, loc),
|
adam@1427
|
2696 (L'.ECase ((L'.ERel 2, loc),
|
adam@1427
|
2697 [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis",
|
adam@1427
|
2698 datatyp = "bool",
|
adam@1427
|
2699 con = "True",
|
adam@1427
|
2700 arg = NONE}, NONE), loc),
|
adam@1427
|
2701 sc " ALL"),
|
adam@1427
|
2702 ((L'.PWild, loc),
|
adam@1427
|
2703 sc "")],
|
adam@1427
|
2704 {disc = (L'.TFfi ("Basis", "bool"), loc),
|
adam@1427
|
2705 result = s}), loc),
|
adam@1427
|
2706 sc " ",
|
adam@1427
|
2707 (L'.ERel 0, loc)]), loc)), loc)), loc)), loc),
|
adamc@260
|
2708 fm)
|
adamc@260
|
2709 end
|
adamc@1071
|
2710 | L.ECApp (
|
adamc@1071
|
2711 (L.ECApp (
|
adamc@1071
|
2712 (L.ECApp (
|
adamc@1191
|
2713 (L.ECApp (
|
adam@1394
|
2714 (L.ECApp (
|
adam@1394
|
2715 (L.EFfi ("Basis", "sql_forget_tables"), _),
|
adam@1394
|
2716 _), _),
|
adamc@1191
|
2717 _), _),
|
adamc@1071
|
2718 _), _),
|
adamc@1071
|
2719 _), _),
|
adamc@1071
|
2720 _) =>
|
adamc@1071
|
2721 let
|
adamc@1071
|
2722 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@1071
|
2723 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@1071
|
2724 in
|
adamc@1071
|
2725 ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc),
|
adamc@1071
|
2726 fm)
|
adamc@1071
|
2727 end
|
adamc@260
|
2728
|
adamc@260
|
2729 | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
|
adamc@1196
|
2730 | L.EFfi ("Basis", "sql_intersect") =>
|
adamc@1196
|
2731 (if #onlyUnion (Settings.currentDbms ()) then
|
adamc@1196
|
2732 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT."
|
adamc@1196
|
2733 else
|
adamc@1196
|
2734 ();
|
adamc@1196
|
2735 ((L'.EPrim (Prim.String "INTERSECT"), loc), fm))
|
adamc@1196
|
2736 | L.EFfi ("Basis", "sql_except") =>
|
adamc@1196
|
2737 (if #onlyUnion (Settings.currentDbms ()) then
|
adamc@1196
|
2738 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT."
|
adamc@1196
|
2739 else
|
adamc@1196
|
2740 ();
|
adamc@1196
|
2741 ((L'.EPrim (Prim.String "EXCEPT"), loc), fm))
|
adamc@260
|
2742
|
adamc@265
|
2743 | L.ECApp (
|
adamc@265
|
2744 (L.ECApp (
|
adamc@265
|
2745 (L.ECApp (
|
adam@1778
|
2746 (L.EFfi ("Basis", "sql_count"), _),
|
adamc@265
|
2747 _), _),
|
adamc@265
|
2748 _), _),
|
adam@1394
|
2749 _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc),
|
adamc@265
|
2750 fm)
|
adamc@266
|
2751
|
adamc@266
|
2752 | L.ECApp (
|
adamc@266
|
2753 (L.ECApp (
|
adamc@266
|
2754 (L.ECApp (
|
adamc@266
|
2755 (L.ECApp (
|
adamc@1187
|
2756 (L.ECApp (
|
adam@1778
|
2757 (L.EFfi ("Basis", "sql_aggregate"), _),
|
adamc@1187
|
2758 _), _),
|
adamc@266
|
2759 _), _),
|
adamc@266
|
2760 _), _),
|
adamc@266
|
2761 _), _),
|
adamc@1168
|
2762 t) =>
|
adamc@266
|
2763 let
|
adamc@266
|
2764 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@266
|
2765 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adam@1357
|
2766
|
adam@1357
|
2767 val main = strcat [(L'.ERel 1, loc),
|
adam@1357
|
2768 sc "(",
|
adam@1357
|
2769 (L'.ERel 0, loc),
|
adam@1357
|
2770 sc ")"]
|
adamc@266
|
2771 in
|
adamc@266
|
2772 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adam@1778
|
2773 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc),
|
adamc@266
|
2774 fm)
|
adamc@266
|
2775 end
|
adamc@266
|
2776
|
adamc@1187
|
2777 | L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) =>
|
adamc@1187
|
2778 ((L'.EPrim (Prim.String "COUNT"), loc),
|
adamc@1187
|
2779 fm)
|
adamc@1187
|
2780
|
adamc@266
|
2781 | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm)
|
adamc@266
|
2782 | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm)
|
adam@1357
|
2783 | L.ECApp ((L.EFfi ("Basis", "sql_summable_option"), _), _) =>
|
adam@1357
|
2784 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
adam@1357
|
2785 (L'.ERecord [], loc)), loc),
|
adam@1357
|
2786 fm)
|
adam@1777
|
2787 | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) =>
|
adam@1777
|
2788 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1777
|
2789 (L'.EPrim (Prim.String "AVG"), loc)), loc),
|
adamc@266
|
2790 fm)
|
adam@1394
|
2791 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) =>
|
adam@1394
|
2792 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
|
adam@1394
|
2793 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1394
|
2794 (L'.EPrim (Prim.String "SUM"), loc)), loc)), loc),
|
adamc@266
|
2795 fm)
|
adamc@266
|
2796
|
adamc@559
|
2797 | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm)
|
adamc@559
|
2798 | L.EFfi ("Basis", "sql_arith_float") => ((L'.ERecord [], loc), fm)
|
adam@1427
|
2799 | L.ECApp ((L.EFfi ("Basis", "sql_arith_option"), _), _) =>
|
adam@1427
|
2800 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
adam@1427
|
2801 (L'.ERecord [], loc)), loc),
|
adam@1427
|
2802 fm)
|
adamc@559
|
2803
|
adamc@266
|
2804 | L.EFfi ("Basis", "sql_maxable_int") => ((L'.ERecord [], loc), fm)
|
adamc@266
|
2805 | L.EFfi ("Basis", "sql_maxable_float") => ((L'.ERecord [], loc), fm)
|
adamc@266
|
2806 | L.EFfi ("Basis", "sql_maxable_string") => ((L'.ERecord [], loc), fm)
|
adam@1357
|
2807 | L.ECApp ((L.EFfi ("Basis", "sql_maxable_option"), _), _) =>
|
adam@1357
|
2808 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
adam@1357
|
2809 (L'.ERecord [], loc)), loc),
|
adam@1357
|
2810 fm)
|
adam@1394
|
2811 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) =>
|
adam@1394
|
2812 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
|
adam@1394
|
2813 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1394
|
2814 (L'.EPrim (Prim.String "MAX"), loc)), loc)), loc),
|
adamc@266
|
2815 fm)
|
adam@1394
|
2816 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) =>
|
adam@1394
|
2817 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
|
adam@1394
|
2818 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1394
|
2819 (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc),
|
adamc@266
|
2820 fm)
|
adamc@266
|
2821
|
adam@1778
|
2822 | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
|
adam@1778
|
2823 | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
|
adam@1777
|
2824 | L.ECApp (
|
adam@1777
|
2825 (L.ECApp (
|
adam@1777
|
2826 (L.ECApp (
|
adam@1777
|
2827 (L.ECApp (
|
adam@1778
|
2828 (L.EFfi ("Basis", "sql_nfunc"), _),
|
adam@1778
|
2829 _), _),
|
adam@1778
|
2830 _), _),
|
adam@1778
|
2831 _), _),
|
adam@1778
|
2832 _) =>
|
adam@1778
|
2833 let
|
adam@1778
|
2834 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1778
|
2835 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adam@1778
|
2836 in
|
adam@1778
|
2837 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
|
adam@1778
|
2838 fm)
|
adam@1778
|
2839 end
|
adam@1778
|
2840
|
adam@1778
|
2841 | L.EFfi ("Basis", "sql_window_normal") => ((L'.ERecord [], loc), fm)
|
adam@1778
|
2842 | L.EFfi ("Basis", "sql_window_fancy") => ((L'.ERecord [], loc), fm)
|
adam@1778
|
2843 | L.ECApp (
|
adam@1778
|
2844 (L.ECApp (
|
adam@1778
|
2845 (L.ECApp (
|
adam@1778
|
2846 (L.ECApp (
|
adam@1778
|
2847 (L.ECApp (
|
adam@1778
|
2848 (L.EFfi ("Basis", "sql_window"), _),
|
adam@1778
|
2849 _), _),
|
adam@1777
|
2850 _), _),
|
adam@1777
|
2851 _), _),
|
adam@1777
|
2852 _), _),
|
adam@1777
|
2853 _) =>
|
adam@1777
|
2854 let
|
adam@1777
|
2855 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1777
|
2856 in
|
adam@1778
|
2857 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
|
adam@1778
|
2858 (L'.EAbs ("e", s, s,
|
adam@1778
|
2859 (L'.ERel 0, loc)), loc)), loc),
|
adam@1777
|
2860 fm)
|
adam@1777
|
2861 end
|
adam@1777
|
2862
|
adam@1778
|
2863 | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm)
|
adam@1776
|
2864
|
adam@1776
|
2865 | L.ECApp (
|
adam@1776
|
2866 (L.ECApp (
|
adam@1776
|
2867 (L.ECApp (
|
adam@1776
|
2868 (L.ECApp (
|
adam@1776
|
2869 (L.ECApp (
|
adam@1778
|
2870 (L.EFfi ("Basis", "sql_ufunc"), _),
|
adamc@746
|
2871 _), _),
|
adamc@746
|
2872 _), _),
|
adamc@746
|
2873 _), _),
|
adamc@746
|
2874 _), _),
|
adamc@746
|
2875 _) =>
|
adamc@746
|
2876 let
|
adamc@746
|
2877 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@746
|
2878 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@746
|
2879 in
|
adamc@746
|
2880 ((L'.EAbs ("f", s, (L'.TFun (s, s), loc),
|
adamc@746
|
2881 (L'.EAbs ("x", s, s,
|
adamc@746
|
2882 strcat [(L'.ERel 1, loc),
|
adamc@746
|
2883 sc "(",
|
adamc@746
|
2884 (L'.ERel 0, loc),
|
adamc@746
|
2885 sc ")"]), loc)), loc),
|
adamc@746
|
2886 fm)
|
adamc@746
|
2887 end
|
adamc@890
|
2888 | L.EFfi ("Basis", "sql_octet_length") =>
|
adamc@890
|
2889 ((L'.EPrim (Prim.String (if #supportsOctetLength (Settings.currentDbms ()) then
|
adamc@890
|
2890 "octet_length"
|
adamc@890
|
2891 else
|
adamc@890
|
2892 "length")), loc), fm)
|
adam@1636
|
2893 | L.EFfi ("Basis", "sql_lower") =>
|
adam@1636
|
2894 ((L'.EPrim (Prim.String "lower"), loc), fm)
|
adam@1636
|
2895 | L.EFfi ("Basis", "sql_upper") =>
|
adam@1636
|
2896 ((L'.EPrim (Prim.String "upper"), loc), fm)
|
adamc@1207
|
2897 | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) =>
|
adamc@1207
|
2898 ((L'.EFfi ("Basis", "sql_known"), loc), fm)
|
adamc@746
|
2899
|
adamc@470
|
2900 | (L.ECApp (
|
adamc@470
|
2901 (L.ECApp (
|
adamc@470
|
2902 (L.ECApp (
|
adamc@470
|
2903 (L.ECApp (
|
adam@1778
|
2904 (L.EFfi ("Basis", "sql_is_null"), _), _),
|
adamc@470
|
2905 _), _),
|
adamc@470
|
2906 _), _),
|
adamc@470
|
2907 _), _)) =>
|
adamc@470
|
2908 let
|
adamc@470
|
2909 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@470
|
2910 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@470
|
2911 in
|
adamc@470
|
2912 ((L'.EAbs ("s", s, s,
|
adamc@598
|
2913 strcat [sc "(",
|
adamc@598
|
2914 (L'.ERel 0, loc),
|
adamc@598
|
2915 sc " IS NULL)"]), loc),
|
adamc@470
|
2916 fm)
|
adamc@470
|
2917 end
|
adamc@470
|
2918
|
kkallio@1572
|
2919 | (L.ECApp (
|
kkallio@1572
|
2920 (L.ECApp (
|
kkallio@1572
|
2921 (L.ECApp (
|
kkallio@1572
|
2922 (L.ECApp (
|
adam@1602
|
2923 (L.EFfi ("Basis", "sql_coalesce"), _), _),
|
adam@1602
|
2924 _), _),
|
adam@1602
|
2925 _), _),
|
adam@1602
|
2926 _), _)) =>
|
adam@1602
|
2927 let
|
adam@1602
|
2928 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1602
|
2929 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adam@1602
|
2930 in
|
adam@1602
|
2931 ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc),
|
adam@1602
|
2932 (L'.EAbs ("x1", s, s,
|
adam@1602
|
2933 strcat [sc "COALESCE(",
|
adam@1602
|
2934 (L'.ERel 1, loc),
|
adam@1602
|
2935 sc ",",
|
adam@1602
|
2936 (L'.ERel 0, loc),
|
adam@1602
|
2937 sc ")"]), loc)), loc),
|
adam@1602
|
2938 fm)
|
adam@1602
|
2939 end
|
adam@1602
|
2940
|
adam@1602
|
2941 | (L.ECApp (
|
adam@1602
|
2942 (L.ECApp (
|
adam@1602
|
2943 (L.ECApp (
|
adam@1602
|
2944 (L.ECApp (
|
adam@1778
|
2945 (L.EFfi ("Basis", "sql_if_then_else"), _), _),
|
kkallio@1572
|
2946 _), _),
|
kkallio@1572
|
2947 _), _),
|
kkallio@1572
|
2948 _), _)) =>
|
kkallio@1572
|
2949 let
|
kkallio@1572
|
2950 val s = (L'.TFfi ("Basis", "string"), loc)
|
kkallio@1572
|
2951 fun sc s = (L'.EPrim (Prim.String s), loc)
|
kkallio@1572
|
2952 in
|
adam@1573
|
2953 ((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
kkallio@1572
|
2954 (L'.EAbs ("then", s, (L'.TFun (s, s), loc),
|
adam@1573
|
2955 (L'.EAbs ("else", s, s,
|
kkallio@1572
|
2956 strcat [sc "(CASE WHEN (",
|
kkallio@1572
|
2957 (L'.ERel 2, loc),
|
kkallio@1572
|
2958 sc ") THEN (",
|
kkallio@1572
|
2959 (L'.ERel 1, loc),
|
kkallio@1572
|
2960 sc ") ELSE (",
|
kkallio@1572
|
2961 (L'.ERel 0, loc),
|
kkallio@1572
|
2962 sc ") END)"]), loc)), loc)), loc),
|
kkallio@1572
|
2963 fm)
|
kkallio@1572
|
2964 end
|
kkallio@1572
|
2965
|
adamc@1081
|
2966 | L.ECApp (
|
adamc@1081
|
2967 (L.ECApp (
|
adamc@1081
|
2968 (L.ECApp (
|
adamc@1081
|
2969 (L.ECApp (
|
adam@1778
|
2970 (L.EFfi ("Basis", "sql_nullable"), _),
|
adamc@1081
|
2971 _), _),
|
adamc@1081
|
2972 _), _),
|
adamc@1081
|
2973 _), _),
|
adamc@1081
|
2974 _) =>
|
adamc@1081
|
2975 let
|
adamc@1081
|
2976 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@1081
|
2977 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@1081
|
2978 in
|
adamc@1081
|
2979 ((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
|
adamc@1081
|
2980 (L'.EAbs ("x", s, s,
|
adamc@1081
|
2981 (L'.ERel 0, loc)), loc)), loc),
|
adamc@1081
|
2982 fm)
|
adamc@1081
|
2983 end
|
adam@1682
|
2984
|
adamc@1191
|
2985 | L.ECApp (
|
adamc@1191
|
2986 (L.ECApp (
|
adamc@1191
|
2987 (L.ECApp (
|
adamc@1191
|
2988 (L.ECApp (
|
adamc@1191
|
2989 (L.ECApp (
|
adam@1421
|
2990 (L.ECApp (
|
adam@1778
|
2991 (L.EFfi ("Basis", "sql_subquery"), _),
|
adam@1421
|
2992 _), _),
|
adamc@1191
|
2993 _), _),
|
adamc@1191
|
2994 _), _),
|
adamc@1191
|
2995 _), _),
|
adamc@1191
|
2996 _), _),
|
adamc@1191
|
2997 _) =>
|
adamc@1191
|
2998 let
|
adamc@1191
|
2999 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@1191
|
3000 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@1191
|
3001 in
|
adam@1421
|
3002 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
|
adam@1421
|
3003 (L'.EAbs ("x", s, s,
|
adam@1421
|
3004 strcat [sc "(",
|
adam@1421
|
3005 (L'.ERel 0, loc),
|
adam@1421
|
3006 sc ")"]), loc)), loc),
|
adamc@1191
|
3007 fm)
|
adamc@1191
|
3008 end
|
adamc@1081
|
3009
|
adam@1778
|
3010 | L.ECApp (
|
adam@1778
|
3011 (L.ECApp (
|
adam@1778
|
3012 (L.ECApp (
|
adam@1778
|
3013 (L.EFfi ("Basis", "sql_no_partition"), _),
|
adam@1778
|
3014 _), _),
|
adam@1778
|
3015 _), _),
|
adam@1778
|
3016 _) => ((L'.EPrim (Prim.String ""), loc), fm)
|
adam@1778
|
3017 | L.ECApp (
|
adam@1778
|
3018 (L.ECApp (
|
adam@1778
|
3019 (L.ECApp (
|
adam@1778
|
3020 (L.ECApp (
|
adam@1778
|
3021 (L.EFfi ("Basis", "sql_partition"), _),
|
adam@1778
|
3022 _), _),
|
adam@1778
|
3023 _), _),
|
adam@1778
|
3024 _), _),
|
adam@1778
|
3025 _) =>
|
adam@1778
|
3026 let
|
adam@1778
|
3027 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1778
|
3028 in
|
adam@1778
|
3029 ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc),
|
adam@1778
|
3030 fm)
|
adam@1778
|
3031 end
|
adam@1778
|
3032
|
adam@1778
|
3033 | L.ECApp (
|
adam@1778
|
3034 (L.ECApp (
|
adam@1778
|
3035 (L.ECApp (
|
adam@1778
|
3036 (L.ECApp (
|
adam@1778
|
3037 (L.EFfi ("Basis", "sql_window_function"), _),
|
adam@1778
|
3038 _), _),
|
adam@1778
|
3039 _), _),
|
adam@1778
|
3040 _), _),
|
adam@1778
|
3041 _) =>
|
adam@1778
|
3042 let
|
adam@1778
|
3043 val () = if #windowFunctions (Settings.currentDbms ()) then
|
adam@1778
|
3044 ()
|
adam@1778
|
3045 else
|
adam@1778
|
3046 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions."
|
adam@1778
|
3047
|
adam@1778
|
3048 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1778
|
3049 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adam@1778
|
3050
|
adam@1778
|
3051 val main = strcat [(L'.ERel 2, loc),
|
adam@1778
|
3052 sc " OVER (",
|
adam@1778
|
3053 (L'.ERel 1, loc),
|
adam@1778
|
3054 (L'.ECase ((L'.ERel 0, loc),
|
adam@1778
|
3055 [((L'.PPrim (Prim.String ""), loc),
|
adam@1778
|
3056 sc ""),
|
adam@1778
|
3057 ((L'.PWild, loc),
|
adam@1778
|
3058 strcat [sc " ORDER BY ",
|
adam@1778
|
3059 (L'.ERel 0, loc)])],
|
adam@1778
|
3060 {disc = s,
|
adam@1778
|
3061 result = s}), loc),
|
adam@1778
|
3062 sc ")"]
|
adam@1778
|
3063 in
|
adam@1778
|
3064 ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adam@1778
|
3065 (L'.EAbs ("p", s, (L'.TFun (s, s), loc),
|
adam@1778
|
3066 (L'.EAbs ("o", s, s,
|
adam@1778
|
3067 main), loc)), loc)), loc),
|
adam@1778
|
3068 fm)
|
adam@1778
|
3069 end
|
adam@1778
|
3070
|
adam@1778
|
3071 | L.ECApp (
|
adam@1778
|
3072 (L.ECApp (
|
adam@1778
|
3073 (L.ECApp (
|
adam@1778
|
3074 (L.ECApp (
|
adam@1778
|
3075 (L.ECApp (
|
adam@1778
|
3076 (L.EFfi ("Basis", "sql_window_aggregate"), _),
|
adam@1778
|
3077 _), _),
|
adam@1778
|
3078 _), _),
|
adam@1778
|
3079 _), _),
|
adam@1778
|
3080 _), _),
|
adam@1778
|
3081 _) =>
|
adam@1778
|
3082 let
|
adam@1778
|
3083 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1778
|
3084 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adam@1778
|
3085
|
adam@1778
|
3086 val main = strcat [(L'.ERel 1, loc),
|
adam@1778
|
3087 sc "(",
|
adam@1778
|
3088 (L'.ERel 0, loc),
|
adam@1778
|
3089 sc ")"]
|
adam@1778
|
3090 in
|
adam@1778
|
3091 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adam@1778
|
3092 (L'.EAbs ("e1", s, s, main), loc)), loc),
|
adam@1778
|
3093 fm)
|
adam@1778
|
3094 end
|
adam@1778
|
3095
|
adam@1778
|
3096 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) =>
|
adam@1778
|
3097 ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm)
|
adam@1778
|
3098 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) =>
|
adam@1778
|
3099 ((L'.EPrim (Prim.String "RANK()"), loc), fm)
|
adam@1778
|
3100
|
adam@1663
|
3101 | L.EFfiApp ("Basis", "nextval", [(e, _)]) =>
|
adamc@338
|
3102 let
|
adamc@338
|
3103 val (e, fm) = monoExp (env, st, fm) e
|
adamc@338
|
3104 in
|
adamc@465
|
3105 ((L'.ENextval e, loc), fm)
|
adamc@338
|
3106 end
|
adam@1663
|
3107 | L.EFfiApp ("Basis", "setval", [(e1, _), (e2, _)]) =>
|
adamc@1073
|
3108 let
|
adamc@1073
|
3109 val (e1, fm) = monoExp (env, st, fm) e1
|
adamc@1073
|
3110 val (e2, fm) = monoExp (env, st, fm) e2
|
adamc@1073
|
3111 in
|
adamc@1073
|
3112 ((L'.ESetval (e1, e2), loc), fm)
|
adamc@1073
|
3113 end
|
adamc@338
|
3114
|
adam@1567
|
3115 | L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm)
|
adam@1567
|
3116
|
adam@1663
|
3117 | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) =>
|
adam@1292
|
3118 let
|
adam@1292
|
3119 val (s1, fm) = monoExp (env, st, fm) s1
|
adam@1292
|
3120 val (s2, fm) = monoExp (env, st, fm) s2
|
adam@1292
|
3121 in
|
adam@1292
|
3122 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
|
adam@1292
|
3123 fm)
|
adam@1292
|
3124 end
|
adam@1292
|
3125
|
adam@2047
|
3126 | L.EFfi ("Basis", "data_kind") => ((L'.EPrim (Prim.String "data-"), loc), fm)
|
adam@2047
|
3127 | L.EFfi ("Basis", "aria_kind") => ((L'.EPrim (Prim.String "aria-"), loc), fm)
|
adam@2047
|
3128
|
adam@2047
|
3129 | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) =>
|
adam@2008
|
3130 let
|
adam@2047
|
3131 val (sk, fm) = monoExp (env, st, fm) sk
|
adam@2008
|
3132 val (s1, fm) = monoExp (env, st, fm) s1
|
adam@2008
|
3133 val (s2, fm) = monoExp (env, st, fm) s2
|
adam@2008
|
3134 in
|
adam@2047
|
3135 ((L'.EStrcat (sk,
|
adam@2008
|
3136 (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc),
|
adam@2008
|
3137 (L'.EStrcat ((L'.EPrim (Prim.String "=\""), loc),
|
adam@2008
|
3138 (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc),
|
adam@2008
|
3139 (L'.EPrim (Prim.String "\""), loc)), loc)),
|
adam@2008
|
3140 loc)), loc)), loc),
|
adam@2008
|
3141 fm)
|
adam@2008
|
3142 end
|
adam@2008
|
3143
|
adam@2008
|
3144 | L.EFfiApp ("Basis", "data_attrs", [(s1, _), (s2, _)]) =>
|
adam@2008
|
3145 let
|
adam@2008
|
3146 val (s1, fm) = monoExp (env, st, fm) s1
|
adam@2008
|
3147 val (s2, fm) = monoExp (env, st, fm) s2
|
adam@2008
|
3148 in
|
adam@2008
|
3149 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
|
adam@2008
|
3150 fm)
|
adam@2008
|
3151 end
|
adam@2008
|
3152
|
adam@1750
|
3153 | L.EFfiApp ("Basis", "css_url", [(s, _)]) =>
|
adam@1750
|
3154 let
|
adam@1750
|
3155 val (s, fm) = monoExp (env, st, fm) s
|
adam@1750
|
3156 in
|
adam@1750
|
3157 ((L'.EStrcat ((L'.EPrim (Prim.String "url("), loc),
|
adam@1750
|
3158 (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
|
adam@1750
|
3159 (L'.EPrim (Prim.String ")"), loc)), loc)), loc),
|
adam@1750
|
3160 fm)
|
adam@1750
|
3161 end
|
adam@1750
|
3162
|
adam@1750
|
3163 | L.EFfiApp ("Basis", "property", [(s, _)]) =>
|
adam@1750
|
3164 let
|
adam@1750
|
3165 val (s, fm) = monoExp (env, st, fm) s
|
adam@1750
|
3166 in
|
adam@1750
|
3167 ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
|
adam@1750
|
3168 (L'.EPrim (Prim.String ":"), loc)), loc),
|
adam@1750
|
3169 fm)
|
adam@1750
|
3170 end
|
adam@1750
|
3171 | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) =>
|
adam@1750
|
3172 let
|
adam@1750
|
3173 val (s1, fm) = monoExp (env, st, fm) s1
|
adam@1750
|
3174 val (s2, fm) = monoExp (env, st, fm) s2
|
adam@1750
|
3175 in
|
adam@1750
|
3176 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
|
adam@1750
|
3177 fm)
|
adam@1750
|
3178 end
|
adam@1750
|
3179
|
adam@1750
|
3180 | L.EFfi ("Basis", "noStyle") => ((L'.EPrim (Prim.String ""), loc), fm)
|
adam@1750
|
3181 | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) =>
|
adam@1750
|
3182 let
|
adam@1750
|
3183 val (s1, fm) = monoExp (env, st, fm) s1
|
adam@1750
|
3184 val (s2, fm) = monoExp (env, st, fm) s2
|
adam@1750
|
3185 in
|
adam@1750
|
3186 ((L'.EStrcat (s1, (L'.EStrcat (s2, (L'.EPrim (Prim.String ";"), loc)), loc)), loc),
|
adam@1750
|
3187 fm)
|
adam@1750
|
3188 end
|
adam@1750
|
3189
|
adamc@139
|
3190 | L.EApp (
|
adamc@139
|
3191 (L.ECApp (
|
adamc@720
|
3192 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
|
adamc@139
|
3193 _), _),
|
adamc@179
|
3194 se) =>
|
adamc@179
|
3195 let
|
adamc@179
|
3196 val (se, fm) = monoExp (env, st, fm) se
|
adamc@179
|
3197 in
|
adam@1663
|
3198 ((L'.EFfiApp ("Basis", "htmlifyString", [(se, (L'.TFfi ("Basis", "string"), loc))]), loc), fm)
|
adamc@179
|
3199 end
|
adam@1358
|
3200 | L.ECApp (
|
adam@1358
|
3201 (L.ECApp ((L.EFfi ("Basis", "cdataChar"), _), _), _),
|
adam@1358
|
3202 _) =>
|
adam@1358
|
3203 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adam@1663
|
3204 (L'.EFfiApp ("Basis", "htmlifySpecialChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc), fm)
|
adamc@179
|
3205
|
adamc@95
|
3206 | L.EApp (
|
adamc@95
|
3207 (L.EApp (
|
adamc@720
|
3208 (L.ECApp (
|
adamc@720
|
3209 (L.ECApp (
|
adamc@95
|
3210 (L.ECApp (
|
adamc@139
|
3211 (L.ECApp (
|
adamc@720
|
3212 (L.EFfi ("Basis", "join"),
|
adamc@720
|
3213 _), _), _),
|
adamc@139
|
3214 _), _),
|
adamc@720
|
3215 _), _),
|
adamc@720
|
3216 _), _),
|
adamc@720
|
3217 xml1), _),
|
adamc@720
|
3218 xml2) =>
|
adamc@179
|
3219 let
|
adamc@179
|
3220 val (xml1, fm) = monoExp (env, st, fm) xml1
|
adamc@179
|
3221 val (xml2, fm) = monoExp (env, st, fm) xml2
|
adamc@179
|
3222 in
|
adamc@179
|
3223 ((L'.EStrcat (xml1, xml2), loc), fm)
|
adamc@179
|
3224 end
|
adamc@95
|
3225
|
adamc@95
|
3226 | L.EApp (
|
adamc@95
|
3227 (L.EApp (
|
adamc@104
|
3228 (L.EApp (
|
adamc@721
|
3229 (L.EApp (
|
adam@1643
|
3230 (L.EApp (
|
adam@1750
|
3231 (L.EApp (
|
adam@1751
|
3232 (L.EApp (
|
adam@1751
|
3233 (L.ECApp (
|
adamc@139
|
3234 (L.ECApp (
|
adamc@139
|
3235 (L.ECApp (
|
adamc@139
|
3236 (L.ECApp (
|
adamc@721
|
3237 (L.ECApp (
|
adam@1643
|
3238 (L.ECApp (
|
adam@1750
|
3239 (L.ECApp (
|
adam@1751
|
3240 (L.ECApp (
|
adam@1751
|
3241 (L.EFfi ("Basis", "tag"),
|
adam@2012
|
3242 _), (L.CRecord (_, attrsGiven), _)), _), _), _), ctxOuter), _), _), _), _), _), _), _), _), _), _), _),
|
adam@1751
|
3243 class), _),
|
adam@1751
|
3244 dynClass), _),
|
adam@1751
|
3245 style), _),
|
adam@1751
|
3246 dynStyle), _),
|
adamc@720
|
3247 attrs), _),
|
adamc@720
|
3248 tag), _),
|
adamc@95
|
3249 xml) =>
|
adamc@95
|
3250 let
|
adamc@140
|
3251 fun getTag' (e, _) =
|
adamc@140
|
3252 case e of
|
adam@1833
|
3253 L.EFfi (_, tag) => (tag, [])
|
adamc@143
|
3254 | L.ECApp (e, t) => let
|
adamc@143
|
3255 val (tag, ts) = getTag' e
|
adamc@143
|
3256 in
|
adamc@143
|
3257 (tag, ts @ [t])
|
adamc@143
|
3258 end
|
adamc@140
|
3259 | _ => (E.errorAt loc "Non-constant XML tag";
|
adamc@140
|
3260 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
|
adamc@143
|
3261 ("", []))
|
adamc@140
|
3262
|
adamc@95
|
3263 fun getTag (e, _) =
|
adamc@95
|
3264 case e of
|
adam@1833
|
3265 L.EFfiApp (_, tag, [((L.ERecord [], _), _)]) => (tag, [])
|
adamc@140
|
3266 | L.EApp (e, (L.ERecord [], _)) => getTag' e
|
adamc@95
|
3267 | _ => (E.errorAt loc "Non-constant XML tag";
|
adamc@95
|
3268 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
|
adamc@143
|
3269 ("", []))
|
adamc@95
|
3270
|
adamc@143
|
3271 val (tag, targs) = getTag tag
|
adamc@95
|
3272
|
adamc@179
|
3273 val (attrs, fm) = monoExp (env, st, fm) attrs
|
adamc@598
|
3274 val attrs = case #1 attrs of
|
adamc@598
|
3275 L'.ERecord xes => xes
|
adamc@1272
|
3276 | _ => map (fn ((L.CName x, _), t) => (x, (L'.EField (attrs, x), loc), monoType env t)
|
adamc@1272
|
3277 | (c, t) => (E.errorAt loc "Non-constant field name for HTML tag attribute";
|
adamc@1272
|
3278 Print.eprefaces' [("Name", CorePrint.p_con env c)];
|
adamc@1272
|
3279 ("", (L'.EField (attrs, ""), loc), monoType env t))) attrsGiven
|
adamc@104
|
3280
|
adamc@717
|
3281 val attrs =
|
adamc@717
|
3282 if List.exists (fn ("Link", _, _) => true
|
adamc@717
|
3283 | _ => false) attrs then
|
adamc@717
|
3284 List.filter (fn ("Href", _, _) => false
|
adamc@717
|
3285 | _ => true) attrs
|
adamc@717
|
3286 else
|
adamc@717
|
3287 attrs
|
adamc@717
|
3288
|
adamc@1042
|
3289 fun findOnload (attrs, onload, onunload, acc) =
|
adamc@668
|
3290 case attrs of
|
adamc@1042
|
3291 [] => (onload, onunload, acc)
|
adamc@1042
|
3292 | ("Onload", e, _) :: rest => findOnload (rest, SOME e, onunload, acc)
|
adamc@1042
|
3293 | ("Onunload", e, _) :: rest => findOnload (rest, onload, SOME e, acc)
|
adamc@1042
|
3294 | x :: rest => findOnload (rest, onload, onunload, x :: acc)
|
adam@1682
|
3295
|
vshabanoff@1711
|
3296 val (onload, onunload, attrs) =
|
vshabanoff@1711
|
3297 if tag = "body" then
|
vshabanoff@1711
|
3298 findOnload (attrs, NONE, NONE, [])
|
vshabanoff@1711
|
3299 else
|
vshabanoff@1711
|
3300 (NONE, NONE, attrs)
|
adamc@668
|
3301
|
adam@2026
|
3302 (* Special case for <button value=""> *)
|
adam@2026
|
3303 val (attrs, extraString) = case tag of
|
adam@2026
|
3304 "button" =>
|
adam@2026
|
3305 (case List.partition (fn (x, _, _) => x = "Value") attrs of
|
adam@2026
|
3306 ([(_, value, _)], rest) =>
|
adam@2026
|
3307 (rest, SOME value)
|
adam@2026
|
3308 | _ => (attrs, NONE))
|
adam@2026
|
3309 | _ => (attrs, NONE)
|
adam@2026
|
3310
|
adam@2026
|
3311
|
adamc@721
|
3312 val (class, fm) = monoExp (env, st, fm) class
|
adam@1643
|
3313 val (dynClass, fm) = monoExp (env, st, fm) dynClass
|
adam@1750
|
3314 val (style, fm) = monoExp (env, st, fm) style
|
adam@1751
|
3315 val (dynStyle, fm) = monoExp (env, st, fm) dynStyle
|
adamc@721
|
3316
|
adam@1926
|
3317 val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script"]
|
adam@1651
|
3318
|
adam@1751
|
3319 fun isSome (e, _) =
|
adam@1751
|
3320 case e of
|
adam@1751
|
3321 L'.ESome _ => true
|
adam@1751
|
3322 | _ => false
|
adam@1751
|
3323
|
adam@1751
|
3324 val () = if isSome dynClass orelse isSome dynStyle then
|
adam@1751
|
3325 if List.exists (fn x => x = tag) dynamics then
|
adam@1751
|
3326 E.errorAt loc ("Dynamic tag <" ^ tag ^ "> cannot be combined with 'dynClass' or 'dynStyle' attribute; an additional <span> may be useful")
|
adam@1751
|
3327 else
|
adam@1751
|
3328 ()
|
adam@1751
|
3329 else
|
adam@1751
|
3330 ()
|
adam@1651
|
3331
|
adam@1479
|
3332 fun tagStart tag' =
|
adamc@598
|
3333 let
|
adamc@721
|
3334 val t = (L'.TFfi ("Basis", "string"), loc)
|
adam@1479
|
3335 val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc)
|
adamc@721
|
3336
|
adam@1817
|
3337 val s = (L'.EStrcat (s,
|
adam@1817
|
3338 (L'.ECase (class,
|
adam@1817
|
3339 [((L'.PPrim (Prim.String ""), loc),
|
adam@1817
|
3340 (L'.EPrim (Prim.String ""), loc)),
|
adam@1817
|
3341 ((L'.PVar ("x", t), loc),
|
adam@1817
|
3342 (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
|
adam@1817
|
3343 (L'.EStrcat ((L'.ERel 0, loc),
|
adam@1817
|
3344 (L'.EPrim (Prim.String "\""), loc)),
|
adam@1817
|
3345 loc)), loc))],
|
adam@1817
|
3346 {disc = t,
|
adam@1817
|
3347 result = t}), loc)), loc)
|
adam@1817
|
3348
|
adam@1817
|
3349 val s = (L'.EStrcat (s,
|
adam@1817
|
3350 (L'.ECase (style,
|
adam@1817
|
3351 [((L'.PPrim (Prim.String ""), loc),
|
adam@1817
|
3352 (L'.EPrim (Prim.String ""), loc)),
|
adam@1817
|
3353 ((L'.PVar ("x", t), loc),
|
adam@1817
|
3354 (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc),
|
adam@1817
|
3355 (L'.EStrcat ((L'.ERel 0, loc),
|
adam@1817
|
3356 (L'.EPrim (Prim.String "\""), loc)),
|
adam@1817
|
3357 loc)), loc))],
|
adam@1817
|
3358 {disc = t,
|
adam@1817
|
3359 result = t}), loc)), loc)
|
adam@1750
|
3360
|
adam@1479
|
3361 val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
|
adam@1479
|
3362 | (("Source", _, _), acc) => acc
|
adam@2008
|
3363 | (("Data", e, _), (s, fm)) =>
|
adam@2008
|
3364 ((L'.EStrcat (s,
|
adam@2008
|
3365 (L'.EStrcat (
|
adam@2008
|
3366 (L'.EPrim (Prim.String " "), loc),
|
adam@2008
|
3367 e), loc)), loc),
|
adam@2008
|
3368 fm)
|
adam@1479
|
3369 | ((x, e, t), (s, fm)) =>
|
adam@1479
|
3370 case t of
|
adam@1479
|
3371 (L'.TFfi ("Basis", "bool"), _) =>
|
adam@1479
|
3372 let
|
adam@1479
|
3373 val s' = " " ^ lowercaseFirst x
|
adam@1479
|
3374 in
|
adam@1479
|
3375 ((L'.ECase (e,
|
adam@1479
|
3376 [((L'.PCon (L'.Enum,
|
adam@1479
|
3377 L'.PConFfi {mod = "Basis",
|
adam@1479
|
3378 datatyp = "bool",
|
adam@1479
|
3379 con = "True",
|
adam@1479
|
3380 arg = NONE},
|
adam@1479
|
3381 NONE), loc),
|
adam@1479
|
3382 (L'.EStrcat (s,
|
adam@1479
|
3383 (L'.EPrim (Prim.String s'), loc)), loc)),
|
adam@1479
|
3384 ((L'.PCon (L'.Enum,
|
adam@1479
|
3385 L'.PConFfi {mod = "Basis",
|
adam@1479
|
3386 datatyp = "bool",
|
adam@1479
|
3387 con = "False",
|
adam@1479
|
3388 arg = NONE},
|
adam@1479
|
3389 NONE), loc),
|
adam@1479
|
3390 s)],
|
adam@1479
|
3391 {disc = (L'.TFfi ("Basis", "bool"), loc),
|
adam@1479
|
3392 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
|
adam@1479
|
3393 fm)
|
adam@1479
|
3394 end
|
adam@1479
|
3395 | (L'.TFun (dom, _), _) =>
|
adam@1479
|
3396 let
|
vshabanoff@1712
|
3397 val e =
|
adam@1479
|
3398 case #1 dom of
|
vshabanoff@1712
|
3399 L'.TRecord [] => (L'.EApp (e, (L'.ERecord [], loc)), loc)
|
adam@1783
|
3400 | _ =>
|
adam@1783
|
3401 if String.isPrefix "Onkey" x then
|
adam@1783
|
3402 (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "keyEvent", []), loc)),
|
adam@1783
|
3403 loc), (L'.ERecord [], loc)), loc)
|
adam@1783
|
3404 else
|
adam@1783
|
3405 (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "mouseEvent", []), loc)),
|
adam@1783
|
3406 loc), (L'.ERecord [], loc)), loc)
|
adam@1783
|
3407
|
vshabanoff@1712
|
3408 val s' = " " ^ lowercaseFirst x ^ "='uw_event=event;exec("
|
adam@1479
|
3409 in
|
adam@1479
|
3410 ((L'.EStrcat (s,
|
adam@1479
|
3411 (L'.EStrcat (
|
adam@1479
|
3412 (L'.EPrim (Prim.String s'), loc),
|
adam@1479
|
3413 (L'.EStrcat (
|
adam@1479
|
3414 (L'.EJavaScript (L'.Attribute, e), loc),
|
adam@1479
|
3415 (L'.EPrim (Prim.String ");return false'"), loc)), loc)),
|
adam@1479
|
3416 loc)), loc),
|
adam@1479
|
3417 fm)
|
adam@1479
|
3418 end
|
adam@1479
|
3419 | _ =>
|
adam@1479
|
3420 let
|
adam@1479
|
3421 val fooify =
|
adam@1479
|
3422 case x of
|
adam@1479
|
3423 "Link" => urlifyExp
|
adam@1479
|
3424 | "Action" => urlifyExp
|
adam@1479
|
3425 | _ => attrifyExp
|
adam@1479
|
3426
|
adam@1479
|
3427 val x =
|
adam@1479
|
3428 case x of
|
adam@1479
|
3429 "Typ" => "Type"
|
adam@1840
|
3430 | "Nam" => "Name"
|
adam@1479
|
3431 | "Link" => "Href"
|
adam@1479
|
3432 | _ => x
|
adam@1840
|
3433
|
adam@1840
|
3434 val x = String.translate (fn #"_" => "-"
|
adam@1840
|
3435 | ch => String.str ch) x
|
adam@1840
|
3436
|
adam@1479
|
3437 val xp = " " ^ lowercaseFirst x ^ "=\""
|
adam@1479
|
3438
|
adam@1479
|
3439 val (e, fm) = fooify env fm (e, t)
|
adam@1479
|
3440 val e = case (tag, x) of
|
adam@1479
|
3441 ("coption", "Value") => (L'.EStrcat ((L'.EPrim (Prim.String "x"), loc), e), loc)
|
adam@1479
|
3442 | _ => e
|
adam@1479
|
3443 in
|
adam@1479
|
3444 ((L'.EStrcat (s,
|
adam@1479
|
3445 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
|
adam@1479
|
3446 (L'.EStrcat (e,
|
adam@1479
|
3447 (L'.EPrim (Prim.String "\""),
|
adam@1479
|
3448 loc)),
|
adam@1479
|
3449 loc)),
|
adam@1479
|
3450 loc)), loc),
|
adam@1479
|
3451 fm)
|
adam@1479
|
3452 end)
|
adam@1479
|
3453 (s, fm) attrs
|
adamc@598
|
3454 in
|
adam@1479
|
3455 (if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then
|
adam@1479
|
3456 (L'.EStrcat (s,
|
adam@1479
|
3457 (L'.EPrim (Prim.String " value=\"\""), loc)), loc)
|
adam@1479
|
3458 else
|
adam@1479
|
3459 s,
|
adam@1479
|
3460 fm)
|
adamc@598
|
3461 end
|
adamc@104
|
3462
|
adamc@143
|
3463 fun input typ =
|
adamc@143
|
3464 case targs of
|
adamc@155
|
3465 [_, (L.CName name, _)] =>
|
adamc@179
|
3466 let
|
adamc@179
|
3467 val (ts, fm) = tagStart "input"
|
adamc@179
|
3468 in
|
adamc@179
|
3469 ((L'.EStrcat (ts,
|
adamc@802
|
3470 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")),
|
adamc@179
|
3471 loc)), loc), fm)
|
adamc@179
|
3472 end
|
adamc@143
|
3473 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adamc@153
|
3474 raise Fail "No name passed to input tag")
|
adamc@104
|
3475
|
adam@1728
|
3476 fun normal (tag, extra) =
|
adamc@143
|
3477 let
|
adamc@179
|
3478 val (tagStart, fm) = tagStart tag
|
adamc@152
|
3479 val tagStart = case extra of
|
adamc@152
|
3480 NONE => tagStart
|
adamc@152
|
3481 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
|
adamc@152
|
3482
|
adamc@143
|
3483 fun normal () =
|
adamc@179
|
3484 let
|
adamc@179
|
3485 val (xml, fm) = monoExp (env, st, fm) xml
|
adam@2026
|
3486
|
adam@2026
|
3487 val xml = case extraString of
|
adam@2026
|
3488 NONE => xml
|
adam@2026
|
3489 | SOME extra => (L'.EStrcat (extra, xml), loc)
|
adamc@179
|
3490 in
|
adamc@179
|
3491 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
|
adamc@179
|
3492 (L'.EStrcat (xml,
|
adamc@179
|
3493 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
|
adamc@179
|
3494 loc)), loc)),
|
adamc@179
|
3495 loc),
|
adamc@179
|
3496 fm)
|
adamc@179
|
3497 end
|
adamc@984
|
3498
|
adamc@984
|
3499 fun isSingleton () =
|
adamc@984
|
3500 let
|
adamc@984
|
3501 val (bef, aft) = Substring.splitl (not o Char.isSpace) (Substring.full tag)
|
adamc@984
|
3502 in
|
adamc@984
|
3503 SS.member (singletons, if Substring.isEmpty aft then
|
adamc@984
|
3504 tag
|
adamc@984
|
3505 else
|
adamc@984
|
3506 Substring.string bef)
|
adamc@984
|
3507 end
|
adamc@143
|
3508 in
|
adam@2026
|
3509 case (xml, extraString) of
|
adam@2026
|
3510 ((L.EApp ((L.ECApp (
|
adam@2026
|
3511 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
|
adam@2026
|
3512 _), _),
|
adam@2026
|
3513 _), _),
|
adam@2026
|
3514 (L.EPrim (Prim.String s), _)), _), NONE) =>
|
adamc@984
|
3515 if CharVector.all Char.isSpace s andalso isSingleton () then
|
adamc@802
|
3516 ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String " />"), loc)), loc), fm)
|
adamc@143
|
3517 else
|
adamc@143
|
3518 normal ()
|
adamc@143
|
3519 | _ => normal ()
|
adamc@143
|
3520 end
|
adamc@606
|
3521
|
adamc@606
|
3522 fun setAttrs jexp =
|
adamc@606
|
3523 let
|
adamc@606
|
3524 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
|
adamc@606
|
3525
|
adamc@606
|
3526 val assgns = List.mapPartial
|
adamc@606
|
3527 (fn ("Source", _, _) => NONE
|
adamc@800
|
3528 | ("Onchange", e, _) =>
|
adamc@970
|
3529 SOME (strcat [str "addOnChange(d,exec(",
|
adamc@815
|
3530 (L'.EJavaScript (L'.Script, e), loc),
|
adam@1398
|
3531 str "));"])
|
adam@1290
|
3532 | (x, e, (L'.TFun ((L'.TRecord [], _), _), _)) =>
|
adamc@970
|
3533 SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
|
adamc@815
|
3534 (L'.EJavaScript (L'.Script, e), loc),
|
adam@1290
|
3535 str ");"])
|
adam@1290
|
3536 | (x, e, _) =>
|
adam@1398
|
3537 if String.isPrefix "On" x then
|
adam@1398
|
3538 let
|
adam@1789
|
3539 val arg = if String.isPrefix "Onkey" x then
|
adam@1789
|
3540 SOME (L'.EFfiApp ("Basis", "keyEvent", []), loc)
|
adam@1789
|
3541 else if String.isSuffix "click" x orelse String.isPrefix "Onmouse" x then
|
adam@1789
|
3542 SOME (L'.EFfiApp ("Basis", "mouseEvent", []), loc)
|
adam@1789
|
3543 else
|
adam@1789
|
3544 NONE
|
adam@1789
|
3545
|
adam@1789
|
3546 val e = liftExpInExp 0 e
|
adam@1789
|
3547
|
adam@1789
|
3548 val e = case arg of
|
adam@1789
|
3549 NONE => e
|
adam@1789
|
3550 | SOME arg => (L'.EApp (e, arg), loc)
|
adam@1789
|
3551
|
adam@1398
|
3552 val e = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
adam@1789
|
3553 (L'.EApp (e, (L'.ERecord [], loc)), loc)), loc)
|
adam@1398
|
3554 in
|
adam@1398
|
3555 case x of
|
adam@1398
|
3556 "Onkeyup" =>
|
adam@1680
|
3557 SOME (strcat [str ("((function(c){addOnKeyUp(d,function(ev){window.uw_event=ev?ev:window.event;return c();});})(exec("),
|
adam@1398
|
3558 (L'.EJavaScript (L'.Script, e), loc),
|
adam@1398
|
3559 str ")));"])
|
adam@1398
|
3560 | _ =>
|
adam@1680
|
3561 SOME (strcat [str ("((function(c){d." ^ lowercaseFirst x ^ "=function(ev){window.uw_event=ev?ev:window.event;return c();};})(exec("),
|
adam@1398
|
3562 (L'.EJavaScript (L'.Script, e), loc),
|
adam@1398
|
3563 str ")));"])
|
adam@1398
|
3564 end
|
adam@1398
|
3565 else
|
adam@1398
|
3566 SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
|
adam@1398
|
3567 (L'.EJavaScript (L'.Script, e), loc),
|
adam@1398
|
3568 str ");"]))
|
adamc@606
|
3569 attrs
|
adamc@1173
|
3570
|
adamc@1173
|
3571 val t = (L'.TFfi ("Basis", "string"), loc)
|
adamc@1173
|
3572 val setClass = (L'.ECase (class,
|
adam@1800
|
3573 [((L'.PPrim (Prim.String ""), loc),
|
adamc@1173
|
3574 str ""),
|
adam@1800
|
3575 ((L'.PVar ("x", t), loc),
|
adamc@1173
|
3576 (L'.EStrcat ((L'.EPrim (Prim.String "d.className=\""), loc),
|
adamc@1173
|
3577 (L'.EStrcat ((L'.ERel 0, loc),
|
adamc@1173
|
3578 (L'.EPrim (Prim.String "\";"), loc)), loc)),
|
adamc@1173
|
3579 loc))],
|
adamc@1173
|
3580 {disc = (L'.TOption t, loc),
|
adamc@1173
|
3581 result = t}), loc)
|
adamc@606
|
3582 in
|
adamc@606
|
3583 case assgns of
|
adamc@1173
|
3584 [] => strcat [str "var d=",
|
adamc@1173
|
3585 jexp,
|
adamc@1173
|
3586 str ";",
|
adamc@1173
|
3587 setClass]
|
adamc@606
|
3588 | _ => strcat (str "var d="
|
adamc@606
|
3589 :: jexp
|
adamc@606
|
3590 :: str ";"
|
adamc@1173
|
3591 :: setClass
|
adamc@606
|
3592 :: assgns)
|
adamc@606
|
3593 end
|
adamc@1042
|
3594
|
adamc@1042
|
3595 fun execify e =
|
adamc@1042
|
3596 case e of
|
adamc@1042
|
3597 NONE => (L'.EPrim (Prim.String ""), loc)
|
adamc@1042
|
3598 | SOME e =>
|
adamc@1042
|
3599 let
|
adamc@1042
|
3600 val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
|
adamc@1042
|
3601 in
|
adamc@1042
|
3602 (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
|
adamc@1042
|
3603 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
|
adamc@1042
|
3604 (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
|
adamc@1042
|
3605 end
|
adam@1643
|
3606
|
adam@2012
|
3607 fun inTag tag' = case ctxOuter of
|
adam@2012
|
3608 (L.CRecord (_, ctx), _) =>
|
adam@2012
|
3609 List.exists (fn ((L.CName tag'', _), _) => tag'' = tag'
|
adam@2012
|
3610 | _ => false) ctx
|
adam@2012
|
3611 | _ => false
|
adam@2012
|
3612
|
adam@2012
|
3613 fun pnode () = if inTag "Tr" then
|
adam@2012
|
3614 "tr"
|
adam@2012
|
3615 else if inTag "Table" then
|
adam@2012
|
3616 "table"
|
adam@2012
|
3617 else
|
adam@2012
|
3618 "span"
|
adam@2012
|
3619
|
adam@1643
|
3620 val baseAll as (base, fm) =
|
adam@1643
|
3621 case tag of
|
adam@1643
|
3622 "body" => let
|
adam@1643
|
3623 val onload = execify onload
|
adam@1643
|
3624 val onunload = execify onunload
|
adam@1663
|
3625 val s = (L'.TFfi ("Basis", "string"), loc)
|
adam@1643
|
3626 in
|
adam@1643
|
3627 normal ("body",
|
adam@1643
|
3628 SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
|
adam@1663
|
3629 [((L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
|
adam@1663
|
3630 [((L'.ERecord [], loc),
|
adam@1663
|
3631 (L'.TRecord [], loc))]), loc),
|
adam@1663
|
3632 onload), loc),
|
adam@1663
|
3633 s)]),
|
adam@1643
|
3634 loc),
|
adam@1643
|
3635 (L'.EFfiApp ("Basis", "maybe_onunload",
|
adam@1663
|
3636 [(onunload, s)]),
|
adam@1728
|
3637 loc)), loc))
|
adam@1643
|
3638 end
|
adam@1643
|
3639
|
adam@1643
|
3640 | "dyn" =>
|
adam@1643
|
3641 let
|
adam@1643
|
3642 in
|
adam@1643
|
3643 case attrs of
|
adam@1643
|
3644 [("Signal", e, _)] =>
|
adam@1643
|
3645 ((L'.EStrcat
|
adam@1643
|
3646 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
|
adam@2012
|
3647 ^ pnode () ^ "\", execD(")), loc),
|
adam@1643
|
3648 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
|
adam@1643
|
3649 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
|
adam@1643
|
3650 fm)
|
adam@1786
|
3651 | _ => raise Fail "Monoize: Bad <dyn> attributes"
|
adam@1643
|
3652 end
|
adam@1682
|
3653
|
adam@1786
|
3654 | "active" =>
|
adam@1786
|
3655 (case attrs of
|
adam@1786
|
3656 [("Code", e, _)] =>
|
adam@1786
|
3657 ((L'.EStrcat
|
adam@1786
|
3658 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">active(execD(")), loc),
|
adam@1786
|
3659 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
|
adam@1786
|
3660 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
|
adam@1786
|
3661 fm)
|
adam@1786
|
3662 | _ => raise Fail "Monoize: Bad <active> attributes")
|
adam@1786
|
3663
|
adam@1926
|
3664 | "script" =>
|
grrwlf@1924
|
3665 (case attrs of
|
grrwlf@1924
|
3666 [("Code", e, _)] =>
|
grrwlf@1924
|
3667 ((L'.EStrcat
|
adam@1926
|
3668 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">execF(execD(")), loc),
|
grrwlf@1924
|
3669 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
|
adam@1926
|
3670 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
|
grrwlf@1924
|
3671 fm)
|
adam@1926
|
3672 | _ => raise Fail "Monoize: Bad <script> attributes")
|
grrwlf@1924
|
3673
|
adam@1728
|
3674 | "submit" => normal ("input type=\"submit\"", NONE)
|
adam@1728
|
3675 | "image" => normal ("input type=\"image\"", NONE)
|
adam@1643
|
3676 | "hidden" => input "hidden"
|
adam@1643
|
3677
|
adam@1643
|
3678 | "textbox" =>
|
adam@1643
|
3679 (case targs of
|
adam@1643
|
3680 [_, (L.CName name, _)] =>
|
adam@1643
|
3681 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
|
adam@1643
|
3682 NONE =>
|
adam@1643
|
3683 let
|
adam@1643
|
3684 val (ts, fm) = tagStart "input"
|
adam@1643
|
3685 in
|
adam@1643
|
3686 ((L'.EStrcat (ts,
|
adam@1835
|
3687 (L'.EPrim (Prim.String (" type=\"text\" name=\"" ^ name ^ "\" />")),
|
adam@1643
|
3688 loc)), loc), fm)
|
adam@1643
|
3689 end
|
adam@1643
|
3690 | SOME (_, src, _) =>
|
adam@1643
|
3691 (strcat [str "<script type=\"text/javascript\">inp(exec(",
|
adam@1643
|
3692 (L'.EJavaScript (L'.Script, src), loc),
|
adam@1643
|
3693 str "), \"",
|
adam@1643
|
3694 str name,
|
adam@1643
|
3695 str "\")</script>"],
|
adam@1643
|
3696 fm))
|
adam@1643
|
3697 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adam@1643
|
3698 raise Fail "No name passed to textbox tag"))
|
adam@1643
|
3699 | "password" => input "password"
|
adam@1643
|
3700 | "textarea" =>
|
adam@1643
|
3701 (case targs of
|
adam@1643
|
3702 [_, (L.CName name, _)] =>
|
adam@1643
|
3703 let
|
adam@1643
|
3704 val (ts, fm) = tagStart "textarea"
|
adam@1643
|
3705 val (xml, fm) = monoExp (env, st, fm) xml
|
adam@1643
|
3706 in
|
adam@1643
|
3707 ((L'.EStrcat ((L'.EStrcat (ts,
|
adam@1643
|
3708 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
|
adam@1643
|
3709 (L'.EStrcat (xml,
|
adam@1643
|
3710 (L'.EPrim (Prim.String "</textarea>"),
|
adam@1643
|
3711 loc)), loc)),
|
adam@1643
|
3712 loc), fm)
|
adam@1643
|
3713 end
|
adam@1643
|
3714 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adam@1643
|
3715 raise Fail "No name passed to ltextarea tag"))
|
adam@1643
|
3716
|
adam@1643
|
3717 | "checkbox" => input "checkbox"
|
adam@1643
|
3718 | "upload" => input "file"
|
adam@1643
|
3719
|
adam@1643
|
3720 | "radio" =>
|
adam@1643
|
3721 (case targs of
|
adam@1643
|
3722 [_, (L.CName name, _)] =>
|
adam@1643
|
3723 monoExp (env, St.setRadioGroup (st, name), fm) xml
|
adam@1643
|
3724 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adam@1643
|
3725 raise Fail "No name passed to radio tag"))
|
adam@1643
|
3726 | "radioOption" =>
|
adam@1643
|
3727 (case St.radioGroup st of
|
adam@1643
|
3728 NONE => raise Fail "No name for radioGroup"
|
adam@1643
|
3729 | SOME name =>
|
adam@1643
|
3730 normal ("input",
|
adam@1728
|
3731 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
|
adam@1643
|
3732
|
adam@1643
|
3733 | "select" =>
|
adam@1643
|
3734 (case targs of
|
adam@1643
|
3735 [_, (L.CName name, _)] =>
|
adam@1643
|
3736 let
|
adam@1643
|
3737 val (ts, fm) = tagStart "select"
|
adam@1643
|
3738 val (xml, fm) = monoExp (env, st, fm) xml
|
adam@1643
|
3739 in
|
adam@1643
|
3740 ((L'.EStrcat ((L'.EStrcat (ts,
|
adam@1643
|
3741 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
|
adam@1643
|
3742 loc)), loc),
|
adam@1643
|
3743 (L'.EStrcat (xml,
|
adam@1643
|
3744 (L'.EPrim (Prim.String "</select>"),
|
adam@1643
|
3745 loc)), loc)),
|
adam@1643
|
3746 loc),
|
adam@1643
|
3747 fm)
|
adam@1643
|
3748 end
|
adam@1643
|
3749 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adam@1643
|
3750 raise Fail "No name passed to lselect tag"))
|
adam@1643
|
3751
|
adam@1643
|
3752 | "ctextbox" =>
|
adam@1643
|
3753 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
|
adam@1643
|
3754 NONE =>
|
adam@1643
|
3755 let
|
adam@1643
|
3756 val (ts, fm) = tagStart "input"
|
adam@1643
|
3757 in
|
adam@1643
|
3758 ((L'.EStrcat (ts,
|
adam@1835
|
3759 (L'.EPrim (Prim.String " type=\"text\" />"), loc)),
|
adam@1643
|
3760 loc), fm)
|
adam@1643
|
3761 end
|
adam@1643
|
3762 | SOME (_, src, _) =>
|
adam@1643
|
3763 let
|
adam@1643
|
3764 val sc = strcat [str "inp(exec(",
|
adam@1643
|
3765 (L'.EJavaScript (L'.Script, src), loc),
|
adam@1643
|
3766 str "))"]
|
adam@1643
|
3767 val sc = setAttrs sc
|
adam@1643
|
3768 in
|
adam@1643
|
3769 (strcat [str "<script type=\"text/javascript\">",
|
adam@1643
|
3770 sc,
|
adam@1643
|
3771 str "</script>"],
|
adam@1643
|
3772 fm)
|
adam@1643
|
3773 end)
|
adam@1643
|
3774
|
adam@1643
|
3775 | "ccheckbox" =>
|
adam@1643
|
3776 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
|
adam@1643
|
3777 NONE =>
|
adam@1643
|
3778 let
|
adam@1643
|
3779 val (ts, fm) = tagStart "input type=\"checkbox\""
|
adam@1643
|
3780 in
|
adam@1643
|
3781 ((L'.EStrcat (ts,
|
adam@1643
|
3782 (L'.EPrim (Prim.String " />"), loc)),
|
adam@1643
|
3783 loc), fm)
|
adam@1643
|
3784 end
|
adam@1643
|
3785 | SOME (_, src, _) =>
|
adam@1643
|
3786 let
|
adam@1643
|
3787 val sc = strcat [str "chk(exec(",
|
adam@1643
|
3788 (L'.EJavaScript (L'.Script, src), loc),
|
adam@1643
|
3789 str "))"]
|
adam@1643
|
3790 val sc = setAttrs sc
|
adam@1643
|
3791 in
|
adam@1643
|
3792 (strcat [str "<script type=\"text/javascript\">",
|
adam@1643
|
3793 sc,
|
adam@1643
|
3794 str "</script>"],
|
adam@1643
|
3795 fm)
|
adam@1643
|
3796 end)
|
adam@1643
|
3797
|
adam@1643
|
3798 | "cselect" =>
|
adam@1643
|
3799 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
|
adam@1643
|
3800 NONE =>
|
adam@1643
|
3801 let
|
adam@1643
|
3802 val (xml, fm) = monoExp (env, st, fm) xml
|
adam@1643
|
3803 val (ts, fm) = tagStart "select"
|
adam@1643
|
3804 in
|
adam@1643
|
3805 (strcat [ts,
|
adam@1643
|
3806 str ">",
|
adam@1643
|
3807 xml,
|
adam@1643
|
3808 str "</select>"],
|
adam@1643
|
3809 fm)
|
adam@1643
|
3810 end
|
adam@1643
|
3811 | SOME (_, src, _) =>
|
adam@1643
|
3812 let
|
adam@1643
|
3813 val (xml, fm) = monoExp (env, st, fm) xml
|
adam@1643
|
3814
|
adam@1643
|
3815 val sc = strcat [str "sel(exec(",
|
adam@1643
|
3816 (L'.EJavaScript (L'.Script, src), loc),
|
adam@1643
|
3817 str "),exec(",
|
adam@1643
|
3818 (L'.EJavaScript (L'.Script, xml), loc),
|
adam@1643
|
3819 str "))"]
|
adam@1643
|
3820 val sc = setAttrs sc
|
adam@1643
|
3821 in
|
adam@1643
|
3822 (strcat [str "<script type=\"text/javascript\">",
|
adam@1643
|
3823 sc,
|
adam@1643
|
3824 str "</script>"],
|
adam@1643
|
3825 fm)
|
adam@1643
|
3826 end)
|
adam@1643
|
3827
|
adam@1728
|
3828 | "coption" => normal ("option", NONE)
|
adam@1643
|
3829
|
adam@1643
|
3830 | "ctextarea" =>
|
adam@1643
|
3831 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
|
adam@1643
|
3832 NONE =>
|
adam@1643
|
3833 let
|
adam@1643
|
3834 val (ts, fm) = tagStart "textarea"
|
adam@1643
|
3835 in
|
adam@1643
|
3836 ((L'.EStrcat (ts,
|
adam@1643
|
3837 (L'.EPrim (Prim.String " />"), loc)),
|
adam@1643
|
3838 loc), fm)
|
adam@1643
|
3839 end
|
adam@1643
|
3840 | SOME (_, src, _) =>
|
adam@1643
|
3841 let
|
adam@1643
|
3842 val sc = strcat [str "tbx(exec(",
|
adam@1643
|
3843 (L'.EJavaScript (L'.Script, src), loc),
|
adam@1643
|
3844 str "))"]
|
adam@1643
|
3845 val sc = setAttrs sc
|
adam@1643
|
3846 in
|
adam@1643
|
3847 (strcat [str "<script type=\"text/javascript\">",
|
adam@1643
|
3848 sc,
|
adam@1643
|
3849 str "</script>"],
|
adam@1643
|
3850 fm)
|
adam@1643
|
3851 end)
|
adam@1643
|
3852
|
adam@1728
|
3853 | "tabl" => normal ("table", NONE)
|
adam@1728
|
3854 | _ => normal (tag, NONE)
|
adam@1643
|
3855 in
|
adam@1643
|
3856 case #1 dynClass of
|
adam@1751
|
3857 L'.ENone _ =>
|
adam@1751
|
3858 (case #1 dynStyle of
|
adam@1751
|
3859 L'.ENone _ => baseAll
|
adam@2012
|
3860 | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"",
|
adam@2012
|
3861 str (pnode ()),
|
adam@2012
|
3862 str "\",execD(",
|
adam@1751
|
3863 (L'.EJavaScript (L'.Script, base), loc),
|
adam@1751
|
3864 str "),null,execD(",
|
adam@1751
|
3865 (L'.EJavaScript (L'.Script, ds), loc),
|
adam@1751
|
3866 str "))</script>"],
|
adam@1751
|
3867 fm)
|
adam@1751
|
3868 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
|
adam@1751
|
3869 baseAll))
|
adam@1751
|
3870 | L'.ESome (_, dc) =>
|
adam@1751
|
3871 let
|
adam@1751
|
3872 val e = case #1 dynStyle of
|
adam@1751
|
3873 L'.ENone _ => str "null"
|
adam@1751
|
3874 | L'.ESome (_, ds) => strcat [str "execD(",
|
adam@1751
|
3875 (L'.EJavaScript (L'.Script, ds), loc),
|
adam@1751
|
3876 str ")"]
|
adam@1751
|
3877 | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
|
adam@1751
|
3878 str "null")
|
adam@1751
|
3879 in
|
adam@2012
|
3880 (strcat [str "<script type=\"text/javascript\">dynClass(\"",
|
adam@2012
|
3881 str (pnode ()),
|
adam@2012
|
3882 str "\",execD(",
|
adam@1751
|
3883 (L'.EJavaScript (L'.Script, base), loc),
|
adam@1751
|
3884 str "),execD(",
|
adam@1751
|
3885 (L'.EJavaScript (L'.Script, dc), loc),
|
adam@1751
|
3886 str "),",
|
adam@1751
|
3887 e,
|
adam@1751
|
3888 str ")</script>"],
|
adam@1751
|
3889 fm)
|
adam@1751
|
3890 end
|
adam@1646
|
3891 | _ => (E.errorAt loc "Absence/presence of 'dynClass' unknown";
|
adam@1646
|
3892 baseAll)
|
adamc@95
|
3893 end
|
adamc@94
|
3894
|
adam@1412
|
3895 | L.EApp (
|
adam@1412
|
3896 (L.EApp ((L.ECApp (
|
adam@1412
|
3897 (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
|
adam@1412
|
3898 (L.CRecord (_, fields), _)), _),
|
adam@1412
|
3899 class), _),
|
adam@1412
|
3900 xml) =>
|
adamc@143
|
3901 let
|
adamc@143
|
3902 fun findSubmit (e, _) =
|
adamc@143
|
3903 case e of
|
adamc@143
|
3904 L.EApp (
|
adamc@143
|
3905 (L.EApp (
|
adamc@143
|
3906 (L.ECApp (
|
adamc@143
|
3907 (L.ECApp (
|
adamc@143
|
3908 (L.ECApp (
|
adamc@143
|
3909 (L.ECApp (
|
adamc@143
|
3910 (L.EFfi ("Basis", "join"),
|
adamc@143
|
3911 _), _), _),
|
adamc@143
|
3912 _), _),
|
adamc@143
|
3913 _), _),
|
adamc@143
|
3914 _), _),
|
adamc@143
|
3915 xml1), _),
|
adamc@143
|
3916 xml2) => (case findSubmit xml1 of
|
adamc@143
|
3917 Error => Error
|
adamc@143
|
3918 | NotFound => findSubmit xml2
|
adamc@143
|
3919 | Found e =>
|
adamc@143
|
3920 case findSubmit xml2 of
|
adamc@143
|
3921 NotFound => Found e
|
adamc@143
|
3922 | _ => Error)
|
adamc@143
|
3923 | L.EApp (
|
adamc@143
|
3924 (L.EApp (
|
adamc@143
|
3925 (L.EApp (
|
adamc@730
|
3926 (L.EApp (
|
adam@1646
|
3927 (L.EApp (
|
adam@1754
|
3928 (L.EApp (
|
adam@1754
|
3929 (L.EApp (
|
adamc@143
|
3930 (L.ECApp (
|
adamc@143
|
3931 (L.ECApp (
|
adamc@143
|
3932 (L.ECApp (
|
adamc@143
|
3933 (L.ECApp (
|
adamc@730
|
3934 (L.ECApp (
|
adam@1646
|
3935 (L.ECApp (
|
adam@1754
|
3936 (L.ECApp (
|
adam@1754
|
3937 (L.ECApp (
|
adam@1754
|
3938 (L.EFfi ("Basis", "tag"),
|
adam@1754
|
3939 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
|
adam@1754
|
3940 _), _),
|
adam@1754
|
3941 _), _),
|
adam@1646
|
3942 _), _),
|
adamc@730
|
3943 _), _),
|
adamc@143
|
3944 attrs), _),
|
adamc@143
|
3945 _), _),
|
adamc@143
|
3946 xml) =>
|
adamc@143
|
3947 (case #1 attrs of
|
adamc@143
|
3948 L.ERecord xes =>
|
adamc@143
|
3949 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
|
adamc@143
|
3950 | _ => NONE) xes of
|
adamc@143
|
3951 NONE => findSubmit xml
|
adamc@143
|
3952 | SOME et =>
|
adamc@143
|
3953 case findSubmit xml of
|
adamc@143
|
3954 NotFound => Found et
|
adamc@143
|
3955 | _ => Error)
|
adamc@143
|
3956 | _ => findSubmit xml)
|
adamc@143
|
3957 | _ => NotFound
|
adamc@143
|
3958
|
adamc@735
|
3959 val (func, action, fm) = case findSubmit xml of
|
adamc@735
|
3960 NotFound => (0, (L'.EPrim (Prim.String ""), loc), fm)
|
adamc@143
|
3961 | Error => raise Fail "Not ready for multi-submit lforms yet"
|
adamc@598
|
3962 | Found (action, actionT) =>
|
adamc@598
|
3963 let
|
adamc@735
|
3964 val func = case #1 action of
|
adamc@735
|
3965 L.EClosure (n, _) => n
|
adamc@735
|
3966 | _ => raise Fail "Monoize: Action is not a closure"
|
adamc@598
|
3967 val actionT = monoType env actionT
|
adamc@598
|
3968 val (action, fm) = monoExp (env, st, fm) action
|
adamc@598
|
3969 val (action, fm) = urlifyExp env fm (action, actionT)
|
adamc@598
|
3970 in
|
adamc@735
|
3971 (func,
|
adamc@735
|
3972 (L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
|
adamc@598
|
3973 (L'.EStrcat (action,
|
adamc@598
|
3974 (L'.EPrim (Prim.String "\""), loc)), loc)), loc),
|
adamc@598
|
3975 fm)
|
adamc@598
|
3976 end
|
adamc@734
|
3977
|
adamc@737
|
3978 val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false,
|
adamc@737
|
3979 con = fn _ => false,
|
adamc@737
|
3980 exp = fn e =>
|
adamc@737
|
3981 case e of
|
adamc@737
|
3982 L.EFfi ("Basis", "upload") => true
|
adamc@737
|
3983 | _ => false} xml
|
adamc@737
|
3984
|
adamc@179
|
3985 val (xml, fm) = monoExp (env, st, fm) xml
|
adamc@735
|
3986
|
adamc@735
|
3987 val xml =
|
adamc@735
|
3988 if IS.member (!readCookie, func) then
|
adamc@735
|
3989 let
|
adamc@735
|
3990 fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s
|
adamc@735
|
3991 | _ => true) fields
|
adamc@735
|
3992
|
adamc@735
|
3993 fun getSigName () =
|
adamc@735
|
3994 let
|
adamc@735
|
3995 fun getSigName' n =
|
adamc@735
|
3996 let
|
adamc@735
|
3997 val s = "Sig" ^ Int.toString n
|
adamc@735
|
3998 in
|
adamc@735
|
3999 if inFields s then
|
adamc@735
|
4000 getSigName' (n + 1)
|
adamc@735
|
4001 else
|
adamc@735
|
4002 s
|
adamc@735
|
4003 end
|
adamc@735
|
4004 in
|
adamc@735
|
4005 if inFields "Sig" then
|
adamc@735
|
4006 getSigName' 0
|
adamc@735
|
4007 else
|
adamc@735
|
4008 "Sig"
|
adamc@735
|
4009 end
|
adamc@735
|
4010
|
adamc@735
|
4011 val sigName = getSigName ()
|
adam@1663
|
4012 val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)
|
adamc@735
|
4013 val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\""
|
adamc@735
|
4014 ^ sigName
|
adamc@735
|
4015 ^ "\" value=\"")), loc),
|
adamc@735
|
4016 sigSet), loc)
|
adamc@735
|
4017 val sigSet = (L'.EStrcat (sigSet,
|
adamc@803
|
4018 (L'.EPrim (Prim.String "\" />"), loc)), loc)
|
adamc@735
|
4019 in
|
adamc@735
|
4020 (L'.EStrcat (sigSet, xml), loc)
|
adamc@735
|
4021 end
|
adamc@735
|
4022 else
|
adamc@735
|
4023 xml
|
adamc@737
|
4024
|
adamc@737
|
4025 val action = if hasUpload then
|
adamc@737
|
4026 (L'.EStrcat (action,
|
adamc@737
|
4027 (L'.EPrim (Prim.String " enctype=\"multipart/form-data\""), loc)), loc)
|
adamc@737
|
4028 else
|
adamc@737
|
4029 action
|
adamc@737
|
4030
|
adam@1412
|
4031 val stt = (L'.TFfi ("Basis", "string"), loc)
|
adam@1412
|
4032 val (class, fm) = monoExp (env, st, fm) class
|
adam@1412
|
4033 val action = (L'.EStrcat (action,
|
adam@1412
|
4034 (L'.ECase (class,
|
adam@1412
|
4035 [((L'.PNone stt, loc),
|
adam@1412
|
4036 (L'.EPrim (Prim.String ""), loc)),
|
adam@1412
|
4037 ((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc),
|
adam@1412
|
4038 (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
|
adam@1412
|
4039 (L'.EStrcat ((L'.ERel 0, loc),
|
adam@1412
|
4040 (L'.EPrim (Prim.String "\""), loc)), loc)), loc))],
|
adam@1412
|
4041 {disc = (L'.TOption stt, loc),
|
adam@1412
|
4042 result = stt}), loc)), loc)
|
adamc@143
|
4043 in
|
adamc@1026
|
4044 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc),
|
adamc@179
|
4045 (L'.EStrcat (action,
|
adamc@598
|
4046 (L'.EPrim (Prim.String ">"), loc)), loc)), loc),
|
adamc@179
|
4047 (L'.EStrcat (xml,
|
adamc@179
|
4048 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
|
adamc@179
|
4049 fm)
|
adamc@143
|
4050 end
|
adamc@141
|
4051
|
adamc@756
|
4052 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
|
adamc@756
|
4053 (L.EFfi ("Basis", "subform"), _), _), _), _),
|
adamc@756
|
4054 _), _), _), (L.CName nm, loc)) =>
|
adamc@756
|
4055 let
|
adamc@756
|
4056 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@756
|
4057 in
|
adamc@756
|
4058 ((L'.EAbs ("xml", s, s,
|
adamc@756
|
4059 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".b\" value=\""
|
adamc@803
|
4060 ^ nm ^ "\" />")), loc),
|
adamc@756
|
4061 (L'.ERel 0, loc),
|
adamc@803
|
4062 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
|
adamc@756
|
4063 loc),
|
adamc@756
|
4064 fm)
|
adamc@756
|
4065 end
|
adamc@756
|
4066
|
adamc@758
|
4067 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
|
adamc@758
|
4068 (L.EFfi ("Basis", "subforms"), _), _), _), _),
|
adamc@758
|
4069 _), _), _), (L.CName nm, loc)) =>
|
adamc@758
|
4070 let
|
adamc@758
|
4071 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@758
|
4072 in
|
adamc@758
|
4073 ((L'.EAbs ("xml", s, s,
|
adamc@758
|
4074 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".s\" value=\""
|
adamc@803
|
4075 ^ nm ^ "\" />")), loc),
|
adamc@758
|
4076 (L'.ERel 0, loc),
|
adamc@803
|
4077 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
|
adamc@758
|
4078 loc),
|
adamc@758
|
4079 fm)
|
adamc@758
|
4080 end
|
adamc@758
|
4081
|
adamc@758
|
4082 | L.ECApp ((L.ECApp (
|
adamc@758
|
4083 (L.EFfi ("Basis", "entry"), _), _), _), _) =>
|
adamc@758
|
4084 let
|
adamc@758
|
4085 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@758
|
4086 in
|
adamc@758
|
4087 ((L'.EAbs ("xml", s, s,
|
adamc@803
|
4088 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".i\" value=\"1\" />")), loc),
|
adamc@758
|
4089 (L'.ERel 0, loc),
|
adamc@803
|
4090 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
|
adamc@758
|
4091 loc),
|
adamc@758
|
4092 fm)
|
adamc@758
|
4093 end
|
adamc@758
|
4094
|
adamc@148
|
4095 | L.EApp ((L.ECApp (
|
adamc@148
|
4096 (L.ECApp (
|
adamc@148
|
4097 (L.ECApp (
|
adamc@148
|
4098 (L.ECApp (
|
adamc@148
|
4099 (L.EFfi ("Basis", "useMore"), _), _), _),
|
adamc@148
|
4100 _), _),
|
adamc@148
|
4101 _), _),
|
adamc@148
|
4102 _), _),
|
adamc@179
|
4103 xml) => monoExp (env, st, fm) xml
|
adamc@148
|
4104
|
adamc@283
|
4105 | L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
|
adamc@283
|
4106 let
|
adamc@283
|
4107 val t = monoType env t
|
adamc@283
|
4108 in
|
adamc@283
|
4109 ((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
|
adamc@283
|
4110 (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
|
adamc@283
|
4111 fm)
|
adamc@283
|
4112 end
|
adam@1932
|
4113 | L.EApp (
|
adam@1932
|
4114 (L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t), _),
|
adam@1932
|
4115 (L.EFfiApp ("Basis", "textBlob", [(e, _)]), _)) =>
|
adam@1932
|
4116 let
|
adam@1932
|
4117 val t = monoType env t
|
adam@1932
|
4118 val un = (L'.TRecord [], loc)
|
adam@1932
|
4119 val (e, fm) = monoExp (env, st, fm) e
|
adam@1932
|
4120 in
|
adam@1932
|
4121 ((L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
|
adam@1932
|
4122 (L'.EAbs ("_", un, t,
|
adam@1932
|
4123 (L'.ESeq ((L'.EFfiApp ("Basis", "clear_page", []), loc),
|
adam@1932
|
4124 (L'.ESeq ((L'.EWrite (liftExpInExp 0 (liftExpInExp 0 e)), loc),
|
adam@1932
|
4125 (L'.EReturnBlob {blob = NONE,
|
adam@1932
|
4126 mimeType = (L'.ERel 1, loc),
|
adam@1932
|
4127 t = t}, loc)), loc)), loc)), loc)),
|
adam@1932
|
4128 loc),
|
adam@1932
|
4129 fm)
|
adam@1932
|
4130 end
|
adamc@741
|
4131 | L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) =>
|
adamc@741
|
4132 let
|
adamc@741
|
4133 val t = monoType env t
|
adamc@741
|
4134 val un = (L'.TRecord [], loc)
|
adamc@741
|
4135 in
|
adamc@741
|
4136 ((L'.EAbs ("b", (L'.TFfi ("Basis", "blob"), loc),
|
adamc@741
|
4137 (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc),
|
adamc@741
|
4138 (L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
|
adamc@741
|
4139 (L'.EAbs ("_", un, t,
|
adam@1932
|
4140 (L'.EReturnBlob {blob = SOME (L'.ERel 2, loc),
|
adamc@741
|
4141 mimeType = (L'.ERel 1, loc),
|
adamc@741
|
4142 t = t}, loc)), loc)), loc)), loc),
|
adamc@741
|
4143 fm)
|
adamc@741
|
4144 end
|
adamc@1065
|
4145 | L.ECApp ((L.EFfi ("Basis", "redirect"), _), t) =>
|
adamc@1065
|
4146 let
|
adamc@1065
|
4147 val t = monoType env t
|
adamc@1065
|
4148 val un = (L'.TRecord [], loc)
|
adamc@1065
|
4149 in
|
adamc@1065
|
4150 ((L'.EAbs ("url", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc),
|
adamc@1065
|
4151 (L'.EAbs ("_", un, t,
|
adamc@1065
|
4152 (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc),
|
adamc@1065
|
4153 fm)
|
adamc@1065
|
4154 end
|
adamc@283
|
4155
|
adamc@1104
|
4156 | L.ECApp ((L.EFfi ("Basis", "serialize"), _), t) =>
|
adamc@1104
|
4157 let
|
adamc@1104
|
4158 val t = monoType env t
|
adamc@1104
|
4159 val (e, fm) = urlifyExp env fm ((L'.ERel 0, loc), t)
|
adamc@1104
|
4160 in
|
adamc@1104
|
4161 ((L'.EAbs ("v", t, (L'.TFfi ("Basis", "string"), loc), e), loc),
|
adamc@1104
|
4162 fm)
|
adamc@1104
|
4163 end
|
adamc@1104
|
4164 | L.ECApp ((L.EFfi ("Basis", "deserialize"), _), t) =>
|
adamc@1104
|
4165 let
|
adamc@1104
|
4166 val t = monoType env t
|
adamc@1104
|
4167 in
|
adamc@1112
|
4168 ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false),
|
adamc@1112
|
4169 loc)), loc),
|
adamc@1104
|
4170 fm)
|
adamc@1104
|
4171 end
|
adamc@1104
|
4172
|
adam@1663
|
4173 | L.EFfiApp ("Basis", "url", [(e, _)]) =>
|
adamc@1067
|
4174 let
|
adamc@1067
|
4175 val (e, fm) = monoExp (env, st, fm) e
|
adam@1370
|
4176 val (e, fm) = urlifyExp env fm (e, dummyTyp)
|
adamc@1067
|
4177 in
|
adam@1370
|
4178 ((L'.EStrcat ((L'.EPrim (Prim.String (Settings.getUrlPrePrefix ())), loc), e), loc), fm)
|
adamc@1067
|
4179 end
|
adamc@1067
|
4180
|
adamc@179
|
4181 | L.EApp (e1, e2) =>
|
adamc@179
|
4182 let
|
adamc@179
|
4183 val (e1, fm) = monoExp (env, st, fm) e1
|
adamc@179
|
4184 val (e2, fm) = monoExp (env, st, fm) e2
|
adamc@179
|
4185 in
|
adamc@179
|
4186 ((L'.EApp (e1, e2), loc), fm)
|
adamc@179
|
4187 end
|
adamc@26
|
4188 | L.EAbs (x, dom, ran, e) =>
|
adamc@179
|
4189 let
|
adamc@179
|
4190 val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
|
adamc@179
|
4191 in
|
adamc@179
|
4192 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
|
adamc@179
|
4193 end
|
adam@1836
|
4194
|
adam@1836
|
4195 | L.ECApp (e, _) =>
|
adam@1836
|
4196 let
|
adam@1836
|
4197 val (e, fm) = monoExp (env, st, fm) e
|
adam@1836
|
4198 in
|
adam@1836
|
4199 case #1 e of
|
adam@1836
|
4200 L'.EFfi _ => (e, fm)
|
adam@1836
|
4201 | _ => poly ()
|
adam@1836
|
4202 end
|
adamc@25
|
4203 | L.ECAbs _ => poly ()
|
adamc@25
|
4204
|
adamc@252
|
4205 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
|
adamc@252
|
4206 | L.EFfiApp (m, x, es) =>
|
adamc@252
|
4207 let
|
adam@1663
|
4208 val (es, fm) = ListUtil.foldlMap (fn ((e, t), fm) =>
|
adam@1663
|
4209 let
|
adam@1663
|
4210 val (e, fm) = monoExp (env, st, fm) e
|
adam@1663
|
4211 in
|
adam@1663
|
4212 ((e, monoType env t), fm)
|
adam@1663
|
4213 end) fm es
|
adamc@252
|
4214 in
|
adamc@252
|
4215 ((L'.EFfiApp (m, x, es), loc), fm)
|
adamc@252
|
4216 end
|
adamc@252
|
4217
|
adamc@179
|
4218 | L.ERecord xes =>
|
adamc@179
|
4219 let
|
adamc@179
|
4220 val (xes, fm) = ListUtil.foldlMap
|
adamc@179
|
4221 (fn ((x, e, t), fm) =>
|
adamc@179
|
4222 let
|
adamc@179
|
4223 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
4224 in
|
adamc@179
|
4225 ((monoName env x,
|
adamc@179
|
4226 e,
|
adamc@179
|
4227 monoType env t), fm)
|
adamc@179
|
4228 end) fm xes
|
adamc@905
|
4229
|
adamc@905
|
4230 val xes = ListMergeSort.sort (fn ((x, _, _), (y, _, _)) => String.compare (x, y) = GREATER) xes
|
adamc@179
|
4231 in
|
adamc@179
|
4232 ((L'.ERecord xes, loc), fm)
|
adamc@179
|
4233 end
|
adamc@179
|
4234 | L.EField (e, x, _) =>
|
adamc@179
|
4235 let
|
adamc@179
|
4236 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
4237 in
|
adamc@179
|
4238 ((L'.EField (e, monoName env x), loc), fm)
|
adamc@179
|
4239 end
|
adamc@445
|
4240 | L.EConcat _ => poly ()
|
adamc@149
|
4241 | L.ECut _ => poly ()
|
adamc@493
|
4242 | L.ECutMulti _ => poly ()
|
adamc@177
|
4243
|
adamc@182
|
4244 | L.ECase (e, pes, {disc, result}) =>
|
adamc@179
|
4245 let
|
adamc@179
|
4246 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
4247 val (pes, fm) = ListUtil.foldlMap
|
adamc@179
|
4248 (fn ((p, e), fm) =>
|
adamc@179
|
4249 let
|
adamc@179
|
4250 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
4251 in
|
adamc@182
|
4252 ((monoPat env p, e), fm)
|
adamc@179
|
4253 end) fm pes
|
adamc@179
|
4254 in
|
adamc@182
|
4255 ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
|
adamc@179
|
4256 end
|
adamc@177
|
4257
|
adamc@179
|
4258 | L.EWrite e =>
|
adamc@179
|
4259 let
|
adamc@179
|
4260 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
4261 in
|
adamc@252
|
4262 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
adamc@252
|
4263 (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
|
adamc@179
|
4264 end
|
adamc@110
|
4265
|
adamc@179
|
4266 | L.EClosure (n, es) =>
|
adamc@179
|
4267 let
|
adamc@179
|
4268 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
|
adamc@179
|
4269 monoExp (env, st, fm) e)
|
adamc@1065
|
4270 fm es
|
adamc@1065
|
4271 val e = (L'.EClosure (n, es), loc)
|
adamc@179
|
4272 in
|
adamc@1067
|
4273 (e, fm)
|
adamc@179
|
4274 end
|
adamc@450
|
4275
|
adamc@450
|
4276 | L.ELet (x, t, e1, e2) =>
|
adamc@450
|
4277 let
|
adamc@450
|
4278 val t' = monoType env t
|
adamc@450
|
4279 val (e1, fm) = monoExp (env, st, fm) e1
|
adamc@450
|
4280 val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2
|
adamc@450
|
4281 in
|
adamc@450
|
4282 ((L'.ELet (x, t', e1, e2), loc), fm)
|
adamc@450
|
4283 end
|
adamc@607
|
4284
|
adam@1848
|
4285 | L.EServerCall (n, es, t, fmode) =>
|
adamc@608
|
4286 let
|
adamc@609
|
4287 val t = monoType env t
|
adamc@614
|
4288 val (_, ft, _, name) = Env.lookupENamed env n
|
adamc@608
|
4289 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
|
adamc@614
|
4290
|
adamc@614
|
4291 fun encodeArgs (es, ft, acc, fm) =
|
adamc@614
|
4292 case (es, ft) of
|
adamc@614
|
4293 ([], _) => (rev acc, fm)
|
adamc@614
|
4294 | (e :: es, (L.TFun (dom, ran), _)) =>
|
adamc@614
|
4295 let
|
adamc@614
|
4296 val (e, fm) = urlifyExp env fm (e, monoType env dom)
|
adamc@614
|
4297 in
|
adamc@614
|
4298 encodeArgs (es, ran, e
|
adamc@614
|
4299 :: (L'.EPrim (Prim.String "/"), loc)
|
adamc@614
|
4300 :: acc, fm)
|
adamc@614
|
4301 end
|
adamc@614
|
4302 | _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
|
adamc@614
|
4303
|
adamc@614
|
4304 val (call, fm) = encodeArgs (es, ft, [], fm)
|
adamc@614
|
4305 val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
|
adamc@614
|
4306 (L'.EPrim (Prim.String name), loc) call
|
adamc@614
|
4307
|
adamc@905
|
4308 val unit = (L'.TRecord [], loc)
|
adamc@905
|
4309
|
adamc@736
|
4310 val eff = if IS.member (!readCookie, n) then
|
adamc@736
|
4311 L'.ReadCookieWrite
|
adamc@736
|
4312 else
|
adamc@736
|
4313 L'.ReadOnly
|
adamc@905
|
4314
|
adam@1848
|
4315 val e = (L'.EServerCall (call, t, eff, fmode), loc)
|
adamc@651
|
4316 val e = liftExpInExp 0 e
|
adamc@651
|
4317 val e = (L'.EAbs ("_", unit, unit, e), loc)
|
adamc@608
|
4318 in
|
adamc@651
|
4319 (e, fm)
|
adamc@608
|
4320 end
|
adamc@626
|
4321
|
adamc@626
|
4322 | L.EKAbs _ => poly ()
|
adamc@626
|
4323 | L.EKApp _ => poly ()
|
adamc@25
|
4324 end
|
adamc@25
|
4325
|
adamc@179
|
4326 fun monoDecl (env, fm) (all as (d, loc)) =
|
adamc@25
|
4327 let
|
adamc@25
|
4328 fun poly () =
|
adamc@25
|
4329 (E.errorAt loc "Unsupported declaration";
|
adamc@25
|
4330 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
|
adamc@25
|
4331 NONE)
|
adamc@25
|
4332 in
|
adamc@25
|
4333 case d of
|
adamc@25
|
4334 L.DCon _ => NONE
|
adamc@808
|
4335 | L.DDatatype [("list", n, [_], [("Nil", _, NONE),
|
adamc@808
|
4336 ("Cons", _, SOME (L.TRecord (L.CRecord (_,
|
adamc@808
|
4337 [((L.CName "1", _),
|
adamc@808
|
4338 (L.CRel 0, _)),
|
adamc@808
|
4339 ((L.CName "2", _),
|
adamc@808
|
4340 (L.CApp ((L.CNamed n', _),
|
adamc@808
|
4341 (L.CRel 0, _)),
|
adamc@808
|
4342 _))]), _), _))])] =>
|
adamc@757
|
4343 if n = n' then
|
adamc@757
|
4344 NONE
|
adamc@757
|
4345 else
|
adamc@757
|
4346 poly ()
|
adamc@808
|
4347 | L.DDatatype dts =>
|
adamc@808
|
4348 let
|
adamc@808
|
4349 val env' = Env.declBinds env all
|
adamc@808
|
4350 val dts = map (fn (x, n, [], xncs) =>
|
adamc@808
|
4351 (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs)
|
adamc@808
|
4352 | _ => (E.errorAt loc "Polymorphic datatype needed too late";
|
adamc@808
|
4353 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
|
adamc@808
|
4354 ("", 0, []))) dts
|
adamc@808
|
4355 val d = (L'.DDatatype dts, loc)
|
adamc@808
|
4356 in
|
adamc@808
|
4357 SOME (env', fm, [d])
|
adamc@808
|
4358 end
|
adamc@179
|
4359 | L.DVal (x, n, t, e, s) =>
|
adamc@179
|
4360 let
|
adamc@179
|
4361 val (e, fm) = monoExp (env, St.empty, fm) e
|
adamc@179
|
4362 in
|
adamc@179
|
4363 SOME (Env.pushENamed env x n t NONE s,
|
adamc@179
|
4364 fm,
|
adamc@273
|
4365 [(L'.DVal (x, n, monoType env t, e, s), loc)])
|
adamc@179
|
4366 end
|
adamc@128
|
4367 | L.DValRec vis =>
|
adamc@128
|
4368 let
|
adamc@1107
|
4369 val vis = map (fn (x, n, t, e, s) =>
|
adamc@1107
|
4370 let
|
adamc@1107
|
4371 fun maybeTransaction (t, e) =
|
adamc@1107
|
4372 case (#1 t, #1 e) of
|
adamc@1107
|
4373 (L.CApp ((L.CFfi ("Basis", "transaction"), _), _), _) =>
|
adamc@1107
|
4374 SOME (L.EAbs ("_",
|
adamc@1107
|
4375 (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc),
|
adamc@1107
|
4376 t,
|
adamc@1107
|
4377 (L.EApp (CoreEnv.liftExpInExp 0 e,
|
adamc@1107
|
4378 (L.ERecord [], loc)), loc)), loc)
|
adamc@1107
|
4379 | (L.TFun (dom, ran), L.EAbs (x, _, _, e)) =>
|
adamc@1107
|
4380 (case maybeTransaction (ran, e) of
|
adamc@1107
|
4381 NONE => NONE
|
adamc@1107
|
4382 | SOME e => SOME (L.EAbs (x, dom, ran, e), loc))
|
adamc@1107
|
4383 | _ => NONE
|
adamc@1107
|
4384 in
|
adamc@1107
|
4385 (x, n, t,
|
adamc@1107
|
4386 case maybeTransaction (t, e) of
|
adamc@1107
|
4387 NONE => e
|
adamc@1107
|
4388 | SOME e => e,
|
adamc@1107
|
4389 s)
|
adamc@1107
|
4390 end) vis
|
adamc@1107
|
4391
|
adamc@128
|
4392 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
|
adamc@179
|
4393
|
adamc@179
|
4394 val (vis, fm) = ListUtil.foldlMap
|
adamc@179
|
4395 (fn ((x, n, t, e, s), fm) =>
|
adamc@179
|
4396 let
|
adamc@179
|
4397 val (e, fm) = monoExp (env, St.empty, fm) e
|
adamc@179
|
4398 in
|
adamc@179
|
4399 ((x, n, monoType env t, e, s), fm)
|
adamc@179
|
4400 end)
|
adamc@179
|
4401 fm vis
|
adamc@128
|
4402 in
|
adamc@128
|
4403 SOME (env,
|
adamc@179
|
4404 fm,
|
adamc@273
|
4405 [(L'.DValRec vis, loc)])
|
adamc@128
|
4406 end
|
adamc@1104
|
4407 | L.DExport (ek, n, b) =>
|
adamc@115
|
4408 let
|
adamc@120
|
4409 val (_, t, _, s) = Env.lookupENamed env n
|
adamc@120
|
4410
|
adamc@609
|
4411 fun unwind (t, args) =
|
adamc@609
|
4412 case #1 t of
|
adamc@609
|
4413 L.TFun (dom, ran) => unwind (ran, dom :: args)
|
adamc@314
|
4414 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
|
adamc@609
|
4415 unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
|
adamc@609
|
4416 | _ => (rev args, t)
|
adamc@120
|
4417
|
adamc@609
|
4418 val (ts, ran) = unwind (t, [])
|
adamc@609
|
4419 val ts = map (monoType env) ts
|
adamc@609
|
4420 val ran = monoType env ran
|
adamc@115
|
4421 in
|
adamc@1104
|
4422 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran, b), loc)])
|
adamc@115
|
4423 end
|
adamc@707
|
4424 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
|
adamc@251
|
4425 let
|
adamc@251
|
4426 val t = (L.CFfi ("Basis", "string"), loc)
|
adamc@251
|
4427 val t' = (L'.TFfi ("Basis", "string"), loc)
|
adam@1953
|
4428 val s = Settings.mangleSqlTable s
|
adamc@704
|
4429 val e_name = (L'.EPrim (Prim.String s), loc)
|
adamc@273
|
4430
|
adamc@273
|
4431 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
|
adamc@704
|
4432
|
adamc@707
|
4433 val (pe, fm) = monoExp (env, St.empty, fm) pe
|
adamc@707
|
4434 val (ce, fm) = monoExp (env, St.empty, fm) ce
|
adamc@251
|
4435 in
|
adamc@251
|
4436 SOME (Env.pushENamed env x n t NONE s,
|
adamc@251
|
4437 fm,
|
adamc@707
|
4438 [(L'.DTable (s, xts, pe, ce), loc),
|
adamc@704
|
4439 (L'.DVal (x, n, t', e_name, s), loc)])
|
adamc@251
|
4440 end
|
adamc@273
|
4441 | L.DTable _ => poly ()
|
adamc@754
|
4442 | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) =>
|
adamc@754
|
4443 let
|
adamc@754
|
4444 val t = (L.CFfi ("Basis", "string"), loc)
|
adamc@754
|
4445 val t' = (L'.TFfi ("Basis", "string"), loc)
|
adam@1953
|
4446 val s = Settings.mangleSqlTable s
|
adamc@754
|
4447 val e_name = (L'.EPrim (Prim.String s), loc)
|
adamc@754
|
4448
|
adamc@754
|
4449 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
|
adamc@754
|
4450
|
adamc@754
|
4451 val (e, fm) = monoExp (env, St.empty, fm) e
|
adam@1663
|
4452 val e = (L'.EFfiApp ("Basis", "viewify", [(e, t')]), loc)
|
adamc@754
|
4453 in
|
adamc@754
|
4454 SOME (Env.pushENamed env x n t NONE s,
|
adamc@754
|
4455 fm,
|
adamc@754
|
4456 [(L'.DView (s, xts, e), loc),
|
adamc@754
|
4457 (L'.DVal (x, n, t', e_name, s), loc)])
|
adamc@754
|
4458 end
|
adamc@754
|
4459 | L.DView _ => poly ()
|
adamc@338
|
4460 | L.DSequence (x, n, s) =>
|
adamc@338
|
4461 let
|
adamc@338
|
4462 val t = (L.CFfi ("Basis", "string"), loc)
|
adamc@338
|
4463 val t' = (L'.TFfi ("Basis", "string"), loc)
|
adam@1953
|
4464 val s = Settings.mangleSql s
|
adamc@338
|
4465 val e = (L'.EPrim (Prim.String s), loc)
|
adamc@338
|
4466 in
|
adamc@338
|
4467 SOME (Env.pushENamed env x n t NONE s,
|
adamc@338
|
4468 fm,
|
adamc@338
|
4469 [(L'.DSequence s, loc),
|
adamc@338
|
4470 (L'.DVal (x, n, t', e, s), loc)])
|
adamc@338
|
4471 end
|
adamc@683
|
4472 | L.DDatabase _ => NONE
|
adamc@462
|
4473 | L.DCookie (x, n, t, s) =>
|
adamc@462
|
4474 let
|
adamc@462
|
4475 val t = (L.CFfi ("Basis", "string"), loc)
|
adamc@462
|
4476 val t' = (L'.TFfi ("Basis", "string"), loc)
|
adamc@462
|
4477 val e = (L'.EPrim (Prim.String s), loc)
|
adamc@462
|
4478 in
|
adamc@462
|
4479 SOME (Env.pushENamed env x n t NONE s,
|
adamc@462
|
4480 fm,
|
adamc@725
|
4481 [(L'.DCookie s, loc),
|
adamc@725
|
4482 (L'.DVal (x, n, t', e, s), loc)])
|
adamc@462
|
4483 end
|
adamc@720
|
4484 | L.DStyle (x, n, s) =>
|
adamc@718
|
4485 let
|
adamc@718
|
4486 val t = (L.CFfi ("Basis", "string"), loc)
|
adamc@718
|
4487 val t' = (L'.TFfi ("Basis", "string"), loc)
|
adamc@718
|
4488 val e = (L'.EPrim (Prim.String s), loc)
|
adamc@718
|
4489 in
|
adamc@718
|
4490 SOME (Env.pushENamed env x n t NONE s,
|
adamc@718
|
4491 fm,
|
adamc@720
|
4492 [(L'.DStyle s, loc),
|
adamc@718
|
4493 (L'.DVal (x, n, t', e, s), loc)])
|
adamc@718
|
4494 end
|
adamc@1075
|
4495 | L.DTask (e1, e2) =>
|
adamc@1073
|
4496 let
|
adamc@1075
|
4497 val (e1, fm) = monoExp (env, St.empty, fm) e1
|
adamc@1075
|
4498 val (e2, fm) = monoExp (env, St.empty, fm) e2
|
adam@1690
|
4499
|
adam@1690
|
4500 val un = (L'.TRecord [], loc)
|
adam@1690
|
4501 val t = if MonoUtil.Exp.exists {typ = fn _ => false,
|
adam@1947
|
4502 exp = fn L'.EFfiApp ("Basis", "periodic", _) =>
|
adam@1947
|
4503 (if #persistent (Settings.currentProtocol ()) then
|
adam@1947
|
4504 ()
|
adam@1947
|
4505 else
|
adam@1947
|
4506 E.errorAt (#2 e1)
|
adam@1947
|
4507 ("Periodic tasks aren't allowed in the selected protocol (" ^ #name (Settings.currentProtocol ()) ^ ").");
|
adam@1947
|
4508 true)
|
adam@1690
|
4509 | _ => false} e1 then
|
adam@1690
|
4510 (L'.TFfi ("Basis", "int"), loc)
|
adam@1690
|
4511 else
|
adam@1690
|
4512 un
|
adam@1690
|
4513
|
adam@1690
|
4514 val e2 = (L'.EAbs ("$x", t, (L'.TFun (un, un), loc),
|
adam@1690
|
4515 (L'.EAbs ("$y", un, un,
|
adam@1690
|
4516 (L'.EApp (
|
adam@1690
|
4517 (L'.EApp (e2, (L'.ERel 1, loc)), loc),
|
adam@1690
|
4518 (L'.ERel 0, loc)), loc)), loc)), loc)
|
adamc@1073
|
4519 in
|
adamc@1073
|
4520 SOME (env,
|
adamc@1073
|
4521 fm,
|
adamc@1075
|
4522 [(L'.DTask (e1, e2), loc)])
|
adamc@1073
|
4523 end
|
adamc@1199
|
4524 | L.DPolicy e =>
|
adamc@1199
|
4525 let
|
adamc@1240
|
4526 fun policies (e, fm) =
|
adamc@1199
|
4527 case #1 e of
|
adam@1663
|
4528 L.EFfiApp ("Basis", "also", [(e1, _), (e2, _)]) =>
|
adamc@1240
|
4529 let
|
adamc@1240
|
4530 val (ps1, fm) = policies (e1, fm)
|
adamc@1240
|
4531 val (ps2, fm) = policies (e2, fm)
|
adamc@1240
|
4532 in
|
adamc@1240
|
4533 (ps1 @ ps2, fm)
|
adamc@1240
|
4534 end
|
adamc@1240
|
4535 | _ =>
|
adamc@1240
|
4536 let
|
adamc@1240
|
4537 val (e, make) =
|
adamc@1240
|
4538 case #1 e of
|
adamc@1240
|
4539 L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sendClient"), _), _), _), _), _), e) =>
|
adamc@1240
|
4540 (e, L'.PolClient)
|
adamc@1240
|
4541 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayInsert"), _), _), _), _), _), e) =>
|
adamc@1240
|
4542 (e, L'.PolInsert)
|
adamc@1240
|
4543 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayDelete"), _), _), _), _), _), e) =>
|
adamc@1240
|
4544 (e, L'.PolDelete)
|
adamc@1240
|
4545 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) =>
|
adamc@1240
|
4546 (e, L'.PolUpdate)
|
adam@1663
|
4547 | L.EFfiApp ("Basis", "sendOwnIds", [(e, _)]) =>
|
adamc@1240
|
4548 (e, L'.PolSequence)
|
adamc@1240
|
4549 | _ => (poly (); (e, L'.PolClient))
|
adamc@1199
|
4550
|
adamc@1240
|
4551 val (e, fm) = monoExp (env, St.empty, fm) e
|
adamc@1240
|
4552 in
|
adamc@1240
|
4553 ([(L'.DPolicy (make e), loc)], fm)
|
adamc@1240
|
4554 end
|
adamc@1240
|
4555
|
adamc@1240
|
4556 val (ps, fm) = policies (e, fm)
|
adamc@1199
|
4557 in
|
adamc@1240
|
4558 SOME (env, fm, ps)
|
adamc@1199
|
4559 end
|
adam@1294
|
4560 | L.DOnError n => SOME (env,
|
adam@1294
|
4561 fm,
|
adam@1294
|
4562 [(L'.DOnError n, loc)])
|
adamc@25
|
4563 end
|
adamc@25
|
4564
|
adamc@683
|
4565 datatype expungable = Client | Channel
|
adamc@683
|
4566
|
adamc@683
|
4567 fun monoize env file =
|
adamc@25
|
4568 let
|
adam@1287
|
4569 val () = pvars := RM.empty
|
adam@1287
|
4570
|
adamc@735
|
4571 (* Calculate which exported functions need cookie signature protection *)
|
adamc@735
|
4572 val rcook = foldl (fn ((d, _), rcook) =>
|
adamc@735
|
4573 case d of
|
adamc@1104
|
4574 L.DExport (L.Action L.ReadCookieWrite, n, _) => IS.add (rcook, n)
|
adamc@1104
|
4575 | L.DExport (L.Rpc L.ReadCookieWrite, n, _) => IS.add (rcook, n)
|
adamc@735
|
4576 | _ => rcook)
|
adamc@735
|
4577 IS.empty file
|
adamc@735
|
4578 val () = readCookie := rcook
|
adamc@735
|
4579
|
adamc@683
|
4580 val loc = E.dummySpan
|
adamc@683
|
4581 val client = (L'.TFfi ("Basis", "client"), loc)
|
adamc@683
|
4582 val unit = (L'.TRecord [], loc)
|
adamc@687
|
4583
|
adamc@687
|
4584 fun calcClientish xts =
|
adamc@687
|
4585 foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
|
adamc@687
|
4586 case #1 x of
|
adamc@687
|
4587 L.CName x =>
|
adamc@687
|
4588 (case #1 t of
|
adamc@687
|
4589 L.CFfi ("Basis", "client") =>
|
adamc@687
|
4590 (nullable, (x, Client) :: notNullable)
|
adamc@687
|
4591 | L.CApp ((L.CFfi ("Basis", "option"), _),
|
adamc@687
|
4592 (L.CFfi ("Basis", "client"), _)) =>
|
adamc@687
|
4593 ((x, Client) :: nullable, notNullable)
|
adamc@687
|
4594 | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
|
adamc@687
|
4595 (nullable, (x, Channel) :: notNullable)
|
adamc@687
|
4596 | L.CApp ((L.CFfi ("Basis", "option"), _),
|
adamc@687
|
4597 (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
|
adamc@687
|
4598 ((x, Channel) :: nullable, notNullable)
|
adamc@687
|
4599 | _ => st)
|
adamc@687
|
4600 | _ => st) ([], []) xts
|
adamc@687
|
4601
|
adamc@683
|
4602 fun expunger () =
|
adamc@683
|
4603 let
|
adam@1663
|
4604 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)
|
adamc@683
|
4605
|
adamc@683
|
4606 fun doTable (tab, xts, e) =
|
adamc@683
|
4607 case xts of
|
adamc@683
|
4608 L.CRecord (_, xts) =>
|
adamc@683
|
4609 let
|
adamc@687
|
4610 val (nullable, notNullable) = calcClientish xts
|
adamc@683
|
4611
|
adamc@684
|
4612 fun cond (x, v) =
|
adam@1953
|
4613 (L'.EStrcat ((L'.EPrim (Prim.String (Settings.mangleSql x
|
adamc@684
|
4614 ^ (case v of
|
adamc@684
|
4615 Client => ""
|
adamc@684
|
4616 | Channel => " >> 32")
|
adamc@684
|
4617 ^ " = ")), loc),
|
adamc@684
|
4618 target), loc)
|
adamc@684
|
4619
|
adamc@684
|
4620 val e =
|
adamc@684
|
4621 foldl (fn ((x, v), e) =>
|
adamc@684
|
4622 (L'.ESeq (
|
adam@1293
|
4623 (L'.EDml ((L'.EStrcat (
|
adam@1953
|
4624 (L'.EPrim (Prim.String ("UPDATE "
|
adam@1953
|
4625 ^ Settings.mangleSql tab
|
adam@1953
|
4626 ^ " SET "
|
adam@1953
|
4627 ^ Settings.mangleSql x
|
adam@1293
|
4628 ^ " = NULL WHERE ")), loc),
|
adam@1293
|
4629 cond (x, v)), loc), L'.Error), loc),
|
adamc@684
|
4630 e), loc))
|
adamc@684
|
4631 e nullable
|
adamc@684
|
4632
|
adamc@683
|
4633 val e =
|
adamc@683
|
4634 case notNullable of
|
adamc@683
|
4635 [] => e
|
adamc@683
|
4636 | eb :: ebs =>
|
adamc@684
|
4637 (L'.ESeq (
|
adamc@684
|
4638 (L'.EDml (foldl
|
adamc@684
|
4639 (fn (eb, s) =>
|
adamc@684
|
4640 (L'.EStrcat (s,
|
adamc@687
|
4641 (L'.EStrcat ((L'.EPrim (Prim.String " OR "),
|
adamc@684
|
4642 loc),
|
adamc@684
|
4643 cond eb), loc)), loc))
|
adam@1953
|
4644 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM "
|
adam@1953
|
4645 ^ Settings.mangleSql tab
|
adamc@684
|
4646 ^ " WHERE ")), loc),
|
adamc@684
|
4647 cond eb), loc)
|
adam@1293
|
4648 ebs, L'.Error), loc),
|
adamc@684
|
4649 e), loc)
|
adamc@683
|
4650 in
|
adamc@683
|
4651 e
|
adamc@683
|
4652 end
|
adamc@683
|
4653 | _ => e
|
adamc@683
|
4654
|
adamc@683
|
4655 val e = (L'.ERecord [], loc)
|
adamc@683
|
4656 in
|
adamc@683
|
4657 foldl (fn ((d, _), e) =>
|
adamc@683
|
4658 case d of
|
adamc@707
|
4659 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
|
adamc@683
|
4660 | _ => e) e file
|
adamc@683
|
4661 end
|
adamc@683
|
4662
|
adamc@687
|
4663 fun initializer () =
|
adamc@687
|
4664 let
|
adamc@687
|
4665 fun doTable (tab, xts, e) =
|
adamc@687
|
4666 case xts of
|
adamc@687
|
4667 L.CRecord (_, xts) =>
|
adamc@687
|
4668 let
|
adamc@687
|
4669 val (nullable, notNullable) = calcClientish xts
|
adamc@687
|
4670
|
adamc@687
|
4671 val e =
|
adamc@687
|
4672 case nullable of
|
adamc@687
|
4673 [] => e
|
adamc@687
|
4674 | (x, _) :: ebs =>
|
adamc@687
|
4675 (L'.ESeq (
|
adam@1293
|
4676 (L'.EDml ((L'.EPrim (Prim.String
|
adam@1293
|
4677 (foldl (fn ((x, _), s) =>
|
adam@1953
|
4678 s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
|
adam@1293
|
4679 ("UPDATE uw_"
|
adam@1293
|
4680 ^ tab
|
adam@1953
|
4681 ^ " SET "
|
adam@1953
|
4682 ^ Settings.mangleSql x
|
adam@1293
|
4683 ^ " = NULL")
|
adam@1293
|
4684 ebs)), loc), L'.Error), loc),
|
adamc@687
|
4685 e), loc)
|
adamc@687
|
4686
|
adamc@687
|
4687 val e =
|
adamc@687
|
4688 case notNullable of
|
adamc@687
|
4689 [] => e
|
adamc@687
|
4690 | eb :: ebs =>
|
adamc@687
|
4691 (L'.ESeq (
|
adam@1953
|
4692 (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM "
|
adam@1953
|
4693 ^ Settings.mangleSql tab)), loc), L'.Error), loc),
|
adamc@687
|
4694 e), loc)
|
adamc@687
|
4695 in
|
adamc@687
|
4696 e
|
adamc@687
|
4697 end
|
adamc@687
|
4698 | _ => e
|
adamc@687
|
4699
|
adamc@687
|
4700 val e = (L'.ERecord [], loc)
|
adamc@687
|
4701 in
|
adamc@687
|
4702 foldl (fn ((d, _), e) =>
|
adamc@687
|
4703 case d of
|
adamc@707
|
4704 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
|
adamc@687
|
4705 | _ => e) e file
|
adamc@687
|
4706 end
|
adamc@687
|
4707
|
adam@1287
|
4708 val mname = CoreUtil.File.maxName file + 1
|
adam@1287
|
4709 val () = nextPvar := mname
|
adam@1287
|
4710
|
adamc@179
|
4711 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
|
adamc@683
|
4712 case #1 d of
|
adamc@683
|
4713 L.DDatabase s =>
|
adamc@683
|
4714 let
|
adamc@687
|
4715 val (nExp, fm) = Fm.freshName fm
|
adamc@687
|
4716 val (nIni, fm) = Fm.freshName fm
|
adam@1682
|
4717
|
adamc@687
|
4718 val dExp = L'.DVal ("expunger",
|
adamc@687
|
4719 nExp,
|
adamc@687
|
4720 (L'.TFun (client, unit), loc),
|
adamc@687
|
4721 (L'.EAbs ("cli", client, unit, expunger ()), loc),
|
adamc@687
|
4722 "expunger")
|
adamc@687
|
4723 val dIni = L'.DVal ("initializer",
|
adamc@687
|
4724 nIni,
|
adamc@687
|
4725 (L'.TFun (unit, unit), loc),
|
adamc@687
|
4726 (L'.EAbs ("_", unit, unit, initializer ()), loc),
|
adamc@687
|
4727 "initializer")
|
adamc@683
|
4728 in
|
adamc@687
|
4729 (env, Fm.enter fm, (L'.DDatabase {name = s,
|
adamc@687
|
4730 expunge = nExp,
|
adamc@687
|
4731 initialize = nIni}, loc)
|
adamc@687
|
4732 :: (dExp, loc)
|
adamc@687
|
4733 :: (dIni, loc)
|
adamc@683
|
4734 :: ds)
|
adamc@683
|
4735 end
|
adamc@683
|
4736 | _ =>
|
adam@1287
|
4737 (pvarDefs := [];
|
adam@1288
|
4738 pvarOldDefs := [];
|
adam@1287
|
4739 case monoDecl (env, fm) d of
|
adam@1287
|
4740 NONE => (env, fm, ds)
|
adam@1287
|
4741 | SOME (env, fm, ds') =>
|
adam@1288
|
4742 (foldr (fn ((n, cs), env) =>
|
adam@1288
|
4743 Env.declBinds env (L.DDatatype [("$poly" ^ Int.toString n,
|
adam@1288
|
4744 n,
|
adam@1288
|
4745 [],
|
adam@1288
|
4746 cs)], loc))
|
adam@1288
|
4747 env (!pvarOldDefs),
|
adam@1287
|
4748 Fm.enter fm,
|
adam@1713
|
4749 case ds' of
|
adam@1713
|
4750 [(L'.DDatatype dts, loc)] =>
|
adam@1713
|
4751 (L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds
|
adam@1713
|
4752 | _ =>
|
adam@1713
|
4753 ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds)))
|
adam@1287
|
4754 (env, Fm.empty mname, []) file
|
adamc@25
|
4755 in
|
adam@1287
|
4756 pvars := RM.empty;
|
adam@1287
|
4757 pvarDefs := [];
|
adam@1288
|
4758 pvarOldDefs := [];
|
adam@1845
|
4759 (rev ds, [])
|
adamc@25
|
4760 end
|
adamc@25
|
4761
|
adamc@25
|
4762 end
|