summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-09-13 12:00:34 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-09-13 12:00:34 -0400
commit20402eff5a1c61c250d735b371e8ad031743d174 (patch)
tree79d8cd5ca5daae30ad0d2bdbc1ba789d485f3615
parent640e40ca6ce43e920e77187f653a86935e9d0acb (diff)
Have nullable columns working with Dbgrid
-rw-r--r--demo/more/grid1.ur11
-rw-r--r--demo/more/grid1.urp1
-rw-r--r--src/cjr_print.sml2
-rw-r--r--src/reduce.sml105
4 files changed, 40 insertions, 79 deletions
diff --git a/demo/more/grid1.ur b/demo/more/grid1.ur
index 4d0fe1bf..ea0dcbd5 100644
--- a/demo/more/grid1.ur
+++ b/demo/more/grid1.ur
@@ -4,7 +4,7 @@ table t1 : {Id : int, A : string}
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 @@ open Make(struct
D = {New = return 0,
Inj = _},
E = {New = return None,
+ Inj = _},
+ F = {New = return None,
Inj = _}}
structure F = Direct.Foreign(struct
@@ -34,11 +36,12 @@ open Make(struct
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 => <xml><a link={page (r.A, r.B)}>Go</a></xml>)*)}
end)
diff --git a/demo/more/grid1.urp b/demo/more/grid1.urp
index 5fc18139..a4f33375 100644
--- a/demo/more/grid1.urp
+++ b/demo/more/grid1.urp
@@ -1,3 +1,4 @@
+debug
database dbname=test
library grid
sql grid.sql
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index c6406cef..538e53f2 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -923,7 +923,7 @@ fun unurlify env (t, loc) =
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 --git a/src/reduce.sml b/src/reduce.sml
index dda0b840..54977432 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -520,6 +520,36 @@ fun kindConAndExp (namedC, namedE) =
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 @@ fun kindConAndExp (namedC, namedE) =
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