Mercurial > urweb

annotate src/mono_fooify.sml @ 2289:78820fa8f5a7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix bugs for lock calculation and SQL parsing and add support for tasks.
author Ziv Scully <ziv@mit.edu>
date Sun, 15 Nov 2015 14:18:35 -0500
parents a647a1560628
children
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@2262 170 then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
ziv@2262 171 else raise CantPass (fm, tAll))
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@2262 294 | _ => raise DontKnow (fm, tAll)
ziv@2254 295 in
ziv@2254 296 fooify
ziv@2254 297 end
ziv@2254 298
ziv@2262 299 fun fooifyExp fk lookupENamed lookupDatatype fm exp =
ziv@2262 300 fooifyExpWithExceptions fk lookupENamed lookupDatatype fm exp
ziv@2262 301 handle TypeMismatch (fm, loc) =>
ziv@2262 302 (E.errorAt loc "Type mismatch encoding attribute";
ziv@2262 303 (dummyExp, fm))
ziv@2262 304 | CantPass (fm, typ as (_, loc)) =>
ziv@2262 305 (E.errorAt loc "MonoFooify: can't pass type from client to server";
ziv@2262 306 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
ziv@2262 307 (dummyExp, fm))
ziv@2262 308 | DontKnow (fm, typ as (_, loc)) =>
ziv@2262 309 (E.errorAt loc "Don't know how to encode attribute/URL type";
ziv@2262 310 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
ziv@2262 311 (dummyExp, fm))
ziv@2262 312
ziv@2256 313 (* Has to be set at the end of [Monoize]. *)
ziv@2256 314 val canonicalFm = ref (Fm.empty 0 : Fm.t)
ziv@2256 315
ziv@2254 316 fun urlify env expTyp =
ziv@2262 317 let
ziv@2262 318 val (exp, fm) =
ziv@2262 319 fooifyExpWithExceptions
ziv@2262 320 Url
ziv@2262 321 (fn n =>
ziv@2262 322 let
ziv@2262 323 val (_, t, _, s) = MonoEnv.lookupENamed env n
ziv@2262 324 in
ziv@2262 325 (t, s)
ziv@2262 326 end)
ziv@2262 327 (fn n => MonoEnv.lookupDatatype env n)
ziv@2262 328 (!canonicalFm)
ziv@2262 329 expTyp
ziv@2262 330 in
ziv@2262 331 canonicalFm := fm;
ziv@2262 332 SOME exp
ziv@2262 333 end
ziv@2262 334 handle TypeMismatch _ => NONE
ziv@2262 335 | CantPass _ => NONE
ziv@2262 336 | DontKnow _ => NONE
ziv@2256 337
ziv@2256 338 fun getNewFmDecls () =
ziv@2254 339 let
ziv@2256 340 val fm = !canonicalFm
ziv@2254 341 in
ziv@2261 342 canonicalFm := Fm.enter fm;
ziv@2256 343 Fm.decls fm
ziv@2254 344 end
ziv@2256 345
ziv@2254 346 end