Mercurial > urweb
comparison src/monoize.sml @ 2254:44ae2254f8fb
Factor out urlification.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Mon, 21 Sep 2015 16:07:35 -0400 |
parents | d665925acff8 |
children | 8428c534913a |
comparison
equal
deleted
inserted
replaced
2253:d665925acff8 | 2254:44ae2254f8fb |
---|---|
48 type ord_key = (string * L'.typ) list | 48 type ord_key = (string * L'.typ) list |
49 fun compare (r1, r2) = MonoUtil.Typ.compare ((L'.TRecord r1, E.dummySpan), | 49 fun compare (r1, r2) = MonoUtil.Typ.compare ((L'.TRecord r1, E.dummySpan), |
50 (L'.TRecord r2, E.dummySpan)) | 50 (L'.TRecord r2, E.dummySpan)) |
51 end) | 51 end) |
52 | 52 |
53 val nextPvar = MonoFm.nextPvar | 53 val nextPvar = MonoFooify.nextPvar |
54 val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) | 54 val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) |
55 val pvarDefs = ref ([] : (string * int * (string * int * L'.typ option) list) list) | 55 val pvarDefs = MonoFooify.pvarDefs |
56 val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list) | 56 val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list) |
57 | 57 |
58 fun choosePvar () = | 58 fun choosePvar () = |
59 let | 59 let |
60 val n = !nextPvar | 60 val n = !nextPvar |
372 mt env IM.empty | 372 mt env IM.empty |
373 end | 373 end |
374 | 374 |
375 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) | 375 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) |
376 | 376 |
377 structure Fm = MonoFm | 377 structure Fm = MonoFooify.Fm |
378 | |
379 fun fk2s fk = | |
380 case fk of | |
381 Fm.Attr => "attr" | |
382 | Fm.Url => "url" | |
383 | |
384 fun capitalize s = | |
385 if s = "" then | |
386 s | |
387 else | |
388 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) | |
389 | 378 |
390 fun fooifyExp fk env = | 379 fun fooifyExp fk env = |
391 let | 380 MonoFooify.fooifyExp |
392 fun fooify fm (e, tAll as (t, loc)) = | 381 fk |
393 case #1 e of | 382 (fn n => |
394 L'.EClosure (fnam, [(L'.ERecord [], _)]) => | 383 let |
395 let | 384 val (_, t, _, s) = Env.lookupENamed env n |
396 val (_, _, _, s) = Env.lookupENamed env fnam | 385 in |
397 in | 386 (monoType env t, s) |
398 ((L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) | 387 end) |
399 end | 388 (fn n => |
400 | L'.EClosure (fnam, args) => | 389 let |
401 let | 390 val (x, _, xncs) = Env.lookupDatatype env n |
402 val (_, ft, _, s) = Env.lookupENamed env fnam | 391 in |
403 val ft = monoType env ft | 392 (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs) |
404 | 393 end) |
405 fun attrify (args, ft, e, fm) = | 394 |
406 case (args, ft) of | 395 val attrifyExp = fooifyExp MonoFooify.Attr |
407 ([], _) => (e, fm) | 396 val urlifyExp = fooifyExp MonoFooify.Url |
408 | (arg :: args, (L'.TFun (t, ft), _)) => | |
409 let | |
410 val (arg', fm) = fooify fm (arg, t) | |
411 in | |
412 attrify (args, ft, | |
413 (L'.EStrcat (e, | |
414 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), | |
415 arg'), loc)), loc), | |
416 fm) | |
417 end | |
418 | _ => (E.errorAt loc "Type mismatch encoding attribute"; | |
419 (e, fm)) | |
420 in | |
421 attrify (args, ft, (L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) | |
422 end | |
423 | _ => | |
424 case t of | |
425 L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) | |
426 | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) | |
427 | |
428 | L'.TRecord [] => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) | |
429 | L'.TRecord ((x, t) :: xts) => | |
430 let | |
431 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t) | |
432 in | |
433 foldl (fn ((x, t), (se, fm)) => | |
434 let | |
435 val (se', fm) = fooify fm ((L'.EField (e, x), loc), t) | |
436 in | |
437 ((L'.EStrcat (se, | |
438 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), | |
439 se'), loc)), loc), | |
440 fm) | |
441 end) (se, fm) xts | |
442 end | |
443 | |
444 | L'.TDatatype (i, ref (dk, _)) => | |
445 let | |
446 fun makeDecl n fm = | |
447 let | |
448 val (x, xncs) = | |
449 case ListUtil.search (fn (x, i', xncs) => | |
450 if i' = i then | |
451 SOME (x, xncs) | |
452 else | |
453 NONE) (!pvarDefs) of | |
454 NONE => | |
455 let | |
456 val (x, _, xncs) = Env.lookupDatatype env i | |
457 in | |
458 (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs) | |
459 end | |
460 | SOME v => v | |
461 | |
462 val (branches, fm) = | |
463 ListUtil.foldlMap | |
464 (fn ((x, n, to), fm) => | |
465 case to of | |
466 NONE => | |
467 (((L'.PCon (dk, L'.PConVar n, NONE), loc), | |
468 (L'.EPrim (Prim.String (Prim.Normal, x)), loc)), | |
469 fm) | |
470 | SOME t => | |
471 let | |
472 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t) | |
473 in | |
474 (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc), | |
475 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), | |
476 arg), loc)), | |
477 fm) | |
478 end) | |
479 fm xncs | |
480 | |
481 val dom = tAll | |
482 val ran = (L'.TFfi ("Basis", "string"), loc) | |
483 in | |
484 ((fk2s fk ^ "ify_" ^ x, | |
485 n, | |
486 (L'.TFun (dom, ran), loc), | |
487 (L'.EAbs ("x", | |
488 dom, | |
489 ran, | |
490 (L'.ECase ((L'.ERel 0, loc), | |
491 branches, | |
492 {disc = dom, | |
493 result = ran}), loc)), loc), | |
494 ""), | |
495 fm) | |
496 end | |
497 | |
498 val (fm, n) = Fm.lookup fm fk i makeDecl | |
499 in | |
500 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) | |
501 end | |
502 | |
503 | L'.TOption t => | |
504 let | |
505 val (body, fm) = fooify fm ((L'.ERel 0, loc), t) | |
506 in | |
507 ((L'.ECase (e, | |
508 [((L'.PNone t, loc), | |
509 (L'.EPrim (Prim.String (Prim.Normal, "None")), loc)), | |
510 | |
511 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), | |
512 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Some/")), loc), | |
513 body), loc))], | |
514 {disc = tAll, | |
515 result = (L'.TFfi ("Basis", "string"), loc)}), loc), | |
516 fm) | |
517 end | |
518 | |
519 | L'.TList t => | |
520 let | |
521 fun makeDecl n fm = | |
522 let | |
523 val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc) | |
524 val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt) | |
525 | |
526 val branches = [((L'.PNone rt, loc), | |
527 (L'.EPrim (Prim.String (Prim.Normal, "Nil")), loc)), | |
528 ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc), | |
529 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Cons/")), loc), | |
530 arg), loc))] | |
531 | |
532 val dom = tAll | |
533 val ran = (L'.TFfi ("Basis", "string"), loc) | |
534 in | |
535 ((fk2s fk ^ "ify_list", | |
536 n, | |
537 (L'.TFun (dom, ran), loc), | |
538 (L'.EAbs ("x", | |
539 dom, | |
540 ran, | |
541 (L'.ECase ((L'.ERel 0, loc), | |
542 branches, | |
543 {disc = dom, | |
544 result = ran}), loc)), loc), | |
545 ""), | |
546 fm) | |
547 end | |
548 | |
549 val (fm, n) = Fm.lookupList fm fk t makeDecl | |
550 in | |
551 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) | |
552 end | |
553 | |
554 | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; | |
555 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; | |
556 (dummyExp, fm)) | |
557 in | |
558 fooify | |
559 end | |
560 | |
561 val attrifyExp = fooifyExp Fm.Attr | |
562 val urlifyExp = fooifyExp Fm.Url | |
563 | 397 |
564 val urlifiedUnit = | 398 val urlifiedUnit = |
565 let | 399 let |
566 val loc = ErrorMsg.dummySpan | 400 val loc = ErrorMsg.dummySpan |
567 (* Urlifies [ERel 0] to match the [sqlcacheInfo] field of [EQuery]s. *) | 401 (* Urlifies [ERel 0] to match the [sqlcacheInfo] field of [EQuery]s. *) |
4665 (env, Fm.empty mname, []) file | 4499 (env, Fm.empty mname, []) file |
4666 in | 4500 in |
4667 pvars := RM.empty; | 4501 pvars := RM.empty; |
4668 pvarDefs := []; | 4502 pvarDefs := []; |
4669 pvarOldDefs := []; | 4503 pvarOldDefs := []; |
4670 Fm.postMonoize := fm; | 4504 Fm.canonical := fm; |
4671 (rev ds, []) | 4505 (rev ds, []) |
4672 end | 4506 end |
4673 | 4507 |
4674 end | 4508 end |