Mercurial > urweb
diff src/monoize.sml @ 179:3bbed533fbd2
Cases through monoize
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 03 Aug 2008 10:48:36 -0400 |
| parents | eb3f9913bf31 |
| children | d11754ffe252 |
line wrap: on
line diff
--- a/src/monoize.sml Sun Aug 03 09:26:49 2008 -0400 +++ b/src/monoize.sml Sun Aug 03 10:48:36 2008 -0400 @@ -87,52 +87,171 @@ val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) -fun fooifyExp name env = +structure IM = IntBinaryMap + +datatype foo_kind = + Attr + | Url + +fun fk2s fk = + case fk of + Attr => "attr" + | Url => "url" + +structure Fm :> sig + type t + + val empty : int -> t + + val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int + val enter : t -> t + val decls : t -> L'.decl list +end = struct + +structure M = BinaryMapFn(struct + type ord_key = foo_kind + fun compare x = + case x of + (Attr, Attr) => EQUAL + | (Attr, _) => LESS + | (_, Attr) => GREATER + + | (Url, Url) => EQUAL + end) + +type t = { + count : int, + map : int IM.map M.map, + decls : L'.decl list +} + +fun empty count = { + count = count, + map = M.empty, + decls = [] +} + +fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []} +fun decls ({decls, ...} : t) = decls + +fun lookup (t as {count, map, decls}) k n thunk = let - fun fooify (e, tAll as (t, loc)) = + val im = Option.getOpt (M.find (map, k), IM.empty) + in + case IM.find (im, n) of + NONE => + let + val n' = count + val (d, {count, map, decls}) = thunk count {count = count + 1, + map = M.insert (map, k, IM.insert (im, n, n')), + decls = decls} + in + ({count = count, + map = map, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +end + + +fun fooifyExp fk env = + let + fun fooify fm (e, tAll as (t, loc)) = case #1 e of L'.EClosure (fnam, [(L'.ERecord [], _)]) => let val (_, _, _, s) = Env.lookupENamed env fnam in - (L'.EPrim (Prim.String s), loc) + ((L'.EPrim (Prim.String s), loc), fm) end | L'.EClosure (fnam, args) => let val (_, ft, _, s) = Env.lookupENamed env fnam val ft = monoType env ft - fun attrify (args, ft, e) = + fun attrify (args, ft, e, fm) = case (args, ft) of - ([], _) => e + ([], _) => (e, fm) | (arg :: args, (L'.TFun (t, ft), _)) => - attrify (args, ft, - (L'.EStrcat (e, - (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), - fooify (arg, t)), loc)), loc)) + let + val (arg', fm) = fooify fm (arg, t) + in + attrify (args, ft, + (L'.EStrcat (e, + (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), + arg'), loc)), loc), + fm) + end | _ => (E.errorAt loc "Type mismatch encoding attribute"; - e) + (e, fm)) in - attrify (args, ft, (L'.EPrim (Prim.String s), loc)) + attrify (args, ft, (L'.EPrim (Prim.String s), loc), fm) end | _ => case t of - L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", name ^ "ifyString", [e]), loc) - | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", name ^ "ifyInt", [e]), loc) - | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", name ^ "ifyFloat", [e]), loc) - | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc) + L'.TFfi ("Basis", "string") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyString", [e]), loc), fm) + | L'.TFfi ("Basis", "int") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyInt", [e]), loc), fm) + | L'.TFfi ("Basis", "float") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyFloat", [e]), loc), fm) + | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm) - | L'.TDatatype _ => (L'.EPrim (Prim.String "A"), loc) + | L'.TDatatype (i, _) => + let + fun makeDecl n fm = + let + val (x, xncs) = Env.lookupDatatype env i + + val (branches, fm) = + ListUtil.foldlMap + (fn ((x, n, to), fm) => + case to of + NONE => + (((L'.PCon (L'.PConVar n, NONE), loc), + (L'.EPrim (Prim.String x), loc)), + fm) + | SOME t => + let + val (arg, fm) = fooify fm ((L'.ERel 0, loc), + monoType env t) + in + (((L'.PCon (L'.PConVar n, SOME (L'.PVar "a", loc)), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc), + arg), loc)), + fm) + end) + fm xncs + + val dom = tAll + val ran = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.DValRec [(fk2s fk ^ "ify_" ^ x, + n, + (L'.TFun (dom, ran), loc), + (L'.EAbs ("x", + dom, + ran, + (L'.ECase ((L'.ERel 0, loc), + branches, + ran), loc)), loc), + "")], loc), + fm) + end + + val (fm, n) = Fm.lookup fm fk i makeDecl + in + ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) + end | _ => (E.errorAt loc "Don't know how to encode attribute type"; Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; - dummyExp) + (dummyExp, fm)) in fooify end -val attrifyExp = fooifyExp "attr" -val urlifyExp = fooifyExp "url" +val attrifyExp = fooifyExp Attr +val urlifyExp = fooifyExp Url datatype 'a failable_search = Found of 'a @@ -173,26 +292,50 @@ | L.PCon (pc, po) => (L'.PCon (monoPatCon pc, Option.map monoPat po), loc) | L.PRecord xps => (L'.PRecord (map (fn (x, p) => (x, monoPat p)) xps), loc) -fun monoExp (env, st) (all as (e, loc)) = +fun monoExp (env, st, fm) (all as (e, loc)) = let fun poly () = (E.errorAt loc "Unsupported expression"; Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; - dummyExp) + (dummyExp, fm)) in case e of - L.EPrim p => (L'.EPrim p, loc) - | L.ERel n => (L'.ERel n, loc) - | L.ENamed n => (L'.ENamed n, loc) - | L.ECon (n, eo) => (L'.ECon (n, Option.map (monoExp (env, st)) eo), loc) - | L.EFfi mx => (L'.EFfi mx, loc) - | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp (env, st)) es), loc) + L.EPrim p => ((L'.EPrim p, loc), fm) + | L.ERel n => ((L'.ERel n, loc), fm) + | L.ENamed n => ((L'.ENamed n, loc), fm) + | L.ECon (n, eo) => + let + val (eo, fm) = + case eo of + NONE => (NONE, fm) + | SOME e => + let + val (e, fm) = monoExp (env, st, fm) e + in + (SOME e, fm) + end + in + ((L'.ECon (n, eo), loc), fm) + end + | L.EFfi mx => ((L'.EFfi mx, loc), fm) + | L.EFfiApp (m, x, es) => + let + val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es + in + ((L'.EFfiApp (m, x, es), loc), fm) + end | L.EApp ( (L.ECApp ( (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), _), _), - se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp (env, st) se]), loc) + se) => + let + val (se, fm) = monoExp (env, st, fm) se + in + ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm) + end + | L.EApp ( (L.EApp ( (L.ECApp ( @@ -205,7 +348,13 @@ _), _), _), _), xml1), _), - xml2) => (L'.EStrcat (monoExp (env, st) xml1, monoExp (env, st) xml2), loc) + xml2) => + let + val (xml1, fm) = monoExp (env, st, fm) xml1 + val (xml2, fm) = monoExp (env, st, fm) xml2 + in + ((L'.EStrcat (xml1, xml2), loc), fm) + end | L.EApp ( (L.EApp ( @@ -246,7 +395,7 @@ val (tag, targs) = getTag tag - val attrs = monoExp (env, st) attrs + val (attrs, fm) = monoExp (env, st, fm) attrs fun tagStart tag = case #1 attrs of @@ -258,7 +407,7 @@ val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) in - foldl (fn ((x, e, t), s) => + foldl (fn ((x, e, t), (s, fm)) => let val xp = " " ^ lowercaseFirst x ^ "=\"" @@ -267,41 +416,53 @@ "Link" => urlifyExp | "Action" => urlifyExp | _ => attrifyExp + + val (e, fm) = fooify env fm (e, t) in - (L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), - (L'.EStrcat (fooify env (e, t), - (L'.EPrim (Prim.String "\""), - loc)), - loc)), - loc)), loc) + ((L'.EStrcat (s, + (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), + (L'.EStrcat (e, + (L'.EPrim (Prim.String "\""), + loc)), + loc)), + loc)), loc), + fm) end) - s xes + (s, fm) xes end | _ => raise Fail "Non-record attributes!" fun input typ = case targs of [_, (L.CName name, _)] => - (L'.EStrcat (tagStart "input", - (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")), - loc)), loc) + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")), + loc)), loc), fm) + end | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to input tag") fun normal (tag, extra) = let - val tagStart = tagStart tag + val (tagStart, fm) = tagStart tag val tagStart = case extra of NONE => tagStart | SOME extra => (L'.EStrcat (tagStart, extra), loc) fun normal () = - (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), - (L'.EStrcat (monoExp (env, st) xml, - (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), - loc)), loc)), - loc) + let + val (xml, fm) = monoExp (env, st, fm) xml + in + ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), + (L'.EStrcat (xml, + (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), + loc)), loc)), + loc), + fm) + end in case xml of (L.EApp ((L.ECApp ( @@ -310,40 +471,49 @@ _), _), (L.EPrim (Prim.String s), _)), _) => if CharVector.all Char.isSpace s then - (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc) + ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc), fm) else normal () | _ => normal () end in case tag of - "submit" => (L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc) + "submit" => ((L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc), fm) | "textbox" => (case targs of [_, (L.CName name, _)] => - (L'.EStrcat (tagStart "input", - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")), - loc)), loc) + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")), + loc)), loc), fm) + end | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to textarea tag")) | "password" => input "password" | "ltextarea" => (case targs of [_, (L.CName name, _)] => - (L'.EStrcat ((L'.EStrcat (tagStart "textarea", - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), - (L'.EStrcat (monoExp (env, st) xml, - (L'.EPrim (Prim.String "</textarea>"), - loc)), loc)), - loc) + let + val (ts, fm) = tagStart "textarea" + val (xml, fm) = monoExp (env, st, fm) xml + in + ((L'.EStrcat ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), + (L'.EStrcat (xml, + (L'.EPrim (Prim.String "</textarea>"), + loc)), loc)), + loc), fm) + end | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to ltextarea tag")) | "radio" => (case targs of [_, (L.CName name, _)] => - monoExp (env, St.setRadioGroup (st, name)) xml + monoExp (env, St.setRadioGroup (st, name), fm) xml | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to radio tag")) | "radioOption" => @@ -356,12 +526,18 @@ | "lselect" => (case targs of [_, (L.CName name, _)] => - (L'.EStrcat ((L'.EStrcat (tagStart "select", - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), - (L'.EStrcat (monoExp (env, st) xml, - (L'.EPrim (Prim.String "</select>"), - loc)), loc)), - loc) + let + val (ts, fm) = tagStart "select" + val (xml, fm) = monoExp (env, st, fm) xml + in + ((L'.EStrcat ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), + (L'.EStrcat (xml, + (L'.EPrim (Prim.String "</select>"), + loc)), loc)), + loc), + fm) + end | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to lselect tag")) @@ -430,13 +606,16 @@ | Found et => et val actionT = monoType env actionT - val action = monoExp (env, st) action + val (action, fm) = monoExp (env, st, fm) action + val (action, fm) = urlifyExp env fm (action, actionT) + val (xml, fm) = monoExp (env, st, fm) xml in - (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc), - (L'.EStrcat (urlifyExp env (action, actionT), - (L'.EPrim (Prim.String "\">"), loc)), loc)), loc), - (L'.EStrcat (monoExp (env, st) xml, - (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc) + ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc), + (L'.EStrcat (action, + (L'.EPrim (Prim.String "\">"), loc)), loc)), loc), + (L'.EStrcat (xml, + (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc), + fm) end | L.EApp ((L.ECApp ( @@ -447,32 +626,79 @@ _), _), _), _), _), _), - xml) => monoExp (env, st) xml - + xml) => monoExp (env, st, fm) xml - | L.EApp (e1, e2) => (L'.EApp (monoExp (env, st) e1, monoExp (env, st) e2), loc) + | L.EApp (e1, e2) => + let + val (e1, fm) = monoExp (env, st, fm) e1 + val (e2, fm) = monoExp (env, st, fm) e2 + in + ((L'.EApp (e1, e2), loc), fm) + end | L.EAbs (x, dom, ran, e) => - (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom, st) e), loc) + let + val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e + in + ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm) + end | L.ECApp _ => poly () | L.ECAbs _ => poly () - | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x, - monoExp (env, st) e, - monoType env t)) xes), loc) - | L.EField (e, x, _) => (L'.EField (monoExp (env, st) e, monoName env x), loc) + | L.ERecord xes => + let + val (xes, fm) = ListUtil.foldlMap + (fn ((x, e, t), fm) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((monoName env x, + e, + monoType env t), fm) + end) fm xes + in + ((L'.ERecord xes, loc), fm) + end + | L.EField (e, x, _) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EField (e, monoName env x), loc), fm) + end | L.ECut _ => poly () | L.EFold _ => poly () - | L.ECase (e, pes, t) => (L'.ECase (monoExp (env, st) e, - map (fn (p, e) => (monoPat p, monoExp (env, st) e)) pes, - monoType env t), loc) + | L.ECase (e, pes, t) => + let + val (e, fm) = monoExp (env, st, fm) e + val (pes, fm) = ListUtil.foldlMap + (fn ((p, e), fm) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((monoPat p, e), fm) + end) fm pes + in + ((L'.ECase (e, pes, monoType env t), loc), fm) + end - | L.EWrite e => (L'.EWrite (monoExp (env, st) e), loc) + | L.EWrite e => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EWrite e, loc), fm) + end - | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp (env, st)) es), loc) + | L.EClosure (n, es) => + let + val (es, fm) = ListUtil.foldlMap (fn (e, fm) => + monoExp (env, st, fm) e) + fm es + in + ((L'.EClosure (n, es), loc), fm) + end end -fun monoDecl env (all as (d, loc)) = +fun monoDecl (env, fm) (all as (d, loc)) = let fun poly () = (E.errorAt loc "Unsupported declaration"; @@ -485,17 +711,32 @@ let val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc) in - SOME (Env.declBinds env all, d) + SOME (Env.declBinds env all, fm, d) end - | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s, - (L'.DVal (x, n, monoType env t, monoExp (env, St.empty) e, s), loc)) + | L.DVal (x, n, t, e, s) => + let + val (e, fm) = monoExp (env, St.empty, fm) e + in + SOME (Env.pushENamed env x n t NONE s, + fm, + (L'.DVal (x, n, monoType env t, e, s), loc)) + end | L.DValRec vis => let val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis + + val (vis, fm) = ListUtil.foldlMap + (fn ((x, n, t, e, s), fm) => + let + val (e, fm) = monoExp (env, St.empty, fm) e + in + ((x, n, monoType env t, e, s), fm) + end) + fm vis in SOME (env, - (L'.DValRec (map (fn (x, n, t, e, s) => (x, n, monoType env t, - monoExp (env, St.empty) e, s)) vis), loc)) + fm, + (L'.DValRec vis, loc)) end | L.DExport (ek, n) => let @@ -508,16 +749,20 @@ val ts = map (monoType env) (unwind t) in - SOME (env, (L'.DExport (ek, s, n, ts), loc)) + SOME (env, fm, (L'.DExport (ek, s, n, ts), loc)) end end fun monoize env ds = let - val (_, ds) = List.foldl (fn (d, (env, ds)) => - case monoDecl env d of - NONE => (env, ds) - | SOME (env, d) => (env, d :: ds)) (env, []) ds + val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => + case monoDecl (env, fm) d of + NONE => (env, fm, ds) + | SOME (env, fm, d) => + (env, + Fm.enter fm, + d :: Fm.decls fm @ ds)) + (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds in rev ds end