Mercurial > urweb

comparison src/monoize.sml @ 2254:44ae2254f8fb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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