Mercurial > urweb

comparison src/monoize.sml @ 192:9bbf4d383381

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Parametrized datatypes through corify
author Adam Chlipala <adamc@hcoop.net>
date Fri, 08 Aug 2008 10:59:06 -0400
parents 3eb53c957d10
children 8a70e2919e86
comparison
equal deleted inserted replaced
191:aa54250f58ac 192:9bbf4d383381
65 (L'.TFfi ("Basis", "string"), loc) 65 (L'.TFfi ("Basis", "string"), loc)
66 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => 66 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
67 (L'.TFfi ("Basis", "string"), loc) 67 (L'.TFfi ("Basis", "string"), loc)
68 68
69 | L.CRel _ => poly () 69 | L.CRel _ => poly ()
70 | L.CNamed n => 70 | L.CNamed n => raise Fail "Monoize CNamed"
71 let 71 (*let
72 val (_, xncs) = Env.lookupDatatype env n 72 val (_, xncs) = Env.lookupDatatype env n
73 73
74 val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs 74 val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs
75 in 75 in
76 (L'.TDatatype (MonoUtil.classifyDatatype xncs, n, xncs), loc) 76 (L'.TDatatype (MonoUtil.classifyDatatype xncs, n, xncs), loc)
77 end 77 end*)
78 | L.CFfi mx => (L'.TFfi mx, loc) 78 | L.CFfi mx => (L'.TFfi mx, loc)
79 | L.CApp _ => poly () 79 | L.CApp _ => poly ()
80 | L.CAbs _ => poly () 80 | L.CAbs _ => poly ()
81 81
82 | L.CName _ => poly () 82 | L.CName _ => poly ()
204 204
205 | L'.TDatatype (dk, i, _) => 205 | L'.TDatatype (dk, i, _) =>
206 let 206 let
207 fun makeDecl n fm = 207 fun makeDecl n fm =
208 let 208 let
209 val (x, xncs) = Env.lookupDatatype env i 209 val (x, xncs) = raise Fail "Monoize TDataype" (*Env.lookupDatatype env i*)
210 210
211 val (branches, fm) = 211 val (branches, fm) =
212 ListUtil.foldlMap 212 ListUtil.foldlMap
213 (fn ((x, n, to), fm) => 213 (fn ((x, n, to), fm) =>
214 case to of 214 case to of
295 fun monoPat env (p, loc) = 295 fun monoPat env (p, loc) =
296 case p of 296 case p of
297 L.PWild => (L'.PWild, loc) 297 L.PWild => (L'.PWild, loc)
298 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) 298 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
299 | L.PPrim p => (L'.PPrim p, loc) 299 | L.PPrim p => (L'.PPrim p, loc)
300 | L.PCon (dk, pc, po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc) 300 | L.PCon (dk, pc, _, po) => raise Fail "Monoize PCon" (*(L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)*)
301 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc) 301 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
302 302
303 fun monoExp (env, st, fm) (all as (e, loc)) = 303 fun monoExp (env, st, fm) (all as (e, loc)) =
304 let 304 let
305 fun poly () = 305 fun poly () =
309 in 309 in
310 case e of 310 case e of
311 L.EPrim p => ((L'.EPrim p, loc), fm) 311 L.EPrim p => ((L'.EPrim p, loc), fm)
312 | L.ERel n => ((L'.ERel n, loc), fm) 312 | L.ERel n => ((L'.ERel n, loc), fm)
313 | L.ENamed n => ((L'.ENamed n, loc), fm) 313 | L.ENamed n => ((L'.ENamed n, loc), fm)
314 | L.ECon (dk, pc, eo) => 314 | L.ECon (dk, pc, _, eo) => raise Fail "Monoize ECon"
315 let 315 (*let
316 val (eo, fm) = 316 val (eo, fm) =
317 case eo of 317 case eo of
318 NONE => (NONE, fm) 318 NONE => (NONE, fm)
319 | SOME e => 319 | SOME e =>
320 let 320 let
322 in 322 in
323 (SOME e, fm) 323 (SOME e, fm)
324 end 324 end
325 in 325 in
326 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm) 326 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
327 end 327 end*)
328 | L.EFfi mx => ((L'.EFfi mx, loc), fm) 328 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
329 | L.EFfiApp (m, x, es) => 329 | L.EFfiApp (m, x, es) =>
330 let 330 let
331 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es 331 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
332 in 332 in
716 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)]; 716 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
717 NONE) 717 NONE)
718 in 718 in
719 case d of 719 case d of
720 L.DCon _ => NONE 720 L.DCon _ => NONE
721 | L.DDatatype (x, n, xncs) => 721 | L.DDatatype (x, n, _, xncs) => raise Fail "Monoize DDatatype"
722 let 722 (*let
723 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc) 723 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc)
724 in 724 in
725 SOME (Env.declBinds env all, fm, d) 725 SOME (Env.declBinds env all, fm, d)
726 end 726 end*)
727 | L.DVal (x, n, t, e, s) => 727 | L.DVal (x, n, t, e, s) =>
728 let 728 let
729 val (e, fm) = monoExp (env, St.empty, fm) e 729 val (e, fm) = monoExp (env, St.empty, fm) e
730 in 730 in
731 SOME (Env.pushENamed env x n t NONE s, 731 SOME (Env.pushENamed env x n t NONE s,