Merge.

5 files changed, 130 insertions, 7 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 4cd347b2..d01cfaa2 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1664,6 +1664,10 @@ void uw_writec(uw_context ctx, char c) {
   uw_writec_unsafe(ctx, c);
 }
 
+void uw_Basis_writec(uw_context ctx, char c) {
+  uw_writec(ctx, c);
+}
+
 static void uw_write_unsafe(uw_context ctx, const char* s) {
   int len = strlen(s);
   memcpy(ctx->page.front, s, len);
diff --git a/src/elaborate.sml b/src/elaborate.sml
index c55dec01..749bd2f1 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -3020,6 +3020,25 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
 
       | (L'.SgnConst sgis1, L'.SgnConst sgis2) =>
         let
+            (* This reshuffling was added to avoid some unfortunate unification behavior.
+             * In particular, in sub-signature checking, constraints might be unified,
+             * even when we don't expect them to be unifiable, deciding on bad values
+             * for unification variables and dooming later unification.
+             * By putting all the constraints _last_, we allow all the other unifications
+             * to happen first, hoping that no unification variables survive to confuse
+             * constraint unification. *)
+
+            val sgis2 =
+                let
+                    val (constraints, others) = List.partition
+                                                   (fn (L'.SgiConstraint _, _) => true
+                                                   | _ => false) sgis2
+                in
+                    case constraints of
+                        [] => sgis2
+                      | _ => others @ constraints
+                end
+
             (*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1),
                                         ("sgn2", p_sgn env sgn2),
                                         ("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)),
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 97f78d3d..22ee36fc 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -167,6 +167,9 @@ fun exp e =
 
       | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2))
 
+      | EStrcat (e1, (EPrim (Prim.String (_, "")), _)) => #1 e1
+      | EStrcat ((EPrim (Prim.String (_, "")), _), e2) => #1 e2
+
       | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) =>
         let
             val s =
@@ -220,6 +223,11 @@ fun exp e =
       | EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) =>
         EFfiApp ("Basis", "htmlifySpecialChar_w", [e])
 
+      | EWrite (EFfiApp ("Basis", "intToString", [e]), _) =>
+        EFfiApp ("Basis", "htmlifyInt_w", [e])
+      | EApp ((EFfi ("Basis", "intToString"), loc), e) =>
+        EFfiApp ("Basis", "intToString", [(e, (TFfi ("Basis", "int"), loc))])
+
       | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) =>
         EPrim (Prim.String (Prim.Html, htmlifyInt n))
       | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) =>
@@ -621,6 +629,8 @@ fun exp e =
         EFfiApp ("Basis", "attrifyChar", [e])
       | EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) =>
         EFfiApp ("Basis", "attrifyChar_w", [e])
+      | EWrite (EFfiApp ("Basis", "str1", [e]), _) =>
+        EFfiApp ("Basis", "writec", [e])
 
       | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2)))
 
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 50553560..8ca84c15 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -39,6 +39,10 @@ structure U = MonoUtil
 structure IM = IntBinaryMap
 structure IS = IntBinarySet
 
+structure SS = BinarySetFn(struct
+                            type ord_key = string
+                            val compare = String.compare
+                            end)
 
 fun simpleTypeImpure tsyms =
     U.Typ.exists (fn TFun _ => true
@@ -208,6 +212,20 @@ fun match (env, p : pat, e : exp) =
         else
             No
 
+      | (PPrim (Prim.String (_, s)), _) =>
+        let
+            fun lengthLb (e : exp) =
+                case #1 e of
+                    EStrcat (e1, e2) => lengthLb e1 + lengthLb e2
+                  | EPrim (Prim.String (_, s)) => size s
+                  | _ => 0
+        in
+            if lengthLb e > size s then
+                No
+            else
+                Maybe
+        end
+
       | (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) =>
         if n1 = n2 then
             case (po, eo) of
@@ -578,6 +596,75 @@ fun reduce (file : file) =
                                  case e' of
                                      (ECase _, _) => e
                                    | _ => doSub ())
