|
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@255
|
640 ]
|
|
adamc@252
|
641 ]), loc),
|
|
adamc@252
|
642 fm)
|
|
adamc@252
|
643 | _ => poly ()
|
|
adamc@252
|
644 end
|
|
adamc@252
|
645
|
|
adamc@252
|
646 | L.ECApp (
|
|
adamc@252
|
647 (L.ECApp (
|
|
adamc@252
|
648 (L.ECApp (
|
|
adamc@252
|
649 (L.ECApp (
|
|
adamc@252
|
650 (L.EFfi ("Basis", "sql_inject"), _),
|
|
adamc@252
|
651 _), _),
|
|
adamc@252
|
652 _), _),
|
|
adamc@252
|
653 _), _),
|
|
adamc@252
|
654 t) =>
|
|
adamc@252
|
655 let
|
|
adamc@252
|
656 val t = monoType env t
|
|
adamc@252
|
657 val s = (L'.TFfi ("Basis", "string"), loc)
|
|
adamc@252
|
658 in
|
|
adamc@252
|
659 ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
|
|
adamc@252
|
660 (L'.ERel 0, loc)), loc), fm)
|
|
adamc@252
|
661 end
|
|
adamc@252
|
662
|
|
adamc@253
|
663 | L.EFfi ("Basis", "sql_int") =>
|
|
adamc@253
|
664 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc),
|
|
adamc@253
|
665 (L'.EFfiApp ("Basis", "sqlifyInt", [(L'.ERel 0, loc)]), loc)), loc),
|
|
adamc@253
|
666 fm)
|
|
adamc@253
|
667 | L.EFfi ("Basis", "sql_float") =>
|
|
adamc@253
|
668 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc),
|
|
adamc@253
|
669 (L'.EFfiApp ("Basis", "sqlifyFloat", [(L'.ERel 0, loc)]), loc)), loc),
|
|
adamc@253
|
670 fm)
|
|
adamc@253
|
671 | L.EFfi ("Basis", "sql_bool") =>
|
|
adamc@253
|
672 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc),
|
|
adamc@253
|
673 (L'.EFfiApp ("Basis", "sqlifyBool", [(L'.ERel 0, loc)]), loc)), loc),
|
|
adamc@253
|
674 fm)
|
|
adamc@253
|
675 | L.EFfi ("Basis", "sql_string") =>
|
|
adamc@253
|
676 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
|
|
adamc@253
|
677 (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
|
|
adamc@253
|
678 fm)
|
|
adamc@253
|
679
|
|
adamc@252
|
680 | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
|
|
adamc@252
|
681 ((L'.ERecord [], loc), fm)
|
|
adamc@252
|
682 | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
|
|
adamc@252
|
683 ((L'.ERecord [], loc), fm)
|
|
adamc@252
|
684
|
|
adamc@252
|
685 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
|
|
adamc@252
|
686 ((L'.EPrim (Prim.String ""), loc), fm)
|
|
adamc@252
|
687
|
|
adamc@252
|
688 | L.EFfi ("Basis", "sql_no_limit") =>
|
|
adamc@252
|
689 ((L'.EPrim (Prim.String ""), loc), fm)
|
|
adamc@252
|
690 | L.EFfi ("Basis", "sql_no_offset") =>
|
|
adamc@252
|
691 ((L'.EPrim (Prim.String ""), loc), fm)
|
|
adamc@253
|
692
|
|
adamc@253
|
693 | L.EFfi ("Basis", "sql_eq") =>
|
|
adamc@253
|
694 ((L'.EPrim (Prim.String "="), loc), fm)
|
|
adamc@253
|
695 | L.EFfi ("Basis", "sql_ne") =>
|
|
adamc@253
|
696 ((L'.EPrim (Prim.String "<>"), loc), fm)
|
|
adamc@253
|
697 | L.EFfi ("Basis", "sql_lt") =>
|
|
adamc@253
|
698 ((L'.EPrim (Prim.String "<"), loc), fm)
|
|
adamc@253
|
699 | L.EFfi ("Basis", "sql_le") =>
|
|
adamc@253
|
700 ((L'.EPrim (Prim.String "<="), loc), fm)
|
|
adamc@253
|
701 | L.EFfi ("Basis", "sql_gt") =>
|
|
adamc@253
|
702 ((L'.EPrim (Prim.String ">"), loc), fm)
|
|
adamc@253
|
703 | L.EFfi ("Basis", "sql_ge") =>
|
|
adamc@253
|
704 ((L'.EPrim (Prim.String ">="), loc), fm)
|
|
adamc@253
|
705
|
|
adamc@253
|
706 | L.ECApp (
|
|
adamc@253
|
707 (L.ECApp (
|
|
adamc@253
|
708 (L.ECApp (
|
|
adamc@253
|
709 (L.ECApp (
|
|
adamc@254
|
710 (L.ECApp (
|
|
adamc@254
|
711 (L.ECApp (
|
|
adamc@254
|
712 (L.EFfi ("Basis", "sql_binary"), _),
|
|
adamc@254
|
713 _), _),
|
|
adamc@254
|
714 _), _),
|
|
adamc@254
|
715 _), _),
|
|
adamc@254
|
716 _), _),
|
|
adamc@254
|
717 _), _),
|
|
adamc@254
|
718 _) =>
|
|
adamc@254
|
719 let
|
|
adamc@254
|
720 val s = (L'.TFfi ("Basis", "string"), loc)
|
|
adamc@254
|
721 fun sc s = (L'.EPrim (Prim.String s), loc)
|
|
adamc@254
|
722 in
|
|
adamc@254
|
723 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
|
adamc@254
|
724 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
|
adamc@254
|
725 (L'.EAbs ("e2", s, s,
|
|
adamc@254
|
726 strcat loc [sc "(",
|
|
adamc@254
|
727 (L'.ERel 1, loc),
|
|
adamc@254
|
728 sc " ",
|
|
adamc@254
|
729 (L'.ERel 2, loc),
|
|
adamc@254
|
730 sc " ",
|
|
adamc@254
|
731 (L'.ERel 0, loc),
|
|
adamc@254
|
732 sc ")"]), loc)), loc)), loc),
|
|
adamc@254
|
733 fm)
|
|
adamc@254
|
734 end
|
|
adamc@254
|
735 | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm)
|
|
adamc@254
|
736 | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm)
|
|
adamc@254
|
737
|
|
adamc@254
|
738 | L.ECApp (
|
|
adamc@254
|
739 (L.ECApp (
|
|
adamc@254
|
740 (L.ECApp (
|
|
adamc@254
|
741 (L.ECApp (
|
|
adamc@253
|
742 (L.EFfi ("Basis", "sql_comparison"), _),
|
|
adamc@253
|
743 _), _),
|
|
adamc@253
|
744 _), _),
|
|
adamc@253
|
745 _), _),
|
|
adamc@253
|
746 _) =>
|
|
adamc@253
|
747 let
|
|
adamc@253
|
748 val s = (L'.TFfi ("Basis", "string"), loc)
|
|
adamc@253
|
749 fun sc s = (L'.EPrim (Prim.String s), loc)
|
|
adamc@253
|
750 in
|
|
adamc@253
|
751 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
|
|
adamc@253
|
752 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
|
|
adamc@253
|
753 (L'.EAbs ("e2", s, s,
|
|
adamc@254
|
754 strcat loc [sc "(",
|
|
adamc@254
|
755 (L'.ERel 1, loc),
|
|
adamc@253
|
756 sc " ",
|
|
adamc@253
|
757 (L'.ERel 2, loc),
|
|
adamc@253
|
758 sc " ",
|
|
adamc@254
|
759 (L'.ERel 0, loc),
|
|
adamc@254
|
760 sc ")"]), loc)), loc)), loc),
|
|
adamc@253
|
761 fm)
|
|
adamc@253
|
762 end
|
|
adamc@253
|
763
|
|
adamc@253
|
764 | L.ECApp (
|
|
adamc@253
|
765 (L.ECApp (
|
|
adamc@253
|
766 (L.ECApp (
|
|
adamc@253
|
767 (L.ECApp (
|
|
adamc@253
|
768 (L.ECApp (
|
|
adamc@253
|
769 (L.ECApp (
|
|
adamc@253
|
770 (L.ECApp (
|
|
adamc@253
|
771 (L.EFfi ("Basis", "sql_field"), _),
|
|
adamc@253
|
772 _), _),
|
|
adamc@253
|
773 _), _),
|
|
adamc@253
|
774 _), _),
|
|
adamc@253
|
775 _), _),
|
|
adamc@253
|
776 _), _),
|
|
adamc@253
|
777 (L.CName tab, _)), _),
|
|
adamc@253
|
778 (L.CName field, _)) => ((L'.EPrim (Prim.String (tab ^ "." ^ field)), loc), fm)
|
|
adamc@252
|
779
|
|
adamc@139
|
780 | L.EApp (
|
|
adamc@139
|
781 (L.ECApp (
|
|
adamc@141
|
782 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
|
|
adamc@139
|
783 _), _),
|
|
adamc@179
|
784 se) =>
|
|
adamc@179
|
785 let
|
|
adamc@179
|
786 val (se, fm) = monoExp (env, st, fm) se
|
|
adamc@179
|
787 in
|
|
adamc@179
|
788 ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm)
|
|
adamc@179
|
789 end
|
|
adamc@179
|
790
|
|
adamc@95
|
791 | L.EApp (
|
|
adamc@95
|
792 (L.EApp (
|
|
adamc@95
|
793 (L.ECApp (
|
|
adamc@95
|
794 (L.ECApp (
|
|
adamc@95
|
795 (L.ECApp (
|
|
adamc@139
|
796 (L.ECApp (
|
|
adamc@140
|
797 (L.EFfi ("Basis", "join"),
|
|
adamc@139
|
798 _), _), _),
|
|
adamc@139
|
799 _), _),
|
|
adamc@95
|
800 _), _),
|
|
adamc@95
|
801 _), _),
|
|
adamc@95
|
802 xml1), _),
|
|
adamc@179
|
803 xml2) =>
|
|
adamc@179
|
804 let
|
|
adamc@179
|
805 val (xml1, fm) = monoExp (env, st, fm) xml1
|
|
adamc@179
|
806 val (xml2, fm) = monoExp (env, st, fm) xml2
|
|
adamc@179
|
807 in
|
|
adamc@179
|
808 ((L'.EStrcat (xml1, xml2), loc), fm)
|
|
adamc@179
|
809 end
|
|
adamc@95
|
810
|
|
adamc@95
|
811 | L.EApp (
|
|
adamc@95
|
812 (L.EApp (
|
|
adamc@104
|
813 (L.EApp (
|
|
adamc@95
|
814 (L.ECApp (
|
|
adamc@104
|
815 (L.ECApp (
|
|
adamc@104
|
816 (L.ECApp (
|
|
adamc@104
|
817 (L.ECApp (
|
|
adamc@139
|
818 (L.ECApp (
|
|
adamc@139
|
819 (L.ECApp (
|
|
adamc@139
|
820 (L.ECApp (
|
|
adamc@139
|
821 (L.ECApp (
|
|
adamc@139
|
822 (L.EFfi ("Basis", "tag"),
|
|
adamc@139
|
823 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
|
|
adamc@104
|
824 attrs), _),
|
|
adamc@95
|
825 tag), _),
|
|
adamc@95
|
826 xml) =>
|
|
adamc@95
|
827 let
|
|
adamc@140
|
828 fun getTag' (e, _) =
|
|
adamc@140
|
829 case e of
|
|
adamc@143
|
830 L.EFfi ("Basis", tag) => (tag, [])
|
|
adamc@143
|
831 | L.ECApp (e, t) => let
|
|
adamc@143
|
832 val (tag, ts) = getTag' e
|
|
adamc@143
|
833 in
|
|
adamc@143
|
834 (tag, ts @ [t])
|
|
adamc@143
|
835 end
|
|
adamc@140
|
836 | _ => (E.errorAt loc "Non-constant XML tag";
|
|
adamc@140
|
837 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
|
|
adamc@143
|
838 ("", []))
|
|
adamc@140
|
839
|
|
adamc@95
|
840 fun getTag (e, _) =
|
|
adamc@95
|
841 case e of
|
|
adamc@143
|
842 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
|
|
adamc@140
|
843 | L.EApp (e, (L.ERecord [], _)) => getTag' e
|
|
adamc@95
|
844 | _ => (E.errorAt loc "Non-constant XML tag";
|
|
adamc@95
|
845 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
|
|
adamc@143
|
846 ("", []))
|
|
adamc@95
|
847
|
|
adamc@143
|
848 val (tag, targs) = getTag tag
|
|
adamc@95
|
849
|
|
adamc@179
|
850 val (attrs, fm) = monoExp (env, st, fm) attrs
|
|
adamc@104
|
851
|
|
adamc@143
|
852 fun tagStart tag =
|
|
adamc@104
|
853 case #1 attrs of
|
|
adamc@104
|
854 L'.ERecord xes =>
|
|
adamc@104
|
855 let
|
|
adamc@104
|
856 fun lowercaseFirst "" = ""
|
|
adamc@143
|
857 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0)))
|
|
adamc@143
|
858 ^ String.extract (s, 1, NONE)
|
|
adamc@104
|
859
|
|
adamc@104
|
860 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
|
|
adamc@104
|
861 in
|
|
adamc@179
|
862 foldl (fn ((x, e, t), (s, fm)) =>
|
|
adamc@104
|
863 let
|
|
adamc@104
|
864 val xp = " " ^ lowercaseFirst x ^ "=\""
|
|
adamc@120
|
865
|
|
adamc@120
|
866 val fooify =
|
|
adamc@120
|
867 case x of
|
|
adamc@185
|
868 "Href" => urlifyExp
|
|
adamc@185
|
869 | "Link" => urlifyExp
|
|
adamc@143
|
870 | "Action" => urlifyExp
|
|
adamc@120
|
871 | _ => attrifyExp
|
|
adamc@179
|
872
|
|
adamc@179
|
873 val (e, fm) = fooify env fm (e, t)
|
|
adamc@104
|
874 in
|
|
adamc@179
|
875 ((L'.EStrcat (s,
|
|
adamc@179
|
876 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
|
|
adamc@179
|
877 (L'.EStrcat (e,
|
|
adamc@179
|
878 (L'.EPrim (Prim.String "\""),
|
|
adamc@179
|
879 loc)),
|
|
adamc@179
|
880 loc)),
|
|
adamc@179
|
881 loc)), loc),
|
|
adamc@179
|
882 fm)
|
|
adamc@104
|
883 end)
|
|
adamc@179
|
884 (s, fm) xes
|
|
adamc@104
|
885 end
|
|
adamc@143
|
886 | _ => raise Fail "Non-record attributes!"
|
|
adamc@104
|
887
|
|
adamc@143
|
888 fun input typ =
|
|
adamc@143
|
889 case targs of
|
|
adamc@155
|
890 [_, (L.CName name, _)] =>
|
|
adamc@179
|
891 let
|
|
adamc@179
|
892 val (ts, fm) = tagStart "input"
|
|
adamc@179
|
893 in
|
|
adamc@179
|
894 ((L'.EStrcat (ts,
|
|
adamc@179
|
895 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
|
|
adamc@179
|
896 loc)), loc), fm)
|
|
adamc@179
|
897 end
|
|
adamc@143
|
898 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@153
|
899 raise Fail "No name passed to input tag")
|
|
adamc@104
|
900
|
|
adamc@152
|
901 fun normal (tag, extra) =
|
|
adamc@143
|
902 let
|
|
adamc@179
|
903 val (tagStart, fm) = tagStart tag
|
|
adamc@152
|
904 val tagStart = case extra of
|
|
adamc@152
|
905 NONE => tagStart
|
|
adamc@152
|
906 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
|
|
adamc@152
|
907
|
|
adamc@143
|
908 fun normal () =
|
|
adamc@179
|
909 let
|
|
adamc@179
|
910 val (xml, fm) = monoExp (env, st, fm) xml
|
|
adamc@179
|
911 in
|
|
adamc@179
|
912 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
|
|
adamc@179
|
913 (L'.EStrcat (xml,
|
|
adamc@179
|
914 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
|
|
adamc@179
|
915 loc)), loc)),
|
|
adamc@179
|
916 loc),
|
|
adamc@179
|
917 fm)
|
|
adamc@179
|
918 end
|
|
adamc@143
|
919 in
|
|
adamc@143
|
920 case xml of
|
|
adamc@143
|
921 (L.EApp ((L.ECApp (
|
|
adamc@143
|
922 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
|
|
adamc@143
|
923 _), _),
|
|
adamc@143
|
924 _), _),
|
|
adamc@143
|
925 (L.EPrim (Prim.String s), _)), _) =>
|
|
adamc@143
|
926 if CharVector.all Char.isSpace s then
|
|
adamc@179
|
927 ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc), fm)
|
|
adamc@143
|
928 else
|
|
adamc@143
|
929 normal ()
|
|
adamc@143
|
930 | _ => normal ()
|
|
adamc@143
|
931 end
|
|
adamc@152
|
932 in
|
|
adamc@152
|
933 case tag of
|
|
adamc@179
|
934 "submit" => ((L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc), fm)
|
|
adamc@152
|
935
|
|
adamc@152
|
936 | "textbox" =>
|
|
adamc@152
|
937 (case targs of
|
|
adamc@152
|
938 [_, (L.CName name, _)] =>
|
|
adamc@179
|
939 let
|
|
adamc@179
|
940 val (ts, fm) = tagStart "input"
|
|
adamc@179
|
941 in
|
|
adamc@179
|
942 ((L'.EStrcat (ts,
|
|
adamc@179
|
943 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
|
|
adamc@179
|
944 loc)), loc), fm)
|
|
adamc@179
|
945 end
|
|
adamc@152
|
946 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@153
|
947 raise Fail "No name passed to textarea tag"))
|
|
adamc@155
|
948 | "password" => input "password"
|
|
adamc@152
|
949 | "ltextarea" =>
|
|
adamc@152
|
950 (case targs of
|
|
adamc@152
|
951 [_, (L.CName name, _)] =>
|
|
adamc@179
|
952 let
|
|
adamc@179
|
953 val (ts, fm) = tagStart "textarea"
|
|
adamc@179
|
954 val (xml, fm) = monoExp (env, st, fm) xml
|
|
adamc@179
|
955 in
|
|
adamc@179
|
956 ((L'.EStrcat ((L'.EStrcat (ts,
|
|
adamc@179
|
957 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
|
|
adamc@179
|
958 (L'.EStrcat (xml,
|
|
adamc@179
|
959 (L'.EPrim (Prim.String "</textarea>"),
|
|
adamc@179
|
960 loc)), loc)),
|
|
adamc@179
|
961 loc), fm)
|
|
adamc@179
|
962 end
|
|
adamc@152
|
963 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@153
|
964 raise Fail "No name passed to ltextarea tag"))
|
|
adamc@153
|
965
|
|
adamc@190
|
966 | "checkbox" => input "checkbox"
|
|
adamc@190
|
967
|
|
adamc@153
|
968 | "radio" =>
|
|
adamc@153
|
969 (case targs of
|
|
adamc@153
|
970 [_, (L.CName name, _)] =>
|
|
adamc@179
|
971 monoExp (env, St.setRadioGroup (st, name), fm) xml
|
|
adamc@153
|
972 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@153
|
973 raise Fail "No name passed to radio tag"))
|
|
adamc@153
|
974 | "radioOption" =>
|
|
adamc@153
|
975 (case St.radioGroup st of
|
|
adamc@153
|
976 NONE => raise Fail "No name for radioGroup"
|
|
adamc@153
|
977 | SOME name =>
|
|
adamc@153
|
978 normal ("input",
|
|
adamc@153
|
979 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
|
|
adamc@152
|
980
|
|
adamc@154
|
981 | "lselect" =>
|
|
adamc@154
|
982 (case targs of
|
|
adamc@154
|
983 [_, (L.CName name, _)] =>
|
|
adamc@179
|
984 let
|
|
adamc@179
|
985 val (ts, fm) = tagStart "select"
|
|
adamc@179
|
986 val (xml, fm) = monoExp (env, st, fm) xml
|
|
adamc@179
|
987 in
|
|
adamc@179
|
988 ((L'.EStrcat ((L'.EStrcat (ts,
|
|
adamc@179
|
989 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
|
|
adamc@179
|
990 (L'.EStrcat (xml,
|
|
adamc@179
|
991 (L'.EPrim (Prim.String "</select>"),
|
|
adamc@179
|
992 loc)), loc)),
|
|
adamc@179
|
993 loc),
|
|
adamc@179
|
994 fm)
|
|
adamc@179
|
995 end
|
|
adamc@154
|
996 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@154
|
997 raise Fail "No name passed to lselect tag"))
|
|
adamc@154
|
998
|
|
adamc@154
|
999 | "loption" => normal ("option", NONE)
|
|
adamc@154
|
1000
|
|
adamc@152
|
1001 | _ => normal (tag, NONE)
|
|
adamc@95
|
1002 end
|
|
adamc@94
|
1003
|
|
adamc@141
|
1004 | L.EApp ((L.ECApp (
|
|
adamc@141
|
1005 (L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _),
|
|
adamc@141
|
1006 _), _),
|
|
adamc@141
|
1007 xml) =>
|
|
adamc@143
|
1008 let
|
|
adamc@143
|
1009 fun findSubmit (e, _) =
|
|
adamc@143
|
1010 case e of
|
|
adamc@143
|
1011 L.EApp (
|
|
adamc@143
|
1012 (L.EApp (
|
|
adamc@143
|
1013 (L.ECApp (
|
|
adamc@143
|
1014 (L.ECApp (
|
|
adamc@143
|
1015 (L.ECApp (
|
|
adamc@143
|
1016 (L.ECApp (
|
|
adamc@143
|
1017 (L.EFfi ("Basis", "join"),
|
|
adamc@143
|
1018 _), _), _),
|
|
adamc@143
|
1019 _), _),
|
|
adamc@143
|
1020 _), _),
|
|
adamc@143
|
1021 _), _),
|
|
adamc@143
|
1022 xml1), _),
|
|
adamc@143
|
1023 xml2) => (case findSubmit xml1 of
|
|
adamc@143
|
1024 Error => Error
|
|
adamc@143
|
1025 | NotFound => findSubmit xml2
|
|
adamc@143
|
1026 | Found e =>
|
|
adamc@143
|
1027 case findSubmit xml2 of
|
|
adamc@143
|
1028 NotFound => Found e
|
|
adamc@143
|
1029 | _ => Error)
|
|
adamc@143
|
1030 | L.EApp (
|
|
adamc@143
|
1031 (L.EApp (
|
|
adamc@143
|
1032 (L.EApp (
|
|
adamc@143
|
1033 (L.ECApp (
|
|
adamc@143
|
1034 (L.ECApp (
|
|
adamc@143
|
1035 (L.ECApp (
|
|
adamc@143
|
1036 (L.ECApp (
|
|
adamc@143
|
1037 (L.ECApp (
|
|
adamc@143
|
1038 (L.ECApp (
|
|
adamc@143
|
1039 (L.ECApp (
|
|
adamc@143
|
1040 (L.ECApp (
|
|
adamc@143
|
1041 (L.EFfi ("Basis", "tag"),
|
|
adamc@143
|
1042 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
|
|
adamc@143
|
1043 attrs), _),
|
|
adamc@143
|
1044 _), _),
|
|
adamc@143
|
1045 xml) =>
|
|
adamc@143
|
1046 (case #1 attrs of
|
|
adamc@143
|
1047 L.ERecord xes =>
|
|
adamc@143
|
1048 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
|
|
adamc@143
|
1049 | _ => NONE) xes of
|
|
adamc@143
|
1050 NONE => findSubmit xml
|
|
adamc@143
|
1051 | SOME et =>
|
|
adamc@143
|
1052 case findSubmit xml of
|
|
adamc@143
|
1053 NotFound => Found et
|
|
adamc@143
|
1054 | _ => Error)
|
|
adamc@143
|
1055 | _ => findSubmit xml)
|
|
adamc@143
|
1056 | _ => NotFound
|
|
adamc@143
|
1057
|
|
adamc@143
|
1058 val (action, actionT) = case findSubmit xml of
|
|
adamc@143
|
1059 NotFound => raise Fail "No submit found"
|
|
adamc@143
|
1060 | Error => raise Fail "Not ready for multi-submit lforms yet"
|
|
adamc@143
|
1061 | Found et => et
|
|
adamc@143
|
1062
|
|
adamc@143
|
1063 val actionT = monoType env actionT
|
|
adamc@179
|
1064 val (action, fm) = monoExp (env, st, fm) action
|
|
adamc@179
|
1065 val (action, fm) = urlifyExp env fm (action, actionT)
|
|
adamc@179
|
1066 val (xml, fm) = monoExp (env, st, fm) xml
|
|
adamc@143
|
1067 in
|
|
adamc@179
|
1068 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
|
|
adamc@179
|
1069 (L'.EStrcat (action,
|
|
adamc@179
|
1070 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
|
|
adamc@179
|
1071 (L'.EStrcat (xml,
|
|
adamc@179
|
1072 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
|
|
adamc@179
|
1073 fm)
|
|
adamc@143
|
1074 end
|
|
adamc@141
|
1075
|
|
adamc@148
|
1076 | L.EApp ((L.ECApp (
|
|
adamc@148
|
1077 (L.ECApp (
|
|
adamc@148
|
1078 (L.ECApp (
|
|
adamc@148
|
1079 (L.ECApp (
|
|
adamc@148
|
1080 (L.EFfi ("Basis", "useMore"), _), _), _),
|
|
adamc@148
|
1081 _), _),
|
|
adamc@148
|
1082 _), _),
|
|
adamc@148
|
1083 _), _),
|
|
adamc@179
|
1084 xml) => monoExp (env, st, fm) xml
|
|
adamc@148
|
1085
|
|
adamc@179
|
1086 | L.EApp (e1, e2) =>
|
|
adamc@179
|
1087 let
|
|
adamc@179
|
1088 val (e1, fm) = monoExp (env, st, fm) e1
|
|
adamc@179
|
1089 val (e2, fm) = monoExp (env, st, fm) e2
|
|
adamc@179
|
1090 in
|
|
adamc@179
|
1091 ((L'.EApp (e1, e2), loc), fm)
|
|
adamc@179
|
1092 end
|
|
adamc@26
|
1093 | L.EAbs (x, dom, ran, e) =>
|
|
adamc@179
|
1094 let
|
|
adamc@179
|
1095 val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
|
|
adamc@179
|
1096 in
|
|
adamc@179
|
1097 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
|
|
adamc@179
|
1098 end
|
|
adamc@25
|
1099 | L.ECApp _ => poly ()
|
|
adamc@25
|
1100 | L.ECAbs _ => poly ()
|
|
adamc@25
|
1101
|
|
adamc@252
|
1102 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
|
|
adamc@252
|
1103 | L.EFfiApp (m, x, es) =>
|
|
adamc@252
|
1104 let
|
|
adamc@252
|
1105 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
|
|
adamc@252
|
1106 in
|
|
adamc@252
|
1107 ((L'.EFfiApp (m, x, es), loc), fm)
|
|
adamc@252
|
1108 end
|
|
adamc@252
|
1109
|
|
adamc@179
|
1110 | L.ERecord xes =>
|
|
adamc@179
|
1111 let
|
|
adamc@179
|
1112 val (xes, fm) = ListUtil.foldlMap
|
|
adamc@179
|
1113 (fn ((x, e, t), fm) =>
|
|
adamc@179
|
1114 let
|
|
adamc@179
|
1115 val (e, fm) = monoExp (env, st, fm) e
|
|
adamc@179
|
1116 in
|
|
adamc@179
|
1117 ((monoName env x,
|
|
adamc@179
|
1118 e,
|
|
adamc@179
|
1119 monoType env t), fm)
|
|
adamc@179
|
1120 end) fm xes
|
|
adamc@179
|
1121 in
|
|
adamc@179
|
1122 ((L'.ERecord xes, loc), fm)
|
|
adamc@179
|
1123 end
|
|
adamc@179
|
1124 | L.EField (e, x, _) =>
|
|
adamc@179
|
1125 let
|
|
adamc@179
|
1126 val (e, fm) = monoExp (env, st, fm) e
|
|
adamc@179
|
1127 in
|
|
adamc@179
|
1128 ((L'.EField (e, monoName env x), loc), fm)
|
|
adamc@179
|
1129 end
|
|
adamc@149
|
1130 | L.ECut _ => poly ()
|
|
adamc@73
|
1131 | L.EFold _ => poly ()
|
|
adamc@177
|
1132
|
|
adamc@182
|
1133 | L.ECase (e, pes, {disc, result}) =>
|
|
adamc@179
|
1134 let
|
|
adamc@179
|
1135 val (e, fm) = monoExp (env, st, fm) e
|
|
adamc@179
|
1136 val (pes, fm) = ListUtil.foldlMap
|
|
adamc@179
|
1137 (fn ((p, e), fm) =>
|
|
adamc@179
|
1138 let
|
|
adamc@179
|
1139 val (e, fm) = monoExp (env, st, fm) e
|
|
adamc@179
|
1140 in
|
|
adamc@182
|
1141 ((monoPat env p, e), fm)
|
|
adamc@179
|
1142 end) fm pes
|
|
adamc@179
|
1143 in
|
|
adamc@182
|
1144 ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
|
|
adamc@179
|
1145 end
|
|
adamc@177
|
1146
|
|
adamc@179
|
1147 | L.EWrite e =>
|
|
adamc@179
|
1148 let
|
|
adamc@179
|
1149 val (e, fm) = monoExp (env, st, fm) e
|
|
adamc@179
|
1150 in
|
|
adamc@252
|
1151 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
|
|
adamc@252
|
1152 (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
|
|
adamc@179
|
1153 end
|
|
adamc@110
|
1154
|
|
adamc@179
|
1155 | L.EClosure (n, es) =>
|
|
adamc@179
|
1156 let
|
|
adamc@179
|
1157 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
|
|
adamc@179
|
1158 monoExp (env, st, fm) e)
|
|
adamc@179
|
1159 fm es
|
|
adamc@179
|
1160 in
|
|
adamc@179
|
1161 ((L'.EClosure (n, es), loc), fm)
|
|
adamc@179
|
1162 end
|
|
adamc@25
|
1163 end
|
|
adamc@25
|
1164
|
|
adamc@179
|
1165 fun monoDecl (env, fm) (all as (d, loc)) =
|
|
adamc@25
|
1166 let
|
|
adamc@25
|
1167 fun poly () =
|
|
adamc@25
|
1168 (E.errorAt loc "Unsupported declaration";
|
|
adamc@25
|
1169 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
|
|
adamc@25
|
1170 NONE)
|
|
adamc@25
|
1171 in
|
|
adamc@25
|
1172 case d of
|
|
adamc@25
|
1173 L.DCon _ => NONE
|
|
adamc@193
|
1174 | L.DDatatype (x, n, [], xncs) =>
|
|
adamc@193
|
1175 let
|
|
adamc@196
|
1176 val env' = Env.declBinds env all
|
|
adamc@196
|
1177 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc)
|
|
adamc@164
|
1178 in
|
|
adamc@196
|
1179 SOME (env', fm, d)
|
|
adamc@193
|
1180 end
|
|
adamc@193
|
1181 | L.DDatatype _ => poly ()
|
|
adamc@179
|
1182 | L.DVal (x, n, t, e, s) =>
|
|
adamc@179
|
1183 let
|
|
adamc@179
|
1184 val (e, fm) = monoExp (env, St.empty, fm) e
|
|
adamc@179
|
1185 in
|
|
adamc@179
|
1186 SOME (Env.pushENamed env x n t NONE s,
|
|
adamc@179
|
1187 fm,
|
|
adamc@179
|
1188 (L'.DVal (x, n, monoType env t, e, s), loc))
|
|
adamc@179
|
1189 end
|
|
adamc@128
|
1190 | L.DValRec vis =>
|
|
adamc@128
|
1191 let
|
|
adamc@128
|
1192 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
|
|
adamc@179
|
1193
|
|
adamc@179
|
1194 val (vis, fm) = ListUtil.foldlMap
|
|
adamc@179
|
1195 (fn ((x, n, t, e, s), fm) =>
|
|
adamc@179
|
1196 let
|
|
adamc@179
|
1197 val (e, fm) = monoExp (env, St.empty, fm) e
|
|
adamc@179
|
1198 in
|
|
adamc@179
|
1199 ((x, n, monoType env t, e, s), fm)
|
|
adamc@179
|
1200 end)
|
|
adamc@179
|
1201 fm vis
|
|
adamc@128
|
1202 in
|
|
adamc@128
|
1203 SOME (env,
|
|
adamc@179
|
1204 fm,
|
|
adamc@179
|
1205 (L'.DValRec vis, loc))
|
|
adamc@128
|
1206 end
|
|
adamc@144
|
1207 | L.DExport (ek, n) =>
|
|
adamc@115
|
1208 let
|
|
adamc@120
|
1209 val (_, t, _, s) = Env.lookupENamed env n
|
|
adamc@120
|
1210
|
|
adamc@120
|
1211 fun unwind (t, _) =
|
|
adamc@120
|
1212 case t of
|
|
adamc@120
|
1213 L.TFun (dom, ran) => dom :: unwind ran
|
|
adamc@120
|
1214 | _ => []
|
|
adamc@120
|
1215
|
|
adamc@120
|
1216 val ts = map (monoType env) (unwind t)
|
|
adamc@115
|
1217 in
|
|
adamc@179
|
1218 SOME (env, fm, (L'.DExport (ek, s, n, ts), loc))
|
|
adamc@115
|
1219 end
|
|
adamc@251
|
1220 | L.DTable (x, n, _, s) =>
|
|
adamc@251
|
1221 let
|
|
adamc@251
|
1222 val t = (L.CFfi ("Basis", "string"), loc)
|
|
adamc@251
|
1223 val t' = (L'.TFfi ("Basis", "string"), loc)
|
|
adamc@251
|
1224 val e = (L'.EPrim (Prim.String s), loc)
|
|
adamc@251
|
1225 in
|
|
adamc@251
|
1226 SOME (Env.pushENamed env x n t NONE s,
|
|
adamc@251
|
1227 fm,
|
|
adamc@251
|
1228 (L'.DVal (x, n, t', e, s), loc))
|
|
adamc@251
|
1229 end
|
|
adamc@25
|
1230 end
|
|
adamc@25
|
1231
|
|
adamc@25
|
1232 fun monoize env ds =
|
|
adamc@25
|
1233 let
|
|
adamc@179
|
1234 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
|
|
adamc@179
|
1235 case monoDecl (env, fm) d of
|
|
adamc@179
|
1236 NONE => (env, fm, ds)
|
|
adamc@179
|
1237 | SOME (env, fm, d) =>
|
|
adamc@179
|
1238 (env,
|
|
adamc@179
|
1239 Fm.enter fm,
|
|
adamc@179
|
1240 d :: Fm.decls fm @ ds))
|
|
adamc@179
|
1241 (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds
|
|
adamc@25
|
1242 in
|
|
adamc@25
|
1243 rev ds
|
|
adamc@25
|
1244 end
|
|
adamc@25
|
1245
|
|
adamc@25
|
1246 end
|
