adamc@25
|
1 (* Copyright (c) 2008, 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
|
adamc@25
|
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@196
|
37
|
adamc@196
|
38 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
|
adamc@25
|
39
|
adamc@252
|
40 structure U = MonoUtil
|
adamc@252
|
41
|
adamc@252
|
42 val liftExpInExp =
|
adamc@252
|
43 U.Exp.mapB {typ = fn t => t,
|
adamc@252
|
44 exp = fn bound => fn e =>
|
adamc@252
|
45 case e of
|
adamc@252
|
46 L'.ERel xn =>
|
adamc@252
|
47 if xn < bound then
|
adamc@252
|
48 e
|
adamc@252
|
49 else
|
adamc@252
|
50 L'.ERel (xn + 1)
|
adamc@252
|
51 | _ => e,
|
adamc@252
|
52 bind = fn (bound, U.Exp.RelE _) => bound + 1
|
adamc@252
|
53 | (bound, _) => bound}
|
adamc@252
|
54
|
adamc@25
|
55 fun monoName env (all as (c, loc)) =
|
adamc@25
|
56 let
|
adamc@25
|
57 fun poly () =
|
adamc@25
|
58 (E.errorAt loc "Unsupported name constructor";
|
adamc@25
|
59 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
|
adamc@25
|
60 "")
|
adamc@25
|
61 in
|
adamc@25
|
62 case c of
|
adamc@25
|
63 L.CName s => s
|
adamc@25
|
64 | _ => poly ()
|
adamc@25
|
65 end
|
adamc@25
|
66
|
adamc@196
|
67 fun monoType env =
|
adamc@25
|
68 let
|
adamc@196
|
69 fun mt env dtmap (all as (c, loc)) =
|
adamc@196
|
70 let
|
adamc@196
|
71 fun poly () =
|
adamc@196
|
72 (E.errorAt loc "Unsupported type constructor";
|
adamc@196
|
73 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
|
adamc@196
|
74 dummyTyp)
|
adamc@196
|
75 in
|
adamc@196
|
76 case c of
|
adamc@196
|
77 L.TFun (c1, c2) => (L'.TFun (mt env dtmap c1, mt env dtmap c2), loc)
|
adamc@196
|
78 | L.TCFun _ => poly ()
|
adamc@196
|
79 | L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
|
adamc@196
|
80 (L'.TRecord (map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs), loc)
|
adamc@196
|
81 | L.TRecord _ => poly ()
|
adamc@196
|
82
|
adamc@288
|
83 | L.CApp ((L.CFfi ("Basis", "option"), _), t) =>
|
adamc@288
|
84 (L'.TOption (mt env dtmap t), loc)
|
adamc@288
|
85
|
adamc@286
|
86 | L.CApp ((L.CFfi ("Basis", "show"), _), t) =>
|
adamc@286
|
87 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
|
adamc@290
|
88 | L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
|
adamc@290
|
89 (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
|
adamc@290
|
90 (L'.TOption (mt env dtmap t), loc)), loc)
|
adamc@286
|
91
|
adamc@196
|
92 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
|
adamc@196
|
93 (L'.TFfi ("Basis", "string"), loc)
|
adamc@196
|
94 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
|
adamc@196
|
95 (L'.TFfi ("Basis", "string"), loc)
|
adamc@196
|
96
|
adamc@251
|
97 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
|
adamc@252
|
98 (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
|
adamc@252
|
99 | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) =>
|
adamc@252
|
100 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
101 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) =>
|
adamc@252
|
102 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
103 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _) =>
|
adamc@252
|
104 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
105 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
|
adamc@252
|
106 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
107
|
adamc@252
|
108 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
|
adamc@252
|
109 (L'.TRecord [], loc)
|
adamc@252
|
110 | L.CFfi ("Basis", "sql_relop") =>
|
adamc@252
|
111 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
112 | L.CFfi ("Basis", "sql_direction") =>
|
adamc@252
|
113 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
114 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_order_by"), _), _), _), _) =>
|
adamc@252
|
115 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
116 | L.CFfi ("Basis", "sql_limit") =>
|
adamc@252
|
117 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
118 | L.CFfi ("Basis", "sql_offset") =>
|
adamc@252
|
119 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
120
|
adamc@252
|
121 | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
|
adamc@252
|
122 (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
|
adamc@252
|
123 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
|
adamc@252
|
124 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
125 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) =>
|
adamc@252
|
126 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
127 | L.CFfi ("Basis", "sql_comparison") =>
|
adamc@252
|
128 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
129 | L.CApp ((L.CFfi ("Basis", "sql_aggregate"), _), t) =>
|
adamc@252
|
130 (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
131 | L.CApp ((L.CFfi ("Basis", "sql_summable"), _), _) =>
|
adamc@252
|
132 (L'.TRecord [], loc)
|
adamc@252
|
133 | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
|
adamc@252
|
134 (L'.TRecord [], loc)
|
adamc@251
|
135
|
adamc@196
|
136 | L.CRel _ => poly ()
|
adamc@196
|
137 | L.CNamed n =>
|
adamc@196
|
138 (case IM.find (dtmap, n) of
|
adamc@196
|
139 SOME r => (L'.TDatatype (n, r), loc)
|
adamc@196
|
140 | NONE =>
|
adamc@196
|
141 let
|
adamc@196
|
142 val r = ref (L'.Default, [])
|
adamc@196
|
143 val (_, xs, xncs) = Env.lookupDatatype env n
|
adamc@196
|
144
|
adamc@196
|
145 val dtmap' = IM.insert (dtmap, n, r)
|
adamc@196
|
146
|
adamc@196
|
147 val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs
|
adamc@196
|
148 in
|
adamc@196
|
149 case xs of
|
adamc@198
|
150 [] =>(r := (ElabUtil.classifyDatatype xncs, xncs);
|
adamc@196
|
151 (L'.TDatatype (n, r), loc))
|
adamc@196
|
152 | _ => poly ()
|
adamc@196
|
153 end)
|
adamc@196
|
154 | L.CFfi mx => (L'.TFfi mx, loc)
|
adamc@196
|
155 | L.CApp _ => poly ()
|
adamc@196
|
156 | L.CAbs _ => poly ()
|
adamc@196
|
157
|
adamc@196
|
158 | L.CName _ => poly ()
|
adamc@196
|
159
|
adamc@196
|
160 | L.CRecord _ => poly ()
|
adamc@196
|
161 | L.CConcat _ => poly ()
|
adamc@196
|
162 | L.CFold _ => poly ()
|
adamc@196
|
163 | L.CUnit => poly ()
|
adamc@214
|
164
|
adamc@214
|
165 | L.CTuple _ => poly ()
|
adamc@214
|
166 | L.CProj _ => poly ()
|
adamc@196
|
167 end
|
adamc@25
|
168 in
|
adamc@196
|
169 mt env IM.empty
|
adamc@25
|
170 end
|
adamc@25
|
171
|
adamc@25
|
172 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
|
adamc@25
|
173
|
adamc@179
|
174 structure IM = IntBinaryMap
|
adamc@179
|
175
|
adamc@179
|
176 datatype foo_kind =
|
adamc@179
|
177 Attr
|
adamc@179
|
178 | Url
|
adamc@179
|
179
|
adamc@179
|
180 fun fk2s fk =
|
adamc@179
|
181 case fk of
|
adamc@179
|
182 Attr => "attr"
|
adamc@179
|
183 | Url => "url"
|
adamc@179
|
184
|
adamc@179
|
185 structure Fm :> sig
|
adamc@179
|
186 type t
|
adamc@179
|
187
|
adamc@179
|
188 val empty : int -> t
|
adamc@179
|
189
|
adamc@179
|
190 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
|
adamc@179
|
191 val enter : t -> t
|
adamc@179
|
192 val decls : t -> L'.decl list
|
adamc@179
|
193 end = struct
|
adamc@179
|
194
|
adamc@179
|
195 structure M = BinaryMapFn(struct
|
adamc@179
|
196 type ord_key = foo_kind
|
adamc@179
|
197 fun compare x =
|
adamc@179
|
198 case x of
|
adamc@179
|
199 (Attr, Attr) => EQUAL
|
adamc@179
|
200 | (Attr, _) => LESS
|
adamc@179
|
201 | (_, Attr) => GREATER
|
adamc@179
|
202
|
adamc@179
|
203 | (Url, Url) => EQUAL
|
adamc@179
|
204 end)
|
adamc@179
|
205
|
adamc@179
|
206 type t = {
|
adamc@179
|
207 count : int,
|
adamc@179
|
208 map : int IM.map M.map,
|
adamc@179
|
209 decls : L'.decl list
|
adamc@179
|
210 }
|
adamc@179
|
211
|
adamc@179
|
212 fun empty count = {
|
adamc@179
|
213 count = count,
|
adamc@179
|
214 map = M.empty,
|
adamc@179
|
215 decls = []
|
adamc@179
|
216 }
|
adamc@179
|
217
|
adamc@179
|
218 fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []}
|
adamc@179
|
219 fun decls ({decls, ...} : t) = decls
|
adamc@179
|
220
|
adamc@179
|
221 fun lookup (t as {count, map, decls}) k n thunk =
|
adamc@120
|
222 let
|
adamc@179
|
223 val im = Option.getOpt (M.find (map, k), IM.empty)
|
adamc@179
|
224 in
|
adamc@179
|
225 case IM.find (im, n) of
|
adamc@179
|
226 NONE =>
|
adamc@179
|
227 let
|
adamc@179
|
228 val n' = count
|
adamc@179
|
229 val (d, {count, map, decls}) = thunk count {count = count + 1,
|
adamc@179
|
230 map = M.insert (map, k, IM.insert (im, n, n')),
|
adamc@179
|
231 decls = decls}
|
adamc@179
|
232 in
|
adamc@179
|
233 ({count = count,
|
adamc@179
|
234 map = map,
|
adamc@179
|
235 decls = d :: decls}, n')
|
adamc@179
|
236 end
|
adamc@179
|
237 | SOME n' => (t, n')
|
adamc@179
|
238 end
|
adamc@179
|
239
|
adamc@179
|
240 end
|
adamc@185
|
241
|
adamc@185
|
242
|
adamc@185
|
243 fun capitalize s =
|
adamc@185
|
244 if s = "" then
|
adamc@185
|
245 s
|
adamc@185
|
246 else
|
adamc@185
|
247 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
|
adamc@179
|
248
|
adamc@179
|
249 fun fooifyExp fk env =
|
adamc@179
|
250 let
|
adamc@179
|
251 fun fooify fm (e, tAll as (t, loc)) =
|
adamc@120
|
252 case #1 e of
|
adamc@120
|
253 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
|
adamc@120
|
254 let
|
adamc@120
|
255 val (_, _, _, s) = Env.lookupENamed env fnam
|
adamc@120
|
256 in
|
adamc@183
|
257 ((L'.EPrim (Prim.String ("/" ^ s)), loc), fm)
|
adamc@120
|
258 end
|
adamc@120
|
259 | L'.EClosure (fnam, args) =>
|
adamc@120
|
260 let
|
adamc@120
|
261 val (_, ft, _, s) = Env.lookupENamed env fnam
|
adamc@120
|
262 val ft = monoType env ft
|
adamc@111
|
263
|
adamc@179
|
264 fun attrify (args, ft, e, fm) =
|
adamc@120
|
265 case (args, ft) of
|
adamc@179
|
266 ([], _) => (e, fm)
|
adamc@120
|
267 | (arg :: args, (L'.TFun (t, ft), _)) =>
|
adamc@179
|
268 let
|
adamc@179
|
269 val (arg', fm) = fooify fm (arg, t)
|
adamc@179
|
270 in
|
adamc@179
|
271 attrify (args, ft,
|
adamc@179
|
272 (L'.EStrcat (e,
|
adamc@179
|
273 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
|
adamc@179
|
274 arg'), loc)), loc),
|
adamc@179
|
275 fm)
|
adamc@179
|
276 end
|
adamc@120
|
277 | _ => (E.errorAt loc "Type mismatch encoding attribute";
|
adamc@179
|
278 (e, fm))
|
adamc@120
|
279 in
|
adamc@183
|
280 attrify (args, ft, (L'.EPrim (Prim.String ("/" ^ s)), loc), fm)
|
adamc@120
|
281 end
|
adamc@120
|
282 | _ =>
|
adamc@120
|
283 case t of
|
adamc@185
|
284 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
|
adamc@200
|
285
|
adamc@179
|
286 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
|
adamc@200
|
287 | L'.TRecord ((x, t) :: xts) =>
|
adamc@200
|
288 let
|
adamc@200
|
289 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
|
adamc@200
|
290 in
|
adamc@200
|
291 foldl (fn ((x, t), (se, fm)) =>
|
adamc@200
|
292 let
|
adamc@200
|
293 val (se', fm) = fooify fm ((L'.EField (e, x), loc), t)
|
adamc@200
|
294 in
|
adamc@200
|
295 ((L'.EStrcat (se,
|
adamc@200
|
296 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
|
adamc@200
|
297 se'), loc)), loc),
|
adamc@200
|
298 fm)
|
adamc@200
|
299 end) (se, fm) xts
|
adamc@200
|
300 end
|
adamc@111
|
301
|
adamc@196
|
302 | L'.TDatatype (i, ref (dk, _)) =>
|
adamc@179
|
303 let
|
adamc@179
|
304 fun makeDecl n fm =
|
adamc@179
|
305 let
|
adamc@193
|
306 val (x, _, xncs) = Env.lookupDatatype env i
|
adamc@179
|
307
|
adamc@179
|
308 val (branches, fm) =
|
adamc@179
|
309 ListUtil.foldlMap
|
adamc@179
|
310 (fn ((x, n, to), fm) =>
|
adamc@179
|
311 case to of
|
adamc@179
|
312 NONE =>
|
adamc@188
|
313 (((L'.PCon (dk, L'.PConVar n, NONE), loc),
|
adamc@179
|
314 (L'.EPrim (Prim.String x), loc)),
|
adamc@179
|
315 fm)
|
adamc@179
|
316 | SOME t =>
|
adamc@179
|
317 let
|
adamc@182
|
318 val t = monoType env t
|
adamc@182
|
319 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
|
adamc@179
|
320 in
|
adamc@188
|
321 (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
|
adamc@179
|
322 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
|
adamc@179
|
323 arg), loc)),
|
adamc@179
|
324 fm)
|
adamc@179
|
325 end)
|
adamc@179
|
326 fm xncs
|
adamc@179
|
327
|
adamc@179
|
328 val dom = tAll
|
adamc@179
|
329 val ran = (L'.TFfi ("Basis", "string"), loc)
|
adamc@179
|
330 in
|
adamc@179
|
331 ((L'.DValRec [(fk2s fk ^ "ify_" ^ x,
|
adamc@179
|
332 n,
|
adamc@179
|
333 (L'.TFun (dom, ran), loc),
|
adamc@179
|
334 (L'.EAbs ("x",
|
adamc@179
|
335 dom,
|
adamc@179
|
336 ran,
|
adamc@179
|
337 (L'.ECase ((L'.ERel 0, loc),
|
adamc@179
|
338 branches,
|
adamc@182
|
339 {disc = dom,
|
adamc@182
|
340 result = ran}), loc)), loc),
|
adamc@179
|
341 "")], loc),
|
adamc@179
|
342 fm)
|
adamc@179
|
343 end
|
adamc@179
|
344
|
adamc@179
|
345 val (fm, n) = Fm.lookup fm fk i makeDecl
|
adamc@179
|
346 in
|
adamc@179
|
347 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
|
adamc@179
|
348 end
|
adamc@164
|
349
|
adamc@120
|
350 | _ => (E.errorAt loc "Don't know how to encode attribute type";
|
adamc@120
|
351 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
|
adamc@179
|
352 (dummyExp, fm))
|
adamc@120
|
353 in
|
adamc@120
|
354 fooify
|
adamc@120
|
355 end
|
adamc@120
|
356
|
adamc@179
|
357 val attrifyExp = fooifyExp Attr
|
adamc@179
|
358 val urlifyExp = fooifyExp Url
|
adamc@105
|
359
|
adamc@143
|
360 datatype 'a failable_search =
|
adamc@143
|
361 Found of 'a
|
adamc@143
|
362 | NotFound
|
adamc@143
|
363 | Error
|
adamc@143
|
364
|
adamc@153
|
365 structure St :> sig
|
adamc@153
|
366 type t
|
adamc@153
|
367
|
adamc@153
|
368 val empty : t
|
adamc@153
|
369
|
adamc@153
|
370 val radioGroup : t -> string option
|
adamc@153
|
371 val setRadioGroup : t * string -> t
|
adamc@153
|
372 end = struct
|
adamc@153
|
373
|
adamc@153
|
374 type t = {
|
adamc@153
|
375 radioGroup : string option
|
adamc@153
|
376 }
|
adamc@153
|
377
|
adamc@153
|
378 val empty = {radioGroup = NONE}
|
adamc@153
|
379
|
adamc@153
|
380 fun radioGroup (t : t) = #radioGroup t
|
adamc@153
|
381
|
adamc@153
|
382 fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
|
adamc@153
|
383
|
adamc@153
|
384 end
|
adamc@153
|
385
|
adamc@186
|
386 fun monoPatCon env pc =
|
adamc@178
|
387 case pc of
|
adamc@178
|
388 L.PConVar n => L'.PConVar n
|
adamc@188
|
389 | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
|
adamc@188
|
390 arg = Option.map (monoType env) arg}
|
adamc@178
|
391
|
adamc@193
|
392 val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
|
adamc@193
|
393
|
adamc@193
|
394 fun monoPat env (all as (p, loc)) =
|
adamc@193
|
395 let
|
adamc@193
|
396 fun poly () =
|
adamc@193
|
397 (E.errorAt loc "Unsupported pattern";
|
adamc@193
|
398 Print.eprefaces' [("Pattern", CorePrint.p_pat env all)];
|
adamc@193
|
399 dummyPat)
|
adamc@193
|
400 in
|
adamc@193
|
401 case p of
|
adamc@193
|
402 L.PWild => (L'.PWild, loc)
|
adamc@193
|
403 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
|
adamc@193
|
404 | L.PPrim p => (L'.PPrim p, loc)
|
adamc@193
|
405 | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
|
adamc@288
|
406 | L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc)
|
adamc@288
|
407 | L.PCon (L.Option, _, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc)
|
adamc@193
|
408 | L.PCon _ => poly ()
|
adamc@193
|
409 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
|
adamc@193
|
410 end
|
adamc@178
|
411
|
adamc@252
|
412 fun strcat loc es =
|
adamc@252
|
413 case es of
|
adamc@252
|
414 [] => (L'.EPrim (Prim.String ""), loc)
|
adamc@252
|
415 | [e] => e
|
adamc@252
|
416 | _ =>
|
adamc@252
|
417 let
|
adamc@252
|
418 val e2 = List.last es
|
adamc@252
|
419 val es = List.take (es, length es - 1)
|
adamc@252
|
420 val e1 = List.last es
|
adamc@252
|
421 val es = List.take (es, length es - 1)
|
adamc@252
|
422 in
|
adamc@252
|
423 foldr (fn (e, e') => (L'.EStrcat (e, e'), loc))
|
adamc@252
|
424 (L'.EStrcat (e1, e2), loc) es
|
adamc@252
|
425 end
|
adamc@252
|
426
|
adamc@252
|
427 fun strcatComma loc es =
|
adamc@252
|
428 case es of
|
adamc@252
|
429 [] => (L'.EPrim (Prim.String ""), loc)
|
adamc@252
|
430 | [e] => e
|
adamc@252
|
431 | _ =>
|
adamc@252
|
432 let
|
adamc@252
|
433 val e1 = List.last es
|
adamc@252
|
434 val es = List.take (es, length es - 1)
|
adamc@252
|
435 in
|
adamc@252
|
436 foldr (fn (e, e') =>
|
adamc@265
|
437 case (e, e') of
|
adamc@265
|
438 ((L'.EPrim (Prim.String ""), _), _) => e'
|
adamc@265
|
439 | (_, (L'.EPrim (Prim.String ""), _)) => e
|
adamc@252
|
440 | _ =>
|
adamc@252
|
441 (L'.EStrcat (e,
|
adamc@252
|
442 (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc))
|
adamc@252
|
443 e1 es
|
adamc@252
|
444 end
|
adamc@252
|
445
|
adamc@252
|
446 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
|
adamc@252
|
447
|
adamc@179
|
448 fun monoExp (env, st, fm) (all as (e, loc)) =
|
adamc@25
|
449 let
|
adamc@25
|
450 fun poly () =
|
adamc@25
|
451 (E.errorAt loc "Unsupported expression";
|
adamc@25
|
452 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
|
adamc@179
|
453 (dummyExp, fm))
|
adamc@25
|
454 in
|
adamc@25
|
455 case e of
|
adamc@179
|
456 L.EPrim p => ((L'.EPrim p, loc), fm)
|
adamc@179
|
457 | L.ERel n => ((L'.ERel n, loc), fm)
|
adamc@179
|
458 | L.ENamed n => ((L'.ENamed n, loc), fm)
|
adamc@193
|
459 | L.ECon (dk, pc, [], eo) =>
|
adamc@193
|
460 let
|
adamc@179
|
461 val (eo, fm) =
|
adamc@179
|
462 case eo of
|
adamc@179
|
463 NONE => (NONE, fm)
|
adamc@179
|
464 | SOME e =>
|
adamc@179
|
465 let
|
adamc@179
|
466 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
467 in
|
adamc@179
|
468 (SOME e, fm)
|
adamc@179
|
469 end
|
adamc@179
|
470 in
|
adamc@188
|
471 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
|
adamc@193
|
472 end
|
adamc@193
|
473 | L.ECon _ => poly ()
|
adamc@94
|
474
|
adamc@286
|
475 | L.ECApp ((L.EFfi ("Basis", "show"), _), t) =>
|
adamc@286
|
476 let
|
adamc@286
|
477 val t = monoType env t
|
adamc@286
|
478 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@286
|
479 in
|
adamc@286
|
480 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
|
adamc@286
|
481 (L'.ERel 0, loc)), loc), fm)
|
adamc@286
|
482 end
|
adamc@286
|
483 | L.EFfi ("Basis", "show_int") =>
|
adamc@286
|
484 ((L'.EFfi ("Basis", "intToString"), loc), fm)
|
adamc@286
|
485 | L.EFfi ("Basis", "show_float") =>
|
adamc@286
|
486 ((L'.EFfi ("Basis", "floatToString"), loc), fm)
|
adamc@286
|
487 | L.EFfi ("Basis", "show_string") =>
|
adamc@286
|
488 let
|
adamc@286
|
489 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@286
|
490 in
|
adamc@286
|
491 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
|
adamc@286
|
492 end
|
adamc@286
|
493 | L.EFfi ("Basis", "show_bool") =>
|
adamc@286
|
494 ((L'.EFfi ("Basis", "boolToString"), loc), fm)
|
adamc@286
|
495
|
adamc@290
|
496 | L.ECApp ((L.EFfi ("Basis", "read"), _), t) =>
|
adamc@290
|
497 let
|
adamc@290
|
498 val t = monoType env t
|
adamc@290
|
499 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@290
|
500 in
|
adamc@290
|
501 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
|
adamc@290
|
502 (L'.ERel 0, loc)), loc), fm)
|
adamc@290
|
503 end
|
adamc@290
|
504 | L.EFfi ("Basis", "read_int") =>
|
adamc@290
|
505 ((L'.EFfi ("Basis", "stringToInt"), loc), fm)
|
adamc@290
|
506 | L.EFfi ("Basis", "read_float") =>
|
adamc@290
|
507 ((L'.EFfi ("Basis", "stringToFloat"), loc), fm)
|
adamc@290
|
508 | L.EFfi ("Basis", "read_string") =>
|
adamc@290
|
509 let
|
adamc@290
|
510 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@290
|
511 in
|
adamc@290
|
512 ((L'.EAbs ("s", s, (L'.TOption s, loc),
|
adamc@290
|
513 (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), fm)
|
adamc@290
|
514 end
|
adamc@290
|
515 | L.EFfi ("Basis", "read_bool") =>
|
adamc@290
|
516 ((L'.EFfi ("Basis", "stringToBool"), loc), fm)
|
adamc@290
|
517
|
adamc@251
|
518 | L.ECApp ((L.EFfi ("Basis", "return"), _), t) =>
|
adamc@252
|
519 let
|
adamc@252
|
520 val t = monoType env t
|
adamc@252
|
521 in
|
adamc@252
|
522 ((L'.EAbs ("x", t,
|
adamc@252
|
523 (L'.TFun ((L'.TRecord [], loc), t), loc),
|
adamc@252
|
524 (L'.EAbs ("_", (L'.TRecord [], loc), t,
|
adamc@252
|
525 (L'.ERel 1, loc)), loc)), loc), fm)
|
adamc@252
|
526 end
|
adamc@251
|
527 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), t1), _), t2) =>
|
adamc@251
|
528 let
|
adamc@251
|
529 val t1 = monoType env t1
|
adamc@251
|
530 val t2 = monoType env t2
|
adamc@251
|
531 val un = (L'.TRecord [], loc)
|
adamc@252
|
532 val mt1 = (L'.TFun (un, t1), loc)
|
adamc@252
|
533 val mt2 = (L'.TFun (un, t2), loc)
|
adamc@251
|
534 in
|
adamc@252
|
535 ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, (L'.TFun (un, un), loc)), loc)), loc),
|
adamc@252
|
536 (L'.EAbs ("m2", mt2, (L'.TFun (un, un), loc),
|
adamc@252
|
537 (L'.EAbs ("_", un, un,
|
adamc@252
|
538 (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
|
adamc@252
|
539 (L'.ERecord [], loc)), loc),
|
adamc@252
|
540 (L'.EApp (
|
adamc@252
|
541 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
|
adamc@252
|
542 (L'.ERecord [], loc)),
|
adamc@252
|
543 loc)), loc)), loc)), loc)), loc),
|
adamc@251
|
544 fm)
|
adamc@251
|
545 end
|
adamc@251
|
546
|
adamc@252
|
547 | L.ECApp (
|
adamc@252
|
548 (L.ECApp (
|
adamc@252
|
549 (L.ECApp ((L.EFfi ("Basis", "query"), _), (L.CRecord (_, tables), _)), _),
|
adamc@252
|
550 exps), _),
|
adamc@252
|
551 state) =>
|
adamc@252
|
552 (case monoType env (L.TRecord exps, loc) of
|
adamc@252
|
553 (L'.TRecord exps, _) =>
|
adamc@252
|
554 let
|
adamc@252
|
555 val tables = map (fn ((L.CName x, _), xts) =>
|
adamc@252
|
556 (case monoType env (L.TRecord xts, loc) of
|
adamc@252
|
557 (L'.TRecord xts, _) => SOME (x, xts)
|
adamc@252
|
558 | _ => NONE)
|
adamc@252
|
559 | _ => NONE) tables
|
adamc@252
|
560 in
|
adamc@252
|
561 if List.exists (fn x => x = NONE) tables then
|
adamc@252
|
562 poly ()
|
adamc@252
|
563 else
|
adamc@252
|
564 let
|
adamc@252
|
565 val tables = List.mapPartial (fn x => x) tables
|
adamc@252
|
566 val state = monoType env state
|
adamc@252
|
567 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
568 val un = (L'.TRecord [], loc)
|
adamc@252
|
569
|
adamc@252
|
570 val rt = exps @ map (fn (x, xts) => (x, (L'.TRecord xts, loc))) tables
|
adamc@252
|
571 val ft = (L'.TFun ((L'.TRecord rt, loc),
|
adamc@252
|
572 (L'.TFun (state,
|
adamc@252
|
573 (L'.TFun (un, state), loc)),
|
adamc@252
|
574 loc)), loc)
|
adamc@252
|
575
|
adamc@267
|
576 val body' = (L'.EApp (
|
adamc@267
|
577 (L'.EApp (
|
adamc@267
|
578 (L'.EApp ((L'.ERel 4, loc),
|
adamc@267
|
579 (L'.ERel 1, loc)), loc),
|
adamc@267
|
580 (L'.ERel 0, loc)), loc),
|
adamc@267
|
581 (L'.ERecord [], loc)), loc)
|
adamc@252
|
582
|
adamc@252
|
583 val body = (L'.EQuery {exps = exps,
|
adamc@252
|
584 tables = tables,
|
adamc@252
|
585 state = state,
|
adamc@252
|
586 query = (L'.ERel 3, loc),
|
adamc@252
|
587 body = body',
|
adamc@252
|
588 initial = (L'.ERel 1, loc)},
|
adamc@252
|
589 loc)
|
adamc@252
|
590 in
|
adamc@252
|
591 ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
|
adamc@252
|
592 (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
|
adamc@252
|
593 (L'.EAbs ("i", state, (L'.TFun (un, state), loc),
|
adamc@252
|
594 (L'.EAbs ("_", un, state,
|
adamc@252
|
595 body), loc)), loc)), loc)), loc), fm)
|
adamc@252
|
596 end
|
adamc@252
|
597 end
|
adamc@252
|
598 | _ => poly ())
|
adamc@252
|
599
|
adamc@252
|
600 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _) =>
|
adamc@252
|
601 let
|
adamc@252
|
602 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@252
|
603 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
604 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
|
adamc@252
|
605 in
|
adamc@252
|
606 ((L'.EAbs ("r",
|
adamc@252
|
607 (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc),
|
adamc@252
|
608 s,
|
adamc@252
|
609 strcat loc [gf "Rows",
|
adamc@261
|
610 (L'.ECase (gf "OrderBy",
|
adamc@261
|
611 [((L'.PPrim (Prim.String ""), loc), sc ""),
|
adamc@261
|
612 ((L'.PWild, loc),
|
adamc@261
|
613 strcat loc [sc " ORDER BY ",
|
adamc@261
|
614 gf "OrderBy"])],
|
adamc@261
|
615 {disc = s, result = s}), loc),
|
adamc@252
|
616 gf "Limit",
|
adamc@252
|
617 gf "Offset"]), loc), fm)
|
adamc@252
|
618 end
|
adamc@252
|
619
|
adamc@252
|
620 | L.ECApp (
|
adamc@252
|
621 (L.ECApp (
|
adamc@252
|
622 (L.ECApp (
|
adamc@252
|
623 (L.ECApp (
|
adamc@252
|
624 (L.EFfi ("Basis", "sql_query1"), _),
|
adamc@252
|
625 (L.CRecord (_, tables), _)), _),
|
adamc@252
|
626 (L.CRecord (_, grouped), _)), _),
|
adamc@252
|
627 (L.CRecord (_, stables), _)), _),
|
adamc@252
|
628 sexps) =>
|
adamc@252
|
629 let
|
adamc@252
|
630 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@252
|
631 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
632 val un = (L'.TRecord [], loc)
|
adamc@252
|
633 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
|
adamc@252
|
634
|
adamc@252
|
635 fun doTables tables =
|
adamc@252
|
636 let
|
adamc@252
|
637 val tables = map (fn ((L.CName x, _), xts) =>
|
adamc@252
|
638 (case monoType env (L.TRecord xts, loc) of
|
adamc@252
|
639 (L'.TRecord xts, _) => SOME (x, xts)
|
adamc@252
|
640 | _ => NONE)
|
adamc@252
|
641 | _ => NONE) tables
|
adamc@252
|
642 in
|
adamc@252
|
643 if List.exists (fn x => x = NONE) tables then
|
adamc@252
|
644 NONE
|
adamc@252
|
645 else
|
adamc@260
|
646 let
|
adamc@260
|
647 val tables = List.mapPartial (fn x => x) tables
|
adamc@260
|
648 val tables = ListMergeSort.sort
|
adamc@260
|
649 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
|
adamc@260
|
650 tables
|
adamc@260
|
651 val tables = map (fn (x, xts) =>
|
adamc@260
|
652 (x, ListMergeSort.sort
|
adamc@260
|
653 (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER)
|
adamc@260
|
654 xts)) tables
|
adamc@260
|
655 in
|
adamc@260
|
656 SOME tables
|
adamc@260
|
657 end
|
adamc@252
|
658 end
|
adamc@252
|
659 in
|
adamc@252
|
660 case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of
|
adamc@252
|
661 (SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) =>
|
adamc@252
|
662 ((L'.EAbs ("r",
|
adamc@252
|
663 (L'.TRecord [("From", (L'.TRecord (map (fn (x, _) => (x, s)) tables), loc)),
|
adamc@252
|
664 ("Where", s),
|
adamc@252
|
665 ("GroupBy", un),
|
adamc@252
|
666 ("Having", s),
|
adamc@252
|
667 ("SelectFields", un),
|
adamc@252
|
668 ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
|
adamc@252
|
669 loc),
|
adamc@252
|
670 s,
|
adamc@252
|
671 strcat loc [sc "SELECT ",
|
adamc@261
|
672 strcatComma loc (map (fn (x, t) =>
|
adamc@261
|
673 strcat loc [
|
adamc@261
|
674 (L'.EField (gf "SelectExps", x), loc),
|
adamc@261
|
675 sc (" AS _" ^ x)
|
adamc@265
|
676 ]) sexps
|
adamc@265
|
677 @ map (fn (x, xts) =>
|
adamc@265
|
678 strcatComma loc
|
adamc@265
|
679 (map (fn (x', _) =>
|
adamc@277
|
680 sc (x ^ ".lw_" ^ x'))
|
adamc@265
|
681 xts)) stables),
|
adamc@252
|
682 sc " FROM ",
|
adamc@252
|
683 strcatComma loc (map (fn (x, _) => strcat loc [(L'.EField (gf "From", x), loc),
|
adamc@253
|
684 sc (" AS " ^ x)]) tables),
|
adamc@258
|
685 (L'.ECase (gf "Where",
|
adamc@258
|
686 [((L'.PPrim (Prim.String "TRUE"), loc),
|
adamc@258
|
687 sc ""),
|
adamc@258
|
688 ((L'.PWild, loc),
|
adamc@258
|
689 strcat loc [sc " WHERE ", gf "Where"])],
|
adamc@258
|
690 {disc = s,
|
adamc@258
|
691 result = s}), loc),
|
adamc@258
|
692
|
adamc@255
|
693 if List.all (fn (x, xts) =>
|
adamc@255
|
694 case List.find (fn (x', _) => x' = x) grouped of
|
adamc@255
|
695 NONE => List.null xts
|
adamc@255
|
696 | SOME (_, xts') =>
|
adamc@255
|
697 List.all (fn (x, _) =>
|
adamc@255
|
698 List.exists (fn (x', _) => x' = x)
|
adamc@255
|
699 xts') xts) tables then
|
adamc@255
|
700 sc ""
|
adamc@255
|
701 else
|
adamc@255
|
702 strcat loc [
|
adamc@255
|
703 sc " GROUP BY ",
|
adamc@255
|
704 strcatComma loc (map (fn (x, xts) =>
|
adamc@255
|
705 strcatComma loc
|
adamc@255
|
706 (map (fn (x', _) =>
|
adamc@277
|
707 sc (x ^ ".lw_" ^ x'))
|
adamc@255
|
708 xts)) grouped)
|
adamc@259
|
709 ],
|
adamc@259
|
710
|
adamc@259
|
711 (L'.ECase (gf "Having",
|
adamc@259
|
712 [((L'.PPrim (Prim.String "TRUE"), loc),
|
adamc@259
|
713 sc ""),
|
adamc@259
|
714 ((L'.PWild, loc),
|
adamc@259
|
715 strcat loc [sc " HAVING ", gf "Having"])],
|
adamc@259
|
716 {disc = s,
|
adamc@259
|
717 result = s}), loc)
|
adamc@252
|
718 ]), loc),
|
adamc@252
|
719 fm)
|
adamc@252
|
720 | _ => poly ()
|
adamc@252
|
721 end
|
adamc@252
|
722
|
adamc@252
|
723 | L.ECApp (
|
adamc@252
|
724 (L.ECApp (
|
adamc@252
|
725 (L.ECApp (
|
adamc@252
|
726 (L.ECApp (
|
adamc@252
|
727 (L.EFfi ("Basis", "sql_inject"), _),
|
adamc@252
|
728 _), _),
|
adamc@252
|
729 _), _),
|
adamc@252
|
730 _), _),
|
adamc@252
|
731 t) =>
|
adamc@252
|
732 let
|
adamc@252
|
733 val t = monoType env t
|
adamc@252
|
734 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@252
|
735 in
|
adamc@252
|
736 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
|
adamc@252
|
737 (L'.ERel 0, loc)), loc), fm)
|
adamc@252
|
738 end
|
adamc@252
|
739
|
adamc@253
|
740 | L.EFfi ("Basis", "sql_int") =>
|
adamc@253
|
741 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@253
|
742 (L'.EFfiApp ("Basis", "sqlifyInt", [(L'.ERel 0, loc)]), loc)), loc),
|
adamc@253
|
743 fm)
|
adamc@253
|
744 | L.EFfi ("Basis", "sql_float") =>
|
adamc@253
|
745 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@253
|
746 (L'.EFfiApp ("Basis", "sqlifyFloat", [(L'.ERel 0, loc)]), loc)), loc),
|
adamc@253
|
747 fm)
|
adamc@253
|
748 | L.EFfi ("Basis", "sql_bool") =>
|
adamc@253
|
749 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@253
|
750 (L'.EFfiApp ("Basis", "sqlifyBool", [(L'.ERel 0, loc)]), loc)), loc),
|
adamc@253
|
751 fm)
|
adamc@253
|
752 | L.EFfi ("Basis", "sql_string") =>
|
adamc@253
|
753 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@253
|
754 (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
|
adamc@253
|
755 fm)
|
adamc@253
|
756
|
adamc@252
|
757 | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
|
adamc@252
|
758 ((L'.ERecord [], loc), fm)
|
adamc@252
|
759 | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
|
adamc@252
|
760 ((L'.ERecord [], loc), fm)
|
adamc@252
|
761
|
adamc@252
|
762 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
|
adamc@252
|
763 ((L'.EPrim (Prim.String ""), loc), fm)
|
adamc@261
|
764 | L.ECApp (
|
adamc@261
|
765 (L.ECApp (
|
adamc@261
|
766 (L.ECApp (
|
adamc@261
|
767 (L.EFfi ("Basis", "sql_order_by_Cons"), _),
|
adamc@261
|
768 _), _),
|
adamc@261
|
769 _), _),
|
adamc@261
|
770 _) =>
|
adamc@261
|
771 let
|
adamc@261
|
772 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@261
|
773 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@261
|
774 in
|
adamc@268
|
775 ((L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@268
|
776 (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
|
adamc@268
|
777 (L'.EAbs ("e2", s, s,
|
adamc@268
|
778 (L'.ECase ((L'.ERel 0, loc),
|
adamc@268
|
779 [((L'.PPrim (Prim.String ""), loc),
|
adamc@268
|
780 strcat loc [(L'.ERel 2, loc),
|
adamc@268
|
781 (L'.ERel 1, loc)]),
|
adamc@268
|
782 ((L'.PWild, loc),
|
adamc@268
|
783 strcat loc [(L'.ERel 2, loc),
|
adamc@268
|
784 (L'.ERel 1, loc),
|
adamc@268
|
785 sc ", ",
|
adamc@268
|
786 (L'.ERel 0, loc)])],
|
adamc@268
|
787 {disc = s, result = s}), loc)), loc)), loc)), loc),
|
adamc@261
|
788 fm)
|
adamc@261
|
789 end
|
adamc@252
|
790
|
adamc@252
|
791 | L.EFfi ("Basis", "sql_no_limit") =>
|
adamc@252
|
792 ((L'.EPrim (Prim.String ""), loc), fm)
|
adamc@262
|
793 | L.EFfiApp ("Basis", "sql_limit", [e]) =>
|
adamc@262
|
794 let
|
adamc@262
|
795 val (e, fm) = monoExp (env, st, fm) e
|
adamc@262
|
796 in
|
adamc@262
|
797 (strcat loc [
|
adamc@262
|
798 (L'.EPrim (Prim.String " LIMIT "), loc),
|
adamc@262
|
799 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
|
adamc@262
|
800 ],
|
adamc@262
|
801 fm)
|
adamc@262
|
802 end
|
adamc@262
|
803
|
adamc@252
|
804 | L.EFfi ("Basis", "sql_no_offset") =>
|
adamc@252
|
805 ((L'.EPrim (Prim.String ""), loc), fm)
|
adamc@263
|
806 | L.EFfiApp ("Basis", "sql_offset", [e]) =>
|
adamc@263
|
807 let
|
adamc@263
|
808 val (e, fm) = monoExp (env, st, fm) e
|
adamc@263
|
809 in
|
adamc@263
|
810 (strcat loc [
|
adamc@263
|
811 (L'.EPrim (Prim.String " OFFSET "), loc),
|
adamc@263
|
812 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
|
adamc@263
|
813 ],
|
adamc@263
|
814 fm)
|
adamc@263
|
815 end
|
adamc@253
|
816
|
adamc@253
|
817 | L.EFfi ("Basis", "sql_eq") =>
|
adamc@253
|
818 ((L'.EPrim (Prim.String "="), loc), fm)
|
adamc@253
|
819 | L.EFfi ("Basis", "sql_ne") =>
|
adamc@253
|
820 ((L'.EPrim (Prim.String "<>"), loc), fm)
|
adamc@253
|
821 | L.EFfi ("Basis", "sql_lt") =>
|
adamc@253
|
822 ((L'.EPrim (Prim.String "<"), loc), fm)
|
adamc@253
|
823 | L.EFfi ("Basis", "sql_le") =>
|
adamc@253
|
824 ((L'.EPrim (Prim.String "<="), loc), fm)
|
adamc@253
|
825 | L.EFfi ("Basis", "sql_gt") =>
|
adamc@253
|
826 ((L'.EPrim (Prim.String ">"), loc), fm)
|
adamc@253
|
827 | L.EFfi ("Basis", "sql_ge") =>
|
adamc@253
|
828 ((L'.EPrim (Prim.String ">="), loc), fm)
|
adamc@253
|
829
|
adamc@253
|
830 | L.ECApp (
|
adamc@253
|
831 (L.ECApp (
|
adamc@253
|
832 (L.ECApp (
|
adamc@253
|
833 (L.ECApp (
|
adamc@254
|
834 (L.ECApp (
|
adamc@264
|
835 (L.EFfi ("Basis", "sql_unary"), _),
|
adamc@264
|
836 _), _),
|
adamc@264
|
837 _), _),
|
adamc@264
|
838 _), _),
|
adamc@264
|
839 _), _),
|
adamc@264
|
840 _) =>
|
adamc@264
|
841 let
|
adamc@264
|
842 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@264
|
843 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@264
|
844 in
|
adamc@264
|
845 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@264
|
846 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
adamc@264
|
847 strcat loc [sc "(",
|
adamc@264
|
848 (L'.ERel 1, loc),
|
adamc@264
|
849 sc " ",
|
adamc@264
|
850 (L'.ERel 0, loc),
|
adamc@264
|
851 sc ")"]), loc)), loc),
|
adamc@264
|
852 fm)
|
adamc@264
|
853 end
|
adamc@264
|
854 | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm)
|
adamc@264
|
855
|
adamc@264
|
856 | L.ECApp (
|
adamc@264
|
857 (L.ECApp (
|
adamc@264
|
858 (L.ECApp (
|
adamc@264
|
859 (L.ECApp (
|
adamc@264
|
860 (L.ECApp (
|
adamc@254
|
861 (L.ECApp (
|
adamc@254
|
862 (L.EFfi ("Basis", "sql_binary"), _),
|
adamc@254
|
863 _), _),
|
adamc@254
|
864 _), _),
|
adamc@254
|
865 _), _),
|
adamc@254
|
866 _), _),
|
adamc@254
|
867 _), _),
|
adamc@254
|
868 _) =>
|
adamc@254
|
869 let
|
adamc@254
|
870 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@254
|
871 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@254
|
872 in
|
adamc@254
|
873 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@254
|
874 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
adamc@254
|
875 (L'.EAbs ("e2", s, s,
|
adamc@254
|
876 strcat loc [sc "(",
|
adamc@254
|
877 (L'.ERel 1, loc),
|
adamc@254
|
878 sc " ",
|
adamc@254
|
879 (L'.ERel 2, loc),
|
adamc@254
|
880 sc " ",
|
adamc@254
|
881 (L'.ERel 0, loc),
|
adamc@254
|
882 sc ")"]), loc)), loc)), loc),
|
adamc@254
|
883 fm)
|
adamc@254
|
884 end
|
adamc@254
|
885 | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm)
|
adamc@254
|
886 | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm)
|
adamc@254
|
887
|
adamc@254
|
888 | L.ECApp (
|
adamc@254
|
889 (L.ECApp (
|
adamc@254
|
890 (L.ECApp (
|
adamc@254
|
891 (L.ECApp (
|
adamc@253
|
892 (L.EFfi ("Basis", "sql_comparison"), _),
|
adamc@253
|
893 _), _),
|
adamc@253
|
894 _), _),
|
adamc@253
|
895 _), _),
|
adamc@253
|
896 _) =>
|
adamc@253
|
897 let
|
adamc@253
|
898 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@253
|
899 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@253
|
900 in
|
adamc@253
|
901 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@253
|
902 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
adamc@253
|
903 (L'.EAbs ("e2", s, s,
|
adamc@254
|
904 strcat loc [sc "(",
|
adamc@254
|
905 (L'.ERel 1, loc),
|
adamc@253
|
906 sc " ",
|
adamc@253
|
907 (L'.ERel 2, loc),
|
adamc@253
|
908 sc " ",
|
adamc@254
|
909 (L'.ERel 0, loc),
|
adamc@254
|
910 sc ")"]), loc)), loc)), loc),
|
adamc@253
|
911 fm)
|
adamc@253
|
912 end
|
adamc@253
|
913
|
adamc@253
|
914 | L.ECApp (
|
adamc@253
|
915 (L.ECApp (
|
adamc@253
|
916 (L.ECApp (
|
adamc@253
|
917 (L.ECApp (
|
adamc@253
|
918 (L.ECApp (
|
adamc@253
|
919 (L.ECApp (
|
adamc@253
|
920 (L.ECApp (
|
adamc@253
|
921 (L.EFfi ("Basis", "sql_field"), _),
|
adamc@253
|
922 _), _),
|
adamc@253
|
923 _), _),
|
adamc@253
|
924 _), _),
|
adamc@253
|
925 _), _),
|
adamc@253
|
926 _), _),
|
adamc@253
|
927 (L.CName tab, _)), _),
|
adamc@277
|
928 (L.CName field, _)) => ((L'.EPrim (Prim.String (tab ^ ".lw_" ^ field)), loc), fm)
|
adamc@260
|
929
|
adamc@260
|
930 | L.ECApp (
|
adamc@260
|
931 (L.ECApp (
|
adamc@260
|
932 (L.ECApp (
|
adamc@260
|
933 (L.ECApp (
|
adamc@261
|
934 (L.ECApp (
|
adamc@261
|
935 (L.EFfi ("Basis", "sql_exp"), _),
|
adamc@261
|
936 _), _),
|
adamc@261
|
937 _), _),
|
adamc@261
|
938 _), _),
|
adamc@261
|
939 _), _),
|
adamc@261
|
940 (L.CName nm, _)) => ((L'.EPrim (Prim.String ("_" ^ nm)), loc), fm)
|
adamc@261
|
941
|
adamc@261
|
942 | L.ECApp (
|
adamc@261
|
943 (L.ECApp (
|
adamc@261
|
944 (L.ECApp (
|
adamc@261
|
945 (L.ECApp (
|
adamc@260
|
946 (L.EFfi ("Basis", "sql_relop"), _),
|
adamc@260
|
947 _), _),
|
adamc@260
|
948 _), _),
|
adamc@260
|
949 _), _),
|
adamc@260
|
950 _) =>
|
adamc@260
|
951 let
|
adamc@260
|
952 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@260
|
953 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@260
|
954 in
|
adamc@260
|
955 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@260
|
956 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
adamc@260
|
957 (L'.EAbs ("e2", s, s,
|
adamc@260
|
958 strcat loc [sc "((",
|
adamc@260
|
959 (L'.ERel 1, loc),
|
adamc@260
|
960 sc ") ",
|
adamc@260
|
961 (L'.ERel 2, loc),
|
adamc@260
|
962 sc " (",
|
adamc@260
|
963 (L'.ERel 0, loc),
|
adamc@260
|
964 sc "))"]), loc)), loc)), loc),
|
adamc@260
|
965 fm)
|
adamc@260
|
966 end
|
adamc@260
|
967
|
adamc@260
|
968 | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
|
adamc@260
|
969 | L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)
|
adamc@260
|
970 | L.EFfi ("Basis", "sql_except") => ((L'.EPrim (Prim.String "EXCEPT"), loc), fm)
|
adamc@260
|
971
|
adamc@265
|
972 | L.ECApp (
|
adamc@265
|
973 (L.ECApp (
|
adamc@265
|
974 (L.ECApp (
|
adamc@265
|
975 (L.EFfi ("Basis", "sql_count"), _),
|
adamc@265
|
976 _), _),
|
adamc@265
|
977 _), _),
|
adamc@265
|
978 _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@265
|
979 (L'.EPrim (Prim.String "COUNT(*)"), loc)), loc),
|
adamc@265
|
980 fm)
|
adamc@266
|
981
|
adamc@266
|
982 | L.ECApp (
|
adamc@266
|
983 (L.ECApp (
|
adamc@266
|
984 (L.ECApp (
|
adamc@266
|
985 (L.ECApp (
|
adamc@266
|
986 (L.EFfi ("Basis", "sql_aggregate"), _),
|
adamc@266
|
987 _), _),
|
adamc@266
|
988 _), _),
|
adamc@266
|
989 _), _),
|
adamc@266
|
990 _) =>
|
adamc@266
|
991 let
|
adamc@266
|
992 val s = (L'.TFfi ("Basis", "string"), loc)
|
adamc@266
|
993 fun sc s = (L'.EPrim (Prim.String s), loc)
|
adamc@266
|
994 in
|
adamc@266
|
995 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
adamc@266
|
996 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
adamc@266
|
997 strcat loc [(L'.ERel 1, loc),
|
adamc@266
|
998 sc "(",
|
adamc@266
|
999 (L'.ERel 0, loc),
|
adamc@266
|
1000 sc ")"]), loc)), loc),
|
adamc@266
|
1001 fm)
|
adamc@266
|
1002 end
|
adamc@266
|
1003
|
adamc@266
|
1004 | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm)
|
adamc@266
|
1005 | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm)
|
adamc@266
|
1006 | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) =>
|
adamc@266
|
1007 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@266
|
1008 (L'.EPrim (Prim.String "AVG"), loc)), loc),
|
adamc@266
|
1009 fm)
|
adamc@266
|
1010 | L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _) =>
|
adamc@266
|
1011 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@266
|
1012 (L'.EPrim (Prim.String "SUM"), loc)), loc),
|
adamc@266
|
1013 fm)
|
adamc@266
|
1014
|
adamc@266
|
1015 | L.EFfi ("Basis", "sql_maxable_int") => ((L'.ERecord [], loc), fm)
|
adamc@266
|
1016 | L.EFfi ("Basis", "sql_maxable_float") => ((L'.ERecord [], loc), fm)
|
adamc@266
|
1017 | L.EFfi ("Basis", "sql_maxable_string") => ((L'.ERecord [], loc), fm)
|
adamc@266
|
1018 | L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _) =>
|
adamc@266
|
1019 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@266
|
1020 (L'.EPrim (Prim.String "MAX"), loc)), loc),
|
adamc@266
|
1021 fm)
|
adamc@266
|
1022 | L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _) =>
|
adamc@266
|
1023 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
|
adamc@266
|
1024 (L'.EPrim (Prim.String "MIN"), loc)), loc),
|
adamc@266
|
1025 fm)
|
adamc@266
|
1026
|
adamc@268
|
1027 | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
|
adamc@268
|
1028 | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
|
adamc@268
|
1029
|
adamc@139
|
1030 | L.EApp (
|
adamc@139
|
1031 (L.ECApp (
|
adamc@141
|
1032 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
|
adamc@139
|
1033 _), _),
|
adamc@179
|
1034 se) =>
|
adamc@179
|
1035 let
|
adamc@179
|
1036 val (se, fm) = monoExp (env, st, fm) se
|
adamc@179
|
1037 in
|
adamc@179
|
1038 ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm)
|
adamc@179
|
1039 end
|
adamc@179
|
1040
|
adamc@95
|
1041 | L.EApp (
|
adamc@95
|
1042 (L.EApp (
|
adamc@95
|
1043 (L.ECApp (
|
adamc@95
|
1044 (L.ECApp (
|
adamc@95
|
1045 (L.ECApp (
|
adamc@139
|
1046 (L.ECApp (
|
adamc@140
|
1047 (L.EFfi ("Basis", "join"),
|
adamc@139
|
1048 _), _), _),
|
adamc@139
|
1049 _), _),
|
adamc@95
|
1050 _), _),
|
adamc@95
|
1051 _), _),
|
adamc@95
|
1052 xml1), _),
|
adamc@179
|
1053 xml2) =>
|
adamc@179
|
1054 let
|
adamc@179
|
1055 val (xml1, fm) = monoExp (env, st, fm) xml1
|
adamc@179
|
1056 val (xml2, fm) = monoExp (env, st, fm) xml2
|
adamc@179
|
1057 in
|
adamc@179
|
1058 ((L'.EStrcat (xml1, xml2), loc), fm)
|
adamc@179
|
1059 end
|
adamc@95
|
1060
|
adamc@95
|
1061 | L.EApp (
|
adamc@95
|
1062 (L.EApp (
|
adamc@104
|
1063 (L.EApp (
|
adamc@95
|
1064 (L.ECApp (
|
adamc@104
|
1065 (L.ECApp (
|
adamc@104
|
1066 (L.ECApp (
|
adamc@104
|
1067 (L.ECApp (
|
adamc@139
|
1068 (L.ECApp (
|
adamc@139
|
1069 (L.ECApp (
|
adamc@139
|
1070 (L.ECApp (
|
adamc@139
|
1071 (L.ECApp (
|
adamc@139
|
1072 (L.EFfi ("Basis", "tag"),
|
adamc@139
|
1073 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
|
adamc@104
|
1074 attrs), _),
|
adamc@95
|
1075 tag), _),
|
adamc@95
|
1076 xml) =>
|
adamc@95
|
1077 let
|
adamc@140
|
1078 fun getTag' (e, _) =
|
adamc@140
|
1079 case e of
|
adamc@143
|
1080 L.EFfi ("Basis", tag) => (tag, [])
|
adamc@143
|
1081 | L.ECApp (e, t) => let
|
adamc@143
|
1082 val (tag, ts) = getTag' e
|
adamc@143
|
1083 in
|
adamc@143
|
1084 (tag, ts @ [t])
|
adamc@143
|
1085 end
|
adamc@140
|
1086 | _ => (E.errorAt loc "Non-constant XML tag";
|
adamc@140
|
1087 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
|
adamc@143
|
1088 ("", []))
|
adamc@140
|
1089
|
adamc@95
|
1090 fun getTag (e, _) =
|
adamc@95
|
1091 case e of
|
adamc@143
|
1092 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
|
adamc@140
|
1093 | L.EApp (e, (L.ERecord [], _)) => getTag' e
|
adamc@95
|
1094 | _ => (E.errorAt loc "Non-constant XML tag";
|
adamc@95
|
1095 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
|
adamc@143
|
1096 ("", []))
|
adamc@95
|
1097
|
adamc@143
|
1098 val (tag, targs) = getTag tag
|
adamc@95
|
1099
|
adamc@179
|
1100 val (attrs, fm) = monoExp (env, st, fm) attrs
|
adamc@104
|
1101
|
adamc@143
|
1102 fun tagStart tag =
|
adamc@104
|
1103 case #1 attrs of
|
adamc@104
|
1104 L'.ERecord xes =>
|
adamc@104
|
1105 let
|
adamc@104
|
1106 fun lowercaseFirst "" = ""
|
adamc@143
|
1107 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0)))
|
adamc@143
|
1108 ^ String.extract (s, 1, NONE)
|
adamc@104
|
1109
|
adamc@104
|
1110 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
|
adamc@104
|
1111 in
|
adamc@179
|
1112 foldl (fn ((x, e, t), (s, fm)) =>
|
adamc@104
|
1113 let
|
adamc@104
|
1114 val xp = " " ^ lowercaseFirst x ^ "=\""
|
adamc@120
|
1115
|
adamc@120
|
1116 val fooify =
|
adamc@120
|
1117 case x of
|
adamc@185
|
1118 "Href" => urlifyExp
|
adamc@185
|
1119 | "Link" => urlifyExp
|
adamc@143
|
1120 | "Action" => urlifyExp
|
adamc@120
|
1121 | _ => attrifyExp
|
adamc@179
|
1122
|
adamc@179
|
1123 val (e, fm) = fooify env fm (e, t)
|
adamc@104
|
1124 in
|
adamc@179
|
1125 ((L'.EStrcat (s,
|
adamc@179
|
1126 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
|
adamc@179
|
1127 (L'.EStrcat (e,
|
adamc@179
|
1128 (L'.EPrim (Prim.String "\""),
|
adamc@179
|
1129 loc)),
|
adamc@179
|
1130 loc)),
|
adamc@179
|
1131 loc)), loc),
|
adamc@179
|
1132 fm)
|
adamc@104
|
1133 end)
|
adamc@179
|
1134 (s, fm) xes
|
adamc@104
|
1135 end
|
adamc@143
|
1136 | _ => raise Fail "Non-record attributes!"
|
adamc@104
|
1137
|
adamc@143
|
1138 fun input typ =
|
adamc@143
|
1139 case targs of
|
adamc@155
|
1140 [_, (L.CName name, _)] =>
|
adamc@179
|
1141 let
|
adamc@179
|
1142 val (ts, fm) = tagStart "input"
|
adamc@179
|
1143 in
|
adamc@179
|
1144 ((L'.EStrcat (ts,
|
adamc@179
|
1145 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
|
adamc@179
|
1146 loc)), loc), fm)
|
adamc@179
|
1147 end
|
adamc@143
|
1148 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adamc@153
|
1149 raise Fail "No name passed to input tag")
|
adamc@104
|
1150
|
adamc@152
|
1151 fun normal (tag, extra) =
|
adamc@143
|
1152 let
|
adamc@179
|
1153 val (tagStart, fm) = tagStart tag
|
adamc@152
|
1154 val tagStart = case extra of
|
adamc@152
|
1155 NONE => tagStart
|
adamc@152
|
1156 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
|
adamc@152
|
1157
|
adamc@143
|
1158 fun normal () =
|
adamc@179
|
1159 let
|
adamc@179
|
1160 val (xml, fm) = monoExp (env, st, fm) xml
|
adamc@179
|
1161 in
|
adamc@179
|
1162 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
|
adamc@179
|
1163 (L'.EStrcat (xml,
|
adamc@179
|
1164 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
|
adamc@179
|
1165 loc)), loc)),
|
adamc@179
|
1166 loc),
|
adamc@179
|
1167 fm)
|
adamc@179
|
1168 end
|
adamc@143
|
1169 in
|
adamc@143
|
1170 case xml of
|
adamc@143
|
1171 (L.EApp ((L.ECApp (
|
adamc@143
|
1172 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
|
adamc@143
|
1173 _), _),
|
adamc@143
|
1174 _), _),
|
adamc@143
|
1175 (L.EPrim (Prim.String s), _)), _) =>
|
adamc@143
|
1176 if CharVector.all Char.isSpace s then
|
adamc@179
|
1177 ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc), fm)
|
adamc@143
|
1178 else
|
adamc@143
|
1179 normal ()
|
adamc@143
|
1180 | _ => normal ()
|
adamc@143
|
1181 end
|
adamc@152
|
1182 in
|
adamc@152
|
1183 case tag of
|
adamc@179
|
1184 "submit" => ((L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc), fm)
|
adamc@152
|
1185
|
adamc@152
|
1186 | "textbox" =>
|
adamc@152
|
1187 (case targs of
|
adamc@152
|
1188 [_, (L.CName name, _)] =>
|
adamc@179
|
1189 let
|
adamc@179
|
1190 val (ts, fm) = tagStart "input"
|
adamc@179
|
1191 in
|
adamc@179
|
1192 ((L'.EStrcat (ts,
|
adamc@179
|
1193 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
|
adamc@179
|
1194 loc)), loc), fm)
|
adamc@179
|
1195 end
|
adamc@152
|
1196 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adamc@153
|
1197 raise Fail "No name passed to textarea tag"))
|
adamc@155
|
1198 | "password" => input "password"
|
adamc@152
|
1199 | "ltextarea" =>
|
adamc@152
|
1200 (case targs of
|
adamc@152
|
1201 [_, (L.CName name, _)] =>
|
adamc@179
|
1202 let
|
adamc@179
|
1203 val (ts, fm) = tagStart "textarea"
|
adamc@179
|
1204 val (xml, fm) = monoExp (env, st, fm) xml
|
adamc@179
|
1205 in
|
adamc@179
|
1206 ((L'.EStrcat ((L'.EStrcat (ts,
|
adamc@179
|
1207 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
|
adamc@179
|
1208 (L'.EStrcat (xml,
|
adamc@179
|
1209 (L'.EPrim (Prim.String "</textarea>"),
|
adamc@179
|
1210 loc)), loc)),
|
adamc@179
|
1211 loc), fm)
|
adamc@179
|
1212 end
|
adamc@152
|
1213 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adamc@153
|
1214 raise Fail "No name passed to ltextarea tag"))
|
adamc@153
|
1215
|
adamc@190
|
1216 | "checkbox" => input "checkbox"
|
adamc@190
|
1217
|
adamc@153
|
1218 | "radio" =>
|
adamc@153
|
1219 (case targs of
|
adamc@153
|
1220 [_, (L.CName name, _)] =>
|
adamc@179
|
1221 monoExp (env, St.setRadioGroup (st, name), fm) xml
|
adamc@153
|
1222 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adamc@153
|
1223 raise Fail "No name passed to radio tag"))
|
adamc@153
|
1224 | "radioOption" =>
|
adamc@153
|
1225 (case St.radioGroup st of
|
adamc@153
|
1226 NONE => raise Fail "No name for radioGroup"
|
adamc@153
|
1227 | SOME name =>
|
adamc@153
|
1228 normal ("input",
|
adamc@153
|
1229 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
|
adamc@152
|
1230
|
adamc@154
|
1231 | "lselect" =>
|
adamc@154
|
1232 (case targs of
|
adamc@154
|
1233 [_, (L.CName name, _)] =>
|
adamc@179
|
1234 let
|
adamc@179
|
1235 val (ts, fm) = tagStart "select"
|
adamc@179
|
1236 val (xml, fm) = monoExp (env, st, fm) xml
|
adamc@179
|
1237 in
|
adamc@179
|
1238 ((L'.EStrcat ((L'.EStrcat (ts,
|
adamc@179
|
1239 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
|
adamc@179
|
1240 (L'.EStrcat (xml,
|
adamc@179
|
1241 (L'.EPrim (Prim.String "</select>"),
|
adamc@179
|
1242 loc)), loc)),
|
adamc@179
|
1243 loc),
|
adamc@179
|
1244 fm)
|
adamc@179
|
1245 end
|
adamc@154
|
1246 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
adamc@154
|
1247 raise Fail "No name passed to lselect tag"))
|
adamc@154
|
1248
|
adamc@154
|
1249 | "loption" => normal ("option", NONE)
|
adamc@154
|
1250
|
adamc@152
|
1251 | _ => normal (tag, NONE)
|
adamc@95
|
1252 end
|
adamc@94
|
1253
|
adamc@141
|
1254 | L.EApp ((L.ECApp (
|
adamc@141
|
1255 (L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _),
|
adamc@141
|
1256 _), _),
|
adamc@141
|
1257 xml) =>
|
adamc@143
|
1258 let
|
adamc@143
|
1259 fun findSubmit (e, _) =
|
adamc@143
|
1260 case e of
|
adamc@143
|
1261 L.EApp (
|
adamc@143
|
1262 (L.EApp (
|
adamc@143
|
1263 (L.ECApp (
|
adamc@143
|
1264 (L.ECApp (
|
adamc@143
|
1265 (L.ECApp (
|
adamc@143
|
1266 (L.ECApp (
|
adamc@143
|
1267 (L.EFfi ("Basis", "join"),
|
adamc@143
|
1268 _), _), _),
|
adamc@143
|
1269 _), _),
|
adamc@143
|
1270 _), _),
|
adamc@143
|
1271 _), _),
|
adamc@143
|
1272 xml1), _),
|
adamc@143
|
1273 xml2) => (case findSubmit xml1 of
|
adamc@143
|
1274 Error => Error
|
adamc@143
|
1275 | NotFound => findSubmit xml2
|
adamc@143
|
1276 | Found e =>
|
adamc@143
|
1277 case findSubmit xml2 of
|
adamc@143
|
1278 NotFound => Found e
|
adamc@143
|
1279 | _ => Error)
|
adamc@143
|
1280 | L.EApp (
|
adamc@143
|
1281 (L.EApp (
|
adamc@143
|
1282 (L.EApp (
|
adamc@143
|
1283 (L.ECApp (
|
adamc@143
|
1284 (L.ECApp (
|
adamc@143
|
1285 (L.ECApp (
|
adamc@143
|
1286 (L.ECApp (
|
adamc@143
|
1287 (L.ECApp (
|
adamc@143
|
1288 (L.ECApp (
|
adamc@143
|
1289 (L.ECApp (
|
adamc@143
|
1290 (L.ECApp (
|
adamc@143
|
1291 (L.EFfi ("Basis", "tag"),
|
adamc@143
|
1292 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
|
adamc@143
|
1293 attrs), _),
|
adamc@143
|
1294 _), _),
|
adamc@143
|
1295 xml) =>
|
adamc@143
|
1296 (case #1 attrs of
|
adamc@143
|
1297 L.ERecord xes =>
|
adamc@143
|
1298 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
|
adamc@143
|
1299 | _ => NONE) xes of
|
adamc@143
|
1300 NONE => findSubmit xml
|
adamc@143
|
1301 | SOME et =>
|
adamc@143
|
1302 case findSubmit xml of
|
adamc@143
|
1303 NotFound => Found et
|
adamc@143
|
1304 | _ => Error)
|
adamc@143
|
1305 | _ => findSubmit xml)
|
adamc@143
|
1306 | _ => NotFound
|
adamc@143
|
1307
|
adamc@143
|
1308 val (action, actionT) = case findSubmit xml of
|
adamc@143
|
1309 NotFound => raise Fail "No submit found"
|
adamc@143
|
1310 | Error => raise Fail "Not ready for multi-submit lforms yet"
|
adamc@143
|
1311 | Found et => et
|
adamc@143
|
1312
|
adamc@143
|
1313 val actionT = monoType env actionT
|
adamc@179
|
1314 val (action, fm) = monoExp (env, st, fm) action
|
adamc@179
|
1315 val (action, fm) = urlifyExp env fm (action, actionT)
|
adamc@179
|
1316 val (xml, fm) = monoExp (env, st, fm) xml
|
adamc@143
|
1317 in
|
adamc@179
|
1318 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
|
adamc@179
|
1319 (L'.EStrcat (action,
|
adamc@179
|
1320 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
|
adamc@179
|
1321 (L'.EStrcat (xml,
|
adamc@179
|
1322 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
|
adamc@179
|
1323 fm)
|
adamc@143
|
1324 end
|
adamc@141
|
1325
|
adamc@148
|
1326 | L.EApp ((L.ECApp (
|
adamc@148
|
1327 (L.ECApp (
|
adamc@148
|
1328 (L.ECApp (
|
adamc@148
|
1329 (L.ECApp (
|
adamc@148
|
1330 (L.EFfi ("Basis", "useMore"), _), _), _),
|
adamc@148
|
1331 _), _),
|
adamc@148
|
1332 _), _),
|
adamc@148
|
1333 _), _),
|
adamc@179
|
1334 xml) => monoExp (env, st, fm) xml
|
adamc@148
|
1335
|
adamc@283
|
1336 | L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
|
adamc@283
|
1337 let
|
adamc@283
|
1338 val t = monoType env t
|
adamc@283
|
1339 in
|
adamc@283
|
1340 ((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
|
adamc@283
|
1341 (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
|
adamc@283
|
1342 fm)
|
adamc@283
|
1343 end
|
adamc@283
|
1344
|
adamc@179
|
1345 | L.EApp (e1, e2) =>
|
adamc@179
|
1346 let
|
adamc@179
|
1347 val (e1, fm) = monoExp (env, st, fm) e1
|
adamc@179
|
1348 val (e2, fm) = monoExp (env, st, fm) e2
|
adamc@179
|
1349 in
|
adamc@179
|
1350 ((L'.EApp (e1, e2), loc), fm)
|
adamc@179
|
1351 end
|
adamc@26
|
1352 | L.EAbs (x, dom, ran, e) =>
|
adamc@179
|
1353 let
|
adamc@179
|
1354 val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
|
adamc@179
|
1355 in
|
adamc@179
|
1356 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
|
adamc@179
|
1357 end
|
adamc@25
|
1358 | L.ECApp _ => poly ()
|
adamc@25
|
1359 | L.ECAbs _ => poly ()
|
adamc@25
|
1360
|
adamc@252
|
1361 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
|
adamc@252
|
1362 | L.EFfiApp (m, x, es) =>
|
adamc@252
|
1363 let
|
adamc@252
|
1364 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
|
adamc@252
|
1365 in
|
adamc@252
|
1366 ((L'.EFfiApp (m, x, es), loc), fm)
|
adamc@252
|
1367 end
|
adamc@252
|
1368
|
adamc@179
|
1369 | L.ERecord xes =>
|
adamc@179
|
1370 let
|
adamc@179
|
1371 val (xes, fm) = ListUtil.foldlMap
|
adamc@179
|
1372 (fn ((x, e, t), fm) =>
|
adamc@179
|
1373 let
|
adamc@179
|
1374 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
1375 in
|
adamc@179
|
1376 ((monoName env x,
|
adamc@179
|
1377 e,
|
adamc@179
|
1378 monoType env t), fm)
|
adamc@179
|
1379 end) fm xes
|
adamc@179
|
1380 in
|
adamc@179
|
1381 ((L'.ERecord xes, loc), fm)
|
adamc@179
|
1382 end
|
adamc@179
|
1383 | L.EField (e, x, _) =>
|
adamc@179
|
1384 let
|
adamc@179
|
1385 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
1386 in
|
adamc@179
|
1387 ((L'.EField (e, monoName env x), loc), fm)
|
adamc@179
|
1388 end
|
adamc@149
|
1389 | L.ECut _ => poly ()
|
adamc@73
|
1390 | L.EFold _ => poly ()
|
adamc@177
|
1391
|
adamc@182
|
1392 | L.ECase (e, pes, {disc, result}) =>
|
adamc@179
|
1393 let
|
adamc@179
|
1394 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
1395 val (pes, fm) = ListUtil.foldlMap
|
adamc@179
|
1396 (fn ((p, e), fm) =>
|
adamc@179
|
1397 let
|
adamc@179
|
1398 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
1399 in
|
adamc@182
|
1400 ((monoPat env p, e), fm)
|
adamc@179
|
1401 end) fm pes
|
adamc@179
|
1402 in
|
adamc@182
|
1403 ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
|
adamc@179
|
1404 end
|
adamc@177
|
1405
|
adamc@179
|
1406 | L.EWrite e =>
|
adamc@179
|
1407 let
|
adamc@179
|
1408 val (e, fm) = monoExp (env, st, fm) e
|
adamc@179
|
1409 in
|
adamc@252
|
1410 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
adamc@252
|
1411 (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
|
adamc@179
|
1412 end
|
adamc@110
|
1413
|
adamc@179
|
1414 | L.EClosure (n, es) =>
|
adamc@179
|
1415 let
|
adamc@179
|
1416 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
|
adamc@179
|
1417 monoExp (env, st, fm) e)
|
adamc@179
|
1418 fm es
|
adamc@179
|
1419 in
|
adamc@179
|
1420 ((L'.EClosure (n, es), loc), fm)
|
adamc@179
|
1421 end
|
adamc@25
|
1422 end
|
adamc@25
|
1423
|
adamc@179
|
1424 fun monoDecl (env, fm) (all as (d, loc)) =
|
adamc@25
|
1425 let
|
adamc@25
|
1426 fun poly () =
|
adamc@25
|
1427 (E.errorAt loc "Unsupported declaration";
|
adamc@25
|
1428 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
|
adamc@25
|
1429 NONE)
|
adamc@25
|
1430 in
|
adamc@25
|
1431 case d of
|
adamc@25
|
1432 L.DCon _ => NONE
|
adamc@193
|
1433 | L.DDatatype (x, n, [], xncs) =>
|
adamc@193
|
1434 let
|
adamc@196
|
1435 val env' = Env.declBinds env all
|
adamc@196
|
1436 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc)
|
adamc@164
|
1437 in
|
adamc@273
|
1438 SOME (env', fm, [d])
|
adamc@193
|
1439 end
|
adamc@193
|
1440 | L.DDatatype _ => poly ()
|
adamc@179
|
1441 | L.DVal (x, n, t, e, s) =>
|
adamc@179
|
1442 let
|
adamc@179
|
1443 val (e, fm) = monoExp (env, St.empty, fm) e
|
adamc@179
|
1444 in
|
adamc@179
|
1445 SOME (Env.pushENamed env x n t NONE s,
|
adamc@179
|
1446 fm,
|
adamc@273
|
1447 [(L'.DVal (x, n, monoType env t, e, s), loc)])
|
adamc@179
|
1448 end
|
adamc@128
|
1449 | L.DValRec vis =>
|
adamc@128
|
1450 let
|
adamc@128
|
1451 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
|
adamc@179
|
1452
|
adamc@179
|
1453 val (vis, fm) = ListUtil.foldlMap
|
adamc@179
|
1454 (fn ((x, n, t, e, s), fm) =>
|
adamc@179
|
1455 let
|
adamc@179
|
1456 val (e, fm) = monoExp (env, St.empty, fm) e
|
adamc@179
|
1457 in
|
adamc@179
|
1458 ((x, n, monoType env t, e, s), fm)
|
adamc@179
|
1459 end)
|
adamc@179
|
1460 fm vis
|
adamc@128
|
1461 in
|
adamc@128
|
1462 SOME (env,
|
adamc@179
|
1463 fm,
|
adamc@273
|
1464 [(L'.DValRec vis, loc)])
|
adamc@128
|
1465 end
|
adamc@144
|
1466 | L.DExport (ek, n) =>
|
adamc@115
|
1467 let
|
adamc@120
|
1468 val (_, t, _, s) = Env.lookupENamed env n
|
adamc@120
|
1469
|
adamc@120
|
1470 fun unwind (t, _) =
|
adamc@120
|
1471 case t of
|
adamc@120
|
1472 L.TFun (dom, ran) => dom :: unwind ran
|
adamc@120
|
1473 | _ => []
|
adamc@120
|
1474
|
adamc@120
|
1475 val ts = map (monoType env) (unwind t)
|
adamc@115
|
1476 in
|
adamc@273
|
1477 SOME (env, fm, [(L'.DExport (ek, s, n, ts), loc)])
|
adamc@115
|
1478 end
|
adamc@273
|
1479 | L.DTable (x, n, (L.CRecord (_, xts), _), s) =>
|
adamc@251
|
1480 let
|
adamc@251
|
1481 val t = (L.CFfi ("Basis", "string"), loc)
|
adamc@251
|
1482 val t' = (L'.TFfi ("Basis", "string"), loc)
|
adamc@274
|
1483 val s = "lw_" ^ s
|
adamc@251
|
1484 val e = (L'.EPrim (Prim.String s), loc)
|
adamc@273
|
1485
|
adamc@273
|
1486 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
|
adamc@251
|
1487 in
|
adamc@251
|
1488 SOME (Env.pushENamed env x n t NONE s,
|
adamc@251
|
1489 fm,
|
adamc@273
|
1490 [(L'.DTable (s, xts), loc),
|
adamc@273
|
1491 (L'.DVal (x, n, t', e, s), loc)])
|
adamc@251
|
1492 end
|
adamc@273
|
1493 | L.DTable _ => poly ()
|
adamc@273
|
1494 | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)])
|
adamc@25
|
1495 end
|
adamc@25
|
1496
|
adamc@25
|
1497 fun monoize env ds =
|
adamc@25
|
1498 let
|
adamc@179
|
1499 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
|
adamc@179
|
1500 case monoDecl (env, fm) d of
|
adamc@179
|
1501 NONE => (env, fm, ds)
|
adamc@273
|
1502 | SOME (env, fm, ds') =>
|
adamc@179
|
1503 (env,
|
adamc@179
|
1504 Fm.enter fm,
|
adamc@273
|
1505 ds' @ Fm.decls fm @ ds))
|
adamc@179
|
1506 (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds
|
adamc@25
|
1507 in
|
adamc@25
|
1508 rev ds
|
adamc@25
|
1509 end
|
adamc@25
|
1510
|
adamc@25
|
1511 end
|