ziv@2260: structure MonoFooify :> MONO_FOOIFY = struct ziv@2254: ziv@2254: open Mono ziv@2254: ziv@2254: datatype foo_kind = ziv@2254: Attr ziv@2254: | Url ziv@2254: ziv@2254: val nextPvar = ref 0 ziv@2254: val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list) ziv@2254: ziv@2254: structure Fm = struct ziv@2254: ziv@2254: type vr = string * int * typ * exp * string ziv@2254: ziv@2254: structure IM = IntBinaryMap ziv@2254: ziv@2254: structure M = BinaryMapFn(struct ziv@2254: type ord_key = foo_kind ziv@2254: fun compare x = ziv@2254: case x of ziv@2254: (Attr, Attr) => EQUAL ziv@2254: | (Attr, _) => LESS ziv@2254: | (_, Attr) => GREATER ziv@2254: ziv@2254: | (Url, Url) => EQUAL ziv@2254: end) ziv@2254: ziv@2254: structure TM = BinaryMapFn(struct ziv@2254: type ord_key = typ ziv@2254: val compare = MonoUtil.Typ.compare ziv@2254: end) ziv@2254: ziv@2254: type t = { ziv@2254: count : int, ziv@2254: map : int IM.map M.map, ziv@2254: listMap : int TM.map M.map, ziv@2254: decls : vr list ziv@2254: } ziv@2254: ziv@2254: fun empty count = { ziv@2254: count = count, ziv@2254: map = M.empty, ziv@2254: listMap = M.empty, ziv@2254: decls = [] ziv@2254: } ziv@2254: ziv@2254: fun chooseNext count = ziv@2254: let ziv@2254: val n = !nextPvar ziv@2254: in ziv@2254: if count < n then ziv@2254: (count, count+1) ziv@2254: else ziv@2254: (nextPvar := n + 1; ziv@2254: (n, n+1)) ziv@2254: end ziv@2254: ziv@2254: fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []} ziv@2254: fun freshName {count, map, listMap, decls} = ziv@2254: let ziv@2254: val (next, count) = chooseNext count ziv@2254: in ziv@2254: (next, {count = count , map = map, listMap = listMap, decls = decls}) ziv@2254: end ziv@2254: fun decls ({decls, ...} : t) = ziv@2254: case decls of ziv@2254: [] => [] ziv@2254: | _ => [(DValRec decls, ErrorMsg.dummySpan)] ziv@2254: ziv@2254: fun lookup (t as {count, map, listMap, decls}) k n thunk = ziv@2254: let ziv@2254: val im = Option.getOpt (M.find (map, k), IM.empty) ziv@2254: in ziv@2254: case IM.find (im, n) of ziv@2254: NONE => ziv@2254: let ziv@2254: val n' = count ziv@2254: val (d, {count, map, listMap, decls}) = ziv@2254: thunk count {count = count + 1, ziv@2254: map = M.insert (map, k, IM.insert (im, n, n')), ziv@2254: listMap = listMap, ziv@2254: decls = decls} ziv@2254: in ziv@2254: ({count = count, ziv@2254: map = map, ziv@2254: listMap = listMap, ziv@2254: decls = d :: decls}, n') ziv@2254: end ziv@2254: | SOME n' => (t, n') ziv@2254: end ziv@2254: ziv@2254: fun lookupList (t as {count, map, listMap, decls}) k tp thunk = ziv@2254: let ziv@2254: val tm = Option.getOpt (M.find (listMap, k), TM.empty) ziv@2254: in ziv@2254: case TM.find (tm, tp) of ziv@2254: NONE => ziv@2254: let ziv@2254: val n' = count ziv@2254: val (d, {count, map, listMap, decls}) = ziv@2254: thunk count {count = count + 1, ziv@2254: map = map, ziv@2254: listMap = M.insert (listMap, k, TM.insert (tm, tp, n')), ziv@2254: decls = decls} ziv@2254: in ziv@2254: ({count = count, ziv@2254: map = map, ziv@2254: listMap = listMap, ziv@2254: decls = d :: decls}, n') ziv@2254: end ziv@2254: | SOME n' => (t, n') ziv@2254: end ziv@2254: ziv@2254: end ziv@2254: ziv@2254: fun fk2s fk = ziv@2254: case fk of ziv@2254: Attr => "attr" ziv@2254: | Url => "url" ziv@2254: ziv@2254: fun capitalize s = ziv@2254: if s = "" then ziv@2254: s ziv@2254: else ziv@2254: str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) ziv@2254: ziv@2254: structure E = ErrorMsg ziv@2254: ziv@2254: val dummyExp = (EPrim (Prim.Int 0), E.dummySpan) ziv@2254: ziv@2254: fun fooifyExp fk lookupENamed lookupDatatype = ziv@2254: let ziv@2254: fun fooify fm (e, tAll as (t, loc)) = ziv@2254: case #1 e of ziv@2254: EClosure (fnam, [(ERecord [], _)]) => ziv@2254: let ziv@2254: val (_, s) = lookupENamed fnam ziv@2254: in ziv@2254: ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) ziv@2254: end ziv@2254: | EClosure (fnam, args) => ziv@2254: let ziv@2254: val (ft, s) = lookupENamed fnam ziv@2254: fun attrify (args, ft, e, fm) = ziv@2254: case (args, ft) of ziv@2254: ([], _) => (e, fm) ziv@2254: | (arg :: args, (TFun (t, ft), _)) => ziv@2254: let ziv@2254: val (arg', fm) = fooify fm (arg, t) ziv@2254: in ziv@2254: attrify (args, ft, ziv@2254: (EStrcat (e, ziv@2254: (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), ziv@2254: arg'), loc)), loc), ziv@2254: fm) ziv@2254: end ziv@2254: | _ => (E.errorAt loc "Type mismatch encoding attribute"; ziv@2254: (e, fm)) ziv@2254: in ziv@2254: attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) ziv@2254: end ziv@2254: | _ => ziv@2254: case t of ziv@2254: TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) ziv@2256: | TFfi (m, x) => (if Settings.mayClientToServer (m, x) ziv@2256: (* TODO: better error message. (Then again, user should never see this.) *) ziv@2256: then () ziv@2256: else (E.errorAt loc "MonoFooify: can't pass type from client to server"; ziv@2256: Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]); ziv@2256: ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)) ziv@2254: ziv@2254: | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) ziv@2254: | TRecord ((x, t) :: xts) => ziv@2254: let ziv@2254: val (se, fm) = fooify fm ((EField (e, x), loc), t) ziv@2254: in ziv@2254: foldl (fn ((x, t), (se, fm)) => ziv@2254: let ziv@2254: val (se', fm) = fooify fm ((EField (e, x), loc), t) ziv@2254: in ziv@2254: ((EStrcat (se, ziv@2254: (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), ziv@2254: se'), loc)), loc), ziv@2254: fm) ziv@2254: end) (se, fm) xts ziv@2254: end ziv@2254: ziv@2254: | TDatatype (i, ref (dk, _)) => ziv@2254: let ziv@2254: fun makeDecl n fm = ziv@2254: let ziv@2254: val (x, xncs) = ziv@2254: case ListUtil.search (fn (x, i', xncs) => ziv@2254: if i' = i then ziv@2254: SOME (x, xncs) ziv@2254: else ziv@2254: NONE) (!pvarDefs) of ziv@2254: NONE => lookupDatatype i ziv@2254: | SOME v => v ziv@2254: ziv@2254: val (branches, fm) = ziv@2254: ListUtil.foldlMap ziv@2254: (fn ((x, n, to), fm) => ziv@2254: case to of ziv@2254: NONE => ziv@2254: (((PCon (dk, PConVar n, NONE), loc), ziv@2254: (EPrim (Prim.String (Prim.Normal, x)), loc)), ziv@2254: fm) ziv@2254: | SOME t => ziv@2254: let ziv@2254: val (arg, fm) = fooify fm ((ERel 0, loc), t) ziv@2254: in ziv@2254: (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc), ziv@2254: (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), ziv@2254: arg), loc)), ziv@2254: fm) ziv@2254: end) ziv@2254: fm xncs ziv@2254: ziv@2254: val dom = tAll ziv@2254: val ran = (TFfi ("Basis", "string"), loc) ziv@2254: in ziv@2254: ((fk2s fk ^ "ify_" ^ x, ziv@2254: n, ziv@2254: (TFun (dom, ran), loc), ziv@2254: (EAbs ("x", ziv@2254: dom, ziv@2254: ran, ziv@2254: (ECase ((ERel 0, loc), ziv@2254: branches, ziv@2254: {disc = dom, ziv@2254: result = ran}), loc)), loc), ziv@2254: ""), ziv@2254: fm) ziv@2254: end ziv@2254: ziv@2254: val (fm, n) = Fm.lookup fm fk i makeDecl ziv@2254: in ziv@2254: ((EApp ((ENamed n, loc), e), loc), fm) ziv@2254: end ziv@2254: ziv@2254: | TOption t => ziv@2254: let ziv@2254: val (body, fm) = fooify fm ((ERel 0, loc), t) ziv@2254: in ziv@2254: ((ECase (e, ziv@2254: [((PNone t, loc), ziv@2254: (EPrim (Prim.String (Prim.Normal, "None")), loc)), ziv@2254: ziv@2254: ((PSome (t, (PVar ("x", t), loc)), loc), ziv@2254: (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc), ziv@2254: body), loc))], ziv@2254: {disc = tAll, ziv@2254: result = (TFfi ("Basis", "string"), loc)}), loc), ziv@2254: fm) ziv@2254: end ziv@2254: ziv@2254: | TList t => ziv@2254: let ziv@2254: fun makeDecl n fm = ziv@2254: let ziv@2254: val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc) ziv@2254: val (arg, fm) = fooify fm ((ERel 0, loc), rt) ziv@2254: ziv@2254: val branches = [((PNone rt, loc), ziv@2254: (EPrim (Prim.String (Prim.Normal, "Nil")), loc)), ziv@2254: ((PSome (rt, (PVar ("a", rt), loc)), loc), ziv@2254: (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc), ziv@2254: arg), loc))] ziv@2254: ziv@2254: val dom = tAll ziv@2254: val ran = (TFfi ("Basis", "string"), loc) ziv@2254: in ziv@2254: ((fk2s fk ^ "ify_list", ziv@2254: n, ziv@2254: (TFun (dom, ran), loc), ziv@2254: (EAbs ("x", ziv@2254: dom, ziv@2254: ran, ziv@2254: (ECase ((ERel 0, loc), ziv@2254: branches, ziv@2254: {disc = dom, ziv@2254: result = ran}), loc)), loc), ziv@2254: ""), ziv@2254: fm) ziv@2254: end ziv@2254: ziv@2254: val (fm, n) = Fm.lookupList fm fk t makeDecl ziv@2254: in ziv@2254: ((EApp ((ENamed n, loc), e), loc), fm) ziv@2254: end ziv@2254: ziv@2254: | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; ziv@2254: Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; ziv@2254: (dummyExp, fm)) ziv@2254: in ziv@2254: fooify ziv@2254: end ziv@2254: ziv@2256: (* Has to be set at the end of [Monoize]. *) ziv@2256: val canonicalFm = ref (Fm.empty 0 : Fm.t) ziv@2256: ziv@2254: fun urlify env expTyp = ziv@2256: if ErrorMsg.anyErrors () ziv@2256: then ((* DEBUG *) print "already error"; NONE) ziv@2256: else ziv@2256: let ziv@2256: val (exp, fm) = ziv@2256: fooifyExp ziv@2256: Url ziv@2256: (fn n => ziv@2256: let ziv@2256: val (_, t, _, s) = MonoEnv.lookupENamed env n ziv@2256: in ziv@2256: (t, s) ziv@2256: end) ziv@2256: (fn n => MonoEnv.lookupDatatype env n) ziv@2256: (!canonicalFm) ziv@2256: expTyp ziv@2256: in ziv@2256: if ErrorMsg.anyErrors () ziv@2256: then ((* DEBUG *) print "why"; (ErrorMsg.resetErrors (); NONE)) ziv@2256: else (canonicalFm := fm; SOME exp) ziv@2256: end ziv@2256: ziv@2256: fun getNewFmDecls () = ziv@2254: let ziv@2256: val fm = !canonicalFm ziv@2254: in ziv@2261: canonicalFm := Fm.enter fm; ziv@2256: Fm.decls fm ziv@2254: end ziv@2256: ziv@2254: end