grid1 compiles but gets stuck in JS

4 files changed, 58 insertions, 0 deletions

diff --git a/lib/ur/monad.ur b/lib/ur/monad.ur
index 356173fd..d6690839 100644
--- a/lib/ur/monad.ur
+++ b/lib/ur/monad.ur
@@ -34,6 +34,19 @@ fun foldR2 [K] [m] (_ : monad m) [tf1 :: K -> Type] [tf2 :: K -> Type] [tr :: {K
        (fn _ _ => return i)
        [_] fl
 
+fun foldR3 [K] [m] (_ : monad m) [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tr :: {K} -> Type]
+           (f : nm :: Name -> t :: K -> rest :: {K}
+                -> [[nm] ~ rest] =>
+            tf1 t -> tf2 t -> tf3 t -> tr rest -> m (tr ([nm = t] ++ rest)))
+           (i : tr []) [r :: {K}] (fl : folder r) =
+    Top.fold [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> m (tr r)]
+       (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] 
+                        (acc : _ -> _ -> _ -> m (tr rest)) r1 r2 r3 =>
+           acc' <- acc (r1 -- nm) (r2 -- nm) (r3 -- nm);
+           f [nm] [t] [rest] ! r1.nm r2.nm r3.nm acc')
+       (fn _ _ _ => return i)
+       [_] fl
+
 fun mapR [K] [m] (_ : monad m) [tf :: K -> Type] [tr :: K -> Type]
          (f : nm :: Name -> t :: K -> tf t -> m (tr t)) =
     @@foldR [m] _ [tf] [fn r => $(map tr r)]
diff --git a/lib/ur/monad.urs b/lib/ur/monad.urs
index 662d780f..f64e2362 100644
--- a/lib/ur/monad.urs
+++ b/lib/ur/monad.urs
@@ -22,6 +22,15 @@ val foldR2 : K --> m ::: (Type -> Type) -> monad m
              -> tr []
              -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> m (tr r)
 
+val foldR3 : K --> m ::: (Type -> Type) -> monad m
+             -> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type)
+             -> tr :: ({K} -> Type)
+             -> (nm :: Name -> t :: K -> rest :: {K}
+                 -> [[nm] ~ rest] =>
+                       tf1 t -> tf2 t -> tf3 t -> tr rest -> m (tr ([nm = t] ++ rest)))
+             -> tr []
+             -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> m (tr r)
+
 val mapR : K --> m ::: (Type -> Type) -> monad m
            -> tf :: (K -> Type)
            -> tr :: (K -> Type)
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index ce110b27..7073884f 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -155,6 +155,17 @@ fun foldR2 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tr :: {K} -> Type]
            f [nm] [t] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
        (fn _ _ => i)
 
+fun foldR3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tr :: {K} -> Type]
+            (f : nm :: Name -> t :: K -> rest :: {K}
+                 -> [[nm] ~ rest] =>
+                       tf1 t -> tf2 t -> tf3 t -> tr rest -> tr ([nm = t] ++ rest))
+            (i : tr []) [r :: {K}] (fl : folder r) =
+    fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> tr r]
+       (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] 
+                        (acc : _ -> _ -> _ -> tr rest) r1 r2 r3 =>
+           f [nm] [t] [rest] ! r1.nm r2.nm r3.nm (acc (r1 -- nm) (r2 -- nm) (r3 -- nm)))
+       (fn _ _ _ => i)
+
 fun foldRX [K] [tf :: K -> Type] [ctx :: {Unit}]
             (f : nm :: Name -> t :: K -> rest :: {K}
                  -> [[nm] ~ rest] =>
@@ -174,6 +185,16 @@ fun foldRX2 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [ctx :: {Unit}]
                <xml>{f [nm] [t] [rest] ! r1 r2}{acc}</xml>)
            <xml/>
 
+fun foldRX3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [ctx :: {Unit}]
+             (f : nm :: Name -> t :: K -> rest :: {K}
+                  -> [[nm] ~ rest] =>
+                        tf1 t -> tf2 t -> tf3 t -> xml ctx [] []) =
+    foldR3 [tf1] [tf2] [tf3] [fn _ => xml ctx [] []]
+           (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest]
+                            r1 r2 r3 acc =>
+               <xml>{f [nm] [t] [rest] ! r1 r2 r3}{acc}</xml>)
+           <xml/>
+
 fun queryI [tables ::: {{Type}}] [exps ::: {Type}]
            [tables ~ exps] (q : sql_query tables exps)
            (f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index bdf9d904..a19961f4 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -84,6 +84,14 @@ val foldR2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type)
              -> tr []
              -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> tr r
 
+val foldR3 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type)
+             -> tr :: ({K} -> Type)
+             -> (nm :: Name -> t :: K -> rest :: {K}
+                 -> [[nm] ~ rest] =>
+                       tf1 t -> tf2 t -> tf3 t -> tr rest -> tr ([nm = t] ++ rest))
+             -> tr []
+             -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> tr r
+
 val foldRX : K --> tf :: (K -> Type) -> ctx :: {Unit}
              -> (nm :: Name -> t :: K -> rest :: {K}
                  -> [[nm] ~ rest] =>
@@ -97,6 +105,13 @@ val foldRX2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit}
               -> r :: {K} -> folder r
               -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
 
+val foldRX3 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) -> ctx :: {Unit}
+              -> (nm :: Name -> t :: K -> rest :: {K}
+                  -> [[nm] ~ rest] =>
+                        tf1 t -> tf2 t -> tf3 t -> xml ctx [] [])
+              -> r :: {K} -> folder r
+              -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> xml ctx [] []
+
 val queryI : tables ::: {{Type}} -> exps ::: {Type}
              -> [tables ~ exps] =>
              sql_query tables exps