Mercurial > urweb
changeset 341:389399d65331
Crud update form
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 14 Sep 2008 19:03:55 -0400 |
| parents | 5ccb1c6412e4 |
| children | f55034419a07 |
| files | lib/basis.urs lib/top.ur lib/top.urs src/elab_env.sml src/elaborate.sml src/mono_reduce.sml src/urweb.grm tests/crud.ur tests/crud.urs tests/crud1.ur |
| diffstat | 10 files changed, 122 insertions(+), 14 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/basis.urs Sun Sep 14 15:20:53 2008 -0400 +++ b/lib/basis.urs Sun Sep 14 19:03:55 2008 -0400 @@ -296,7 +296,7 @@ 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 [] []
--- a/lib/top.ur Sun Sep 14 15:20:53 2008 -0400 +++ b/lib/top.ur Sun Sep 14 19:03:55 2008 -0400 @@ -103,3 +103,9 @@ 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
--- a/lib/top.urs Sun Sep 14 15:20:53 2008 -0400 +++ b/lib/top.urs Sun Sep 14 19:03:55 2008 -0400 @@ -66,3 +66,8 @@ -> ($(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))
--- a/src/elab_env.sml Sun Sep 14 15:20:53 2008 -0400 +++ b/src/elab_env.sml Sun Sep 14 19:03:55 2008 -0400 @@ -795,7 +795,10 @@ | 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 @@ 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 @@ 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 - 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', NONE) + end + else + NONE + | SgiDatatypeImp (x, _, m1, ms, 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', SOME (CModProj (m1, ms, x'), #2 sgn)) + end else NONE | SgiClassAbs (x, _) => if x = field then @@ -1032,8 +1052,7 @@ (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) =>
--- a/src/elaborate.sml Sun Sep 14 15:20:53 2008 -0400 +++ b/src/elaborate.sml Sun Sep 14 19:03:55 2008 -0400 @@ -1321,7 +1321,9 @@ | 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
--- a/src/mono_reduce.sml Sun Sep 14 15:20:53 2008 -0400 +++ b/src/mono_reduce.sml Sun Sep 14 19:03:55 2008 -0400 @@ -111,6 +111,21 @@ 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 @@ 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
--- a/src/urweb.grm Sun Sep 14 15:20:53 2008 -0400 +++ b/src/urweb.grm Sun Sep 14 19:03:55 2008 -0400 @@ -43,6 +43,7 @@ datatype select_item = Field of con * con | Exp of con * exp + | Fields of con * con datatype select = Star @@ -77,6 +78,22 @@ (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 @@ 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)
--- a/tests/crud.ur Sun Sep 14 15:20:53 2008 -0400 +++ b/tests/crud.ur Sun Sep 14 19:03:55 2008 -0400 @@ -2,6 +2,7 @@ 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 @@ 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 @@ <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>
--- a/tests/crud.urs Sun Sep 14 15:20:53 2008 -0400 +++ b/tests/crud.urs Sun Sep 14 19:03:55 2008 -0400 @@ -2,6 +2,7 @@ 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 }
--- a/tests/crud1.ur Sun Sep 14 15:20:53 2008 -0400 +++ b/tests/crud1.ur Sun Sep 14 19:03:55 2008 -0400 @@ -17,6 +17,7 @@ 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 @@ 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 @@ 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 @@ 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 }