Crud update form

4 files changed, 80 insertions, 12 deletions

diff --git a/src/elab_env.sml b/src/elab_env.sml
index 3f32ed21..4ff026f1 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -795,7 +795,10 @@ fun sgiBinds env (sgi, loc) =
       | SgiCon (x, n, k, c) => pushCNamedAs env x n k (SOME c)
       | SgiDatatype (x, n, xs, xncs) =>
         let
-            val env = pushCNamedAs env x n (KType, loc) NONE
+            val k = (KType, loc)
+            val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs
+
+            val env = pushCNamedAs env x n k' NONE
         in
             foldl (fn ((x', n', to), env) =>
                       let
@@ -813,7 +816,10 @@ fun sgiBinds env (sgi, loc) =
         end
       | SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) =>
         let
-            val env = pushCNamedAs env x n (KType, loc) (SOME (CModProj (m1, ms, x'), loc))
+            val k = (KType, loc)
+            val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs
+
+            val env = pushCNamedAs env x n k' (SOME (CModProj (m1, ms, x'), loc))
         in
             foldl (fn ((x', n', to), env) =>
                       let
@@ -880,10 +886,24 @@ fun projectCon env {sgn, str, field} =
         SgnConst sgis =>
         (case sgnSeek (fn SgiConAbs (x, _, k) => if x = field then SOME (k, NONE) else NONE
                         | SgiCon (x, _, k, c) => if x = field then SOME (k, SOME c) else NONE
-                        | SgiDatatype (x, _, _, _) => if x = field then SOME ((KType, #2 sgn), NONE) else NONE
-                        | SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
+                        | SgiDatatype (x, _, xs, _) =>
+                          if x = field then
+                              let
+                                  val k = (KType, #2 sgn)
+                                  val k' = foldl (fn (_, k') => (KArrow (k, k'), #2 sgn)) k xs
+                              in
+                                  SOME (k', NONE)
+                              end
+                          else
+                              NONE
+                        | SgiDatatypeImp (x, _, m1, ms, x', xs, _) =>
                           if x = field then
-                              SOME ((KType, #2 sgn), SOME (CModProj (m1, ms, x'), #2 sgn))
+                              let
+                                  val k = (KType, #2 sgn)
+                                  val k' = foldl (fn (_, k') => (KArrow (k, k'), #2 sgn)) k xs
+                              in
+                                  SOME (k', SOME (CModProj (m1, ms, x'), #2 sgn))
+                              end
                           else
                               NONE
                         | SgiClassAbs (x, _) => if x = field then
@@ -1032,8 +1052,7 @@ fun declBinds env (d, loc) =
                                                 (KArrow (k, kb), loc)))
                                            ((CNamed n, loc), k) xs
 
-            val t' = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs
-            val env = pushCNamedAs env x n kb (SOME t')
+            val env = pushCNamedAs env x n kb (SOME t)
             val env = pushDatatype env n xs xncs
         in
             foldl (fn ((x', n', to), env) =>
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 70404cf1..7702e0ff 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1321,7 +1321,9 @@ fun exhaustive (env, denv, t, ps) =
                               | SOME (_, cons) => dtype cons
                         end
                       | L'.CError => (true, gs)
-                      | _ => raise Fail "isTotal: Not a datatype"
+                      | c =>
+                        (prefaces "Not a datatype" [("c", p_con env (c, ErrorMsg.dummySpan))];
+                         raise Fail "isTotal: Not a datatype")
                 end
               | Record _ => (List.all (fn c2 => coverageImp (c, c2)) (enumerateCases t), [])
     in
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index c7b727ee..e288e34e 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -111,6 +111,21 @@ val swapExpVars =
                 bind = fn (lower, U.Exp.RelE _) => lower+1
                         | (lower, _) => lower}
 
+val swapExpVarsPat =
+    U.Exp.mapB {typ = fn t => t,
+                exp = fn (lower, len) => fn e =>
+                                     case e of
+                                         ERel xn =>
+                                         if xn = lower then
+                                             ERel (lower + 1)
+                                         else if xn >= lower + 1 andalso xn < lower + 1 + len then
+                                             ERel (xn - 1)
+                                         else
+                                             e
+                                       | _ => e,
+                bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
+                        | (st, _) => st}
+
 datatype result = Yes of E.env | No | Maybe
 
 fun match (env, p : pat, e : exp) =
@@ -272,15 +287,29 @@ fun exp env e =
         else
             #1 (reduceExp env (subExpInExp (0, e2) e1)))
 
-      | ECase (disc, pes, _) =>
+      | ECase (e', pes, {disc, result}) =>
         let
+            fun push () =
+                case result of
+                    (TFun (dom, result), loc) =>
+                    if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then
+                        EAbs ("_", dom, result,
+                              (ECase (liftExpInExp 0 e',
+                                      map (fn (p, (EAbs (_, _, _, e), _)) =>
+                                              (p, swapExpVarsPat (0, patBinds p) e)
+                                            | _ => raise Fail "MonoReduce ECase") pes,
+                                      {disc = disc, result = result}), loc))
+                    else
+                        e
+                  | _ => e
+
             fun search pes =
                 case pes of
-                    [] => e
+                    [] => push ()
                   | (p, body) :: pes =>
-                    case match (env, p, disc) of
+                    case match (env, p, e') of
                         No => search pes
-                      | Maybe => e
+                      | Maybe => push ()
                       | Yes env => #1 (reduceExp env body)
         in
             search pes
diff --git a/src/urweb.grm b/src/urweb.grm
index d3e7fe5b..8219c35b 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -43,6 +43,7 @@ fun entable t =
 datatype select_item =
          Field of con * con
        | Exp of con * exp
+       | Fields of con * con
 
 datatype select =
          Star
@@ -77,6 +78,22 @@ fun amend_select loc (si, (tabs, exps)) =
             
             (tabs, exps)
         end
+      | Fields (tx, fs) =>
+        let
+            val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) =>
+                                                      if eqTnames (tx, tx') then
+                                                          ((tx', (CConcat (fs, c'), loc)), true)
+                                                      else
+                                                          ((tx', c'), found))
+                                                  false tabs
+        in
+            if found then
+                ()
+            else
+                ErrorMsg.errorAt loc "Select of field from unbound table";
+            
+            (tabs, exps)
+        end
       | Exp (c, e) => (tabs, (c, e) :: exps)
 
 fun amend_group loc (gi, tabs) =
@@ -1041,6 +1058,7 @@ fident : CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLr
 
 seli   : tident DOT fident              (Field (tident, fident))
        | sqlexp AS fident               (Exp (fident, sqlexp))
+       | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (Fields (tident, cexp))
 
 selis  : seli                           ([seli])
        | seli COMMA selis               (seli :: selis)