Mercurial > urweb
comparison src/sqlcache.sml @ 2265:a647a1560628
Hard-code Sqlcache module (in Ur/Web) as effectful and reorder sqlcache.sml.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Wed, 14 Oct 2015 00:07:00 -0400 |
parents | bbcf9ba9b39a |
children | afd12c75e0d6 |
comparison
equal
deleted
inserted
replaced
2264:bbcf9ba9b39a | 2265:a647a1560628 |
---|---|
13 then raise Fail "Can't iterate function negative number of times." | 13 then raise Fail "Can't iterate function negative number of times." |
14 else if n = 0 | 14 else if n = 0 |
15 then x | 15 then x |
16 else iterate f (n-1) (f x) | 16 else iterate f (n-1) (f x) |
17 | 17 |
18 (* Filled in by [cacheWrap] during [Sqlcache]. *) | 18 (* Filled in by [cacheWrap]. *) |
19 val ffiInfo : {index : int, params : int} list ref = ref [] | 19 val ffiInfo : {index : int, params : int} list ref = ref [] |
20 | 20 |
21 fun resetFfiInfo () = ffiInfo := [] | 21 fun resetFfiInfo () = ffiInfo := [] |
22 | 22 |
23 fun getFfiInfo () = !ffiInfo | 23 fun getFfiInfo () = !ffiInfo |
39 "urlifyFloat_w", | 39 "urlifyFloat_w", |
40 "urlifyString_w", | 40 "urlifyString_w", |
41 "urlifyBool_w", | 41 "urlifyBool_w", |
42 "urlifyChannel_w"] | 42 "urlifyChannel_w"] |
43 in | 43 in |
44 (* ASK: nicer way than using [Settings.addEffectful] for each Sqlcache | 44 (* ASK: is it okay to hardcode Sqlcache functions as effectful? *) |
45 function? Right now they're all always effectful. *) | |
46 fn (m, f) => Settings.isEffectful (m, f) | 45 fn (m, f) => Settings.isEffectful (m, f) |
47 andalso not (m = "Basis" andalso SS.member (okayWrites, f)) | 46 andalso not (m = "Basis" andalso SS.member (okayWrites, f)) |
48 end | 47 end |
49 | 48 |
50 val cache = ref LruCache.cache | 49 val cache = ref LruCache.cache |
454 fn Sql.Insert (tab, _) => tab | 453 fn Sql.Insert (tab, _) => tab |
455 | Sql.Delete (tab, _) => tab | 454 | Sql.Delete (tab, _) => tab |
456 | Sql.Update (tab, _, _) => tab | 455 | Sql.Update (tab, _, _) => tab |
457 | 456 |
458 | 457 |
459 (***************************) | 458 (*************************************) |
460 (* Program Instrumentation *) | 459 (* Program Instrumentation Utilities *) |
461 (***************************) | 460 (*************************************) |
462 | 461 |
463 val varName = | 462 val varName = |
464 let | 463 let |
465 val varNumber = ref 0 | 464 val varNumber = ref 0 |
466 in | 465 in |
493 exp = fn bound => | 492 exp = fn bound => |
494 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n) | 493 (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n) |
495 | e' => e'), | 494 | e' => e'), |
496 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} | 495 bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} |
497 0 | 496 0 |
498 | |
499 fun cacheWrap (env, exp, resultTyp, args, i) = | |
500 let | |
501 val loc = dummyLoc | |
502 val rel0 = (ERel 0, loc) | |
503 in | |
504 case MonoFooify.urlify env (rel0, resultTyp) of | |
505 NONE => NONE | |
506 | SOME urlified => | |
507 let | |
508 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo | |
509 (* We ensure before this step that all arguments aren't effectful. | |
510 by turning them into local variables as needed. *) | |
511 val argsInc = map (incRels 1) args | |
512 val check = (check (i, args), loc) | |
513 val store = (store (i, argsInc, urlified), loc) | |
514 in | |
515 SOME (ECase | |
516 (check, | |
517 [((PNone stringTyp, loc), | |
518 (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)), | |
519 ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), | |
520 (* Boolean is false because we're not unurlifying from a cookie. *) | |
521 (EUnurlify (rel0, resultTyp, false), loc))], | |
522 {disc = (TOption stringTyp, loc), result = resultTyp})) | |
523 end | |
524 end | |
525 | 497 |
526 fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state = | 498 fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state = |
527 let | 499 let |
528 fun doVal env ((x, n, t, exp, s), state) = | 500 fun doVal env ((x, n, t, exp, s), state) = |
529 let | 501 let |
567 MonoEnv.empty file start of | 539 MonoEnv.empty file start of |
568 Search.Continue x => x | 540 Search.Continue x => x |
569 | Search.Return _ => raise Match | 541 | Search.Return _ => raise Match |
570 | 542 |
571 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) | 543 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) |
572 | |
573 fun factorOutNontrivial text = | |
574 let | |
575 val loc = dummyLoc | |
576 fun strcat (e1, e2) = (EStrcat (e1, e2), loc) | |
577 val chunks = Sql.chunkify text | |
578 val (newText, newVariables) = | |
579 (* Important that this is foldr (to oppose foldl below). *) | |
580 List.foldr | |
581 (fn (chunk, (qText, newVars)) => | |
582 (* Variable bound to the head of newBs will have the lowest index. *) | |
583 case chunk of | |
584 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) | |
585 | Sql.Exp e => | |
586 let | |
587 val n = length newVars | |
588 in | |
589 (* This is the (n+1)th new variable, so there are | |
590 already n new variables bound, so we increment | |
591 indices by n. *) | |
592 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) | |
593 end | |
594 | Sql.String s => (strcat (stringExp s, qText), newVars)) | |
595 (stringExp "", []) | |
596 chunks | |
597 fun wrapLets e' = | |
598 (* Important that this is foldl (to oppose foldr above). *) | |
599 List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc))) | |
600 e' | |
601 newVariables | |
602 val numArgs = length newVariables | |
603 in | |
604 (newText, wrapLets, numArgs) | |
605 end | |
606 | |
607 fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = | |
608 fn e' as EQuery {query = origQueryText, | |
609 state = resultTyp, | |
610 initial, body, tables, exps} => | |
611 let | |
612 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText | |
613 (* Increment once for each new variable just made. *) | |
614 val queryExp = incRels numArgs | |
615 (EQuery {query = newQueryText, | |
616 state = resultTyp, | |
617 initial = initial, | |
618 body = body, | |
619 tables = tables, | |
620 exps = exps}, | |
621 dummyLoc) | |
622 (* DEBUG *) | |
623 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) | |
624 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) | |
625 fun bind x f = Option.mapPartial f x | |
626 fun guard b x = if b then x else NONE | |
627 (* We use dummyTyp here. I think this is okay because databases don't | |
628 store (effectful) functions, but perhaps there's some pathalogical | |
629 corner case missing.... *) | |
630 fun safe bound = | |
631 not | |
632 o effectful effs | |
633 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) | |
634 bound | |
635 env) | |
636 val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE | |
637 val attempt = | |
638 (* Ziv misses Haskell's do notation.... *) | |
639 bind (textOfQuery queryExp) (fn queryText => | |
640 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( | |
641 bind (Sql.parse Sql.query queryText) (fn queryParsed => | |
642 bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp => | |
643 SOME (wrapLets cachedExp, | |
644 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) | |
645 tableToIndices | |
646 (tablesQuery queryParsed), | |
647 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), | |
648 index + 1)))))) | |
649 in | |
650 case attempt of | |
651 SOME pair => pair | |
652 (* We have to increment index conservatively. *) | |
653 (* TODO: just use a reference for current index.... *) | |
654 | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1)) | |
655 end | |
656 | e' => (e', queryInfo) | |
657 | |
658 fun addChecking file = | |
659 let | |
660 val effs = effectfulDecls file | |
661 in | |
662 (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp) | |
663 file | |
664 (SIMM.empty, IM.empty, 0), | |
665 effs) | |
666 end | |
667 | |
668 structure Invalidations = struct | |
669 | |
670 val loc = dummyLoc | |
671 | |
672 val optionAtomExpToExp = | |
673 fn NONE => (ENone stringTyp, loc) | |
674 | SOME e => (ESome (stringTyp, | |
675 (case e of | |
676 DmlRel n => ERel n | |
677 | Prim p => EPrim p | |
678 (* TODO: make new type containing only these two. *) | |
679 | _ => raise Match, | |
680 loc)), | |
681 loc) | |
682 | |
683 fun eqsToInvalidation numArgs eqs = | |
684 let | |
685 fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) | |
686 in | |
687 inv (numArgs - 1) | |
688 end | |
689 | |
690 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here | |
691 represents unknown, which means a wider invalidation. *) | |
692 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = | |
693 fn ([], []) => true | |
694 | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys) | |
695 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of | |
696 EQUAL => madeRedundantBy (xs, ys) | |
697 | _ => false) | |
698 | _ => false | |
699 | |
700 fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml) | |
701 | |
702 fun invalidations ((query, numArgs), dml) = | |
703 (map (map optionAtomExpToExp) | |
704 o removeRedundant madeRedundantBy | |
705 o map (eqsToInvalidation numArgs) | |
706 o eqss) | |
707 (query, dml) | |
708 | |
709 end | |
710 | |
711 val invalidations = Invalidations.invalidations | |
712 | |
713 (* DEBUG *) | |
714 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) | |
715 (* val gunk' : exp list ref = ref [] *) | |
716 | |
717 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = | |
718 let | |
719 val flushes = List.concat | |
720 o map (fn (i, argss) => map (fn args => flush (i, args)) argss) | |
721 val doExp = | |
722 fn EDml (origDmlText, failureMode) => | |
723 let | |
724 (* DEBUG *) | |
725 (* val () = gunk' := origDmlText :: !gunk' *) | |
726 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText | |
727 val dmlText = incRels numArgs newDmlText | |
728 val dmlExp = EDml (dmlText, failureMode) | |
729 (* DEBUG *) | |
730 val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) | |
731 val inval = | |
732 case Sql.parse Sql.dml dmlText of | |
733 SOME dmlParsed => | |
734 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of | |
735 SOME queryNumArgs => | |
736 (* DEBUG *) | |
737 ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *) | |
738 (i, invalidations (queryNumArgs, dmlParsed))) | |
739 (* TODO: fail more gracefully. *) | |
740 | NONE => raise Match)) | |
741 (SIMM.findList (tableToIndices, tableDml dmlParsed))) | |
742 | NONE => NONE | |
743 in | |
744 case inval of | |
745 (* TODO: fail more gracefully. *) | |
746 NONE => raise Match | |
747 | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp])) | |
748 end | |
749 | e' => e' | |
750 in | |
751 (* DEBUG *) | |
752 (* gunk := []; *) | |
753 (fileMap doExp file, index, effs) | |
754 end | |
755 | |
756 val inlineSql = | |
757 let | |
758 val doExp = | |
759 (* TODO: EQuery, too? *) | |
760 (* ASK: should this live in [MonoOpt]? *) | |
761 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => | |
762 let | |
763 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases | |
764 in | |
765 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) | |
766 end | |
767 | e => e | |
768 in | |
769 fileMap doExp | |
770 end | |
771 | 544 |
772 | 545 |
773 (**********************) | 546 (**********************) |
774 (* Mono Type Checking *) | 547 (* Mono Type Checking *) |
775 (**********************) | 548 (**********************) |
827 | 600 |
828 | 601 |
829 (*******************************) | 602 (*******************************) |
830 (* Caching Pure Subexpressions *) | 603 (* Caching Pure Subexpressions *) |
831 (*******************************) | 604 (*******************************) |
605 | |
606 fun cacheWrap (env, exp, resultTyp, args, i) = | |
607 let | |
608 val loc = dummyLoc | |
609 val rel0 = (ERel 0, loc) | |
610 in | |
611 case MonoFooify.urlify env (rel0, resultTyp) of | |
612 NONE => NONE | |
613 | SOME urlified => | |
614 let | |
615 val () = ffiInfo := {index = i, params = length args} :: !ffiInfo | |
616 (* We ensure before this step that all arguments aren't effectful. | |
617 by turning them into local variables as needed. *) | |
618 val argsInc = map (incRels 1) args | |
619 val check = (check (i, args), loc) | |
620 val store = (store (i, argsInc, urlified), loc) | |
621 in | |
622 SOME (ECase | |
623 (check, | |
624 [((PNone stringTyp, loc), | |
625 (ELet (varName "q", resultTyp, exp, (ESeq (store, rel0), loc)), loc)), | |
626 ((PSome (stringTyp, (PVar (varName "hit", stringTyp), loc)), loc), | |
627 (* Boolean is false because we're not unurlifying from a cookie. *) | |
628 (EUnurlify (rel0, resultTyp, false), loc))], | |
629 {disc = (TOption stringTyp, loc), result = resultTyp})) | |
630 end | |
631 end | |
832 | 632 |
833 val freeVars = | 633 val freeVars = |
834 IS.listItems | 634 IS.listItems |
835 o MonoUtil.Exp.foldB | 635 o MonoUtil.Exp.foldB |
836 {typ = #2, | 636 {typ = #2, |
1003 end | 803 end |
1004 in | 804 in |
1005 #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart) | 805 #1 (fileTopLevelMapfoldB doTopLevelExp file indexStart) |
1006 end | 806 end |
1007 | 807 |
808 | |
809 (***********************) | |
810 (* Caching SQL Queries *) | |
811 (***********************) | |
812 | |
813 fun factorOutNontrivial text = | |
814 let | |
815 val loc = dummyLoc | |
816 fun strcat (e1, e2) = (EStrcat (e1, e2), loc) | |
817 val chunks = Sql.chunkify text | |
818 val (newText, newVariables) = | |
819 (* Important that this is foldr (to oppose foldl below). *) | |
820 List.foldr | |
821 (fn (chunk, (qText, newVars)) => | |
822 (* Variable bound to the head of newBs will have the lowest index. *) | |
823 case chunk of | |
824 Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) | |
825 | Sql.Exp e => | |
826 let | |
827 val n = length newVars | |
828 in | |
829 (* This is the (n+1)th new variable, so there are | |
830 already n new variables bound, so we increment | |
831 indices by n. *) | |
832 (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) | |
833 end | |
834 | Sql.String s => (strcat (stringExp s, qText), newVars)) | |
835 (stringExp "", []) | |
836 chunks | |
837 fun wrapLets e' = | |
838 (* Important that this is foldl (to oppose foldr above). *) | |
839 List.foldl (fn (v, e') => ELet (varName "sqlArg", stringTyp, v, (e', loc))) | |
840 e' | |
841 newVariables | |
842 val numArgs = length newVariables | |
843 in | |
844 (newText, wrapLets, numArgs) | |
845 end | |
846 | |
847 fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = | |
848 fn e' as EQuery {query = origQueryText, | |
849 state = resultTyp, | |
850 initial, body, tables, exps} => | |
851 let | |
852 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText | |
853 (* Increment once for each new variable just made. *) | |
854 val queryExp = incRels numArgs | |
855 (EQuery {query = newQueryText, | |
856 state = resultTyp, | |
857 initial = initial, | |
858 body = body, | |
859 tables = tables, | |
860 exps = exps}, | |
861 dummyLoc) | |
862 (* DEBUG *) | |
863 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) | |
864 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) | |
865 fun bind x f = Option.mapPartial f x | |
866 fun guard b x = if b then x else NONE | |
867 (* We use dummyTyp here. I think this is okay because databases don't | |
868 store (effectful) functions, but perhaps there's some pathalogical | |
869 corner case missing.... *) | |
870 fun safe bound = | |
871 not | |
872 o effectful effs | |
873 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) | |
874 bound | |
875 env) | |
876 val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE | |
877 val attempt = | |
878 (* Ziv misses Haskell's do notation.... *) | |
879 bind (textOfQuery queryExp) (fn queryText => | |
880 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( | |
881 bind (Sql.parse Sql.query queryText) (fn queryParsed => | |
882 bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp => | |
883 SOME (wrapLets cachedExp, | |
884 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) | |
885 tableToIndices | |
886 (tablesQuery queryParsed), | |
887 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), | |
888 index + 1)))))) | |
889 in | |
890 case attempt of | |
891 SOME pair => pair | |
892 (* We have to increment index conservatively. *) | |
893 (* TODO: just use a reference for current index.... *) | |
894 | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1)) | |
895 end | |
896 | e' => (e', queryInfo) | |
897 | |
898 fun addChecking file = | |
899 let | |
900 val effs = effectfulDecls file | |
901 in | |
902 (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp) | |
903 file | |
904 (SIMM.empty, IM.empty, 0), | |
905 effs) | |
906 end | |
907 | |
908 | |
909 (************) | |
910 (* Flushing *) | |
911 (************) | |
912 | |
913 structure Invalidations = struct | |
914 | |
915 val loc = dummyLoc | |
916 | |
917 val optionAtomExpToExp = | |
918 fn NONE => (ENone stringTyp, loc) | |
919 | SOME e => (ESome (stringTyp, | |
920 (case e of | |
921 DmlRel n => ERel n | |
922 | Prim p => EPrim p | |
923 (* TODO: make new type containing only these two. *) | |
924 | _ => raise Match, | |
925 loc)), | |
926 loc) | |
927 | |
928 fun eqsToInvalidation numArgs eqs = | |
929 let | |
930 fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1) | |
931 in | |
932 inv (numArgs - 1) | |
933 end | |
934 | |
935 (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here | |
936 represents unknown, which means a wider invalidation. *) | |
937 val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = | |
938 fn ([], []) => true | |
939 | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys) | |
940 | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of | |
941 EQUAL => madeRedundantBy (xs, ys) | |
942 | _ => false) | |
943 | _ => false | |
944 | |
945 fun eqss (query, dml) = conflictMaps (queryToFormula query, dmlToFormula dml) | |
946 | |
947 fun invalidations ((query, numArgs), dml) = | |
948 (map (map optionAtomExpToExp) | |
949 o removeRedundant madeRedundantBy | |
950 o map (eqsToInvalidation numArgs) | |
951 o eqss) | |
952 (query, dml) | |
953 | |
954 end | |
955 | |
956 val invalidations = Invalidations.invalidations | |
957 | |
958 (* DEBUG *) | |
959 (* val gunk : ((Sql.query * int) * Sql.dml) list ref = ref [] *) | |
960 (* val gunk' : exp list ref = ref [] *) | |
961 | |
962 fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) = | |
963 let | |
964 val flushes = List.concat | |
965 o map (fn (i, argss) => map (fn args => flush (i, args)) argss) | |
966 val doExp = | |
967 fn EDml (origDmlText, failureMode) => | |
968 let | |
969 (* DEBUG *) | |
970 (* val () = gunk' := origDmlText :: !gunk' *) | |
971 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText | |
972 val dmlText = incRels numArgs newDmlText | |
973 val dmlExp = EDml (dmlText, failureMode) | |
974 (* DEBUG *) | |
975 (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *) | |
976 val inval = | |
977 case Sql.parse Sql.dml dmlText of | |
978 SOME dmlParsed => | |
979 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of | |
980 SOME queryNumArgs => | |
981 (* DEBUG *) | |
982 ((* gunk := (queryNumArgs, dmlParsed) :: !gunk; *) | |
983 (i, invalidations (queryNumArgs, dmlParsed))) | |
984 (* TODO: fail more gracefully. *) | |
985 | NONE => raise Match)) | |
986 (SIMM.findList (tableToIndices, tableDml dmlParsed))) | |
987 | NONE => NONE | |
988 in | |
989 case inval of | |
990 (* TODO: fail more gracefully. *) | |
991 NONE => raise Match | |
992 | SOME invs => wrapLets (sequence (flushes invs @ [dmlExp])) | |
993 end | |
994 | e' => e' | |
995 in | |
996 (* DEBUG *) | |
997 (* gunk := []; *) | |
998 (fileMap doExp file, index, effs) | |
999 end | |
1000 | |
1001 | |
1002 (***************) | |
1003 (* Entry point *) | |
1004 (***************) | |
1005 | |
1006 val inlineSql = | |
1007 let | |
1008 val doExp = | |
1009 (* TODO: EQuery, too? *) | |
1010 (* ASK: should this live in [MonoOpt]? *) | |
1011 fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => | |
1012 let | |
1013 val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases | |
1014 in | |
1015 ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) | |
1016 end | |
1017 | e => e | |
1018 in | |
1019 fileMap doExp | |
1020 end | |
1021 | |
1008 fun insertAfterDatatypes ((decls, sideInfo), newDecls) = | 1022 fun insertAfterDatatypes ((decls, sideInfo), newDecls) = |
1009 let | 1023 let |
1010 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls | 1024 val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls |
1011 in | 1025 in |
1012 (datatypes @ newDecls @ others, sideInfo) | 1026 (datatypes @ newDecls @ others, sideInfo) |