From fe35c44cd34ceb2a2f02b27f56bf1607557bb89a Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 14 Sep 2008 19:03:55 -0400
Subject: Crud update form

---
 lib/basis.urs       |  2 +-
 lib/top.ur          |  6 ++++++
 lib/top.urs         |  5 +++++
 src/elab_env.sml    | 33 ++++++++++++++++++++++++++-------
 src/elaborate.sml   |  4 +++-
 src/mono_reduce.sml | 37 +++++++++++++++++++++++++++++++++----
 src/urweb.grm       | 18 ++++++++++++++++++
 tests/crud.ur       | 26 +++++++++++++++++++++++++-
 tests/crud.urs      |  1 +
 tests/crud1.ur      |  4 ++++
 10 files changed, 122 insertions(+), 14 deletions(-)

diff --git a/lib/basis.urs b/lib/basis.urs
index ed217e3a..7fd5dc52 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -296,7 +296,7 @@ con lformTag = fn ty :: Type => fn inner :: {Unit} => fn attrs :: {Type} =>
         ctx ::: {Unit} -> [LForm] ~ ctx
         -> nm :: Name -> unit
         -> tag attrs ([LForm] ++ ctx) inner [] [nm = ty]
-val textbox : lformTag string [] []
+val textbox : lformTag string [] [Value = string]
 val password : lformTag string [] []
 val ltextarea : lformTag string [] []
 
diff --git a/lib/top.ur b/lib/top.ur
index 15f2a732..990a18fa 100644
--- a/lib/top.ur
+++ b/lib/top.ur
@@ -103,3 +103,9 @@ fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (q : sql_que
         query q
                 (fn fs acc => return <xml>{acc}{f fs}</xml>)
                 <xml></xml>
+
+fun oneOrNoRows (tables ::: {{Type}}) (exps ::: {Type}) (q : sql_query tables exps) =
+        [tables ~ exps] =>
+        query q
+                (fn fs _ => return (Some fs))
+                None
diff --git a/lib/top.urs b/lib/top.urs
index 17ce5c28..add94578 100644
--- a/lib/top.urs
+++ b/lib/top.urs
@@ -66,3 +66,8 @@ val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
         -> ($(exps ++ fold (fn nm (fields :: {Type}) acc => [nm] ~ acc => [nm = $fields] ++ acc) [] tables)
                 -> xml ctx [] [])
         -> transaction (xml ctx [] [])
+
+val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type} -> sql_query tables exps
+        -> tables ~ exps
+        -> transaction
+                (option $(exps ++ fold (fn nm (fields :: {Type}) acc => [nm] ~ acc => [nm = $fields] ++ acc) [] tables))
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
@@ -75,6 +76,22 @@ fun amend_select loc (si, (tabs, exps)) =
             else
                 ErrorMsg.errorAt loc "Select of field from unbound table";
             
+            (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)
@@ -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)
diff --git a/tests/crud.ur b/tests/crud.ur
index 0a7efeec..66a685bf 100644
--- a/tests/crud.ur
+++ b/tests/crud.ur
@@ -2,6 +2,7 @@ con colMeta = fn t_formT :: (Type * Type) => {
         Nam : string,
         Show : t_formT.1 -> xbody,
         Widget : nm :: Name -> xml form [] [nm = t_formT.2],
+        WidgetPopulated : nm :: Name -> t_formT.1 -> xml form [] [nm = t_formT.2],
         Parse : t_formT.2 -> t_formT.1,
         Inject : sql_injectable t_formT.1
 }
@@ -36,6 +37,29 @@ fun create (inputs : $(mapT2T sndTT M.cols)) =
                 Inserted with ID {txt _ id}.
         </body></html>
 
+fun save (id : int) _ =
+        return <html><body>
+                Under Construction
+        </body></html>
+
+fun update (id : int) =
+        fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {id});
+        case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of
+          None => return <html><body>Not found!</body></html>
+        | Some fs => return <html><body><lform>
+                {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)]
+                        (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) =>
+                                [[nm] ~ rest] =>
+                                fn (v : t.1) (col : colMeta t) (acc : xml form [] (mapT2T sndTT rest)) => <lform>
+                                        <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
+                                        {useMore acc}
+                                </lform>)
+                        <lform></lform>
+                        [M.cols] fs.Tab M.cols}
+
+                <submit action={save id}/>
+        </lform></body></html>
+
 fun delete (id : int) =
         () <- dml (DELETE FROM tab WHERE Id = {id});
         return <html><body>
@@ -60,7 +84,7 @@ fun main () : transaction page =
                                                         <td>{col.Show v}</td>
                                                 </tr>)
                                         [M.cols] (fs.T -- #Id) M.cols}
-                                <td><a link={confirm fs.T.Id}>[Delete]</a></td>
+                                <td><a link={update fs.T.Id}>[Update]</a> <a link={confirm fs.T.Id}>[Delete]</a></td>
                         </tr>
                 </body>);
         return <html><head>
diff --git a/tests/crud.urs b/tests/crud.urs
index d445ed6e..3056392c 100644
--- a/tests/crud.urs
+++ b/tests/crud.urs
@@ -2,6 +2,7 @@ con colMeta = fn t_formT :: (Type * Type) => {
         Nam : string,
         Show : t_formT.1 -> xbody,
         Widget : nm :: Name -> xml form [] [nm = t_formT.2],
+        WidgetPopulated : nm :: Name -> t_formT.1 -> xml form [] [nm = t_formT.2],
         Parse : t_formT.2 -> t_formT.1,
         Inject : sql_injectable t_formT.1
 }
diff --git a/tests/crud1.ur b/tests/crud1.ur
index fa539dd3..fb2e4854 100644
--- a/tests/crud1.ur
+++ b/tests/crud1.ur
@@ -17,6 +17,7 @@ open Crud.Make(struct
                         Nam = "A",
                         Show = txt _,
                         Widget = fn nm :: Name => <lform><textbox{nm}/></lform>,
+                        WidgetPopulated = fn (nm :: Name) n => <lform><textbox{nm} value={show _ n}/></lform>,
                         Parse = readError _,
                         Inject = sql_int
                     },
@@ -24,6 +25,7 @@ open Crud.Make(struct
                         Nam = "B",
                         Show = txt _,
                         Widget = fn nm :: Name => <lform><textbox{nm}/></lform>,
+                        WidgetPopulated = fn (nm :: Name) s => <lform><textbox{nm} value={s}/></lform>,
                         Parse = readError _,
                         Inject = sql_string
                     },
@@ -31,6 +33,7 @@ open Crud.Make(struct
                         Nam = "C",
                         Show = txt _,
                         Widget = fn nm :: Name => <lform><textbox{nm}/></lform>,
+                        WidgetPopulated = fn (nm :: Name) n => <lform><textbox{nm} value={show _ n}/></lform>,
                         Parse = readError _,
                         Inject = sql_float
                     },
@@ -38,6 +41,7 @@ open Crud.Make(struct
                         Nam = "D",
                         Show = txt _,
                         Widget = fn nm :: Name => <lform><textbox{nm}/></lform>,
+                        WidgetPopulated = fn (nm :: Name) b => <lform><textbox{nm} value={show _ b}/></lform>,
                         Parse = readError _,
                         Inject = sql_bool
                     }
-- 
cgit v1.2.3