Mercurial > urweb

comparison src/monoize.sml @ 2253:d665925acff8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Factor out [Monoize.Fm] to make it accessible to [Sqlcache].
author Ziv Scully <ziv@mit.edu>
date Mon, 21 Sep 2015 14:54:07 -0400
parents e843a04499d4
children 44ae2254f8fb
comparison
equal deleted inserted replaced
2252:e843a04499d4 2253:d665925acff8
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 = ref 0 53 val nextPvar = MonoFm.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 = ref ([] : (string * int * (string * int * L'.typ option) list) list)
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 () =
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 IM = IntBinaryMap 377 structure Fm = MonoFm
378
379 datatype foo_kind =
380 Attr
381 | Url
382 378
383 fun fk2s fk = 379 fun fk2s fk =
384 case fk of 380 case fk of
385 Attr => "attr" 381 Fm.Attr => "attr"
386 | Url => "url" 382 | Fm.Url => "url"
387
388 type vr = string * int * L'.typ * L'.exp * string
389
390 structure Fm :> sig
391 type t
392
393 val empty : int -> t
394
395 val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int
396 val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> vr * t) -> t * int
397 val enter : t -> t
398 val decls : t -> L'.decl list
399
400 val freshName : t -> int * t
401 end = struct
402
403 structure M = BinaryMapFn(struct
404 type ord_key = foo_kind
405 fun compare x =
406 case x of
407 (Attr, Attr) => EQUAL
408 | (Attr, _) => LESS
409 | (_, Attr) => GREATER
410
411 | (Url, Url) => EQUAL
412 end)
413
414 structure TM = BinaryMapFn(struct
415 type ord_key = L'.typ
416 val compare = MonoUtil.Typ.compare
417 end)
418
419 type t = {
420 count : int,
421 map : int IM.map M.map,
422 listMap : int TM.map M.map,
423 decls : vr list
424 }
425
426 fun empty count = {
427 count = count,
428 map = M.empty,
429 listMap = M.empty,
430 decls = []
431 }
432
433 fun chooseNext count =
434 let
435 val n = !nextPvar
436 in
437 if count < n then
438 (count, count+1)
439 else
440 (nextPvar := n + 1;
441 (n, n+1))
442 end
443
444 fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
445 fun freshName {count, map, listMap, decls} =
446 let
447 val (next, count) = chooseNext count
448 in
449 (next, {count = count , map = map, listMap = listMap, decls = decls})
450 end
451 fun decls ({decls, ...} : t) =
452 case decls of
453 [] => []
454 | _ => [(L'.DValRec decls, ErrorMsg.dummySpan)]
455
456 fun lookup (t as {count, map, listMap, decls}) k n thunk =
457 let
458 val im = Option.getOpt (M.find (map, k), IM.empty)
459 in
460 case IM.find (im, n) of
461 NONE =>
462 let
463 val n' = count
464 val (d, {count, map, listMap, decls}) =
465 thunk count {count = count + 1,
466 map = M.insert (map, k, IM.insert (im, n, n')),
467 listMap = listMap,
468 decls = decls}
469 in
470 ({count = count,
471 map = map,
472 listMap = listMap,
473 decls = d :: decls}, n')
474 end
475 | SOME n' => (t, n')
476 end
477
478 fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
479 let
480 val tm = Option.getOpt (M.find (listMap, k), TM.empty)
481 in
482 case TM.find (tm, tp) of
483 NONE =>
484 let
485 val n' = count
486 val (d, {count, map, listMap, decls}) =
487 thunk count {count = count + 1,
488 map = map,
489 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
490 decls = decls}
491 in
492 ({count = count,
493 map = map,
494 listMap = listMap,
495 decls = d :: decls}, n')
496 end
497 | SOME n' => (t, n')
498 end
499
500 end
501
502 383
503 fun capitalize s = 384 fun capitalize s =
504 if s = "" then 385 if s = "" then
505 s 386 s
506 else 387 else
675 (dummyExp, fm)) 556 (dummyExp, fm))
676 in 557 in
677 fooify 558 fooify
678 end 559 end
679 560
680 val attrifyExp = fooifyExp Attr 561 val attrifyExp = fooifyExp Fm.Attr
681 val urlifyExp = fooifyExp Url 562 val urlifyExp = fooifyExp Fm.Url
682 563
683 val urlifiedUnit = 564 val urlifiedUnit =
684 let 565 let
685 val loc = ErrorMsg.dummySpan 566 val loc = ErrorMsg.dummySpan
686 (* Urlifies [ERel 0] to match the [sqlcacheInfo] field of [EQuery]s. *) 567 (* Urlifies [ERel 0] to match the [sqlcacheInfo] field of [EQuery]s. *)
4736 end 4617 end
4737 4618
4738 val mname = CoreUtil.File.maxName file + 1 4619 val mname = CoreUtil.File.maxName file + 1
4739 val () = nextPvar := mname 4620 val () = nextPvar := mname
4740 4621
4741 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => 4622 val (_, fm, ds) = List.foldl (fn (d, (env, fm, ds)) =>
4742 case #1 d of 4623 case #1 d of
4743 L.DDatabase s => 4624 L.DDatabase s =>
4744 let 4625 let
4745 val (nExp, fm) = Fm.freshName fm 4626 val (nExp, fm) = Fm.freshName fm
4746 val (nIni, fm) = Fm.freshName fm 4627 val (nIni, fm) = Fm.freshName fm
4784 (env, Fm.empty mname, []) file 4665 (env, Fm.empty mname, []) file
4785 in 4666 in
4786 pvars := RM.empty; 4667 pvars := RM.empty;
4787 pvarDefs := []; 4668 pvarDefs := [];
4788 pvarOldDefs := []; 4669 pvarOldDefs := [];
4670 Fm.postMonoize := fm;
4789 (rev ds, []) 4671 (rev ds, [])
4790 end 4672 end
4791 4673
4792 end 4674 end