|
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@168
|
36 val dummyTyp = (L'.TDatatype (0, []), E.dummySpan)
|
|
adamc@25
|
37
|
|
adamc@25
|
38 fun monoName env (all as (c, loc)) =
|
|
adamc@25
|
39 let
|
|
adamc@25
|
40 fun poly () =
|
|
adamc@25
|
41 (E.errorAt loc "Unsupported name constructor";
|
|
adamc@25
|
42 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
|
|
adamc@25
|
43 "")
|
|
adamc@25
|
44 in
|
|
adamc@25
|
45 case c of
|
|
adamc@25
|
46 L.CName s => s
|
|
adamc@25
|
47 | _ => poly ()
|
|
adamc@25
|
48 end
|
|
adamc@25
|
49
|
|
adamc@25
|
50 fun monoType env (all as (c, loc)) =
|
|
adamc@25
|
51 let
|
|
adamc@25
|
52 fun poly () =
|
|
adamc@25
|
53 (E.errorAt loc "Unsupported type constructor";
|
|
adamc@25
|
54 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
|
|
adamc@25
|
55 dummyTyp)
|
|
adamc@25
|
56 in
|
|
adamc@25
|
57 case c of
|
|
adamc@25
|
58 L.TFun (c1, c2) => (L'.TFun (monoType env c1, monoType env c2), loc)
|
|
adamc@25
|
59 | L.TCFun _ => poly ()
|
|
adamc@25
|
60 | L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
|
|
adamc@25
|
61 (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc)
|
|
adamc@25
|
62 | L.TRecord _ => poly ()
|
|
adamc@25
|
63
|
|
adamc@143
|
64 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
|
|
adamc@143
|
65 (L'.TFfi ("Basis", "string"), loc)
|
|
adamc@94
|
66
|
|
adamc@25
|
67 | L.CRel _ => poly ()
|
|
adamc@168
|
68 | L.CNamed n =>
|
|
adamc@168
|
69 let
|
|
adamc@168
|
70 val (_, xncs) = Env.lookupDatatype env n
|
|
adamc@168
|
71
|
|
adamc@168
|
72 val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs
|
|
adamc@168
|
73 in
|
|
adamc@168
|
74 (L'.TDatatype (n, xncs), loc)
|
|
adamc@168
|
75 end
|
|
adamc@51
|
76 | L.CFfi mx => (L'.TFfi mx, loc)
|
|
adamc@25
|
77 | L.CApp _ => poly ()
|
|
adamc@25
|
78 | L.CAbs _ => poly ()
|
|
adamc@25
|
79
|
|
adamc@25
|
80 | L.CName _ => poly ()
|
|
adamc@25
|
81
|
|
adamc@25
|
82 | L.CRecord _ => poly ()
|
|
adamc@25
|
83 | L.CConcat _ => poly ()
|
|
adamc@69
|
84 | L.CFold _ => poly ()
|
|
adamc@87
|
85 | L.CUnit => poly ()
|
|
adamc@25
|
86 end
|
|
adamc@25
|
87
|
|
adamc@25
|
88 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
|
|
adamc@25
|
89
|
|
adamc@120
|
90 fun fooifyExp name env =
|
|
adamc@120
|
91 let
|
|
adamc@120
|
92 fun fooify (e, tAll as (t, loc)) =
|
|
adamc@120
|
93 case #1 e of
|
|
adamc@120
|
94 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
|
|
adamc@120
|
95 let
|
|
adamc@120
|
96 val (_, _, _, s) = Env.lookupENamed env fnam
|
|
adamc@120
|
97 in
|
|
adamc@120
|
98 (L'.EPrim (Prim.String s), loc)
|
|
adamc@120
|
99 end
|
|
adamc@120
|
100 | L'.EClosure (fnam, args) =>
|
|
adamc@120
|
101 let
|
|
adamc@120
|
102 val (_, ft, _, s) = Env.lookupENamed env fnam
|
|
adamc@120
|
103 val ft = monoType env ft
|
|
adamc@111
|
104
|
|
adamc@120
|
105 fun attrify (args, ft, e) =
|
|
adamc@120
|
106 case (args, ft) of
|
|
adamc@120
|
107 ([], _) => e
|
|
adamc@120
|
108 | (arg :: args, (L'.TFun (t, ft), _)) =>
|
|
adamc@121
|
109 attrify (args, ft,
|
|
adamc@121
|
110 (L'.EStrcat (e,
|
|
adamc@121
|
111 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
|
|
adamc@121
|
112 fooify (arg, t)), loc)), loc))
|
|
adamc@120
|
113 | _ => (E.errorAt loc "Type mismatch encoding attribute";
|
|
adamc@120
|
114 e)
|
|
adamc@120
|
115 in
|
|
adamc@120
|
116 attrify (args, ft, (L'.EPrim (Prim.String s), loc))
|
|
adamc@120
|
117 end
|
|
adamc@120
|
118 | _ =>
|
|
adamc@120
|
119 case t of
|
|
adamc@120
|
120 L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", name ^ "ifyString", [e]), loc)
|
|
adamc@120
|
121 | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", name ^ "ifyInt", [e]), loc)
|
|
adamc@120
|
122 | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", name ^ "ifyFloat", [e]), loc)
|
|
adamc@120
|
123 | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc)
|
|
adamc@111
|
124
|
|
adamc@168
|
125 | L'.TDatatype _ => (L'.EPrim (Prim.String "A"), loc)
|
|
adamc@164
|
126
|
|
adamc@120
|
127 | _ => (E.errorAt loc "Don't know how to encode attribute type";
|
|
adamc@120
|
128 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
|
|
adamc@120
|
129 dummyExp)
|
|
adamc@120
|
130 in
|
|
adamc@120
|
131 fooify
|
|
adamc@120
|
132 end
|
|
adamc@120
|
133
|
|
adamc@120
|
134 val attrifyExp = fooifyExp "attr"
|
|
adamc@120
|
135 val urlifyExp = fooifyExp "url"
|
|
adamc@105
|
136
|
|
adamc@143
|
137 datatype 'a failable_search =
|
|
adamc@143
|
138 Found of 'a
|
|
adamc@143
|
139 | NotFound
|
|
adamc@143
|
140 | Error
|
|
adamc@143
|
141
|
|
adamc@153
|
142 structure St :> sig
|
|
adamc@153
|
143 type t
|
|
adamc@153
|
144
|
|
adamc@153
|
145 val empty : t
|
|
adamc@153
|
146
|
|
adamc@153
|
147 val radioGroup : t -> string option
|
|
adamc@153
|
148 val setRadioGroup : t * string -> t
|
|
adamc@153
|
149 end = struct
|
|
adamc@153
|
150
|
|
adamc@153
|
151 type t = {
|
|
adamc@153
|
152 radioGroup : string option
|
|
adamc@153
|
153 }
|
|
adamc@153
|
154
|
|
adamc@153
|
155 val empty = {radioGroup = NONE}
|
|
adamc@153
|
156
|
|
adamc@153
|
157 fun radioGroup (t : t) = #radioGroup t
|
|
adamc@153
|
158
|
|
adamc@153
|
159 fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
|
|
adamc@153
|
160
|
|
adamc@153
|
161 end
|
|
adamc@153
|
162
|
|
adamc@153
|
163 fun monoExp (env, st) (all as (e, loc)) =
|
|
adamc@25
|
164 let
|
|
adamc@25
|
165 fun poly () =
|
|
adamc@25
|
166 (E.errorAt loc "Unsupported expression";
|
|
adamc@25
|
167 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
|
|
adamc@25
|
168 dummyExp)
|
|
adamc@25
|
169 in
|
|
adamc@25
|
170 case e of
|
|
adamc@25
|
171 L.EPrim p => (L'.EPrim p, loc)
|
|
adamc@25
|
172 | L.ERel n => (L'.ERel n, loc)
|
|
adamc@25
|
173 | L.ENamed n => (L'.ENamed n, loc)
|
|
adamc@177
|
174 | L.ECon _ => raise Fail "Monoize ECon"
|
|
adamc@51
|
175 | L.EFfi mx => (L'.EFfi mx, loc)
|
|
adamc@153
|
176 | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp (env, st)) es), loc)
|
|
adamc@94
|
177
|
|
adamc@139
|
178 | L.EApp (
|
|
adamc@139
|
179 (L.ECApp (
|
|
adamc@141
|
180 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
|
|
adamc@139
|
181 _), _),
|
|
adamc@153
|
182 se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp (env, st) se]), loc)
|
|
adamc@95
|
183 | L.EApp (
|
|
adamc@95
|
184 (L.EApp (
|
|
adamc@95
|
185 (L.ECApp (
|
|
adamc@95
|
186 (L.ECApp (
|
|
adamc@95
|
187 (L.ECApp (
|
|
adamc@139
|
188 (L.ECApp (
|
|
adamc@140
|
189 (L.EFfi ("Basis", "join"),
|
|
adamc@139
|
190 _), _), _),
|
|
adamc@139
|
191 _), _),
|
|
adamc@95
|
192 _), _),
|
|
adamc@95
|
193 _), _),
|
|
adamc@95
|
194 xml1), _),
|
|
adamc@153
|
195 xml2) => (L'.EStrcat (monoExp (env, st) xml1, monoExp (env, st) xml2), loc)
|
|
adamc@95
|
196
|
|
adamc@95
|
197 | L.EApp (
|
|
adamc@95
|
198 (L.EApp (
|
|
adamc@104
|
199 (L.EApp (
|
|
adamc@95
|
200 (L.ECApp (
|
|
adamc@104
|
201 (L.ECApp (
|
|
adamc@104
|
202 (L.ECApp (
|
|
adamc@104
|
203 (L.ECApp (
|
|
adamc@139
|
204 (L.ECApp (
|
|
adamc@139
|
205 (L.ECApp (
|
|
adamc@139
|
206 (L.ECApp (
|
|
adamc@139
|
207 (L.ECApp (
|
|
adamc@139
|
208 (L.EFfi ("Basis", "tag"),
|
|
adamc@139
|
209 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
|
|
adamc@104
|
210 attrs), _),
|
|
adamc@95
|
211 tag), _),
|
|
adamc@95
|
212 xml) =>
|
|
adamc@95
|
213 let
|
|
adamc@140
|
214 fun getTag' (e, _) =
|
|
adamc@140
|
215 case e of
|
|
adamc@143
|
216 L.EFfi ("Basis", tag) => (tag, [])
|
|
adamc@143
|
217 | L.ECApp (e, t) => let
|
|
adamc@143
|
218 val (tag, ts) = getTag' e
|
|
adamc@143
|
219 in
|
|
adamc@143
|
220 (tag, ts @ [t])
|
|
adamc@143
|
221 end
|
|
adamc@140
|
222 | _ => (E.errorAt loc "Non-constant XML tag";
|
|
adamc@140
|
223 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
|
|
adamc@143
|
224 ("", []))
|
|
adamc@140
|
225
|
|
adamc@95
|
226 fun getTag (e, _) =
|
|
adamc@95
|
227 case e of
|
|
adamc@143
|
228 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
|
|
adamc@140
|
229 | L.EApp (e, (L.ERecord [], _)) => getTag' e
|
|
adamc@95
|
230 | _ => (E.errorAt loc "Non-constant XML tag";
|
|
adamc@95
|
231 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
|
|
adamc@143
|
232 ("", []))
|
|
adamc@95
|
233
|
|
adamc@143
|
234 val (tag, targs) = getTag tag
|
|
adamc@95
|
235
|
|
adamc@153
|
236 val attrs = monoExp (env, st) attrs
|
|
adamc@104
|
237
|
|
adamc@143
|
238 fun tagStart tag =
|
|
adamc@104
|
239 case #1 attrs of
|
|
adamc@104
|
240 L'.ERecord xes =>
|
|
adamc@104
|
241 let
|
|
adamc@104
|
242 fun lowercaseFirst "" = ""
|
|
adamc@143
|
243 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0)))
|
|
adamc@143
|
244 ^ String.extract (s, 1, NONE)
|
|
adamc@104
|
245
|
|
adamc@104
|
246 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
|
|
adamc@104
|
247 in
|
|
adamc@105
|
248 foldl (fn ((x, e, t), s) =>
|
|
adamc@104
|
249 let
|
|
adamc@104
|
250 val xp = " " ^ lowercaseFirst x ^ "=\""
|
|
adamc@120
|
251
|
|
adamc@120
|
252 val fooify =
|
|
adamc@120
|
253 case x of
|
|
adamc@120
|
254 "Link" => urlifyExp
|
|
adamc@143
|
255 | "Action" => urlifyExp
|
|
adamc@120
|
256 | _ => attrifyExp
|
|
adamc@104
|
257 in
|
|
adamc@104
|
258 (L'.EStrcat (s,
|
|
adamc@104
|
259 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
|
|
adamc@120
|
260 (L'.EStrcat (fooify env (e, t),
|
|
adamc@143
|
261 (L'.EPrim (Prim.String "\""),
|
|
adamc@143
|
262 loc)),
|
|
adamc@104
|
263 loc)),
|
|
adamc@104
|
264 loc)), loc)
|
|
adamc@104
|
265 end)
|
|
adamc@143
|
266 s xes
|
|
adamc@104
|
267 end
|
|
adamc@143
|
268 | _ => raise Fail "Non-record attributes!"
|
|
adamc@104
|
269
|
|
adamc@143
|
270 fun input typ =
|
|
adamc@143
|
271 case targs of
|
|
adamc@155
|
272 [_, (L.CName name, _)] =>
|
|
adamc@143
|
273 (L'.EStrcat (tagStart "input",
|
|
adamc@143
|
274 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
|
|
adamc@143
|
275 loc)), loc)
|
|
adamc@143
|
276 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@153
|
277 raise Fail "No name passed to input tag")
|
|
adamc@104
|
278
|
|
adamc@152
|
279 fun normal (tag, extra) =
|
|
adamc@143
|
280 let
|
|
adamc@143
|
281 val tagStart = tagStart tag
|
|
adamc@152
|
282 val tagStart = case extra of
|
|
adamc@152
|
283 NONE => tagStart
|
|
adamc@152
|
284 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
|
|
adamc@152
|
285
|
|
adamc@143
|
286 fun normal () =
|
|
adamc@143
|
287 (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
|
|
adamc@153
|
288 (L'.EStrcat (monoExp (env, st) xml,
|
|
adamc@143
|
289 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
|
|
adamc@143
|
290 loc)), loc)),
|
|
adamc@143
|
291 loc)
|
|
adamc@143
|
292 in
|
|
adamc@143
|
293 case xml of
|
|
adamc@143
|
294 (L.EApp ((L.ECApp (
|
|
adamc@143
|
295 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
|
|
adamc@143
|
296 _), _),
|
|
adamc@143
|
297 _), _),
|
|
adamc@143
|
298 (L.EPrim (Prim.String s), _)), _) =>
|
|
adamc@143
|
299 if CharVector.all Char.isSpace s then
|
|
adamc@143
|
300 (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc)
|
|
adamc@143
|
301 else
|
|
adamc@143
|
302 normal ()
|
|
adamc@143
|
303 | _ => normal ()
|
|
adamc@143
|
304 end
|
|
adamc@152
|
305 in
|
|
adamc@152
|
306 case tag of
|
|
adamc@152
|
307 "submit" => (L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc)
|
|
adamc@152
|
308
|
|
adamc@152
|
309 | "textbox" =>
|
|
adamc@152
|
310 (case targs of
|
|
adamc@152
|
311 [_, (L.CName name, _)] =>
|
|
adamc@152
|
312 (L'.EStrcat (tagStart "input",
|
|
adamc@152
|
313 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
|
|
adamc@152
|
314 loc)), loc)
|
|
adamc@152
|
315 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@153
|
316 raise Fail "No name passed to textarea tag"))
|
|
adamc@155
|
317 | "password" => input "password"
|
|
adamc@152
|
318 | "ltextarea" =>
|
|
adamc@152
|
319 (case targs of
|
|
adamc@152
|
320 [_, (L.CName name, _)] =>
|
|
adamc@152
|
321 (L'.EStrcat ((L'.EStrcat (tagStart "textarea",
|
|
adamc@152
|
322 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
|
|
adamc@153
|
323 (L'.EStrcat (monoExp (env, st) xml,
|
|
adamc@152
|
324 (L'.EPrim (Prim.String "</textarea>"),
|
|
adamc@152
|
325 loc)), loc)),
|
|
adamc@152
|
326 loc)
|
|
adamc@152
|
327 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@153
|
328 raise Fail "No name passed to ltextarea tag"))
|
|
adamc@153
|
329
|
|
adamc@153
|
330 | "radio" =>
|
|
adamc@153
|
331 (case targs of
|
|
adamc@153
|
332 [_, (L.CName name, _)] =>
|
|
adamc@153
|
333 monoExp (env, St.setRadioGroup (st, name)) xml
|
|
adamc@153
|
334 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@153
|
335 raise Fail "No name passed to radio tag"))
|
|
adamc@153
|
336 | "radioOption" =>
|
|
adamc@153
|
337 (case St.radioGroup st of
|
|
adamc@153
|
338 NONE => raise Fail "No name for radioGroup"
|
|
adamc@153
|
339 | SOME name =>
|
|
adamc@153
|
340 normal ("input",
|
|
adamc@153
|
341 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
|
|
adamc@152
|
342
|
|
adamc@154
|
343 | "lselect" =>
|
|
adamc@154
|
344 (case targs of
|
|
adamc@154
|
345 [_, (L.CName name, _)] =>
|
|
adamc@154
|
346 (L'.EStrcat ((L'.EStrcat (tagStart "select",
|
|
adamc@154
|
347 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
|
|
adamc@154
|
348 (L'.EStrcat (monoExp (env, st) xml,
|
|
adamc@154
|
349 (L'.EPrim (Prim.String "</select>"),
|
|
adamc@154
|
350 loc)), loc)),
|
|
adamc@154
|
351 loc)
|
|
adamc@154
|
352 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
|
|
adamc@154
|
353 raise Fail "No name passed to lselect tag"))
|
|
adamc@154
|
354
|
|
adamc@154
|
355 | "loption" => normal ("option", NONE)
|
|
adamc@154
|
356
|
|
adamc@152
|
357 | _ => normal (tag, NONE)
|
|
adamc@95
|
358 end
|
|
adamc@94
|
359
|
|
adamc@141
|
360 | L.EApp ((L.ECApp (
|
|
adamc@141
|
361 (L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _),
|
|
adamc@141
|
362 _), _),
|
|
adamc@141
|
363 xml) =>
|
|
adamc@143
|
364 let
|
|
adamc@143
|
365 fun findSubmit (e, _) =
|
|
adamc@143
|
366 case e of
|
|
adamc@143
|
367 L.EApp (
|
|
adamc@143
|
368 (L.EApp (
|
|
adamc@143
|
369 (L.ECApp (
|
|
adamc@143
|
370 (L.ECApp (
|
|
adamc@143
|
371 (L.ECApp (
|
|
adamc@143
|
372 (L.ECApp (
|
|
adamc@143
|
373 (L.EFfi ("Basis", "join"),
|
|
adamc@143
|
374 _), _), _),
|
|
adamc@143
|
375 _), _),
|
|
adamc@143
|
376 _), _),
|
|
adamc@143
|
377 _), _),
|
|
adamc@143
|
378 xml1), _),
|
|
adamc@143
|
379 xml2) => (case findSubmit xml1 of
|
|
adamc@143
|
380 Error => Error
|
|
adamc@143
|
381 | NotFound => findSubmit xml2
|
|
adamc@143
|
382 | Found e =>
|
|
adamc@143
|
383 case findSubmit xml2 of
|
|
adamc@143
|
384 NotFound => Found e
|
|
adamc@143
|
385 | _ => Error)
|
|
adamc@143
|
386 | L.EApp (
|
|
adamc@143
|
387 (L.EApp (
|
|
adamc@143
|
388 (L.EApp (
|
|
adamc@143
|
389 (L.ECApp (
|
|
adamc@143
|
390 (L.ECApp (
|
|
adamc@143
|
391 (L.ECApp (
|
|
adamc@143
|
392 (L.ECApp (
|
|
adamc@143
|
393 (L.ECApp (
|
|
adamc@143
|
394 (L.ECApp (
|
|
adamc@143
|
395 (L.ECApp (
|
|
adamc@143
|
396 (L.ECApp (
|
|
adamc@143
|
397 (L.EFfi ("Basis", "tag"),
|
|
adamc@143
|
398 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
|
|
adamc@143
|
399 attrs), _),
|
|
adamc@143
|
400 _), _),
|
|
adamc@143
|
401 xml) =>
|
|
adamc@143
|
402 (case #1 attrs of
|
|
adamc@143
|
403 L.ERecord xes =>
|
|
adamc@143
|
404 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
|
|
adamc@143
|
405 | _ => NONE) xes of
|
|
adamc@143
|
406 NONE => findSubmit xml
|
|
adamc@143
|
407 | SOME et =>
|
|
adamc@143
|
408 case findSubmit xml of
|
|
adamc@143
|
409 NotFound => Found et
|
|
adamc@143
|
410 | _ => Error)
|
|
adamc@143
|
411 | _ => findSubmit xml)
|
|
adamc@143
|
412 | _ => NotFound
|
|
adamc@143
|
413
|
|
adamc@143
|
414 val (action, actionT) = case findSubmit xml of
|
|
adamc@143
|
415 NotFound => raise Fail "No submit found"
|
|
adamc@143
|
416 | Error => raise Fail "Not ready for multi-submit lforms yet"
|
|
adamc@143
|
417 | Found et => et
|
|
adamc@143
|
418
|
|
adamc@143
|
419 val actionT = monoType env actionT
|
|
adamc@153
|
420 val action = monoExp (env, st) action
|
|
adamc@143
|
421 in
|
|
adamc@143
|
422 (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
|
|
adamc@143
|
423 (L'.EStrcat (urlifyExp env (action, actionT),
|
|
adamc@143
|
424 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
|
|
adamc@153
|
425 (L'.EStrcat (monoExp (env, st) xml,
|
|
adamc@143
|
426 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc)
|
|
adamc@143
|
427 end
|
|
adamc@141
|
428
|
|
adamc@148
|
429 | L.EApp ((L.ECApp (
|
|
adamc@148
|
430 (L.ECApp (
|
|
adamc@148
|
431 (L.ECApp (
|
|
adamc@148
|
432 (L.ECApp (
|
|
adamc@148
|
433 (L.EFfi ("Basis", "useMore"), _), _), _),
|
|
adamc@148
|
434 _), _),
|
|
adamc@148
|
435 _), _),
|
|
adamc@148
|
436 _), _),
|
|
adamc@153
|
437 xml) => monoExp (env, st) xml
|
|
adamc@148
|
438
|
|
adamc@148
|
439
|
|
adamc@153
|
440 | L.EApp (e1, e2) => (L'.EApp (monoExp (env, st) e1, monoExp (env, st) e2), loc)
|
|
adamc@26
|
441 | L.EAbs (x, dom, ran, e) =>
|
|
adamc@153
|
442 (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom, st) e), loc)
|
|
adamc@25
|
443 | L.ECApp _ => poly ()
|
|
adamc@25
|
444 | L.ECAbs _ => poly ()
|
|
adamc@25
|
445
|
|
adamc@153
|
446 | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x,
|
|
adamc@153
|
447 monoExp (env, st) e,
|
|
adamc@153
|
448 monoType env t)) xes), loc)
|
|
adamc@153
|
449 | L.EField (e, x, _) => (L'.EField (monoExp (env, st) e, monoName env x), loc)
|
|
adamc@149
|
450 | L.ECut _ => poly ()
|
|
adamc@73
|
451 | L.EFold _ => poly ()
|
|
adamc@177
|
452
|
|
adamc@177
|
453 | L.ECase _ => raise Fail "Monoize ECase"
|
|
adamc@177
|
454
|
|
adamc@153
|
455 | L.EWrite e => (L'.EWrite (monoExp (env, st) e), loc)
|
|
adamc@110
|
456
|
|
adamc@153
|
457 | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp (env, st)) es), loc)
|
|
adamc@25
|
458 end
|
|
adamc@25
|
459
|
|
adamc@25
|
460 fun monoDecl env (all as (d, loc)) =
|
|
adamc@25
|
461 let
|
|
adamc@25
|
462 fun poly () =
|
|
adamc@25
|
463 (E.errorAt loc "Unsupported declaration";
|
|
adamc@25
|
464 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
|
|
adamc@25
|
465 NONE)
|
|
adamc@25
|
466 in
|
|
adamc@25
|
467 case d of
|
|
adamc@25
|
468 L.DCon _ => NONE
|
|
adamc@164
|
469 | L.DDatatype (x, n, xncs) =>
|
|
adamc@164
|
470 let
|
|
adamc@164
|
471 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc)
|
|
adamc@164
|
472 in
|
|
adamc@164
|
473 SOME (Env.declBinds env all, d)
|
|
adamc@164
|
474 end
|
|
adamc@109
|
475 | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s,
|
|
adamc@153
|
476 (L'.DVal (x, n, monoType env t, monoExp (env, St.empty) e, s), loc))
|
|
adamc@128
|
477 | L.DValRec vis =>
|
|
adamc@128
|
478 let
|
|
adamc@128
|
479 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
|
|
adamc@128
|
480 in
|
|
adamc@128
|
481 SOME (env,
|
|
adamc@153
|
482 (L'.DValRec (map (fn (x, n, t, e, s) => (x, n, monoType env t,
|
|
adamc@153
|
483 monoExp (env, St.empty) e, s)) vis), loc))
|
|
adamc@128
|
484 end
|
|
adamc@144
|
485 | L.DExport (ek, n) =>
|
|
adamc@115
|
486 let
|
|
adamc@120
|
487 val (_, t, _, s) = Env.lookupENamed env n
|
|
adamc@120
|
488
|
|
adamc@120
|
489 fun unwind (t, _) =
|
|
adamc@120
|
490 case t of
|
|
adamc@120
|
491 L.TFun (dom, ran) => dom :: unwind ran
|
|
adamc@120
|
492 | _ => []
|
|
adamc@120
|
493
|
|
adamc@120
|
494 val ts = map (monoType env) (unwind t)
|
|
adamc@115
|
495 in
|
|
adamc@144
|
496 SOME (env, (L'.DExport (ek, s, n, ts), loc))
|
|
adamc@115
|
497 end
|
|
adamc@25
|
498 end
|
|
adamc@25
|
499
|
|
adamc@25
|
500 fun monoize env ds =
|
|
adamc@25
|
501 let
|
|
adamc@25
|
502 val (_, ds) = List.foldl (fn (d, (env, ds)) =>
|
|
adamc@25
|
503 case monoDecl env d of
|
|
adamc@25
|
504 NONE => (env, ds)
|
|
adamc@25
|
505 | SOME (env, d) => (env, d :: ds)) (env, []) ds
|
|
adamc@25
|
506 in
|
|
adamc@25
|
507 rev ds
|
|
adamc@25
|
508 end
|
|
adamc@25
|
509
|
|
adamc@25
|
510 end
|
