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