Mercurial > urweb

comparison src/monoize.sml @ 757:fa2019a63ea4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Basis.list
author Adam Chlipala <adamc@hcoop.net>
date Thu, 30 Apr 2009 11:07:29 -0400
parents 8ce31c052dce
children 8323c1beef2e
comparison
equal deleted inserted replaced
756:8ce31c052dce 757:fa2019a63ea4
92 (L'.TRecord (map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs), loc) 92 (L'.TRecord (map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs), loc)
93 | L.TRecord _ => poly () 93 | L.TRecord _ => poly ()
94 94
95 | L.CApp ((L.CFfi ("Basis", "option"), _), t) => 95 | L.CApp ((L.CFfi ("Basis", "option"), _), t) =>
96 (L'.TOption (mt env dtmap t), loc) 96 (L'.TOption (mt env dtmap t), loc)
97 | L.CApp ((L.CFfi ("Basis", "list"), _), t) =>
98 (L'.TList (mt env dtmap t), loc)
97 99
98 | L.CApp ((L.CFfi ("Basis", "eq"), _), t) => 100 | L.CApp ((L.CFfi ("Basis", "eq"), _), t) =>
99 let 101 let
100 val t = mt env dtmap t 102 val t = mt env dtmap t
101 in 103 in
492 | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con, 494 | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
493 arg = Option.map (monoType env) arg} 495 arg = Option.map (monoType env) arg}
494 496
495 val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan) 497 val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
496 498
499
500 fun listify t = (L'.TRecord [("1", t), ("2", (L'.TList t, #2 t))], #2 t)
501
497 fun monoPat env (all as (p, loc)) = 502 fun monoPat env (all as (p, loc)) =
498 let 503 let
499 fun poly () = 504 fun poly () =
500 (E.errorAt loc "Unsupported pattern"; 505 (E.errorAt loc "Unsupported pattern";
501 Print.eprefaces' [("Pattern", CorePrint.p_pat env all)]; 506 Print.eprefaces' [("Pattern", CorePrint.p_pat env all)];
504 case p of 509 case p of
505 L.PWild => (L'.PWild, loc) 510 L.PWild => (L'.PWild, loc)
506 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) 511 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
507 | L.PPrim p => (L'.PPrim p, loc) 512 | L.PPrim p => (L'.PPrim p, loc)
508 | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc) 513 | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
514 | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
515 (L'.PNone (listify (monoType env t)), loc)
516 | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME p) =>
517 (L'.PSome (listify (monoType env t), monoPat env p), loc)
509 | L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc) 518 | L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc)
510 | L.PCon (L.Option, _, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc) 519 | L.PCon (L.Option, pc, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc)
511 | L.PCon _ => poly () 520 | L.PCon _ => poly ()
512 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc) 521 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
513 end 522 end
514 523
515 fun strcat loc es = 524 fun strcat loc es =
610 in 619 in
611 (SOME e, fm) 620 (SOME e, fm)
612 end 621 end
613 in 622 in
614 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm) 623 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
624 end
625 | L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) =>
626 ((L'.ENone (listify (monoType env t)), loc), fm)
627 | L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME e) =>
628 let
629 val (e, fm) = monoExp (env, st, fm) e
630 in
631 ((L'.ESome (listify (monoType env t), e), loc), fm)
615 end 632 end
616 | L.ECon (L.Option, _, [t], NONE) => 633 | L.ECon (L.Option, _, [t], NONE) =>
617 ((L'.ENone (monoType env t), loc), fm) 634 ((L'.ENone (monoType env t), loc), fm)
618 | L.ECon (L.Option, _, [t], SOME e) => 635 | L.ECon (L.Option, _, [t], SOME e) =>
619 let 636 let
2890 val env' = Env.declBinds env all 2907 val env' = Env.declBinds env all
2891 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc) 2908 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc)
2892 in 2909 in
2893 SOME (env', fm, [d]) 2910 SOME (env', fm, [d])
2894 end 2911 end
2912 | L.DDatatype ("list", n, [_], [("Nil", _, NONE),
2913 ("Cons", _, SOME (L.TRecord (L.CRecord (_,
2914 [((L.CName "1", _),
2915 (L.CRel 0, _)),
2916 ((L.CName "2", _),
2917 (L.CApp ((L.CNamed n', _),
2918 (L.CRel 0, _)),
2919 _))]), _), _))]) =>
2920 if n = n' then
2921 NONE
2922 else
2923 poly ()
2895 | L.DDatatype _ => poly () 2924 | L.DDatatype _ => poly ()
2896 | L.DVal (x, n, t, e, s) => 2925 | L.DVal (x, n, t, e, s) =>
2897 let 2926 let
2898 val (e, fm) = monoExp (env, St.empty, fm) e 2927 val (e, fm) = monoExp (env, St.empty, fm) e
2899 in 2928 in