changeset 844:74a1e3bdf430

Fix datatype import bug in Elaborate; fix server-side source setting; more standard library stuff
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Jun 2009 16:45:00 -0400
parents 9f0ea203a1ca
children 6725d73c3c31
files lib/ur/basis.urs lib/ur/list.ur lib/ur/list.urs lib/ur/listPair.ur lib/ur/listPair.urs lib/ur/option.ur lib/ur/option.urs src/c/urweb.c src/elaborate.sml src/monoize.sml
diffstat 10 files changed, 85 insertions(+), 3 deletions(-) [+]
line wrap: on
line diff
--- a/lib/ur/basis.urs	Sun Jun 07 14:15:22 2009 -0400
+++ b/lib/ur/basis.urs	Sun Jun 07 16:45:00 2009 -0400
@@ -25,6 +25,7 @@
 val eq_char : eq char
 val eq_bool : eq bool
 val eq_time : eq time
+val eq_option : t ::: Type -> eq t -> eq (option t)
 val mkEq : t ::: Type -> (t -> t -> bool) -> eq t
 
 class num
--- a/lib/ur/list.ur	Sun Jun 07 14:15:22 2009 -0400
+++ b/lib/ur/list.ur	Sun Jun 07 16:45:00 2009 -0400
@@ -171,3 +171,15 @@
     in
         all'
     end
+
+fun app [m] (_ : monad m) [a] f =
+    let
+        fun app' ls =
+            case ls of
+                [] => return ()
+              | x :: ls =>
+                f x;
+                app' ls
+    in
+        app'
+    end
--- a/lib/ur/list.urs	Sun Jun 07 14:15:22 2009 -0400
+++ b/lib/ur/list.urs	Sun Jun 07 16:45:00 2009 -0400
@@ -35,3 +35,6 @@
 val search : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> option b
 
 val all : a ::: Type -> (a -> bool) -> t a -> bool
+
+val app : m ::: (Type -> Type) -> monad m -> a ::: Type
+          -> (a -> m unit) -> t a -> m unit
--- a/lib/ur/listPair.ur	Sun Jun 07 14:15:22 2009 -0400
+++ b/lib/ur/listPair.ur	Sun Jun 07 16:45:00 2009 -0400
@@ -8,3 +8,14 @@
     in
         mapX'
     end
+
+fun all [a] [b] f =
+    let
+        fun all' ls1 ls2 =
+            case (ls1, ls2) of
+                ([], []) => True
+              | (x1 :: ls1, x2 :: ls2) => f x1 x2 && all' ls1 ls2
+              | _ => False
+    in
+        all'
+    end
--- a/lib/ur/listPair.urs	Sun Jun 07 14:15:22 2009 -0400
+++ b/lib/ur/listPair.urs	Sun Jun 07 16:45:00 2009 -0400
@@ -1,2 +1,4 @@
 val mapX : a ::: Type -> b ::: Type -> ctx ::: {Unit}
            -> (a -> b -> xml ctx [] []) -> list a -> list b -> xml ctx [] []
+
+val all : a ::: Type -> b ::: Type -> (a -> b -> bool) -> list a -> list b -> bool
--- a/lib/ur/option.ur	Sun Jun 07 14:15:22 2009 -0400
+++ b/lib/ur/option.ur	Sun Jun 07 16:45:00 2009 -0400
@@ -4,3 +4,8 @@
     case x of
         None => False
       | Some _ => True
+
+fun mp [a] [b] f x =
+    case x of
+        None => None
+      | Some y => Some (f y)
--- a/lib/ur/option.urs	Sun Jun 07 14:15:22 2009 -0400
+++ b/lib/ur/option.urs	Sun Jun 07 16:45:00 2009 -0400
@@ -1,3 +1,5 @@
 datatype t = datatype Basis.option
 
 val isSome : a ::: Type -> t a -> bool
