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

2 files changed, 47 insertions, 0 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