Mercurial > urweb

annotate src/mono_fooify.sml @ 2262:34ad83d9b729

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors.
author Ziv Scully <ziv@mit.edu>
date Wed, 07 Oct 2015 08:58:08 -0400
parents f81f1930c5d6
children a647a1560628
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@2262 130 exception TypeMismatch of Fm.t * E.span
ziv@2262 131 exception CantPass of Fm.t * typ
ziv@2262 132 exception DontKnow of Fm.t * typ
ziv@2262 133
ziv@2254 134 val dummyExp = (EPrim (Prim.Int 0), E.dummySpan)
ziv@2254 135
ziv@2262 136 fun fooifyExpWithExceptions fk lookupENamed lookupDatatype =
ziv@2254 137 let
ziv@2254 138 fun fooify fm (e, tAll as (t, loc)) =
ziv@2254 139 case #1 e of
ziv@2254 140 EClosure (fnam, [(ERecord [], _)]) =>
ziv@2254 141 let
ziv@2254 142 val (_, s) = lookupENamed fnam
ziv@2254 143 in
ziv@2254 144 ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
ziv@2254 145 end
ziv@2254 146 | EClosure (fnam, args) =>
ziv@2254 147 let
ziv@2254 148 val (ft, s) = lookupENamed fnam
ziv@2254 149 fun attrify (args, ft, e, fm) =
ziv@2254 150 case (args, ft) of
ziv@2254 151 ([], _) => (e, fm)
ziv@2254 152 | (arg :: args, (TFun (t, ft), _)) =>
ziv@2254 153 let
ziv@2254 154 val (arg', fm) = fooify fm (arg, t)
ziv@2254 155 in
ziv@2254 156 attrify (args, ft,
ziv@2254 157 (EStrcat (e,
ziv@2254 158 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
ziv@2254 159 arg'), loc)), loc),
ziv@2254 160 fm)
ziv@2254 161 end
ziv@2262 162 | _ => raise TypeMismatch (fm, loc)
ziv@2254 163 in
ziv@2254 164 attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
ziv@2254 165 end
ziv@2254 166 | _ =>
ziv@2254 167 case t of
ziv@2254 168 TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
ziv@2256 169 | TFfi (m, x) => (if Settings.mayClientToServer (m, x)
ziv@2256 170 (* TODO: better error message. (Then again, user should never see this.) *)
ziv@2262 171 then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
ziv@2262 172 else raise CantPass (fm, tAll))
ziv@2254 173
ziv@2254 174 | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
ziv@2254 175 | TRecord ((x, t) :: xts) =>
ziv@2254 176 let
ziv@2254 177 val (se, fm) = fooify fm ((EField (e, x), loc), t)
ziv@2254 178 in
ziv@2254 179 foldl (fn ((x, t), (se, fm)) =>
ziv@2254 180 let
ziv@2254 181 val (se', fm) = fooify fm ((EField (e, x), loc), t)
ziv@2254 182 in
ziv@2254 183 ((EStrcat (se,
ziv@2254 184 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
ziv@2254 185 se'), loc)), loc),
ziv@2254 186 fm)
ziv@2254 187 end) (se, fm) xts
ziv@2254 188 end
ziv@2254 189
ziv@2254 190 | TDatatype (i, ref (dk, _)) =>
ziv@2254 191 let
ziv@2254 192 fun makeDecl n fm =
ziv@2254 193 let
ziv@2254 194 val (x, xncs) =
ziv@2254 195 case ListUtil.search (fn (x, i', xncs) =>
ziv@2254 196 if i' = i then
ziv@2254 197 SOME (x, xncs)
ziv@2254 198 else
ziv@2254 199 NONE) (!pvarDefs) of
ziv@2254 200 NONE => lookupDatatype i
ziv@2254 201 | SOME v => v
ziv@2254 202
ziv@2254 203 val (branches, fm) =
ziv@2254 204 ListUtil.foldlMap
ziv@2254 205 (fn ((x, n, to), fm) =>
ziv@2254 206 case to of
ziv@2254 207 NONE =>
ziv@2254 208 (((PCon (dk, PConVar n, NONE), loc),
ziv@2254 209 (EPrim (Prim.String (Prim.Normal, x)), loc)),
ziv@2254 210 fm)
ziv@2254 211 | SOME t =>
ziv@2254 212 let
ziv@2254 213 val (arg, fm) = fooify fm ((ERel 0, loc), t)
ziv@2254 214 in
ziv@2254 215 (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc),
ziv@2254 216 (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
ziv@2254 217 arg), loc)),
ziv@2254 218 fm)
ziv@2254 219 end)
ziv@2254 220 fm xncs
ziv@2254 221
ziv@2254 222 val dom = tAll
ziv@2254 223 val ran = (TFfi ("Basis", "string"), loc)
ziv@2254 224 in
ziv@2254 225 ((fk2s fk ^ "ify_" ^ x,
ziv@2254 226 n,
ziv@2254 227 (TFun (dom, ran), loc),
ziv@2254 228 (EAbs ("x",
ziv@2254 229 dom,
ziv@2254 230 ran,
ziv@2254 231 (ECase ((ERel 0, loc),
ziv@2254 232 branches,
ziv@2254 233 {disc = dom,
ziv@2254 234 result = ran}), loc)), loc),
ziv@2254 235 ""),
ziv@2254 236 fm)
ziv@2254 237 end
ziv@2254 238
ziv@2254 239 val (fm, n) = Fm.lookup fm fk i makeDecl
ziv@2254 240 in
ziv@2254 241 ((EApp ((ENamed n, loc), e), loc), fm)
ziv@2254 242 end
ziv@2254 243
ziv@2254 244 | TOption t =>
ziv@2254 245 let
ziv@2254 246 val (body, fm) = fooify fm ((ERel 0, loc), t)
ziv@2254 247 in
ziv@2254 248 ((ECase (e,
ziv@2254 249 [((PNone t, loc),
ziv@2254 250 (EPrim (Prim.String (Prim.Normal, "None")), loc)),
ziv@2254 251
ziv@2254 252 ((PSome (t, (PVar ("x", t), loc)), loc),
ziv@2254 253 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc),
ziv@2254 254 body), loc))],
ziv@2254 255 {disc = tAll,
ziv@2254 256 result = (TFfi ("Basis", "string"), loc)}), loc),
ziv@2254 257 fm)
ziv@2254 258 end
ziv@2254 259
ziv@2254 260 | TList t =>
ziv@2254 261 let
ziv@2254 262 fun makeDecl n fm =
ziv@2254 263 let
ziv@2254 264 val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc)
ziv@2254 265 val (arg, fm) = fooify fm ((ERel 0, loc), rt)
ziv@2254 266
ziv@2254 267 val branches = [((PNone rt, loc),
ziv@2254 268 (EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
ziv@2254 269 ((PSome (rt, (PVar ("a", rt), loc)), loc),
ziv@2254 270 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
ziv@2254 271 arg), loc))]
ziv@2254 272
ziv@2254 273 val dom = tAll
ziv@2254 274 val ran = (TFfi ("Basis", "string"), loc)
ziv@2254 275 in
ziv@2254 276 ((fk2s fk ^ "ify_list",
ziv@2254 277 n,
ziv@2254 278 (TFun (dom, ran), loc),
ziv@2254 279 (EAbs ("x",
ziv@2254 280 dom,
ziv@2254 281 ran,
ziv@2254 282 (ECase ((ERel 0, loc),
ziv@2254 283 branches,
ziv@2254 284 {disc = dom,
ziv@2254 285 result = ran}), loc)), loc),
ziv@2254 286 ""),
ziv@2254 287 fm)
ziv@2254 288 end
ziv@2254 289
ziv@2254 290 val (fm, n) = Fm.lookupList fm fk t makeDecl
ziv@2254 291 in
ziv@2254 292 ((EApp ((ENamed n, loc), e), loc), fm)
ziv@2254 293 end
ziv@2254 294
ziv@2262 295 | _ => raise DontKnow (fm, tAll)
ziv@2254 296 in
ziv@2254 297 fooify
ziv@2254 298 end
ziv@2254 299
ziv@2262 300 fun fooifyExp fk lookupENamed lookupDatatype fm exp =
ziv@2262 301 fooifyExpWithExceptions fk lookupENamed lookupDatatype fm exp
ziv@2262 302 handle TypeMismatch (fm, loc) =>
ziv@2262 303 (E.errorAt loc "Type mismatch encoding attribute";
ziv@2262 304 (dummyExp, fm))
ziv@2262 305 | CantPass (fm, typ as (_, loc)) =>
ziv@2262 306 (E.errorAt loc "MonoFooify: can't pass type from client to server";
ziv@2262 307 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
ziv@2262 308 (dummyExp, fm))
ziv@2262 309 | DontKnow (fm, typ as (_, loc)) =>
ziv@2262 310 (E.errorAt loc "Don't know how to encode attribute/URL type";
ziv@2262 311 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
ziv@2262 312 (dummyExp, fm))
ziv@2262 313
ziv@2262 314
ziv@2256 315 (* Has to be set at the end of [Monoize]. *)
ziv@2256 316 val canonicalFm = ref (Fm.empty 0 : Fm.t)
ziv@2256 317
ziv@2254 318 fun urlify env expTyp =
ziv@2262 319 let
ziv@2262 320 val (exp, fm) =
ziv@2262 321 fooifyExpWithExceptions
ziv@2262 322 Url
ziv@2262 323 (fn n =>
ziv@2262 324 let
ziv@2262 325 val (_, t, _, s) = MonoEnv.lookupENamed env n
ziv@2262 326 in
ziv@2262 327 (t, s)
ziv@2262 328 end)
ziv@2262 329 (fn n => MonoEnv.lookupDatatype env n)
ziv@2262 330 (!canonicalFm)
ziv@2262 331 expTyp
ziv@2262 332 in
ziv@2262 333 canonicalFm := fm;
ziv@2262 334 SOME exp
ziv@2262 335 end
ziv@2262 336 handle TypeMismatch _ => NONE
ziv@2262 337 | CantPass _ => NONE
ziv@2262 338 | DontKnow _ => NONE
ziv@2256 339
ziv@2256 340 fun getNewFmDecls () =
ziv@2254 341 let
ziv@2256 342 val fm = !canonicalFm
ziv@2254 343 in
ziv@2261 344 canonicalFm := Fm.enter fm;
ziv@2256 345 Fm.decls fm
ziv@2254 346 end
ziv@2256 347
ziv@2254 348 end