Mercurial > urweb

annotate src/mono_fooify.sml @ 2260:03b10c7fab9a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Begin work on cache merging.
author Ziv Scully <ziv@mit.edu>
date Mon, 28 Sep 2015 22:16:51 -0400
parents 6f2ea4ed573a
children f81f1930c5d6
rev   line source
ziv@2260 1 structure MonoFooify :> MONO_FOOIFY = struct
ziv@2254 2
ziv@2254 3 open Mono
ziv@2254 4
ziv@2254 5 datatype foo_kind =
ziv@2254 6 Attr
ziv@2254 7 | Url
ziv@2254 8
ziv@2254 9 val nextPvar = ref 0
ziv@2254 10 val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list)
ziv@2254 11
ziv@2254 12 structure Fm = struct
ziv@2254 13
ziv@2254 14 type vr = string * int * typ * exp * string
ziv@2254 15
ziv@2254 16 structure IM = IntBinaryMap
ziv@2254 17
ziv@2254 18 structure M = BinaryMapFn(struct
ziv@2254 19 type ord_key = foo_kind
ziv@2254 20 fun compare x =
ziv@2254 21 case x of
ziv@2254 22 (Attr, Attr) => EQUAL
ziv@2254 23 | (Attr, _) => LESS
ziv@2254 24 | (_, Attr) => GREATER
ziv@2254 25
ziv@2254 26 | (Url, Url) => EQUAL
ziv@2254 27 end)
ziv@2254 28
ziv@2254 29 structure TM = BinaryMapFn(struct
ziv@2254 30 type ord_key = typ
ziv@2254 31 val compare = MonoUtil.Typ.compare
ziv@2254 32 end)
ziv@2254 33
ziv@2254 34 type t = {
ziv@2254 35 count : int,
ziv@2254 36 map : int IM.map M.map,
ziv@2254 37 listMap : int TM.map M.map,
ziv@2254 38 decls : vr list
ziv@2254 39 }
ziv@2254 40
ziv@2254 41 fun empty count = {
ziv@2254 42 count = count,
ziv@2254 43 map = M.empty,
ziv@2254 44 listMap = M.empty,
ziv@2254 45 decls = []
ziv@2254 46 }
ziv@2254 47
ziv@2254 48 fun chooseNext count =
ziv@2254 49 let
ziv@2254 50 val n = !nextPvar
ziv@2254 51 in
ziv@2254 52 if count < n then
ziv@2254 53 (count, count+1)
ziv@2254 54 else
ziv@2254 55 (nextPvar := n + 1;
ziv@2254 56 (n, n+1))
ziv@2254 57 end
ziv@2254 58
ziv@2254 59 fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
ziv@2254 60 fun freshName {count, map, listMap, decls} =
ziv@2254 61 let
ziv@2254 62 val (next, count) = chooseNext count
ziv@2254 63 in
ziv@2254 64 (next, {count = count , map = map, listMap = listMap, decls = decls})
ziv@2254 65 end
ziv@2254 66 fun decls ({decls, ...} : t) =
ziv@2254 67 case decls of
ziv@2254 68 [] => []
ziv@2254 69 | _ => [(DValRec decls, ErrorMsg.dummySpan)]
ziv@2254 70
ziv@2254 71 fun lookup (t as {count, map, listMap, decls}) k n thunk =
ziv@2254 72 let
ziv@2254 73 val im = Option.getOpt (M.find (map, k), IM.empty)
ziv@2254 74 in
ziv@2254 75 case IM.find (im, n) of
ziv@2254 76 NONE =>
ziv@2254 77 let
ziv@2254 78 val n' = count
ziv@2254 79 val (d, {count, map, listMap, decls}) =
ziv@2254 80 thunk count {count = count + 1,
ziv@2254 81 map = M.insert (map, k, IM.insert (im, n, n')),
ziv@2254 82 listMap = listMap,
ziv@2254 83 decls = decls}
ziv@2254 84 in
ziv@2254 85 ({count = count,
ziv@2254 86 map = map,
ziv@2254 87 listMap = listMap,
ziv@2254 88 decls = d :: decls}, n')
ziv@2254 89 end
ziv@2254 90 | SOME n' => (t, n')
ziv@2254 91 end
ziv@2254 92
ziv@2254 93 fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
ziv@2254 94 let
ziv@2254 95 val tm = Option.getOpt (M.find (listMap, k), TM.empty)
ziv@2254 96 in
ziv@2254 97 case TM.find (tm, tp) of
ziv@2254 98 NONE =>
ziv@2254 99 let
ziv@2254 100 val n' = count
ziv@2254 101 val (d, {count, map, listMap, decls}) =
ziv@2254 102 thunk count {count = count + 1,
ziv@2254 103 map = map,
ziv@2254 104 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
ziv@2254 105 decls = decls}
ziv@2254 106 in
ziv@2254 107 ({count = count,
ziv@2254 108 map = map,
ziv@2254 109 listMap = listMap,
ziv@2254 110 decls = d :: decls}, n')
ziv@2254 111 end
ziv@2254 112 | SOME n' => (t, n')
ziv@2254 113 end
ziv@2254 114
ziv@2254 115 end
ziv@2254 116
ziv@2254 117 fun fk2s fk =
ziv@2254 118 case fk of
ziv@2254 119 Attr => "attr"
ziv@2254 120 | Url => "url"
ziv@2254 121
ziv@2254 122 fun capitalize s =
ziv@2254 123 if s = "" then
ziv@2254 124 s
ziv@2254 125 else
ziv@2254 126 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
ziv@2254 127
ziv@2254 128 structure E = ErrorMsg
ziv@2254 129
ziv@2254 130 val dummyExp = (EPrim (Prim.Int 0), E.dummySpan)
ziv@2254 131
ziv@2254 132 fun fooifyExp fk lookupENamed lookupDatatype =
ziv@2254 133 let
ziv@2254 134 fun fooify fm (e, tAll as (t, loc)) =
ziv@2254 135 case #1 e of
ziv@2254 136 EClosure (fnam, [(ERecord [], _)]) =>
ziv@2254 137 let
ziv@2254 138 val (_, s) = lookupENamed fnam
ziv@2254 139 in
ziv@2254 140 ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
ziv@2254 141 end
ziv@2254 142 | EClosure (fnam, args) =>
ziv@2254 143 let
ziv@2254 144 val (ft, s) = lookupENamed fnam
ziv@2254 145 fun attrify (args, ft, e, fm) =
ziv@2254 146 case (args, ft) of
ziv@2254 147 ([], _) => (e, fm)
ziv@2254 148 | (arg :: args, (TFun (t, ft), _)) =>
ziv@2254 149 let
ziv@2254 150 val (arg', fm) = fooify fm (arg, t)
ziv@2254 151 in
ziv@2254 152 attrify (args, ft,
ziv@2254 153 (EStrcat (e,
ziv@2254 154 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
ziv@2254 155 arg'), loc)), loc),
ziv@2254 156 fm)
ziv@2254 157 end
ziv@2254 158 | _ => (E.errorAt loc "Type mismatch encoding attribute";
ziv@2254 159 (e, fm))
ziv@2254 160 in
ziv@2254 161 attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
ziv@2254 162 end
ziv@2254 163 | _ =>
ziv@2254 164 case t of
ziv@2254 165 TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
ziv@2256 166 | TFfi (m, x) => (if Settings.mayClientToServer (m, x)
ziv@2256 167 (* TODO: better error message. (Then again, user should never see this.) *)
ziv@2256 168 then ()
ziv@2256 169 else (E.errorAt loc "MonoFooify: can't pass type from client to server";
ziv@2256 170 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]);
ziv@2256 171 ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm))
ziv@2254 172
ziv@2254 173 | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
ziv@2254 174 | TRecord ((x, t) :: xts) =>
ziv@2254 175 let
ziv@2254 176 val (se, fm) = fooify fm ((EField (e, x), loc), t)
ziv@2254 177 in
ziv@2254 178 foldl (fn ((x, t), (se, fm)) =>
ziv@2254 179 let
ziv@2254 180 val (se', fm) = fooify fm ((EField (e, x), loc), t)
ziv@2254 181 in
ziv@2254 182 ((EStrcat (se,
ziv@2254 183 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
ziv@2254 184 se'), loc)), loc),
ziv@2254 185 fm)
ziv@2254 186 end) (se, fm) xts
ziv@2254 187 end
ziv@2254 188
ziv@2254 189 | TDatatype (i, ref (dk, _)) =>
ziv@2254 190 let
ziv@2254 191 fun makeDecl n fm =
ziv@2254 192 let
ziv@2254 193 val (x, xncs) =
ziv@2254 194 case ListUtil.search (fn (x, i', xncs) =>
ziv@2254 195 if i' = i then
ziv@2254 196 SOME (x, xncs)
ziv@2254 197 else
ziv@2254 198 NONE) (!pvarDefs) of
ziv@2254 199 NONE => lookupDatatype i
ziv@2254 200 | SOME v => v
ziv@2254 201
ziv@2254 202 val (branches, fm) =
ziv@2254 203 ListUtil.foldlMap
ziv@2254 204 (fn ((x, n, to), fm) =>
ziv@2254 205 case to of
ziv@2254 206 NONE =>
ziv@2254 207 (((PCon (dk, PConVar n, NONE), loc),
ziv@2254 208 (EPrim (Prim.String (Prim.Normal, x)), loc)),
ziv@2254 209 fm)
ziv@2254 210 | SOME t =>
ziv@2254 211 let
ziv@2254 212 val (arg, fm) = fooify fm ((ERel 0, loc), t)
ziv@2254 213 in
ziv@2254 214 (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc),
ziv@2254 215 (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
ziv@2254 216 arg), loc)),
ziv@2254 217 fm)
ziv@2254 218 end)
ziv@2254 219 fm xncs
ziv@2254 220
ziv@2254 221 val dom = tAll
ziv@2254 222 val ran = (TFfi ("Basis", "string"), loc)
ziv@2254 223 in
ziv@2254 224 ((fk2s fk ^ "ify_" ^ x,
ziv@2254 225 n,
ziv@2254 226 (TFun (dom, ran), loc),
ziv@2254 227 (EAbs ("x",
ziv@2254 228 dom,
ziv@2254 229 ran,
ziv@2254 230 (ECase ((ERel 0, loc),
ziv@2254 231 branches,
ziv@2254 232 {disc = dom,
ziv@2254 233 result = ran}), loc)), loc),
ziv@2254 234 ""),
ziv@2254 235 fm)
ziv@2254 236 end
ziv@2254 237
ziv@2254 238 val (fm, n) = Fm.lookup fm fk i makeDecl
ziv@2254 239 in
ziv@2254 240 ((EApp ((ENamed n, loc), e), loc), fm)
ziv@2254 241 end
ziv@2254 242
ziv@2254 243 | TOption t =>
ziv@2254 244 let
ziv@2254 245 val (body, fm) = fooify fm ((ERel 0, loc), t)
ziv@2254 246 in
ziv@2254 247 ((ECase (e,
ziv@2254 248 [((PNone t, loc),
ziv@2254 249 (EPrim (Prim.String (Prim.Normal, "None")), loc)),
ziv@2254 250
ziv@2254 251 ((PSome (t, (PVar ("x", t), loc)), loc),
ziv@2254 252 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc),
ziv@2254 253 body), loc))],
ziv@2254 254 {disc = tAll,
ziv@2254 255 result = (TFfi ("Basis", "string"), loc)}), loc),
ziv@2254 256 fm)
ziv@2254 257 end
ziv@2254 258
ziv@2254 259 | TList t =>
ziv@2254 260 let
ziv@2254 261 fun makeDecl n fm =
ziv@2254 262 let
ziv@2254 263 val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc)
ziv@2254 264 val (arg, fm) = fooify fm ((ERel 0, loc), rt)
ziv@2254 265
ziv@2254 266 val branches = [((PNone rt, loc),
ziv@2254 267 (EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
ziv@2254 268 ((PSome (rt, (PVar ("a", rt), loc)), loc),
ziv@2254 269 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
ziv@2254 270 arg), loc))]
ziv@2254 271
ziv@2254 272 val dom = tAll
ziv@2254 273 val ran = (TFfi ("Basis", "string"), loc)
ziv@2254 274 in
ziv@2254 275 ((fk2s fk ^ "ify_list",
ziv@2254 276 n,
ziv@2254 277 (TFun (dom, ran), loc),
ziv@2254 278 (EAbs ("x",
ziv@2254 279 dom,
ziv@2254 280 ran,
ziv@2254 281 (ECase ((ERel 0, loc),
ziv@2254 282 branches,
ziv@2254 283 {disc = dom,
ziv@2254 284 result = ran}), loc)), loc),
ziv@2254 285 ""),
ziv@2254 286 fm)
ziv@2254 287 end
ziv@2254 288
ziv@2254 289 val (fm, n) = Fm.lookupList fm fk t makeDecl
ziv@2254 290 in
ziv@2254 291 ((EApp ((ENamed n, loc), e), loc), fm)
ziv@2254 292 end
ziv@2254 293
ziv@2254 294 | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
ziv@2254 295 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
ziv@2254 296 (dummyExp, fm))
ziv@2254 297 in
ziv@2254 298 fooify
ziv@2254 299 end
ziv@2254 300
ziv@2256 301 (* Has to be set at the end of [Monoize]. *)
ziv@2256 302 val canonicalFm = ref (Fm.empty 0 : Fm.t)
ziv@2256 303
ziv@2254 304 fun urlify env expTyp =
ziv@2256 305 if ErrorMsg.anyErrors ()
ziv@2256 306 then ((* DEBUG *) print "already error"; NONE)
ziv@2256 307 else
ziv@2256 308 let
ziv@2256 309 val (exp, fm) =
ziv@2256 310 fooifyExp
ziv@2256 311 Url
ziv@2256 312 (fn n =>
ziv@2256 313 let
ziv@2256 314 val (_, t, _, s) = MonoEnv.lookupENamed env n
ziv@2256 315 in
ziv@2256 316 (t, s)
ziv@2256 317 end)
ziv@2256 318 (fn n => MonoEnv.lookupDatatype env n)
ziv@2256 319 (!canonicalFm)
ziv@2256 320 expTyp
ziv@2256 321 in
ziv@2256 322 if ErrorMsg.anyErrors ()
ziv@2256 323 then ((* DEBUG *) print "why"; (ErrorMsg.resetErrors (); NONE))
ziv@2256 324 else (canonicalFm := fm; SOME exp)
ziv@2256 325 end
ziv@2256 326
ziv@2256 327 fun getNewFmDecls () =
ziv@2254 328 let
ziv@2256 329 val fm = !canonicalFm
ziv@2254 330 in
ziv@2256 331 (* canonicalFm := Fm.enter fm; *)
ziv@2256 332 Fm.decls fm
ziv@2254 333 end
ziv@2256 334
ziv@2254 335 end