Mercurial > urweb

changeset 297:59dc042629b9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
pquery working with all four types of columns
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 13:29:01 -0400
parents 5dc11235129d
children 43f35291433d
files include/urweb.h src/cjr.sml src/cjr_print.sml src/cjrize.sml src/compiler.sml src/elab_env.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/prepare.sml tests/pquery.ur
diffstat 13 files changed, 93 insertions(+), 26 deletions(-) [+]
line wrap: on
line diff
--- a/include/urweb.h	Sun Sep 07 12:58:33 2008 -0400
+++ b/include/urweb.h	Sun Sep 07 13:29:01 2008 -0400
@@ -66,10 +66,10 @@
 lw_Basis_string lw_Basis_strcat(lw_context, lw_Basis_string, lw_Basis_string);
 lw_Basis_string lw_Basis_strdup(lw_context, lw_Basis_string);
 
-lw_Basis_int lw_Basis_sqlifyInt(lw_context, lw_Basis_int);
-lw_Basis_float lw_Basis_sqlifyFloat(lw_context, lw_Basis_float);
+lw_Basis_string lw_Basis_sqlifyInt(lw_context, lw_Basis_int);
+lw_Basis_string lw_Basis_sqlifyFloat(lw_context, lw_Basis_float);
 lw_Basis_string lw_Basis_sqlifyString(lw_context, lw_Basis_string);
-lw_Basis_bool lw_Basis_sqlifyBool(lw_context, lw_Basis_bool);
+lw_Basis_string lw_Basis_sqlifyBool(lw_context, lw_Basis_bool);
 
 char *lw_Basis_ensqlBool(lw_Basis_bool);
 
--- a/src/cjr.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/cjr.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -60,6 +60,7 @@
        | ERel of int
        | ENamed of int
        | ECon of datatype_kind * patCon * exp option
+       | ENone of typ
        | ESome of typ * exp
        | EFfi of string * string
        | EFfiApp of string * string * exp list
--- a/src/cjr_print.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/cjr_print.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -518,6 +518,7 @@
                  newline,
                  string "})"]          
         end
