Eta-expand bodies of transaction functions in Monoization, to enable later optimization

5 files changed, 106 insertions, 29 deletions

diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index 3abd8b97..bca5f4ba 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -133,6 +133,20 @@ fun mapM [m ::: (Type -> Type)] (_ : monad m) [a] [b] f =
         mapM' []
     end
 
+fun mapPartialM [m ::: (Type -> Type)] (_ : monad m) [a] [b] f =
+    let
+        fun mapPartialM' acc ls =
+            case ls of
+                [] => return (rev acc)
+              | x :: ls =>
+                v <- f x;
+                mapPartialM' (case v of
+                                  None => acc
+                                | Some x' => x' :: acc) ls
+    in
+        mapPartialM' []
+    end
+
 fun mapXM [m ::: (Type -> Type)] (_ : monad m) [a] [ctx ::: {Unit}] f =
     let
         fun mapXM' ls =
@@ -237,6 +251,25 @@ fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
                 [];
     return (rev ls)
 
+fun mapQueryM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
+             [tables ~ exps] (q : sql_query tables exps)
+             (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction t) =
+    ls <- query q
+                (fn fs acc => v <- f fs; return (v :: acc))
+                [];
+    return (rev ls)
+
+fun mapQueryPartialM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
+             [tables ~ exps] (q : sql_query tables exps)
+             (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (option t)) =
+    ls <- query q
+                (fn fs acc => v <- f fs;
+                    return (case v of
+                                None => acc
+                              | Some v => v :: acc))
+                [];
+    return (rev ls)
+
 fun assoc [a] [b] (_ : eq a) (x : a) =
     let
         fun assoc' (ls : list (a * b)) =
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index 5f3fad9c..c5e41816 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -27,6 +27,8 @@ val mapX : a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> t a -> xml ct
 val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type
            -> (a -> m b) -> t a -> m (t b)
 
+val mapPartialM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m (option b)) -> t a -> m (t b)
+                                                                        
 val mapXM : m ::: (Type -> Type) -> monad m -> a ::: Type -> ctx ::: {Unit}
             -> (a -> m (xml ctx [] [])) -> t a -> m (xml ctx [] [])
 
@@ -53,6 +55,18 @@ val mapQuery : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
     -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> t)
     -> transaction (list t)
 
+val mapQueryM : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+               -> [tables ~ exps] =>
+    sql_query tables exps
+    -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction t)
+    -> transaction (list t)
+
+val mapQueryPartialM : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+               -> [tables ~ exps] =>
+    sql_query tables exps
+    -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (option t))
+    -> transaction (list t)
+
 (** Association lists *)
 
 val assoc : a ::: Type -> b ::: Type -> eq a -> a -> t (a * b) -> option b
diff --git a/src/mono_print.sml b/src/mono_print.sml
index d190640e..a5e795b2 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -206,18 +206,26 @@ fun p_exp' par env (e, _) =
              string ".",
              string x]
 
-      | ECase (e, pes, _) => parenIf true (box [string "case",
-                                                space,
-                                                p_exp env e,
-                                                space,
-                                                string "of",
-                                                space,
-                                                p_list_sep (box [space, string "|", space])
-                                                           (fn (p, e) => box [p_pat env p,
-                                                                              space,
-                                                                              string "=>",
-                                                                              space,
-                                                                              p_exp (E.patBinds env p) e]) pes])
+      | ECase (e, pes, {result, ...}) => parenIf true (box [string "case",
+                                                            space,
+                                                            p_exp env e,
+                                                            space,
+                                                            if !debug then
+                                                                box [string "return",
+                                                                     space,
+                                                                     p_typ env result,
+                                                                     space]
+                                                            else
+                                                                box [],
+                                                            string "of",
+                                                            space,
+                                                            p_list_sep (box [space, string "|", space])
+                                                                       (fn (p, e) => box [p_pat env p,
+                                                                                          space,
+                                                                                          string "=>",
+                                                                                          space,
+                                                                                          p_exp (E.patBinds env p) e])
+                                                                       pes])
 
       | EError (e, t) => box [string "(error",
                               space,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index aa6b7051..16cfd9f9 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -582,23 +582,22 @@ fun reduce file =
                             fun push () =
                                 case result of
                                     (TFun (dom, result), loc) =>
-                                    if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then
-                                        let
-                                            val r =
-                                                EAbs ("y", dom, result,
-                                                      (ECase (liftExpInExp 0 e',
-                                                              map (fn (p, (EAbs (_, _, _, e), _)) =>
-                                                                      (p, swapExpVarsPat (0, patBinds p) e)
-                                                                    | _ => raise Fail "MonoReduce ECase") pes,
-                                                              {disc = disc, result = result}), loc))
-                                        in
-                                            (*Print.prefaces "Swapped"
-                                                           [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
-                                                            ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
-                                            r
-                                        end
-                                    else
-                                        e
+                                    let
+                                        fun safe (e, _) =
+                                            case e of
+                                                EAbs _ => true
+                                              | _ => false
+                                    in
+                                        if List.all (safe o #2) pes then
+                                            EAbs ("y", dom, result,
+                                                  (ECase (liftExpInExp 0 e',
+                                                          map (fn (p, (EAbs (_, _, _, e), _)) =>
+                                                                  (p, swapExpVarsPat (0, patBinds p) e)
+                                                                | _ => raise Fail "MonoReduce ECase") pes,
+                                                          {disc = disc, result = result}), loc))
+                                        else
+                                            e
+                                    end
                                   | _ => e
 
                             fun search pes =
diff --git a/src/monoize.sml b/src/monoize.sml
index afe2012f..4d3bfda2 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3440,6 +3440,29 @@ fun monoDecl (env, fm) (all as (d, loc)) =
             end
           | L.DValRec vis =>
             let
+                val vis = map (fn (x, n, t, e, s) =>
+                                  let
+                                      fun maybeTransaction (t, e) =
+                                          case (#1 t, #1 e) of
+                                              (L.CApp ((L.CFfi ("Basis", "transaction"), _), _), _) =>
+                                              SOME (L.EAbs ("_",
+                                                            (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc),
+                                                            t,
+                                                            (L.EApp (CoreEnv.liftExpInExp 0 e,
+                                                                     (L.ERecord [], loc)), loc)), loc)
+                                            | (L.TFun (dom, ran), L.EAbs (x, _, _, e)) =>
+                                              (case maybeTransaction (ran, e) of
+                                                   NONE => NONE
+                                                 | SOME e => SOME (L.EAbs (x, dom, ran, e), loc))
+                                            | _ => NONE
+                                  in
+                                      (x, n, t,
+                                       case maybeTransaction (t, e) of
+                                           NONE => e
+                                         | SOME e => e,
+                                       s)
+                                  end) vis
+
                 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
 
                 val (vis, fm) = ListUtil.foldlMap