Mercurial > urweb
comparison src/monoize.sml @ 1730:02533f681ad2
Fix urlification of recursive polymorphic variants
author | Adam Chlipala <adam@chlipala.net> |
---|---|
date | Sat, 28 Apr 2012 11:35:12 -0400 |
parents | 95d3b4f26f59 |
children | d2b3fada532e |
comparison
equal
deleted
inserted
replaced
1729:6817ddd6cf1f | 1730:02533f681ad2 |
---|---|
355 fun fk2s fk = | 355 fun fk2s fk = |
356 case fk of | 356 case fk of |
357 Attr => "attr" | 357 Attr => "attr" |
358 | Url => "url" | 358 | Url => "url" |
359 | 359 |
360 type vr = string * int * L'.typ * L'.exp * string | |
361 | |
360 structure Fm :> sig | 362 structure Fm :> sig |
361 type t | 363 type t |
362 | 364 |
363 val empty : int -> t | 365 val empty : int -> t |
364 | 366 |
365 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int | 367 val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int |
366 val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> L'.decl * t) -> t * int | 368 val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> vr * t) -> t * int |
367 val enter : t -> t | 369 val enter : t -> t |
368 val decls : t -> L'.decl list | 370 val decls : t -> L'.decl list |
369 | 371 |
370 val freshName : t -> int * t | 372 val freshName : t -> int * t |
371 end = struct | 373 end = struct |
388 | 390 |
389 type t = { | 391 type t = { |
390 count : int, | 392 count : int, |
391 map : int IM.map M.map, | 393 map : int IM.map M.map, |
392 listMap : int TM.map M.map, | 394 listMap : int TM.map M.map, |
393 decls : L'.decl list | 395 decls : vr list |
394 } | 396 } |
395 | 397 |
396 fun empty count = { | 398 fun empty count = { |
397 count = count, | 399 count = count, |
398 map = M.empty, | 400 map = M.empty, |
416 let | 418 let |
417 val (next, count) = chooseNext count | 419 val (next, count) = chooseNext count |
418 in | 420 in |
419 (next, {count = count , map = map, listMap = listMap, decls = decls}) | 421 (next, {count = count , map = map, listMap = listMap, decls = decls}) |
420 end | 422 end |
421 fun decls ({decls, ...} : t) = decls | 423 fun decls ({decls, ...} : t) = |
424 case decls of | |
425 [] => [] | |
426 | _ => [(L'.DValRec decls, ErrorMsg.dummySpan)] | |
422 | 427 |
423 fun lookup (t as {count, map, listMap, decls}) k n thunk = | 428 fun lookup (t as {count, map, listMap, decls}) k n thunk = |
424 let | 429 let |
425 val im = Option.getOpt (M.find (map, k), IM.empty) | 430 val im = Option.getOpt (M.find (map, k), IM.empty) |
426 in | 431 in |
565 fm xncs | 570 fm xncs |
566 | 571 |
567 val dom = tAll | 572 val dom = tAll |
568 val ran = (L'.TFfi ("Basis", "string"), loc) | 573 val ran = (L'.TFfi ("Basis", "string"), loc) |
569 in | 574 in |
570 ((L'.DValRec [(fk2s fk ^ "ify_" ^ x, | 575 ((fk2s fk ^ "ify_" ^ x, |
571 n, | 576 n, |
572 (L'.TFun (dom, ran), loc), | 577 (L'.TFun (dom, ran), loc), |
573 (L'.EAbs ("x", | 578 (L'.EAbs ("x", |
574 dom, | 579 dom, |
575 ran, | 580 ran, |
576 (L'.ECase ((L'.ERel 0, loc), | 581 (L'.ECase ((L'.ERel 0, loc), |
577 branches, | 582 branches, |
578 {disc = dom, | 583 {disc = dom, |
579 result = ran}), loc)), loc), | 584 result = ran}), loc)), loc), |
580 "")], loc), | 585 ""), |
581 fm) | 586 fm) |
582 end | 587 end |
583 | 588 |
584 val (fm, n) = Fm.lookup fm fk i makeDecl | 589 val (fm, n) = Fm.lookup fm fk i makeDecl |
585 in | 590 in |
616 arg), loc))] | 621 arg), loc))] |
617 | 622 |
618 val dom = tAll | 623 val dom = tAll |
619 val ran = (L'.TFfi ("Basis", "string"), loc) | 624 val ran = (L'.TFfi ("Basis", "string"), loc) |
620 in | 625 in |
621 ((L'.DValRec [(fk2s fk ^ "ify_list", | 626 ((fk2s fk ^ "ify_list", |
622 n, | 627 n, |
623 (L'.TFun (dom, ran), loc), | 628 (L'.TFun (dom, ran), loc), |
624 (L'.EAbs ("x", | 629 (L'.EAbs ("x", |
625 dom, | 630 dom, |
626 ran, | 631 ran, |
627 (L'.ECase ((L'.ERel 0, loc), | 632 (L'.ECase ((L'.ERel 0, loc), |
628 branches, | 633 branches, |
629 {disc = dom, | 634 {disc = dom, |
630 result = ran}), loc)), loc), | 635 result = ran}), loc)), loc), |
631 "")], loc), | 636 ""), |
632 fm) | 637 fm) |
633 end | 638 end |
634 | 639 |
635 val (fm, n) = Fm.lookupList fm fk t makeDecl | 640 val (fm, n) = Fm.lookupList fm fk t makeDecl |
636 in | 641 in |