Do 'open constraints' automatically; fix sourceless <cselect> monoize bug; Monad library module

8 files changed, 35 insertions, 12 deletions

diff --git a/demo/batchFun.ur b/demo/batchFun.ur
index 4243970a..560c0c55 100644
--- a/demo/batchFun.ur
+++ b/demo/batchFun.ur
@@ -34,7 +34,6 @@ functor Make(M : sig
                  val cols : colsMeta cols
              end) = struct
 
-    open constraints M
     val t = M.tab
 
     datatype list t = Nil | Cons of t * list t
diff --git a/demo/crud.ur b/demo/crud.ur
index baf157e5..72523a9d 100644
--- a/demo/crud.ur
+++ b/demo/crud.ur
@@ -42,7 +42,6 @@ functor Make(M : sig
                  val cols : colsMeta cols
              end) = struct
 
-    open constraints M
     val tab = M.tab
 
     sequence seq
diff --git a/lib/ur/monad.ur b/lib/ur/monad.ur
new file mode 100644
index 00000000..41f44d3a
--- /dev/null
+++ b/lib/ur/monad.ur
@@ -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 --git a/lib/ur/monad.urs b/lib/ur/monad.urs
new file mode 100644
index 00000000..cfe0ef8e
--- /dev/null
+++ b/lib/ur/monad.urs
@@ -0,0 +1,2 @@
+val exec : m ::: (Type -> Type) -> monad m -> ts ::: {Type}
+           -> $(map m ts) -> folder ts -> m $ts
diff --git a/src/compiler.sml b/src/compiler.sml
index fb5ed0e0..4209426f 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -589,6 +589,8 @@ fun capitalize "" = ""
 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 parse = {
 
                           val sgn = (Source.SgnConst (#func parseUrs urs), loc)
                       in
+                          checkErrors ();
                           (Source.DFfiStr (mname, sgn), loc)
                       end
 
@@ -617,6 +620,7 @@ val parse = {
                                         {file = urs,
                                          first = ErrorMsg.dummyPos,
                                          last = ErrorMsg.dummyPos})
+                                  before checkErrors ()
                               else
                                   NONE
 
@@ -626,12 +630,18 @@ val parse = {
 
                           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 --git a/src/elaborate.sml b/src/elaborate.sml
index 62d99bf3..87c1eb27 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -3355,6 +3355,10 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                             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 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                            | _ => 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 @@ and elabStr (env, denv) (str, loc) =
         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 --git a/src/jscomp.sml b/src/jscomp.sml
index e162aa7f..f197ce13 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -374,10 +374,8 @@ fun process file =
                          ((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 --git a/src/monoize.sml b/src/monoize.sml
index 4d7a666e..9654fd53 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2716,11 +2716,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                     (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