Mercurial > urweb

comparison src/monoize.sml @ 1730:02533f681ad2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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