From dac2c194b1416d7710081d5c57c24d52e110a224 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 26 Mar 2009 16:22:34 -0400 Subject: Preliminary work supporting channels in databases --- src/c/urweb.c | 43 +++++++++++++++++++++++++++++++++++++++++++ src/cjr_print.sml | 17 ++++++++++++----- src/monoize.sml | 26 ++++++++++++++++++++++++++ src/prepare.sml | 18 ++++++++---------- 4 files changed, 89 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/c/urweb.c b/src/c/urweb.c index 5fa2af42..75f7675f 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -999,6 +999,16 @@ char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) { return result; } +char *uw_Basis_attrifyChannel(uw_context ctx, uw_Basis_channel n) { + char *result; + int len; + uw_check_heap(ctx, INTS_MAX); + result = ctx->heap.front; + sprintf(result, "%lld%n", (long long)n, &len); + ctx->heap.front += len+1; + return result; +} + char *uw_Basis_attrifyFloat(uw_context ctx, uw_Basis_float n) { char *result; int len; @@ -1502,6 +1512,17 @@ char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) { return r; } +char *uw_Basis_sqlifyChannel(uw_context ctx, uw_Basis_channel n) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX + 6); + r = ctx->heap.front; + sprintf(r, "%lld::int4%n", (long long)n, &len); + ctx->heap.front += len+1; + return r; +} + char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) { if (n == NULL) return "NULL"; @@ -1673,6 +1694,18 @@ uw_Basis_int *uw_Basis_stringToInt(uw_context ctx, uw_Basis_string s) { return NULL; } +uw_Basis_channel *uw_Basis_stringToChannel(uw_context ctx, uw_Basis_string s) { + char *endptr; + uw_Basis_channel n = strtoll(s, &endptr, 10); + + if (*s != '\0' && *endptr == '\0') { + uw_Basis_channel *r = uw_malloc(ctx, sizeof(uw_Basis_channel)); + *r = n; + return r; + } else + return NULL; +} + uw_Basis_float *uw_Basis_stringToFloat(uw_context ctx, uw_Basis_string s) { char *endptr; uw_Basis_float n = strtod(s, &endptr); @@ -1740,6 +1773,16 @@ uw_Basis_int uw_Basis_stringToInt_error(uw_context ctx, uw_Basis_string s) { uw_error(ctx, FATAL, "Can't parse int: %s", s); } +uw_Basis_channel uw_Basis_stringToChannel_error(uw_context ctx, uw_Basis_string s) { + char *endptr; + uw_Basis_channel n = strtoll(s, &endptr, 10); + + if (*s != '\0' && *endptr == '\0') + return n; + else + uw_error(ctx, FATAL, "Can't parse channel int: %s", s); +} + uw_Basis_float uw_Basis_stringToFloat_error(uw_context ctx, uw_Basis_string s) { char *endptr; uw_Basis_float n = strtod(s, &endptr); diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 79a43d19..a17a0416 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -403,6 +403,7 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e = box [string "uw_Basis_strdup(ctx, ", e, string ")"] | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"] + | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"] | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; Print.eprefaces' [("Type", p_typ env tAll)]; @@ -445,6 +446,7 @@ datatype sql_type = | String | Bool | Time + | Channel | Nullable of sql_type fun p_sql_type' t = @@ -454,6 +456,7 @@ fun p_sql_type' t = | String => "uw_Basis_string" | Bool => "uw_Basis_bool" | Time => "uw_Basis_time" + | Channel => "uw_Basis_channel" | Nullable String => "uw_Basis_string" | Nullable t => p_sql_type' t ^ "*" @@ -469,12 +472,14 @@ fun getPargs (e, _) = | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] + | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)] - | EFfiApp ("Basis", "sqlifyIntN", [e]) => [(e, Nullable Int)] - | EFfiApp ("Basis", "sqlifyFloatN", [e]) => [(e, Nullable Float)] - | EFfiApp ("Basis", "sqlifyStringN", [e]) => [(e, Nullable String)] - | EFfiApp ("Basis", "sqlifyBoolN", [e]) => [(e, Nullable Bool)] - | EFfiApp ("Basis", "sqlifyTimeN", [e]) => [(e, Nullable Time)] + | ECase (e, + [((PNone _, _), + (EPrim (Prim.String "NULL"), _)), + ((PSome (_, (PVar _, _)), _), + (EFfiApp (m, x, [(ERel 0, _)]), _))], + _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e)) | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), @@ -492,6 +497,7 @@ fun p_ensql t e = | String => e | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"] + | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"] | Nullable String => e | Nullable t => box [string "(", e, @@ -2102,6 +2108,7 @@ fun p_sqltype'' env (tAll as (t, loc)) = | TFfi ("Basis", "string") => "text" | TFfi ("Basis", "bool") => "bool" | TFfi ("Basis", "time") => "timestamp" + | TFfi ("Basis", "channel") => "int4" | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; Print.eprefaces' [("Type", p_typ env tAll)]; "ERROR") diff --git a/src/monoize.sml b/src/monoize.sml index 1860fd19..eb3f81b3 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -165,6 +165,8 @@ fun monoType env = | L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) => (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) + | L.CApp ((L.CFfi ("Basis", "sql_injectable_nullable"), _), t) => + (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) => (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) => @@ -1425,6 +1427,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc), + fm) | L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) => let val t = monoType env t @@ -1453,6 +1459,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = result = s}), loc)), loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "sql_nullable"), _), t) => + let + val t = monoType env t + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", + (L'.TFun (t, s), loc), + (L'.TFun ((L'.TOption t, loc), s), loc), + (L'.EAbs ("x", + (L'.TOption t, loc), + s, + (L'.ECase ((L'.ERel 0, loc), + [((L'.PNone t, loc), + (L'.EPrim (Prim.String "NULL"), loc)), + ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc), + (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))], + {disc = (L'.TOption t, loc), + result = s}), loc)), loc)), loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) => ((L'.ERecord [], loc), fm) diff --git a/src/prepare.sml b/src/prepare.sml index 110f6f9a..1f3f323a 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -47,17 +47,15 @@ fun prepString (e, ss, n) = SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1) | EFfiApp ("Basis", "sqlifyTime", [e]) => SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1) + | EFfiApp ("Basis", "sqlifyChannel", [e]) => + SOME ("$" ^ Int.toString (n + 1) ^ "::int4" :: ss, n + 1) - | EFfiApp ("Basis", "sqlifyIntN", [e]) => - SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1) - | EFfiApp ("Basis", "sqlifyFloatN", [e]) => - SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1) - | EFfiApp ("Basis", "sqlifyStringN", [e]) => - SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1) - | EFfiApp ("Basis", "sqlifyBoolN", [e]) => - SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1) - | EFfiApp ("Basis", "sqlifyTimeN", [e]) => - SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1) + | ECase (e, + [((PNone _, _), + (EPrim (Prim.String "NULL"), _)), + ((PSome (_, (PVar _, _)), _), + (EFfiApp (m, x, [(ERel 0, _)]), _))], + _) => prepString ((EFfiApp (m, x, [e]), #2 e), ss, n) | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), -- cgit v1.2.3