# HG changeset patch # User Adam Chlipala # Date 1252857634 14400 # Node ID be6585b4058b84839b14ac68e6212b615c0be099 # Parent 51bc7681c47edee9ebbff0f916f6a0857e252765 Have nullable columns working with Dbgrid diff -r 51bc7681c47e -r be6585b4058b demo/more/grid1.ur --- a/demo/more/grid1.ur Sat Sep 12 15:08:16 2009 -0400 +++ b/demo/more/grid1.ur Sun Sep 13 12:00:34 2009 -0400 @@ -4,7 +4,7 @@ PRIMARY KEY Id sequence s -table t : {Id : int, A : int, B : string, C : bool, D : int, E : option int} +table t : {Id : int, A : int, B : string, C : bool, D : int, E : option int, F : option int} PRIMARY KEY Id, CONSTRAINT Foreign FOREIGN KEY (D) REFERENCES t1(Id) ON DELETE CASCADE @@ -25,6 +25,8 @@ D = {New = return 0, Inj = _}, E = {New = return None, + Inj = _}, + F = {New = return None, Inj = _}} structure F = Direct.Foreign(struct @@ -34,11 +36,12 @@ end) val cols = {Id = Direct.readOnly [#Id] ! "Id" Direct.int, - A = Direct.editable [#A] ! "A" Direct.int, + (*A = Direct.editable [#A] ! "A" Direct.int, B = Direct.editable [#B] ! "B" Direct.string, - C = Direct.editable [#C] ! "C" Direct.bool(*, - D = Direct.editable [#D] ! "D" F.meta, + C = Direct.editable [#C] ! "C" Direct.bool, + D = Direct.editable [#D] ! "D" F.meta,*) E = Direct.editable [#E] ! "E" (Direct.nullable Direct.int), + F = Direct.editable [#F] ! "F" (Direct.nullable F.meta)(*, DA = computed "2A" (fn r => 2 * r.A), Link = computedHtml "Link" (fn r => Go)*)} end) diff -r 51bc7681c47e -r be6585b4058b demo/more/grid1.urp --- a/demo/more/grid1.urp Sat Sep 12 15:08:16 2009 -0400 +++ b/demo/more/grid1.urp Sun Sep 13 12:00:34 2009 -0400 @@ -1,3 +1,4 @@ +debug database dbname=test library grid sql grid.sql diff -r 51bc7681c47e -r be6585b4058b src/cjr_print.sml --- a/src/cjr_print.sml Sat Sep 12 15:08:16 2009 -0400 +++ b/src/cjr_print.sml Sun Sep 13 12:00:34 2009 -0400 @@ -923,7 +923,7 @@ box [string "(request[0] == '/' ? ++request : request, ", string "((!strncmp(request, \"None\", 4) ", string "&& (request[4] == 0 || request[4] == '/')) ", - string "? (request += 4, NULL) ", + string "? (request += (request[4] == 0 ? 4 : 5), NULL) ", string ": ((!strncmp(request, \"Some\", 4) ", string "&& request[4] == '/') ", string "? (request += 5, ", diff -r 51bc7681c47e -r be6585b4058b src/reduce.sml --- a/src/reduce.sml Sat Sep 12 15:08:16 2009 -0400 +++ b/src/reduce.sml Sun Sep 13 12:00:34 2009 -0400 @@ -520,6 +520,36 @@ e' end + | EApp + ((EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), + t1), + _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + (ECase (e, pes, {disc, ...}), _)), _), trans) => + let + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) + val e' = (ECApp (e', t1), loc) + val e' = (ECApp (e', t2), loc) + val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) + + fun doCase (p, e) = + let + val e' = (EApp (e', e), loc) + val e' = (EApp (e', + multiLiftExpInExp (E.patBindsN p) + trans), loc) + in + (p, reassoc e') + end + in + (ECase (e, map doCase pes, + {disc = disc, + result = (CApp ((CFfi ("Basis", "transaction"), loc), + t2), loc)}), loc) + end + | _ => e val e1 = exp env e1 @@ -528,80 +558,7 @@ in case #1 e12 of EApp ((EAbs (_, _, _, b), _), e2) => - ((*Print.preface ("Body", CorePrint.p_exp CoreEnv.empty b);*) - exp (KnownE e2 :: env') b) - (*| EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), - _), t2), _), - _), _), - (EApp ( - (EApp ( - (ECApp ( - (ECApp ((EFfi ("Basis", "return"), _), _), _), - _), _), - _), _), v), _)) => - (ELet ("rv", con env t1, v, - exp (deKnown env) (EApp (E.liftExpInExp 0 e2, (ERel 0, loc)), loc)), loc)*) - (*| EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), - _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - (EServerCall (n, es, ke, dom, ran), _)) => - let - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) - val e' = (ECApp (e', dom), loc) - val e' = (ECApp (e', t2), loc) - val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc) - val e' = (EApp (e', E.liftExpInExp 0 (exp env e2)), loc) - val e' = (EAbs ("x", dom, t2, e'), loc) - val e' = (EServerCall (n, es, e', dom, t2), loc) - val e' = exp (deKnown env) e' - in - (*Print.prefaces "SC" [("Old", CorePrint.p_exp CoreEnv.empty all), - ("New", CorePrint.p_exp CoreEnv.empty e')]*) - e' - end - | EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt), - _), _), _), t3), _), - me), _), - (EApp ((EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), - t1), _), t2), _), - _), _), - trans1), _), trans2), _)) => - let - val e'' = (EFfi ("Basis", "bind"), loc) - val e'' = (ECApp (e'', mt), loc) - val e'' = (ECApp (e'', t2), loc) - val e'' = (ECApp (e'', t3), loc) - val e'' = (EApp (e'', me), loc) - val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc) - val e'' = (EApp (e'', E.liftExpInExp 0 e2), loc) - val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc) - - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', mt), loc) - val e' = (ECApp (e', t1), loc) - val e' = (ECApp (e', t3), loc) - val e' = (EApp (e', me), loc) - val e' = (EApp (e', trans1), loc) - val e' = (EApp (e', e''), loc) - (*val () = Print.prefaces "Going in" [("e", CorePrint.p_exp CoreEnv.empty (e, loc)), - ("e1", CorePrint.p_exp CoreEnv.empty e1), - ("e'", CorePrint.p_exp CoreEnv.empty e')]*) - val ee' = exp (deKnown env) e' - val () = Print.prefaces "Coming out" [("ee'", CorePrint.p_exp CoreEnv.empty ee')] - in - (*Print.prefaces "Commute" [("Pre", CorePrint.p_exp CoreEnv.empty (e, loc)), - ("Mid", CorePrint.p_exp CoreEnv.empty e'), - ("env", Print.PD.string (e2s env)), - ("Post", CorePrint.p_exp CoreEnv.empty ee')];*) - ee' - end - | _ => (EApp (e1, exp env e2), loc)*) + exp (KnownE e2 :: env') b | _ => e12 end