Mercurial > urweb

annotate src/mono_fooify.sml @ 2264:bbcf9ba9b39a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix another mismatch between expunger SQL generation and SQL parser.
author Ziv Scully <ziv@mit.edu>
date Tue, 13 Oct 2015 20:24:37 -0400
parents 34ad83d9b729
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