Mercurial > urweb

comparison src/cjrize.sml @ 1601:78e0d56b594e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Better error messages when client-side constructs are detected in Cjrize
author Adam Chlipala <adam@chlipala.net>
date Sat, 19 Nov 2011 10:26:19 -0500
parents 36f7d1debb37
children 0577be31a435
comparison
equal deleted inserted replaced
1600:8128fcb2d4a4 1601:78e0d56b594e
235 in 235 in
236 ((L'.PSome (t, p), loc), sm) 236 ((L'.PSome (t, p), loc), sm)
237 end 237 end
238 238
239 fun cifyExp (eAll as (e, loc), sm) = 239 fun cifyExp (eAll as (e, loc), sm) =
240 case e of 240 let
241 L.EPrim p => ((L'.EPrim p, loc), sm) 241 fun fail msg =
242 | L.ERel n => ((L'.ERel n, loc), sm) 242 (ErrorMsg.errorAt loc msg;
243 | L.ENamed n => ((L'.ENamed n, loc), sm) 243 ((L'.EPrim (Prim.String ""), loc), sm))
244 | L.ECon (dk, pc, eo) => 244 in
245 let 245 case e of
246 val (eo, sm) = 246 L.EPrim p => ((L'.EPrim p, loc), sm)
247 case eo of 247 | L.ERel n => ((L'.ERel n, loc), sm)
248 NONE => (NONE, sm) 248 | L.ENamed n => ((L'.ENamed n, loc), sm)
249 | SOME e => 249 | L.ECon (dk, pc, eo) =>
250 let 250 let
251 val (e, sm) = cifyExp (e, sm) 251 val (eo, sm) =
252 in 252 case eo of
253 (SOME e, sm) 253 NONE => (NONE, sm)
254 end 254 | SOME e =>
255 val (pc, sm) = cifyPatCon (pc, sm) 255 let
256 in 256 val (e, sm) = cifyExp (e, sm)
257 ((L'.ECon (dk, pc, eo), loc), sm) 257 in
258 end 258 (SOME e, sm)
259 | L.ENone t => 259 end
260 let 260 val (pc, sm) = cifyPatCon (pc, sm)
261 val (t, sm) = cifyTyp (t, sm) 261 in
262 in 262 ((L'.ECon (dk, pc, eo), loc), sm)
263 ((L'.ENone t, loc), sm) 263 end
264 end 264 | L.ENone t =>
265 | L.ESome (t, e) => 265 let
266 let 266 val (t, sm) = cifyTyp (t, sm)
267 val (t, sm) = cifyTyp (t, sm) 267 in
268 val (e, sm) = cifyExp (e, sm) 268 ((L'.ENone t, loc), sm)
269 in 269 end
270 ((L'.ESome (t, e), loc), sm) 270 | L.ESome (t, e) =>
271 end 271 let
272 | L.EFfi mx => ((L'.EFfi mx, loc), sm) 272 val (t, sm) = cifyTyp (t, sm)
273 | L.EFfiApp (m, x, es) => 273 val (e, sm) = cifyExp (e, sm)
274 let 274 in
275 val (es, sm) = ListUtil.foldlMap cifyExp sm es 275 ((L'.ESome (t, e), loc), sm)
276 in 276 end
277 ((L'.EFfiApp (m, x, es), loc), sm) 277 | L.EFfi mx => ((L'.EFfi mx, loc), sm)
278 end 278 | L.EFfiApp (m, x, es) =>
279 | L.EApp (e1, e2) => 279 let
280 let 280 val (es, sm) = ListUtil.foldlMap cifyExp sm es
281 fun unravel (e, args) = 281 in
282 case e of 282 ((L'.EFfiApp (m, x, es), loc), sm)
283 (L.EApp (e1, e2), _) => unravel (e1, e2 :: args) 283 end
284 | _ => (e, args) 284 | L.EApp (e1, e2) =>
285 285 let
286 val (f, es) = unravel (e1, [e2]) 286 fun unravel (e, args) =
287 287 case e of
288 val (f, sm) = cifyExp (f, sm) 288 (L.EApp (e1, e2), _) => unravel (e1, e2 :: args)
289 val (es, sm) = ListUtil.foldlMap cifyExp sm es 289 | _ => (e, args)
290 in 290
291 ((L'.EApp (f, es), loc), sm) 291 val (f, es) = unravel (e1, [e2])
292 end 292
293 | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation"; 293 val (f, sm) = cifyExp (f, sm)
294 Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)]; 294 val (es, sm) = ListUtil.foldlMap cifyExp sm es
295 (dummye, sm)) 295 in
296 296 ((L'.EApp (f, es), loc), sm)
297 | L.EUnop (s, e1) => 297 end
298 let 298 | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
299 val (e1, sm) = cifyExp (e1, sm) 299 Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
300 in 300 (dummye, sm))
301 ((L'.EUnop (s, e1), loc), sm) 301
302 end 302 | L.EUnop (s, e1) =>
303 | L.EBinop (_, s, e1, e2) => 303 let
304 let 304 val (e1, sm) = cifyExp (e1, sm)
305 val (e1, sm) = cifyExp (e1, sm) 305 in
306 val (e2, sm) = cifyExp (e2, sm) 306 ((L'.EUnop (s, e1), loc), sm)
307 in 307 end
308 ((L'.EBinop (s, e1, e2), loc), sm) 308 | L.EBinop (_, s, e1, e2) =>
309 end 309 let
310 310 val (e1, sm) = cifyExp (e1, sm)
311 | L.ERecord xes => 311 val (e2, sm) = cifyExp (e2, sm)
312 let 312 in
313 val old_xts = map (fn (x, _, t) => (x, t)) xes 313 ((L'.EBinop (s, e1, e2), loc), sm)
314 314 end
315 val (xets, sm) = ListUtil.foldlMap (fn ((x, e, t), sm) => 315
316 let 316 | L.ERecord xes =>
317 val (e, sm) = cifyExp (e, sm) 317 let
318 val (t, sm) = cifyTyp (t, sm) 318 val old_xts = map (fn (x, _, t) => (x, t)) xes
319 in 319
320 ((x, e, t), sm) 320 val (xets, sm) = ListUtil.foldlMap (fn ((x, e, t), sm) =>
321 end) 321 let
322 sm xes 322 val (e, sm) = cifyExp (e, sm)
323 323 val (t, sm) = cifyTyp (t, sm)
324 val (sm, si) = Sm.find (sm, old_xts, map (fn (x, _, t) => (x, t)) xets) 324 in
325 325 ((x, e, t), sm)
326 val xes = map (fn (x, e, _) => (x, e)) xets 326 end)
327 val xes = ListMergeSort.sort (fn ((x1, _), (x2, _)) => String.compare (x1, x2) = GREATER) xes 327 sm xes
328 in 328
329 ((L'.ERecord (si, xes), loc), sm) 329 val (sm, si) = Sm.find (sm, old_xts, map (fn (x, _, t) => (x, t)) xets)
330 end 330
331 | L.EField (e, x) => 331 val xes = map (fn (x, e, _) => (x, e)) xets
332 let 332 val xes = ListMergeSort.sort (fn ((x1, _), (x2, _)) => String.compare (x1, x2) = GREATER) xes
333 val (e, sm) = cifyExp (e, sm) 333 in
334 in 334 ((L'.ERecord (si, xes), loc), sm)
335 ((L'.EField (e, x), loc), sm) 335 end
336 end 336 | L.EField (e, x) =>
337 337 let
338 | L.ECase (e, pes, {disc, result}) => 338 val (e, sm) = cifyExp (e, sm)
339 let 339 in
340 ((L'.EField (e, x), loc), sm)
341 end
342
343 | L.ECase (e, pes, {disc, result}) =>
344 let
340 val (e, sm) = cifyExp (e, sm) 345 val (e, sm) = cifyExp (e, sm)
341 val (pes, sm) = ListUtil.foldlMap 346 val (pes, sm) = ListUtil.foldlMap
342 (fn ((p, e), sm) => 347 (fn ((p, e), sm) =>
343 let 348 let
344 val (e, sm) = cifyExp (e, sm) 349 val (e, sm) = cifyExp (e, sm)
350 val (result, sm) = cifyTyp (result, sm) 355 val (result, sm) = cifyTyp (result, sm)
351 in 356 in
352 ((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm) 357 ((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm)
353 end 358 end
354 359
355 | L.EError (e, t) => 360 | L.EError (e, t) =>
356 let 361 let
357 val (e, sm) = cifyExp (e, sm) 362 val (e, sm) = cifyExp (e, sm)
358 val (t, sm) = cifyTyp (t, sm) 363 val (t, sm) = cifyTyp (t, sm)
359 in 364 in
360 ((L'.EError (e, t), loc), sm) 365 ((L'.EError (e, t), loc), sm)
361 end 366 end
362 | L.EReturnBlob {blob, mimeType, t} => 367 | L.EReturnBlob {blob, mimeType, t} =>
363 let 368 let
364 val (blob, sm) = cifyExp (blob, sm) 369 val (blob, sm) = cifyExp (blob, sm)
365 val (mimeType, sm) = cifyExp (mimeType, sm) 370 val (mimeType, sm) = cifyExp (mimeType, sm)
366 val (t, sm) = cifyTyp (t, sm) 371 val (t, sm) = cifyTyp (t, sm)
367 in 372 in
368 ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm) 373 ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm)
369 end 374 end
370 | L.ERedirect (e, t) => 375 | L.ERedirect (e, t) =>
371 let 376 let
372 val (e, sm) = cifyExp (e, sm) 377 val (e, sm) = cifyExp (e, sm)
373 val (t, sm) = cifyTyp (t, sm) 378 val (t, sm) = cifyTyp (t, sm)
374 in 379 in
375 ((L'.ERedirect (e, t), loc), sm) 380 ((L'.ERedirect (e, t), loc), sm)
376 end 381 end
377 382
378 | L.EStrcat (e1, e2) => 383 | L.EStrcat (e1, e2) =>
379 let 384 let
380 val (e1, sm) = cifyExp (e1, sm) 385 val (e1, sm) = cifyExp (e1, sm)
381 val (e2, sm) = cifyExp (e2, sm) 386 val (e2, sm) = cifyExp (e2, sm)
382 in 387 in
383 ((L'.EFfiApp ("Basis", "strcat", [e1, e2]), loc), sm) 388 ((L'.EFfiApp ("Basis", "strcat", [e1, e2]), loc), sm)
384 end 389 end
385 390
386 | L.EWrite e => 391 | L.EWrite e =>
387 let 392 let
388 val (e, sm) = cifyExp (e, sm) 393 val (e, sm) = cifyExp (e, sm)
389 in 394 in
390 ((L'.EWrite e, loc), sm) 395 ((L'.EWrite e, loc), sm)
391 end 396 end
392 397
393 | L.ESeq (e1, e2) => 398 | L.ESeq (e1, e2) =>
394 let 399 let
395 val (e1, sm) = cifyExp (e1, sm) 400 val (e1, sm) = cifyExp (e1, sm)
396 val (e2, sm) = cifyExp (e2, sm) 401 val (e2, sm) = cifyExp (e2, sm)
397 in 402 in
398 ((L'.ESeq (e1, e2), loc), sm) 403 ((L'.ESeq (e1, e2), loc), sm)
399 end 404 end
400 405
401 | L.ELet (x, t, e1, e2) => 406 | L.ELet (x, t, e1, e2) =>
402 let 407 let
403 val (t, sm) = cifyTyp (t, sm) 408 val (t, sm) = cifyTyp (t, sm)
404 val (e1, sm) = cifyExp (e1, sm) 409 val (e1, sm) = cifyExp (e1, sm)
405 val (e2, sm) = cifyExp (e2, sm) 410 val (e2, sm) = cifyExp (e2, sm)
406 in 411 in
407 ((L'.ELet (x, t, e1, e2), loc), sm) 412 ((L'.ELet (x, t, e1, e2), loc), sm)
408 end 413 end
409 414
410 | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation"; 415 | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
411 (dummye, sm)) 416 (dummye, sm))
412 417
413 | L.EQuery {exps, tables, state, query, body, initial} => 418 | L.EQuery {exps, tables, state, query, body, initial} =>
414 let 419 let
415 val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) => 420 val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
416 let
417 val (t, sm) = cifyTyp (t, sm)
418 in
419 ((x, t), sm)
420 end) sm exps
421 val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) =>
422 let
423 val (xts, sm) = ListUtil.foldlMap
424 (fn ((x, t), sm) =>
425 let
426 val (t, sm) = cifyTyp (t, sm)
427 in
428 ((x, t), sm)
429 end) sm xts
430 in
431 ((x, xts), sm)
432 end) sm tables
433
434 val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables
435 val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
436
437 val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) =>
438 let 421 let
439 val (sm, rnum) = Sm.find (sm, xts, xts') 422 val (t, sm) = cifyTyp (t, sm)
440 in 423 in
441 ((x, rnum), sm) 424 ((x, t), sm)
442 end) 425 end) sm exps
443 sm (ListPair.zip (tables, tables')) 426 val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) =>
444 val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows 427 let
445 val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row' 428 val (xts, sm) = ListUtil.foldlMap
446 429 (fn ((x, t), sm) =>
447 val (sm, rnum) = Sm.find (sm, row, row') 430 let
448 431 val (t, sm) = cifyTyp (t, sm)
449 val (state, sm) = cifyTyp (state, sm) 432 in
450 val (query, sm) = cifyExp (query, sm) 433 ((x, t), sm)
451 val (body, sm) = cifyExp (body, sm) 434 end) sm xts
452 val (initial, sm) = cifyExp (initial, sm) 435 in
453 in 436 ((x, xts), sm)
454 ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state, 437 end) sm tables
455 query = query, body = body, initial = initial, prepared = NONE}, loc), sm) 438
456 end 439 val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables
457 440 val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
458 | L.EDml (e, mode) => 441
459 let 442 val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) =>
460 val (e, sm) = cifyExp (e, sm) 443 let
461 in 444 val (sm, rnum) = Sm.find (sm, xts, xts')
462 ((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm) 445 in
463 end 446 ((x, rnum), sm)
464 447 end)
465 | L.ENextval e => 448 sm (ListPair.zip (tables, tables'))
466 let 449 val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows
467 val (e, sm) = cifyExp (e, sm) 450 val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row'
468 in 451
469 ((L'.ENextval {seq = e, prepared = NONE}, loc), sm) 452 val (sm, rnum) = Sm.find (sm, row, row')
470 end 453
471 | L.ESetval (e1, e2) => 454 val (state, sm) = cifyTyp (state, sm)
472 let 455 val (query, sm) = cifyExp (query, sm)
473 val (e1, sm) = cifyExp (e1, sm) 456 val (body, sm) = cifyExp (body, sm)
474 val (e2, sm) = cifyExp (e2, sm) 457 val (initial, sm) = cifyExp (initial, sm)
475 in 458 in
476 ((L'.ESetval {seq = e1, count = e2}, loc), sm) 459 ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state,
477 end 460 query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
478 461 end
479 | L.EUnurlify (e, t, b) => 462
480 let 463 | L.EDml (e, mode) =>
481 val (e, sm) = cifyExp (e, sm) 464 let
482 val (t, sm) = cifyTyp (t, sm) 465 val (e, sm) = cifyExp (e, sm)
483 in 466 in
484 ((L'.EUnurlify (e, t, b), loc), sm) 467 ((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm)
485 end 468 end
486 469
487 | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" 470 | L.ENextval e =>
488 471 let
489 | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" 472 val (e, sm) = cifyExp (e, sm)
490 | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" 473 in
491 | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains" 474 ((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
492 475 end
493 | L.EServerCall _ => raise Fail "Cjrize EServerCall" 476 | L.ESetval (e1, e2) =>
494 | L.ERecv _ => raise Fail "Cjrize ERecv" 477 let
495 | L.ESleep _ => raise Fail "Cjrize ESleep" 478 val (e1, sm) = cifyExp (e1, sm)
496 | L.ESpawn _ => raise Fail "Cjrize ESpawn" 479 val (e2, sm) = cifyExp (e2, sm)
480 in
481 ((L'.ESetval {seq = e1, count = e2}, loc), sm)
482 end
483
484 | L.EUnurlify (e, t, b) =>
485 let
486 val (e, sm) = cifyExp (e, sm)
487 val (t, sm) = cifyTyp (t, sm)
488 in
489 ((L'.EUnurlify (e, t, b), loc), sm)
490 end
491
492 | L.EJavaScript _ => fail "Uncompilable JavaScript remains"
493
494 | L.ESignalReturn _ => fail "Signal monad 'return' remains in server-side code"
495 | L.ESignalBind _ => fail "Signal monad 'bind' remains in server-side code"
496 | L.ESignalSource _ => fail "Signal monad 'source' remains in server-side code"
497
498 | L.EServerCall _ => fail "RPC in server-side code"
499 | L.ERecv _ => fail "Message receive in server-side code"
500 | L.ESleep _ => fail "Sleep in server-side code"
501 | L.ESpawn _ => fail "Thread spawn in server-side code"
502 end
497 503
498 fun cifyDecl ((d, loc), sm) = 504 fun cifyDecl ((d, loc), sm) =
499 case d of 505 case d of
500 L.DDatatype dts => 506 L.DDatatype dts =>
501 let 507 let