Mercurial > urweb

comparison src/monoize.sml @ 758:8323c1beef2e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Subforms type-checks; lists urlified and unurlified
author Adam Chlipala <adamc@hcoop.net>
date Thu, 30 Apr 2009 11:48:56 -0400
parents fa2019a63ea4
children 16b34dc2e29c
comparison
equal deleted inserted replaced
757:fa2019a63ea4 758:8323c1beef2e
272 type t 272 type t
273 273
274 val empty : int -> t 274 val empty : int -> t
275 275
276 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int 276 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
277 val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> L'.decl * t) -> t * int
277 val enter : t -> t 278 val enter : t -> t
278 val decls : t -> L'.decl list 279 val decls : t -> L'.decl list
279 280
280 val freshName : t -> int * t 281 val freshName : t -> int * t
281 end = struct 282 end = struct
289 | (_, Attr) => GREATER 290 | (_, Attr) => GREATER
290 291
291 | (Url, Url) => EQUAL 292 | (Url, Url) => EQUAL
292 end) 293 end)
293 294
295 structure TM = BinaryMapFn(struct
296 type ord_key = L'.typ
297 val compare = MonoUtil.Typ.compare
298 end)
299
294 type t = { 300 type t = {
295 count : int, 301 count : int,
296 map : int IM.map M.map, 302 map : int IM.map M.map,
303 listMap : int TM.map M.map,
297 decls : L'.decl list 304 decls : L'.decl list
298 } 305 }
299 306
300 fun empty count = { 307 fun empty count = {
301 count = count, 308 count = count,
302 map = M.empty, 309 map = M.empty,
310 listMap = M.empty,
303 decls = [] 311 decls = []
304 } 312 }
305 313
306 fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []} 314 fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
307 fun freshName {count, map, decls} = (count, {count = count + 1, map = map, decls = decls}) 315 fun freshName {count, map, listMap, decls} = (count, {count = count + 1, map = map, listMap = listMap, decls = decls})
308 fun decls ({decls, ...} : t) = decls 316 fun decls ({decls, ...} : t) = decls
309 317
310 fun lookup (t as {count, map, decls}) k n thunk = 318 fun lookup (t as {count, map, listMap, decls}) k n thunk =
311 let 319 let
312 val im = Option.getOpt (M.find (map, k), IM.empty) 320 val im = Option.getOpt (M.find (map, k), IM.empty)
313 in 321 in
314 case IM.find (im, n) of 322 case IM.find (im, n) of
315 NONE => 323 NONE =>
316 let 324 let
317 val n' = count 325 val n' = count
318 val (d, {count, map, decls}) = thunk count {count = count + 1, 326 val (d, {count, map, listMap, decls}) =
319 map = M.insert (map, k, IM.insert (im, n, n')), 327 thunk count {count = count + 1,
320 decls = decls} 328 map = M.insert (map, k, IM.insert (im, n, n')),
329 listMap = listMap,
330 decls = decls}
321 in 331 in
322 ({count = count, 332 ({count = count,
323 map = map, 333 map = map,
334 listMap = listMap,
335 decls = d :: decls}, n')
336 end
337 | SOME n' => (t, n')
338 end
339
340 fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
341 let
342 val tm = Option.getOpt (M.find (listMap, k), TM.empty)
343 in
344 case TM.find (tm, tp) of
345 NONE =>
346 let
347 val n' = count
348 val (d, {count, map, listMap, decls}) =
349 thunk count {count = count + 1,
350 map = map,
351 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
352 decls = decls}
353 in
354 ({count = count,
355 map = map,
356 listMap = listMap,
324 decls = d :: decls}, n') 357 decls = d :: decls}, n')
325 end 358 end
326 | SOME n' => (t, n') 359 | SOME n' => (t, n')
327 end 360 end
328 361
448 (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc), 481 (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc),
449 body), loc))], 482 body), loc))],
450 {disc = tAll, 483 {disc = tAll,
451 result = (L'.TFfi ("Basis", "string"), loc)}), loc), 484 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
452 fm) 485 fm)
486 end
487
488 | L'.TList t =>
489 let
490 fun makeDecl n fm =
491 let
492 val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc)
493 val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt)
494
495 val branches = [((L'.PNone rt, loc),
496 (L'.EPrim (Prim.String "Nil"), loc)),
497 ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc),
498 (L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc),
499 arg), loc))]
500
501 val dom = tAll
502 val ran = (L'.TFfi ("Basis", "string"), loc)
503 in
504 ((L'.DValRec [(fk2s fk ^ "ify_list",
505 n,
506 (L'.TFun (dom, ran), loc),
507 (L'.EAbs ("x",
508 dom,
509 ran,
510 (L'.ECase ((L'.ERel 0, loc),
511 branches,
512 {disc = dom,
513 result = ran}), loc)), loc),
514 "")], loc),
515 fm)
516 end
517
518 val (fm, n) = Fm.lookupList fm fk t makeDecl
519 in
520 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
453 end 521 end
454 522
455 | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; 523 | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
456 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; 524 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
457 (dummyExp, fm)) 525 (dummyExp, fm))
2716 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\">")), loc)]), 2784 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\">")), loc)]),
2717 loc), 2785 loc),
2718 fm) 2786 fm)
2719 end 2787 end
2720 2788
2789 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
2790 (L.EFfi ("Basis", "subforms"), _), _), _), _),
2791 _), _), _), (L.CName nm, loc)) =>
2792 let
2793 val s = (L'.TFfi ("Basis", "string"), loc)
2794 in
2795 ((L'.EAbs ("xml", s, s,
2796 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".s\" value=\""
2797 ^ nm ^ "\">")), loc),
2798 (L'.ERel 0, loc),
2799 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\">")), loc)]),
2800 loc),
2801 fm)
2802 end
2803
2804 | L.ECApp ((L.ECApp (
2805 (L.EFfi ("Basis", "entry"), _), _), _), _) =>
2806 let
2807 val s = (L'.TFfi ("Basis", "string"), loc)
2808 in
2809 ((L'.EAbs ("xml", s, s,
2810 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".i\" value=\"1\">")), loc),
2811 (L'.ERel 0, loc),
2812 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\">")), loc)]),
2813 loc),
2814 fm)
2815 end
2816
2721 | L.EApp ((L.ECApp ( 2817 | L.EApp ((L.ECApp (
2722 (L.ECApp ( 2818 (L.ECApp (
2723 (L.ECApp ( 2819 (L.ECApp (
2724 (L.ECApp ( 2820 (L.ECApp (
2725 (L.EFfi ("Basis", "useMore"), _), _), _), 2821 (L.EFfi ("Basis", "useMore"), _), _), _),