diff lib/top.ur @ 418:ad7e854a518c

Metaform demos, minus prose
author Adam Chlipala <adamc@hcoop.net>
date Thu, 23 Oct 2008 14:03:12 -0400
parents df4cbd90a26e
children 0ce90d4d9ae7
line wrap: on
line diff
--- a/lib/top.ur	Thu Oct 23 12:58:35 2008 -0400
+++ b/lib/top.ur	Thu Oct 23 14:03:12 2008 -0400
@@ -36,6 +36,26 @@
                  f [nm] [rest] r.nm (acc (r -- nm)))
              (fn _ => i)
 
+fun foldUR2 (tf1 :: Type) (tf2 :: Type) (tr :: {Unit} -> Type)
+           (f : nm :: Name -> rest :: {Unit}
+                -> fn [[nm] ~ rest] =>
+                      tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest))
+           (i : tr []) =
+    fold [fn r :: {Unit} => $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r]
+             (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
+                              [[nm] ~ rest] r1 r2 =>
+                 f [nm] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
+             (fn _ _ => i)
+
+fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit})
+           (f : nm :: Name -> rest :: {Unit}
+                -> fn [[nm] ~ rest] =>
+                      tf1 -> tf2 -> xml ctx [] []) =
+    foldUR2 [tf1] [tf2] [fn _ => xml ctx [] []]
+            (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] v1 v2 acc =>
+                <xml>{f [nm] [rest] v1 v2}{acc}</xml>)
+            <xml/>
+
 fun foldTR (tf :: Type -> Type) (tr :: {Type} -> Type)
            (f : nm :: Name -> t :: Type -> rest :: {Type}
                 -> fn [[nm] ~ rest] =>