Mercurial > urweb

annotate src/cjrize.sml @ 2101:32e2752390ad

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fixing one small issue with changes to signature matching (grandfathered into release)
author Adam Chlipala <adam@chlipala.net>
date Sat, 03 Jan 2015 10:21:26 -0500
parents a9159911c3ba
children 278e10629ba1
rev   line source
adam@1348 1 (* Copyright (c) 2008-2010, Adam Chlipala
adamc@29 2 * All rights reserved.
adamc@29 3 *
adamc@29 4 * Redistribution and use in source and binary forms, with or without
adamc@29 5 * modification, are permitted provided that the following conditions are met:
adamc@29 6 *
adamc@29 7 * - Redistributions of source code must retain the above copyright notice,
adamc@29 8 * this list of conditions and the following disclaimer.
adamc@29 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@29 10 * this list of conditions and the following disclaimer in the documentation
adamc@29 11 * and/or other materials provided with the distribution.
adamc@29 12 * - The names of contributors may not be used to endorse or promote products
adamc@29 13 * derived from this software without specific prior written permission.
adamc@29 14 *
adamc@29 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@29 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@29 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@29 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@29 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@29 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@29 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@29 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@29 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@29 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@29 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@29 26 *)
adamc@29 27
adamc@29 28 structure Cjrize :> CJRIZE = struct
adamc@29 29
adamc@109 30 structure L = Mono
adamc@29 31 structure L' = Cjr
adamc@29 32
adamc@196 33 structure IM = IntBinaryMap
adamc@196 34
adamc@29 35 structure Sm :> sig
adamc@29 36 type t
adamc@29 37
adamc@29 38 val empty : t
adamc@29 39 val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int
adamc@757 40 val findList : t * L.typ * L'.typ -> t * int
adamc@29 41
adamc@29 42 val declares : t -> (int * (string * L'.typ) list) list
adamc@453 43 val clearDeclares : t -> t
adamc@29 44 end = struct
adamc@29 45
adamc@29 46 structure FM = BinaryMapFn(struct
adamc@29 47 type ord_key = L.typ
adamc@109 48 val compare = MonoUtil.Typ.compare
adamc@29 49 end)
adamc@29 50
adamc@757 51 type t = {
adamc@757 52 count : int,
adamc@757 53 normal : int FM.map,
adamc@757 54 lists : int FM.map,
adamc@757 55 decls : (int * (string * L'.typ) list) list
adamc@757 56 }
adamc@29 57
adamc@757 58 val empty : t = {
adamc@757 59 count = 1,
adamc@757 60 normal = FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0),
adamc@757 61 lists = FM.empty,
adamc@757 62 decls = []
adamc@757 63 }
adamc@29 64
adamc@757 65 fun find (v as {count, normal, decls, lists}, xts, xts') =
adamc@29 66 let
adamc@29 67 val t = (L.TRecord xts, ErrorMsg.dummySpan)
adamc@29 68 in
adamc@757 69 case FM.find (normal, t) of
adamc@757 70 SOME i => (v, i)
adamc@757 71 | NONE => ({count = count+1,
adamc@757 72 normal = FM.insert (normal, t, count),
adamc@757 73 lists = lists,
adamc@757 74 decls = (count, xts') :: decls},
adamc@757 75 count)
adamc@29 76 end
adamc@29 77
adamc@757 78 fun findList (v as {count, normal, decls, lists}, t, t') =
adamc@757 79 case FM.find (lists, t) of
adamc@757 80 SOME i => (v, i)
adamc@757 81 | NONE =>
adamc@757 82 let
adamc@757 83 val xts = [("1", t), ("2", (L.TList t, #2 t))]
adamc@757 84 val xts' = [("1", t'), ("2", (L'.TList (t', count), #2 t'))]
adamc@757 85 in
adamc@757 86 ({count = count+1,
adamc@757 87 normal = FM.insert (normal, (L.TRecord xts, ErrorMsg.dummySpan), count),
adamc@757 88 lists = FM.insert (lists, t, count),
adamc@757 89 decls = (count, xts') :: decls},
adamc@757 90 count)
adamc@757 91 end
adamc@29 92
adamc@757 93 fun declares (v : t) = #decls v
adamc@757 94
adamc@757 95 fun clearDeclares (v : t) = {count = #count v,
adamc@757 96 normal = #normal v,
adamc@757 97 lists = #lists v,
adamc@757 98 decls = []}
adamc@453 99
adamc@29 100 end
adamc@29 101
adamc@196 102 fun cifyTyp x =
adamc@196 103 let
adamc@196 104 fun cify dtmap ((t, loc), sm) =
adamc@196 105 case t of
adamc@196 106 L.TFun (t1, t2) =>
adamc@196 107 let
adamc@196 108 val (t1, sm) = cify dtmap (t1, sm)
adamc@196 109 val (t2, sm) = cify dtmap (t2, sm)
adamc@196 110 in
adamc@196 111 ((L'.TFun (t1, t2), loc), sm)
adamc@196 112 end
adamc@196 113 | L.TRecord xts =>
adamc@196 114 let
adam@1314 115 val xts = MonoUtil.Typ.sortFields xts
adamc@196 116 val old_xts = xts
adamc@196 117 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adamc@196 118 let
adamc@196 119 val (t, sm) = cify dtmap (t, sm)
adamc@196 120 in
adamc@196 121 ((x, t), sm)
adamc@196 122 end)
adamc@196 123 sm xts
adamc@196 124 val (sm, si) = Sm.find (sm, old_xts, xts)
adamc@196 125 in
adamc@196 126 ((L'.TRecord si, loc), sm)
adamc@196 127 end
adamc@196 128 | L.TDatatype (n, ref (dk, xncs)) =>
adamc@196 129 (case IM.find (dtmap, n) of
adamc@196 130 SOME r => ((L'.TDatatype (dk, n, r), loc), sm)
adamc@196 131 | NONE =>
adamc@196 132 let
adamc@196 133 val r = ref []
adamc@196 134 val dtmap = IM.insert (dtmap, n, r)
adamc@196 135
adamc@196 136 val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
adamc@196 137 case to of
adamc@196 138 NONE => ((x, n, NONE), sm)
adamc@196 139 | SOME t =>
adamc@196 140 let
adamc@196 141 val (t, sm) = cify dtmap (t, sm)
adamc@196 142 in
adamc@196 143 ((x, n, SOME t), sm)
adamc@196 144 end)
adamc@196 145 sm xncs
adamc@196 146 in
adamc@196 147 r := xncs;
adamc@196 148 ((L'.TDatatype (dk, n, r), loc), sm)
adamc@196 149 end)
adamc@196 150 | L.TFfi mx => ((L'.TFfi mx, loc), sm)
adamc@288 151 | L.TOption t =>
adamc@288 152 let
adamc@288 153 val (t, sm) = cify dtmap (t, sm)
adamc@288 154 in
adamc@288 155 ((L'.TOption t, loc), sm)
adamc@288 156 end
adamc@757 157 | L.TList t =>
adamc@757 158 let
adamc@757 159 val (t', sm) = cify dtmap (t, sm)
adamc@757 160 val (sm, si) = Sm.findList (sm, t, t')
adamc@757 161 in
adamc@757 162 ((L'.TList (t', si), loc), sm)
adamc@757 163 end
adam@1446 164 | L.TSource => ((L'.TFfi ("Basis", "source"), loc), sm)
adam@1821 165 | L.TSignal _ => (ErrorMsg.errorAt loc "TSignal remains";
adam@1821 166 Print.epreface ("Full type", MonoPrint.p_typ MonoEnv.empty (#1 x));
adam@1821 167 ((L'.TFfi ("Basis", "bogus"), loc), sm))
adamc@196 168 in
adamc@196 169 cify IM.empty x
adamc@196 170 end
adamc@29 171
adamc@109 172 val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
adamc@109 173
adamc@186 174 fun cifyPatCon (pc, sm) =
adamc@181 175 case pc of
adamc@186 176 L.PConVar n => (L'.PConVar n, sm)
adamc@186 177 | L.PConFfi {mod = m, datatyp, con, arg} =>
adamc@186 178 let
adamc@186 179 val (arg, sm) =
adamc@186 180 case arg of
adamc@186 181 NONE => (NONE, sm)
adamc@186 182 | SOME t =>
adamc@186 183 let
adamc@186 184 val (t, sm) = cifyTyp (t, sm)
adamc@186 185 in
adamc@186 186 (SOME t, sm)
adamc@186 187 end
adamc@186 188 in
adamc@186 189 (L'.PConFfi {mod = m, datatyp = datatyp, con = con, arg = arg}, sm)
adamc@186 190 end
adamc@181 191
adamc@182 192 fun cifyPat ((p, loc), sm) =
adamc@181 193 case p of
adamc@182 194 L.PWild => ((L'.PWild, loc), sm)
adamc@182 195 | L.PVar (x, t) =>
adamc@182 196 let
adamc@182 197 val (t, sm) = cifyTyp (t, sm)
adamc@182 198 in
adamc@182 199 ((L'.PVar (x, t), loc), sm)
adamc@182 200 end
adamc@182 201 | L.PPrim p => ((L'.PPrim p, loc), sm)
adamc@188 202 | L.PCon (dk, pc, NONE) =>
adamc@186 203 let
adamc@186 204 val (pc, sm) = cifyPatCon (pc, sm)
adamc@186 205 in
adamc@188 206 ((L'.PCon (dk, pc, NONE), loc), sm)
adamc@186 207 end
adamc@188 208 | L.PCon (dk, pc, SOME p) =>
adamc@182 209 let
adamc@186 210 val (pc, sm) = cifyPatCon (pc, sm)
adamc@182 211 val (p, sm) = cifyPat (p, sm)
adamc@182 212 in
adamc@188 213 ((L'.PCon (dk, pc, SOME p), loc), sm)
adamc@182 214 end
adamc@182 215 | L.PRecord xps =>
adamc@182 216 let
adamc@182 217 val (xps, sm) = ListUtil.foldlMap (fn ((x, p, t), sm) =>
adamc@182 218 let
adamc@182 219 val (p, sm) = cifyPat (p, sm)
adamc@182 220 val (t, sm) = cifyTyp (t, sm)
adamc@182 221 in
adamc@182 222 ((x, p, t), sm)
adamc@182 223 end) sm xps
adamc@182 224 in
adamc@182 225 ((L'.PRecord xps, loc), sm)
adamc@182 226 end
adamc@288 227 | L.PNone t =>
adamc@288 228 let
adamc@288 229 val (t, sm) = cifyTyp (t, sm)
adamc@288 230 in
adamc@288 231 ((L'.PNone t, loc), sm)
adamc@288 232 end
adamc@288 233 | L.PSome (t, p) =>
adamc@288 234 let
adamc@288 235 val (t, sm) = cifyTyp (t, sm)
adamc@288 236 val (p, sm) = cifyPat (p, sm)
adamc@288 237 in
adamc@288 238 ((L'.PSome (t, p), loc), sm)
adamc@288 239 end
adamc@288 240
adamc@280 241 fun cifyExp (eAll as (e, loc), sm) =
adam@1601 242 let
adam@1601 243 fun fail msg =
adam@1601 244 (ErrorMsg.errorAt loc msg;
adam@2048 245 ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), sm))
adam@1601 246 in
adam@1601 247 case e of
adam@1601 248 L.EPrim p => ((L'.EPrim p, loc), sm)
adam@1601 249 | L.ERel n => ((L'.ERel n, loc), sm)
adam@1601 250 | L.ENamed n => ((L'.ENamed n, loc), sm)
adam@1601 251 | L.ECon (dk, pc, eo) =>
adam@1601 252 let
adam@1601 253 val (eo, sm) =
adam@1601 254 case eo of
adam@1601 255 NONE => (NONE, sm)
adam@1601 256 | SOME e =>
adam@1601 257 let
adam@1601 258 val (e, sm) = cifyExp (e, sm)
adam@1601 259 in
adam@1601 260 (SOME e, sm)
adam@1601 261 end
adam@1601 262 val (pc, sm) = cifyPatCon (pc, sm)
adam@1601 263 in
adam@1601 264 ((L'.ECon (dk, pc, eo), loc), sm)
adam@1601 265 end
adam@1601 266 | L.ENone t =>
adam@1601 267 let
adam@1601 268 val (t, sm) = cifyTyp (t, sm)
adam@1601 269 in
adam@1601 270 ((L'.ENone t, loc), sm)
adam@1601 271 end
adam@1601 272 | L.ESome (t, e) =>
adam@1601 273 let
adam@1601 274 val (t, sm) = cifyTyp (t, sm)
adam@1601 275 val (e, sm) = cifyExp (e, sm)
adam@1601 276 in
adam@1601 277 ((L'.ESome (t, e), loc), sm)
adam@1601 278 end
adam@1601 279 | L.EFfi mx => ((L'.EFfi mx, loc), sm)
adam@1601 280 | L.EFfiApp (m, x, es) =>
adam@1601 281 let
adam@1663 282 val (es, sm) = ListUtil.foldlMap (fn ((e, t), sm) =>
adam@1663 283 let
adam@1663 284 val (t, sm) = cifyTyp (t, sm)
adam@1663 285 val (e, sm) = cifyExp (e, sm)
adam@1663 286 in
adam@1663 287 ((e, t), sm)
adam@1663 288 end) sm es
adam@1601 289 in
adam@1601 290 ((L'.EFfiApp (m, x, es), loc), sm)
adam@1601 291 end
adam@1601 292 | L.EApp (e1, e2) =>
adam@1601 293 let
adam@1601 294 fun unravel (e, args) =
adam@1601 295 case e of
adam@1601 296 (L.EApp (e1, e2), _) => unravel (e1, e2 :: args)
adam@1601 297 | _ => (e, args)
adamc@316 298
adam@1601 299 val (f, es) = unravel (e1, [e2])
adamc@316 300
adam@1601 301 val (f, sm) = cifyExp (f, sm)
adam@1601 302 val (es, sm) = ListUtil.foldlMap cifyExp sm es
adam@1601 303 in
adam@1601 304 ((L'.EApp (f, es), loc), sm)
adam@1601 305 end
adam@1601 306 | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
adam@1601 307 Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
adam@1601 308 (dummye, sm))
adamc@29 309
adam@1601 310 | L.EUnop (s, e1) =>
adam@1601 311 let
adam@1601 312 val (e1, sm) = cifyExp (e1, sm)
adam@1601 313 in
adam@1601 314 ((L'.EUnop (s, e1), loc), sm)
adam@1601 315 end
adam@1601 316 | L.EBinop (_, s, e1, e2) =>
adam@1601 317 let
adam@1601 318 val (e1, sm) = cifyExp (e1, sm)
adam@1601 319 val (e2, sm) = cifyExp (e2, sm)
adam@1601 320 in
adam@1601 321 ((L'.EBinop (s, e1, e2), loc), sm)
adam@1601 322 end
adamc@387 323
adam@1601 324 | L.ERecord xes =>
adam@1601 325 let
adam@1601 326 val old_xts = map (fn (x, _, t) => (x, t)) xes
adamc@29 327
adam@1601 328 val (xets, sm) = ListUtil.foldlMap (fn ((x, e, t), sm) =>
adam@1601 329 let
adam@1601 330 val (e, sm) = cifyExp (e, sm)
adam@1601 331 val (t, sm) = cifyTyp (t, sm)
adam@1601 332 in
adam@1601 333 ((x, e, t), sm)
adam@1601 334 end)
adam@1601 335 sm xes
adamc@29 336
adam@1601 337 val (sm, si) = Sm.find (sm, old_xts, map (fn (x, _, t) => (x, t)) xets)
adamc@29 338
adam@1601 339 val xes = map (fn (x, e, _) => (x, e)) xets
adam@1601 340 val xes = ListMergeSort.sort (fn ((x1, _), (x2, _)) => String.compare (x1, x2) = GREATER) xes
adam@1601 341 in
adam@1601 342 ((L'.ERecord (si, xes), loc), sm)
adam@1601 343 end
adam@1601 344 | L.EField (e, x) =>
adam@1601 345 let
adam@1601 346 val (e, sm) = cifyExp (e, sm)
adam@1601 347 in
adam@1601 348 ((L'.EField (e, x), loc), sm)
adam@1601 349 end
adamc@29 350
adam@1601 351 | L.ECase (e, pes, {disc, result}) =>
adam@1601 352 let
adamc@181 353 val (e, sm) = cifyExp (e, sm)
adamc@181 354 val (pes, sm) = ListUtil.foldlMap
adamc@181 355 (fn ((p, e), sm) =>
adamc@181 356 let
adamc@181 357 val (e, sm) = cifyExp (e, sm)
adamc@182 358 val (p, sm) = cifyPat (p, sm)
adamc@181 359 in
adamc@182 360 ((p, e), sm)
adamc@181 361 end) sm pes
adamc@182 362 val (disc, sm) = cifyTyp (disc, sm)
adamc@182 363 val (result, sm) = cifyTyp (result, sm)
adamc@181 364 in
adamc@182 365 ((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm)
adamc@181 366 end
adamc@178 367
adam@1601 368 | L.EError (e, t) =>
adam@1601 369 let
adam@1601 370 val (e, sm) = cifyExp (e, sm)
adam@1601 371 val (t, sm) = cifyTyp (t, sm)
adam@1601 372 in
adam@1601 373 ((L'.EError (e, t), loc), sm)
adam@1601 374 end
adam@1932 375 | L.EReturnBlob {blob = NONE, mimeType, t} =>
adam@1932 376 let
adam@1932 377 val (mimeType, sm) = cifyExp (mimeType, sm)
adam@1932 378 val (t, sm) = cifyTyp (t, sm)
adam@1932 379 in
adam@1932 380 ((L'.EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), sm)
adam@1932 381 end
adam@1932 382 | L.EReturnBlob {blob = SOME blob, mimeType, t} =>
adam@1601 383 let
adam@1601 384 val (blob, sm) = cifyExp (blob, sm)
adam@1601 385 val (mimeType, sm) = cifyExp (mimeType, sm)
adam@1601 386 val (t, sm) = cifyTyp (t, sm)
adam@1601 387 in
adam@1932 388 ((L'.EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), sm)
adam@1601 389 end
adam@1601 390 | L.ERedirect (e, t) =>
adam@1601 391 let
adam@1601 392 val (e, sm) = cifyExp (e, sm)
adam@1601 393 val (t, sm) = cifyTyp (t, sm)
adam@1601 394 in
adam@1601 395 ((L'.ERedirect (e, t), loc), sm)
adam@1601 396 end
adamc@283 397
adam@1601 398 | L.EStrcat (e1, e2) =>
adam@1601 399 let
adam@1601 400 val (e1, sm) = cifyExp (e1, sm)
adam@1601 401 val (e2, sm) = cifyExp (e2, sm)
adam@1663 402 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1601 403 in
adam@1663 404 ((L'.EFfiApp ("Basis", "strcat", [(e1, s), (e2, s)]), loc), sm)
adam@1601 405 end
adamc@102 406
adam@1601 407 | L.EWrite e =>
adam@1601 408 let
adam@1601 409 val (e, sm) = cifyExp (e, sm)
adam@1601 410 in
adam@1601 411 ((L'.EWrite e, loc), sm)
adam@1601 412 end
adamc@102 413
adam@1601 414 | L.ESeq (e1, e2) =>
adam@1601 415 let
adam@1601 416 val (e1, sm) = cifyExp (e1, sm)
adam@1601 417 val (e2, sm) = cifyExp (e2, sm)
adam@1601 418 in
adam@1601 419 ((L'.ESeq (e1, e2), loc), sm)
adam@1601 420 end
adamc@106 421
adam@1601 422 | L.ELet (x, t, e1, e2) =>
adam@1601 423 let
adam@1601 424 val (t, sm) = cifyTyp (t, sm)
adam@1601 425 val (e1, sm) = cifyExp (e1, sm)
adam@1601 426 val (e2, sm) = cifyExp (e2, sm)
adam@1601 427 in
adam@1601 428 ((L'.ELet (x, t, e1, e2), loc), sm)
adam@1601 429 end
adamc@251 430
adam@1601 431 | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
adam@1601 432 (dummye, sm))
adamc@111 433
adam@1601 434 | L.EQuery {exps, tables, state, query, body, initial} =>
adam@1601 435 let
adam@1601 436 val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adam@1601 437 let
adam@1601 438 val (t, sm) = cifyTyp (t, sm)
adam@1601 439 in
adam@1601 440 ((x, t), sm)
adam@1601 441 end) sm exps
adam@1601 442 val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) =>
adam@1601 443 let
adam@1601 444 val (xts, sm) = ListUtil.foldlMap
adam@1601 445 (fn ((x, t), sm) =>
adam@1601 446 let
adam@1601 447 val (t, sm) = cifyTyp (t, sm)
adam@1601 448 in
adam@1601 449 ((x, t), sm)
adam@1601 450 end) sm xts
adam@1601 451 in
adam@1601 452 ((x, xts), sm)
adam@1601 453 end) sm tables
adamc@269 454
adam@1601 455 val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables
adam@1601 456 val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
adamc@269 457
adam@1601 458 val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) =>
adam@1601 459 let
adam@1601 460 val (sm, rnum) = Sm.find (sm, xts, xts')
adam@1601 461 in
adam@1601 462 ((x, rnum), sm)
adam@1601 463 end)
adam@1601 464 sm (ListPair.zip (tables, tables'))
adam@1601 465 val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows
adam@1601 466 val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row'
adamc@269 467
adam@1601 468 val (sm, rnum) = Sm.find (sm, row, row')
adamc@269 469
adam@1601 470 val (state, sm) = cifyTyp (state, sm)
adam@1601 471 val (query, sm) = cifyExp (query, sm)
adam@1601 472 val (body, sm) = cifyExp (body, sm)
adam@1601 473 val (initial, sm) = cifyExp (initial, sm)
adam@1601 474 in
adam@1601 475 ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state,
adam@1601 476 query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
adam@1601 477 end
adamc@269 478
adam@1601 479 | L.EDml (e, mode) =>
adam@1601 480 let
adam@1601 481 val (e, sm) = cifyExp (e, sm)
adam@1601 482 in
adam@1601 483 ((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm)
adam@1601 484 end
adamc@307 485
adam@1601 486 | L.ENextval e =>
adam@1601 487 let
adam@1601 488 val (e, sm) = cifyExp (e, sm)
adam@1601 489 in
adam@1601 490 ((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
adam@1601 491 end
adam@1601 492 | L.ESetval (e1, e2) =>
adam@1601 493 let
adam@1601 494 val (e1, sm) = cifyExp (e1, sm)
adam@1601 495 val (e2, sm) = cifyExp (e2, sm)
adam@1601 496 in
adam@1601 497 ((L'.ESetval {seq = e1, count = e2}, loc), sm)
adam@1601 498 end
adamc@338 499
adam@1601 500 | L.EUnurlify (e, t, b) =>
adam@1601 501 let
adam@1601 502 val (e, sm) = cifyExp (e, sm)
adam@1601 503 val (t, sm) = cifyTyp (t, sm)
adam@1601 504 in
adam@1601 505 ((L'.EUnurlify (e, t, b), loc), sm)
adam@1601 506 end
adamc@252 507
adam@1601 508 | L.EJavaScript _ => fail "Uncompilable JavaScript remains"
adamc@578 509
adam@1601 510 | L.ESignalReturn _ => fail "Signal monad 'return' remains in server-side code"
adam@1601 511 | L.ESignalBind _ => fail "Signal monad 'bind' remains in server-side code"
adam@1601 512 | L.ESignalSource _ => fail "Signal monad 'source' remains in server-side code"
adamc@566 513
adam@1601 514 | L.EServerCall _ => fail "RPC in server-side code"
adam@1601 515 | L.ERecv _ => fail "Message receive in server-side code"
adam@1601 516 | L.ESleep _ => fail "Sleep in server-side code"
adam@1601 517 | L.ESpawn _ => fail "Thread spawn in server-side code"
adam@1601 518 end
adamc@608 519
adamc@29 520 fun cifyDecl ((d, loc), sm) =
adamc@29 521 case d of
adamc@809 522 L.DDatatype dts =>
adamc@165 523 let
adamc@809 524 val (dts, sm) = ListUtil.foldlMap
adamc@809 525 (fn ((x, n, xncs), sm) =>
adamc@809 526 let
adamc@809 527 val dk = ElabUtil.classifyDatatype xncs
adamc@809 528 val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
adamc@809 529 case to of
adamc@809 530 NONE => ((x, n, NONE), sm)
adamc@809 531 | SOME t =>
adamc@809 532 let
adamc@809 533 val (t, sm) = cifyTyp (t, sm)
adamc@809 534 in
adamc@809 535 ((x, n, SOME t), sm)
adamc@809 536 end) sm xncs
adamc@809 537 in
adamc@809 538 ((dk, x, n, xncs), sm)
adamc@809 539 end)
adamc@809 540 sm dts
adamc@165 541 in
adamc@809 542 (SOME (L'.DDatatype dts, loc), NONE, sm)
adamc@809 543 end
adamc@164 544
adamc@164 545 | L.DVal (x, n, t, e, _) =>
adamc@29 546 let
adamc@29 547 val (t, sm) = cifyTyp (t, sm)
adamc@109 548
adamc@109 549 val (d, sm) = case #1 t of
adamc@121 550 L'.TFun _ =>
adamc@121 551 let
adamc@121 552 fun unravel (tAll as (t, _), eAll as (e, _)) =
adamc@121 553 case (t, e) of
adamc@121 554 (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) =>
adamc@121 555 let
adamc@121 556 val (args, t, e) = unravel (ran, e)
adamc@121 557 in
adamc@121 558 ((ax, dom) :: args, t, e)
adamc@121 559 end
adamc@993 560 | (L'.TFun (dom, ran), _) =>
adamc@993 561 let
adamc@993 562 val e = MonoEnv.liftExpInExp 0 eAll
adamc@993 563 val e = (L.EApp (e, (L.ERel 0, loc)), loc)
adamc@993 564 val (args, t, e) = unravel (ran, e)
adamc@993 565 in
adamc@993 566 (("x", dom) :: args, t, e)
adamc@993 567 end
adamc@121 568 | _ => ([], tAll, eAll)
adamc@121 569
adamc@121 570 val (args, ran, e) = unravel (t, e)
adamc@121 571 val (e, sm) = cifyExp (e, sm)
adamc@121 572 in
adamc@121 573 (L'.DFun (x, n, args, ran, e), sm)
adamc@121 574 end
adamc@121 575
adamc@109 576 | _ =>
adamc@109 577 let
adamc@109 578 val (e, sm) = cifyExp (e, sm)
adamc@109 579 in
adamc@109 580 (L'.DVal (x, n, t, e), sm)
adamc@109 581 end
adamc@29 582 in
adamc@109 583 (SOME (d, loc), NONE, sm)
adamc@29 584 end
adamc@129 585 | L.DValRec vis =>
adamc@129 586 let
adamc@129 587 val (vis, sm) = ListUtil.foldlMap
adamc@129 588 (fn ((x, n, t, e, _), sm) =>
adamc@129 589 let
adamc@129 590 val (t, sm) = cifyTyp (t, sm)
adamc@129 591
adamc@129 592 fun unravel (tAll as (t, _), eAll as (e, _)) =
adamc@129 593 case (t, e) of
adamc@129 594 (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) =>
adamc@129 595 let
adamc@129 596 val (args, t, e) = unravel (ran, e)
adamc@129 597 in
adamc@129 598 ((ax, dom) :: args, t, e)
adamc@129 599 end
adamc@129 600 | (L'.TFun _, _) =>
adamc@129 601 (ErrorMsg.errorAt loc "Function isn't explicit at code generation";
adamc@129 602 ([], tAll, eAll))
adamc@129 603 | _ => ([], tAll, eAll)
adamc@129 604
adamc@129 605 val (args, ran, e) = unravel (t, e)
adamc@129 606 val (e, sm) = cifyExp (e, sm)
adamc@129 607 in
adamc@129 608 ((x, n, args, ran, e), sm)
adamc@129 609 end)
adamc@129 610 sm vis
adamc@129 611 in
adamc@129 612 (SOME (L'.DFunRec vis, loc), NONE, sm)
adamc@129 613 end
adamc@129 614
adamc@1104 615 | L.DExport (ek, s, n, ts, t, b) =>
adamc@120 616 let
adamc@120 617 val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
adamc@609 618 val (t, sm) = cifyTyp (t, sm)
adamc@120 619 in
adamc@1104 620 (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush, b), sm)
adamc@120 621 end
adamc@29 622
adamc@707 623 | L.DTable (s, xts, pe, ce) =>
adamc@273 624 let
adamc@273 625 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adamc@273 626 let
adamc@273 627 val (t, sm) = cifyTyp (t, sm)
adamc@273 628 in
adamc@273 629 ((x, t), sm)
adamc@273 630 end) sm xts
adamc@704 631
adamc@704 632 fun flatten e =
adamc@704 633 case #1 e of
adamc@704 634 L.ERecord [] => []
adam@2048 635 | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)]
adamc@704 636 | L.EStrcat (e1, e2) => flatten e1 @ flatten e2
adamc@704 637 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
adamc@704 638 Print.prefaces "Undetermined constraint"
adamc@707 639 [("e", MonoPrint.p_exp MonoEnv.empty e)];
adamc@704 640 [])
adamc@707 641
adamc@707 642 val pe = case #1 pe of
adam@2048 643 L.EPrim (Prim.String (_, s)) => s
adamc@707 644 | _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined";
adamc@707 645 Print.prefaces "Undetermined constraint"
adamc@707 646 [("e", MonoPrint.p_exp MonoEnv.empty pe)];
adamc@707 647 "")
adamc@273 648 in
adamc@707 649 (SOME (L'.DTable (s, xts, pe, flatten ce), loc), NONE, sm)
adamc@273 650 end
adamc@338 651 | L.DSequence s =>
adamc@338 652 (SOME (L'.DSequence s, loc), NONE, sm)
adamc@754 653 | L.DView (s, xts, e) =>
adamc@754 654 let
adamc@754 655 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adamc@754 656 let
adamc@754 657 val (t, sm) = cifyTyp (t, sm)
adamc@754 658 in
adamc@754 659 ((x, t), sm)
adamc@754 660 end) sm xts
adamc@754 661
adamc@754 662 fun flatten e =
adamc@754 663 case #1 e of
adamc@754 664 L.ERecord [] => []
adam@2048 665 | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)]
adamc@754 666 | L.EStrcat (e1, e2) => flatten e1 @ flatten e2
adamc@754 667 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
adamc@754 668 Print.prefaces "Undetermined constraint"
adamc@754 669 [("e", MonoPrint.p_exp MonoEnv.empty e)];
adamc@754 670 [])
adamc@754 671
adamc@754 672 val e = case #1 e of
adam@2048 673 L.EPrim (Prim.String (_, s)) => s
adamc@754 674 | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined";
adamc@754 675 Print.prefaces "Undetermined VIEW query"
adamc@754 676 [("e", MonoPrint.p_exp MonoEnv.empty e)];
adamc@754 677 "")
adamc@754 678 in
adamc@754 679 (SOME (L'.DView (s, xts, e), loc), NONE, sm)
adamc@754 680 end
adamc@271 681 | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm)
adamc@569 682 | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
adamc@725 683 | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm)
adamc@718 684 | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm)
adamc@1075 685 | L.DTask (e1, e2) =>
adamc@1075 686 (case #1 e2 of
adam@1348 687 L.EAbs (x1, _, _, (L.EAbs (x2, _, _, e), _)) =>
adamc@1073 688 let
adamc@1075 689 val tk = case #1 e1 of
adamc@1075 690 L.EFfi ("Basis", "initialize") => L'.Initialize
adam@1348 691 | L.EFfi ("Basis", "clientLeaves") => L'.ClientLeaves
adam@1663 692 | L.EFfiApp ("Basis", "periodic", [((L.EPrim (Prim.Int n), _), _)]) => L'.Periodic n
adamc@1075 693 | _ => (ErrorMsg.errorAt loc "Task kind not fully determined";
adamc@1075 694 L'.Initialize)
adamc@1073 695 val (e, sm) = cifyExp (e, sm)
adamc@1073 696 in
adam@1348 697 (SOME (L'.DTask (tk, x1, x2, e), loc), NONE, sm)
adamc@1073 698 end
adamc@1073 699 | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
adamc@1073 700 (NONE, NONE, sm)))
adamc@1199 701 | L.DPolicy _ => (NONE, NONE, sm)
adam@1294 702 | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm)
adamc@271 703
adam@1845 704 fun cjrize (ds, sideInfo) =
adamc@29 705 let
adamc@196 706 val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) =>
adamc@196 707 let
adamc@196 708 val (dop, pop, sm) = cifyDecl (d, sm)
adamc@453 709
adamc@640 710 val dsF = case dop of
adamc@809 711 SOME (L'.DDatatype dts, loc) =>
adamc@809 712 map (fn (dk, x, n, _) =>
adamc@809 713 (L'.DDatatypeForward (dk, x, n), loc)) dts @ dsF
adamc@640 714 | _ => dsF
adamc@640 715
adamc@640 716 val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm)
adamc@640 717 @ dsF
adamc@640 718
adamc@196 719 val (dsF, ds) = case dop of
adamc@196 720 NONE => (dsF, ds)
adamc@453 721 | SOME (d as (L'.DDatatype _, loc)) =>
adamc@453 722 (d :: dsF, ds)
adamc@196 723 | SOME d => (dsF, d :: ds)
adamc@453 724
adamc@196 725 val ps = case pop of
adamc@196 726 NONE => ps
adamc@196 727 | SOME p => p :: ps
adamc@196 728 in
adamc@453 729 (dsF, ds, ps, Sm.clearDeclares sm)
adamc@196 730 end)
adamc@196 731 ([], [], [], Sm.empty) ds
adam@1845 732
adam@2056 733 val sideInfo = foldl (fn ((n, mode, dbmode), mp) => IM.insert (mp, n, (mode, dbmode))) IM.empty sideInfo
adam@1845 734
adam@1845 735 val ps = map (fn (ek, s, n, ts, t, _, b) =>
adam@2056 736 let
adam@2056 737 val (side, db) = getOpt (IM.find (sideInfo, n), (L'.ServerOnly, L'.AnyDb))
adam@2056 738 in
adam@2056 739 (ek, s, n, ts, t, side, db, b)
adam@2056 740 end) ps
adamc@29 741 in
adamc@453 742 (List.revAppend (dsF, rev ds),
adamc@101 743 ps)
adamc@29 744 end
adamc@29 745
adamc@29 746 end