Have nullable columns working with Dbgrid

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