Mercurial > urweb

comparison src/monoize.sml @ 179:3bbed533fbd2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Cases through monoize
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Aug 2008 10:48:36 -0400
parents eb3f9913bf31
children d11754ffe252
comparison
equal deleted inserted replaced
178:eb3f9913bf31 179:3bbed533fbd2
85 | L.CUnit => poly () 85 | L.CUnit => poly ()
86 end 86 end
87 87
88 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) 88 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
89 89
90 fun fooifyExp name env = 90 structure IM = IntBinaryMap
91
92 datatype foo_kind =
93 Attr
94 | Url
95
96 fun fk2s fk =
97 case fk of
98 Attr => "attr"
99 | Url => "url"
100
101 structure Fm :> sig
102 type t
103
104 val empty : int -> t
105
106 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
107 val enter : t -> t
108 val decls : t -> L'.decl list
109 end = struct
110
111 structure M = BinaryMapFn(struct
112 type ord_key = foo_kind
113 fun compare x =
114 case x of
115 (Attr, Attr) => EQUAL
116 | (Attr, _) => LESS
117 | (_, Attr) => GREATER
118
119 | (Url, Url) => EQUAL
120 end)
121
122 type t = {
123 count : int,
124 map : int IM.map M.map,
125 decls : L'.decl list
126 }
127
128 fun empty count = {
129 count = count,
130 map = M.empty,
131 decls = []
132 }
133
134 fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []}
135 fun decls ({decls, ...} : t) = decls
136
137 fun lookup (t as {count, map, decls}) k n thunk =
91 let 138 let
92 fun fooify (e, tAll as (t, loc)) = 139 val im = Option.getOpt (M.find (map, k), IM.empty)
140 in
141 case IM.find (im, n) of
142 NONE =>
143 let
144 val n' = count
145 val (d, {count, map, decls}) = thunk count {count = count + 1,
146 map = M.insert (map, k, IM.insert (im, n, n')),
147 decls = decls}
148 in
149 ({count = count,
150 map = map,
151 decls = d :: decls}, n')
152 end
153 | SOME n' => (t, n')
154 end
155
156 end
157
158
159 fun fooifyExp fk env =
160 let
161 fun fooify fm (e, tAll as (t, loc)) =
93 case #1 e of 162 case #1 e of
94 L'.EClosure (fnam, [(L'.ERecord [], _)]) => 163 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
95 let 164 let
96 val (_, _, _, s) = Env.lookupENamed env fnam 165 val (_, _, _, s) = Env.lookupENamed env fnam
97 in 166 in
98 (L'.EPrim (Prim.String s), loc) 167 ((L'.EPrim (Prim.String s), loc), fm)
99 end 168 end
100 | L'.EClosure (fnam, args) => 169 | L'.EClosure (fnam, args) =>
101 let 170 let
102 val (_, ft, _, s) = Env.lookupENamed env fnam 171 val (_, ft, _, s) = Env.lookupENamed env fnam
103 val ft = monoType env ft 172 val ft = monoType env ft
104 173
105 fun attrify (args, ft, e) = 174 fun attrify (args, ft, e, fm) =
106 case (args, ft) of 175 case (args, ft) of
107 ([], _) => e 176 ([], _) => (e, fm)
108 | (arg :: args, (L'.TFun (t, ft), _)) => 177 | (arg :: args, (L'.TFun (t, ft), _)) =>
109 attrify (args, ft, 178 let
110 (L'.EStrcat (e, 179 val (arg', fm) = fooify fm (arg, t)
111 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), 180 in
112 fooify (arg, t)), loc)), loc)) 181 attrify (args, ft,
182 (L'.EStrcat (e,
183 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
184 arg'), loc)), loc),
185 fm)
186 end
113 | _ => (E.errorAt loc "Type mismatch encoding attribute"; 187 | _ => (E.errorAt loc "Type mismatch encoding attribute";
114 e) 188 (e, fm))
115 in 189 in
116 attrify (args, ft, (L'.EPrim (Prim.String s), loc)) 190 attrify (args, ft, (L'.EPrim (Prim.String s), loc), fm)
117 end 191 end
118 | _ => 192 | _ =>
119 case t of 193 case t of
120 L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", name ^ "ifyString", [e]), loc) 194 L'.TFfi ("Basis", "string") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyString", [e]), loc), fm)
121 | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", name ^ "ifyInt", [e]), loc) 195 | L'.TFfi ("Basis", "int") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyInt", [e]), loc), fm)
122 | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", name ^ "ifyFloat", [e]), loc) 196 | L'.TFfi ("Basis", "float") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyFloat", [e]), loc), fm)
123 | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc) 197 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
124 198
125 | L'.TDatatype _ => (L'.EPrim (Prim.String "A"), loc) 199 | L'.TDatatype (i, _) =>
200 let
201 fun makeDecl n fm =
202 let
203 val (x, xncs) = Env.lookupDatatype env i
204
205 val (branches, fm) =
206 ListUtil.foldlMap
207 (fn ((x, n, to), fm) =>
208 case to of
209 NONE =>
210 (((L'.PCon (L'.PConVar n, NONE), loc),
211 (L'.EPrim (Prim.String x), loc)),
212 fm)
213 | SOME t =>
214 let
215 val (arg, fm) = fooify fm ((L'.ERel 0, loc),
216 monoType env t)
217 in
218 (((L'.PCon (L'.PConVar n, SOME (L'.PVar "a", loc)), loc),
219 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
220 arg), loc)),
221 fm)
222 end)
223 fm xncs
224
225 val dom = tAll
226 val ran = (L'.TFfi ("Basis", "string"), loc)
227 in
228 ((L'.DValRec [(fk2s fk ^ "ify_" ^ x,
229 n,
230 (L'.TFun (dom, ran), loc),
231 (L'.EAbs ("x",
232 dom,
233 ran,
234 (L'.ECase ((L'.ERel 0, loc),
235 branches,
236 ran), loc)), loc),
237 "")], loc),
238 fm)
239 end
240
241 val (fm, n) = Fm.lookup fm fk i makeDecl
242 in
243 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
244 end
126 245
127 | _ => (E.errorAt loc "Don't know how to encode attribute type"; 246 | _ => (E.errorAt loc "Don't know how to encode attribute type";
128 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; 247 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
129 dummyExp) 248 (dummyExp, fm))
130 in 249 in
131 fooify 250 fooify
132 end 251 end
133 252
134 val attrifyExp = fooifyExp "attr" 253 val attrifyExp = fooifyExp Attr
135 val urlifyExp = fooifyExp "url" 254 val urlifyExp = fooifyExp Url
136 255
137 datatype 'a failable_search = 256 datatype 'a failable_search =
138 Found of 'a 257 Found of 'a
139 | NotFound 258 | NotFound
140 | Error 259 | Error
171 | L.PVar x => (L'.PVar x, loc) 290 | L.PVar x => (L'.PVar x, loc)
172 | L.PPrim p => (L'.PPrim p, loc) 291 | L.PPrim p => (L'.PPrim p, loc)
173 | L.PCon (pc, po) => (L'.PCon (monoPatCon pc, Option.map monoPat po), loc) 292 | L.PCon (pc, po) => (L'.PCon (monoPatCon pc, Option.map monoPat po), loc)
174 | L.PRecord xps => (L'.PRecord (map (fn (x, p) => (x, monoPat p)) xps), loc) 293 | L.PRecord xps => (L'.PRecord (map (fn (x, p) => (x, monoPat p)) xps), loc)
175 294
176 fun monoExp (env, st) (all as (e, loc)) = 295 fun monoExp (env, st, fm) (all as (e, loc)) =
177 let 296 let
178 fun poly () = 297 fun poly () =
179 (E.errorAt loc "Unsupported expression"; 298 (E.errorAt loc "Unsupported expression";
180 Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; 299 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
181 dummyExp) 300 (dummyExp, fm))
182 in 301 in
183 case e of 302 case e of
184 L.EPrim p => (L'.EPrim p, loc) 303 L.EPrim p => ((L'.EPrim p, loc), fm)
185 | L.ERel n => (L'.ERel n, loc) 304 | L.ERel n => ((L'.ERel n, loc), fm)
186 | L.ENamed n => (L'.ENamed n, loc) 305 | L.ENamed n => ((L'.ENamed n, loc), fm)
187 | L.ECon (n, eo) => (L'.ECon (n, Option.map (monoExp (env, st)) eo), loc) 306 | L.ECon (n, eo) =>
188 | L.EFfi mx => (L'.EFfi mx, loc) 307 let
189 | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp (env, st)) es), loc) 308 val (eo, fm) =
309 case eo of
310 NONE => (NONE, fm)
311 | SOME e =>
312 let
313 val (e, fm) = monoExp (env, st, fm) e
314 in
315 (SOME e, fm)
316 end
317 in
318 ((L'.ECon (n, eo), loc), fm)
319 end
320 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
321 | L.EFfiApp (m, x, es) =>
322 let
323 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
324 in
325 ((L'.EFfiApp (m, x, es), loc), fm)
326 end
190 327
191 | L.EApp ( 328 | L.EApp (
192 (L.ECApp ( 329 (L.ECApp (
193 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), 330 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
194 _), _), 331 _), _),
195 se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp (env, st) se]), loc) 332 se) =>
333 let
334 val (se, fm) = monoExp (env, st, fm) se
335 in
336 ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm)
337 end
338
196 | L.EApp ( 339 | L.EApp (
197 (L.EApp ( 340 (L.EApp (
198 (L.ECApp ( 341 (L.ECApp (
199 (L.ECApp ( 342 (L.ECApp (
200 (L.ECApp ( 343 (L.ECApp (
203 _), _), _), 346 _), _), _),
204 _), _), 347 _), _),
205 _), _), 348 _), _),
206 _), _), 349 _), _),
207 xml1), _), 350 xml1), _),
208 xml2) => (L'.EStrcat (monoExp (env, st) xml1, monoExp (env, st) xml2), loc) 351 xml2) =>
352 let
353 val (xml1, fm) = monoExp (env, st, fm) xml1
354 val (xml2, fm) = monoExp (env, st, fm) xml2
355 in
356 ((L'.EStrcat (xml1, xml2), loc), fm)
357 end
209 358
210 | L.EApp ( 359 | L.EApp (
211 (L.EApp ( 360 (L.EApp (
212 (L.EApp ( 361 (L.EApp (
213 (L.ECApp ( 362 (L.ECApp (
244 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; 393 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
245 ("", [])) 394 ("", []))
246 395
247 val (tag, targs) = getTag tag 396 val (tag, targs) = getTag tag
248 397
249 val attrs = monoExp (env, st) attrs 398 val (attrs, fm) = monoExp (env, st, fm) attrs
250 399
251 fun tagStart tag = 400 fun tagStart tag =
252 case #1 attrs of 401 case #1 attrs of
253 L'.ERecord xes => 402 L'.ERecord xes =>
254 let 403 let
256 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0))) 405 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0)))
257 ^ String.extract (s, 1, NONE) 406 ^ String.extract (s, 1, NONE)
258 407
259 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) 408 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
260 in 409 in
261 foldl (fn ((x, e, t), s) => 410 foldl (fn ((x, e, t), (s, fm)) =>
262 let 411 let
263 val xp = " " ^ lowercaseFirst x ^ "=\"" 412 val xp = " " ^ lowercaseFirst x ^ "=\""
264 413
265 val fooify = 414 val fooify =
266 case x of 415 case x of
267 "Link" => urlifyExp 416 "Link" => urlifyExp
268 | "Action" => urlifyExp 417 | "Action" => urlifyExp
269 | _ => attrifyExp 418 | _ => attrifyExp
419
420 val (e, fm) = fooify env fm (e, t)
270 in 421 in
271 (L'.EStrcat (s, 422 ((L'.EStrcat (s,
272 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), 423 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
273 (L'.EStrcat (fooify env (e, t), 424 (L'.EStrcat (e,
274 (L'.EPrim (Prim.String "\""), 425 (L'.EPrim (Prim.String "\""),
275 loc)), 426 loc)),
276 loc)), 427 loc)),
277 loc)), loc) 428 loc)), loc),
429 fm)
278 end) 430 end)
279 s xes 431 (s, fm) xes
280 end 432 end
281 | _ => raise Fail "Non-record attributes!" 433 | _ => raise Fail "Non-record attributes!"
282 434
283 fun input typ = 435 fun input typ =
284 case targs of 436 case targs of
285 [_, (L.CName name, _)] => 437 [_, (L.CName name, _)] =>
286 (L'.EStrcat (tagStart "input", 438 let
287 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")), 439 val (ts, fm) = tagStart "input"
288 loc)), loc) 440 in
441 ((L'.EStrcat (ts,
442 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
443 loc)), loc), fm)
444 end
289 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 445 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
290 raise Fail "No name passed to input tag") 446 raise Fail "No name passed to input tag")
291 447
292 fun normal (tag, extra) = 448 fun normal (tag, extra) =
293 let 449 let
294 val tagStart = tagStart tag 450 val (tagStart, fm) = tagStart tag
295 val tagStart = case extra of 451 val tagStart = case extra of
296 NONE => tagStart 452 NONE => tagStart
297 | SOME extra => (L'.EStrcat (tagStart, extra), loc) 453 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
298 454
299 fun normal () = 455 fun normal () =
300 (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), 456 let
301 (L'.EStrcat (monoExp (env, st) xml, 457 val (xml, fm) = monoExp (env, st, fm) xml
302 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), 458 in
303 loc)), loc)), 459 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
304 loc) 460 (L'.EStrcat (xml,
461 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
462 loc)), loc)),
463 loc),
464 fm)
465 end
305 in 466 in
306 case xml of 467 case xml of
307 (L.EApp ((L.ECApp ( 468 (L.EApp ((L.ECApp (
308 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), 469 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
309 _), _), 470 _), _),
310 _), _), 471 _), _),
311 (L.EPrim (Prim.String s), _)), _) => 472 (L.EPrim (Prim.String s), _)), _) =>
312 if CharVector.all Char.isSpace s then 473 if CharVector.all Char.isSpace s then
313 (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc) 474 ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc), fm)
314 else 475 else
315 normal () 476 normal ()
316 | _ => normal () 477 | _ => normal ()
317 end 478 end
318 in 479 in
319 case tag of 480 case tag of
320 "submit" => (L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc) 481 "submit" => ((L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc), fm)
321 482
322 | "textbox" => 483 | "textbox" =>
323 (case targs of 484 (case targs of
324 [_, (L.CName name, _)] => 485 [_, (L.CName name, _)] =>
325 (L'.EStrcat (tagStart "input", 486 let
326 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")), 487 val (ts, fm) = tagStart "input"
327 loc)), loc) 488 in
489 ((L'.EStrcat (ts,
490 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
491 loc)), loc), fm)
492 end
328 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 493 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
329 raise Fail "No name passed to textarea tag")) 494 raise Fail "No name passed to textarea tag"))
330 | "password" => input "password" 495 | "password" => input "password"
331 | "ltextarea" => 496 | "ltextarea" =>
332 (case targs of 497 (case targs of
333 [_, (L.CName name, _)] => 498 [_, (L.CName name, _)] =>
334 (L'.EStrcat ((L'.EStrcat (tagStart "textarea", 499 let
335 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), 500 val (ts, fm) = tagStart "textarea"
336 (L'.EStrcat (monoExp (env, st) xml, 501 val (xml, fm) = monoExp (env, st, fm) xml
337 (L'.EPrim (Prim.String "</textarea>"), 502 in
338 loc)), loc)), 503 ((L'.EStrcat ((L'.EStrcat (ts,
339 loc) 504 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
505 (L'.EStrcat (xml,
506 (L'.EPrim (Prim.String "</textarea>"),
507 loc)), loc)),
508 loc), fm)
509 end
340 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 510 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
341 raise Fail "No name passed to ltextarea tag")) 511 raise Fail "No name passed to ltextarea tag"))
342 512
343 | "radio" => 513 | "radio" =>
344 (case targs of 514 (case targs of
345 [_, (L.CName name, _)] => 515 [_, (L.CName name, _)] =>
346 monoExp (env, St.setRadioGroup (st, name)) xml 516 monoExp (env, St.setRadioGroup (st, name), fm) xml
347 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 517 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
348 raise Fail "No name passed to radio tag")) 518 raise Fail "No name passed to radio tag"))
349 | "radioOption" => 519 | "radioOption" =>
350 (case St.radioGroup st of 520 (case St.radioGroup st of
351 NONE => raise Fail "No name for radioGroup" 521 NONE => raise Fail "No name for radioGroup"
354 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc))) 524 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
355 525
356 | "lselect" => 526 | "lselect" =>
357 (case targs of 527 (case targs of
358 [_, (L.CName name, _)] => 528 [_, (L.CName name, _)] =>
359 (L'.EStrcat ((L'.EStrcat (tagStart "select", 529 let
360 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), 530 val (ts, fm) = tagStart "select"
361 (L'.EStrcat (monoExp (env, st) xml, 531 val (xml, fm) = monoExp (env, st, fm) xml
362 (L'.EPrim (Prim.String "</select>"), 532 in
363 loc)), loc)), 533 ((L'.EStrcat ((L'.EStrcat (ts,
364 loc) 534 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
535 (L'.EStrcat (xml,
536 (L'.EPrim (Prim.String "</select>"),
537 loc)), loc)),
538 loc),
539 fm)
540 end
365 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 541 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
366 raise Fail "No name passed to lselect tag")) 542 raise Fail "No name passed to lselect tag"))
367 543
368 | "loption" => normal ("option", NONE) 544 | "loption" => normal ("option", NONE)
369 545
428 NotFound => raise Fail "No submit found" 604 NotFound => raise Fail "No submit found"
429 | Error => raise Fail "Not ready for multi-submit lforms yet" 605 | Error => raise Fail "Not ready for multi-submit lforms yet"
430 | Found et => et 606 | Found et => et
431 607
432 val actionT = monoType env actionT 608 val actionT = monoType env actionT
433 val action = monoExp (env, st) action 609 val (action, fm) = monoExp (env, st, fm) action
434 in 610 val (action, fm) = urlifyExp env fm (action, actionT)
435 (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc), 611 val (xml, fm) = monoExp (env, st, fm) xml
436 (L'.EStrcat (urlifyExp env (action, actionT), 612 in
437 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc), 613 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
438 (L'.EStrcat (monoExp (env, st) xml, 614 (L'.EStrcat (action,
439 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc) 615 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
616 (L'.EStrcat (xml,
617 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
618 fm)
440 end 619 end
441 620
442 | L.EApp ((L.ECApp ( 621 | L.EApp ((L.ECApp (
443 (L.ECApp ( 622 (L.ECApp (
444 (L.ECApp ( 623 (L.ECApp (
445 (L.ECApp ( 624 (L.ECApp (
446 (L.EFfi ("Basis", "useMore"), _), _), _), 625 (L.EFfi ("Basis", "useMore"), _), _), _),
447 _), _), 626 _), _),
448 _), _), 627 _), _),
449 _), _), 628 _), _),
450 xml) => monoExp (env, st) xml 629 xml) => monoExp (env, st, fm) xml
451 630
452 631 | L.EApp (e1, e2) =>
453 | L.EApp (e1, e2) => (L'.EApp (monoExp (env, st) e1, monoExp (env, st) e2), loc) 632 let
633 val (e1, fm) = monoExp (env, st, fm) e1
634 val (e2, fm) = monoExp (env, st, fm) e2
635 in
636 ((L'.EApp (e1, e2), loc), fm)
637 end
454 | L.EAbs (x, dom, ran, e) => 638 | L.EAbs (x, dom, ran, e) =>
455 (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom, st) e), loc) 639 let
640 val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
641 in
642 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
643 end
456 | L.ECApp _ => poly () 644 | L.ECApp _ => poly ()
457 | L.ECAbs _ => poly () 645 | L.ECAbs _ => poly ()
458 646
459 | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x, 647 | L.ERecord xes =>
460 monoExp (env, st) e, 648 let
461 monoType env t)) xes), loc) 649 val (xes, fm) = ListUtil.foldlMap
462 | L.EField (e, x, _) => (L'.EField (monoExp (env, st) e, monoName env x), loc) 650 (fn ((x, e, t), fm) =>
651 let
652 val (e, fm) = monoExp (env, st, fm) e
653 in
654 ((monoName env x,
655 e,
656 monoType env t), fm)
657 end) fm xes
658 in
659 ((L'.ERecord xes, loc), fm)
660 end
661 | L.EField (e, x, _) =>
662 let
663 val (e, fm) = monoExp (env, st, fm) e
664 in
665 ((L'.EField (e, monoName env x), loc), fm)
666 end
463 | L.ECut _ => poly () 667 | L.ECut _ => poly ()
464 | L.EFold _ => poly () 668 | L.EFold _ => poly ()
465 669
466 | L.ECase (e, pes, t) => (L'.ECase (monoExp (env, st) e, 670 | L.ECase (e, pes, t) =>
467 map (fn (p, e) => (monoPat p, monoExp (env, st) e)) pes, 671 let
468 monoType env t), loc) 672 val (e, fm) = monoExp (env, st, fm) e
469 673 val (pes, fm) = ListUtil.foldlMap
470 | L.EWrite e => (L'.EWrite (monoExp (env, st) e), loc) 674 (fn ((p, e), fm) =>
471 675 let
472 | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp (env, st)) es), loc) 676 val (e, fm) = monoExp (env, st, fm) e
677 in
678 ((monoPat p, e), fm)
679 end) fm pes
680 in
681 ((L'.ECase (e, pes, monoType env t), loc), fm)
682 end
683
684 | L.EWrite e =>
685 let
686 val (e, fm) = monoExp (env, st, fm) e
687 in
688 ((L'.EWrite e, loc), fm)
689 end
690
691 | L.EClosure (n, es) =>
692 let
693 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
694 monoExp (env, st, fm) e)
695 fm es
696 in
697 ((L'.EClosure (n, es), loc), fm)
698 end
473 end 699 end
474 700
475 fun monoDecl env (all as (d, loc)) = 701 fun monoDecl (env, fm) (all as (d, loc)) =
476 let 702 let
477 fun poly () = 703 fun poly () =
478 (E.errorAt loc "Unsupported declaration"; 704 (E.errorAt loc "Unsupported declaration";
479 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)]; 705 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
480 NONE) 706 NONE)
483 L.DCon _ => NONE 709 L.DCon _ => NONE
484 | L.DDatatype (x, n, xncs) => 710 | L.DDatatype (x, n, xncs) =>
485 let 711 let
486 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc) 712 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc)
487 in 713 in
488 SOME (Env.declBinds env all, d) 714 SOME (Env.declBinds env all, fm, d)
489 end 715 end
490 | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s, 716 | L.DVal (x, n, t, e, s) =>
491 (L'.DVal (x, n, monoType env t, monoExp (env, St.empty) e, s), loc)) 717 let
718 val (e, fm) = monoExp (env, St.empty, fm) e
719 in
720 SOME (Env.pushENamed env x n t NONE s,
721 fm,
722 (L'.DVal (x, n, monoType env t, e, s), loc))
723 end
492 | L.DValRec vis => 724 | L.DValRec vis =>
493 let 725 let
494 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis 726 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
727
728 val (vis, fm) = ListUtil.foldlMap
729 (fn ((x, n, t, e, s), fm) =>
730 let
731 val (e, fm) = monoExp (env, St.empty, fm) e
732 in
733 ((x, n, monoType env t, e, s), fm)
734 end)
735 fm vis
495 in 736 in
496 SOME (env, 737 SOME (env,
497 (L'.DValRec (map (fn (x, n, t, e, s) => (x, n, monoType env t, 738 fm,
498 monoExp (env, St.empty) e, s)) vis), loc)) 739 (L'.DValRec vis, loc))
499 end 740 end
500 | L.DExport (ek, n) => 741 | L.DExport (ek, n) =>
501 let 742 let
502 val (_, t, _, s) = Env.lookupENamed env n 743 val (_, t, _, s) = Env.lookupENamed env n
503 744
506 L.TFun (dom, ran) => dom :: unwind ran 747 L.TFun (dom, ran) => dom :: unwind ran
507 | _ => [] 748 | _ => []
508 749
509 val ts = map (monoType env) (unwind t) 750 val ts = map (monoType env) (unwind t)
510 in 751 in
511 SOME (env, (L'.DExport (ek, s, n, ts), loc)) 752 SOME (env, fm, (L'.DExport (ek, s, n, ts), loc))
512 end 753 end
513 end 754 end
514 755
515 fun monoize env ds = 756 fun monoize env ds =
516 let 757 let
517 val (_, ds) = List.foldl (fn (d, (env, ds)) => 758 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
518 case monoDecl env d of 759 case monoDecl (env, fm) d of
519 NONE => (env, ds) 760 NONE => (env, fm, ds)
520 | SOME (env, d) => (env, d :: ds)) (env, []) ds 761 | SOME (env, fm, d) =>
762 (env,
763 Fm.enter fm,
764 d :: Fm.decls fm @ ds))
765 (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds
521 in 766 in
522 rev ds 767 rev ds
523 end 768 end
524 769
525 end 770 end