+      | ENone _ => string "NULL"
       | ESome (t, e) =>
         (case #1 t of
              TDatatype _ => p_exp' par env e
--- a/src/cjrize.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/cjrize.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -211,6 +211,12 @@
         in
             ((L'.ECon (dk, pc, eo), loc), sm)
         end
+      | L.ENone t =>
+        let
+            val (t, sm) = cifyTyp (t, sm)
+        in
+            ((L'.ENone t, loc), sm)
+        end
       | L.ESome (t, e) =>
         let
             val (t, sm) = cifyTyp (t, sm)
--- a/src/compiler.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/compiler.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -467,8 +467,8 @@
 
 fun compileC {cname, oname, ename} =
     let
-        val compile = "gcc -s -O3 -I include -c " ^ cname ^ " -o " ^ oname
-        val link = "gcc -s -O3 -pthread -lpq clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename
+        val compile = "gcc -Wstrict-prototypes -Werror -s -O3 -I include -c " ^ cname ^ " -o " ^ oname
+        val link = "gcc -Werror -s -O3 -pthread -lpq clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename
     in
         if not (OS.Process.isSuccess (OS.Process.system compile)) then
             print "C compilation failed\n"
--- a/src/elab_env.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/elab_env.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -991,17 +991,23 @@
         DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c)
       | DDatatype (x, n, xs, xncs) =>
         let
-            val env = pushCNamedAs env x n (KType, loc) NONE
+            val k = (KType, loc) 
+            val nxs = length xs
+            val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) =>
+                                               ((CApp (tb, (CRel (nxs - i - 1), loc)), loc),
+                                                (KArrow (k, kb), loc)))
+                                           ((CNamed n, loc), k) xs
+                                              
+            val env = pushCNamedAs env x n kb NONE
             val env = pushDatatype env n xs xncs
         in
             foldl (fn ((x', n', to), env) =>
                       let
                           val t =
                               case to of
-                                  NONE => (CNamed n, loc)
-                                | SOME t => (TFun (t, (CNamed n, loc)), loc)
-                          val k = (KType, loc)
-                          val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs
+                                  NONE => tb
+                                | SOME t => (TFun (t, tb), loc)
+                          val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs
                       in
                           pushENamedAs env x' n' t
                       end)
@@ -1010,19 +1016,24 @@
       | DDatatypeImp (x, n, m, ms, x', xs, xncs) =>
         let
             val t = (CModProj (m, ms, x'), loc)
-            val env = pushCNamedAs env x n (KType, loc) (SOME t)
+            val k = (KType, loc) 
+            val nxs = length xs
+            val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) =>
+                                               ((CApp (tb, (CRel (nxs - i - 1), loc)), loc),
+                                                (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 = pushDatatype env n xs xncs
-
-            val t = (CNamed n, loc)
         in
             foldl (fn ((x', n', to), env) =>
                       let
                           val t =
                               case to of
-                                  NONE => (CNamed n, loc)
-                                | SOME t => (TFun (t, (CNamed n, loc)), loc)
-                          val k = (KType, loc)
-                          val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs
+                                  NONE => tb
+                                | SOME t => (TFun (t, tb), loc)
+                          val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs
                       in
                           pushENamedAs env x' n' t
                       end)
--- a/src/mono.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/mono.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -60,6 +60,7 @@
        | ERel of int
        | ENamed of int
        | ECon of datatype_kind * patCon * exp option
+       | ENone of typ
        | ESome of typ * exp
        | EFfi of string * string
        | EFfiApp of string * string * exp list
--- a/src/mono_print.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/mono_print.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -130,6 +130,7 @@
       | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc,
                                                   space,
                                                   p_exp' true env e])
+      | ENone _ => string "None"
       | ESome (_, e) => parenIf par (box [string "Some",
                                           space,
                                           p_exp' true env e])
--- a/src/mono_reduce.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/mono_reduce.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -45,6 +45,7 @@
       | ERel _ => false
       | ENamed _ => false
       | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
+      | ENone _ => false
       | ESome (_, e) => impure e
       | EFfi _ => false
       | EFfiApp _ => false
--- a/src/mono_util.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/mono_util.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -145,6 +145,10 @@
                 S.map2 (mfe ctx e,
                         fn e' =>
                            (ECon (dk, n, SOME e'), loc))
+              | ENone t =>
+                S.map2 (mft t,
+                        fn t' =>
+                           (ENone t', loc))
               | ESome (t, e) =>
                 S.bind2 (mft t,
                          fn t' =>
--- a/src/monoize.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/monoize.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -478,6 +478,14 @@
             in
                 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
             end
+          | L.ECon (L.Option, _, [t], NONE) =>
+            ((L'.ENone (monoType env t), loc), fm)
+          | L.ECon (L.Option, _, [t], SOME e) =>
+            let
+                val (e, fm) = monoExp (env, st, fm) e
+            in
+                ((L'.ESome (monoType env t, e), loc), fm)
+            end
           | L.ECon _ => poly ()
 
           | L.ECApp ((L.EFfi ("Basis", "show"), _), t) =>
--- a/src/prepare.sml	Sun Sep 07 12:58:33 2008 -0400
+++ b/src/prepare.sml	Sun Sep 07 13:29:01 2008 -0400
@@ -60,6 +60,7 @@
         in
             ((ECon (dk, pc, SOME e), loc), sns)
         end
+      | ENone t => (e, sns)
       | ESome (t, e) =>
         let
             val (e, sns) = prepExp (e, sns)
--- a/tests/pquery.ur	Sun Sep 07 12:58:33 2008 -0400
+++ b/tests/pquery.ur	Sun Sep 07 13:29:01 2008 -0400
@@ -1,19 +1,51 @@
 table t1 : {A : int, B : string, C : float, D : bool}
 
-fun lookup (inp : {B : string}) =
-        s <- query (SELECT * FROM t1 WHERE t1.B = {inp.B})
-                (fn fs _ => return fs.T1)
-                {A = 0, B = "Couldn't find it!", C = 0.0, D = False};
+fun display (q : sql_query [T1 = [A = int, B = string, C = float, D = bool]] []) =
+        s <- query q
+                (fn fs _ => return (Some fs.T1))
+                None;
         return <html><body>
-                A: {cdata (show _ s.A)}<br/>
-                B: {cdata (show _ s.B)}<br/>
-                C: {cdata (show _ s.C)}<br/>
-                D: {cdata (show _ s.D)}<br/>
+                {case s of
+                  None => cdata "Row not found."
+                | Some s =>
+                        <body>
+                                A: {cdata (show _ s.A)}<br/>
+                                B: {cdata (show _ s.B)}<br/>
+                                C: {cdata (show _ s.C)}<br/>
+                                D: {cdata (show _ s.D)}<br/>
+                        </body>}
         </body></html>
 
+fun lookupA (inp : {A : string}) =
+        display (SELECT * FROM t1 WHERE t1.A = {readError _ inp.A : int})
+
+fun lookupB (inp : {B : string}) =
+        display (SELECT * FROM t1 WHERE t1.B = {inp.B})
+
+fun lookupC (inp : {C : string}) =
+        display (SELECT * FROM t1 WHERE t1.C = {readError _ inp.C : float})
+
+fun lookupD (inp : {D : string}) =
+        display (SELECT * FROM t1 WHERE t1.D = {readError _ inp.D : bool})
+
 fun main () : transaction page = return <html><body>
         <lform>
+                A: <textbox{#A}/>
+                <submit action={lookupA}/>
+        </lform>
+
+        <lform>
                 B: <textbox{#B}/>
-                <submit action={lookup}/>
+                <submit action={lookupB}/>
+        </lform>
+
+        <lform>
+                C: <textbox{#C}/>
+                <submit action={lookupC}/>
+        </lform>
+
+        <lform>
+                D: <textbox{#D}/>
+                <submit action={lookupD}/>
         </lform>
 </body></html>