Mercurial > urweb
changeset 2254:44ae2254f8fb
Factor out urlification.
| author | Ziv Scully <ziv@mit.edu> |
|---|---|
| date | Mon, 21 Sep 2015 16:07:35 -0400 |
| parents | d665925acff8 |
| children | 8428c534913a |
| files | src/mono_fm.sig src/mono_fm.sml src/mono_fooify.sig src/mono_fooify.sml src/monoize.sml src/sources |
| diffstat | 6 files changed, 378 insertions(+), 326 deletions(-) [+] |
line wrap: on
line diff
--- a/src/mono_fm.sig Mon Sep 21 14:54:07 2015 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,22 +0,0 @@ -signature MONO_FM = sig - type t - - type vr = string * int * Mono.typ * Mono.exp * string - - datatype foo_kind = - Attr - | Url - - val empty : int -> t - - val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int - val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int - val enter : t -> t - val decls : t -> Mono.decl list - - val freshName : t -> int * t - - (* TODO: don't expose raw references if possible. *) - val nextPvar : int ref - val postMonoize : t ref -end
--- a/src/mono_fm.sml Mon Sep 21 14:54:07 2015 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,115 +0,0 @@ -(* TODO: better name than "fm"? *) -structure MonoFm : MONO_FM = struct - -open Mono - -type vr = string * int * typ * exp * string - -datatype foo_kind = - Attr - | Url - -structure IM = IntBinaryMap - -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) - -structure TM = BinaryMapFn(struct - type ord_key = typ - val compare = MonoUtil.Typ.compare - end) - -type t = { - count : int, - map : int IM.map M.map, - listMap : int TM.map M.map, - decls : vr list -} - -val nextPvar = ref 0 - -fun empty count = { - count = count, - map = M.empty, - listMap = M.empty, - decls = [] -} - -fun chooseNext count = - let - val n = !nextPvar - in - if count < n then - (count, count+1) - else - (nextPvar := n + 1; - (n, n+1)) - end - -fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []} -fun freshName {count, map, listMap, decls} = - let - val (next, count) = chooseNext count - in - (next, {count = count , map = map, listMap = listMap, decls = decls}) - end -fun decls ({decls, ...} : t) = - case decls of - [] => [] - | _ => [(DValRec decls, ErrorMsg.dummySpan)] - -fun lookup (t as {count, map, listMap, decls}) k n thunk = - let - 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, listMap, decls}) = - thunk count {count = count + 1, - map = M.insert (map, k, IM.insert (im, n, n')), - listMap = listMap, - decls = decls} - in - ({count = count, - map = map, - listMap = listMap, - decls = d :: decls}, n') - end - | SOME n' => (t, n') - end - -fun lookupList (t as {count, map, listMap, decls}) k tp thunk = - let - val tm = Option.getOpt (M.find (listMap, k), TM.empty) - in - case TM.find (tm, tp) of - NONE => - let - val n' = count - val (d, {count, map, listMap, decls}) = - thunk count {count = count + 1, - map = map, - listMap = M.insert (listMap, k, TM.insert (tm, tp, n')), - decls = decls} - in - ({count = count, - map = map, - listMap = listMap, - decls = d :: decls}, n') - end - | SOME n' => (t, n') - end - -val postMonoize : t ref = ref (empty 0) - -end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mono_fooify.sig Mon Sep 21 16:07:35 2015 -0400 @@ -0,0 +1,38 @@ +signature MONO_FOOIFY = sig + +(* TODO: don't expose raw references if possible. *) +val nextPvar : int ref +val pvarDefs : ((string * int * (string * int * Mono.typ option) list) list) ref + +datatype foo_kind = Attr | Url + +structure Fm : sig + type t + + type vr = string * int * Mono.typ * Mono.exp * string + + val empty : int -> t + + val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int + val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int + val enter : t -> t + val decls : t -> Mono.decl list + + val freshName : t -> int * t + + (* Set at the end of [Monoize]. *) + val canonical : t ref +end + +(* General form used in [Monoize]. *) +val fooifyExp : foo_kind + -> (int -> Mono.typ * string) + -> (int -> string * (string * int * Mono.typ option) list) + -> Fm.t + -> Mono.exp * Mono.typ + -> Mono.exp * Fm.t + +(* Easy-to-use special case used in [Sqlcache]. *) +val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mono_fooify.sml Mon Sep 21 16:07:35 2015 -0400 @@ -0,0 +1,317 @@ +structure MonoFooify :> MONO_FOOIFY = struct + +open Mono + +datatype foo_kind = + Attr + | Url + +val nextPvar = ref 0 +val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list) + +structure Fm = struct + +type vr = string * int * typ * exp * string + +structure IM = IntBinaryMap + +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) + +structure TM = BinaryMapFn(struct + type ord_key = typ + val compare = MonoUtil.Typ.compare + end) + +type t = { + count : int, + map : int IM.map M.map, + listMap : int TM.map M.map, + decls : vr list +} + +fun empty count = { + count = count, + map = M.empty, + listMap = M.empty, + decls = [] +} + +fun chooseNext count = + let + val n = !nextPvar + in + if count < n then + (count, count+1) + else + (nextPvar := n + 1; + (n, n+1)) + end + +fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []} +fun freshName {count, map, listMap, decls} = + let + val (next, count) = chooseNext count + in + (next, {count = count , map = map, listMap = listMap, decls = decls}) + end +fun decls ({decls, ...} : t) = + case decls of + [] => [] + | _ => [(DValRec decls, ErrorMsg.dummySpan)] + +fun lookup (t as {count, map, listMap, decls}) k n thunk = + let + 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, listMap, decls}) = + thunk count {count = count + 1, + map = M.insert (map, k, IM.insert (im, n, n')), + listMap = listMap, + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +fun lookupList (t as {count, map, listMap, decls}) k tp thunk = + let + val tm = Option.getOpt (M.find (listMap, k), TM.empty) + in + case TM.find (tm, tp) of + NONE => + let + val n' = count + val (d, {count, map, listMap, decls}) = + thunk count {count = count + 1, + map = map, + listMap = M.insert (listMap, k, TM.insert (tm, tp, n')), + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +(* Has to be set at the end of [Monoize]. *) +val canonical = ref (empty 0 : t) + +end + +fun fk2s fk = + case fk of + Attr => "attr" + | Url => "url" + +fun capitalize s = + if s = "" then + s + else + str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +structure E = ErrorMsg + +val dummyExp = (EPrim (Prim.Int 0), E.dummySpan) + +fun fooifyExp fk lookupENamed lookupDatatype = + let + fun fooify fm (e, tAll as (t, loc)) = + case #1 e of + EClosure (fnam, [(ERecord [], _)]) => + let + val (_, s) = lookupENamed fnam + in + ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) + end + | EClosure (fnam, args) => + let + val (ft, s) = lookupENamed fnam + fun attrify (args, ft, e, fm) = + case (args, ft) of + ([], _) => (e, fm) + | (arg :: args, (TFun (t, ft), _)) => + let + val (arg', fm) = fooify fm (arg, t) + in + attrify (args, ft, + (EStrcat (e, + (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), + arg'), loc)), loc), + fm) + end + | _ => (E.errorAt loc "Type mismatch encoding attribute"; + (e, fm)) + in + attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) + end + | _ => + case t of + TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) + + | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + | TRecord ((x, t) :: xts) => + let + val (se, fm) = fooify fm ((EField (e, x), loc), t) + in + foldl (fn ((x, t), (se, fm)) => + let + val (se', fm) = fooify fm ((EField (e, x), loc), t) + in + ((EStrcat (se, + (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), + se'), loc)), loc), + fm) + end) (se, fm) xts + end + + | TDatatype (i, ref (dk, _)) => + let + fun makeDecl n fm = + let + val (x, xncs) = + case ListUtil.search (fn (x, i', xncs) => + if i' = i then + SOME (x, xncs) + else + NONE) (!pvarDefs) of + NONE => lookupDatatype i + | SOME v => v + + val (branches, fm) = + ListUtil.foldlMap + (fn ((x, n, to), fm) => + case to of + NONE => + (((PCon (dk, PConVar n, NONE), loc), + (EPrim (Prim.String (Prim.Normal, x)), loc)), + fm) + | SOME t => + let + val (arg, fm) = fooify fm ((ERel 0, loc), t) + in + (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), + arg), loc)), + fm) + end) + fm xncs + + val dom = tAll + val ran = (TFfi ("Basis", "string"), loc) + in + ((fk2s fk ^ "ify_" ^ x, + n, + (TFun (dom, ran), loc), + (EAbs ("x", + dom, + ran, + (ECase ((ERel 0, loc), + branches, + {disc = dom, + result = ran}), loc)), loc), + ""), + fm) + end + + val (fm, n) = Fm.lookup fm fk i makeDecl + in + ((EApp ((ENamed n, loc), e), loc), fm) + end + + | TOption t => + let + val (body, fm) = fooify fm ((ERel 0, loc), t) + in + ((ECase (e, + [((PNone t, loc), + (EPrim (Prim.String (Prim.Normal, "None")), loc)), + + ((PSome (t, (PVar ("x", t), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc), + body), loc))], + {disc = tAll, + result = (TFfi ("Basis", "string"), loc)}), loc), + fm) + end + + | TList t => + let + fun makeDecl n fm = + let + val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc) + val (arg, fm) = fooify fm ((ERel 0, loc), rt) + + val branches = [((PNone rt, loc), + (EPrim (Prim.String (Prim.Normal, "Nil")), loc)), + ((PSome (rt, (PVar ("a", rt), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc), + arg), loc))] + + val dom = tAll + val ran = (TFfi ("Basis", "string"), loc) + in + ((fk2s fk ^ "ify_list", + n, + (TFun (dom, ran), loc), + (EAbs ("x", + dom, + ran, + (ECase ((ERel 0, loc), + branches, + {disc = dom, + result = ran}), loc)), loc), + ""), + fm) + end + + val (fm, n) = Fm.lookupList fm fk t makeDecl + in + ((EApp ((ENamed n, loc), e), loc), fm) + end + + | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; + (dummyExp, fm)) + in + fooify + end + +fun urlify env expTyp = + let + val (exp, fm) = + fooifyExp + Url + (fn n => + let + val (_, t, _, s) = MonoEnv.lookupENamed env n + in + (t, s) + end) + (fn n => MonoEnv.lookupDatatype env n) + (!Fm.canonical) + expTyp + in + Fm.canonical := fm; + exp + end +end
--- a/src/monoize.sml Mon Sep 21 14:54:07 2015 -0400 +++ b/src/monoize.sml Mon Sep 21 16:07:35 2015 -0400 @@ -50,9 +50,9 @@ (L'.TRecord r2, E.dummySpan)) end) -val nextPvar = MonoFm.nextPvar +val nextPvar = MonoFooify.nextPvar val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) -val pvarDefs = ref ([] : (string * int * (string * int * L'.typ option) list) list) +val pvarDefs = MonoFooify.pvarDefs val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list) fun choosePvar () = @@ -374,192 +374,26 @@ val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) -structure Fm = MonoFm - -fun fk2s fk = - case fk of - Fm.Attr => "attr" - | Fm.Url => "url" - -fun capitalize s = - if s = "" then - s - else - str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) +structure Fm = MonoFooify.Fm 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 (Prim.Normal, Settings.getUrlPrefix () ^ 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, fm) = - case (args, ft) of - ([], _) => (e, fm) - | (arg :: args, (L'.TFun (t, ft), _)) => - let - val (arg', fm) = fooify fm (arg, t) - in - attrify (args, ft, - (L'.EStrcat (e, - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), - arg'), loc)), loc), - fm) - end - | _ => (E.errorAt loc "Type mismatch encoding attribute"; - (e, fm)) - in - attrify (args, ft, (L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) - end - | _ => - case t of - L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) - | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) - - | L'.TRecord [] => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) - | L'.TRecord ((x, t) :: xts) => - let - val (se, fm) = fooify fm ((L'.EField (e, x), loc), t) - in - foldl (fn ((x, t), (se, fm)) => - let - val (se', fm) = fooify fm ((L'.EField (e, x), loc), t) - in - ((L'.EStrcat (se, - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), - se'), loc)), loc), - fm) - end) (se, fm) xts - end - - | L'.TDatatype (i, ref (dk, _)) => - let - fun makeDecl n fm = - let - val (x, xncs) = - case ListUtil.search (fn (x, i', xncs) => - if i' = i then - SOME (x, xncs) - else - NONE) (!pvarDefs) of - NONE => - let - val (x, _, xncs) = Env.lookupDatatype env i - in - (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs) - end - | SOME v => v - - val (branches, fm) = - ListUtil.foldlMap - (fn ((x, n, to), fm) => - case to of - NONE => - (((L'.PCon (dk, L'.PConVar n, NONE), loc), - (L'.EPrim (Prim.String (Prim.Normal, x)), loc)), - fm) - | SOME t => - let - val (arg, fm) = fooify fm ((L'.ERel 0, loc), t) - in - (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), - arg), loc)), - fm) - end) - fm xncs - - val dom = tAll - val ran = (L'.TFfi ("Basis", "string"), loc) - in - ((fk2s fk ^ "ify_" ^ x, - n, - (L'.TFun (dom, ran), loc), - (L'.EAbs ("x", - dom, - ran, - (L'.ECase ((L'.ERel 0, loc), - branches, - {disc = dom, - result = ran}), loc)), loc), - ""), - fm) - end - - val (fm, n) = Fm.lookup fm fk i makeDecl - in - ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) - end - - | L'.TOption t => - let - val (body, fm) = fooify fm ((L'.ERel 0, loc), t) - in - ((L'.ECase (e, - [((L'.PNone t, loc), - (L'.EPrim (Prim.String (Prim.Normal, "None")), loc)), - - ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Some/")), loc), - body), loc))], - {disc = tAll, - result = (L'.TFfi ("Basis", "string"), loc)}), loc), - fm) - end - - | L'.TList t => - let - fun makeDecl n fm = - let - val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc) - val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt) - - val branches = [((L'.PNone rt, loc), - (L'.EPrim (Prim.String (Prim.Normal, "Nil")), loc)), - ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Cons/")), loc), - arg), loc))] - - val dom = tAll - val ran = (L'.TFfi ("Basis", "string"), loc) - in - ((fk2s fk ^ "ify_list", - n, - (L'.TFun (dom, ran), loc), - (L'.EAbs ("x", - dom, - ran, - (L'.ECase ((L'.ERel 0, loc), - branches, - {disc = dom, - result = ran}), loc)), loc), - ""), - fm) - end - - val (fm, n) = Fm.lookupList fm fk t makeDecl - in - ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) - end - - | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; - Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; - (dummyExp, fm)) - in - fooify - end - -val attrifyExp = fooifyExp Fm.Attr -val urlifyExp = fooifyExp Fm.Url + MonoFooify.fooifyExp + fk + (fn n => + let + val (_, t, _, s) = Env.lookupENamed env n + in + (monoType env t, s) + end) + (fn n => + let + val (x, _, xncs) = Env.lookupDatatype env n + in + (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs) + end) + +val attrifyExp = fooifyExp MonoFooify.Attr +val urlifyExp = fooifyExp MonoFooify.Url val urlifiedUnit = let @@ -4667,7 +4501,7 @@ pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - Fm.postMonoize := fm; + Fm.canonical := fm; (rev ds, []) end