# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1243957853 14400
# Node ID 74e9e7642f0849eb0c64e2eb9cef9a330fefd87f
# Parent  9a1026e2b3f57fbb9a5a4cc027751e4a97b7fe35
Do 'open constraints' automatically; fix sourceless <cselect> monoize bug; Monad library module

diff -r 9a1026e2b3f5 -r 74e9e7642f08 demo/batchFun.ur
--- a/demo/batchFun.ur	Sun May 31 15:25:27 2009 -0400
+++ b/demo/batchFun.ur	Tue Jun 02 11:50:53 2009 -0400
@@ -34,7 +34,6 @@
                  val cols : colsMeta cols
              end) = struct
 
-    open constraints M
     val t = M.tab
 
     datatype list t = Nil | Cons of t * list t
diff -r 9a1026e2b3f5 -r 74e9e7642f08 demo/crud.ur
--- a/demo/crud.ur	Sun May 31 15:25:27 2009 -0400
+++ b/demo/crud.ur	Tue Jun 02 11:50:53 2009 -0400
@@ -42,7 +42,6 @@
                  val cols : colsMeta cols
              end) = struct
 
-    open constraints M
     val tab = M.tab
 
     sequence seq
diff -r 9a1026e2b3f5 -r 74e9e7642f08 lib/ur/monad.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/ur/monad.ur	Tue Jun 02 11:50:53 2009 -0400
@@ -0,0 +1,7 @@
+fun exec [m ::: Type -> Type] (_ : monad m) [ts ::: {Type}] r (fd : folder ts) =
+    foldR [m] [fn ts => m $ts]
+    (fn [nm :: Name] [v :: Type] [rest :: {Type}] [[nm] ~ rest] action acc =>
+        this <- action;
+        others <- acc;
+        return ({nm = this} ++ others))
+    (return {}) [ts] fd r
diff -r 9a1026e2b3f5 -r 74e9e7642f08 lib/ur/monad.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/ur/monad.urs	Tue Jun 02 11:50:53 2009 -0400
@@ -0,0 +1,2 @@
+val exec : m ::: (Type -> Type) -> monad m -> ts ::: {Type}
+           -> $(map m ts) -> folder ts -> m $ts
diff -r 9a1026e2b3f5 -r 74e9e7642f08 src/compiler.sml
--- a/src/compiler.sml	Sun May 31 15:25:27 2009 -0400
+++ b/src/compiler.sml	Tue Jun 02 11:50:53 2009 -0400
@@ -589,6 +589,8 @@
 val parse = {
     func = fn {database, sources = fnames, ffi, ...} : job =>
               let
+                  val anyErrors = ref false
+                  fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ())
                   fun nameOf fname = capitalize (OS.Path.file fname)
 
                   fun parseFfi fname =
@@ -602,6 +604,7 @@
 
                           val sgn = (Source.SgnConst (#func parseUrs urs), loc)
                       in
+                          checkErrors ();
                           (Source.DFfiStr (mname, sgn), loc)
                       end
 
@@ -617,6 +620,7 @@
                                         {file = urs,
                                          first = ErrorMsg.dummyPos,
                                          last = ErrorMsg.dummyPos})
+                                  before checkErrors ()
                               else
                                   NONE
 
@@ -626,12 +630,18 @@
 
                           val ds = #func parseUr ur
                       in
+                          checkErrors ();
                           (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
                       end
 
                   val dsFfi = map parseFfi ffi
                   val ds = map parseOne fnames
               in
+                  if !anyErrors then
+                      ErrorMsg.error "Parse failure"
+                  else
+                      ();
+
                   let
                       val final = nameOf (List.last fnames)
 
diff -r 9a1026e2b3f5 -r 74e9e7642f08 src/elaborate.sml
--- a/src/elaborate.sml	Sun May 31 15:25:27 2009 -0400
+++ b/src/elaborate.sml	Tue Jun 02 11:50:53 2009 -0400
@@ -3355,6 +3355,10 @@
                             end
 
                     val (env', n) = E.pushStrNamed env x sgn'
+                    val denv' =
+                        case #1 str' of
+                            L'.StrConst _ => dopenConstraints (loc, env', denv) {str = x, strs = []}
+                          | _ => denv
                 in
                     case #1 (hnormSgn env sgn') of
                         L'.SgnFun _ =>
@@ -3363,7 +3367,7 @@
                            | _ => strError env (FunctorRebind loc))
                       | _ => ();
 
-                    ([(L'.DStr (x, n, sgn', str'), loc)], (env', denv, gs' @ gs))
+                    ([(L'.DStr (x, n, sgn', str'), loc)], (env', denv', gs' @ gs))
                 end
 
               | L.DFfiStr (x, sgn) =>
@@ -3721,14 +3725,15 @@
         let
             val (dom', gs1) = elabSgn (env, denv) dom
             val (env', n) = E.pushStrNamed env m dom'
-            val (str', actual, gs2) = elabStr (env', denv) str
+            val denv' = dopenConstraints (loc, env', denv) {str = m, strs = []}
+            val (str', actual, gs2) = elabStr (env', denv') str
 
             val (formal, gs3) =
                 case ranO of
                     NONE => (actual, [])
                   | SOME ran =>
                     let
-                        val (ran', gs) = elabSgn (env', denv) ran
+                        val (ran', gs) = elabSgn (env', denv') ran
                     in
                         subSgn env' actual ran';
                         (ran', gs)
diff -r 9a1026e2b3f5 -r 74e9e7642f08 src/jscomp.sml
--- a/src/jscomp.sml	Sun May 31 15:25:27 2009 -0400
+++ b/src/jscomp.sml	Tue Jun 02 11:50:53 2009 -0400
@@ -374,10 +374,8 @@
                          ((EApp ((ENamed n', loc), e), loc), st)
                      end)
 
-              | _ => raise CantEmbed t
-                             (*(EM.errorAt loc "Don't know how to embed type in JavaScript";
-                      Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
-                      (str loc "ERROR", st))*)
+              | _ => ((*Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];*)
+                      raise CantEmbed t)
 
         fun unurlifyExp loc (t : typ, st) =
             case #1 t of
diff -r 9a1026e2b3f5 -r 74e9e7642f08 src/monoize.sml
--- a/src/monoize.sml	Sun May 31 15:25:27 2009 -0400
+++ b/src/monoize.sml	Tue Jun 02 11:50:53 2009 -0400
@@ -2716,11 +2716,14 @@
                     (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
                          NONE =>
                          let
+                             val (xml, fm) = monoExp (env, st, fm) xml
                              val (ts, fm) = tagStart "select"
                          in
-                             ((L'.EStrcat (ts,
-                                           (L'.EPrim (Prim.String " />"), loc)),
-                               loc), fm)
+                             (strcat [ts,
+                                      str ">",
+                                      xml,
+                                      str "</select>"],
+                              fm)
                          end
                        | SOME (_, src, _) =>
                          let