+
+                        fun isRecord () =
+                            case #1 e' of
+                                ERecord _ => true
+                              | _ => false
+
+                        fun whichProj i (e : exp) =
+                            case #1 e of
+                                EPrim _ => SOME SS.empty
+                              | ERel i' => if i' = i then NONE else SOME SS.empty
+                              | ENamed _ => SOME SS.empty
+                              | ECon (_, _, NONE) => SOME SS.empty
+                              | ECon (_, _, SOME e') => whichProj i e'
+                              | ENone _ => SOME SS.empty
+                              | ESome (_, e') => whichProj i e'
+                              | EFfi _ => SOME SS.empty
+                              | EFfiApp (_, _, es) => whichProjs i (map #1 es)
+                              | EApp (e1, e2) => whichProjs i [e1, e2]
+                              | EAbs (_, _, _, e) => whichProj (i + 1) e
+                              | EUnop (_, e1) => whichProj i e1
+                              | EBinop (_, _, e1, e2) => whichProjs i [e1, e2]
+                              | ERecord xets => whichProjs i (map #2 xets)
+                              | EField ((ERel i', _), s) =>
+                                if i' = i then
+                                    SOME (SS.singleton s)
+                                else
+                                    SOME SS.empty
+                              | EField (e1, _) => whichProj i e1
+                              | ECase (e1, pes, _) =>
+                                whichProjs' i ((0, e1)
+                                               :: map (fn (p, e) => (patBinds p, e)) pes)
+                              | EStrcat (e1, e2) => whichProjs i [e1, e2]
+                              | EError (e1, _) => whichProj i e1
+                              | EReturnBlob {blob = NONE, mimeType = e2, ...} => whichProj i e2
+                              | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => whichProjs i [e1, e2]
+                              | ERedirect (e1, _) => whichProj i e1
+                              | EWrite e1 => whichProj i e1
+                              | ESeq (e1, e2) => whichProjs i [e1, e2]
+                              | ELet (_, _, e1, e2) => whichProjs' i [(0, e1), (1, e2)]
+                              | EClosure (_, es) => whichProjs i es
+                              | EQuery {query = e1, body = e2, initial = e3, ...} =>
+                                whichProjs' i [(0, e1), (2, e2), (0, e3)]
+                              | EDml (e1, _) => whichProj i e1
+                              | ENextval e1 => whichProj i e1
+                              | ESetval (e1, e2) => whichProjs i [e1, e2]
+                              | EUnurlify (e1, _, _) => whichProj i e1
+                              | EJavaScript (_, e1) => whichProj i e1
+                              | ESignalReturn e1 => whichProj i e1
+                              | ESignalBind (e1, e2) => whichProjs i [e1, e2]
+                              | ESignalSource e1 => whichProj i e1
+                              | EServerCall (e1, _, _, _) => whichProj i e1
+                              | ERecv (e1, _) => whichProj i e1
+                              | ESleep e1 => whichProj i e1
+                              | ESpawn e1 => whichProj i e1
+
+                        and whichProjs i es =
+                            whichProjs' i (map (fn e => (0, e)) es)
+
+                        and whichProjs' i es =
+                            case es of
+                                [] => SOME SS.empty
+                              | (n, e) :: es' =>
+                                case (whichProj (i + n) e, whichProjs' i es') of
+                                    (SOME m1, SOME m2) =>
+                                    if SS.isEmpty (SS.intersection (m1, m2)) then
+                                        SOME (SS.union (m1, m2))
+                                    else
+                                        NONE
+                                  | _ => NONE
                     in
                         if impure env e' then
                             let
@@ -636,7 +723,10 @@ fun reduce (file : file) =
                                 else
                                     e
                             end
-                        else if countFree 0 0 b > 1 andalso not (!fullMode) andalso not (passive e') then
+                        else if countFree 0 0 b > 1
+                                andalso not (!fullMode)
+                                andalso not (passive e')
+                                andalso not (isRecord () andalso Option.isSome (whichProj 0 b)) then
                             e
                         else
                             trySub ()
diff --git a/src/monoize.sml b/src/monoize.sml
index fa69b3af..4034e3ed 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2003,9 +2003,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                            strcat [gf "Rows",
                                    (L'.ECase (gf "OrderBy",
                                               [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""),
-                                               ((L'.PWild, loc),
+                                               ((L'.PVar ("orderby", s), loc),
                                                 strcat [str " ORDER BY ",
-                                                        gf "OrderBy"])],
+                                                        (L'.ERel 0, loc)])],
                                               {disc = s, result = s}), loc),
                                    gf "Limit",
                                    gf "Offset"]), loc), fm)
@@ -2114,8 +2114,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                       [((L'.PPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))),
                                                          loc),
                                                         str ""),
-                                                       ((L'.PWild, loc),
-                                                        strcat [str " WHERE ", gf "Where"])],
+                                                       ((L'.PVar ("where", s), loc),
+                                                        strcat [str " WHERE ", (L'.ERel 0, loc)])],
                                                       {disc = s,
                                                        result = s}), loc),
 
@@ -2143,8 +2143,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                       [((L'.PPrim (Prim.String
                                                                        (Prim.Normal, #trueString (Settings.currentDbms ()))), loc),
                                                         str ""),
-                                                       ((L'.PWild, loc),
-                                                        strcat [str " HAVING ", gf "Having"])],
+                                                       ((L'.PVar ("having", s), loc),
+                                                        strcat [str " HAVING ", (L'.ERel 0, loc)])],
                                                       {disc = s,
                                                        result = s}), loc)
                                   ]), loc),