+
+val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b
--- a/src/c/urweb.c	Sun Jun 07 14:15:22 2009 -0400
+++ b/src/c/urweb.c	Sun Jun 07 16:45:00 2009 -0400
@@ -1278,12 +1278,12 @@
   size_t s_len = strlen(s);
 
   uw_check_script(ctx, 6 + INTS_MAX + s_len);
-  sprintf(ctx->script.front, "s%d.v=%n", (int)n, &len);
+  sprintf(ctx->script.front, "sv(s%d,%n", (int)n, &len);
   ctx->script.front += len;
   strcpy(ctx->script.front, s);
   ctx->script.front += s_len;
-  strcpy(ctx->script.front, ";");
-  ctx->script.front++;
+  strcpy(ctx->script.front, ");");
+  ctx->script.front += 2;
 
   return uw_unit_v;
 }
--- a/src/elaborate.sml	Sun Jun 07 14:15:22 2009 -0400
+++ b/src/elaborate.sml	Sun Jun 07 16:45:00 2009 -0400
@@ -3271,6 +3271,10 @@
                                       val env = E.pushDatatype env n' xs xncs
 
                                       val t = (L'.CNamed n', loc)
+                                      val nxs = length xs
+                                      val t = ListUtil.foldli (fn (i, _, t) =>
+                                                                  (L'.CApp (t, (L'.CRel (nxs - 1 - i), loc)), loc))
+                                                              t xs
                                       val env = foldl (fn ((x, n, to), env) =>
                                                           let
                                                               val t = case to of
--- a/src/monoize.sml	Sun Jun 07 14:15:22 2009 -0400
+++ b/src/monoize.sml	Sun Jun 07 16:45:00 2009 -0400
@@ -778,6 +778,48 @@
                                  (L'.TFfi ("Basis", "bool"), loc),
                                  (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
              fm)
+          | L.ECApp ((L.EFfi ("Basis", "eq_option"), _), t) =>
+            let
+                val t = monoType env t
+                val t' = (L'.TOption t, loc)
+                val bool = (L'.TFfi ("Basis", "bool"), loc)
+            in
+                ((L'.EAbs ("f", (L'.TFun (t, (L'.TFun (t, bool), loc)), loc),
+                           (L'.TFun (t', (L'.TFun (t', bool), loc)), loc),
+                           (L'.EAbs ("x", t', (L'.TFun (t', bool), loc),
+                                     (L'.EAbs ("y", t', bool,
+                                               (L'.ECase ((L'.ERecord [("1", (L'.ERel 1, loc), t'),
+                                                                       ("2", (L'.ERel 0, loc), t')], loc),
+                                                          [((L'.PRecord [("1", (L'.PNone t, loc), t'),
+                                                                         ("2", (L'.PNone t, loc), t')], loc),
+                                                            (L'.ECon (L'.Enum, L'.PConFfi {mod = "Basis",
+                                                                                           datatyp = "bool",
+                                                                                           con = "True",
+                                                                                           arg = NONE},
+                                                                      NONE), loc)),
+                                                           ((L'.PRecord [("1", (L'.PSome (t,
+                                                                                          (L'.PVar ("x1",
+                                                                                                    t), loc)),
+                                                                                loc), t'),
+                                                                         ("2", (L'.PSome (t,
+                                                                                          (L'.PVar ("x2",
+                                                                                                    t), loc)),
+                                                                                loc), t')], loc),
+                                                            (L'.EApp ((L'.EApp ((L'.ERel 4, loc),
+                                                                                (L'.ERel 1, loc)), loc),
+                                                                      (L'.ERel 0, loc)), loc)),
+                                                           ((L'.PWild, loc),
+                                                            (L'.ECon (L'.Enum, L'.PConFfi {mod = "Basis",
+                                                                                           datatyp = "bool",
+                                                                                           con = "False",
+                                                                                           arg = NONE},
+                                                                      NONE), loc))],
+                                                          {disc = (L'.TRecord [("1", t'), ("2", t')], loc),
+                                                           result = (L'.TFfi ("Basis", "bool"), loc)}),
+                                                loc)), loc)), loc)), loc),
+                 fm)
+            end
+
           | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) =>
             let
                 val t = monoType env t