Mercurial > urweb
changeset 930:51bc7681c47e
Nullable columns *might* be working, but too much JS is generated for the page to load in finite time
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 12 Sep 2009 15:08:16 -0400 |
| parents | 095df8f710e0 |
| children | be6585b4058b |
| files | demo/more/dbgrid.ur demo/more/dbgrid.urs demo/more/grid1.ur src/reduce.sml |
| diffstat | 4 files changed, 219 insertions(+), 47 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/more/dbgrid.ur Sat Sep 12 10:36:17 2009 -0400 +++ b/demo/more/dbgrid.ur Sat Sep 12 15:08:16 2009 -0400 @@ -15,53 +15,93 @@ Handlers : global_t.1 -> colMeta' row global_t.2} structure Direct = struct + con metaBase = fn actual_input :: (Type * Type) => + {Display : actual_input.2 -> xbody, + Edit : actual_input.2 -> xbody, + Initialize : actual_input.1 -> transaction actual_input.2, + Parse : actual_input.2 -> signal (option actual_input.1)} + + datatype metaBoth actual input = + NonNull of metaBase (actual, input) * metaBase (option actual, input) + | Nullable of metaBase (actual, input) + con meta = fn global_actual_input :: (Type * Type * Type) => {Initialize : transaction global_actual_input.1, Handlers : global_actual_input.1 - -> {Display : global_actual_input.3 -> xbody, - Edit : global_actual_input.3 -> xbody, - Initialize : global_actual_input.2 -> transaction global_actual_input.3, - Parse : global_actual_input.3 -> signal (option global_actual_input.2)}} + -> metaBoth global_actual_input.2 global_actual_input.3} con editableState (ts :: (Type * Type * Type)) = (ts.1, ts.3) fun editable [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest) (editableState ts) = - {Initialize = m.Initialize, - Handlers = fn data => {Header = name, - Project = fn r => (m.Handlers data).Initialize r.nm, - Update = fn r s => - vo <- current ((m.Handlers data).Parse s); - return (case vo of - None => r - | Some v => r -- nm ++ {nm = v}), - Display = (m.Handlers data).Display, - Edit = (m.Handlers data).Edit, - Validate = fn s => vo <- (m.Handlers data).Parse s; return (Option.isSome vo)}} + let + fun doMr mr = {Header = name, + Project = fn r => mr.Initialize r.nm, + Update = fn r s => + vo <- current (mr.Parse s); + return (case vo of + None => r + | Some v => r -- nm ++ {nm = v}), + Display = mr.Display, + Edit = mr.Edit, + Validate = fn s => vo <- mr.Parse s; return (Option.isSome vo)} + in + {Initialize = m.Initialize, + Handlers = fn data => case m.Handlers data of + NonNull (mr, _) => doMr mr + | Nullable mr => doMr mr} + end con readOnlyState (ts :: (Type * Type * Type)) = (ts.1, ts.3) fun readOnly [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest) (readOnlyState ts) = - {Initialize = m.Initialize, - Handlers = fn data => {Header = name, - Project = fn r => (m.Handlers data).Initialize r.nm, - Update = fn r _ => return r, - Display = (m.Handlers data).Display, - Edit = (m.Handlers data).Display, - Validate = fn _ => return True}} + let + fun doMr mr = {Header = name, + Project = fn r => mr.Initialize r.nm, + Update = fn r _ => return r, + Display = mr.Display, + Edit = mr.Display, + Validate = fn _ => return True} + in + {Initialize = m.Initialize, + Handlers = fn data => case m.Handlers data of + NonNull (mr, _) => doMr mr + | Nullable mr => doMr mr} + end con metaBasic = fn actual_input :: (Type * Type) => - {Display : actual_input.2 -> xbody, - Edit : source actual_input.2 -> xbody, - Initialize : actual_input.1 -> actual_input.2, - Parse : actual_input.2 -> option actual_input.1} + {Display : actual_input.2 -> xbody, + Edit : source actual_input.2 -> xbody, + Initialize : actual_input.1 -> actual_input.2, + InitializeNull : actual_input.2, + IsNull : actual_input.2 -> bool, + Parse : actual_input.2 -> option actual_input.1} con basicState = source fun basic [ts ::: (Type * Type)] (m : metaBasic ts) : meta (unit, ts.1, basicState ts.2) = {Initialize = return (), - Handlers = fn () => {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>, + Handlers = fn () => NonNull ( + {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>, Edit = m.Edit, Initialize = fn v => source (m.Initialize v), - Parse = fn s => v <- signal s; return (m.Parse v)}} + Parse = fn s => v <- signal s; return (m.Parse v)}, + {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>, + Edit = m.Edit, + Initialize = fn v => source (case v of + None => m.InitializeNull + | Some v => m.Initialize v), + Parse = fn s => v <- signal s; + return (if m.IsNull v then + Some None + else + case m.Parse v of + None => None + | Some v' => Some (Some v'))})} + + fun nullable [global] [actual] [input] (m : meta (global, actual, input)) = + {Initialize = m.Initialize, + Handlers = fn d => case m.Handlers d of + Nullable _ => error <xml>Don't stack calls to Direct.nullable!</xml> + | NonNull (_, ho) => Nullable ho} type intGlobal = unit type intInput = basicState string @@ -69,6 +109,8 @@ basic {Display = fn s => <xml>{[s]}</xml>, Edit = fn s => <xml><ctextbox source={s}/></xml>, Initialize = fn n => show n, + InitializeNull = "", + IsNull = eq "", Parse = fn v => read v} type stringGlobal = unit @@ -77,6 +119,8 @@ basic {Display = fn s => <xml>{[s]}</xml>, Edit = fn s => <xml><ctextbox source={s}/></xml>, Initialize = fn s => s, + InitializeNull = "", + IsNull = eq "", Parse = fn s => Some s} type boolGlobal = unit @@ -85,6 +129,8 @@ basic {Display = fn b => <xml>{[b]}</xml>, Edit = fn s => <xml><ccheckbox source={s}/></xml>, Initialize = fn b => b, + InitializeNull = False, + IsNull = fn _ => False, Parse = fn b => Some b} functor Foreign (M : sig @@ -102,7 +148,7 @@ open M con global = list (t * string) - con input = source string * t * $row + con input = source string * option (t * $row) val getChoices = List.mapQuery (SELECT * FROM tab AS T) (fn r => (r.T.nm, render r.T)) @@ -111,21 +157,57 @@ r <- oneRow (SELECT T.{{row}} FROM tab AS T WHERE T.{nm} = {[k]}); return r.T - val meta = + val meta : meta (global, M.t, input) = {Initialize = getChoices, Handlers = fn choices => - {Display = fn (_, k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>, - Edit = fn (s, k, _) => + NonNull ( + {Display = fn (_, kr) => case kr of + None => error <xml>Unexpected Foreign null</xml> + | Some (k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>, + Edit = fn (s, kr) => <xml><cselect source={s}> {List.mapX (fn (k', rend) => - <xml><coption value={show k'} selected={k' = k}>{[rend]}</coption> + <xml><coption value={show k'} selected={case kr of + None => False + | Some (k, _) => + k' = k}>{[rend]}</coption> </xml>) choices} </cselect></xml>, Initialize = fn k => s <- source (show k); r <- rpc (getChoice k); - return (s, k, r), - Parse = fn (s, _, _) => k <- signal s; return (read k)}} + return (s, Some (k, r)), + Parse = fn (s, _) => k <- signal s; return (read k : option t)}, + {Display = fn (_, kr) => case kr of + None => <xml>NULL</xml> + | Some (k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>, + Edit = fn (s, kr) => + <xml><cselect source={s}> + <coption value="" selected={case kr of + None => True + | _ => False}>NULL</coption> + {List.mapX (fn (k', rend) => + <xml><coption value={show k'} selected={case kr of + None => False + | Some (k, _) => + k' = k}>{[rend]}</coption> + </xml>) + choices} + </cselect></xml>, + Initialize = fn k => case k of + None => + s <- source ""; + return (s, None) + | Some k => + s <- source (show k); + r <- rpc (getChoice k); + return (s, Some (k, r)), + Parse = fn (s, _) => ks <- signal s; + return (case ks of + "" => Some None + | _ => case read ks : option t of + None => None + | Some k => Some (Some k))})} end end
--- a/demo/more/dbgrid.urs Sat Sep 12 10:36:17 2009 -0400 +++ b/demo/more/dbgrid.urs Sat Sep 12 15:08:16 2009 -0400 @@ -15,13 +15,20 @@ Handlers : global_t.1 -> colMeta' row global_t.2} structure Direct : sig + con metaBase = fn actual_input :: (Type * Type) => + {Display : actual_input.2 -> xbody, + Edit : actual_input.2 -> xbody, + Initialize : actual_input.1 -> transaction actual_input.2, + Parse : actual_input.2 -> signal (option actual_input.1)} + + datatype metaBoth actual input = + NonNull of metaBase (actual, input) * metaBase (option actual, input) + | Nullable of metaBase (actual, input) + con meta = fn global_actual_input :: (Type * Type * Type) => {Initialize : transaction global_actual_input.1, Handlers : global_actual_input.1 - -> {Display : global_actual_input.3 -> xbody, - Edit : global_actual_input.3 -> xbody, - Initialize : global_actual_input.2 -> transaction global_actual_input.3, - Parse : global_actual_input.3 -> signal (option global_actual_input.2)}} + -> metaBoth global_actual_input.2 global_actual_input.3} con editableState :: (Type * Type * Type) -> (Type * Type) val editable : ts ::: (Type * Type * Type) -> rest ::: {Type} @@ -35,6 +42,10 @@ -> colMeta ([nm = ts.2] ++ rest) (readOnlyState ts) + val nullable : global ::: Type -> actual ::: Type -> input ::: Type + -> meta (global, actual, input) + -> meta (global, option actual, input) + type intGlobal type intInput val int : meta (intGlobal, int, intInput)
--- a/demo/more/grid1.ur Sat Sep 12 10:36:17 2009 -0400 +++ b/demo/more/grid1.ur Sat Sep 12 15:08:16 2009 -0400 @@ -4,11 +4,11 @@ PRIMARY KEY Id sequence s -table t : {Id : int, A : int, B : string, C : bool, D : int} +table t : {Id : int, A : int, B : string, C : bool, D : int, E : option int} PRIMARY KEY Id, CONSTRAINT Foreign FOREIGN KEY (D) REFERENCES t1(Id) ON DELETE CASCADE -fun page (n, s) = return <xml>A = {[n]}, B = {[s]}</xml> +(*fun page (n, s) = return <xml>A = {[n]}, B = {[s]}</xml>*) open Make(struct val tab = t @@ -23,6 +23,8 @@ C = {New = return False, Inj = _}, D = {New = return 0, + Inj = _}, + E = {New = return None, Inj = _}} structure F = Direct.Foreign(struct @@ -34,10 +36,11 @@ val cols = {Id = Direct.readOnly [#Id] ! "Id" Direct.int, A = Direct.editable [#A] ! "A" Direct.int, B = Direct.editable [#B] ! "B" Direct.string, - C = Direct.editable [#C] ! "C" Direct.bool, + C = Direct.editable [#C] ! "C" Direct.bool(*, D = Direct.editable [#D] ! "D" F.meta, + E = Direct.editable [#E] ! "E" (Direct.nullable Direct.int), DA = computed "2A" (fn r => 2 * r.A), - Link = computedHtml "Link" (fn r => <xml><a link={page (r.A, r.B)}>Go</a></xml>)} + Link = computedHtml "Link" (fn r => <xml><a link={page (r.A, r.B)}>Go</a></xml>)*)} end) fun main () =
--- a/src/reduce.sml Sat Sep 12 10:36:17 2009 -0400 +++ b/src/reduce.sml Sat Sep 12 15:08:16 2009 -0400 @@ -101,6 +101,69 @@ @ List.tabulate (ne, fn _ => UnknownE) | x => [x]) +datatype result = Yes of env | No | Maybe + +fun match (env, p : pat, e : exp) = + case (#1 p, #1 e) of + (PWild, _) => Yes env + | (PVar (x, t), _) => Yes (KnownE e :: env) + + | (PPrim p, EPrim p') => + if Prim.equal (p, p') then + Yes env + else + No + + | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) => + if n1 = n2 then + Yes env + else + No + + | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) => + if n1 = n2 then + match (env, p, e) + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE), + ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) => + if m1 = m2 andalso con1 = con2 then + Yes env + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep), + ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) => + if m1 = m2 andalso con1 = con2 then + match (env, p, e) + else + No + + | (PRecord xps, ERecord xes) => + if List.exists (fn ((CName _, _), _, _) => false + | _ => true) xes then + Maybe + else + let + fun consider (xps, env) = + case xps of + [] => Yes env + | (x, p, _) :: rest => + case List.find (fn ((CName x', _), _, _) => x' = x + | _ => false) xes of + NONE => No + | SOME (_, e, _) => + case match (env, p, e) of + No => No + | Maybe => Maybe + | Yes env => consider (rest, env) + in + consider (xps, env) + end + + | _ => Maybe + fun kindConAndExp (namedC, namedE) = let fun kind env (all as (k, loc)) = @@ -690,11 +753,24 @@ | PCon (dk, pc, cs, po) => (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc) + + fun push () = + (ECase (exp env e, + map (fn (p, e) => (pat p, + exp (List.tabulate (patBinds p, + fn _ => UnknownE) @ env) e)) + pes, {disc = con env disc, result = con env result}), loc) + + fun search pes = + case pes of + [] => push () + | (p, body) :: pes => + case match (env, p, e) of + No => search pes + | Maybe => push () + | Yes env' => exp env' body in - (ECase (exp env e, - map (fn (p, e) => (pat p, - exp (List.tabulate (patBinds p, fn _ => UnknownE) @ env) e)) - pes, {disc = con env disc, result = con env result}), loc) + search pes end | EWrite e => (EWrite (exp env e), loc)