From 0fa422bfaf3931aacff958cb73d44ebfa4191f4a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Oct 2008 12:58:35 -0400 Subject: Fix nasty de Bruijn substitution bug; TcSum demo --- src/monoize.sml | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) (limited to 'src/monoize.sml') diff --git a/src/monoize.sml b/src/monoize.sml index cacf3d6d..6a12306b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -104,7 +104,8 @@ fun monoType env = let val t = mt env dtmap t in - (L'.TRecord [("Neg", (L'.TFun (t, t), loc)), + (L'.TRecord [("Zero", t), + ("Neg", (L'.TFun (t, t), loc)), ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), @@ -491,14 +492,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (dummyExp, fm)) fun numTy t = - (L'.TRecord [("Neg", (L'.TFun (t, t), loc)), + (L'.TRecord [("Zero", t), + ("Neg", (L'.TFun (t, t), loc)), ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc) - fun numEx (t, neg, plus, minus, times, dv, md) = - ((L'.ERecord [("Neg", neg, (L'.TFun (t, t), loc)), + fun numEx (t, zero, neg, plus, minus, times, dv, md) = + ((L'.ERecord [("Zero", (L'.EPrim zero, loc), t), + ("Neg", neg, (L'.TFun (t, t), loc)), ("Plus", plus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), ("Minus", minus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), ("Times", times, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), @@ -595,6 +598,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "zero"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", numTy t, t, + (L'.EField ((L'.ERel 0, loc), "Zero"), loc)), loc), fm) + end | L.ECApp ((L.EFfi ("Basis", "neg"), _), t) => let val t = monoType env t @@ -647,6 +657,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in numEx ((L'.TFfi ("Basis", "int"), loc), + Prim.Int (Int64.fromInt 0), (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc), (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc), @@ -666,6 +677,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in numEx ((L'.TFfi ("Basis", "float"), loc), + Prim.Float 0.0, (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc), (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc), -- cgit v1.2.3 From 9569ae99c75cb74aeeb6fa02e6eec9eff2c7669f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Oct 2008 18:45:10 -0400 Subject: Crud2 demo --- demo/crud2.sql | 6 ++++++ demo/crud2.ur | 34 ++++++++++++++++++++++++++++++++++ demo/crud2.urp | 5 +++++ demo/prose | 4 ++++ lib/basis.urs | 3 ++- lib/top.ur | 2 ++ lib/top.urs | 2 ++ src/monoize.sml | 9 +++++++++ 8 files changed, 64 insertions(+), 1 deletion(-) create mode 100644 demo/crud2.sql create mode 100644 demo/crud2.ur create mode 100644 demo/crud2.urp (limited to 'src/monoize.sml') diff --git a/demo/crud2.sql b/demo/crud2.sql new file mode 100644 index 00000000..88568f2a --- /dev/null +++ b/demo/crud2.sql @@ -0,0 +1,6 @@ +CREATE TABLE uw_Crud2_t(uw_id int8 NOT NULL, uw_nam text NOT NULL, + uw_ready bool NOT NULL); + + CREATE SEQUENCE uw_Crud2_Crud_Make_seq; + + \ No newline at end of file diff --git a/demo/crud2.ur b/demo/crud2.ur new file mode 100644 index 00000000..1db376d4 --- /dev/null +++ b/demo/crud2.ur @@ -0,0 +1,34 @@ +table t : {Id : int, Nam : string, Ready : bool} + +open Crud.Make(struct + val tab = t + + val title = "Are you ready?" + + val cols = {Nam = Crud.string "Name", + Ready = {Nam = "Ready", + Show = (fn b => if b then + Ready! + else + Not ready), + Widget = (fn (nm :: Name) => + + + + + ), + WidgetPopulated = (fn (nm :: Name) b => + + + + + ), + Parse = (fn s => + case s of + "Ready" => True + | "Not ready" => False + | _ => error Invalid ready/not ready), + Inject = _ + } + } + end) diff --git a/demo/crud2.urp b/demo/crud2.urp new file mode 100644 index 00000000..d552e1a7 --- /dev/null +++ b/demo/crud2.urp @@ -0,0 +1,5 @@ +database dbname=test +sql crud2.sql + +crud +crud2 diff --git a/demo/prose b/demo/prose index 6b7ddf29..3b9d9ebb 100644 --- a/demo/prose +++ b/demo/prose @@ -152,3 +152,7 @@ crud1.urp

Looking at crud1.ur, we see that a use of the functor is almost trivial. Only the value components of the argument structure must be provided. The column row type is inferred, and the disjointness constraint is proved automatically.

We won't go into detail on the implementation of Crud.Make. The types of the functions used there can be found in the signatures of the built-in Basis module and the Top module from the standard library. The signature of the first and the signature and implementation of the second can be found in the lib directory of the Ur/Web distribution.

+ +crud2.urp + +

This example shows another application of Crud.Make. We mix one standard column with one customized column. We write an underscore for the Inject field of meta-data, since the type class facility can infer that witness.

diff --git a/lib/basis.urs b/lib/basis.urs index a8c81353..fce29ff9 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -18,6 +18,7 @@ val eq_int : eq int val eq_float : eq float val eq_string : eq string val eq_bool : eq bool +val mkEq : t ::: Type -> (t -> t -> bool) -> eq t class num val zero : t ::: Type -> num t -> t @@ -365,7 +366,7 @@ val radioOption : unit -> tag [Value = string] radio [] [] [] con select = [Select] val select : formTag string select [] -val option : unit -> tag [Value = string] select [] [] [] +val option : unit -> tag [Value = string, Selected = bool] select [] [] [] val submit : ctx ::: {Unit} -> use ::: {Type} -> fn [[Form] ~ ctx] => diff --git a/lib/top.ur b/lib/top.ur index 91cab991..0bc345de 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -1,3 +1,5 @@ +fun not b = if b then False else True + con idT (t :: Type) = t con record (t :: {Type}) = $t con fstTT (t :: (Type * Type)) = t.1 diff --git a/lib/top.urs b/lib/top.urs index 29a1acf1..22cebb16 100644 --- a/lib/top.urs +++ b/lib/top.urs @@ -1,3 +1,5 @@ +val not : bool -> bool + con idT = fn t :: Type => t con record = fn t :: {Type} => $t con fstTT = fn t :: (Type * Type) => t.1 diff --git a/src/monoize.sml b/src/monoize.sml index 6a12306b..5fda4fa1 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -597,6 +597,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFfi ("Basis", "bool"), loc), (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc) + in + ((L'.EAbs ("f", dom, dom, + (L'.ERel 0, loc)), loc), fm) + end | L.ECApp ((L.EFfi ("Basis", "zero"), _), t) => let -- cgit v1.2.3 From d321a012ed51bf14ce6271198ccb29784efb7bd5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 14:36:48 -0400 Subject: time type --- include/types.h | 4 +++ include/urweb.h | 5 ++++ lib/basis.urs | 3 +++ src/c/urweb.c | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-- src/mono_opt.sml | 7 +++++ src/monoize.sml | 11 ++++++++ tests/time.ur | 3 +++ tests/time.urp | 3 +++ tests/time.urs | 1 + 9 files changed, 114 insertions(+), 2 deletions(-) create mode 100644 tests/time.ur create mode 100644 tests/time.urp create mode 100644 tests/time.urs (limited to 'src/monoize.sml') diff --git a/include/types.h b/include/types.h index 09d88681..4e76243b 100644 --- a/include/types.h +++ b/include/types.h @@ -1,6 +1,9 @@ +#include + typedef long long uw_Basis_int; typedef double uw_Basis_float; typedef char* uw_Basis_string; +typedef time_t uw_Basis_time; struct __uws_0 { }; @@ -21,3 +24,4 @@ typedef enum { SUCCESS, FATAL, BOUNDED_RETRY, UNLIMITED_RETRY } failure_kind; #define INTS_MAX 50 #define FLOATS_MAX 100 +#define TIMES_MAX 100 diff --git a/include/urweb.h b/include/urweb.h index 6ac7df15..752c00d2 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -39,11 +39,13 @@ char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int); char *uw_Basis_htmlifyFloat(uw_context, uw_Basis_float); char *uw_Basis_htmlifyString(uw_context, uw_Basis_string); char *uw_Basis_htmlifyBool(uw_context, uw_Basis_bool); +char *uw_Basis_htmlifyTime(uw_context, uw_Basis_time); uw_unit uw_Basis_htmlifyInt_w(uw_context, uw_Basis_int); uw_unit uw_Basis_htmlifyFloat_w(uw_context, uw_Basis_float); uw_unit uw_Basis_htmlifyString_w(uw_context, uw_Basis_string); uw_unit uw_Basis_htmlifyBool_w(uw_context, uw_Basis_bool); +uw_unit uw_Basis_htmlifyTime_w(uw_context, uw_Basis_time); char *uw_Basis_attrifyInt(uw_context, uw_Basis_int); char *uw_Basis_attrifyFloat(uw_context, uw_Basis_float); @@ -81,11 +83,14 @@ char *uw_Basis_ensqlBool(uw_Basis_bool); uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_floatToString(uw_context, uw_Basis_float); uw_Basis_string uw_Basis_boolToString(uw_context, uw_Basis_bool); +uw_Basis_string uw_Basis_timeToString(uw_context, uw_Basis_time); uw_Basis_int *uw_Basis_stringToInt(uw_context, uw_Basis_string); uw_Basis_float *uw_Basis_stringToFloat(uw_context, uw_Basis_string); uw_Basis_bool *uw_Basis_stringToBool(uw_context, uw_Basis_string); +uw_Basis_time *uw_Basis_stringToTime(uw_context, uw_Basis_string); uw_Basis_int uw_Basis_stringToInt_error(uw_context, uw_Basis_string); uw_Basis_float uw_Basis_stringToFloat_error(uw_context, uw_Basis_string); uw_Basis_bool uw_Basis_stringToBool_error(uw_context, uw_Basis_string); +uw_Basis_time uw_Basis_stringToTime_error(uw_context, uw_Basis_string); diff --git a/lib/basis.urs b/lib/basis.urs index fce29ff9..ba8f3d40 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -1,6 +1,7 @@ type int type float type string +type time type unit = {} @@ -52,6 +53,7 @@ val show_int : show int val show_float : show float val show_string : show string val show_bool : show bool +val show_time : show time class read val read : t ::: Type -> read t -> string -> option t @@ -61,6 +63,7 @@ val read_int : read int val read_float : read float val read_string : read string val read_bool : read bool +val read_time : read time (** SQL *) diff --git a/src/c/urweb.c b/src/c/urweb.c index 3fa4d19d..7a160637 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1,3 +1,5 @@ +#define _XOPEN_SOURCE + #include #include #include @@ -256,9 +258,9 @@ void uw_memstats(uw_context ctx) { printf("Heap: %d/%d\n", ctx->heap_front - ctx->heap, ctx->heap_back - ctx->heap); } -int uw_really_send(int sock, const void *buf, ssize_t len) { +int uw_really_send(int sock, const void *buf, size_t len) { while (len > 0) { - ssize_t n = send(sock, buf, len, 0); + size_t n = send(sock, buf, len, 0); if (n < 0) return n; @@ -725,6 +727,42 @@ uw_unit uw_Basis_htmlifyBool_w(uw_context ctx, uw_Basis_bool b) { return uw_unit_v; } +#define TIME_FMT "%x %X" + +uw_Basis_string uw_Basis_htmlifyTime(uw_context ctx, uw_Basis_time t) { + size_t len; + char *r; + struct tm stm; + + if (localtime_r(&t, &stm)) { + uw_check_heap(ctx, TIMES_MAX); + r = ctx->heap_front; + len = strftime(r, TIMES_MAX, TIME_FMT, &stm); + ctx->heap_front += len+1; + return r; + } else + return "Invalid time"; +} + +uw_unit uw_Basis_htmlifyTime_w(uw_context ctx, uw_Basis_time t) { + size_t len; + char *r; + struct tm stm; + + if (localtime_r(&t, &stm)) { + uw_check(ctx, TIMES_MAX); + r = ctx->page_front; + len = strftime(r, TIMES_MAX, TIME_FMT, &stm); + ctx->page_front += len; + } else { + uw_check(ctx, 20); + strcpy(ctx->page_front, "Invalid time"); + ctx->page_front += 19; + } + + return uw_unit_v; +} + uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_string s2) { int len = strlen(s1) + strlen(s2) + 1; char *s; @@ -860,6 +898,20 @@ uw_Basis_string uw_Basis_boolToString(uw_context ctx, uw_Basis_bool b) { return "True"; } +uw_Basis_string uw_Basis_timeToString(uw_context ctx, uw_Basis_time t) { + size_t len; + char *r; + struct tm stm; + + if (localtime_r(&t, &stm)) { + uw_check_heap(ctx, TIMES_MAX); + r = ctx->heap_front; + len = strftime(r, TIMES_MAX, TIME_FMT, &stm); + ctx->heap_front += len+1; + return r; + } else + return ""; +} uw_Basis_int *uw_Basis_stringToInt(uw_context ctx, uw_Basis_string s) { char *endptr; @@ -897,6 +949,19 @@ uw_Basis_bool *uw_Basis_stringToBool(uw_context ctx, uw_Basis_string s) { return NULL; } +uw_Basis_time *uw_Basis_stringToTime(uw_context ctx, uw_Basis_string s) { + char *end = strchr(s, 0); + struct tm stm; + + if (strptime(s, TIME_FMT, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + *r = mktime(&stm); + return r; + } + else + return NULL; +} + uw_Basis_int uw_Basis_stringToInt_error(uw_context ctx, uw_Basis_string s) { char *endptr; uw_Basis_int n = strtoll(s, &endptr, 10); @@ -925,3 +990,13 @@ uw_Basis_bool uw_Basis_stringToBool_error(uw_context ctx, uw_Basis_string s) { else uw_error(ctx, FATAL, "Can't parse bool: %s", s); } + +uw_Basis_time uw_Basis_stringToTime_error(uw_context ctx, uw_Basis_string s) { + char *end = strchr(s, 0); + struct tm stm = {}; + + if (strptime(s, TIME_FMT, &stm) == end) + return mktime(&stm); + else + uw_error(ctx, FATAL, "Can't parse time: %s", s); +} diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 843bdf90..8d11fe1a 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -197,6 +197,13 @@ fun exp e = | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) => EFfiApp ("Basis", "htmlifyBool_w", [e]) + | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) => + EFfiApp ("Basis", "htmlifyTime", [e]) + | EFfiApp ("Basis", "htmlifyString_w", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) => + EFfiApp ("Basis", "htmlifyTime_w", [e]) + | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) => + EFfiApp ("Basis", "htmlifyTime_w", [e]) + | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) => EPrim (Prim.String (htmlifyString s)) | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) => diff --git a/src/monoize.sml b/src/monoize.sml index 5fda4fa1..273efafe 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -820,6 +820,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.EFfi ("Basis", "show_bool") => ((L'.EFfi ("Basis", "boolToString"), loc), fm) + | L.EFfi ("Basis", "show_time") => + ((L'.EFfi ("Basis", "timeToString"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "read"), _), t) => let @@ -873,6 +875,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc), fm) end + | L.EFfi ("Basis", "read_time") => + let + val t = (L'.TFfi ("Basis", "time"), loc) + in + ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToTime"), loc), readType' (t, loc)), + ("ReadError", (L'.EFfi ("Basis", "stringToTime_error"), loc), readErrType (t, loc))], + loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "return"), _), t) => let diff --git a/tests/time.ur b/tests/time.ur new file mode 100644 index 00000000..393939e9 --- /dev/null +++ b/tests/time.ur @@ -0,0 +1,3 @@ +val now : time = readError "10/30/08 14:35:42" + +fun main () = return {[now]} diff --git a/tests/time.urp b/tests/time.urp new file mode 100644 index 00000000..f48698e9 --- /dev/null +++ b/tests/time.urp @@ -0,0 +1,3 @@ +debug + +time diff --git a/tests/time.urs b/tests/time.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/time.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From 49330740529a9d1448bff0fd3123e8946ab3915d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 14:40:42 -0400 Subject: Add time to some type classes --- lib/basis.urs | 4 ++++ src/monoize.sml | 20 ++++++++++++++++++++ tests/time.ur | 3 ++- 3 files changed, 26 insertions(+), 1 deletion(-) (limited to 'src/monoize.sml') diff --git a/lib/basis.urs b/lib/basis.urs index ba8f3d40..ffb13330 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -19,6 +19,7 @@ val eq_int : eq int val eq_float : eq float val eq_string : eq string val eq_bool : eq bool +val eq_time : eq time val mkEq : t ::: Type -> (t -> t -> bool) -> eq t class num @@ -41,6 +42,7 @@ val ord_int : ord int val ord_float : ord float val ord_string : ord string val ord_bool : ord bool +val ord_time : ord time (** String operations *) @@ -164,6 +166,7 @@ val sql_bool : sql_injectable bool val sql_int : sql_injectable int val sql_float : sql_injectable float val sql_string : sql_injectable string +val sql_time : sql_injectable time val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable t -> t -> sql_exp tables agg exps t @@ -216,6 +219,7 @@ class sql_maxable val sql_maxable_int : sql_maxable int val sql_maxable_float : sql_maxable float val sql_maxable_string : sql_maxable string +val sql_maxable_time : sql_maxable time val sql_max : t ::: Type -> sql_maxable t -> sql_aggregate t val sql_min : t ::: Type -> sql_maxable t -> sql_aggregate t diff --git a/src/monoize.sml b/src/monoize.sml index 273efafe..0557bb4c 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -597,6 +597,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFfi ("Basis", "bool"), loc), (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) + | L.EFfi ("Basis", "eq_time") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), + (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) => let val t = monoType env t @@ -799,6 +806,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = boolBin "<", boolBin "<=") end + | L.EFfi ("Basis", "ord_time") => + let + fun boolBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), + (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + in + ordEx ((L'.TFfi ("Basis", "time"), loc), + boolBin "<", + boolBin "<=") + end | L.ECApp ((L.EFfi ("Basis", "show"), _), t) => let diff --git a/tests/time.ur b/tests/time.ur index 393939e9..7b8b93ef 100644 --- a/tests/time.ur +++ b/tests/time.ur @@ -1,3 +1,4 @@ val now : time = readError "10/30/08 14:35:42" +val later : time = readError "10/30/08 14:37:42" -fun main () = return {[now]} +fun main () = return {[now]}, {[now = now]}, {[now = later]}, {[later < now]}, {[now < later]} -- cgit v1.2.3 From 5421d219d4b51b4b8ef18524d5b7db5c4939c36d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 15:11:37 -0400 Subject: Marshaling time to SQL --- include/urweb.h | 1 + src/c/urweb.c | 51 ++++++++++++++++++++++++++++++++++++++++++++------- src/cjr_print.sml | 13 +++++-------- src/monoize.sml | 4 ++++ src/prepare.sml | 2 ++ tests/time.ur | 1 + 6 files changed, 57 insertions(+), 15 deletions(-) (limited to 'src/monoize.sml') diff --git a/include/urweb.h b/include/urweb.h index 752c00d2..43a63324 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -77,6 +77,7 @@ uw_Basis_string uw_Basis_sqlifyInt(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_sqlifyFloat(uw_context, uw_Basis_float); uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool); +uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time); char *uw_Basis_ensqlBool(uw_Basis_bool); diff --git a/src/c/urweb.c b/src/c/urweb.c index df3ce6e1..f05b0b9d 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -860,6 +860,21 @@ char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { return "TRUE"; } +char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { + size_t len; + char *r; + struct tm stm; + + if (localtime_r(&t, &stm)) { + uw_check_heap(ctx, TIMES_MAX); + r = ctx->heap_front; + len = strftime(r, TIMES_MAX, TIME_FMT, &stm); + ctx->heap_front += len+1; + return r; + } else + return ""; +} + char *uw_Basis_ensqlBool(uw_Basis_bool b) { static uw_Basis_int true = 1; static uw_Basis_int false = 0; @@ -954,13 +969,33 @@ uw_Basis_time *uw_Basis_stringToTime(uw_context ctx, uw_Basis_string s) { char *dot = strchr(s, '.'), *end = strchr(s, 0); struct tm stm; - if ((dot ? (*dot = 0, strptime(s, TIME_FMT_PG, &stm)) : strptime(s, TIME_FMT, &stm)) == end) { - uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); - *r = mktime(&stm); - return r; + if (dot) { + *dot = 0; + if (strptime(s, TIME_FMT_PG, &stm) == end) { + *dot = '.'; + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + *r = mktime(&stm); + return r; + } + else { + *dot = '.'; + return NULL; + } + } + else { + if (strptime(s, TIME_FMT_PG, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + *r = mktime(&stm); + return r; + } + else if (strptime(s, TIME_FMT, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + *r = mktime(&stm); + return r; + } + else + return NULL; } - else - return NULL; } uw_Basis_int uw_Basis_stringToInt_error(uw_context ctx, uw_Basis_string s) { @@ -1008,7 +1043,9 @@ uw_Basis_time uw_Basis_stringToTime_error(uw_context ctx, uw_Basis_string s) { } } else { - if (strptime(s, TIME_FMT, &stm) == end) + if (strptime(s, TIME_FMT_PG, &stm) == end) + return mktime(&stm); + else if (strptime(s, TIME_FMT, &stm) == end) return mktime(&stm); else uw_error(ctx, FATAL, "Can't parse time: %s", s); diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 01d71872..f1f4ef70 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -413,13 +413,15 @@ datatype sql_type = | Float | String | Bool + | Time fun p_sql_type t = string (case t of Int => "uw_Basis_int" | Float => "uw_Basis_float" | String => "uw_Basis_string" - | Bool => "uw_Basis_bool") + | Bool => "uw_Basis_bool" + | Time => "uw_Basis_time") fun getPargs (e, _) = case e of @@ -430,6 +432,7 @@ fun getPargs (e, _) = | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)] | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] + | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] | ECase (e, _, _) => [(e, Bool)] | _ => raise Fail "CjrPrint: getPargs" @@ -440,13 +443,7 @@ fun p_ensql t e = | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"] | String => e | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] - -fun p_ensql_len t e = - case t of - Int => string "sizeof(uw_Basis_int)" - | Float => string "sizeof(uw_Basis_float)" - | String => box [string "strlen(", e, string ")"] - | Bool => string "sizeof(uw_Basis_bool)" + | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"] fun notLeaky env allowHeapAllocated = let diff --git a/src/monoize.sml b/src/monoize.sml index 0557bb4c..d28b27e4 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1220,6 +1220,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc), fm) + | L.EFfi ("Basis", "sql_time") => + ((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_subset"), _), _) => ((L'.ERecord [], loc), fm) diff --git a/src/prepare.sml b/src/prepare.sml index 6bf929f0..166f658b 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -45,6 +45,8 @@ fun prepString (e, ss, n) = SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1) | EFfiApp ("Basis", "sqlifyBool", [e]) => SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1) + | EFfiApp ("Basis", "sqlifyTime", [e]) => + SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1) | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), (EPrim (Prim.String "TRUE"), _)), diff --git a/tests/time.ur b/tests/time.ur index f6093dd3..f66004a5 100644 --- a/tests/time.ur +++ b/tests/time.ur @@ -4,6 +4,7 @@ val now : time = readError "10/30/08 14:35:42" val later : time = readError "10/30/08 14:37:42" fun main () = + dml (INSERT INTO t (Id, Time) VALUES (42, {now})); xml <- queryX (SELECT * FROM t) (fn r => {[r.T.Id]}: {[r.T.Time]}
); return -- cgit v1.2.3 From a2008ff2da76acfd69886499c6f8386041a1a4e0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 15:33:28 -0400 Subject: CURRENT_TIMESTAMP --- lib/basis.urs | 6 +++ src/monoize.sml | 139 +++++++++++++++++++++++++++++++++----------------------- src/urweb.grm | 10 ++++ src/urweb.lex | 2 + tests/time.ur | 4 +- 5 files changed, 102 insertions(+), 59 deletions(-) (limited to 'src/monoize.sml') diff --git a/lib/basis.urs b/lib/basis.urs index ffb13330..8992bc8c 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -223,6 +223,12 @@ val sql_maxable_time : sql_maxable time val sql_max : t ::: Type -> sql_maxable t -> sql_aggregate t val sql_min : t ::: Type -> sql_maxable t -> sql_aggregate t +con sql_nfunc :: Type -> Type +val sql_nfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> t ::: Type + -> sql_nfunc t -> sql_exp tables agg exps t +val sql_current_timestamp : sql_nfunc time + (*** Executing queries *) diff --git a/src/monoize.sml b/src/monoize.sml index d28b27e4..df775554 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -171,6 +171,8 @@ fun monoType env = (L'.TRecord [], loc) | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) => (L'.TRecord [], loc) + | L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CRel _ => poly () | L.CNamed n => @@ -1126,64 +1128,69 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of (SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) => - ((L'.EAbs ("r", - (L'.TRecord [("From", (L'.TRecord (map (fn (x, _) => (x, s)) tables), loc)), - ("Where", s), - ("GroupBy", un), - ("Having", s), - ("SelectFields", un), - ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))], - loc), - s, - strcat loc [sc "SELECT ", - strcatComma loc (map (fn (x, t) => - strcat loc [ - (L'.EField (gf "SelectExps", x), loc), - sc (" AS _" ^ x) + let + val sexps = ListMergeSort.sort + (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps + in + ((L'.EAbs ("r", + (L'.TRecord [("From", (L'.TRecord (map (fn (x, _) => (x, s)) tables), loc)), + ("Where", s), + ("GroupBy", un), + ("Having", s), + ("SelectFields", un), + ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))], + loc), + s, + strcat loc [sc "SELECT ", + strcatComma loc (map (fn (x, t) => + strcat loc [ + (L'.EField (gf "SelectExps", x), loc), + sc (" AS _" ^ x) ]) sexps - @ map (fn (x, xts) => - strcatComma loc - (map (fn (x', _) => - sc (x ^ ".uw_" ^ x')) - xts)) stables), - sc " FROM ", - strcatComma loc (map (fn (x, _) => strcat loc [(L'.EField (gf "From", x), loc), - sc (" AS " ^ x)]) tables), - (L'.ECase (gf "Where", - [((L'.PPrim (Prim.String "TRUE"), loc), - sc ""), - ((L'.PWild, loc), - strcat loc [sc " WHERE ", gf "Where"])], - {disc = s, - result = s}), loc), - - if List.all (fn (x, xts) => - case List.find (fn (x', _) => x' = x) grouped of - NONE => List.null xts - | SOME (_, xts') => - List.all (fn (x, _) => - List.exists (fn (x', _) => x' = x) - xts') xts) tables then - sc "" - else - strcat loc [ - sc " GROUP BY ", - strcatComma loc (map (fn (x, xts) => - strcatComma loc - (map (fn (x', _) => - sc (x ^ ".uw_" ^ x')) - xts)) grouped) - ], - - (L'.ECase (gf "Having", - [((L'.PPrim (Prim.String "TRUE"), loc), - sc ""), - ((L'.PWild, loc), - strcat loc [sc " HAVING ", gf "Having"])], - {disc = s, - result = s}), loc) - ]), loc), - fm) + @ map (fn (x, xts) => + strcatComma loc + (map (fn (x', _) => + sc (x ^ ".uw_" ^ x')) + xts)) stables), + sc " FROM ", + strcatComma loc (map (fn (x, _) => strcat loc [(L'.EField (gf "From", x), loc), + sc (" AS " ^ x)]) tables), + (L'.ECase (gf "Where", + [((L'.PPrim (Prim.String "TRUE"), loc), + sc ""), + ((L'.PWild, loc), + strcat loc [sc " WHERE ", gf "Where"])], + {disc = s, + result = s}), loc), + + if List.all (fn (x, xts) => + case List.find (fn (x', _) => x' = x) grouped of + NONE => List.null xts + | SOME (_, xts') => + List.all (fn (x, _) => + List.exists (fn (x', _) => x' = x) + xts') xts) tables then + sc "" + else + strcat loc [ + sc " GROUP BY ", + strcatComma loc (map (fn (x, xts) => + strcatComma loc + (map (fn (x', _) => + sc (x ^ ".uw_" ^ x')) + xts)) grouped) + ], + + (L'.ECase (gf "Having", + [((L'.PPrim (Prim.String "TRUE"), loc), + sc ""), + ((L'.PWild, loc), + strcat loc [sc " HAVING ", gf "Having"])], + {disc = s, + result = s}), loc) + ]), loc), + fm) + end | _ => poly () end @@ -1498,6 +1505,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm) | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_nfunc"), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + fun sc s = (L'.EPrim (Prim.String s), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), + fm) + end + | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm) + | L.EFfiApp ("Basis", "nextval", [e]) => let val un = (L'.TRecord [], loc) diff --git a/src/urweb.grm b/src/urweb.grm index 4f470fa0..3f56cb94 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -154,6 +154,13 @@ fun sql_relop (oper, sqlexp1, sqlexp2, loc) = (EApp (e, sqlexp2), loc) end +fun sql_nfunc (oper, loc) = + let + val e = (EVar (["Basis"], "sql_nfunc", Infer), loc) + in + (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) + end + fun native_unop (oper, e1, loc) = let val e = (EVar (["Basis"], oper, Infer), loc) @@ -206,6 +213,7 @@ fun tagIn bt = | COUNT | AVG | SUM | MIN | MAX | ASC | DESC | INSERT | INTO | VALUES | UPDATE | SET | DELETE + | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE %nonterm @@ -1169,6 +1177,8 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In s (FLOATleft, FLOATright))) | STRING (sql_inject (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))) + | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp", + s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright))) | tident DOT fident (let val loc = s (tidentleft, fidentright) diff --git a/src/urweb.lex b/src/urweb.lex index fd8a8077..fc8db17f 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -356,6 +356,8 @@ notags = [^<{\n]+; "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext)); "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext)); + "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); + {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); diff --git a/tests/time.ur b/tests/time.ur index f81c59c3..8676c48f 100644 --- a/tests/time.ur +++ b/tests/time.ur @@ -7,9 +7,9 @@ fun main () = dml (INSERT INTO t (Id, Time) VALUES (42, {now})); xml <- queryX (SELECT * FROM t) (fn r => {[r.T.Id]}: {[r.T.Time]}
); - minMax <- oneRow (SELECT MIN(t.Time) AS Min, MAX(t.Time) AS Max FROM t); + minMax <- oneRow (SELECT CURRENT_TIMESTAMP AS Cur, MIN(t.Time) AS Min, MAX(t.Time) AS Max FROM t); return {xml} {[now]}, {[now = now]}, {[now = later]}, {[later < now]}, {[now < later]}
- {[minMax.Min]}, {[minMax.Max]} + {[minMax.Cur]}, {[minMax.Min]}, {[minMax.Max]} -- cgit v1.2.3 From 389aae9254a3bdee3e79bb75b7355de270f2e8dd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 31 Oct 2008 09:30:22 -0400 Subject: Replace 'with' with '++' --- lib/top.ur | 50 +++++++++++++++++++++++++++++++++++++ lib/top.urs | 35 ++++++++++++++++++++++++++ src/core.sml | 2 +- src/core_print.sml | 23 +++++++---------- src/core_util.sml | 16 ++++++------ src/corify.sml | 4 +-- src/elab.sml | 2 +- src/elab_print.sml | 25 +++++++------------ src/elab_util.sml | 16 ++++++------ src/elaborate.sml | 70 ++++++++++++++++++++++++++-------------------------- src/expl.sml | 2 +- src/expl_print.sml | 23 +++++++---------- src/expl_util.sml | 16 ++++++------ src/explify.sml | 4 +-- src/monoize.sml | 2 +- src/reduce.sml | 8 +++--- src/source.sml | 2 +- src/source_print.sml | 12 ++++----- src/termination.sml | 2 +- src/urweb.grm | 5 ++-- src/urweb.lex | 1 - 21 files changed, 189 insertions(+), 131 deletions(-) (limited to 'src/monoize.sml') diff --git a/lib/top.ur b/lib/top.ur index d36af3f3..347b2a35 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -4,6 +4,9 @@ con idT (t :: Type) = t con record (t :: {Type}) = $t con fstTT (t :: (Type * Type)) = t.1 con sndTT (t :: (Type * Type)) = t.2 +con fstTTT (t :: (Type * Type * Type)) = t.1 +con sndTTT (t :: (Type * Type * Type)) = t.2 +con thdTTT (t :: (Type * Type * Type)) = t.3 con mapTT (f :: Type -> Type) = fold (fn nm t acc [[nm] ~ acc] => [nm = f t] ++ acc) [] @@ -14,6 +17,9 @@ con mapUT = fn f :: Type => fold (fn nm t acc [[nm] ~ acc] => con mapT2T (f :: (Type * Type) -> Type) = fold (fn nm t acc [[nm] ~ acc] => [nm = f t] ++ acc) [] +con mapT3T (f :: (Type * Type * Type) -> Type) = fold (fn nm t acc [[nm] ~ acc] => + [nm = f t] ++ acc) [] + con ex = fn tf :: (Type -> Type) => res ::: Type -> (choice :: Type -> tf choice -> res) -> res @@ -80,6 +86,17 @@ fun foldT2R (tf :: (Type * Type) -> Type) (tr :: {(Type * Type)} -> Type) f [nm] [t] [rest] r.nm (acc (r -- nm))) (fn _ => i) +fun foldT3R (tf :: (Type * Type * Type) -> Type) (tr :: {(Type * Type * Type)} -> Type) + (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} + -> fn [[nm] ~ rest] => + tf t -> tr rest -> tr ([nm = t] ++ rest)) + (i : tr []) = + fold [fn r :: {(Type * Type * Type)} => $(mapT3T tf r) -> tr r] + (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)}) + (acc : _ -> tr rest) [[nm] ~ rest] r => + f [nm] [t] [rest] r.nm (acc (r -- nm))) + (fn _ => i) + fun foldTR2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (tr :: {Type} -> Type) (f : nm :: Name -> t :: Type -> rest :: {Type} -> fn [[nm] ~ rest] => @@ -103,6 +120,18 @@ fun foldT2R2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type) f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) (fn _ _ => i) +fun foldT3R2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type) -> Type) + (tr :: {(Type * Type * Type)} -> Type) + (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} + -> fn [[nm] ~ rest] => + tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) + (i : tr []) = + fold [fn r :: {(Type * Type * Type)} => $(mapT3T tf1 r) -> $(mapT3T tf2 r) -> tr r] + (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)}) + (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 => + f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) + (fn _ _ => i) + fun foldTRX (tf :: Type -> Type) (ctx :: {Unit}) (f : nm :: Name -> t :: Type -> rest :: {Type} -> fn [[nm] ~ rest] => @@ -122,6 +151,16 @@ fun foldT2RX (tf :: (Type * Type) -> Type) (ctx :: {Unit}) {f [nm] [t] [rest] r}{acc}) +fun foldT3RX (tf :: (Type * Type * Type) -> Type) (ctx :: {Unit}) + (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} + -> fn [[nm] ~ rest] => + tf t -> xml ctx [] []) = + foldT3R [tf] [fn _ => xml ctx [] []] + (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)}) + [[nm] ~ rest] r acc => + {f [nm] [t] [rest] r}{acc}) + + fun foldTRX2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (ctx :: {Unit}) (f : nm :: Name -> t :: Type -> rest :: {Type} -> fn [[nm] ~ rest] => @@ -143,6 +182,17 @@ fun foldT2RX2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type) {f [nm] [t] [rest] r1 r2}{acc}) +fun foldT3RX2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type) -> Type) + (ctx :: {Unit}) + (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} + -> fn [[nm] ~ rest] => + tf1 t -> tf2 t -> xml ctx [] []) = + foldT3R2 [tf1] [tf2] [fn _ => xml ctx [] []] + (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)}) + [[nm] ~ rest] r1 r2 acc => + {f [nm] [t] [rest] r1 r2}{acc}) + + fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (q : sql_query tables exps) [tables ~ exps] (f : $(exps ++ fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] => diff --git a/lib/top.urs b/lib/top.urs index 6e9dda4e..d52ec9d7 100644 --- a/lib/top.urs +++ b/lib/top.urs @@ -4,6 +4,9 @@ con idT = fn t :: Type => t con record = fn t :: {Type} => $t con fstTT = fn t :: (Type * Type) => t.1 con sndTT = fn t :: (Type * Type) => t.2 +con fstTTT = fn t :: (Type * Type * Type) => t.1 +con sndTTT = fn t :: (Type * Type * Type) => t.2 +con thdTTT = fn t :: (Type * Type * Type) => t.3 con mapTT = fn f :: Type -> Type => fold (fn nm t acc [[nm] ~ acc] => [nm = f t] ++ acc) [] @@ -14,6 +17,9 @@ con mapUT = fn f :: Type => fold (fn nm t acc [[nm] ~ acc] => con mapT2T = fn f :: (Type * Type) -> Type => fold (fn nm t acc [[nm] ~ acc] => [nm = f t] ++ acc) [] +con mapT3T = fn f :: (Type * Type * Type) -> Type => fold (fn nm t acc [[nm] ~ acc] => + [nm = f t] ++ acc) [] + con ex = fn tf :: (Type -> Type) => res ::: Type -> (choice :: Type -> tf choice -> res) -> res @@ -55,6 +61,12 @@ val foldT2R : tf :: ((Type * Type) -> Type) -> tr :: ({(Type * Type)} -> Type) tf t -> tr rest -> tr ([nm = t] ++ rest)) -> tr [] -> r :: {(Type * Type)} -> $(mapT2T tf r) -> tr r +val foldT3R : tf :: ((Type * Type * Type) -> Type) -> tr :: ({(Type * Type * Type)} -> Type) + -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} + -> fn [[nm] ~ rest] => + tf t -> tr rest -> tr ([nm = t] ++ rest)) + -> tr [] -> r :: {(Type * Type * Type)} -> $(mapT3T tf r) -> tr r + val foldTR2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type) -> tr :: ({Type} -> Type) -> (nm :: Name -> t :: Type -> rest :: {Type} @@ -71,6 +83,14 @@ val foldT2R2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type) -> tr [] -> r :: {(Type * Type)} -> $(mapT2T tf1 r) -> $(mapT2T tf2 r) -> tr r +val foldT3R2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type) + -> tr :: ({(Type * Type * Type)} -> Type) + -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} + -> fn [[nm] ~ rest] => + tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest)) + -> tr [] -> r :: {(Type * Type * Type)} + -> $(mapT3T tf1 r) -> $(mapT3T tf2 r) -> tr r + val foldTRX : tf :: (Type -> Type) -> ctx :: {Unit} -> (nm :: Name -> t :: Type -> rest :: {Type} -> fn [[nm] ~ rest] => @@ -83,6 +103,12 @@ val foldT2RX : tf :: ((Type * Type) -> Type) -> ctx :: {Unit} tf t -> xml ctx [] []) -> r :: {(Type * Type)} -> $(mapT2T tf r) -> xml ctx [] [] +val foldT3RX : tf :: ((Type * Type * Type) -> Type) -> ctx :: {Unit} + -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} + -> fn [[nm] ~ rest] => + tf t -> xml ctx [] []) + -> r :: {(Type * Type * Type)} -> $(mapT3T tf r) -> xml ctx [] [] + val foldTRX2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type) -> ctx :: {Unit} -> (nm :: Name -> t :: Type -> rest :: {Type} -> fn [[nm] ~ rest] => @@ -98,6 +124,15 @@ val foldT2RX2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type) -> r :: {(Type * Type)} -> $(mapT2T tf1 r) -> $(mapT2T tf2 r) -> xml ctx [] [] + +val foldT3RX2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type) + -> ctx :: {Unit} + -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)} + -> fn [[nm] ~ rest] => + tf1 t -> tf2 t -> xml ctx [] []) + -> r :: {(Type * Type * Type)} + -> $(mapT3T tf1 r) -> $(mapT3T tf2 r) -> xml ctx [] [] + val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> sql_query tables exps -> fn [tables ~ exps] => diff --git a/src/core.sml b/src/core.sml index 11055aa4..baec6e41 100644 --- a/src/core.sml +++ b/src/core.sml @@ -93,7 +93,7 @@ datatype exp' = | ERecord of (con * exp * con) list | EField of exp * con * { field : con, rest : con } - | EWith of exp * con * exp * { field : con, rest : con } + | EConcat of exp * con * exp * con | ECut of exp * con * { field : con, rest : con } | EFold of kind diff --git a/src/core_print.sml b/src/core_print.sml index 0d470d39..1214a54f 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -283,31 +283,26 @@ fun p_exp' par env (e, _) = box [p_exp' true env e, string ".", p_con' true env c] - | EWith (e1, c, e2, {field, rest}) => + | EConcat (e1, c1, e2, c2) => parenIf par (if !debug then - box [p_exp env e1, + box [p_exp' true env e1, space, - string "with", + string ":", space, - p_con' true env c, + p_con env c1, + space, + string "++", space, - string "=", p_exp' true env e2, space, - string "[", - p_con env field, + string ":", space, - string " in ", - space, - p_con env rest, - string "]"] + p_con env c2] else - box [p_exp env e1, + box [p_exp' true env e1, space, string "with", space, - p_con' true env c, - space, p_exp' true env e2]) | ECut (e, c, {field, rest}) => parenIf par (if !debug then diff --git a/src/core_util.sml b/src/core_util.sml index df8465ae..f0697183 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -424,19 +424,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfc ctx rest, fn rest' => (EField (e', c', {field = field', rest = rest'}), loc))))) - | EWith (e1, c, e2, {field, rest}) => + | EConcat (e1, c1, e2, c2) => S.bind2 (mfe ctx e1, fn e1' => - S.bind2 (mfc ctx c, - fn c' => + S.bind2 (mfc ctx c1, + fn c1' => S.bind2 (mfe ctx e2, fn e2' => - S.bind2 (mfc ctx field, - fn field' => - S.map2 (mfc ctx rest, - fn rest' => - (EWith (e1', c', e2', {field = field', rest = rest'}), - loc)))))) + S.map2 (mfc ctx c2, + fn c2' => + (EConcat (e1', c1', e2', c2'), + loc))))) | ECut (e, c, {field, rest}) => S.bind2 (mfe ctx e, fn e' => diff --git a/src/corify.sml b/src/corify.sml index 89d1e63f..ff9506fd 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -566,8 +566,8 @@ fun corifyExp st (e, loc) = (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc) | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c, {field = corifyCon st field, rest = corifyCon st rest}), loc) - | L.EWith (e1, c, e2, {field, rest}) => (L'.EWith (corifyExp st e1, corifyCon st c, corifyExp st e2, - {field = corifyCon st field, rest = corifyCon st rest}), loc) + | L.EConcat (e1, c1, e2, c2) => (L'.EConcat (corifyExp st e1, corifyCon st c1, corifyExp st e2, + corifyCon st c2), loc) | L.ECut (e1, c, {field, rest}) => (L'.ECut (corifyExp st e1, corifyCon st c, {field = corifyCon st field, rest = corifyCon st rest}), loc) | L.EFold k => (L'.EFold (corifyKind k), loc) diff --git a/src/elab.sml b/src/elab.sml index 9bb609bf..4202d367 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -108,7 +108,7 @@ datatype exp' = | ERecord of (con * exp * con) list | EField of exp * con * { field : con, rest : con } - | EWith of exp * con * exp * { field : con, rest : con } + | EConcat of exp * con * exp * con | ECut of exp * con * { field : con, rest : con } | EFold of kind diff --git a/src/elab_print.sml b/src/elab_print.sml index c1bc5938..8c0b41f7 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -317,33 +317,26 @@ fun p_exp' par env (e, _) = box [p_exp' true env e, string ".", p_con' true env c] - | EWith (e1, c, e2, {field, rest}) => + | EConcat (e1, c1, e2, c2) => parenIf par (if !debug then - box [p_exp env e1, + box [p_exp' true env e1, space, - string "with", + string ":", space, - p_con' true env c, + p_con env c1, space, - string "=", - p_exp' true env e2, + string "++", space, - string "[", - p_con env field, + p_exp' true env e2, space, - string " in ", + string ":", space, - p_con env rest, - string "]"] + p_con env c2] else - box [p_exp env e1, + box [p_exp' true env e1, space, string "with", space, - p_con' true env c, - space, - string "=", - space, p_exp' true env e2]) | ECut (e, c, {field, rest}) => parenIf par (if !debug then diff --git a/src/elab_util.sml b/src/elab_util.sml index 69ed3248..247e2b3a 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -309,19 +309,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfc ctx rest, fn rest' => (EField (e', c', {field = field', rest = rest'}), loc))))) - | EWith (e1, c, e2, {field, rest}) => + | EConcat (e1, c1, e2, c2) => S.bind2 (mfe ctx e1, fn e1' => - S.bind2 (mfc ctx c, - fn c' => + S.bind2 (mfc ctx c1, + fn c1' => S.bind2 (mfe ctx e2, fn e2' => - S.bind2 (mfc ctx field, - fn field' => - S.map2 (mfc ctx rest, - fn rest' => - (EWith (e1', c', e2', {field = field', rest = rest'}), - loc)))))) + S.map2 (mfc ctx c2, + fn c2' => + (EConcat (e1', c1', e2', c2'), + loc))))) | ECut (e, c, {field, rest}) => S.bind2 (mfe ctx e, fn e' => diff --git a/src/elaborate.sml b/src/elaborate.sml index 6e23c760..4927e37d 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1,29 +1,29 @@ (* Copyright (c) 2008, Adam Chlipala - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - The names of contributors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - * POSSIBILITY OF SUCH DAMAGE. - *) + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) structure Elaborate :> ELABORATE = struct @@ -1603,21 +1603,21 @@ fun elabExp (env, denv) (eAll as (e, loc)) = ((L'.EField (e', c', {field = ft, rest = rest}), loc), ft, gs1 @ enD gs2 @ enD gs3 @ enD gs4) end - | L.EWith (e1, c, e2) => + | L.EConcat (e1, e2) => let val (e1', e1t, gs1) = elabExp (env, denv) e1 - val (c', ck, gs2) = elabCon (env, denv) c - val (e2', e2t, gs3) = elabExp (env, denv) e2 + val (e2', e2t, gs2) = elabExp (env, denv) e2 - val rest = cunif (loc, ktype_record) - val first = (L'.CRecord (ktype, [(c', e2t)]), loc) + val r1 = cunif (loc, ktype_record) + val r2 = cunif (loc, ktype_record) - val gs4 = checkCon (env, denv) e1' e1t (L'.TRecord rest, loc) - val gs5 = D.prove env denv (first, rest, loc) + val gs3 = checkCon (env, denv) e1' e1t (L'.TRecord r1, loc) + val gs4 = checkCon (env, denv) e2' e2t (L'.TRecord r2, loc) + val gs5 = D.prove env denv (r1, r2, loc) in - ((L'.EWith (e1', c', e2', {field = e2t, rest = rest}), loc), - (L'.TRecord ((L'.CConcat (first, rest), loc)), loc), - gs1 @ enD gs2 @ gs3 @ enD gs4 @ enD gs5) + ((L'.EConcat (e1', r1, e2', r2), loc), + (L'.TRecord ((L'.CConcat (r1, r2), loc)), loc), + gs1 @ gs2 @ enD gs3 @ enD gs4 @ enD gs5) end | L.ECut (e, c) => let diff --git a/src/expl.sml b/src/expl.sml index 9e35d674..2e96db54 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -90,7 +90,7 @@ datatype exp' = | ERecord of (con * exp * con) list | EField of exp * con * { field : con, rest : con } - | EWith of exp * con * exp * { field : con, rest : con } + | EConcat of exp * con * exp * con | ECut of exp * con * { field : con, rest : con } | EFold of kind diff --git a/src/expl_print.sml b/src/expl_print.sml index 39df4e3f..d19edeae 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -289,31 +289,26 @@ fun p_exp' par env (e, loc) = box [p_exp' true env e, string ".", p_con' true env c] - | EWith (e1, c, e2, {field, rest}) => + | EConcat (e1, c1, e2, c2) => parenIf par (if !debug then - box [p_exp env e1, + box [p_exp' true env e1, space, - string "with", + string ":", space, - p_con' true env c, + p_con env c1, + space, + string "++", space, - string "=", p_exp' true env e2, space, - string "[", - p_con env field, + string ":", space, - string " in ", - space, - p_con env rest, - string "]"] + p_con env c2] else - box [p_exp env e1, + box [p_exp' true env e1, space, string "with", space, - p_con' true env c, - space, p_exp' true env e2]) | ECut (e, c, {field, rest}) => parenIf par (if !debug then diff --git a/src/expl_util.sml b/src/expl_util.sml index 8dec2687..bda602d3 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -282,19 +282,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfc ctx rest, fn rest' => (EField (e', c', {field = field', rest = rest'}), loc))))) - | EWith (e1, c, e2, {field, rest}) => + | EConcat (e1, c1, e2, c2) => S.bind2 (mfe ctx e1, fn e1' => - S.bind2 (mfc ctx c, - fn c' => + S.bind2 (mfc ctx c1, + fn c1' => S.bind2 (mfe ctx e2, fn e2' => - S.bind2 (mfc ctx field, - fn field' => - S.map2 (mfc ctx rest, - fn rest' => - (EWith (e1', c', e2', {field = field', rest = rest'}), - loc)))))) + S.map2 (mfc ctx c2, + fn c2' => + (EConcat (e1', c1', e2', c2'), + loc))))) | ECut (e, c, {field, rest}) => S.bind2 (mfe ctx e, fn e' => diff --git a/src/explify.sml b/src/explify.sml index 72531d7a..1bca49c3 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -101,8 +101,8 @@ fun explifyExp (e, loc) = | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (explifyCon c, explifyExp e, explifyCon t)) xes), loc) | L.EField (e1, c, {field, rest}) => (L'.EField (explifyExp e1, explifyCon c, {field = explifyCon field, rest = explifyCon rest}), loc) - | L.EWith (e1, c, e2, {field, rest}) => (L'.EWith (explifyExp e1, explifyCon c, explifyExp e2, - {field = explifyCon field, rest = explifyCon rest}), loc) + | L.EConcat (e1, c1, e2, c2) => (L'.EConcat (explifyExp e1, explifyCon c1, explifyExp e2, explifyCon c2), + loc) | L.ECut (e1, c, {field, rest}) => (L'.ECut (explifyExp e1, explifyCon c, {field = explifyCon field, rest = explifyCon rest}), loc) | L.EFold k => (L'.EFold (explifyKind k), loc) diff --git a/src/monoize.sml b/src/monoize.sml index df775554..17e28034 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1920,7 +1920,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EField (e, monoName env x), loc), fm) end - | L.EWith _ => poly () + | L.EConcat _ => poly () | L.ECut _ => poly () | L.EFold _ => poly () diff --git a/src/reduce.sml b/src/reduce.sml index 8dc4527f..1404b598 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -107,18 +107,18 @@ fun exp env e = | _ => false) xes of SOME (_, e, _) => #1 e | NONE => e) - | EWith (r as (_, loc), x, e, {rest = (CRecord (k, xts), _), field}) => + | EConcat (r1 as (_, loc), (CRecord (k, xts1), _), r2, (CRecord (_, xts2), _)) => let - fun fields (remaining, passed) = + fun fields (r, remaining, passed) = case remaining of [] => [] | (x, t) :: rest => (x, (EField (r, x, {field = t, rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc), - t) :: fields (rest, (x, t) :: passed) + t) :: fields (r, rest, (x, t) :: passed) in - #1 (reduceExp env (ERecord ((x, e, field) :: fields (xts, [])), loc)) + #1 (reduceExp env (ERecord (fields (r1, xts1, []) @ fields (r2, xts2, [])), loc)) end | ECut (r as (_, loc), _, {rest = (CRecord (k, xts), _), ...}) => let diff --git a/src/source.sml b/src/source.sml index 23d2089f..386b1a83 100644 --- a/src/source.sml +++ b/src/source.sml @@ -123,7 +123,7 @@ datatype exp' = | ERecord of (con * exp) list | EField of exp * con - | EWith of exp * con * exp + | EConcat of exp * exp | ECut of exp * con | EFold diff --git a/src/source_print.sml b/src/source_print.sml index f9fc8a53..a25be2d4 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -258,13 +258,11 @@ fun p_exp' par (e, _) = | EField (e, c) => box [p_exp' true e, string ".", p_con' true c] - | EWith (e1, c, e2) => parenIf par (box [p_exp e1, - space, - string "with", - space, - p_con' true c, - space, - p_exp' true e2]) + | EConcat (e1, e2) => parenIf par (box [p_exp' true e1, + space, + string "++", + space, + p_exp' true e2]) | ECut (e, c) => parenIf par (box [p_exp' true e, space, string "--", diff --git a/src/termination.sml b/src/termination.sml index 1bae7592..b0716eca 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -265,7 +265,7 @@ fun declOk' env (d, loc) = in (Rabble, calls) end - | EWith (e1, _, e2, _) => + | EConcat (e1, _, e2, _) => let val (_, calls) = exp parent (penv, calls) e1 val (_, calls) = exp parent (penv, calls) e2 diff --git a/src/urweb.grm b/src/urweb.grm index 3f56cb94..143b6935 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -198,7 +198,7 @@ fun tagIn bt = | TYPE | NAME | ARROW | LARROW | DARROW | STAR | SEMI | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE - | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | WITH | SQL + | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | CASE | IF | THEN | ELSE @@ -344,7 +344,6 @@ fun tagIn bt = %right CAND %nonassoc EQ NE LT LE GT GE %right ARROW -%left WITH %right PLUSPLUS MINUSMINUS %left PLUS MINUS %left STAR DIVIDE MOD @@ -699,7 +698,7 @@ eexp : eapps (eapps) | eexp GT eexp (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right))) | eexp GE eexp (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right))) - | eexp WITH cterm EQ eexp (EWith (eexp1, cterm, eexp2), s (eexp1left, eexp2right)) + | eexp PLUSPLUS eexp (EConcat (eexp1, eexp2), s (eexp1left, eexp2right)) bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps) | UNIT LARROW eapps (let diff --git a/src/urweb.lex b/src/urweb.lex index fc8db17f..cc0f5b7c 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -311,7 +311,6 @@ notags = [^<{\n]+; "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); - "with" => (Tokens.WITH (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); -- cgit v1.2.3 From 2e59aaacd591f76ba5d509284b835c8c34a034f5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 16:46:16 -0400 Subject: Wrapping works in Blog --- src/core.sml | 2 ++ src/core_print.sml | 15 +++++++++++++++ src/core_util.sml | 9 +++++++++ src/corify.sml | 2 ++ src/monoize.sml | 9 +++++++++ src/unnest.sml | 20 +++++++++++--------- tests/nest.ur | 20 +++++++++++++++++++- 7 files changed, 67 insertions(+), 10 deletions(-) (limited to 'src/monoize.sml') diff --git a/src/core.sml b/src/core.sml index baec6e41..0b81e50e 100644 --- a/src/core.sml +++ b/src/core.sml @@ -103,6 +103,8 @@ datatype exp' = | EClosure of int * exp list + | ELet of string * con * exp * exp + withtype exp = exp' located datatype export_kind = diff --git a/src/core_print.sml b/src/core_print.sml index 1214a54f..cd31487e 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -362,6 +362,21 @@ fun p_exp' par env (e, _) = p_exp env e]) es, string ")"] + | ELet (x, t, e1, e2) => box [string "let", + space, + string x, + space, + string ":", + p_con env t, + space, + string "=", + space, + p_exp env e1, + space, + string "in", + newline, + p_exp (E.pushERel env x t) e2] + and p_exp env = p_exp' false env fun p_named x n = diff --git a/src/core_util.sml b/src/core_util.sml index f0697183..2a690736 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -487,6 +487,15 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn es' => (EClosure (n, es'), loc)) + | ELet (x, t, e1, e2) => + S.bind2 (mfc ctx t, + fn t' => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ELet (x, t', e1', e2'), loc)))) + and mfp ctx (pAll as (p, loc)) = case p of PWild => S.return2 pAll diff --git a/src/corify.sml b/src/corify.sml index ff9506fd..0ec98c69 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -580,6 +580,8 @@ fun corifyExp st (e, loc) = | L.EWrite e => (L'.EWrite (corifyExp st e), loc) + | L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc) + fun corifyDecl mods ((d, loc : EM.span), st) = case d of L.DCon (x, n, k, c) => diff --git a/src/monoize.sml b/src/monoize.sml index 17e28034..79940842 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1954,6 +1954,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EClosure (n, es), loc), fm) end + + | L.ELet (x, t, e1, e2) => + let + val t' = monoType env t + val (e1, fm) = monoExp (env, st, fm) e1 + val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2 + in + ((L'.ELet (x, t', e1, e2), loc), fm) + end end fun monoDecl (env, fm) (all as (d, loc)) = diff --git a/src/unnest.sml b/src/unnest.sml index e5eddc42..b305b467 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -206,29 +206,31 @@ fun exp ((ks, ts), e, st : state) = val subs' = ListUtil.mapi (fn (i, (_, n, _, _)) => let - val e = apply (ENamed n, loc) + val dummy = (EError, ErrorMsg.dummySpan) + + fun repeatLift k = + if k = 0 then + apply (ENamed n, loc) + else + E.liftExpInExp 0 (repeatLift (k - 1)) in - (0, E.liftExpInExp (nr - i - 1) e) + (0, repeatLift i) end) - vis + vis + val subs' = rev subs' val cfv = IS.listItems cfv val efv = IS.listItems efv val efn = length efv - (*val subsInner = subs - @ map (fn (i, e) => - (i + efn, - E.liftExpInExp efn e)) subs'*) - val subs = subs @ subs' val vis = map (fn (x, n, t, e) => let (*val () = Print.prefaces "preSubst" [("e", ElabPrint.p_exp E.empty e)]*) - val e = doSubst e subs(*Inner*) + val e = doSubst e subs (*val () = Print.prefaces "squishCon" [("t", ElabPrint.p_con E.empty t)]*) diff --git a/tests/nest.ur b/tests/nest.ur index c136b1e6..8da50712 100644 --- a/tests/nest.ur +++ b/tests/nest.ur @@ -25,7 +25,24 @@ fun f (x : int) = Some r => return {[r]} | _ => return Error in - page1 + page2 + end + +fun f (x : int) = + let + fun page1 () = return + {[x]} + + + and page2 () = + case Some True of + Some r => return {[r]} + | _ => return !! + + and page3 () = return !! + ! + in + page3 end datatype list t = Nil | Cons of t * list t @@ -39,3 +56,4 @@ fun length (t ::: Type) (ls : list t) = in length' ls 0 end + -- cgit v1.2.3 From 9a22207b565607db64f95dda5fdc1c9e56224ec9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 17:19:12 -0400 Subject: Fix some type-class detection --- lib/basis.urs | 1 + src/elab_env.sml | 1 + src/elaborate.sml | 1 + src/monoize.sml | 9 +++++++++ 4 files changed, 12 insertions(+) (limited to 'src/monoize.sml') diff --git a/lib/basis.urs b/lib/basis.urs index a344b3ce..ca81c95f 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -56,6 +56,7 @@ val show_float : show float val show_string : show string val show_bool : show bool val show_time : show time +val mkShow : t ::: Type -> (t -> string) -> show t class read val read : t ::: Type -> read t -> string -> option t diff --git a/src/elab_env.sml b/src/elab_env.sml index 2732de13..6b762abd 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -419,6 +419,7 @@ fun class_pair_in (c, _) = (case (class_name_in f, class_key_in x) of (SOME f, SOME x) => SOME (f, x) | _ => NONE) + | CUnif (_, _, _, ref (SOME c)) => class_pair_in c | _ => NONE fun resolveClass (env : env) c = diff --git a/src/elaborate.sml b/src/elaborate.sml index 38c03f6e..b0f2d331 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1398,6 +1398,7 @@ fun normClassConstraint envs (c, loc) = in ((L'.CApp (f, x), loc), gs) end + | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint envs c | _ => ((c, loc), []) diff --git a/src/monoize.sml b/src/monoize.sml index 79940842..0bdc1c70 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -844,6 +844,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EFfi ("Basis", "boolToString"), loc), fm) | L.EFfi ("Basis", "show_time") => ((L'.EFfi ("Basis", "timeToString"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "mkShow"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "string"), loc) + val dom = (L'.TFun (t, b), loc) + in + ((L'.EAbs ("f", dom, dom, + (L'.ERel 0, loc)), loc), fm) + end | L.ECApp ((L.EFfi ("Basis", "read"), _), t) => let -- cgit v1.2.3 From bfad3d26b4471c93b92d41c894e25919fd7bf953 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 11:29:16 -0500 Subject: Setting a cookie --- include/urweb.h | 3 +++ src/c/driver.c | 7 ++---- src/c/urweb.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++-- src/mono_reduce.sml | 12 +++++++--- src/monoize.sml | 39 ++++++++++++++++++++++++++++++ tests/cookie.ur | 3 +-- 6 files changed, 121 insertions(+), 12 deletions(-) (limited to 'src/monoize.sml') diff --git a/include/urweb.h b/include/urweb.h index 301129c5..4fb2d612 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -98,3 +98,6 @@ uw_Basis_bool uw_Basis_stringToBool_error(uw_context, uw_Basis_string); uw_Basis_time uw_Basis_stringToTime_error(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string); + +void uw_write_header(uw_context, uw_Basis_string); +uw_unit uw_Basis_set_cookie(uw_context, uw_Basis_string, uw_Basis_string); diff --git a/src/c/driver.c b/src/c/driver.c index ac968dc9..438adb8d 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -206,15 +206,12 @@ static void *worker(void *data) { } } - uw_write(ctx, "HTTP/1.1 200 OK\r\n"); - uw_write(ctx, "Content-type: text/html\r\n\r\n"); - uw_write(ctx, ""); + uw_write_header(ctx, "HTTP/1.1 200 OK\r\n"); + uw_write_header(ctx, "Content-type: text/html\r\n"); strcpy(path_copy, path); fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { - uw_write(ctx, ""); - if (uw_db_commit(ctx)) { fk = FATAL; diff --git a/src/c/urweb.c b/src/c/urweb.c index 5f718db6..dc58576a 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -26,6 +26,7 @@ typedef struct { struct uw_context { char *headers, *headers_end; + char *outHeaders, *outHeaders_front, *outHeaders_back; char *page, *page_front, *page_back; char *heap, *heap_front, *heap_back; char **inputs; @@ -43,11 +44,16 @@ struct uw_context { extern int uw_inputs_len; -uw_context uw_init(size_t page_len, size_t heap_len) { +uw_context uw_init(size_t outHeaders_len, size_t page_len, size_t heap_len) { uw_context ctx = malloc(sizeof(struct uw_context)); ctx->headers = ctx->headers_end = NULL; + ctx->outHeaders_front = ctx->outHeaders = malloc(outHeaders_len); + ctx->outHeaders_back = ctx->outHeaders_front + outHeaders_len; + + ctx->heap_front = ctx->heap = malloc(heap_len); + ctx->page_front = ctx->page = malloc(page_len); ctx->page_back = ctx->page_front + page_len; @@ -76,6 +82,7 @@ void *uw_get_db(uw_context ctx) { } void uw_free(uw_context ctx) { + free(ctx->outHeaders); free(ctx->page); free(ctx->heap); free(ctx->inputs); @@ -84,6 +91,7 @@ void uw_free(uw_context ctx) { } void uw_reset_keep_request(uw_context ctx) { + ctx->outHeaders_front = ctx->outHeaders; ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; ctx->regions = NULL; @@ -93,6 +101,7 @@ void uw_reset_keep_request(uw_context ctx) { } void uw_reset_keep_error_message(uw_context ctx) { + ctx->outHeaders_front = ctx->outHeaders; ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; ctx->regions = NULL; @@ -276,6 +285,7 @@ void uw_end_region(uw_context ctx) { } void uw_memstats(uw_context ctx) { + printf("Headers: %d/%d\n", ctx->outHeaders_front - ctx->outHeaders, ctx->outHeaders_back - ctx->outHeaders); printf("Page: %d/%d\n", ctx->page_front - ctx->page, ctx->page_back - ctx->page); printf("Heap: %d/%d\n", ctx->heap_front - ctx->heap, ctx->heap_back - ctx->heap); } @@ -295,7 +305,52 @@ int uw_really_send(int sock, const void *buf, size_t len) { } int uw_send(uw_context ctx, int sock) { - return uw_really_send(sock, ctx->page, ctx->page_front - ctx->page); + int n = uw_really_send(sock, ctx->outHeaders, ctx->outHeaders_front - ctx->outHeaders); + + if (n < 0) + return n; + + n = uw_really_send(sock, "\r\n", 2); + + if (n < 0) + return n; + + n = uw_really_send(sock, "", 6); + + if (n < 0) + return n; + + n = uw_really_send(sock, ctx->page, ctx->page_front - ctx->page); + + if (n < 0) + return n; + + return uw_really_send(sock, "", 7); +} + +static void uw_check_headers(uw_context ctx, size_t extra) { + size_t desired = ctx->outHeaders_front - ctx->outHeaders + extra, next; + char *new_outHeaders; + + next = ctx->outHeaders_back - ctx->outHeaders; + if (next < desired) { + if (next == 0) + next = 1; + for (; next < desired; next *= 2); + + new_outHeaders = realloc(ctx->outHeaders, next); + ctx->outHeaders_front = new_outHeaders + (ctx->outHeaders_front - ctx->outHeaders); + ctx->outHeaders_back = new_outHeaders + next; + ctx->outHeaders = new_outHeaders; + } +} + +void uw_write_header(uw_context ctx, uw_Basis_string s) { + int len = strlen(s); + + uw_check_headers(ctx, len + 1); + strcpy(ctx->outHeaders_front, s); + ctx->outHeaders_front += len; } static void uw_check(uw_context ctx, size_t extra) { @@ -1090,3 +1145,13 @@ uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { } } + +uw_unit uw_Basis_set_cookie(uw_context ctx, uw_Basis_string c, uw_Basis_string v) { + uw_write_header(ctx, "Set-Cookie: "); + uw_write_header(ctx, c); + uw_write_header(ctx, "="); + uw_write_header(ctx, v); + uw_write_header(ctx, "\r\n"); + + return uw_unit_v; +} diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 57a9cc6d..7420f14f 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -50,6 +50,7 @@ fun impure (e, _) = | ENone _ => false | ESome (_, e) => impure e | EFfi _ => false + | EFfiApp ("Basis", "set_cookie", _) => true | EFfiApp _ => false | EApp ((EFfi _, _), _) => false | EApp _ => true @@ -231,6 +232,7 @@ fun summarize d (e, _) = | ENone _ => [] | ESome (_, e) => summarize d e | EFfi _ => [] + | EFfiApp ("Basis", "set_cookie", _) => [Unsure] | EFfiApp (_, _, es) => List.concat (map (summarize d) es) | EApp ((EFfi _, _), e) => summarize d e | EApp _ => [Unsure] @@ -347,12 +349,16 @@ fun exp env e = #1 (reduceExp env (ELet (x, t, e, (EApp (b, liftExpInExp 0 e'), loc)), loc)) - | ELet (x, t, e, (EAbs (x', t' as (TRecord [], _), ran, e'), loc)) => - EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e, swapExpVars 0 e'), loc)) + | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => + if impure e' then + e + else + EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) | ELet (x, t, e', b) => let - fun doSub () = #1 (reduceExp env (subExpInExp (0, e') b)) + fun doSub () = + #1 (reduceExp env (subExpInExp (0, e') b)) fun trySub () = case t of diff --git a/src/monoize.sml b/src/monoize.sml index 0bdc1c70..64522a18 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -133,6 +133,8 @@ fun monoType env = | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) + | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "sql_sequence") => @@ -945,6 +947,33 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end + | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val un = (L'.TRecord [], loc) + val t = monoType env t + in + ((L'.EAbs ("c", s, (L'.TFun (un, s), loc), + (L'.EAbs ("_", un, s, + (L'.EPrim (Prim.String "Cookie!"), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "setCookie"), _), t) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val un = (L'.TRecord [], loc) + val t = monoType env t + val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t) + in + ((L'.EAbs ("c", s, (L'.TFun (t, (L'.TFun (un, un), loc)), loc), + (L'.EAbs ("v", t, (L'.TFun (un, un), loc), + (L'.EAbs ("_", un, un, + (L'.EFfiApp ("Basis", "set_cookie", [(L'.ERel 2, loc), e]), loc)), + loc)), loc)), loc), + fm) + end + | L.EFfiApp ("Basis", "dml", [e]) => let val (e, fm) = monoExp (env, st, fm) e @@ -2059,6 +2088,16 @@ fun monoDecl (env, fm) (all as (d, loc)) = (L'.DVal (x, n, t', e, s), loc)]) end | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)]) + | L.DCookie (x, n, t, s) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val e = (L'.EPrim (Prim.String s), loc) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DVal (x, n, t', e, s), loc)]) + end end fun monoize env ds = diff --git a/tests/cookie.ur b/tests/cookie.ur index b2bca580..36734260 100644 --- a/tests/cookie.ur +++ b/tests/cookie.ur @@ -2,8 +2,7 @@ cookie c : string fun main () : transaction page = setCookie c "Hi"; - so <- getCookie c; + so <- requestHeader "Cookie"; case so of None => return No cookie | Some s => return Cookie: {[s]} - -- cgit v1.2.3 From 9f6397d0f801f6e020aa6123f14ddc44e11deee7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 12:08:41 -0500 Subject: Reading cookies works --- include/urweb.h | 2 + src/c/urweb.c | 16 ++ src/cjr.sml | 1 + src/cjr_print.sml | 741 +++++++++++++++++++++++++++------------------------- src/cjrize.sml | 7 + src/mono.sml | 2 + src/mono_print.sml | 3 + src/mono_reduce.sml | 2 + src/mono_util.sml | 6 + src/monoize.sml | 4 +- src/prepare.sml | 7 + tests/cookie.ur | 2 +- 12 files changed, 440 insertions(+), 353 deletions(-) (limited to 'src/monoize.sml') diff --git a/include/urweb.h b/include/urweb.h index 4fb2d612..2330a0b4 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -100,4 +100,6 @@ uw_Basis_time uw_Basis_stringToTime_error(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string); void uw_write_header(uw_context, uw_Basis_string); + +uw_Basis_string uw_Basis_get_cookie(uw_context, uw_Basis_string); uw_unit uw_Basis_set_cookie(uw_context, uw_Basis_string, uw_Basis_string); diff --git a/src/c/urweb.c b/src/c/urweb.c index dc58576a..be12c5ea 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1143,7 +1143,23 @@ uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { return NULL; } } +} + +uw_Basis_string uw_Basis_get_cookie(uw_context ctx, uw_Basis_string c) { + int len = strlen(c); + char *s = ctx->headers, *p; + while (p = strchr(s, ':')) { + if (!strncasecmp(s, "Cookie: ", 8) && !strncmp(p + 2, c, len) + && p + 2 + len < ctx->headers_end && p[2 + len] == '=') { + return p + 3 + len; + } else { + if ((s = strchr(p, 0)) && s < ctx->headers_end) + s += 2; + else + return NULL; + } + } } uw_unit uw_Basis_set_cookie(uw_context ctx, uw_Basis_string c, uw_Basis_string v) { diff --git a/src/cjr.sml b/src/cjr.sml index dc700a56..84aea54e 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -92,6 +92,7 @@ datatype exp' = prepared : int option } | ENextval of { seq : exp, prepared : int option } + | EUnurlify of exp * typ withtype exp = exp' located diff --git a/src/cjr_print.sml b/src/cjr_print.sml index f1f4ef70..06154b91 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -62,6 +62,12 @@ val ident = String.translate (fn #"'" => "PRIME" val p_ident = string o ident +fun isUnboxable (t : typ) = + case #1 t of + TDatatype (Default, _, _) => true + | TFfi ("Basis", "string") => true + | _ => false + fun p_typ' par env (t, loc) = case t of TFun (t1, t2) => parenIf par (box [p_typ' true env t2, @@ -96,11 +102,11 @@ fun p_typ' par env (t, loc) = handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) | TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] | TOption t => - (case #1 t of - TDatatype _ => p_typ' par env t - | TFfi ("Basis", "string") => p_typ' par env t - | _ => box [p_typ' par env t, - string "*"]) + if isUnboxable t then + p_typ' par env t + else + box [p_typ' par env t, + string "*"] and p_typ env = p_typ' false env @@ -228,13 +234,12 @@ fun p_pat (env, exit, depth) (p, _) = string "->data.", string x] | Option => - case #1 t of - TDatatype _ => box [string "disc", - string (Int.toString depth)] - | TFfi ("Basis", "string") => box [string "disc", - string (Int.toString depth)] - | _ => box [string "*disc", - string (Int.toString depth)], + if isUnboxable t then + box [string "disc", + string (Int.toString depth)] + else + box [string "*disc", + string (Int.toString depth)], string ";", newline, p, @@ -335,13 +340,12 @@ fun p_pat (env, exit, depth) (p, _) = space, string "=", space, - case #1 t of - TDatatype _ => box [string "disc", - string (Int.toString depth)] - | TFfi ("Basis", "string") => box [string "disc", - string (Int.toString depth)] - | _ => box [string "*disc", - string (Int.toString depth)], + if isUnboxable t then + box [string "disc", + string (Int.toString depth)] + else + box [string "*disc", + string (Int.toString depth)], string ";", newline, p, @@ -468,6 +472,288 @@ fun notLeaky env allowHeapAllocated = nl end +fun capitalize s = + if s = "" then + "" + else + str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +fun unurlify env (t, loc) = + let + fun unurlify' rf t = + case t of + TFfi ("Basis", "unit") => string ("uw_unit_v") + | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") + + | TRecord 0 => string "uw_unit_v" + | TRecord i => + let + val xts = E.lookupStruct env i + in + box [string "({", + newline, + box (map (fn (x, t) => + box [p_typ env t, + space, + string "uwr_", + string x, + space, + string "=", + space, + unurlify' rf (#1 t), + string ";", + newline]) xts), + string "struct", + space, + string "__uws_", + string (Int.toString i), + space, + string "tmp", + space, + string "=", + space, + string "{", + space, + p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_", + string x]) xts, + space, + string "};", + newline, + string "tmp;", + newline, + string "})"] + end + + | TDatatype (Enum, i, _) => + let + val (x, xncs) = E.lookupDatatype env i + + fun doEm xncs = + case xncs of + [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " + ^ x ^ "\"), (enum __uwe_" + ^ x ^ "_" ^ Int.toString i ^ ")0)") + | (x', n, to) :: rest => + box [string "((!strncmp(request, \"", + string x', + string "\", ", + string (Int.toString (size x')), + string ") && (request[", + string (Int.toString (size x')), + string "] == 0 || request[", + string (Int.toString (size x')), + string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), + space, + string ":", + space, + doEm rest, + string ")"] + in + doEm xncs + end + + | TDatatype (Option, i, xncs) => + if IS.member (rf, i) then + box [string "unurlify_", + string (Int.toString i), + string "()"] + else + let + val (x, _) = E.lookupDatatype env i + + val (no_arg, has_arg, t) = + case !xncs of + [(no_arg, _, NONE), (has_arg, _, SOME t)] => + (no_arg, has_arg, t) + | [(has_arg, _, SOME t), (no_arg, _, NONE)] => + (no_arg, has_arg, t) + | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" + + val rf = IS.add (rf, i) + in + box [string "({", + space, + p_typ env t, + space, + string "*unurlify_", + string (Int.toString i), + string "(void) {", + newline, + box [string "return (request[0] == '/' ? ++request : request,", + newline, + string "((!strncmp(request, \"", + string no_arg, + string "\", ", + string (Int.toString (size no_arg)), + string ") && (request[", + string (Int.toString (size no_arg)), + string "] == 0 || request[", + string (Int.toString (size no_arg)), + string "] == '/')) ? (request", + space, + string "+=", + space, + string (Int.toString (size no_arg)), + string ", NULL) : ((!strncmp(request, \"", + string has_arg, + string "\", ", + string (Int.toString (size has_arg)), + string ") && (request[", + string (Int.toString (size has_arg)), + string "] == 0 || request[", + string (Int.toString (size has_arg)), + string "] == '/')) ? (request", + space, + string "+=", + space, + string (Int.toString (size has_arg)), + string ", (request[0] == '/' ? ++request : NULL), ", + newline, + + if isUnboxable t then + unurlify' rf (#1 t) + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + space, + unurlify' rf (#1 t), + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")", + newline, + string ":", + space, + string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x + ^ "\"), NULL))));"), + newline], + string "}", + newline, + newline, + + string "unurlify_", + string (Int.toString i), + string "();", + newline, + string "})"] + end + + | TDatatype (Default, i, _) => + if IS.member (rf, i) then + box [string "unurlify_", + string (Int.toString i), + string "()"] + else + let + val (x, xncs) = E.lookupDatatype env i + + val rf = IS.add (rf, i) + + fun doEm xncs = + case xncs of + [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " + ^ x ^ "\"), NULL)") + | (x', n, to) :: rest => + box [string "((!strncmp(request, \"", + string x', + string "\", ", + string (Int.toString (size x')), + string ") && (request[", + string (Int.toString (size x')), + string "] == 0 || request[", + string (Int.toString (size x')), + string "] == '/')) ? ({", + newline, + string "struct", + space, + string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), + space, + string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", + string x, + string "_", + string (Int.toString i), + string "));", + newline, + string "tmp->tag", + space, + string "=", + space, + string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), + string ";", + newline, + string "request", + space, + string "+=", + space, + string (Int.toString (size x')), + string ";", + newline, + string "if (request[0] == '/') ++request;", + newline, + case to of + NONE => box [] + | SOME (t, _) => box [string "tmp->data.uw_", + p_ident x', + space, + string "=", + space, + unurlify' rf t, + string ";", + newline], + string "tmp;", + newline, + string "})", + space, + string ":", + space, + doEm rest, + string ")"] + in + box [string "({", + space, + p_typ env (t, ErrorMsg.dummySpan), + space, + string "unurlify_", + string (Int.toString i), + string "(void) {", + newline, + box [string "return", + space, + doEm xncs, + string ";", + newline], + string "}", + newline, + newline, + + string "unurlify_", + string (Int.toString i), + string "();", + newline, + string "})"] + end + + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; + space) + in + unurlify' IS.empty t + end + fun p_exp' par env (e, loc) = case e of EPrim p => Prim.p_t_GCC p @@ -485,30 +771,30 @@ fun p_exp' par env (e, loc) = NONE => raise Fail "CjrPrint: ECon argument status mismatch" | SOME t => t in - case #1 t of - TDatatype _ => p_exp' par env e - | TFfi ("Basis", "string") => p_exp' par env e - | _ => box [string "({", - newline, - p_typ env t, - space, - string "*tmp", - space, - string "=", - space, - string "uw_malloc(ctx, sizeof(", - p_typ env t, - string "));", - newline, - string "*tmp", - space, - string "=", - p_exp' par env e, - string ";", - newline, - string "tmp;", - newline, - string "})"] + if isUnboxable t then + p_exp' par env e + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + p_exp' par env e, + string ";", + newline, + string "tmp;", + newline, + string "})"] end | ECon (Default, pc, eo) => let @@ -551,30 +837,30 @@ fun p_exp' par env (e, loc) = end | ENone _ => string "NULL" | ESome (t, e) => - (case #1 t of - TDatatype _ => p_exp' par env e - | TFfi ("Basis", "string") => p_exp' par env e - | _ => box [string "({", - newline, - p_typ env t, - space, - string "*tmp", - space, - string "=", - space, - string "uw_malloc(ctx, sizeof(", - p_typ env t, - string "));", - newline, - string "*tmp", - space, - string "=", - p_exp' par env e, - string ";", - newline, - string "tmp;", - newline, - string "})"]) + if isUnboxable t then + p_exp' par env e + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + p_exp' par env e, + string ";", + newline, + string "tmp;", + newline, + string "})"] | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] | EError (e, t) => @@ -1078,6 +1364,41 @@ fun p_exp' par env (e, loc) = string "}))"] end + | EUnurlify (e, t) => + let + fun getIt () = + if isUnboxable t then + unurlify env t + else + box [string "({", + newline, + p_typ env t, + string " *tmp = uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp = ", + unurlify env t, + string ";", + newline, + string "tmp;", + newline, + string "})"] + in + box [string "({", + newline, + string "uw_Basis_string request = ", + p_exp env e, + string ";", + newline, + newline, + string "(request ? ", + getIt (), + string " : NULL);", + newline, + string "})"] + end + and p_exp env = p_exp' false env fun p_fun env (fx, n, args, ran, e) = @@ -1527,288 +1848,6 @@ fun p_file env (ds, ps) = string "}"] end - fun capitalize s = - if s = "" then - "" - else - str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) - - fun unurlify (t, loc) = - let - fun unurlify' rf t = - case t of - TFfi ("Basis", "unit") => string ("uw_unit_v") - | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") - - | TRecord 0 => string "uw_unit_v" - | TRecord i => - let - val xts = E.lookupStruct env i - in - box [string "({", - newline, - box (map (fn (x, t) => - box [p_typ env t, - space, - string "uwr_", - string x, - space, - string "=", - space, - unurlify' rf (#1 t), - string ";", - newline]) xts), - string "struct", - space, - string "__uws_", - string (Int.toString i), - space, - string "tmp", - space, - string "=", - space, - string "{", - space, - p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_", - string x]) xts, - space, - string "};", - newline, - string "tmp;", - newline, - string "})"] - end - - | TDatatype (Enum, i, _) => - let - val (x, xncs) = E.lookupDatatype env i - - fun doEm xncs = - case xncs of - [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " - ^ x ^ "\"), (enum __uwe_" - ^ x ^ "_" ^ Int.toString i ^ ")0)") - | (x', n, to) :: rest => - box [string "((!strncmp(request, \"", - string x', - string "\", ", - string (Int.toString (size x')), - string ") && (request[", - string (Int.toString (size x')), - string "] == 0 || request[", - string (Int.toString (size x')), - string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), - space, - string ":", - space, - doEm rest, - string ")"] - in - doEm xncs - end - - | TDatatype (Option, i, xncs) => - if IS.member (rf, i) then - box [string "unurlify_", - string (Int.toString i), - string "()"] - else - let - val (x, _) = E.lookupDatatype env i - - val (no_arg, has_arg, t) = - case !xncs of - [(no_arg, _, NONE), (has_arg, _, SOME t)] => - (no_arg, has_arg, t) - | [(has_arg, _, SOME t), (no_arg, _, NONE)] => - (no_arg, has_arg, t) - | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" - - val rf = IS.add (rf, i) - in - box [string "({", - space, - p_typ env t, - space, - string "*unurlify_", - string (Int.toString i), - string "(void) {", - newline, - box [string "return (request[0] == '/' ? ++request : request,", - newline, - string "((!strncmp(request, \"", - string no_arg, - string "\", ", - string (Int.toString (size no_arg)), - string ") && (request[", - string (Int.toString (size no_arg)), - string "] == 0 || request[", - string (Int.toString (size no_arg)), - string "] == '/')) ? (request", - space, - string "+=", - space, - string (Int.toString (size no_arg)), - string ", NULL) : ((!strncmp(request, \"", - string has_arg, - string "\", ", - string (Int.toString (size has_arg)), - string ") && (request[", - string (Int.toString (size has_arg)), - string "] == 0 || request[", - string (Int.toString (size has_arg)), - string "] == '/')) ? (request", - space, - string "+=", - space, - string (Int.toString (size has_arg)), - string ", (request[0] == '/' ? ++request : NULL), ", - newline, - - case #1 t of - TDatatype _ => unurlify' rf (#1 t) - | TFfi ("Basis", "string") => unurlify' rf (#1 t) - | _ => box [string "({", - newline, - p_typ env t, - space, - string "*tmp", - space, - string "=", - space, - string "uw_malloc(ctx, sizeof(", - p_typ env t, - string "));", - newline, - string "*tmp", - space, - string "=", - space, - unurlify' rf (#1 t), - string ";", - newline, - string "tmp;", - newline, - string "})"], - string ")", - newline, - string ":", - space, - string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x - ^ "\"), NULL))));"), - newline], - string "}", - newline, - newline, - - string "unurlify_", - string (Int.toString i), - string "();", - newline, - string "})"] - end - - | TDatatype (Default, i, _) => - if IS.member (rf, i) then - box [string "unurlify_", - string (Int.toString i), - string "()"] - else - let - val (x, xncs) = E.lookupDatatype env i - - val rf = IS.add (rf, i) - - fun doEm xncs = - case xncs of - [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " - ^ x ^ "\"), NULL)") - | (x', n, to) :: rest => - box [string "((!strncmp(request, \"", - string x', - string "\", ", - string (Int.toString (size x')), - string ") && (request[", - string (Int.toString (size x')), - string "] == 0 || request[", - string (Int.toString (size x')), - string "] == '/')) ? ({", - newline, - string "struct", - space, - string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), - space, - string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", - string x, - string "_", - string (Int.toString i), - string "));", - newline, - string "tmp->tag", - space, - string "=", - space, - string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), - string ";", - newline, - string "request", - space, - string "+=", - space, - string (Int.toString (size x')), - string ";", - newline, - string "if (request[0] == '/') ++request;", - newline, - case to of - NONE => box [] - | SOME (t, _) => box [string "tmp->data.uw_", - p_ident x', - space, - string "=", - space, - unurlify' rf t, - string ";", - newline], - string "tmp;", - newline, - string "})", - space, - string ":", - space, - doEm rest, - string ")"] - in - box [string "({", - space, - p_typ env (t, ErrorMsg.dummySpan), - space, - string "unurlify_", - string (Int.toString i), - string "(void) {", - newline, - box [string "return", - space, - doEm xncs, - string ";", - newline], - string "}", - newline, - newline, - - string "unurlify_", - string (Int.toString i), - string "();", - newline, - string "})"] - end - - | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; - space) - in - unurlify' IS.empty t - end - fun p_page (ek, s, n, ts) = let val (ts, defInputs, inputsVar) = @@ -1855,7 +1894,7 @@ fun p_file env (ds, ps) = space, string "=", space, - unurlify t, + unurlify env t, string ";", newline] end) xts), @@ -1904,7 +1943,7 @@ fun p_file env (ds, ps) = space, string "=", space, - unurlify t, + unurlify env t, string ";", newline]) ts), defInputs, diff --git a/src/cjrize.sml b/src/cjrize.sml index db2bd48f..6c34923b 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -412,6 +412,13 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.ENextval {seq = e, prepared = NONE}, loc), sm) end + | L.EUnurlify (e, t) => + let + val (e, sm) = cifyExp (e, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.EUnurlify (e, t), loc), sm) + end fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/mono.sml b/src/mono.sml index b7ac6346..f465d2bd 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -94,6 +94,8 @@ datatype exp' = | EDml of exp | ENextval of exp + | EUnurlify of exp * typ + withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index 5d9f8007..8d91d048 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -272,6 +272,9 @@ fun p_exp' par env (e, _) = | ENextval e => box [string "nextval(", p_exp env e, string ")"] + | EUnurlify (e, _) => box [string "unurlify(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 7420f14f..3c4ac0df 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -41,6 +41,7 @@ fun impure (e, _) = | EQuery _ => true | EDml _ => true | ENextval _ => true + | EUnurlify _ => true | EAbs _ => false | EPrim _ => false @@ -275,6 +276,7 @@ fun summarize d (e, _) = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] + | EUnurlify (e, _) => summarize d e fun exp env e = let diff --git a/src/mono_util.sml b/src/mono_util.sml index 080c3dc9..14ab1674 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -305,6 +305,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ENextval e', loc)) + | EUnurlify (e, t) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => + (EUnurlify (e', t'), loc))) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index 64522a18..b8c3a6a9 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -955,7 +955,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("c", s, (L'.TFun (un, s), loc), (L'.EAbs ("_", un, s, - (L'.EPrim (Prim.String "Cookie!"), loc)), loc)), loc), + (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc), + t), + loc)), loc)), loc), fm) end diff --git a/src/prepare.sml b/src/prepare.sml index 166f658b..6d63ad7d 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -191,6 +191,13 @@ fun prepExp (e as (_, loc), sns) = ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)) end + | EUnurlify (e, t) => + let + val (e, sns) = prepExp (e, sns) + in + ((EUnurlify (e, t), loc), sns) + end + fun prepDecl (d as (_, loc), sns) = case #1 d of DStruct _ => (d, sns) diff --git a/tests/cookie.ur b/tests/cookie.ur index 36734260..cb4f8854 100644 --- a/tests/cookie.ur +++ b/tests/cookie.ur @@ -2,7 +2,7 @@ cookie c : string fun main () : transaction page = setCookie c "Hi"; - so <- requestHeader "Cookie"; + so <- getCookie c; case so of None => return No cookie | Some s => return Cookie: {[s]} -- cgit v1.2.3 From 24777c2dc9b6ea0f3db24ae372be2af0c3f70602 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 12:46:45 -0500 Subject: Cookie prose; fix bugs that broke demo compilation --- demo/cookie.ur | 29 ++++++++++++----------------- demo/prose | 6 ++++++ src/mono_reduce.sml | 5 +++-- src/monoize.sml | 6 +----- 4 files changed, 22 insertions(+), 24 deletions(-) (limited to 'src/monoize.sml') diff --git a/demo/cookie.ur b/demo/cookie.ur index 02f4cab5..ad4e19ec 100644 --- a/demo/cookie.ur +++ b/demo/cookie.ur @@ -6,21 +6,16 @@ fun set r = fun main () = ro <- getCookie c; - let - val xml = case ro of - None => No cookie set. - | Some v => Cookie: A = {[v.A]}, B = {[v.B]}, C = {[v.C]} - in - return - {xml}

- -
- A:
- B:
- C:
- - -
- end - + return + {case ro of + None => No cookie set. + | Some v => Cookie: A = {[v.A]}, B = {[v.B]}, C = {[v.C]}} +

+
+ A:
+ B:
+ C:
+ + +
diff --git a/demo/prose b/demo/prose index 06c47722..fad98e26 100644 --- a/demo/prose +++ b/demo/prose @@ -58,6 +58,12 @@ nested.urp

Here is an implementation of the tiny challenge problem from this web framework comparison. Using nested function definitions, it is easy to persist state across clicks.

+cookie.urp + +

Often, it is useful to associate persistent data with particular web clients. Ur/Web includes an easy facility for using type-safe cookies. This example shows how to use a form to set a named cookie.

+ +

After setting the cookie, try browsing back to this demo from the main index. The data you entered should still be there.

+ listShop.urp

This example shows off algebraic datatypes, parametric polymorphism, and functors.

diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 3c4ac0df..bf68f175 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -352,9 +352,10 @@ fun exp env e = (EApp (b, liftExpInExp 0 e'), loc)), loc)) | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => - if impure e' then + (*if impure e' then e - else + else*) + (* Seems unsound in general without the check... should revisit later *) EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) | ELet (x, t, e', b) => diff --git a/src/monoize.sml b/src/monoize.sml index b8c3a6a9..20677816 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1565,13 +1565,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfiApp ("Basis", "nextval", [e]) => let - val un = (L'.TRecord [], loc) - val int = (L'.TFfi ("Basis", "int"), loc) val (e, fm) = monoExp (env, st, fm) e in - ((L'.EAbs ("_", un, int, - (L'.ENextval (liftExpInExp 0 e), loc)), loc), - fm) + ((L'.ENextval e, loc), fm) end | L.EApp ( -- cgit v1.2.3 From d6dbcd83918e1cc3b6f6bba2f2b8e82bb15a6e7b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 14:03:50 -0500 Subject: Cookies work across pages --- include/urweb.h | 6 +++--- src/c/driver.c | 2 +- src/c/urweb.c | 4 +++- src/monoize.sml | 5 ++++- tests/cookie.ur | 18 ++++++++++++++++-- 5 files changed, 27 insertions(+), 8 deletions(-) (limited to 'src/monoize.sml') diff --git a/include/urweb.h b/include/urweb.h index 2330a0b4..7db66ed4 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -6,7 +6,7 @@ int uw_really_send(int sock, void *buf, ssize_t len); extern uw_unit uw_unit_v; -uw_context uw_init(size_t page_len, size_t heap_len); +uw_context uw_init(size_t outHeaders_len, size_t page_len, size_t heap_len); void uw_set_db(uw_context, void*); void *uw_get_db(uw_context); void uw_free(uw_context); @@ -101,5 +101,5 @@ uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string); void uw_write_header(uw_context, uw_Basis_string); -uw_Basis_string uw_Basis_get_cookie(uw_context, uw_Basis_string); -uw_unit uw_Basis_set_cookie(uw_context, uw_Basis_string, uw_Basis_string); +uw_Basis_string uw_Basis_get_cookie(uw_context, uw_Basis_string c); +uw_unit uw_Basis_set_cookie(uw_context, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v); diff --git a/src/c/driver.c b/src/c/driver.c index d884c025..1eef9742 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -71,7 +71,7 @@ static int try_rollback(uw_context ctx) { static void *worker(void *data) { int me = *(int *)data, retries_left = MAX_RETRIES; - uw_context ctx = uw_init(1024, 0); + uw_context ctx = uw_init(0, 1024, 0); while (1) { failure_kind fk = uw_begin_init(ctx); diff --git a/src/c/urweb.c b/src/c/urweb.c index cc21c558..638fbb16 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1152,11 +1152,13 @@ uw_Basis_string uw_Basis_get_cookie(uw_context ctx, uw_Basis_string c) { } } -uw_unit uw_Basis_set_cookie(uw_context ctx, uw_Basis_string c, uw_Basis_string v) { +uw_unit uw_Basis_set_cookie(uw_context ctx, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v) { uw_write_header(ctx, "Set-Cookie: "); uw_write_header(ctx, c); uw_write_header(ctx, "="); uw_write_header(ctx, v); + uw_write_header(ctx, "; path="); + uw_write_header(ctx, prefix); uw_write_header(ctx, "\r\n"); return uw_unit_v; diff --git a/src/monoize.sml b/src/monoize.sml index 20677816..c4c296bd 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -971,7 +971,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("c", s, (L'.TFun (t, (L'.TFun (un, un), loc)), loc), (L'.EAbs ("v", t, (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, - (L'.EFfiApp ("Basis", "set_cookie", [(L'.ERel 2, loc), e]), loc)), + (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String (!urlPrefix)), + loc), + (L'.ERel 2, loc), + e]), loc)), loc)), loc)), loc), fm) end diff --git a/tests/cookie.ur b/tests/cookie.ur index cb4f8854..bef45a4f 100644 --- a/tests/cookie.ur +++ b/tests/cookie.ur @@ -1,8 +1,22 @@ cookie c : string -fun main () : transaction page = - setCookie c "Hi"; +fun other () = so <- getCookie c; case so of None => return No cookie | Some s => return Cookie: {[s]} + +structure M = struct + fun aux () = + setCookie c "Hi"; + so <- getCookie c; + case so of + None => return No cookie + | Some s => return Cookie: {[s]}
+ Other +end + +fun main () : transaction page = return + Other
+ Aux
+ -- cgit v1.2.3 From 0a10b5b7d2bbdcbfec723176b2a31d6b4c6d34d1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 15:37:38 -0500 Subject: Inserted a NULL value --- CHANGELOG | 9 +++++ include/urweb.h | 6 +++ lib/basis.urs | 5 +++ src/c/urweb.c | 35 ++++++++++++++++++ src/cjr_print.sml | 101 +++++++++++++++++++++++++++++++++++++++++---------- src/elab_env.sml | 31 ++++++++++++++-- src/elaborate.sml | 47 ++++++++++++++++-------- src/mono_opt.sml | 5 +++ src/monoize.sml | 24 ++++++++++-- src/urweb.grm | 5 ++- src/urweb.lex | 1 + tests/sql_option.ur | 22 +++++++++++ tests/sql_option.urp | 5 +++ 13 files changed, 252 insertions(+), 44 deletions(-) create mode 100644 tests/sql_option.ur create mode 100644 tests/sql_option.urp (limited to 'src/monoize.sml') diff --git a/CHANGELOG b/CHANGELOG index aca01ea7..0f8d0f09 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +======== +NEXT +======== + +- Nested function definitions +- Primitive "time" type +- Nullable SQL columns (via "option") +- Cookies + ======== 20081028 ======== diff --git a/include/urweb.h b/include/urweb.h index 7db66ed4..7e16fd40 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -80,6 +80,12 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool); uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time); +uw_Basis_string uw_Basis_sqlifyIntN(uw_context, uw_Basis_int*); +uw_Basis_string uw_Basis_sqlifyFloatN(uw_context, uw_Basis_float*); +uw_Basis_string uw_Basis_sqlifyStringN(uw_context, uw_Basis_string); +uw_Basis_string uw_Basis_sqlifyBoolN(uw_context, uw_Basis_bool*); +uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*); + char *uw_Basis_ensqlBool(uw_Basis_bool); uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); diff --git a/lib/basis.urs b/lib/basis.urs index 84fb4e4c..f68bedee 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -188,6 +188,11 @@ val sql_int : sql_injectable int val sql_float : sql_injectable float val sql_string : sql_injectable string val sql_time : sql_injectable time +val sql_option_bool : sql_injectable (option bool) +val sql_option_int : sql_injectable (option int) +val sql_option_float : sql_injectable (option float) +val sql_option_string : sql_injectable (option string) +val sql_option_time : sql_injectable (option time) val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable t -> t -> sql_exp tables agg exps t diff --git a/src/c/urweb.c b/src/c/urweb.c index 638fbb16..1530c138 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -872,6 +872,13 @@ char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) { return r; } +char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) { + if (n == NULL) + return "NULL"; + else + return uw_Basis_sqlifyInt(ctx, *n); +} + char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { int len; char *r; @@ -883,6 +890,13 @@ char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { return r; } +char *uw_Basis_sqlifyFloatN(uw_context ctx, uw_Basis_float *n) { + if (n == NULL) + return "NULL"; + else + return uw_Basis_sqlifyFloat(ctx, *n); +} + uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; @@ -920,6 +934,13 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { return r; } +uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) { + if (s == NULL) + return "NULL"; + else + return uw_Basis_sqlifyString(ctx, s); +} + char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { if (b == uw_Basis_False) return "FALSE"; @@ -927,6 +948,13 @@ char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { return "TRUE"; } +char *uw_Basis_sqlifyBoolN(uw_context ctx, uw_Basis_bool *b) { + if (b == NULL) + return "NULL"; + else + return uw_Basis_sqlifyBool(ctx, *b); +} + char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { size_t len; char *r; @@ -942,6 +970,13 @@ char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { return ""; } +char *uw_Basis_sqlifyTimeN(uw_context ctx, uw_Basis_time *t) { + if (t == NULL) + return "NULL"; + else + return uw_Basis_sqlifyTime(ctx, *t); +} + char *uw_Basis_ensqlBool(uw_Basis_bool b) { static uw_Basis_int true = 1; static uw_Basis_int false = 0; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 06154b91..d7e426c3 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -408,24 +408,61 @@ 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 ")"] + | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; Print.eprefaces' [("Type", p_typ env tAll)]; string "ERROR") +fun p_getcol wontLeakStrings env (tAll as (t, loc)) i = + case t of + TOption t => + box [string "(PQgetisnull (res, i, ", + string (Int.toString i), + string ") ? NULL : ", + case t of + (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i + | _ => box [string "({", + newline, + p_typ env t, + space, + string "*tmp = uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp = ", + p_getcol wontLeakStrings env t i, + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")"] + + | _ => + p_unsql wontLeakStrings env tAll + (box [string "PQgetvalue(res, i, ", + string (Int.toString i), + string ")"]) + datatype sql_type = Int | Float | String | Bool | Time + | Nullable of sql_type + +fun p_sql_type' t = + case t of + Int => "uw_Basis_int" + | Float => "uw_Basis_float" + | String => "uw_Basis_string" + | Bool => "uw_Basis_bool" + | Time => "uw_Basis_time" + | Nullable String => "uw_Basis_string" + | Nullable t => p_sql_type' t ^ "*" -fun p_sql_type t = - string (case t of - Int => "uw_Basis_int" - | Float => "uw_Basis_float" - | String => "uw_Basis_string" - | Bool => "uw_Basis_bool" - | Time => "uw_Basis_time") +fun p_sql_type t = string (p_sql_type' t) fun getPargs (e, _) = case e of @@ -448,6 +485,12 @@ fun p_ensql t e = | String => e | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"] + | Nullable String => e + | Nullable t => box [string "(", + e, + string " == NULL ? NULL : ", + p_ensql t (box [string "*", e]), + string ")"] fun notLeaky env allowHeapAllocated = let @@ -1169,10 +1212,7 @@ fun p_exp' par env (e, loc) = space, string "=", space, - p_unsql wontLeakStrings env t - (box [string "PQgetvalue(res, i, ", - string (Int.toString i), - string ")"]), + p_getcol wontLeakStrings env t i, string ";", newline]) outputs, @@ -1660,7 +1700,10 @@ fun p_decl env (dAll as (d, _) : decl) = string "}", newline] - | DPreparedStatements [] => box [] + | DPreparedStatements [] => + box [string "static void uw_db_prepare(uw_context ctx) {", + newline, + string "}"] | DPreparedStatements ss => box [string "static void uw_db_prepare(uw_context ctx) {", newline, @@ -1708,7 +1751,7 @@ datatype 'a search = | NotFound | Error -fun p_sqltype' env (tAll as (t, loc)) = +fun p_sqltype'' env (tAll as (t, loc)) = case t of TFfi ("Basis", "int") => "int8" | TFfi ("Basis", "float") => "float8" @@ -1719,8 +1762,25 @@ fun p_sqltype' env (tAll as (t, loc)) = Print.eprefaces' [("Type", p_typ env tAll)]; "ERROR") +fun p_sqltype' env (tAll as (t, loc)) = + case t of + (TOption t, _) => p_sqltype'' env t + | _ => p_sqltype'' env t ^ " NOT NULL" + fun p_sqltype env t = string (p_sqltype' env t) +fun p_sqltype_base' env t = + case t of + (TOption t, _) => p_sqltype'' env t + | _ => p_sqltype'' env t + +fun p_sqltype_base env t = string (p_sqltype_base' env t) + +fun is_not_null t = + case t of + (TOption _, _) => false + | _ => true + fun p_file env (ds, ps) = let val (pds, env) = ListUtil.foldlMap (fn (d, env) => @@ -1997,8 +2057,13 @@ fun p_file env (ds, ps) = Char.toLower (ident x), "' AND atttypid = (SELECT oid FROM pg_type", " WHERE typname = '", - p_sqltype' env t, - "'))"]) xts), + p_sqltype_base' env t, + "') AND attnotnull = ", + if is_not_null t then + "TRUE" + else + "FALSE", + ")"]) xts), ")"] val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", @@ -2295,11 +2360,7 @@ fun p_sql env (ds, _) = box [string "uw_", string (CharVector.map Char.toLower x), space, - p_sqltype env t, - space, - string "NOT", - space, - string "NULL"]) xts, + p_sqltype env (t, ErrorMsg.dummySpan)]) xts, string ");", newline, newline] diff --git a/src/elab_env.sml b/src/elab_env.sml index b14cd06c..46f62727 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -150,12 +150,14 @@ datatype class_key = CkNamed of int | CkRel of int | CkProj of int * string list * string + | CkApp of class_key * class_key fun ck2s ck = case ck of CkNamed n => "Named(" ^ Int.toString n ^ ")" | CkRel n => "Rel(" ^ Int.toString n ^ ")" | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")" + | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")" fun cp2s (cn, ck) = "(" ^ cn2s cn ^ "," ^ ck2s ck ^ ")" @@ -176,6 +178,12 @@ fun compare x = join (Int.compare (m1, m2), fn () => join (joinL String.compare (ms1, ms2), fn () => String.compare (x1, x2))) + | (CkProj _, _) => LESS + | (_, CkProj _) => GREATER + + | (CkApp (f1, x1), CkApp (f2, x2)) => + join (compare (f1, f2), + fn () => compare (x1, x2)) end structure KM = BinaryMapFn(KK) @@ -251,6 +259,7 @@ fun liftClassKey ck = CkNamed _ => ck | CkRel n => CkRel (n + 1) | CkProj _ => ck + | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2) fun pushCRel (env : env) x k = let @@ -411,6 +420,10 @@ fun class_key_in (c, _) = | CNamed n => SOME (CkNamed n) | CModProj x => SOME (CkProj x) | CUnif (_, _, _, ref (SOME c)) => class_key_in c + | CApp (c1, c2) => + (case (class_key_in c1, class_key_in c2) of + (SOME k1, SOME k2) => SOME (CkApp (k1, k2)) + | _ => NONE) | _ => NONE fun class_pair_in (c, _) = @@ -653,7 +666,7 @@ fun sgnS_con (str, (sgns, strs, cons)) c = end) | _ => c -fun sgnS_con' (m1, ms', (sgns, strs, cons)) c = +fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c = case c of CModProj (m1, ms, x) => (case IM.find (strs, m1) of @@ -663,6 +676,8 @@ fun sgnS_con' (m1, ms', (sgns, strs, cons)) c = (case IM.find (cons, n) of NONE => c | SOME nx => CModProj (m1, ms', nx)) + | CApp (c1, c2) => CApp ((sgnS_con' arg (#1 c1), #2 c1), + (sgnS_con' arg (#1 c2), #2 c2)) | _ => c fun sgnS_sgn (str, (sgns, strs, cons)) sgn = @@ -1033,13 +1048,21 @@ fun projectVal env {sgn, str, field} = ListUtil.search (fn (x, _, to) => if x = field then SOME (let + val base = (CNamed n, #2 sgn) + val nxs = length xs + val base = ListUtil.foldli (fn (i, _, base) => + (CApp (base, + (CRel (nxs - i - 1), #2 sgn)), + #2 sgn)) + base xs + val t = case to of - NONE => (CNamed n, #2 sgn) - | SOME t => (TFun (t, (CNamed n, #2 sgn)), #2 sgn) + NONE => base + | SOME t => (TFun (t, base), #2 sgn) val k = (KType, #2 sgn) in - foldr (fn (x, t) => (TCFun (Explicit, x, k, t), #2 sgn)) + foldr (fn (x, t) => (TCFun (Implicit, x, k, t), #2 sgn)) t xs end) else diff --git a/src/elaborate.sml b/src/elaborate.sml index 3b70c623..a6edc0ed 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1389,17 +1389,32 @@ fun unmodCon env (c, loc) = end | _ => (c, loc) -fun normClassConstraint envs (c, loc) = +fun normClassKey envs c = + let + val c = ElabOps.hnormCon envs c + in + case #1 c of + L'.CApp (c1, c2) => + let + val c1 = normClassKey envs c1 + val c2 = normClassKey envs c2 + in + (L'.CApp (c1, c2), #2 c) + end + | _ => c + end + +fun normClassConstraint env (c, loc) = case c of L'.CApp (f, x) => let - val f = unmodCon (#1 envs) f - val (x, gs) = hnormCon envs x + val f = unmodCon env f + val x = normClassKey env x in - ((L'.CApp (f, x), loc), gs) + (L'.CApp (f, x), loc) end - | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint envs c - | _ => ((c, loc), []) + | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c + | _ => (c, loc) val makeInstantiable = @@ -1491,12 +1506,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) = checkKind env t' tk ktype; (t', gs) end - val (dom, gs2) = normClassConstraint (env, denv) t' - val (e', et, gs3) = elabExp (E.pushERel env x dom, denv) e + val dom = normClassConstraint env t' + val (e', et, gs2) = elabExp (E.pushERel env x dom, denv) e in ((L'.EAbs (x, t', et, e'), loc), (L'.TFun (t', et), loc), - enD gs1 @ enD gs2 @ gs3) + enD gs1 @ gs2) end | L.ECApp (e, c) => let @@ -1708,11 +1723,11 @@ and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) = val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' - val (c', gs4) = normClassConstraint (env, denv) c' + val c' = normClassConstraint env c' val env' = E.pushERel env x c' val c' = makeInstantiable c' in - ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs)) + ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.EDValRec vis => let @@ -1884,12 +1899,12 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushENamed env x c' - val (c', gs'') = normClassConstraint (env, denv) c' + val c' = normClassConstraint env c' in (unifyKinds ck ktype handle KUnify ue => strError env (NotType (ck, ue))); - ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs'' @ gs)) + ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs)) end | L.SgiStr (x, sgn) => @@ -2875,13 +2890,13 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' - val (c', gs4) = normClassConstraint (env, denv) c' + val c = normClassConstraint env c' val (env', n) = E.pushENamed env x c' val c' = makeInstantiable c' in (*prefaces "DVal" [("x", Print.PD.string x), ("c'", p_con env c')];*) - ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs)) + ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.DValRec vis => let @@ -3404,7 +3419,7 @@ fun elabFile basis topStr topSgn env file = ("Hnormed 2", p_con env (ElabOps.hnormCon env c2))])) | TypeClass (env, c, r, loc) => let - val c = ElabOps.hnormCon env c + val c = normClassKey env c in case E.resolveClass env c of SOME e => r := SOME e diff --git a/src/mono_opt.sml b/src/mono_opt.sml index b22f053b..93cb888b 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -268,6 +268,11 @@ fun exp e = | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) => EPrim (Prim.String (sqlifyInt n)) + | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) => + EPrim (Prim.String "NULL") + | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) => + EPrim (Prim.String (sqlifyInt n)) + | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) => EPrim (Prim.String (sqlifyFloat n)) | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) => diff --git a/src/monoize.sml b/src/monoize.sml index c4c296bd..83da382b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -982,10 +982,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfiApp ("Basis", "dml", [e]) => let val (e, fm) = monoExp (env, st, fm) e - val un = (L'.TRecord [], loc) in - ((L'.EAbs ("_", un, un, - (L'.EDml (liftExpInExp 0 e), loc)), loc), + ((L'.EDml (liftExpInExp 0 e), loc), fm) end @@ -1274,6 +1272,26 @@ 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.EFfi ("Basis", "sql_option_int") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "int"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyIntN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_float") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "float"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyFloatN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_bool") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "bool"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyBoolN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_string") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "string"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyStringN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_time") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyTimeN", [(L'.ERel 0, loc)]), loc)), loc), + fm) | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) => ((L'.ERecord [], loc), fm) diff --git a/src/urweb.grm b/src/urweb.grm index b2f2d486..2482be1b 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -214,7 +214,7 @@ fun tagIn bt = | TRUE | FALSE | CAND | OR | NOT | COUNT | AVG | SUM | MIN | MAX | ASC | DESC - | INSERT | INTO | VALUES | UPDATE | SET | DELETE + | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE @@ -1251,6 +1251,9 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) + | NULL (sql_inject ((EVar (["Basis"], "None", Infer), + s (NULLleft, NULLright)))) + | COUNT LPAREN STAR RPAREN (let val loc = s (COUNTleft, RPARENright) in diff --git a/src/urweb.lex b/src/urweb.lex index f5ea558a..f4ae3a85 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -357,6 +357,7 @@ notags = [^<{\n]+; "UPDATE" => (Tokens.UPDATE (pos yypos, pos yypos + size yytext)); "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext)); "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext)); + "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); diff --git a/tests/sql_option.ur b/tests/sql_option.ur new file mode 100644 index 00000000..257f8c55 --- /dev/null +++ b/tests/sql_option.ur @@ -0,0 +1,22 @@ +table t : { O : option int } + +fun addNull () = + dml (INSERT INTO t (O) VALUES (NULL)); + return Done + +(*fun add42 () = + dml (INSERT INTO t (O) VALUES (42)); + return Done*) + +fun main () : transaction page = + xml <- queryX (SELECT * FROM t) + (fn r => case r.T.O of + None => Nada
 + | Some n => Num: {[n]}
); + return + {xml} + + Add a null
+ + +(* Add a 42
*) diff --git a/tests/sql_option.urp b/tests/sql_option.urp new file mode 100644 index 00000000..543c32a8 --- /dev/null +++ b/tests/sql_option.urp @@ -0,0 +1,5 @@ +debug +database dbname=option +sql option.sql + +sql_option -- cgit v1.2.3 From 49f721d39e46ab0635cc2e9a5ed2a66944586640 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 15:52:13 -0500 Subject: Ensql'ing nullables --- src/cjr_print.sml | 7 +++++++ src/monoize.sml | 2 +- src/prepare.sml | 12 ++++++++++++ tests/sql_option.ur | 16 +++++++++++----- tests/sql_option.urs | 1 + 5 files changed, 32 insertions(+), 6 deletions(-) create mode 100644 tests/sql_option.urs (limited to 'src/monoize.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index d7e426c3..b6c32e24 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -474,6 +474,13 @@ fun getPargs (e, _) = | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] + + | 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, _, _) => [(e, Bool)] | _ => raise Fail "CjrPrint: getPargs" diff --git a/src/monoize.sml b/src/monoize.sml index 83da382b..70f15867 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -983,7 +983,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (e, fm) = monoExp (env, st, fm) e in - ((L'.EDml (liftExpInExp 0 e), loc), + ((L'.EDml e, loc), fm) end diff --git a/src/prepare.sml b/src/prepare.sml index 6d63ad7d..b20c7fec 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -47,6 +47,18 @@ 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", "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, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), (EPrim (Prim.String "TRUE"), _)), diff --git a/tests/sql_option.ur b/tests/sql_option.ur index 257f8c55..0676c907 100644 --- a/tests/sql_option.ur +++ b/tests/sql_option.ur @@ -4,9 +4,13 @@ fun addNull () = dml (INSERT INTO t (O) VALUES (NULL)); return Done -(*fun add42 () = - dml (INSERT INTO t (O) VALUES (42)); - return Done*) +fun add3 () = + dml (INSERT INTO t (O) VALUES ({Some 3})); + return Done + +fun addN r = + dml (INSERT INTO t (O) VALUES ({Some (readError r.N)})); + return Done fun main () : transaction page = xml <- queryX (SELECT * FROM t) @@ -17,6 +21,8 @@ fun main () : transaction page = {xml} Add a null
+ Add a 3
+
+ Add +
- -(* Add a 42
*) diff --git a/tests/sql_option.urs b/tests/sql_option.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/sql_option.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From dd4d718ac9f0a9862ebef19beb568bbedcc85848 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 18:49:38 -0500 Subject: Tree demo works --- demo/treeFun.ur | 2 +- lib/basis.urs | 5 + lib/top.ur | 13 ++ lib/top.urs | 12 ++ src/c/urweb.c | 2 +- src/cjr_print.sml | 9 +- src/mono_reduce.sml | 440 +++++++++++++++++++++++++++++----------------------- src/monoize.sml | 19 +++ src/urweb.grm | 13 +- src/urweb.lex | 1 + 10 files changed, 316 insertions(+), 200 deletions(-) (limited to 'src/monoize.sml') diff --git a/demo/treeFun.ur b/demo/treeFun.ur index 60633695..236f354c 100644 --- a/demo/treeFun.ur +++ b/demo/treeFun.ur @@ -18,7 +18,7 @@ functor Make(M : sig (root : option M.key) = let fun recurse (root : option key) = - queryX' (SELECT * FROM tab WHERE tab.{parent} = {root}) + queryX' (SELECT * FROM tab WHERE {[eqNullable' (SQL tab.{parent}) root]}) (fn r => children <- recurse (Some r.Tab.id); return diff --git a/lib/basis.urs b/lib/basis.urs index daefe954..656c5b91 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -197,6 +197,11 @@ val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable t -> t -> sql_exp tables agg exps t +val sql_is_null : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> t ::: Type + -> sql_exp tables agg exps (option t) + -> sql_exp tables agg exps bool + con sql_unary :: Type -> Type -> Type val sql_not : sql_unary bool bool val sql_unary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} diff --git a/lib/top.ur b/lib/top.ur index abc70e53..5d00282c 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -226,3 +226,16 @@ fun oneRow (tables ::: {{Type}}) (exps ::: {Type}) None => error Query returned no rows | Some r => r) +fun eqNullable (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) + (t ::: Type) (_ : sql_injectable (option t)) + (e1 : sql_exp tables agg exps (option t)) + (e2 : sql_exp tables agg exps (option t)) = + (SQL ({[e1]} IS NULL AND {[e2]} IS NULL) OR {[e1]} = {[e2]}) + +fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) + (t ::: Type) (inj : sql_injectable (option t)) + (e1 : sql_exp tables agg exps (option t)) + (e2 : option t) = + case e2 of + None => (SQL {[e1]} IS NULL) + | Some _ => sql_comparison sql_eq e1 (@sql_inject inj e2) diff --git a/lib/top.urs b/lib/top.urs index 6653db07..d6315b92 100644 --- a/lib/top.urs +++ b/lib/top.urs @@ -169,3 +169,15 @@ val oneRow : tables ::: {{Type}} -> exps ::: {Type} [[nm] ~ acc] => [nm = $fields] ++ acc) [] tables) + +val eqNullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> t ::: Type -> sql_injectable (option t) + -> sql_exp tables agg exps (option t) + -> sql_exp tables agg exps (option t) + -> sql_exp tables agg exps bool + +val eqNullable' : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> t ::: Type -> sql_injectable (option t) + -> sql_exp tables agg exps (option t) + -> option t + -> sql_exp tables agg exps bool diff --git a/src/c/urweb.c b/src/c/urweb.c index 1530c138..e50d6965 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -174,7 +174,7 @@ void uw_push_cleanup(uw_context ctx, void (*func)(void *), void *arg) { newLen = 1; else newLen = len * 2; - ctx->cleanup = realloc(ctx->cleanup, newLen); + ctx->cleanup = realloc(ctx->cleanup, newLen * sizeof(cleanup)); ctx->cleanup_front = ctx->cleanup + len; ctx->cleanup_back = ctx->cleanup + newLen; } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b6c32e24..2485e317 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -70,13 +70,14 @@ fun isUnboxable (t : typ) = fun p_typ' par env (t, loc) = case t of - TFun (t1, t2) => parenIf par (box [p_typ' true env t2, + TFun (t1, t2) => parenIf par (box [string "(", + p_typ' true env t2, space, string "(*)", space, string "(", p_typ env t1, - string ")"]) + string "))"]) | TRecord i => box [string "struct", space, string "__uws_", @@ -1151,6 +1152,10 @@ fun p_exp' par env (e, loc) = p_exp env initial, string ";", newline, + case prepared of + NONE => box [string "printf(\"Executing: %s\\n\", query);", + newline] + | _ => box [], string "PGresult *res = ", case prepared of NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index bf68f175..dce6ef35 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -34,6 +34,8 @@ open Mono structure E = MonoEnv structure U = MonoUtil +structure IM = IntBinaryMap + fun impure (e, _) = case e of @@ -212,6 +214,8 @@ fun p_event e = | Unsure => string "Unsure" end +val p_events = Print.p_list p_event + fun patBinds (p, _) = case p of PWild => 0 @@ -223,218 +227,266 @@ fun patBinds (p, _) = | PNone _ => 0 | PSome (_, p) => patBinds p -fun summarize d (e, _) = - case e of - EPrim _ => [] - | ERel n => if n >= d then [UseRel (n - d)] else [] - | ENamed _ => [] - | ECon (_, _, NONE) => [] - | ECon (_, _, SOME e) => summarize d e - | ENone _ => [] - | ESome (_, e) => summarize d e - | EFfi _ => [] - | EFfiApp ("Basis", "set_cookie", _) => [Unsure] - | EFfiApp (_, _, es) => List.concat (map (summarize d) es) - | EApp ((EFfi _, _), e) => summarize d e - | EApp _ => [Unsure] - | EAbs _ => [] - - | EUnop (_, e) => summarize d e - | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 - - | ERecord xets => List.concat (map (summarize d o #2) xets) - | EField (e, _) => summarize d e - - | ECase (e, pes, _) => - let - val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes - in - case lss of - [] => raise Fail "Empty pattern match" - | ls :: lss => - if List.all (fn ls' => ls' = ls) lss then - summarize d e @ ls - else - [Unsure] - end - | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 - - | EError (e, _) => summarize d e @ [Unsure] - - | EWrite e => summarize d e @ [WritePage] - - | ESeq (e1, e2) => summarize d e1 @ summarize d e2 - | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 - - | EClosure (_, es) => List.concat (map (summarize d) es) - - | EQuery {query, body, initial, ...} => - List.concat [summarize d query, - summarize (d + 2) body, - summarize d initial, - [ReadDb]] - - | EDml e => summarize d e @ [WriteDb] - | ENextval e => summarize d e @ [WriteDb] - | EUnurlify (e, _) => summarize d e - -fun exp env e = +fun reduce file = let - (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) - - val r = + fun countAbs (e, _) = + case e of + EAbs (_, _, _, e) => 1 + countAbs e + | _ => 0 + + val absCounts = + foldl (fn ((d, _), absCounts) => + case d of + DVal (_, n, _, e, _) => + IM.insert (absCounts, n, countAbs e) + | DValRec vis => + foldl (fn ((_, n, _, e, _), absCounts) => + IM.insert (absCounts, n, countAbs e)) + absCounts vis + | _ => absCounts) + IM.empty file + + fun summarize d (e, _) = case e of - ERel n => - (case E.lookupERel env n of - (_, _, SOME e') => #1 e' - | _ => e) - | ENamed n => - (case E.lookupENamed env n of - (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)), - ("e'", MonoPrint.p_exp env e')];*) - #1 e') - | _ => e) - - | EApp ((EAbs (x, t, _, e1), loc), e2) => - ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), - ("e2", MonoPrint.p_exp env e2), - ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) - if impure e2 then - #1 (reduceExp env (ELet (x, t, e2, e1), loc)) - else - #1 (reduceExp env (subExpInExp (0, e2) e1))) - - | ECase (e', pes, {disc, result}) => + EPrim _ => [] + | ERel n => if n >= d then [UseRel (n - d)] else [] + | ENamed _ => [] + | ECon (_, _, NONE) => [] + | ECon (_, _, SOME e) => summarize d e + | ENone _ => [] + | ESome (_, e) => summarize d e + | EFfi _ => [] + | EFfiApp ("Basis", "set_cookie", _) => [Unsure] + | EFfiApp (_, _, es) => List.concat (map (summarize d) es) + | EApp ((EFfi _, _), e) => summarize d e + | EApp _ => let - fun push () = - case result of - (TFun (dom, result), loc) => - if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then - EAbs ("_", dom, result, - (ECase (liftExpInExp 0 e', - map (fn (p, (EAbs (_, _, _, e), _)) => - (p, swapExpVarsPat (0, patBinds p) e) - | _ => raise Fail "MonoReduce ECase") pes, - {disc = disc, result = result}), loc)) - else - e - | _ => e - - fun search pes = - case pes of - [] => push () - | (p, body) :: pes => - case match (env, p, e') of - No => search pes - | Maybe => push () - | Yes env => #1 (reduceExp env body) + fun unravel (e, ls) = + case e of + ENamed n => + let + val ls = rev ls + in + case IM.find (absCounts, n) of + NONE => [Unsure] + | SOME len => + if length ls < len then + ls + else + [Unsure] + end + | ERel n => List.revAppend (ls, [UseRel (n - d), Unsure]) + | EApp (f, x) => + unravel (#1 f, summarize d x @ ls) + | _ => [Unsure] in - search pes + unravel (e, []) end - | EField ((ERecord xes, _), x) => - (case List.find (fn (x', _, _) => x' = x) xes of - SOME (_, e, _) => #1 e - | NONE => e) + | EAbs _ => [] + + | EUnop (_, e) => summarize d e + | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 - | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => + | ERecord xets => List.concat (map (summarize d o #2) xets) + | EField (e, _) => summarize d e + + | ECase (e, pes, _) => let - val e' = (ELet (x2, t2, e1, - (ELet (x1, t1, b1, - liftExpInExp 1 b2), loc)), loc) + val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes in - (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)), - ("e'", MonoPrint.p_exp env e')];*) - #1 (reduceExp env e') + case lss of + [] => raise Fail "Empty pattern match" + | ls :: lss => + if List.all (fn ls' => ls' = ls) lss then + summarize d e @ ls + else + [Unsure] end - | EApp ((ELet (x, t, e, b), loc), e') => - #1 (reduceExp env (ELet (x, t, e, - (EApp (b, liftExpInExp 0 e'), loc)), loc)) - - | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => - (*if impure e' then - e - else*) - (* Seems unsound in general without the check... should revisit later *) - EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) - - | ELet (x, t, e', b) => - let - fun doSub () = - #1 (reduceExp env (subExpInExp (0, e') b)) - - fun trySub () = - case t of - (TFfi ("Basis", "string"), _) => doSub () - | _ => - case e' of - (ECase _, _) => e - | _ => doSub () - in - if impure e' then + | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 + + | EError (e, _) => summarize d e @ [Unsure] + + | EWrite e => summarize d e @ [WritePage] + + | ESeq (e1, e2) => summarize d e1 @ summarize d e2 + | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 + + | EClosure (_, es) => List.concat (map (summarize d) es) + + | EQuery {query, body, initial, ...} => + List.concat [summarize d query, + summarize (d + 2) body, + summarize d initial, + [ReadDb]] + + | EDml e => summarize d e @ [WriteDb] + | ENextval e => summarize d e @ [WriteDb] + | EUnurlify (e, _) => summarize d e + + + fun exp env e = + let + (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) + + val r = + case e of + ERel n => + (case E.lookupERel env n of + (_, _, SOME e') => #1 e' + | _ => e) + | ENamed n => + (case E.lookupENamed env n of + (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)), + ("e'", MonoPrint.p_exp env e')];*) + #1 e') + | _ => e) + + | EApp ((EAbs (x, t, _, e1), loc), e2) => + ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), + ("e2", MonoPrint.p_exp env e2), + ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) + if impure e2 then + #1 (reduceExp env (ELet (x, t, e2, e1), loc)) + else + #1 (reduceExp env (subExpInExp (0, e2) e1))) + + | ECase (e', pes, {disc, result}) => let - val effs_e' = summarize 0 e' - val effs_b = summarize 0 b - - fun does eff = List.exists (fn eff' => eff' = eff) effs_e' - val writesPage = does WritePage - val readsDb = does ReadDb - val writesDb = does WriteDb - - fun verifyUnused eff = - case eff of - UseRel r => r <> 0 - | Unsure => false - | _ => true - - fun verifyCompatible effs = - case effs of - [] => false - | eff :: effs => - case eff of - Unsure => false - | UseRel r => - if r = 0 then - List.all verifyUnused effs - else - verifyCompatible effs - | WritePage => not writesPage andalso verifyCompatible effs - | ReadDb => not writesDb andalso verifyCompatible effs - | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs + fun push () = + case result of + (TFun (dom, result), loc) => + if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then + EAbs ("_", dom, result, + (ECase (liftExpInExp 0 e', + map (fn (p, (EAbs (_, _, _, e), _)) => + (p, swapExpVarsPat (0, patBinds p) e) + | _ => raise Fail "MonoReduce ECase") pes, + {disc = disc, result = result}), loc)) + else + e + | _ => e + + fun search pes = + case pes of + [] => push () + | (p, body) :: pes => + case match (env, p, e') of + No => search pes + | Maybe => push () + | Yes env => #1 (reduceExp env body) in - (*Print.prefaces "verifyCompatible" - [("e'", MonoPrint.p_exp env e'), - ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), - ("effs_e'", Print.p_list p_event effs_e'), - ("effs_b", Print.p_list p_event effs_b)];*) - if verifyCompatible effs_b then - trySub () - else - e + search pes end - else - trySub () - end - | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => - EPrim (Prim.String (s1 ^ s2)) + | EField ((ERecord xes, _), x) => + (case List.find (fn (x', _, _) => x' = x) xes of + SOME (_, e, _) => #1 e + | NONE => e) - | _ => e - in - (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) - r - end + | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => + let + val e' = (ELet (x2, t2, e1, + (ELet (x1, t1, b1, + liftExpInExp 1 b2), loc)), loc) + in + (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)), + ("e'", MonoPrint.p_exp env e')];*) + #1 (reduceExp env e') + end + | EApp ((ELet (x, t, e, b), loc), e') => + #1 (reduceExp env (ELet (x, t, e, + (EApp (b, liftExpInExp 0 e'), loc)), loc)) + + | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => + (*if impure e' then + e + else*) + (* Seems unsound in general without the check... should revisit later *) + EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) + + | ELet (x, t, e', b) => + let + fun doSub () = + #1 (reduceExp env (subExpInExp (0, e') b)) + + fun trySub () = + case t of + (TFfi ("Basis", "string"), _) => doSub () + | _ => + case e' of + (ECase _, _) => e + | _ => doSub () + in + if impure e' then + let + val effs_e' = summarize 0 e' + val effs_b = summarize 0 b + + (*val () = Print.prefaces "Try" + [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), + ("e'", p_events effs_e'), + ("b", p_events effs_b)]*) + + fun does eff = List.exists (fn eff' => eff' = eff) effs_e' + val writesPage = does WritePage + val readsDb = does ReadDb + val writesDb = does WriteDb + + fun verifyUnused eff = + case eff of + UseRel r => r <> 0 + | _ => true + + fun verifyCompatible effs = + case effs of + [] => false + | eff :: effs => + case eff of + Unsure => false + | UseRel r => + if r = 0 then + List.all verifyUnused effs + else + verifyCompatible effs + | WritePage => not writesPage andalso verifyCompatible effs + | ReadDb => not writesDb andalso verifyCompatible effs + | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs + in + (*Print.prefaces "verifyCompatible" + [("e'", MonoPrint.p_exp env e'), + ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), + ("effs_e'", Print.p_list p_event effs_e'), + ("effs_b", Print.p_list p_event effs_b)];*) + if verifyCompatible effs_b then + trySub () + else + e + end + else + trySub () + end + + | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => + EPrim (Prim.String (s1 ^ s2)) -and bind (env, b) = - case b of - U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs - | U.Decl.RelE (x, t) => E.pushERel env x t NONE - | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s + | _ => e + in + (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) + r + end -and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env + and bind (env, b) = + case b of + U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs + | U.Decl.RelE (x, t) => E.pushERel env x t NONE + | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s -fun decl env d = d + and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env -val reduce = U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty + fun decl env d = d + in + U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file + end end diff --git a/src/monoize.sml b/src/monoize.sml index 70f15867..9e1a4d22 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1584,6 +1584,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm) + | (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_is_null"), _), _), + _), _), + _), _), + _), _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + fun sc s = (L'.EPrim (Prim.String s), loc) + in + ((L'.EAbs ("s", s, s, + strcat loc [sc "(", + (L'.ERel 0, loc), + sc " IS NULL)"]), loc), + fm) + end + | L.EFfiApp ("Basis", "nextval", [e]) => let val (e, fm) = monoExp (env, st, fm) e diff --git a/src/urweb.grm b/src/urweb.grm index 2482be1b..4ac14450 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -214,7 +214,7 @@ fun tagIn bt = | TRUE | FALSE | CAND | OR | NOT | COUNT | AVG | SUM | MIN | MAX | ASC | DESC - | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL + | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE @@ -346,7 +346,7 @@ fun tagIn bt = %right COMMA %right OR %right CAND -%nonassoc EQ NE LT LE GT GE +%nonassoc EQ NE LT LE GT GE IS %right ARROW %right PLUSPLUS MINUSMINUS %left PLUS MINUS @@ -1236,6 +1236,8 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In end end) + | LBRACE LBRACK eexp RBRACK RBRACE (eexp) + | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) @@ -1247,6 +1249,13 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright))) + | sqlexp IS NULL (let + val loc = s (sqlexpleft, NULLright) + in + (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc), + sqlexp), loc) + end) + | LBRACE eexp RBRACE (sql_inject (#1 eexp, s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) diff --git a/src/urweb.lex b/src/urweb.lex index f4ae3a85..642282ec 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -358,6 +358,7 @@ notags = [^<{\n]+; "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext)); "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext)); "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); + "IS" => (Tokens.IS (pos yypos, pos yypos + size yytext)); "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); -- cgit v1.2.3 From 24b68e6d7408f50023272e765687eab777596363 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 19:43:48 -0500 Subject: Tree demo working (and other assorted regressions fixed) --- demo/crud.ur | 8 ++++---- demo/prose | 4 ++++ demo/refFun.ur | 8 ++++---- demo/sql.ur | 4 ++-- demo/tree.ur | 22 ++++++++++++++++++++-- demo/tree.urp | 2 +- demo/treeFun.ur | 2 +- lib/top.ur | 4 ++-- src/cjr_print.sml | 37 +++++++++++++++++++++++++++++++++++++ src/elab_env.sig | 1 + src/elab_env.sml | 3 +++ src/elaborate.sml | 16 +++++++++++----- src/monoize.sml | 16 ++++++++++++++++ src/urweb.grm | 6 +++--- 14 files changed, 109 insertions(+), 24 deletions(-) (limited to 'src/monoize.sml') diff --git a/demo/crud.ur b/demo/crud.ur index ee6a95f6..a120cb2a 100644 --- a/demo/crud.ur +++ b/demo/crud.ur @@ -102,7 +102,7 @@ functor Make(M : sig [[nm] ~ rest] => fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) {} [M.cols] inputs M.cols - ++ {Id = (SQL {id})})); + ++ {Id = (SQL {[id]})})); ls <- list (); return

Inserted with ID {[id]}.

@@ -122,7 +122,7 @@ functor Make(M : sig fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) {} [M.cols] inputs M.cols) - tab (WHERE T.Id = {id})); + tab (WHERE T.Id = {[id]})); ls <- list (); return

Saved!

@@ -131,7 +131,7 @@ functor Make(M : sig and upd (id : int) = - fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {id}); + fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {[id]}); case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of None => return Not found! | Some fs => return
@@ -150,7 +150,7 @@ functor Make(M : sig
and delete (id : int) = - dml (DELETE FROM tab WHERE Id = {id}); + dml (DELETE FROM tab WHERE Id = {[id]}); ls <- list (); return

The deed is done.

diff --git a/demo/prose b/demo/prose index fad98e26..11661211 100644 --- a/demo/prose +++ b/demo/prose @@ -132,6 +132,10 @@ metaform2.urp

This example showcases code reuse by applying the same functor as in the last example. The Metaform2 module mixes pages from the functor with some new pages of its own.

+tree.urp + +

Here we see how we can abstract over common patterns of SQL queries. In particular, since standard SQL does not help much with queries over trees, we write a function for traversing an SQL tree, building an HTML representation, based on a user-provided function for rendering individual rows.

+ crud1.urp

This example pulls together much of what we have seen so far. It involves a generic "admin interface" builder. That is, we have the Crud.Make functor, which takes in a description of a table and outputs a sub-application for viewing and editing that table.

diff --git a/demo/refFun.ur b/demo/refFun.ur index d648f31e..e523bac7 100644 --- a/demo/refFun.ur +++ b/demo/refFun.ur @@ -10,19 +10,19 @@ functor Make(M : sig fun new d = id <- nextval s; - dml (INSERT INTO t (Id, Data) VALUES ({id}, {d})); + dml (INSERT INTO t (Id, Data) VALUES ({[id]}, {[d]})); return id fun read r = - o <- oneOrNoRows (SELECT t.Data FROM t WHERE t.Id = {r}); + o <- oneOrNoRows (SELECT t.Data FROM t WHERE t.Id = {[r]}); return (case o of None => error You already deleted that ref! | Some r => r.T.Data) fun write r d = - dml (UPDATE t SET Data = {d} WHERE Id = {r}) + dml (UPDATE t SET Data = {[d]} WHERE Id = {[r]}) fun delete r = - dml (DELETE FROM t WHERE Id = {r}) + dml (DELETE FROM t WHERE Id = {[r]}) end diff --git a/demo/sql.ur b/demo/sql.ur index 43a69573..44ff478f 100644 --- a/demo/sql.ur +++ b/demo/sql.ur @@ -27,7 +27,7 @@ fun list () = and add r = dml (INSERT INTO t (A, B, C, D) - VALUES ({readError r.A}, {readError r.B}, {r.C}, {r.D})); + VALUES ({[readError r.A]}, {[readError r.B]}, {[r.C]}, {[r.D]})); xml <- list (); return

Row added.

@@ -37,7 +37,7 @@ and add r = and delete a = dml (DELETE FROM t - WHERE t.A = {a}); + WHERE t.A = {[a]}); xml <- list (); return

Row deleted.

diff --git a/demo/tree.ur b/demo/tree.ur index 06a30cf9..27e9aa21 100644 --- a/demo/tree.ur +++ b/demo/tree.ur @@ -1,3 +1,4 @@ +sequence s table t : { Id : int, Parent : option int, Nam : string } open TreeFun.Make(struct @@ -5,11 +6,28 @@ open TreeFun.Make(struct end) fun row r = - #{[r.Id]}: {[r.Nam]} + #{[r.Id]}: {[r.Nam]} [Delete] + +
+ Add child: +
-fun main () = +and main () = xml <- tree row None; return {xml} + +
+ Add a top-level node: +
+ +and add parent r = + id <- nextval s; + dml (INSERT INTO t (Id, Parent, Nam) VALUES ({[id]}, {[parent]}, {[r.Nam]})); + main () + +and del id = + dml (DELETE FROM t WHERE Id = {[id]}); + main () diff --git a/demo/tree.urp b/demo/tree.urp index 2270dd06..880a7ab4 100644 --- a/demo/tree.urp +++ b/demo/tree.urp @@ -1,5 +1,5 @@ debug -database dbname=tree +database dbname=test sql tree.sql treeFun diff --git a/demo/treeFun.ur b/demo/treeFun.ur index 236f354c..15fe60f5 100644 --- a/demo/treeFun.ur +++ b/demo/treeFun.ur @@ -18,7 +18,7 @@ functor Make(M : sig (root : option M.key) = let fun recurse (root : option key) = - queryX' (SELECT * FROM tab WHERE {[eqNullable' (SQL tab.{parent}) root]}) + queryX' (SELECT * FROM tab WHERE {eqNullable' (SQL tab.{parent}) root}) (fn r => children <- recurse (Some r.Tab.id); return diff --git a/lib/top.ur b/lib/top.ur index 5d00282c..76fe73c1 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -230,12 +230,12 @@ fun eqNullable (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) (t ::: Type) (_ : sql_injectable (option t)) (e1 : sql_exp tables agg exps (option t)) (e2 : sql_exp tables agg exps (option t)) = - (SQL ({[e1]} IS NULL AND {[e2]} IS NULL) OR {[e1]} = {[e2]}) + (SQL ({e1} IS NULL AND {e2} IS NULL) OR {e1} = {e2}) fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) (t ::: Type) (inj : sql_injectable (option t)) (e1 : sql_exp tables agg exps (option t)) (e2 : option t) = case e2 of - None => (SQL {[e1]} IS NULL) + None => (SQL {e1} IS NULL) | Some _ => sql_comparison sql_eq e1 (@sql_inject inj e2) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 2485e317..3941fdd9 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -799,6 +799,43 @@ fun unurlify env (t, loc) = string "})"] end + | TOption t => + box [string "(request[0] == '/' ? ++request : request, ", + string "((!strncmp(request, \"None\", 4) ", + string "&& (request[4] == 0 || request[4] == '/')) ", + string "? (request += 4, NULL) ", + string ": ((!strncmp(request, \"Some\", 4) ", + string "&& request[4] == '/') ", + string "? (request += 5, ", + if isUnboxable t then + unurlify' rf (#1 t) + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + space, + unurlify' rf (#1 t), + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ") :", + space, + string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"] + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; space) in diff --git a/src/elab_env.sig b/src/elab_env.sig index 90cf8153..926837e1 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -74,6 +74,7 @@ signature ELAB_ENV = sig val pushENamed : env -> string -> Elab.con -> env * int val pushENamedAs : env -> string -> int -> Elab.con -> env val lookupENamed : env -> int -> string * Elab.con + val checkENamed : env -> int -> bool val lookupE : env -> string -> Elab.con var diff --git a/src/elab_env.sml b/src/elab_env.sml index 46f62727..05da56db 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -542,6 +542,9 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x +fun checkENamed (env : env) n = + Option.isSome (IM.find (#namedE env, n)) + fun lookupE (env : env) x = case SM.find (#renameE env, x) of NONE => NotBound diff --git a/src/elaborate.sml b/src/elaborate.sml index f0beecdd..e84f5307 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2282,9 +2282,15 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = let val env = case #1 h of L'.SgiCon (x, n, k, c) => - E.pushCNamedAs env x n k (SOME c) + if E.checkENamed env n then + env + else + E.pushCNamedAs env x n k (SOME c) | L'.SgiConAbs (x, n, k) => - E.pushCNamedAs env x n k NONE + if E.checkENamed env n then + env + else + E.pushCNamedAs env x n k NONE | _ => env in seek (E.sgiBinds env h, sgiBindsD (env, denv) h) t @@ -2391,12 +2397,12 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = fun good () = let - val env = E.sgiBinds env sgi2All + val env = E.sgiBinds env sgi1All val env = if n1 = n2 then env else - E.pushCNamedAs env x n1 k' - (SOME (L'.CNamed n2, loc)) + E.pushCNamedAs env x n2 k' + (SOME (L'.CNamed n1, loc)) in SOME (env, denv) end diff --git a/src/monoize.sml b/src/monoize.sml index 9e1a4d22..ee509f52 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -390,6 +390,22 @@ fun fooifyExp fk env = ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) end + | L'.TOption t => + let + val (body, fm) = fooify fm ((L'.ERel 0, loc), t) + in + ((L'.ECase (e, + [((L'.PNone t, loc), + (L'.EPrim (Prim.String "None"), loc)), + + ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), + (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc), + body), loc))], + {disc = tAll, + result = (L'.TFfi ("Basis", "string"), loc)}), loc), + fm) + end + | _ => (E.errorAt loc "Don't know how to encode attribute type"; Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; (dummyExp, fm)) diff --git a/src/urweb.grm b/src/urweb.grm index 4ac14450..b49cd793 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1236,7 +1236,7 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In end end) - | LBRACE LBRACK eexp RBRACK RBRACE (eexp) + | LBRACE eexp RBRACE (eexp) | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) @@ -1256,8 +1256,8 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In sqlexp), loc) end) - | LBRACE eexp RBRACE (sql_inject (#1 eexp, - s (LBRACEleft, RBRACEright))) + | LBRACE LBRACK eexp RBRACK RBRACE (sql_inject (#1 eexp, + s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) | NULL (sql_inject ((EVar (["Basis"], "None", Infer), -- cgit v1.2.3 From 4ec6c9e24ebb58cd62b6f9d69447fae314aac82d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 16:27:51 -0500 Subject: More ThreadedBlog progress --- src/monoize.sml | 2 +- src/unnest.sml | 13 +++++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) (limited to 'src/monoize.sml') diff --git a/src/monoize.sml b/src/monoize.sml index ee509f52..a4f38dc6 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -406,7 +406,7 @@ fun fooifyExp fk env = fm) end - | _ => (E.errorAt loc "Don't know how to encode attribute type"; + | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; (dummyExp, fm)) in diff --git a/src/unnest.sml b/src/unnest.sml index fe63f9fe..8e363301 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -206,6 +206,14 @@ fun exp ((ks, ts), e as old, st : state) = val loc = #2 ed val nr = length vis + val subsLocal = List.filter (fn (_, (ERel _, _)) => false + | _ => true) subs + val subsLocal = map (fn (n, e) => (n + nr, liftExpInExp nr 0 e)) + subsLocal + + val vis = map (fn (x, t, e) => + (x, t, doSubst' (e, subsLocal))) vis + val (cfv, efv) = foldl (fn ((_, t, e), (cfv, efv)) => let val (cfv', efv') = fvsExp nr e @@ -243,15 +251,12 @@ fun exp ((ks, ts), e as old, st : state) = maxName + 1)) maxName vis - - val subs = map (fn (n, e) => (n + nr, case e of (ERel _, _) => e | _ => liftExpInExp nr 0 e)) subs - val subs' = ListUtil.mapi (fn (i, (_, n, _, _)) => let val e = (ENamed n, loc) @@ -278,7 +283,7 @@ fun exp ((ks, ts), e as old, st : state) = let (*val () = Print.prefaces "preSubst" [("e", ElabPrint.p_exp E.empty e)]*) - val e = doSubst' (e, subs) + val e = doSubst' (e, subs') (*val () = Print.prefaces "squishCon" [("t", ElabPrint.p_con E.empty t)]*) -- cgit v1.2.3 From 887af944c67e3395679a750a205ef114234c61a0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 19:20:37 -0500 Subject: Add CutMulti --- include/urweb.h | 1 + src/c/urweb.c | 7 ++++++ src/cjr_print.sml | 2 +- src/core.sml | 1 + src/core_print.sml | 17 +++++++++++++ src/core_util.sml | 16 ++++++++++++- src/corify.sml | 2 ++ src/elab.sml | 1 + src/elab_print.sml | 18 ++++++++++++++ src/elab_util.sml | 9 +++++++ src/elaborate.sml | 67 +++++++++++++++++++++++++++++++++++++++++++++------- src/expl.sml | 1 + src/expl_print.sml | 17 +++++++++++++ src/expl_util.sml | 8 +++++++ src/explify.sml | 2 ++ src/monoize.sml | 1 + src/reduce.sml | 13 ++++++++++ src/source.sml | 1 + src/source_print.sml | 5 ++++ src/termination.sml | 6 +++++ src/urweb.grm | 5 ++-- src/urweb.lex | 1 + tests/cut.ur | 7 +++--- tests/cut.urp | 3 +++ 24 files changed, 195 insertions(+), 16 deletions(-) create mode 100644 tests/cut.urp (limited to 'src/monoize.sml') diff --git a/include/urweb.h b/include/urweb.h index d148654f..ad08c811 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -75,6 +75,7 @@ uw_Basis_time uw_Basis_unurlifyTime(uw_context, char **); uw_Basis_string uw_Basis_strcat(uw_context, uw_Basis_string, uw_Basis_string); uw_Basis_string uw_Basis_strdup(uw_context, uw_Basis_string); +uw_Basis_string uw_Basis_maybe_strdup(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sqlifyInt(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_sqlifyFloat(uw_context, uw_Basis_float); diff --git a/src/c/urweb.c b/src/c/urweb.c index a347dd45..253cda87 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -869,6 +869,13 @@ uw_Basis_string uw_Basis_strdup(uw_context ctx, uw_Basis_string s1) { return s; } +uw_Basis_string uw_Basis_maybe_strdup(uw_context ctx, uw_Basis_string s1) { + if (s1) + return uw_Basis_strdup(ctx, s1); + else + return NULL; +} + char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) { int len; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 1c750b33..8c3c3d86 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1481,7 +1481,7 @@ fun p_exp' par env (e, loc) = in box [string "({", newline, - string "uw_Basis_string request = uw_Basis_strdup(ctx, ", + string "uw_Basis_string request = uw_Basis_maybe_strdup(ctx, ", p_exp env e, string ");", newline, diff --git a/src/core.sml b/src/core.sml index 1a181a68..4623bb49 100644 --- a/src/core.sml +++ b/src/core.sml @@ -95,6 +95,7 @@ datatype exp' = | EField of exp * con * { field : con, rest : con } | EConcat of exp * con * exp * con | ECut of exp * con * { field : con, rest : con } + | ECutMulti of exp * con * { rest : con } | EFold of kind | ECase of exp * (pat * exp) list * { disc : con, result : con } diff --git a/src/core_print.sml b/src/core_print.sml index f209b84f..53922936 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -325,6 +325,23 @@ fun p_exp' par env (e, _) = string "--", space, p_con' true env c]) + | ECutMulti (e, c, {rest}) => + parenIf par (if !debug then + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c, + space, + string "[", + p_con env rest, + string "]"] + else + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c]) | EFold _ => string "fold" | ECase (e, pes, {disc, result}) => diff --git a/src/core_util.sml b/src/core_util.sml index 38004f74..71efe16e 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -444,10 +444,16 @@ fun compare ((e1, _), (e2, _)) = | (ECut (e1, c1, _), ECut (e2, c2, _)) => join (compare (e1, e2), - fn () => Con.compare (c1, c2)) + fn () => Con.compare (c1, c2)) | (ECut _, _) => LESS | (_, ECut _) => GREATER + | (ECutMulti (e1, c1, _), ECutMulti (e2, c2, _)) => + join (compare (e1, e2), + fn () => Con.compare (c1, c2)) + | (ECutMulti _, _) => LESS + | (_, ECutMulti _) => GREATER + | (EFold _, EFold _) => EQUAL | (EFold _, _) => LESS | (_, EFold _) => GREATER @@ -588,6 +594,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfc ctx rest, fn rest' => (ECut (e', c', {field = field', rest = rest'}), loc))))) + | ECutMulti (e, c, {rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfc ctx rest, + fn rest' => + (ECutMulti (e', c', {rest = rest'}), loc)))) | EFold k => S.map2 (mfk k, fn k' => diff --git a/src/corify.sml b/src/corify.sml index fdb4e7b7..8bb1a925 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -590,6 +590,8 @@ fun corifyExp st (e, loc) = corifyCon st c2), loc) | L.ECut (e1, c, {field, rest}) => (L'.ECut (corifyExp st e1, corifyCon st c, {field = corifyCon st field, rest = corifyCon st rest}), loc) + | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (corifyExp st e1, corifyCon st c, + {rest = corifyCon st rest}), loc) | L.EFold k => (L'.EFold (corifyKind k), loc) | L.ECase (e, pes, {disc, result}) => diff --git a/src/elab.sml b/src/elab.sml index d00d1f1a..d997b7ec 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -110,6 +110,7 @@ datatype exp' = | EField of exp * con * { field : con, rest : con } | EConcat of exp * con * exp * con | ECut of exp * con * { field : con, rest : con } + | ECutMulti of exp * con * { rest : con } | EFold of kind | ECase of exp * (pat * exp) list * { disc : con, result : con } diff --git a/src/elab_print.sml b/src/elab_print.sml index 2afedef1..62b1ea02 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -359,6 +359,24 @@ fun p_exp' par env (e, _) = string "--", space, p_con' true env c]) + | ECutMulti (e, c, {rest}) => + parenIf par (if !debug then + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c, + space, + string "[", + p_con env rest, + string "]"] + else + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c]) + | EFold _ => string "fold" | ECase (e, pes, _) => parenIf par (box [string "case", diff --git a/src/elab_util.sml b/src/elab_util.sml index 9c25ae86..6e2c76f6 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -338,6 +338,15 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn rest' => (ECut (e', c', {field = field', rest = rest'}), loc))))) + | ECutMulti (e, c, {rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfc ctx rest, + fn rest' => + (ECutMulti (e', c', {rest = rest'}), loc)))) + | EFold k => S.map2 (mfk k, fn k' => diff --git a/src/elaborate.sml b/src/elaborate.sml index 70429c1b..e3d334eb 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1664,6 +1664,21 @@ fun elabExp (env, denv) (eAll as (e, loc)) = ((L'.ECut (e', c', {field = ft, rest = rest}), loc), (L'.TRecord rest, loc), gs1 @ enD gs2 @ enD gs3 @ enD gs4) end + | L.ECutMulti (e, c) => + let + val (e', et, gs1) = elabExp (env, denv) e + val (c', ck, gs2) = elabCon (env, denv) c + + val rest = cunif (loc, ktype_record) + + val gs3 = + checkCon (env, denv) e' et + (L'.TRecord (L'.CConcat (c', rest), loc), loc) + val gs4 = D.prove env denv (c', rest, loc) + in + ((L'.ECutMulti (e', c', {rest = rest}), loc), (L'.TRecord rest, loc), + gs1 @ enD gs2 @ enD gs3 @ enD gs4) + end | L.EFold => let @@ -2694,6 +2709,33 @@ fun wildifyStr env (str, sgn) = (case #1 str of L.StrConst ds => let + fun decompileKind (k, loc) = + case k of + L'.KType => SOME (L.KType, loc) + | L'.KArrow (k1, k2) => + (case (decompileKind k1, decompileKind k2) of + (SOME k1, SOME k2) => SOME (L.KArrow (k1, k2), loc) + | _ => NONE) + | L'.KName => SOME (L.KName, loc) + | L'.KRecord k => + (case decompileKind k of + SOME k => SOME (L.KRecord k, loc) + | _ => NONE) + | L'.KUnit => SOME (L.KUnit, loc) + | L'.KTuple ks => + let + val ks' = List.mapPartial decompileKind ks + in + if length ks' = length ks then + SOME (L.KTuple ks', loc) + else + NONE + end + + | L'.KError => NONE + | L'.KUnif (_, _, ref (SOME k)) => decompileKind k + | L'.KUnif _ => NONE + fun decompileCon env (c, loc) = case c of L'.CRel i => @@ -2741,7 +2783,7 @@ fun wildifyStr env (str, sgn) = let val (needed, constraints, neededV) = case sgi of - L'.SgiConAbs (x, _, _) => (SS.add (neededC, x), constraints, neededV) + L'.SgiConAbs (x, _, k) => (SM.insert (neededC, x, k), constraints, neededV) | L'.SgiConstraint cs => (neededC, (env', cs, loc) :: constraints, neededV) | L'.SgiVal (x, _, t) => @@ -2764,18 +2806,18 @@ fun wildifyStr env (str, sgn) = in (needed, constraints, neededV, E.sgiBinds env' (sgi, loc)) end) - (SS.empty, [], SS.empty, env) sgis + (SM.empty, [], SS.empty, env) sgis val (neededC, neededV) = foldl (fn ((d, _), needed as (neededC, neededV)) => case d of - L.DCon (x, _, _) => ((SS.delete (neededC, x), neededV) + L.DCon (x, _, _) => ((#1 (SM.remove (neededC, x)), neededV) handle NotFound => needed) - | L.DClass (x, _) => ((SS.delete (neededC, x), neededV) + | L.DClass (x, _) => ((#1 (SM.remove (neededC, x)), neededV) handle NotFound => needed) | L.DVal (x, _, _) => ((neededC, SS.delete (neededV, x)) handle NotFound => needed) - | L.DOpen _ => (SS.empty, SS.empty) + | L.DOpen _ => (SM.empty, SS.empty) | _ => needed) (neededC, neededV) ds @@ -2797,13 +2839,20 @@ fun wildifyStr env (str, sgn) = end val ds' = - case SS.listItems neededC of + case SM.listItemsi neededC of [] => ds' | xs => let - val kwild = (L.KWild, #2 str) - val cwild = (L.CWild kwild, #2 str) - val ds'' = map (fn x => (L.DCon (x, NONE, cwild), #2 str)) xs + val ds'' = map (fn (x, k) => + let + val k = + case decompileKind k of + NONE => (L.KWild, #2 str) + | SOME k => k + val cwild = (L.CWild k, #2 str) + in + (L.DCon (x, NONE, cwild), #2 str) + end) xs in ds'' @ ds' end diff --git a/src/expl.sml b/src/expl.sml index 57396684..cce0fc22 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -92,6 +92,7 @@ datatype exp' = | EField of exp * con * { field : con, rest : con } | EConcat of exp * con * exp * con | ECut of exp * con * { field : con, rest : con } + | ECutMulti of exp * con * { rest : con } | EFold of kind | ECase of exp * (pat * exp) list * { disc : con, result : con } diff --git a/src/expl_print.sml b/src/expl_print.sml index e3153ef2..2ce0c5e2 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -334,6 +334,23 @@ fun p_exp' par env (e, loc) = string "--", space, p_con' true env c]) + | ECutMulti (e, c, {rest}) => + parenIf par (if !debug then + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c, + space, + string "[", + p_con env rest, + string "]"] + else + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c]) | EFold _ => string "fold" | EWrite e => box [string "write(", diff --git a/src/expl_util.sml b/src/expl_util.sml index 2bd9eabd..d2073a23 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -303,6 +303,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfc ctx rest, fn rest' => (ECut (e', c', {field = field', rest = rest'}), loc))))) + | ECutMulti (e, c, {rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfc ctx rest, + fn rest' => + (ECutMulti (e', c', {rest = rest'}), loc)))) | EFold k => S.map2 (mfk k, fn k' => diff --git a/src/explify.sml b/src/explify.sml index 4115476b..e3c22f20 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -105,6 +105,8 @@ fun explifyExp (e, loc) = loc) | L.ECut (e1, c, {field, rest}) => (L'.ECut (explifyExp e1, explifyCon c, {field = explifyCon field, rest = explifyCon rest}), loc) + | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (explifyExp e1, explifyCon c, + {rest = explifyCon rest}), loc) | L.EFold k => (L'.EFold (explifyKind k), loc) | L.ECase (e, pes, {disc, result}) => diff --git a/src/monoize.sml b/src/monoize.sml index a4f38dc6..28ea5946 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2014,6 +2014,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.EConcat _ => poly () | L.ECut _ => poly () + | L.ECutMulti _ => poly () | L.EFold _ => poly () | L.ECase (e, pes, {disc, result}) => diff --git a/src/reduce.sml b/src/reduce.sml index 1404b598..e480dea2 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -133,6 +133,19 @@ fun exp env e = in #1 (reduceExp env (ERecord (fields (xts, [])), loc)) end + | ECutMulti (r as (_, loc), _, {rest = (CRecord (k, xts), _), ...}) => + let + fun fields (remaining, passed) = + case remaining of + [] => [] + | (x, t) :: rest => + (x, + (EField (r, x, {field = t, + rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc), + t) :: fields (rest, (x, t) :: passed) + in + #1 (reduceExp env (ERecord (fields (xts, [])), loc)) + end | _ => e in diff --git a/src/source.sml b/src/source.sml index 2a348338..7685bb2f 100644 --- a/src/source.sml +++ b/src/source.sml @@ -123,6 +123,7 @@ datatype exp' = | EField of exp * con | EConcat of exp * exp | ECut of exp * con + | ECutMulti of exp * con | EFold | EWild diff --git a/src/source_print.sml b/src/source_print.sml index 3c26812f..77f2d749 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -268,6 +268,11 @@ fun p_exp' par (e, _) = string "--", space, p_con' true c]) + | ECutMulti (e, c) => parenIf par (box [p_exp' true e, + space, + string "---", + space, + p_con' true c]) | EFold => string "fold" | ECase (e, pes) => parenIf par (box [string "case", diff --git a/src/termination.sml b/src/termination.sml index 2db5bb11..e89f329e 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -265,6 +265,12 @@ fun declOk' env (d, loc) = in (Rabble, calls) end + | ECutMulti (e, _, _) => + let + val (_, calls) = exp parent (penv, calls) e + in + (Rabble, calls) + end | EConcat (e1, _, e2, _) => let val (_, calls) = exp parent (penv, calls) e1 diff --git a/src/urweb.grm b/src/urweb.grm index 5241ed20..8a3bee7f 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -197,7 +197,7 @@ fun tagIn bt = | DATATYPE | OF | TYPE | NAME | ARROW | LARROW | DARROW | STAR | SEMI - | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE + | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE @@ -348,7 +348,7 @@ fun tagIn bt = %right CAND %nonassoc EQ NE LT LE GT GE IS %right ARROW -%right PLUSPLUS MINUSMINUS +%right PLUSPLUS MINUSMINUS MINUSMINUSMINUS %left PLUS MINUS %left STAR DIVIDE MOD %left NOT @@ -692,6 +692,7 @@ eexp : eapps (eapps) end) | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright)) | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright)) + | eexp MINUSMINUSMINUS cexp (ECutMulti (eexp, cexp), s (eexpleft, cexpright)) | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright)) | IF eexp THEN eexp ELSE eexp (let val loc = s (IFleft, eexp3right) diff --git a/src/urweb.lex b/src/urweb.lex index 642282ec..aef68ad1 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -251,6 +251,7 @@ notags = [^<{\n]+; "=>" => (Tokens.DARROW (pos yypos, pos yypos + size yytext)); "++" => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext)); "--" => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext)); + "---" => (Tokens.MINUSMINUSMINUS (pos yypos, pos yypos + size yytext)); "=" => (Tokens.EQ (pos yypos, pos yypos + size yytext)); "<>" => (Tokens.NE (pos yypos, pos yypos + size yytext)); diff --git a/tests/cut.ur b/tests/cut.ur index 6b7b4ef3..7d0ee77a 100644 --- a/tests/cut.ur +++ b/tests/cut.ur @@ -1,6 +1,7 @@ val r = {A = 1, B = "Hi", C = 0.0} val rA = r -- #A +val rB = r --- [A = _, C = _] -val main : unit -> page = fn () => - {cdata rA.B} - +fun main () : transaction page = return + {cdata rA.B}, {cdata rB.B} + diff --git a/tests/cut.urp b/tests/cut.urp new file mode 100644 index 00000000..5c9c3e81 --- /dev/null +++ b/tests/cut.urp @@ -0,0 +1,3 @@ +debug + +cut -- cgit v1.2.3 From 6da109f29357054c27022d363819edd5da94206c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 10:02:04 -0500 Subject: Finish documenting queries; remove a stray [unit] argument --- doc/manual.tex | 122 +++++++++++++++++++++++++++++++++++++++++++++++++++----- lib/basis.urs | 2 +- src/monoize.sml | 3 +- src/urweb.grm | 3 +- 4 files changed, 116 insertions(+), 14 deletions(-) (limited to 'src/monoize.sml') diff --git a/doc/manual.tex b/doc/manual.tex index 0a0bdc88..fb6b3b01 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -922,7 +922,6 @@ The built-in parts of the Ur/Web standard library are described by the signature Additionally, other common functions that are definable within Ur are included in \texttt{lib/top.urs} and \texttt{lib/top.ur}. This $\mt{Top}$ module is also opened implicitly. The idea behind Ur is to serve as the ideal host for embedded domain-specific languages. For now, however, the ``generic'' functionality is intermixed with Ur/Web-specific functionality, including in these two library modules. We hope that these generic library components have types that speak for themselves. The next section introduces the Ur/Web-specific elements. Here, we only give the type declarations from the beginning of $\mt{Basis}$. - $$\begin{array}{l} \mt{type} \; \mt{int} \\ \mt{type} \; \mt{float} \\ @@ -942,7 +941,6 @@ $$\begin{array}{l} \subsection{Transactions} Ur is a pure language; we use Haskell's trick to support controlled side effects. The standard library defines a monad $\mt{transaction}$, meant to stand for actions that may be undone cleanly. By design, no other kinds of actions are supported. - $$\begin{array}{l} \mt{con} \; \mt{transaction} :: \mt{Type} \to \mt{Type} \\ \\ @@ -953,7 +951,6 @@ $$\begin{array}{l} \subsection{HTTP} There are transactions for reading an HTTP header by name and for getting and setting strongly-typed cookies. Cookies may only be created by the $\mt{cookie}$ declaration form, ensuring that they be named consistently based on module structure. - $$\begin{array}{l} \mt{val} \; \mt{requestHeader} : \mt{string} \to \mt{transaction} \; (\mt{option} \; \mt{string}) \\ \\ @@ -965,7 +962,6 @@ $$\begin{array}{l} \subsection{SQL} The fundamental unit of interest in the embedding of SQL is tables, described by a type family and creatable only via the $\mt{table}$ declaration form. - $$\begin{array}{l} \mt{con} \; \mt{sql\_table} :: \{\mt{Type}\} \to \mt{Type} \end{array}$$ @@ -973,7 +969,6 @@ $$\begin{array}{l} \subsubsection{Queries} A final query is constructed via the $\mt{sql\_query}$ function. Constructor arguments respectively specify the table fields we select (as records mapping tables to the subsets of their fields that we choose) and the (always named) extra expressions that we select. - $$\begin{array}{l} \mt{con} \; \mt{sql\_query} :: \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \\ \mt{val} \; \mt{sql\_query} : \mt{tables} ::: \{\{\mt{Type}\}\} \\ @@ -987,7 +982,6 @@ $$\begin{array}{l} \end{array}$$ Most of the complexity of the query encoding is in the type $\mt{sql\_query1}$, which includes simple queries and derived queries based on relational operators. Constructor arguments respectively specify the tables we select from, the subset of fields that we keep from each table for the result rows, and the extra expressions that we select. - $$\begin{array}{l} \mt{con} \; \mt{sql\_query1} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \\ \\ @@ -1020,7 +1014,6 @@ $$\begin{array}{l} \end{array}$$ To encode projection of subsets of fields in $\mt{SELECT}$ clauses, and to encode $\mt{GROUP} \; \mt{BY}$ clauses, we rely on a type family $\mt{sql\_subset}$, capturing what it means for one record of table fields to be a subset of another. The main constructor $\mt{sql\_subset}$ ``proves subset facts'' by requiring a split of a record into kept and dropped parts. The extra constructor $\mt{sql\_subset\_all}$ is a convenience for keeping all fields of a record. - $$\begin{array}{l} \mt{con} \; \mt{sql\_subset} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \mt{Type} \\ \mt{val} \; \mt{sql\_subset} : \mt{keep\_drop} :: \{(\{\mt{Type}\} \times \{\mt{Type}\})\} \\ @@ -1032,13 +1025,11 @@ $$\begin{array}{l} \end{array}$$ SQL expressions are used in several places, including $\mt{SELECT}$, $\mt{WHERE}$, $\mt{HAVING}$, and $\mt{ORDER} \; \mt{BY}$ clauses. They reify a fragment of the standard SQL expression language, while making it possible to inject ``native'' Ur values in some places. The arguments to the $\mt{sql\_exp}$ type family respectively give the unrestricted-availablity table fields, the table fields that may only be used in arguments to aggregate functions, the available selected expressions, and the type of the expression. - $$\begin{array}{l} \mt{con} \; \mt{sql\_exp} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \to \mt{Type} \end{array}$$ Any field in scope may be converted to an expression. - $$\begin{array}{l} \mt{val} \; \mt{sql\_field} : \mt{otherTabs} ::: \{\{\mt{Type}\}\} \to \mt{otherFields} ::: \{\mt{Type}\} \\ \hspace{.1in} \to \mt{fieldType} ::: \mt{Type} \to \mt{agg} ::: \{\{\mt{Type}\}\} \\ @@ -1047,4 +1038,117 @@ $$\begin{array}{l} \hspace{.1in} \to \mt{sql\_exp} \; ([\mt{tab} = [\mt{field} = \mt{fieldType}] \rc \mt{otherFields}] \rc \mt{otherTabs}) \; \mt{agg} \; \mt{exps} \; \mt{fieldType} \end{array}$$ +There is an analogous function for referencing named expressions. +$$\begin{array}{l} + \mt{val} \; \mt{sql\_exp} : \mt{tabs} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{t} ::: \mt{Type} \to \mt{rest} ::: \{\mt{Type}\} \to \mt{nm} :: \mt{Name} \\ + \hspace{.1in} \to \mt{sql\_exp} \; \mt{tabs} \; \mt{agg} \; ([\mt{nm} = \mt{t}] \rc \mt{rest}) \; \mt{t} +\end{array}$$ + +Ur values of appropriate types may be injected into SQL expressions. +$$\begin{array}{l} + \mt{class} \; \mt{sql\_injectable} \\ + \mt{val} \; \mt{sql\_bool} : \mt{sql\_injectable} \; \mt{bool} \\ + \mt{val} \; \mt{sql\_int} : \mt{sql\_injectable} \; \mt{int} \\ + \mt{val} \; \mt{sql\_float} : \mt{sql\_injectable} \; \mt{float} \\ + \mt{val} \; \mt{sql\_string} : \mt{sql\_injectable} \; \mt{string} \\ + \mt{val} \; \mt{sql\_time} : \mt{sql\_injectable} \; \mt{time} \\ + \mt{val} \; \mt{sql\_option\_bool} : \mt{sql\_injectable} \; (\mt{option} \; \mt{bool}) \\ + \mt{val} \; \mt{sql\_option\_int} : \mt{sql\_injectable} \; (\mt{option} \; \mt{int}) \\ + \mt{val} \; \mt{sql\_option\_float} : \mt{sql\_injectable} \; (\mt{option} \; \mt{float}) \\ + \mt{val} \; \mt{sql\_option\_string} : \mt{sql\_injectable} \; (\mt{option} \; \mt{string}) \\ + \mt{val} \; \mt{sql\_option\_time} : \mt{sql\_injectable} \; (\mt{option} \; \mt{time}) \\ + \mt{val} \; \mt{sql\_inject} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \to \mt{sql\_injectable} \; \mt{t} \\ + \hspace{.1in} \to \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} +\end{array}$$ + +We have the SQL nullness test, which is necessary because of the strange SQL semantics of equality in the presence of null values. +$$\begin{array}{l} + \mt{val} \; \mt{sql\_is\_null} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\ + \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; (\mt{option} \; \mt{t}) \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{bool} +\end{array}$$ + +We have generic nullary, unary, and binary operators, as well as comparison operators. +$$\begin{array}{l} + \mt{con} \; \mt{sql\_nfunc} :: \mt{Type} \to \mt{Type} \\ + \mt{val} \; \mt{sql\_current\_timestamp} : \mt{sql\_nfunc} \; \mt{time} \\ + \mt{val} \; \mt{sql\_nfunc} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\ + \hspace{.1in} \to \mt{sql\_nfunc} \; \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\\end{array}$$ + +$$\begin{array}{l} + \mt{con} \; \mt{sql\_unary} :: \mt{Type} \to \mt{Type} \to \mt{Type} \\ + \mt{val} \; \mt{sql\_not} : \mt{sql\_unary} \; \mt{bool} \; \mt{bool} \\ + \mt{val} \; \mt{sql\_unary} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{arg} ::: \mt{Type} \to \mt{res} ::: \mt{Type} \\ + \hspace{.1in} \to \mt{sql\_unary} \; \mt{arg} \; \mt{res} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{arg} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{res} \\ +\end{array}$$ + +$$\begin{array}{l} + \mt{con} \; \mt{sql\_binary} :: \mt{Type} \to \mt{Type} \to \mt{Type} \to \mt{Type} \\ + \mt{val} \; \mt{sql\_and} : \mt{sql\_binary} \; \mt{bool} \; \mt{bool} \; \mt{bool} \\ + \mt{val} \; \mt{sql\_or} : \mt{sql\_binary} \; \mt{bool} \; \mt{bool} \; \mt{bool} \\ + \mt{val} \; \mt{sql\_binary} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{arg_1} ::: \mt{Type} \to \mt{arg_2} ::: \mt{Type} \to \mt{res} ::: \mt{Type} \\ + \hspace{.1in} \to \mt{sql\_binary} \; \mt{arg_1} \; \mt{arg_2} \; \mt{res} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{arg_1} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{arg_2} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{res} +\end{array}$$ + +$$\begin{array}{l} + \mt{type} \; \mt{sql\_comparison} \\ + \mt{val} \; \mt{sql\_eq} : \mt{sql\_comparison} \\ + \mt{val} \; \mt{sql\_ne} : \mt{sql\_comparison} \\ + \mt{val} \; \mt{sql\_lt} : \mt{sql\_comparison} \\ + \mt{val} \; \mt{sql\_le} : \mt{sql\_comparison} \\ + \mt{val} \; \mt{sql\_gt} : \mt{sql\_comparison} \\ + \mt{val} \; \mt{sql\_ge} : \mt{sql\_comparison} \\ + \mt{val} \; \mt{sql\_comparison} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\ + \hspace{.1in} \to \mt{sql\_comparison} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{bool} + \end{array}$$ + +Finally, we have aggregate functions. The $\mt{COUNT(\ast)}$ syntax is handled specially, since it takes no real argument. The other aggregate functions are placed into a general type family, using type classes to restrict usage to properly-typed arguments. The key aspect of the $\mt{sql\_aggregate}$ function's type is the shift of aggregate-function-only fields into unrestricted fields. + +$$\begin{array}{l} + \mt{val} \; \mt{sql\_count} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{int} +\end{array}$$ + +$$\begin{array}{l} + \mt{con} \; \mt{sql\_aggregate} :: \mt{Type} \to \mt{Type} \\ + \mt{val} \; \mt{sql\_aggregate} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\ + \hspace{.1in} \to \mt{sql\_aggregate} \; \mt{t} \to \mt{sql\_exp} \; \mt{agg} \; \mt{agg} \; \mt{exps} \; \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} +\end{array}$$ + +$$\begin{array}{l} + \mt{class} \; \mt{sql\_summable} \\ + \mt{val} \; \mt{sql\_summable\_int} : \mt{sql\_summable} \; \mt{int} \\ + \mt{val} \; \mt{sql\_summable\_float} : \mt{sql\_summable} \; \mt{float} \\ + \mt{val} \; \mt{sql\_avg} : \mt{t} ::: \mt{Type} \to \mt{sql\_summable} \; \mt{t} \to \mt{sql\_aggregate} \; \mt{t} \\ + \mt{val} \; \mt{sql\_sum} : \mt{t} ::: \mt{Type} \to \mt{sql\_summable} \mt{t} \to \mt{sql\_aggregate} \; \mt{t} +\end{array}$$ + +$$\begin{array}{l} + \mt{class} \; \mt{sql\_maxable} \\ + \mt{val} \; \mt{sql\_maxable\_int} : \mt{sql\_maxable} \; \mt{int} \\ + \mt{val} \; \mt{sql\_maxable\_float} : \mt{sql\_maxable} \; \mt{float} \\ + \mt{val} \; \mt{sql\_maxable\_string} : \mt{sql\_maxable} \; \mt{string} \\ + \mt{val} \; \mt{sql\_maxable\_time} : \mt{sql\_maxable} \; \mt{time} \\ + \mt{val} \; \mt{sql\_max} : \mt{t} ::: \mt{Type} \to \mt{sql\_maxable} \; \mt{t} \to \mt{sql\_aggregate} \; \mt{t} \\ + \mt{val} \; \mt{sql\_min} : \mt{t} ::: \mt{Type} \to \mt{sql\_maxable} \; \mt{t} \to \mt{sql\_aggregate} \; \mt{t} +\end{array}$$ + +We wrap up the definition of query syntax with the types used in representing $\mt{ORDER} \; \mt{BY}$, $\mt{LIMIT}$, and $\mt{OFFSET}$ clauses. +$$\begin{array}{l} + \mt{type} \; \mt{sql\_direction} \\ + \mt{val} \; \mt{sql\_asc} : \mt{sql\_direction} \\ + \mt{val} \; \mt{sql\_desc} : \mt{sql\_direction} \\ + \\ + \mt{con} \; \mt{sql\_order\_by} :: \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \\ + \mt{val} \; \mt{sql\_order\_by\_Nil} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{exps} :: \{\mt{Type}\} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \\ + \mt{val} \; \mt{sql\_order\_by\_Cons} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\ + \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; [] \; \mt{exps} \; \mt{t} \to \mt{sql\_direction} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \\ + \\ + \mt{type} \; \mt{sql\_limit} \\ + \mt{val} \; \mt{sql\_no\_limit} : \mt{sql\_limit} \\ + \mt{val} \; \mt{sql\_limit} : \mt{int} \to \mt{sql\_limit} \\ + \\ + \mt{type} \; \mt{sql\_offset} \\ + \mt{val} \; \mt{sql\_no\_offset} : \mt{sql\_offset} \\ + \mt{val} \; \mt{sql\_offset} : \mt{int} \to \mt{sql\_offset} +\end{array}$$ + \end{document} \ No newline at end of file diff --git a/lib/basis.urs b/lib/basis.urs index 656c5b91..9681328f 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -232,7 +232,7 @@ val sql_comparison : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> sql_exp tables agg exps bool val sql_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} - -> unit -> sql_exp tables agg exps int + -> sql_exp tables agg exps int con sql_aggregate :: Type -> Type val sql_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} diff --git a/src/monoize.sml b/src/monoize.sml index 28ea5946..cd20e366 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1530,8 +1530,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.EFfi ("Basis", "sql_count"), _), _), _), _), _), - _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "COUNT(*)"), loc)), loc), + _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm) | L.ECApp ( diff --git a/src/urweb.grm b/src/urweb.grm index 8a3bee7f..3d77905e 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1267,8 +1267,7 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In | COUNT LPAREN STAR RPAREN (let val loc = s (COUNTleft, RPARENright) in - (EApp ((EVar (["Basis"], "sql_count", Infer), loc), - (ERecord [], loc)), loc) + (EVar (["Basis"], "sql_count", Infer), loc) end) | sqlagg LPAREN sqlexp RPAREN (let val loc = s (sqlaggleft, RPARENright) -- cgit v1.2.3 From 5108a7e86734b335b65b9efd60a7f2f2797b602b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 9 Dec 2008 14:41:19 -0500 Subject: Add SQL arithmetic operators --- doc/manual.tex | 24 +++++++++++---------- lib/basis.urs | 30 +++++++++++++++----------- lib/top.ur | 2 +- src/monoize.sml | 63 +++++++++++++++++++++++++------------------------------ src/urweb.grm | 29 +++++++++++++------------ tests/sql_ops.ur | 8 +++++++ tests/sql_ops.urp | 6 ++++++ 7 files changed, 89 insertions(+), 73 deletions(-) create mode 100644 tests/sql_ops.ur create mode 100644 tests/sql_ops.urp (limited to 'src/monoize.sml') diff --git a/doc/manual.tex b/doc/manual.tex index 3c97b720..21092735 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1198,7 +1198,7 @@ $$\begin{array}{l} \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; (\mt{option} \; \mt{t}) \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{bool} \end{array}$$ -We have generic nullary, unary, and binary operators, as well as comparison operators. +We have generic nullary, unary, and binary operators. $$\begin{array}{l} \mt{con} \; \mt{sql\_nfunc} :: \mt{Type} \to \mt{Type} \\ \mt{val} \; \mt{sql\_current\_timestamp} : \mt{sql\_nfunc} \; \mt{time} \\ @@ -1221,16 +1221,16 @@ $$\begin{array}{l} \end{array}$$ $$\begin{array}{l} - \mt{type} \; \mt{sql\_comparison} \\ - \mt{val} \; \mt{sql\_eq} : \mt{sql\_comparison} \\ - \mt{val} \; \mt{sql\_ne} : \mt{sql\_comparison} \\ - \mt{val} \; \mt{sql\_lt} : \mt{sql\_comparison} \\ - \mt{val} \; \mt{sql\_le} : \mt{sql\_comparison} \\ - \mt{val} \; \mt{sql\_gt} : \mt{sql\_comparison} \\ - \mt{val} \; \mt{sql\_ge} : \mt{sql\_comparison} \\ - \mt{val} \; \mt{sql\_comparison} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\ - \hspace{.1in} \to \mt{sql\_comparison} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{bool} - \end{array}$$ + \mt{class} \; \mt{sql\_arith} \\ + \mt{val} \; \mt{sql\_int\_arith} : \mt{sql\_arith} \; \mt{int} \\ + \mt{val} \; \mt{sql\_float\_arith} : \mt{sql\_arith} \; \mt{float} \\ + \mt{val} \; \mt{sql\_neg} : \mt{t} ::: \mt{Type} \to \mt{sql\_arith} \; \mt{t} \to \mt{sql\_unary} \; \mt{t} \; \mt{t} \\ + \mt{val} \; \mt{sql\_plus} : \mt{t} ::: \mt{Type} \to \mt{sql\_arith} \; \mt{t} \to \mt{sql\_binary} \; \mt{t} \; \mt{t} \; \mt{t} \\ + \mt{val} \; \mt{sql\_minus} : \mt{t} ::: \mt{Type} \to \mt{sql\_arith} \; \mt{t} \to \mt{sql\_binary} \; \mt{t} \; \mt{t} \; \mt{t} \\ + \mt{val} \; \mt{sql\_times} : \mt{t} ::: \mt{Type} \to \mt{sql\_arith} \; \mt{t} \to \mt{sql\_binary} \; \mt{t} \; \mt{t} \; \mt{t} \\ + \mt{val} \; \mt{sql\_div} : \mt{t} ::: \mt{Type} \to \mt{sql\_arith} \; \mt{t} \to \mt{sql\_binary} \; \mt{t} \; \mt{t} \; \mt{t} \\ + \mt{val} \; \mt{sql\_mod} : \mt{sql\_binary} \; \mt{int} \; \mt{int} \; \mt{int} +\end{array}$$ Finally, we have aggregate functions. The $\mt{COUNT(\ast)}$ syntax is handled specially, since it takes no real argument. The other aggregate functions are placed into a general type family, using type classes to restrict usage to properly-typed arguments. The key aspect of the $\mt{sql\_aggregate}$ function's type is the shift of aggregate-function-only fields into unrestricted fields. @@ -1445,6 +1445,8 @@ $$\begin{array}{rrcll} \textrm{XML pieces} & l &::=& \textrm{text} & \textrm{cdata} \\ &&& \texttt{<}g\texttt{/>} & \textrm{tag with no children} \\ &&& \texttt{<}g\texttt{>}l^*\texttt{} & \textrm{tag with children} \\ + &&& \{e\} & \textrm{computed XML fragment} \\ + &&& \{[e]\} & \textrm{injection of an Ur expression, via the $\mt{Top}.\mt{txt}$ function} \\ \textrm{Tag} & g &::=& h \; (x = v)^* \\ \textrm{Tag head} & h &::=& x & \textrm{tag name} \\ &&& h\{c\} & \textrm{constructor parameter} \\ diff --git a/lib/basis.urs b/lib/basis.urs index 9681328f..eb2a6d29 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -202,6 +202,10 @@ val sql_is_null : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> sql_exp tables agg exps (option t) -> sql_exp tables agg exps bool +class sql_arith +val sql_int_arith : sql_arith int +val sql_float_arith : sql_arith float + con sql_unary :: Type -> Type -> Type val sql_not : sql_unary bool bool val sql_unary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} @@ -209,6 +213,8 @@ val sql_unary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> sql_unary arg res -> sql_exp tables agg exps arg -> sql_exp tables agg exps res +val sql_neg : t ::: Type -> sql_arith t -> sql_unary t t + con sql_binary :: Type -> Type -> Type -> Type val sql_and : sql_binary bool bool bool val sql_or : sql_binary bool bool bool @@ -218,18 +224,18 @@ val sql_binary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> sql_exp tables agg exps arg2 -> sql_exp tables agg exps res -type sql_comparison -val sql_eq : sql_comparison -val sql_ne : sql_comparison -val sql_lt : sql_comparison -val sql_le : sql_comparison -val sql_gt : sql_comparison -val sql_ge : sql_comparison -val sql_comparison : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} - -> t ::: Type - -> sql_comparison - -> sql_exp tables agg exps t -> sql_exp tables agg exps t - -> sql_exp tables agg exps bool +val sql_plus : t ::: Type -> sql_arith t -> sql_binary t t t +val sql_minus : t ::: Type -> sql_arith t -> sql_binary t t t +val sql_times : t ::: Type -> sql_arith t -> sql_binary t t t +val sql_div : t ::: Type -> sql_arith t -> sql_binary t t t +val sql_mod : sql_binary int int int + +val sql_eq : t ::: Type -> sql_binary t t bool +val sql_ne : t ::: Type -> sql_binary t t bool +val sql_lt : t ::: Type -> sql_binary t t bool +val sql_le : t ::: Type -> sql_binary t t bool +val sql_gt : t ::: Type -> sql_binary t t bool +val sql_ge : t ::: Type -> sql_binary t t bool val sql_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> sql_exp tables agg exps int diff --git a/lib/top.ur b/lib/top.ur index 76fe73c1..fd7676a3 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -238,4 +238,4 @@ fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) (e2 : option t) = case e2 of None => (SQL {e1} IS NULL) - | Some _ => sql_comparison sql_eq e1 (@sql_inject inj e2) + | Some _ => sql_binary sql_eq e1 (@sql_inject inj e2) diff --git a/src/monoize.sml b/src/monoize.sml index cd20e366..1880c57d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -165,14 +165,14 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) - | L.CFfi ("Basis", "sql_comparison") => - (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "sql_aggregate"), _), t) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "sql_summable"), _), _) => (L'.TRecord [], loc) | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) => (L'.TRecord [], loc) + | L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) => + (L'.TRecord [], loc) | L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) => (L'.TFfi ("Basis", "string"), loc) @@ -1369,19 +1369,34 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.EFfi ("Basis", "sql_eq") => + | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) => ((L'.EPrim (Prim.String "="), loc), fm) - | L.EFfi ("Basis", "sql_ne") => + | L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) => ((L'.EPrim (Prim.String "<>"), loc), fm) - | L.EFfi ("Basis", "sql_lt") => + | L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) => ((L'.EPrim (Prim.String "<"), loc), fm) - | L.EFfi ("Basis", "sql_le") => + | L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) => ((L'.EPrim (Prim.String "<="), loc), fm) - | L.EFfi ("Basis", "sql_gt") => + | L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) => ((L'.EPrim (Prim.String ">"), loc), fm) - | L.EFfi ("Basis", "sql_ge") => + | L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) => ((L'.EPrim (Prim.String ">="), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "+"), loc)), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "-"), loc)), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "*"), loc)), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "/"), loc)), loc), fm) + | L.EFfi ("Basis", "sql_mod") => + ((L'.EPrim (Prim.String "%"), loc), fm) + | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -1407,6 +1422,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EPrim (Prim.String "-"), loc)), loc), fm) | L.ECApp ( (L.ECApp ( @@ -1440,32 +1458,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm) | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm) - | L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.EFfi ("Basis", "sql_comparison"), _), - _), _), - _), _), - _), _), - _) => - let - val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) - in - ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), - (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), - (L'.EAbs ("e2", s, s, - strcat loc [sc "(", - (L'.ERel 1, loc), - sc " ", - (L'.ERel 2, loc), - sc " ", - (L'.ERel 0, loc), - sc ")"]), loc)), loc)), loc), - fm) - end - | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -1566,6 +1558,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EPrim (Prim.String "SUM"), loc)), loc), fm) + | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm) + | L.EFfi ("Basis", "sql_arith_float") => ((L'.ERecord [], loc), fm) + | L.EFfi ("Basis", "sql_maxable_int") => ((L'.ERecord [], loc), fm) | L.EFfi ("Basis", "sql_maxable_float") => ((L'.ERecord [], loc), fm) | L.EFfi ("Basis", "sql_maxable_string") => ((L'.ERecord [], loc), fm) diff --git a/src/urweb.grm b/src/urweb.grm index 3d77905e..7798b018 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -119,15 +119,6 @@ fun amend_group loc (gi, tabs) = fun sql_inject (v, loc) = (EApp ((EVar (["Basis"], "sql_inject", Infer), loc), (v, loc)), loc) -fun sql_compare (oper, sqlexp1, sqlexp2, loc) = - let - val e = (EVar (["Basis"], "sql_comparison", Infer), loc) - val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) - val e = (EApp (e, sqlexp1), loc) - in - (EApp (e, sqlexp2), loc) - end - fun sql_binary (oper, sqlexp1, sqlexp2, loc) = let val e = (EVar (["Basis"], "sql_binary", Infer), loc) @@ -1239,16 +1230,24 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In | LBRACE eexp RBRACE (eexp) - | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp LE sqlexp (sql_compare ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp GT sqlexp (sql_compare ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) - | sqlexp GE sqlexp (sql_compare ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp EQ sqlexp (sql_binary ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp NE sqlexp (sql_binary ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp LT sqlexp (sql_binary ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp LE sqlexp (sql_binary ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp GT sqlexp (sql_binary ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp GE sqlexp (sql_binary ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + + | sqlexp PLUS sqlexp (sql_binary ("plus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp MINUS sqlexp (sql_binary ("minus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp STAR sqlexp (sql_binary ("times", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp DIVIDE sqlexp (sql_binary ("div", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp MOD sqlexp (sql_binary ("mod", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright))) + | MINUS sqlexp (sql_unary ("neg", sqlexp, s (MINUSleft, sqlexpright))) | sqlexp IS NULL (let val loc = s (sqlexpleft, NULLright) diff --git a/tests/sql_ops.ur b/tests/sql_ops.ur new file mode 100644 index 00000000..34e78775 --- /dev/null +++ b/tests/sql_ops.ur @@ -0,0 +1,8 @@ +table t : { A : int, B : float } + +val q = (SELECT t.A + t.A AS X, t.B * t.B AS Y FROM t) + +fun main () : transaction page = + xml <- queryX q (fn r => {[r.X]}, {[r.Y]}
); + return {xml} + diff --git a/tests/sql_ops.urp b/tests/sql_ops.urp new file mode 100644 index 00000000..90e47b77 --- /dev/null +++ b/tests/sql_ops.urp @@ -0,0 +1,6 @@ +debug +database dbname=sql_ops +sql sql_ops.sql +exe /tmp/webapp + +sql_ops -- cgit v1.2.3 From a2854d6b8db55b9c6e69d16262ea182ab9bd307d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Dec 2008 10:27:58 -0500 Subject: Monad type class seems to be working --- lib/basis.urs | 19 +++++++++++++------ lib/top.ur | 8 ++++---- src/corify.sml | 2 ++ src/elaborate.sml | 10 +++++++++- src/monoize.sml | 6 ++++-- 5 files changed, 32 insertions(+), 13 deletions(-) (limited to 'src/monoize.sml') diff --git a/lib/basis.urs b/lib/basis.urs index eb2a6d29..25923870 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -69,15 +69,22 @@ val read_bool : read bool val read_time : read time -(** * Transactions *) +(** * Monads *) + +class monad :: Type -> Type +val return : m ::: (Type -> Type) -> t ::: Type + -> monad m + -> t -> m t +val bind : m ::: (Type -> Type) -> t1 ::: Type -> t2 ::: Type + -> monad m + -> m t1 -> (t1 -> m t2) + -> m t2 + +(** ** Transactions *) con transaction :: Type -> Type +val transaction_monad : monad transaction -val return : t ::: Type - -> t -> transaction t -val bind : t1 ::: Type -> t2 ::: Type - -> transaction t1 -> (t1 -> transaction t2) - -> transaction t2 (** HTTP operations *) diff --git a/lib/top.ur b/lib/top.ur index fd7676a3..35e8519b 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -30,8 +30,8 @@ fun ex (tf :: (Type -> Type)) (choice :: Type) (body : tf choice) : ex tf = fun compose (t1 ::: Type) (t2 ::: Type) (t3 ::: Type) (f1 : t2 -> t3) (f2 : t1 -> t2) (x : t1) = f1 (f2 x) -fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (sh : show t) (v : t) = - cdata (@show sh v) +fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (_ : show t) (v : t) = + cdata (show v) fun foldUR (tf :: Type) (tr :: {Unit} -> Type) (f : nm :: Name -> rest :: {Unit} @@ -233,9 +233,9 @@ fun eqNullable (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) (SQL ({e1} IS NULL AND {e2} IS NULL) OR {e1} = {e2}) fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) - (t ::: Type) (inj : sql_injectable (option t)) + (t ::: Type) (_ : sql_injectable (option t)) (e1 : sql_exp tables agg exps (option t)) (e2 : option t) = case e2 of None => (SQL {e1} IS NULL) - | Some _ => sql_binary sql_eq e1 (@sql_inject inj e2) + | Some _ => sql_binary sql_eq e1 (sql_inject e2) diff --git a/src/corify.sml b/src/corify.sml index 8bb1a925..2383ee03 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -926,8 +926,10 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = val e = (L.EModProj (m, ms, s), loc) val ef = (L.EModProj (basis, [], "bind"), loc) + val ef = (L.ECApp (ef, (L.CModProj (basis, [], "transaction"), loc)), loc) val ef = (L.ECApp (ef, ran'), loc) val ef = (L.ECApp (ef, ran), loc) + val ef = (L.EApp (ef, (L.EModProj (basis, [], "transaction_monad"), loc)), loc) val ef = (L.EApp (ef, (L.EApp (e, (L.ERel 0, loc)), loc)), loc) val eat = (L.CApp ((L.CModProj (basis, [], "transaction"), loc), diff --git a/src/elaborate.sml b/src/elaborate.sml index 05e08c81..c18cfb49 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3548,7 +3548,15 @@ fun elabFile basis topStr topSgn env file = ("c1", p_con env c1), ("c2", p_con env c2)]; raise Fail "Unresolved constraint in top.ur")) - | TypeClass _ => raise Fail "Unresolved type class constraint in top.ur") gs + | TypeClass (env, c, r, loc) => + let + val c = normClassKey env c + in + case E.resolveClass env c of + SOME e => r := SOME e + | NONE => expError env (Unresolvable (loc, c)) + end) gs + val () = subSgn (env', D.empty) topSgn' topSgn val (env', top_n) = E.pushStrNamed env' "Top" topSgn diff --git a/src/monoize.sml b/src/monoize.sml index 1880c57d..1c4aa81b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -934,7 +934,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.ECApp ((L.EFfi ("Basis", "return"), _), t) => + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _), + (L.EFfi ("Basis", "transaction_monad"), _)) => let val t = monoType env t in @@ -943,7 +944,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("_", (L'.TRecord [], loc), t, (L'.ERel 1, loc)), loc)), loc), fm) end - | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), t1), _), t2) => + | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), + (L.EFfi ("Basis", "transaction_monad"), _)) => let val t1 = monoType env t1 val t2 = monoType env t2 -- cgit v1.2.3 From ed7c55c7d3d47e59b73cda4d1d7663bec6728934 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Dec 2008 11:47:18 -0500 Subject: Creation of sources in server code --- include/urweb.h | 3 ++- lib/basis.urs | 8 ++++++-- src/c/urweb.c | 25 +++++++++++++++++++------ src/mono_reduce.sml | 2 ++ src/monoize.sml | 32 ++++++++++++++++++++++++++------ tests/reactive.ur | 4 ++++ tests/reactive.urp | 3 +++ 7 files changed, 62 insertions(+), 15 deletions(-) create mode 100644 tests/reactive.ur create mode 100644 tests/reactive.urp (limited to 'src/monoize.sml') diff --git a/include/urweb.h b/include/urweb.h index c021c3dd..3d7b967c 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -36,7 +36,8 @@ char *uw_get_optional_input(uw_context, int name); void uw_write(uw_context, const char*); -int uw_Basis_new_client_reactive(uw_context); +int uw_Basis_new_client_source(uw_context, uw_unit); +char *uw_Basis_get_script(uw_context, uw_unit); char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int); char *uw_Basis_htmlifyFloat(uw_context, uw_Basis_float); diff --git a/lib/basis.urs b/lib/basis.urs index 25923870..ffba2b37 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -80,11 +80,15 @@ val bind : m ::: (Type -> Type) -> t1 ::: Type -> t2 ::: Type -> m t1 -> (t1 -> m t2) -> m t2 -(** ** Transactions *) - con transaction :: Type -> Type val transaction_monad : monad transaction +con source :: Type -> Type +val source : t ::: Type -> t -> transaction (source t) + +con signal :: Type -> Type +val signal_monad : monad signal +val signal : t ::: Type -> source t -> signal t (** HTTP operations *) diff --git a/src/c/urweb.c b/src/c/urweb.c index f9b623a4..7a9b3e79 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -32,7 +32,7 @@ struct uw_context { char **inputs; char *script, *script_front, *script_back; - int reactive_count; + int source_count; void *db; @@ -75,7 +75,7 @@ uw_context uw_init(size_t outHeaders_len, size_t script_len, size_t page_len, si ctx->script_front = ctx->script = malloc(script_len); ctx->script_back = ctx->script_front + script_len; - ctx->reactive_count = 0; + ctx->source_count = 0; return ctx; } @@ -105,7 +105,7 @@ void uw_reset_keep_error_message(uw_context ctx) { ctx->heap_front = ctx->heap; ctx->regions = NULL; ctx->cleanup_front = ctx->cleanup; - ctx->reactive_count = 0; + ctx->source_count = 0; } void uw_reset_keep_request(uw_context ctx) { @@ -374,14 +374,27 @@ void uw_write_script(uw_context ctx, uw_Basis_string s) { ctx->script_front += len; } -int uw_Basis_new_client_reactive(uw_context ctx) { +char *uw_Basis_get_script(uw_context ctx, uw_unit u) { + if (ctx->script_front == ctx->script) { + char *r = uw_malloc(ctx, 1); + r[0] = 0; + return r; + } else { + char *r = uw_malloc(ctx, 41 + (ctx->script_front - ctx->script)); + + sprintf(r, "", ctx->script); + return r; + } +} + +int uw_Basis_new_client_source(uw_context ctx, uw_unit u) { size_t len; uw_check_script(ctx, 8 + INTS_MAX); - sprintf(ctx->script_front, "var e%d=0\n%n", ctx->reactive_count, &len); + sprintf(ctx->script_front, "var e%d=0\n%n", ctx->source_count, &len); ctx->script_front += len; - return ctx->reactive_count++; + return ctx->source_count++; } static void uw_check(uw_context ctx, size_t extra) { diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 24e686da..9cf6d8e8 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -54,6 +54,7 @@ fun impure (e, _) = | ESome (_, e) => impure e | EFfi _ => false | EFfiApp ("Basis", "set_cookie", _) => true + | EFfiApp ("Basis", "new_client_source", _) => true | EFfiApp _ => false | EApp ((EFfi _, _), _) => false | EApp _ => true @@ -257,6 +258,7 @@ fun reduce file = | ESome (_, e) => summarize d e | EFfi _ => [] | EFfiApp ("Basis", "set_cookie", _) => [Unsure] + | EFfiApp ("Basis", "new_client_source", _) => [Unsure] | EFfiApp (_, _, es) => List.concat (map (summarize d) es) | EApp ((EFfi _, _), e) => summarize d e | EApp _ => diff --git a/src/monoize.sml b/src/monoize.sml index 1c4aa81b..e23d4f80 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -133,6 +133,8 @@ fun monoType env = | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) + | L.CApp ((L.CFfi ("Basis", "source"), _), t) => + (L'.TFfi ("Basis", "int"), loc) | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => @@ -965,6 +967,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end + | L.ECApp ((L.EFfi ("Basis", "source"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc), + (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERecord [], loc)]), loc)), loc)), + loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let val s = (L'.TFfi ("Basis", "string"), loc) @@ -1769,7 +1782,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to input tag") - fun normal (tag, extra) = + fun normal (tag, extra, extraInner) = let val (tagStart, fm) = tagStart tag val tagStart = case extra of @@ -1779,6 +1792,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun normal () = let val (xml, fm) = monoExp (env, st, fm) xml + val xml = case extraInner of + NONE => xml + | SOME ei => (L'.EStrcat (ei, xml), loc) in ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), (L'.EStrcat (xml, @@ -1802,7 +1818,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end in case tag of - "submit" => normal ("input type=\"submit\"", NONE) + "body" => normal ("body", NONE, + SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + + | "submit" => normal ("input type=\"submit\"", NONE, NONE) | "textbox" => (case targs of @@ -1847,7 +1866,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = NONE => raise Fail "No name for radioGroup" | SOME name => normal ("input", - SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc))) + SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc), + NONE)) | "select" => (case targs of @@ -1867,10 +1887,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to lselect tag")) - | "option" => normal ("option", NONE) + | "option" => normal ("option", NONE, NONE) - | "tabl" => normal ("table", NONE) - | _ => normal (tag, NONE) + | "tabl" => normal ("table", NONE, NONE) + | _ => normal (tag, NONE, NONE) end | L.EApp ((L.ECApp ( diff --git a/tests/reactive.ur b/tests/reactive.ur new file mode 100644 index 00000000..cb49541f --- /dev/null +++ b/tests/reactive.ur @@ -0,0 +1,4 @@ +fun main () : transaction page = + x <- source (); + y <- source (); + return Hi! diff --git a/tests/reactive.urp b/tests/reactive.urp new file mode 100644 index 00000000..88dd4cbc --- /dev/null +++ b/tests/reactive.urp @@ -0,0 +1,3 @@ +debug + +reactive -- cgit v1.2.3 From e478b4d432d65b33613a601f71204fc0c656c3db Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Dec 2008 12:38:11 -0500 Subject: Displayed an alert dialog --- include/urweb.h | 2 ++ lib/basis.urs | 7 ++++++- src/c/urweb.c | 35 +++++++++++++++++++++++++++++++++++ src/cjrize.sml | 2 ++ src/mono.sml | 2 ++ src/mono_opt.sml | 5 +++++ src/mono_print.sml | 3 +++ src/mono_reduce.sml | 2 ++ src/mono_util.sml | 4 ++++ src/monoize.sml | 13 +++++++++++++ tests/alert.ur | 3 +++ tests/alert.urp | 3 +++ 12 files changed, 80 insertions(+), 1 deletion(-) create mode 100644 tests/alert.ur create mode 100644 tests/alert.urp (limited to 'src/monoize.sml') diff --git a/include/urweb.h b/include/urweb.h index 3d7b967c..647f153a 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -94,6 +94,8 @@ uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*); char *uw_Basis_ensqlBool(uw_Basis_bool); +char *uw_Basis_jsifyString(uw_context, uw_Basis_string); + uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_floatToString(uw_context, uw_Basis_float); uw_Basis_string uw_Basis_boolToString(uw_context, uw_Basis_bool); diff --git a/lib/basis.urs b/lib/basis.urs index ffba2b37..ac4c4832 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -100,6 +100,11 @@ val getCookie : t ::: Type -> http_cookie t -> transaction (option t) val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit +(** JavaScript-y gadgets *) + +val alert : string -> transaction unit + + (** SQL *) con sql_table :: {Type} -> Type @@ -403,7 +408,7 @@ val ul : bodyTag [] val hr : bodyTag [] -val a : bodyTag [Link = transaction page] +val a : bodyTag [Link = transaction page, Onclick = transaction unit] val form : ctx ::: {Unit} -> bind ::: {Type} -> fn [[Body] ~ ctx] => diff --git a/src/c/urweb.c b/src/c/urweb.c index 7a9b3e79..64cdb81e 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1056,6 +1056,41 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) { return (char *)&true; } +uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_heap(ctx, strlen(s) * 4 + 2); + + r = s2 = ctx->heap_front; + *s2++ = '"'; + + for (; *s; s++) { + char c = *s; + + switch (c) { + case '"': + strcpy(s2, "\\\""); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\"); + s2 += 2; + break; + default: + if (isprint(c)) + *s2++ = c; + else { + sprintf(s2, "\\%3o", c); + s2 += 4; + } + } + } + + strcpy(s2, "\""); + ctx->heap_front = s2 + 1; + return r; +} + uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) { int len; char *r; diff --git a/src/cjrize.sml b/src/cjrize.sml index 6c34923b..1152b0ef 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -420,6 +420,8 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.EUnurlify (e, t), loc), sm) end + | L.EJavaScript _ => raise Fail "EJavaScript remains" + fun cifyDecl ((d, loc), sm) = case d of L.DDatatype (x, n, xncs) => diff --git a/src/mono.sml b/src/mono.sml index f465d2bd..187b1853 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -96,6 +96,8 @@ datatype exp' = | EUnurlify of exp * typ + | EJavaScript of exp + withtype exp = exp' located diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 6c0e6e21..7f83c003 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,6 +360,11 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] + | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) => + EStrcat ((EPrim (Prim.String "alert("), loc), + (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc), + (EPrim (Prim.String ")"), loc)), loc)) + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index 8d91d048..7b675438 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -275,6 +275,9 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] + | EJavaScript e => box [string "JavaScript(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 9cf6d8e8..040414f3 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -75,6 +75,7 @@ fun impure (e, _) = | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es + | EJavaScript e => impure e val liftExpInExp = Monoize.liftExpInExp @@ -329,6 +330,7 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e + | EJavaScript e => summarize d e fun exp env e = diff --git a/src/mono_util.sml b/src/mono_util.sml index 2b2476e7..18b5c948 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -311,6 +311,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) + | EJavaScript e => + S.map2 (mfe ctx e, + fn e' => + (EJavaScript e', loc)) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index e23d4f80..e92a1c8a 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1744,6 +1744,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = result = (L'.TFfi ("Basis", "string"), loc)}), loc), fm) end + | (L'.TFun _, _) => + let + val s' = " " ^ lowercaseFirst x ^ "='" + in + ((L'.EStrcat (s, + (L'.EStrcat ( + (L'.EPrim (Prim.String s'), loc), + (L'.EStrcat ( + (L'.EJavaScript e, loc), + (L'.EPrim (Prim.String "'"), loc)), loc)), + loc)), loc), + fm) + end | _ => let val fooify = diff --git a/tests/alert.ur b/tests/alert.ur new file mode 100644 index 00000000..7b2eaacf --- /dev/null +++ b/tests/alert.ur @@ -0,0 +1,3 @@ +fun main () : transaction page = return + Click Me! + diff --git a/tests/alert.urp b/tests/alert.urp new file mode 100644 index 00000000..3976e9b0 --- /dev/null +++ b/tests/alert.urp @@ -0,0 +1,3 @@ +debug + +alert -- cgit v1.2.3 From 80be553bea33f3d9cb19f399f64eed36017048a3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 15:46:48 -0500 Subject: Initial support --- lib/basis.urs | 5 +++- src/cjrize.sml | 4 +++- src/jscomp.sml | 66 +++++++++++++++++++++++++++++++++++++++-------------- src/mono.sml | 9 +++++++- src/mono_print.sml | 13 ++++++++--- src/mono_reduce.sml | 7 ++++-- src/mono_util.sml | 16 +++++++++++-- src/monoize.sml | 33 ++++++++++++++++++++++++++- tests/sreturn.ur | 5 ++++ tests/sreturn.urp | 3 +++ 10 files changed, 133 insertions(+), 28 deletions(-) create mode 100644 tests/sreturn.ur create mode 100644 tests/sreturn.urp (limited to 'src/monoize.sml') diff --git a/lib/basis.urs b/lib/basis.urs index ac4c4832..a61bf3ce 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -376,6 +376,9 @@ con form = [Body, Form] con tabl = [Body, Table] con tr = [Body, Tr] +val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> unit + -> tag [Signal = signal (xml ctx use bind)] ctx [] use bind + val head : unit -> tag [] html head [] [] val title : unit -> tag [] head [] [] [] @@ -433,7 +436,7 @@ con select = [Select] val select : formTag string select [] val option : unit -> tag [Value = string, Selected = bool] select [] [] [] -val submit : ctx ::: {Unit} -> use ::: {Type} +val submit : ctx ::: {Unit} -> use ::: {Type} -> fn [[Form] ~ ctx] => unit -> tag [Value = string, Action = $use -> transaction page] diff --git a/src/cjrize.sml b/src/cjrize.sml index 1152b0ef..f3c5e5a7 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -120,6 +120,7 @@ fun cifyTyp x = in ((L'.TOption t, loc), sm) end + | L.TSignal _ => raise Fail "Cjrize: TSignal remains" in cify IM.empty x end @@ -420,7 +421,8 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.EUnurlify (e, t), loc), sm) end - | L.EJavaScript _ => raise Fail "EJavaScript remains" + | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" + | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/jscomp.sml b/src/jscomp.sml index 0dd7882a..b0842c6b 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -69,8 +69,15 @@ fun varDepth (e, _) = | ENextval _ => 0 | EUnurlify _ => 0 | EJavaScript _ => 0 + | ESignalReturn e => varDepth e -fun jsExp inAttr outer = +fun strcat loc es = + case es of + [] => (EPrim (Prim.String ""), loc) + | [x] => x + | x :: es' => (EStrcat (x, strcat loc es'), loc) + +fun jsExp mode outer = let val len = length outer @@ -85,11 +92,7 @@ fun jsExp inAttr outer = PConVar n => str (Int.toString n) | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") - fun strcat es = - case es of - [] => (EPrim (Prim.String ""), loc) - | [x] => x - | x :: es' => (EStrcat (x, strcat es'), loc) + fun isNullable (t, _) = case t of @@ -99,17 +102,19 @@ fun jsExp inAttr outer = fun unsupported s = (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); (str "ERROR", st)) + + val strcat = strcat loc in case #1 e of EPrim (Prim.String s) => (str ("\"" ^ String.translate (fn #"'" => - if inAttr then + if mode = Attribute then "\\047" else "'" | #"<" => - if inAttr then + if mode = Script then "<" else "\\074" @@ -274,7 +279,14 @@ fun jsExp inAttr outer = st) end - | EWrite _ => unsupported "EWrite" + | EWrite e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "document.write(", + e, + str ")"], st) + end | ESeq (e1, e2) => let @@ -301,6 +313,15 @@ fun jsExp inAttr outer = | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" | EJavaScript _ => unsupported "Nested JavaScript" + | ESignalReturn e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [(*str "sreturn(",*) + e(*, + str ")"*)], + st) + end end in jsE @@ -309,14 +330,25 @@ fun jsExp inAttr outer = val decl : state -> decl -> decl * state = U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => - case e of - EJavaScript (EAbs (_, t, _, e), _) => - let - val (e, st) = jsExp true (t :: env) 0 (e, st) - in - (#1 e, st) - end - | _ => (e, st), + let + fun doCode m env e = + let + val len = length env + fun str s = (EPrim (Prim.String s), #2 e) + + val locals = List.tabulate + (varDepth e, + fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) + val (e, st) = jsExp m env 0 (e, st) + in + (#1 (strcat (#2 e) (locals @ [e])), st) + end + in + case e of + EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e + | EJavaScript (m, e) => doCode m env e + | _ => (e, st) + end, decl = fn (_, e, st) => (e, st), bind = fn (env, U.Decl.RelE (_, t)) => t :: env | (env, _) => env} diff --git a/src/mono.sml b/src/mono.sml index 187b1853..c6e0ae8a 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -37,6 +37,7 @@ datatype typ' = | TDatatype of int * (datatype_kind * (string * int * typ option) list) ref | TFfi of string * string | TOption of typ + | TSignal of typ withtype typ = typ' located @@ -55,6 +56,11 @@ datatype pat' = withtype pat = pat' located +datatype javascript_mode = + Attribute + | Script + | File + datatype exp' = EPrim of Prim.t | ERel of int @@ -96,8 +102,9 @@ datatype exp' = | EUnurlify of exp * typ - | EJavaScript of exp + | EJavaScript of javascript_mode * exp + | ESignalReturn of exp withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index 7b675438..89b6c35b 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -65,6 +65,9 @@ fun p_typ' par env (t, _) = | TOption t => box [string "option(", p_typ env t, string ")"] + | TSignal t => box [string "signal(", + p_typ env t, + string ")"] and p_typ env = p_typ' false env @@ -275,9 +278,13 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] - | EJavaScript e => box [string "JavaScript(", - p_exp env e, - string ")"] + | EJavaScript (_, e) => box [string "JavaScript(", + p_exp env e, + string ")"] + + | ESignalReturn e => box [string "Return(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 040414f3..e1da02c9 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -75,7 +75,8 @@ fun impure (e, _) = | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es - | EJavaScript e => impure e + | EJavaScript (_, e) => impure e + | ESignalReturn e => impure e val liftExpInExp = Monoize.liftExpInExp @@ -330,7 +331,8 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e - | EJavaScript e => summarize d e + | EJavaScript (_, e) => summarize d e + | ESignalReturn e => summarize d e fun exp env e = @@ -421,6 +423,7 @@ fun reduce file = fun trySub () = case t of (TFfi ("Basis", "string"), _) => doSub () + | (TSignal _, _) => e | _ => case e' of (ECase _, _) => e diff --git a/src/mono_util.sml b/src/mono_util.sml index ebc30984..553f802e 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -51,6 +51,7 @@ fun compare ((t1, _), (t2, _)) = | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2) | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) | (TOption t1, TOption t2) => compare (t1, t2) + | (TSignal t1, TSignal t2) => compare (t1, t2) | (TFun _, _) => LESS | (_, TFun _) => GREATER @@ -64,6 +65,9 @@ fun compare ((t1, _), (t2, _)) = | (TFfi _, _) => LESS | (_, TFfi _) => GREATER + | (TOption _, _) => LESS + | (_, TOption _) => GREATER + and compareFields ((x1, t1), (x2, t2)) = join (String.compare (x1, x2), fn () => compare (t1, t2)) @@ -96,6 +100,10 @@ fun mapfold fc = S.map2 (mft t, fn t' => (TOption t, loc)) + | TSignal t => + S.map2 (mft t, + fn t' => + (TSignal t, loc)) in mft end @@ -311,10 +319,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) - | EJavaScript e => + | EJavaScript (m, e) => + S.map2 (mfe ctx e, + fn e' => + (EJavaScript (m, e'), loc)) + | ESignalReturn e => S.map2 (mfe ctx e, fn e' => - (EJavaScript e', loc)) + (ESignalReturn e', loc)) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index e92a1c8a..1b7b467d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -135,6 +135,8 @@ fun monoType env = (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) | L.CApp ((L.CFfi ("Basis", "source"), _), t) => (L'.TFfi ("Basis", "int"), loc) + | L.CApp ((L.CFfi ("Basis", "signal"), _), t) => + (L'.TSignal (mt env dtmap t), loc) | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => @@ -978,6 +980,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _), + (L.EFfi ("Basis", "signal_monad"), _)) => + let + val t = monoType env t + in + ((L'.EAbs ("x", t, (L'.TSignal t, loc), + (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let val s = (L'.TFfi ("Basis", "string"), loc) @@ -1752,7 +1764,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EStrcat ( (L'.EPrim (Prim.String s'), loc), (L'.EStrcat ( - (L'.EJavaScript e, loc), + (L'.EJavaScript (L'.Attribute, e), loc), (L'.EPrim (Prim.String "'"), loc)), loc)), loc)), loc), fm) @@ -1833,6 +1845,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) = case tag of "body" => normal ("body", NONE, SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + + | "dyn" => + (case #1 attrs of + (*L'.ERecord [("Signal", (L'.ESignalReturn e, _), _)] => (e, fm) + | L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), + e), _), _)] => (e, fm) *) + + L'.ERecord [("Signal", e, _)] => + ((L'.EStrcat + ((L'.EPrim (Prim.String ""), loc)), loc)), loc), + fm) + | _ => raise Fail "Monoize: Bad dyn attributes") | "submit" => normal ("input type=\"submit\"", NONE, NONE) diff --git a/tests/sreturn.ur b/tests/sreturn.ur new file mode 100644 index 00000000..62db377d --- /dev/null +++ b/tests/sreturn.ur @@ -0,0 +1,5 @@ +fun main () : transaction page = return +

Before

+

Hi!}/>

+

After

+ diff --git a/tests/sreturn.urp b/tests/sreturn.urp new file mode 100644 index 00000000..5591aa5e --- /dev/null +++ b/tests/sreturn.urp @@ -0,0 +1,3 @@ +debug + +sreturn -- cgit v1.2.3 From ec745f90fc97e10948dc32ec4f44aabf5c6908db Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 16:19:26 -0500 Subject: Successfully generated a page element from a signal --- Makefile.in | 3 +++ jslib/urweb.js | 1 + src/c/driver.c | 5 ----- src/cjr.sml | 2 ++ src/cjr_env.sml | 1 + src/cjr_print.sml | 20 ++++++++++++++++++++ src/cjrize.sml | 1 + src/config.sig | 1 + src/config.sml.in | 2 ++ src/jscomp.sml | 18 +++++++++++++----- src/mono.sml | 3 +++ src/mono_env.sml | 1 + src/mono_print.sml | 4 ++++ src/mono_shake.sml | 6 ++++-- src/mono_util.sml | 6 +++++- src/monoize.sml | 4 +++- src/prepare.sml | 1 + 17 files changed, 65 insertions(+), 14 deletions(-) create mode 100644 jslib/urweb.js (limited to 'src/monoize.sml') diff --git a/Makefile.in b/Makefile.in index 57a083bd..ed65ceea 100644 --- a/Makefile.in +++ b/Makefile.in @@ -5,6 +5,7 @@ SITELISP := @SITELISP@ LIB_UR := $(LIB)/ur LIB_C := $(LIB)/c +LIB_JS := $(LIB)/js all: smlnj mlton c @@ -70,6 +71,8 @@ install: cp lib/*.ur $(LIB_UR)/ mkdir -p $(LIB_C) cp clib/*.o $(LIB_C)/ + mkdir -p $(LIB_JS) + cp jslib/*.js $(LIB_JS)/ mkdir -p $(INCLUDE) cp include/*.h $(INCLUDE)/ mkdir -p $(SITELISP) diff --git a/jslib/urweb.js b/jslib/urweb.js new file mode 100644 index 00000000..32912e4c --- /dev/null +++ b/jslib/urweb.js @@ -0,0 +1 @@ +function sreturn(v) { return {v : v} } diff --git a/src/c/driver.c b/src/c/driver.c index a25cd743..34e57a6d 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -193,8 +193,6 @@ static void *worker(void *data) { uw_set_headers(ctx, headers); while (1) { - uw_write(ctx, ""); - if (uw_db_begin(ctx)) { printf("Error running SQL BEGIN\n"); if (retries_left) @@ -211,13 +209,10 @@ static void *worker(void *data) { } uw_write_header(ctx, "HTTP/1.1 200 OK\r\n"); - uw_write_header(ctx, "Content-type: text/html\r\n"); strcpy(path_copy, path); fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { - uw_write(ctx, ""); - if (uw_db_commit(ctx)) { fk = FATAL; diff --git a/src/cjr.sml b/src/cjr.sml index 84aea54e..43a29a6c 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -109,6 +109,8 @@ datatype decl' = | DDatabase of string | DPreparedStatements of (string * int) list + | DJavaScript of string + withtype decl = decl' located type file = decl list * (Core.export_kind * string * int * typ list) list diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 49e86140..9921ee48 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -166,6 +166,7 @@ fun declBinds env (d, loc) = | DSequence _ => env | DDatabase _ => env | DPreparedStatements _ => env + | DJavaScript _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 8c3c3d86..06f9f5ca 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1800,6 +1800,10 @@ fun p_decl env (dAll as (d, _) : decl) = string "}"] + | DJavaScript s => box [string "static char jslib[] = \"", + string (String.toString s), + string "\";"] + datatype 'a search = Found of 'a | NotFound @@ -2048,6 +2052,10 @@ fun p_file env (ds, ps) = newline, string "if (*request == '/') ++request;", newline, + string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", + newline, + string "uw_write(ctx, \"\");", + newline, box [string "{", newline, box (ListUtil.mapi (fn (i, t) => box [p_typ env t, @@ -2070,6 +2078,8 @@ fun p_file env (ds, ps) = inputsVar, string ", uw_unit_v);", newline, + string "uw_write(ctx, \"\");", + newline, string "return;", newline, string "}", @@ -2374,6 +2384,16 @@ fun p_file env (ds, ps) = newline, string "void uw_handle(uw_context ctx, char *request) {", newline, + string "if (!strcmp(request, \"/app.js\")) {", + newline, + box [string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");", + newline, + string "uw_write(ctx, jslib);", + newline, + string "return;", + newline], + string "}", + newline, p_list_sep newline (fn x => x) pds', newline, string "uw_error(ctx, FATAL, \"Unknown page\");", diff --git a/src/cjrize.sml b/src/cjrize.sml index f3c5e5a7..78513ef7 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -528,6 +528,7 @@ fun cifyDecl ((d, loc), sm) = | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm) | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) + | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) fun cjrize ds = let diff --git a/src/config.sig b/src/config.sig index 6075482e..90fb72e7 100644 --- a/src/config.sig +++ b/src/config.sig @@ -6,6 +6,7 @@ signature CONFIG = sig val libUr : string val libC : string + val libJs : string val gccArgs : string end diff --git a/src/config.sml.in b/src/config.sml.in index 9e53986b..c7d231d5 100644 --- a/src/config.sml.in +++ b/src/config.sml.in @@ -9,6 +9,8 @@ val libUr = OS.Path.joinDirFile {dir = lib, file = "ur"} val libC = OS.Path.joinDirFile {dir = lib, file = "c"} +val libJs = OS.Path.joinDirFile {dir = lib, + file = "js"} val gccArgs = "@GCCARGS@" diff --git a/src/jscomp.sml b/src/jscomp.sml index b0842c6b..95c18016 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -285,7 +285,7 @@ fun jsExp mode outer = in (strcat [str "document.write(", e, - str ")"], st) + str ".v)"], st) end | ESeq (e1, e2) => @@ -317,9 +317,9 @@ fun jsExp mode outer = let val (e, st) = jsE inner (e, st) in - (strcat [(*str "sreturn(",*) - e(*, - str ")"*)], + (strcat [str "sreturn(", + e, + str ")"], st) end end @@ -369,8 +369,16 @@ fun process file = {decls = [], script = ""} file + + val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"}) + fun lines acc = + case TextIO.inputLine inf of + NONE => String.concat (rev acc) + | SOME line => lines (line :: acc) + val lines = lines [] in - ds + TextIO.closeIn inf; + (DJavaScript lines, ErrorMsg.dummySpan) :: ds end end diff --git a/src/mono.sml b/src/mono.sml index c6e0ae8a..1a7fde00 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -118,6 +118,9 @@ datatype decl' = | DSequence of string | DDatabase of string + | DJavaScript of string + + withtype decl = decl' located type file = decl list diff --git a/src/mono_env.sml b/src/mono_env.sml index cce4a4c4..248567de 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -110,6 +110,7 @@ fun declBinds env (d, loc) = | DTable _ => env | DSequence _ => env | DDatabase _ => env + | DJavaScript _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index 89b6c35b..e44bb74c 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -379,6 +379,10 @@ fun p_decl env (dAll as (d, _) : decl) = | DDatabase s => box [string "database", space, string s] + | DJavaScript s => box [string "JavaScript(", + string s, + string ")"] + fun p_file env file = let diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 6714718a..34bd98be 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -56,7 +56,8 @@ fun shake file = | ((DExport _, _), acc) => acc | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc - | ((DDatabase _, _), acc) => acc) + | ((DDatabase _, _), acc) => acc + | ((DJavaScript _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -112,7 +113,8 @@ fun shake file = | (DExport _, _) => true | (DTable _, _) => true | (DSequence _, _) => true - | (DDatabase _, _) => true) file + | (DDatabase _, _) => true + | (DJavaScript _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 553f802e..9788a551 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -323,6 +323,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (EJavaScript (m, e'), loc)) + | ESignalReturn e => S.map2 (mfe ctx e, fn e' => @@ -421,6 +422,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | DTable _ => S.return2 dAll | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll + | DJavaScript _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -501,6 +503,7 @@ fun mapfoldB (all as {bind, ...}) = | DTable _ => ctx | DSequence _ => ctx | DDatabase _ => ctx + | DJavaScript _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -548,7 +551,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable _ => count | DSequence _ => count - | DDatabase _ => count) 0 + | DDatabase _ => count + | DJavaScript _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 1b7b467d..a0a0df30 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1844,7 +1844,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in case tag of "body" => normal ("body", NONE, - SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + SOME (L'.EStrcat ((L'.EPrim (Prim.String ""), loc), + (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), + loc)), loc)) | "dyn" => (case #1 attrs of diff --git a/src/prepare.sml b/src/prepare.sml index 708bcade..110f6f9a 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -258,6 +258,7 @@ fun prepDecl (d as (_, loc), sns) = | DSequence _ => (d, sns) | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) + | DJavaScript _ => (d, sns) fun prepare (ds, ps) = let -- cgit v1.2.3 From 0a3abbb2250da6464e91566a1f275829158d3058 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Dec 2008 12:01:00 -0500 Subject: Switch to using dyn() function in JavaScript --- jslib/urweb.js | 6 ++++++ src/monoize.sml | 14 ++++---------- 2 files changed, 10 insertions(+), 10 deletions(-) (limited to 'src/monoize.sml') diff --git a/jslib/urweb.js b/jslib/urweb.js index 32912e4c..b7a1af91 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1 +1,7 @@ function sreturn(v) { return {v : v} } + +function dyn(s) { + var x = document.createElement("span"); + x.innerHTML = s.v; + document.body.appendChild(x); +} diff --git a/src/monoize.sml b/src/monoize.sml index a0a0df30..63d84d8c 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1850,20 +1850,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | "dyn" => (case #1 attrs of - (*L'.ERecord [("Signal", (L'.ESignalReturn e, _), _)] => (e, fm) - | L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), + (*L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), e), _), _)] => (e, fm) *) L'.ERecord [("Signal", e, _)] => ((L'.EStrcat - ((L'.EPrim (Prim.String ""), loc)), loc)), loc), + ((L'.EPrim (Prim.String ""), loc)), loc)), loc), fm) | _ => raise Fail "Monoize: Bad dyn attributes") -- cgit v1.2.3 From d5c3faacb1c3114fe6802973a62528cda8be8ac7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Dec 2008 12:30:57 -0500 Subject: Handling singnal bind --- jslib/urweb.js | 3 +- src/cjrize.sml | 1 + src/compiler.sig | 3 +- src/compiler.sml | 8 +++-- src/jscomp.sml | 90 +++++++++++++++++++++++++++++++++++++++-------------- src/mono.sml | 1 + src/mono_opt.sml | 3 ++ src/mono_print.sml | 6 ++++ src/mono_reduce.sml | 5 +++ src/mono_util.sml | 6 ++++ src/monoize.sml | 18 +++++++++-- tests/sbind.ur | 5 +++ tests/sbind.urp | 3 ++ 13 files changed, 122 insertions(+), 30 deletions(-) create mode 100644 tests/sbind.ur create mode 100644 tests/sbind.urp (limited to 'src/monoize.sml') diff --git a/jslib/urweb.js b/jslib/urweb.js index b7a1af91..f552b26b 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1,4 +1,5 @@ -function sreturn(v) { return {v : v} } +function sr(v) { return {v : v} } +function sb(x,y) { return {v : y(x.v).v} } function dyn(s) { var x = document.createElement("span"); diff --git a/src/cjrize.sml b/src/cjrize.sml index 78513ef7..a46c725e 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -423,6 +423,7 @@ fun cifyExp (eAll as (e, loc), sm) = | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" + | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/compiler.sig b/src/compiler.sig index 1f1f4973..c156b268 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -102,8 +102,9 @@ signature COMPILER = sig val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform - val toJscomp : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform + val toJscomp : (string, Mono.file) transform + val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform val toMono_shake2 : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index ecee1065..6d499283 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -511,21 +511,23 @@ val mono_shake = { val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce +val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake + val jscomp = { func = JsComp.process, print = MonoPrint.p_file MonoEnv.empty } -val toJscomp = transform jscomp "jscomp" o toMono_reduce +val toJscomp = transform jscomp "jscomp" o toMono_opt2 -val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp +val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp val fuse = { func = Fuse.fuse, print = MonoPrint.p_file MonoEnv.empty } -val toFuse = transform fuse "fuse" o toMono_opt2 +val toFuse = transform fuse "fuse" o toMono_opt3 val toUntangle2 = transform untangle "untangle2" o toFuse diff --git a/src/jscomp.sml b/src/jscomp.sml index 95c18016..c38056e8 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -33,6 +33,20 @@ structure EM = ErrorMsg structure E = MonoEnv structure U = MonoUtil +val funcs = [(("Basis", "alert"), "alert"), + (("Basis", "htmlifyString"), "escape")] + +structure FM = BinaryMapFn(struct + type ord_key = string * string + fun compare ((m1, x1), (m2, x2)) = + Order.join (String.compare (m1, m2), + fn () => String.compare (x1, x2)) + end) + +val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs + +fun ffi k = FM.find (funcs, k) + type state = { decls : decl list, script : string @@ -70,6 +84,7 @@ fun varDepth (e, _) = | EUnurlify _ => 0 | EJavaScript _ => 0 | ESignalReturn e => varDepth e + | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) fun strcat loc es = case es of @@ -150,33 +165,50 @@ fun jsExp mode outer = e, st) end - | EFfi (_, s) => (str s, st) - | EFfiApp (_, s, []) => (str (s ^ "()"), st) - | EFfiApp (_, s, [e]) => + | EFfi k => let - val (e, st) = jsE inner (e, st) - + val name = case ffi k of + NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript"; + "ERROR") + | SOME s => s in - (strcat [str (s ^ "("), - e, - str ")"], st) + (str name, st) end - | EFfiApp (_, s, e :: es) => + | EFfiApp (m, x, args) => let - val (e, st) = jsE inner (e, st) - val (es, st) = ListUtil.foldlMapConcat - (fn (e, st) => - let - val (e, st) = jsE inner (e, st) - in - ([str ",", e], st) - end) - st es + val name = case ffi (m, x) of + NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript"; + "ERROR") + | SOME s => s in - (strcat (str (s ^ "(") - :: e - :: es - @ [str ")"]), st) + case args of + [] => (str (name ^ "()"), st) + | [e] => + let + val (e, st) = jsE inner (e, st) + + in + (strcat [str (name ^ "("), + e, + str ")"], st) + end + | e :: es => + let + val (e, st) = jsE inner (e, st) + val (es, st) = ListUtil.foldlMapConcat + (fn (e, st) => + let + val (e, st) = jsE inner (e, st) + in + ([str ",", e], st) + end) + st es + in + (strcat (str (name ^ "(") + :: e + :: es + @ [str ")"]), st) + end end | EApp (e1, e2) => @@ -317,11 +349,23 @@ fun jsExp mode outer = let val (e, st) = jsE inner (e, st) in - (strcat [str "sreturn(", + (strcat [str "sr(", e, str ")"], st) end + | ESignalBind (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "sb(", + e1, + str ",", + e2, + str ")"], + st) + end end in jsE diff --git a/src/mono.sml b/src/mono.sml index 1a7fde00..54b77550 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -105,6 +105,7 @@ datatype exp' = | EJavaScript of javascript_mode * exp | ESignalReturn of exp + | ESignalBind of exp * exp withtype exp = exp' located diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 6c0e6e21..550a055c 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,6 +360,9 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] + | ESignalBind ((ESignalReturn e1, loc), e2) => + optExp (EApp (e2, e1), loc) + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index e44bb74c..608fe269 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -285,6 +285,12 @@ fun p_exp' par env (e, _) = | ESignalReturn e => box [string "Return(", p_exp env e, string ")"] + | ESignalBind (e1, e2) => box [string "Return(", + p_exp env e1, + string ",", + space, + p_exp env e2, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index e1da02c9..841e034e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -77,6 +77,7 @@ fun impure (e, _) = | EClosure (_, es) => List.exists impure es | EJavaScript (_, e) => impure e | ESignalReturn e => impure e + | ESignalBind (e1, e2) => impure e1 orelse impure e2 val liftExpInExp = Monoize.liftExpInExp @@ -333,6 +334,7 @@ fun reduce file = | EUnurlify (e, _) => summarize d e | EJavaScript (_, e) => summarize d e | ESignalReturn e => summarize d e + | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 fun exp env e = @@ -478,6 +480,9 @@ fun reduce file = | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => EPrim (Prim.String (s1 ^ s2)) + | ESignalBind ((ESignalReturn e1, loc), e2) => + #1 (reduceExp env (EApp (e2, e1), loc)) + | _ => e in (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) diff --git a/src/mono_util.sml b/src/mono_util.sml index 9788a551..a85443d7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -328,6 +328,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ESignalReturn e', loc)) + | ESignalBind (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESignalBind (e1', e2'), loc))) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index 63d84d8c..30bd5daa 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -957,8 +957,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val mt1 = (L'.TFun (un, t1), loc) val mt2 = (L'.TFun (un, t2), loc) in - ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, (L'.TFun (un, un), loc)), loc)), loc), - (L'.EAbs ("m2", mt2, (L'.TFun (un, un), loc), + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc), (L'.ERecord [], loc)), loc), @@ -989,6 +989,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc), fm) end + | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), + (L.EFfi ("Basis", "signal_monad"), _)) => + let + val t1 = monoType env t1 + val t2 = monoType env t2 + val un = (L'.TRecord [], loc) + val mt1 = (L'.TSignal t1, loc) + val mt2 = (L'.TSignal t2, loc) + in + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2, + (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let diff --git a/tests/sbind.ur b/tests/sbind.ur new file mode 100644 index 00000000..6e3ca782 --- /dev/null +++ b/tests/sbind.ur @@ -0,0 +1,5 @@ +fun main () : transaction page = return +

Before

+

{[s]}}/>

+

After

+ diff --git a/tests/sbind.urp b/tests/sbind.urp new file mode 100644 index 00000000..d8735c70 --- /dev/null +++ b/tests/sbind.urp @@ -0,0 +1,3 @@ +debug + +sbind -- cgit v1.2.3 From f60bcb83cf4d8e0a6176a1dca6e557c49e9f9375 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Dec 2008 12:56:39 -0500 Subject: Trivial use of a source --- jslib/urweb.js | 3 ++ src/c/urweb.c | 111 ++++++++++++++++++++++++++++++++++------------------ src/cjrize.sml | 1 + src/jscomp.sml | 17 ++++++-- src/mono.sml | 1 + src/mono_print.sml | 5 ++- src/mono_reduce.sml | 3 +- src/mono_util.sml | 4 ++ src/monoize.sml | 10 ++++- tests/reactive.ur | 7 ++-- 10 files changed, 116 insertions(+), 46 deletions(-) (limited to 'src/monoize.sml') diff --git a/jslib/urweb.js b/jslib/urweb.js index f552b26b..eab67626 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1,3 +1,6 @@ +function sc(v) { return {v : v} } + +function ss(s) { return {v : s.v} } function sr(v) { return {v : v} } function sb(x,y) { return {v : y(x.v).v} } diff --git a/src/c/urweb.c b/src/c/urweb.c index 64cdb81e..11b99f4c 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -387,12 +387,84 @@ char *uw_Basis_get_script(uw_context ctx, uw_unit u) { } } -int uw_Basis_new_client_source(uw_context ctx, uw_unit u) { +uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_heap(ctx, strlen(s) * 4 + 2); + + r = s2 = ctx->heap_front; + *s2++ = '"'; + + for (; *s; s++) { + char c = *s; + + switch (c) { + case '"': + strcpy(s2, "\\\""); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\"); + s2 += 2; + break; + default: + if (isprint(c)) + *s2++ = c; + else { + sprintf(s2, "\\%3o", c); + s2 += 4; + } + } + } + + strcpy(s2, "\""); + ctx->heap_front = s2 + 1; + return r; +} + +uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_script(ctx, strlen(s) * 4 + 2); + + r = s2 = ctx->script_front; + *s2++ = '"'; + + for (; *s; s++) { + char c = *s; + + switch (c) { + case '"': + strcpy(s2, "\\\""); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\"); + s2 += 2; + break; + default: + if (isprint(c)) + *s2++ = c; + else { + sprintf(s2, "\\%3o", c); + s2 += 4; + } + } + } + + strcpy(s2, "\""); + ctx->script_front = s2 + 1; + return r; +} + +int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) { size_t len; uw_check_script(ctx, 8 + INTS_MAX); - sprintf(ctx->script_front, "var e%d=0\n%n", ctx->source_count, &len); + sprintf(ctx->script_front, "var s%d=sc(%n", ctx->source_count, &len); ctx->script_front += len; + uw_Basis_jsifyString_ws(ctx, s); + uw_write_script(ctx, ");"); return ctx->source_count++; } @@ -1056,41 +1128,6 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) { return (char *)&true; } -uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { - char *r, *s2; - - uw_check_heap(ctx, strlen(s) * 4 + 2); - - r = s2 = ctx->heap_front; - *s2++ = '"'; - - for (; *s; s++) { - char c = *s; - - switch (c) { - case '"': - strcpy(s2, "\\\""); - s2 += 2; - break; - case '\\': - strcpy(s2, "\\\\"); - s2 += 2; - break; - default: - if (isprint(c)) - *s2++ = c; - else { - sprintf(s2, "\\%3o", c); - s2 += 4; - } - } - } - - strcpy(s2, "\""); - ctx->heap_front = s2 + 1; - return r; -} - uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) { int len; char *r; diff --git a/src/cjrize.sml b/src/cjrize.sml index a46c725e..a9c51826 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -424,6 +424,7 @@ fun cifyExp (eAll as (e, loc), sm) = | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" + | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains" fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/jscomp.sml b/src/jscomp.sml index c38056e8..f7ef6927 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -34,7 +34,8 @@ structure E = MonoEnv structure U = MonoUtil val funcs = [(("Basis", "alert"), "alert"), - (("Basis", "htmlifyString"), "escape")] + (("Basis", "htmlifyString"), "escape"), + (("Basis", "new_client_source"), "sc")] structure FM = BinaryMapFn(struct type ord_key = string * string @@ -85,6 +86,7 @@ fun varDepth (e, _) = | EJavaScript _ => 0 | ESignalReturn e => varDepth e | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) + | ESignalSource e => varDepth e fun strcat loc es = case es of @@ -168,7 +170,7 @@ fun jsExp mode outer = | EFfi k => let val name = case ffi k of - NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript"; + NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k ^ " in JavaScript"); "ERROR") | SOME s => s in @@ -177,7 +179,7 @@ fun jsExp mode outer = | EFfiApp (m, x, args) => let val name = case ffi (m, x) of - NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript"; + NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript"); "ERROR") | SOME s => s in @@ -366,6 +368,15 @@ fun jsExp mode outer = str ")"], st) end + | ESignalSource e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "ss(", + e, + str ")"], + st) + end end in jsE diff --git a/src/mono.sml b/src/mono.sml index 54b77550..ae9a06c7 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -106,6 +106,7 @@ datatype exp' = | ESignalReturn of exp | ESignalBind of exp * exp + | ESignalSource of exp withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index 608fe269..b3c0a568 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -285,12 +285,15 @@ fun p_exp' par env (e, _) = | ESignalReturn e => box [string "Return(", p_exp env e, string ")"] - | ESignalBind (e1, e2) => box [string "Return(", + | ESignalBind (e1, e2) => box [string "Bind(", p_exp env e1, string ",", space, p_exp env e2, string ")"] + | ESignalSource e => box [string "Source(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 841e034e..a6777db5 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -78,6 +78,7 @@ fun impure (e, _) = | EJavaScript (_, e) => impure e | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 + | ESignalSource e => impure e val liftExpInExp = Monoize.liftExpInExp @@ -335,7 +336,7 @@ fun reduce file = | EJavaScript (_, e) => summarize d e | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 - + | ESignalSource e => summarize d e fun exp env e = let diff --git a/src/mono_util.sml b/src/mono_util.sml index a85443d7..b14e3ac9 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -334,6 +334,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e2, fn e2' => (ESignalBind (e1', e2'), loc))) + | ESignalSource e => + S.map2 (mfe ctx e, + fn e' => + (ESignalSource e', loc)) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index 30bd5daa..d3d20e7c 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -975,7 +975,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc), - (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERecord [], loc)]), loc)), loc)), + (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERel 1, loc)]), loc)), loc)), loc), fm) end @@ -1003,6 +1003,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "signal"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TSignal t, loc), + (L'.ESignalSource (L'.ERel 0, loc), loc)), loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let diff --git a/tests/reactive.ur b/tests/reactive.ur index cb49541f..95839c7d 100644 --- a/tests/reactive.ur +++ b/tests/reactive.ur @@ -1,4 +1,5 @@ fun main () : transaction page = - x <- source (); - y <- source (); - return Hi! + x <- source TEST; + return + + -- cgit v1.2.3 From 01ae2cbd82a1592d725bc6789c2afb7345b45ff1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2008 09:43:41 -0500 Subject: Starting to implement source set --- lib/basis.urs | 1 + src/monoize.sml | 13 +++++++++++++ 2 files changed, 14 insertions(+) (limited to 'src/monoize.sml') diff --git a/lib/basis.urs b/lib/basis.urs index a61bf3ce..dddc8bde 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -85,6 +85,7 @@ val transaction_monad : monad transaction con source :: Type -> Type val source : t ::: Type -> t -> transaction (source t) +val set : t ::: Type -> source t -> t -> transaction unit con signal :: Type -> Type val signal_monad : monad signal diff --git a/src/monoize.sml b/src/monoize.sml index d3d20e7c..e34ef162 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -979,6 +979,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "set"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("src", (L'.TFfi ("Basis", "int"), loc), + (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc), + (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.EFfiApp ("Basis", "set_client_source", + [(L'.ERel 2, loc), (L'.ERel 1, loc)]), + loc)), loc)), loc)), loc), + fm) + end | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _), (L.EFfi ("Basis", "signal_monad"), _)) => -- cgit v1.2.3 From 493ec594ea29706c85196d1b616ab28ed3da6797 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2008 10:49:42 -0500 Subject: Setting a source server-side --- include/urweb.h | 4 +++- src/c/urweb.c | 31 +++++++++++++++++++++++++------ src/cjrize.sml | 1 + src/jscomp.sml | 14 +++++++++++++- src/mono.sml | 1 + src/mono_print.sml | 1 + src/mono_reduce.sml | 2 ++ src/mono_util.sml | 5 +++++ src/monoize.sml | 14 ++++++++------ tests/reactive2.ur | 6 ++++++ tests/reactive2.urp | 3 +++ 11 files changed, 68 insertions(+), 14 deletions(-) create mode 100644 tests/reactive2.ur create mode 100644 tests/reactive2.urp (limited to 'src/monoize.sml') diff --git a/include/urweb.h b/include/urweb.h index 647f153a..a5bb8dc0 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -36,7 +36,9 @@ char *uw_get_optional_input(uw_context, int name); void uw_write(uw_context, const char*); -int uw_Basis_new_client_source(uw_context, uw_unit); +uw_Basis_int uw_Basis_new_client_source(uw_context, uw_Basis_string); +uw_unit uw_Basis_set_client_source(uw_context, uw_Basis_int, uw_Basis_string); + char *uw_Basis_get_script(uw_context, uw_unit); char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int); diff --git a/src/c/urweb.c b/src/c/urweb.c index 11b99f4c..2c6d493a 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -363,6 +363,7 @@ static void uw_check_script(uw_context ctx, size_t extra) { ctx->script_front = new_script + (ctx->script_front - ctx->script); ctx->script_back = new_script + next; ctx->script = new_script; + printf("new_script = %p\n", new_script); } } @@ -434,7 +435,7 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) { char c = *s; switch (c) { - case '"': + case '\'': strcpy(s2, "\\\""); s2 += 2; break; @@ -457,18 +458,36 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) { return r; } -int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) { - size_t len; +uw_Basis_int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) { + int len; + size_t s_len = strlen(s); - uw_check_script(ctx, 8 + INTS_MAX); + uw_check_script(ctx, 12 + INTS_MAX + s_len); sprintf(ctx->script_front, "var s%d=sc(%n", ctx->source_count, &len); ctx->script_front += len; - uw_Basis_jsifyString_ws(ctx, s); - uw_write_script(ctx, ");"); + strcpy(ctx->script_front, s); + ctx->script_front += s_len; + strcpy(ctx->script_front, ");"); + ctx->script_front += 2; return ctx->source_count++; } +uw_unit uw_Basis_set_client_source(uw_context ctx, uw_Basis_int n, uw_Basis_string s) { + int len; + size_t s_len = strlen(s); + + uw_check_script(ctx, 6 + INTS_MAX + s_len); + sprintf(ctx->script_front, "s%d.v=%n", (int)n, &len); + ctx->script_front += len; + strcpy(ctx->script_front, s); + ctx->script_front += s_len; + strcpy(ctx->script_front, ";"); + ctx->script_front++; + + return uw_unit_v; +} + static void uw_check(uw_context ctx, size_t extra) { size_t desired = ctx->page_front - ctx->page + extra, next; char *new_page; diff --git a/src/cjrize.sml b/src/cjrize.sml index a9c51826..6d0ece61 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -120,6 +120,7 @@ fun cifyTyp x = in ((L'.TOption t, loc), sm) end + | L.TSource => ((L'.TFfi ("Basis", "int"), loc), sm) | L.TSignal _ => raise Fail "Cjrize: TSignal remains" in cify IM.empty x diff --git a/src/jscomp.sml b/src/jscomp.sml index f7ef6927..8b874289 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -121,6 +121,13 @@ fun jsExp mode outer = (str "ERROR", st)) val strcat = strcat loc + + fun quoteExp (t : typ) e = + case #1 t of + TSource => strcat [str "s", + (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] + | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; + str "ERROR") in case #1 e of EPrim (Prim.String s) => @@ -130,6 +137,7 @@ fun jsExp mode outer = "\\047" else "'" + | #"\"" => "\\\"" | #"<" => if mode = Script then "<" @@ -143,7 +151,11 @@ fun jsExp mode outer = if n < inner then (str ("uwr" ^ var n), st) else - (str ("uwo" ^ var n), st) + let + val n = n - inner + in + (quoteExp (List.nth (outer, n)) (ERel n, loc), st) + end | ENamed _ => raise Fail "Named" | ECon (_, pc, NONE) => (patCon pc, st) | ECon (_, pc, SOME e) => diff --git a/src/mono.sml b/src/mono.sml index ae9a06c7..41457071 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -37,6 +37,7 @@ datatype typ' = | TDatatype of int * (datatype_kind * (string * int * typ option) list) ref | TFfi of string * string | TOption of typ + | TSource | TSignal of typ withtype typ = typ' located diff --git a/src/mono_print.sml b/src/mono_print.sml index b3c0a568..a876cfac 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -65,6 +65,7 @@ fun p_typ' par env (t, _) = | TOption t => box [string "option(", p_typ env t, string ")"] + | TSource => string "source" | TSignal t => box [string "signal(", p_typ env t, string ")"] diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index a6777db5..072c548e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -55,6 +55,7 @@ fun impure (e, _) = | EFfi _ => false | EFfiApp ("Basis", "set_cookie", _) => true | EFfiApp ("Basis", "new_client_source", _) => true + | EFfiApp ("Basis", "set_client_source", _) => true | EFfiApp _ => false | EApp ((EFfi _, _), _) => false | EApp _ => true @@ -263,6 +264,7 @@ fun reduce file = | EFfi _ => [] | EFfiApp ("Basis", "set_cookie", _) => [Unsure] | EFfiApp ("Basis", "new_client_source", _) => [Unsure] + | EFfiApp ("Basis", "set_client_source", _) => [Unsure] | EFfiApp (_, _, es) => List.concat (map (summarize d) es) | EApp ((EFfi _, _), e) => summarize d e | EApp _ => diff --git a/src/mono_util.sml b/src/mono_util.sml index b14e3ac9..3f9183d0 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -51,6 +51,7 @@ fun compare ((t1, _), (t2, _)) = | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2) | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) | (TOption t1, TOption t2) => compare (t1, t2) + | (TSource, TSource) => EQUAL | (TSignal t1, TSignal t2) => compare (t1, t2) | (TFun _, _) => LESS @@ -68,6 +69,9 @@ fun compare ((t1, _), (t2, _)) = | (TOption _, _) => LESS | (_, TOption _) => GREATER + | (TSource, _) => LESS + | (_, TSource) => GREATER + and compareFields ((x1, t1), (x2, t2)) = join (String.compare (x1, x2), fn () => compare (t1, t2)) @@ -100,6 +104,7 @@ fun mapfold fc = S.map2 (mft t, fn t' => (TOption t, loc)) + | TSource => S.return2 cAll | TSignal t => S.map2 (mft t, fn t' => diff --git a/src/monoize.sml b/src/monoize.sml index e34ef162..f40d49d0 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -134,7 +134,7 @@ fun monoType env = | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) | L.CApp ((L.CFfi ("Basis", "source"), _), t) => - (L'.TFfi ("Basis", "int"), loc) + (L'.TSource, loc) | L.CApp ((L.CFfi ("Basis", "signal"), _), t) => (L'.TSignal (mt env dtmap t), loc) | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => @@ -973,9 +973,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val t = monoType env t in - ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc)), loc), - (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc), - (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERel 1, loc)]), loc)), loc)), + ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc), + (L'.EFfiApp ("Basis", "new_client_source", + [(L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), loc)), loc)), loc), fm) end @@ -983,12 +984,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val t = monoType env t in - ((L'.EAbs ("src", (L'.TFfi ("Basis", "int"), loc), + ((L'.EAbs ("src", (L'.TSource, loc), (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc), (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.EFfiApp ("Basis", "set_client_source", - [(L'.ERel 2, loc), (L'.ERel 1, loc)]), + [(L'.ERel 2, loc), + (L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), loc)), loc)), loc)), loc), fm) end diff --git a/tests/reactive2.ur b/tests/reactive2.ur new file mode 100644 index 00000000..7164468e --- /dev/null +++ b/tests/reactive2.ur @@ -0,0 +1,6 @@ +fun main () : transaction page = + x <- source TEST; + set x HI; + return + + diff --git a/tests/reactive2.urp b/tests/reactive2.urp new file mode 100644 index 00000000..bdc0d1be --- /dev/null +++ b/tests/reactive2.urp @@ -0,0 +1,3 @@ +debug + +reactive2 -- cgit v1.2.3 From 8d3edc5aaa4617dd06623447cf9357067eadc072 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2008 11:33:31 -0500 Subject: Harmonized source-setting between server and client --- src/cjrize.sml | 2 ++ src/jscomp.sml | 15 ++++++++++----- src/mono.sml | 2 +- src/mono_opt.sml | 2 ++ src/mono_print.sml | 13 ++++++++----- src/mono_reduce.sml | 4 ++-- src/mono_util.sml | 10 ++++++++-- src/monoize.sml | 16 ++++++++-------- 8 files changed, 41 insertions(+), 23 deletions(-) (limited to 'src/monoize.sml') diff --git a/src/cjrize.sml b/src/cjrize.sml index 6d0ece61..1a5d10c0 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -422,7 +422,9 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.EUnurlify (e, t), loc), sm) end + | L.EJavaScript (_, _, SOME e) => cifyExp (e, sm) | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" + | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains" diff --git a/src/jscomp.sml b/src/jscomp.sml index 8b874289..a4e3dd35 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -190,6 +190,12 @@ fun jsExp mode outer = end | EFfiApp (m, x, args) => let + val args = + case (m, x, args) of + ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e] + | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2] + | _ => args + val name = case ffi (m, x) of NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript"); "ERROR") @@ -200,7 +206,6 @@ fun jsExp mode outer = | [e] => let val (e, st) = jsE inner (e, st) - in (strcat [str (name ^ "("), e, @@ -398,7 +403,7 @@ val decl : state -> decl -> decl * state = U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => let - fun doCode m env e = + fun doCode m env orig e = let val len = length env fun str s = (EPrim (Prim.String s), #2 e) @@ -408,12 +413,12 @@ val decl : state -> decl -> decl * state = fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) val (e, st) = jsExp m env 0 (e, st) in - (#1 (strcat (#2 e) (locals @ [e])), st) + (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) end in case e of - EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e - | EJavaScript (m, e) => doCode m env e + EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e + | EJavaScript (m, e, _) => doCode m env e e | _ => (e, st) end, decl = fn (_, e, st) => (e, st), diff --git a/src/mono.sml b/src/mono.sml index 41457071..b58396fa 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -103,7 +103,7 @@ datatype exp' = | EUnurlify of exp * typ - | EJavaScript of javascript_mode * exp + | EJavaScript of javascript_mode * exp * exp option | ESignalReturn of exp | ESignalBind of exp * exp diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 550a055c..7f23d8b1 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -363,6 +363,8 @@ fun exp e = | ESignalBind ((ESignalReturn e1, loc), e2) => optExp (EApp (e2, e1), loc) + | EJavaScript (_, _, SOME (e, _)) => e + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index a876cfac..f8a23d1d 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -216,10 +216,12 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] - | ESeq (e1, e2) => box [p_exp env e1, + | ESeq (e1, e2) => box [string "(", + p_exp env e1, string ";", space, - p_exp env e2] + p_exp env e2, + string ")"] | ELet (x, t, e1, e2) => box [string "(let", space, string x, @@ -279,9 +281,10 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] - | EJavaScript (_, e) => box [string "JavaScript(", - p_exp env e, - string ")"] + | EJavaScript (_, e, NONE) => box [string "JavaScript(", + p_exp env e, + string ")"] + | EJavaScript (_, _, SOME e) => p_exp env e | ESignalReturn e => box [string "Return(", p_exp env e, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 072c548e..c96f97cf 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -76,7 +76,7 @@ fun impure (e, _) = | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es - | EJavaScript (_, e) => impure e + | EJavaScript (_, e, _) => impure e | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 | ESignalSource e => impure e @@ -335,7 +335,7 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e - | EJavaScript (_, e) => summarize d e + | EJavaScript (_, e, _) => summarize d e | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e diff --git a/src/mono_util.sml b/src/mono_util.sml index 3f9183d0..9ce3293b 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -324,10 +324,16 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) - | EJavaScript (m, e) => + | EJavaScript (m, e, NONE) => S.map2 (mfe ctx e, fn e' => - (EJavaScript (m, e'), loc)) + (EJavaScript (m, e', NONE), loc)) + | EJavaScript (m, e, SOME e2) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfe ctx e2, + fn e2' => + (EJavaScript (m, e', SOME e2'), loc))) | ESignalReturn e => S.map2 (mfe ctx e, diff --git a/src/monoize.sml b/src/monoize.sml index f40d49d0..f62848c5 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -976,7 +976,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc), (L'.EFfiApp ("Basis", "new_client_source", - [(L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), loc)), loc)), + [(L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]), + loc)), loc)), loc), fm) end @@ -990,7 +991,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.EFfiApp ("Basis", "set_client_source", [(L'.ERel 2, loc), - (L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), + (L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]), loc)), loc)), loc)), loc), fm) end @@ -1801,7 +1802,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EStrcat ( (L'.EPrim (Prim.String s'), loc), (L'.EStrcat ( - (L'.EJavaScript (L'.Attribute, e), loc), + (L'.EJavaScript (L'.Attribute, e, NONE), loc), (L'.EPrim (Prim.String "'"), loc)), loc)), loc)), loc), fm) @@ -1887,13 +1888,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | "dyn" => (case #1 attrs of - (*L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), - e), _), _)] => (e, fm) *) - - L'.ERecord [("Signal", e, _)] => + L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), + e), _), _)] => (e, fm) + | L'.ERecord [("Signal", e, _)] => ((L'.EStrcat ((L'.EPrim (Prim.String ""), loc)), loc)), loc), fm) | _ => raise Fail "Monoize: Bad dyn attributes") -- cgit v1.2.3 From 8bb915433716ecfdcf2c2209d1a62796ebde4714 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 15:11:17 -0500 Subject: Injecting an int --- src/jscomp.sml | 67 +++++++++++++++++++++++++++++++++++++++++---------------- src/mono.sml | 2 +- src/monoize.sml | 5 +++-- tests/jsinj.ur | 14 ++++++++++++ tests/jsinj.urp | 3 +++ 5 files changed, 70 insertions(+), 21 deletions(-) create mode 100644 tests/jsinj.ur create mode 100644 tests/jsinj.urp (limited to 'src/monoize.sml') diff --git a/src/jscomp.sml b/src/jscomp.sml index 67d8d9c1..b27a860b 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -102,6 +102,8 @@ fun strcat loc es = | [x] => x | x :: es' => (EStrcat (x, strcat loc es'), loc) +exception Unsupported of string * EM.span + fun process file = let val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e) @@ -111,13 +113,28 @@ fun process file = | (_, nameds) => nameds) IM.empty file + fun str loc s = (EPrim (Prim.String s), loc) + + fun quoteExp loc (t : typ) e = + case #1 t of + TSource => strcat loc [str loc "s", + (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] + | TRecord [] => str loc "null" + + | TFfi ("Basis", "string") => e + | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc) + + | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; + Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; + str loc "ERROR") + fun jsExp mode skip outer = let val len = length outer fun jsE inner (e as (_, loc), st) = let - fun str s = (EPrim (Prim.String s), loc) + val str = str loc fun var n = Int.toString (len + inner - n - 1) @@ -134,22 +151,10 @@ fun process file = | TRecord [] => true | _ => false - fun unsupported s = - (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); - (str "ERROR", st)) + fun unsupported s = raise Unsupported (s, loc) val strcat = strcat loc - fun quoteExp (t : typ) e = - case #1 t of - TSource => strcat [str "s", - (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] - | TRecord [] => str "null" - | TFfi ("Basis", "string") => e - | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; - Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; - str "ERROR") - fun jsPrim p = case p of Prim.String s => @@ -241,7 +246,11 @@ fun process file = EPrim (Prim.String s) => s | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2 | _ => raise Fail "Jscomp: deStrcat" + + val quoteExp = quoteExp loc in + (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*) + case #1 e of EPrim p => (jsPrim p, st) | ERel n => @@ -513,12 +522,15 @@ fun process file = str ")"], st) end + | EJavaScript (_, _, SOME e) => (e, st) + | EClosure _ => unsupported "EClosure" | EQuery _ => unsupported "Query" | EDml _ => unsupported "DML" | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" - | EJavaScript _ => unsupported "Nested JavaScript" + | EJavaScript (_, e, _) => unsupported "Nested JavaScript" + | ESignalReturn e => let val (e, st) = jsE inner (e, st) @@ -572,9 +584,28 @@ fun process file = end in case e of - EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => - doCode m 1 (t :: env) orig e - | EJavaScript (m, e, _) => doCode m 0 env e e + EJavaScript (m as Source t, orig, _) => + (doCode m 0 env orig orig + handle Unsupported (s, loc) => + let + val e = ELet ("js", t, orig, quoteExp (#2 orig) t + (ERel 0, #2 orig)) + in + (EJavaScript (m, orig, SOME (e, #2 orig)), st) + end) + + | EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => + (doCode m 1 (t :: env) orig e + handle Unsupported (s, loc) => + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); + (EPrim (Prim.String "ERROR"), st))) + + | EJavaScript (m, orig, _) => + (doCode m 0 env orig orig + handle Unsupported (s, loc) => + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); + (EPrim (Prim.String "ERROR"), st))) + | _ => (e, st) end, decl = fn (_, e, st) => (e, st), diff --git a/src/mono.sml b/src/mono.sml index b58396fa..8999704c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -60,7 +60,7 @@ withtype pat = pat' located datatype javascript_mode = Attribute | Script - | File + | Source of typ datatype exp' = EPrim of Prim.t diff --git a/src/monoize.sml b/src/monoize.sml index f62848c5..6c4534ac 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -976,7 +976,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc), (L'.EFfiApp ("Basis", "new_client_source", - [(L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]), + [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc), NONE), loc)]), loc)), loc)), loc), fm) @@ -991,7 +991,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.EFfiApp ("Basis", "set_client_source", [(L'.ERel 2, loc), - (L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]), + (L'.EJavaScript (L'.Source t, + (L'.ERel 1, loc), NONE), loc)]), loc)), loc)), loc)), loc), fm) end diff --git a/tests/jsinj.ur b/tests/jsinj.ur new file mode 100644 index 00000000..194d26be --- /dev/null +++ b/tests/jsinj.ur @@ -0,0 +1,14 @@ +cookie int : int + +fun getOpt (t ::: Type) (o : option t) (v : t) : t = + case o of + None => v + | Some x => x + +fun main () : transaction page = + n <- getCookie int; + sn <- source (getOpt n 7); + return + {[n]}}/> + CHANGE + diff --git a/tests/jsinj.urp b/tests/jsinj.urp new file mode 100644 index 00000000..dc929b9d --- /dev/null +++ b/tests/jsinj.urp @@ -0,0 +1,3 @@ +debug + +jsinj -- cgit v1.2.3 From 40a04276005343f3dbc7d963a425e382a4e20701 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Jan 2009 10:05:06 -0500 Subject: Hooking a source into an input --- jslib/urweb.js | 8 ++ lib/basis.urs | 2 +- src/monoize.sml | 440 +++++++++++++++++++++++++++++--------------------------- tests/rform.ur | 10 ++ tests/rform.urp | 3 + 5 files changed, 252 insertions(+), 211 deletions(-) create mode 100644 tests/rform.ur create mode 100644 tests/rform.urp (limited to 'src/monoize.sml') diff --git a/jslib/urweb.js b/jslib/urweb.js index 9d28b461..0f9c06cf 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -41,6 +41,14 @@ function dyn(s) { s.h = cons(function() { x.innerHTML = s.v }, s.h); } +function inp(t, s) { + var x = document.createElement(t); + x.value = s.v; + document.body.appendChild(x); + s.h = cons(function() { x.value = s.v }, s.h); + x.onkeyup = function() { sv(s, x.value) }; +} + function eh(x) { return x.split("&").join("&").split("<").join("<").split(">").join(">"); } diff --git a/lib/basis.urs b/lib/basis.urs index dddc8bde..9b09e8d2 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -423,7 +423,7 @@ con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) => -> fn [[Form] ~ ctx] => nm :: Name -> unit -> tag attrs ([Form] ++ ctx) inner [] [nm = ty] -val textbox : formTag string [] [Value = string, Size = int] +val textbox : formTag string [] [Value = string, Size = int, Source = source string] val password : formTag string [] [Value = string, Size = int] val textarea : formTag string [] [Rows = int, Cols = int] diff --git a/src/monoize.sml b/src/monoize.sml index 6c4534ac..4a2f47d7 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -510,6 +510,10 @@ fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc fun monoExp (env, st, fm) (all as (e, loc)) = let + val strcat = strcat loc + val strcatComma = strcatComma loc + fun str s = (L'.EPrim (Prim.String s), loc) + fun poly () = (E.errorAt loc "Unsupported expression"; Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; @@ -1080,15 +1084,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc), (L'.EAbs ("fs", rt, s, - strcat loc [sc "INSERT INTO ", - (L'.ERel 1, loc), - sc " (", - strcatComma loc (map (fn (x, _) => sc ("uw_" ^ x)) fields), - sc ") VALUES (", - strcatComma loc (map (fn (x, _) => - (L'.EField ((L'.ERel 0, loc), - x), loc)) fields), - sc ")"]), loc)), loc), + strcat [sc "INSERT INTO ", + (L'.ERel 1, loc), + sc " (", + strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields), + sc ") VALUES (", + strcatComma (map (fn (x, _) => + (L'.EField ((L'.ERel 0, loc), + x), loc)) fields), + sc ")"]), loc)), loc), fm) end | _ => poly ()) @@ -1105,19 +1109,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("tab", s, (L'.TFun (s, s), loc), (L'.EAbs ("e", s, s, - strcat loc [sc "UPDATE ", - (L'.ERel 1, loc), - sc " AS T SET ", - strcatComma loc (map (fn (x, _) => - strcat loc [sc ("uw_" ^ x - ^ " = "), - (L'.EField - ((L'.ERel 2, - loc), - x), loc)]) - changed), - sc " WHERE ", - (L'.ERel 0, loc)]), loc)), loc)), loc), + strcat [sc "UPDATE ", + (L'.ERel 1, loc), + sc " AS T SET ", + strcatComma (map (fn (x, _) => + strcat [sc ("uw_" ^ x + ^ " = "), + (L'.EField + ((L'.ERel 2, + loc), + x), loc)]) + changed), + sc " WHERE ", + (L'.ERel 0, loc)]), loc)), loc)), loc), fm) end | _ => poly ()) @@ -1129,10 +1133,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc), (L'.EAbs ("e", s, s, - strcat loc [sc "DELETE FROM ", - (L'.ERel 1, loc), - sc " AS T WHERE ", - (L'.ERel 0, loc)]), loc)), loc), + strcat [sc "DELETE FROM ", + (L'.ERel 1, loc), + sc " AS T WHERE ", + (L'.ERel 0, loc)]), loc)), loc), fm) end @@ -1198,15 +1202,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("r", (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc), s, - strcat loc [gf "Rows", - (L'.ECase (gf "OrderBy", - [((L'.PPrim (Prim.String ""), loc), sc ""), - ((L'.PWild, loc), - strcat loc [sc " ORDER BY ", - gf "OrderBy"])], - {disc = s, result = s}), loc), - gf "Limit", - gf "Offset"]), loc), fm) + strcat [gf "Rows", + (L'.ECase (gf "OrderBy", + [((L'.PPrim (Prim.String ""), loc), sc ""), + ((L'.PWild, loc), + strcat [sc " ORDER BY ", + gf "OrderBy"])], + {disc = s, result = s}), loc), + gf "Limit", + gf "Offset"]), loc), fm) end | L.ECApp ( @@ -1264,53 +1268,53 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))], loc), s, - strcat loc [sc "SELECT ", - strcatComma loc (map (fn (x, t) => - strcat loc [ - (L'.EField (gf "SelectExps", x), loc), - sc (" AS _" ^ x) - ]) sexps - @ map (fn (x, xts) => - strcatComma loc - (map (fn (x', _) => - sc (x ^ ".uw_" ^ x')) - xts)) stables), - sc " FROM ", - strcatComma loc (map (fn (x, _) => strcat loc [(L'.EField (gf "From", x), loc), - sc (" AS " ^ x)]) tables), - (L'.ECase (gf "Where", - [((L'.PPrim (Prim.String "TRUE"), loc), - sc ""), - ((L'.PWild, loc), - strcat loc [sc " WHERE ", gf "Where"])], - {disc = s, - result = s}), loc), - - if List.all (fn (x, xts) => - case List.find (fn (x', _) => x' = x) grouped of - NONE => List.null xts - | SOME (_, xts') => - List.all (fn (x, _) => - List.exists (fn (x', _) => x' = x) - xts') xts) tables then - sc "" - else - strcat loc [ - sc " GROUP BY ", - strcatComma loc (map (fn (x, xts) => - strcatComma loc - (map (fn (x', _) => - sc (x ^ ".uw_" ^ x')) - xts)) grouped) - ], - - (L'.ECase (gf "Having", - [((L'.PPrim (Prim.String "TRUE"), loc), - sc ""), - ((L'.PWild, loc), - strcat loc [sc " HAVING ", gf "Having"])], - {disc = s, - result = s}), loc) + strcat [sc "SELECT ", + strcatComma (map (fn (x, t) => + strcat [ + (L'.EField (gf "SelectExps", x), loc), + sc (" AS _" ^ x) + ]) sexps + @ map (fn (x, xts) => + strcatComma + (map (fn (x', _) => + sc (x ^ ".uw_" ^ x')) + xts)) stables), + sc " FROM ", + strcatComma (map (fn (x, _) => strcat [(L'.EField (gf "From", x), loc), + sc (" AS " ^ x)]) tables), + (L'.ECase (gf "Where", + [((L'.PPrim (Prim.String "TRUE"), loc), + sc ""), + ((L'.PWild, loc), + strcat [sc " WHERE ", gf "Where"])], + {disc = s, + result = s}), loc), + + if List.all (fn (x, xts) => + case List.find (fn (x', _) => x' = x) grouped of + NONE => List.null xts + | SOME (_, xts') => + List.all (fn (x, _) => + List.exists (fn (x', _) => x' = x) + xts') xts) tables then + sc "" + else + strcat [ + sc " GROUP BY ", + strcatComma (map (fn (x, xts) => + strcatComma + (map (fn (x', _) => + sc (x ^ ".uw_" ^ x')) + xts)) grouped) + ], + + (L'.ECase (gf "Having", + [((L'.PPrim (Prim.String "TRUE"), loc), + sc ""), + ((L'.PWild, loc), + strcat [sc " HAVING ", gf "Having"])], + {disc = s, + result = s}), loc) ]), loc), fm) end @@ -1398,13 +1402,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("e2", s, s, (L'.ECase ((L'.ERel 0, loc), [((L'.PPrim (Prim.String ""), loc), - strcat loc [(L'.ERel 2, loc), - (L'.ERel 1, loc)]), + strcat [(L'.ERel 2, loc), + (L'.ERel 1, loc)]), ((L'.PWild, loc), - strcat loc [(L'.ERel 2, loc), - (L'.ERel 1, loc), - sc ", ", - (L'.ERel 0, loc)])], + strcat [(L'.ERel 2, loc), + (L'.ERel 1, loc), + sc ", ", + (L'.ERel 0, loc)])], {disc = s, result = s}), loc)), loc)), loc)), loc), fm) end @@ -1415,7 +1419,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (e, fm) = monoExp (env, st, fm) e in - (strcat loc [ + (strcat [ (L'.EPrim (Prim.String " LIMIT "), loc), (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc) ], @@ -1428,7 +1432,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (e, fm) = monoExp (env, st, fm) e in - (strcat loc [ + (strcat [ (L'.EPrim (Prim.String " OFFSET "), loc), (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc) ], @@ -1480,11 +1484,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), - strcat loc [sc "(", - (L'.ERel 1, loc), - sc " ", - (L'.ERel 0, loc), - sc ")"]), loc)), loc), + strcat [sc "(", + (L'.ERel 1, loc), + sc " ", + (L'.ERel 0, loc), + sc ")"]), loc)), loc), fm) end | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm) @@ -1512,13 +1516,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, - strcat loc [sc "(", - (L'.ERel 1, loc), - sc " ", - (L'.ERel 2, loc), - sc " ", - (L'.ERel 0, loc), - sc ")"]), loc)), loc)), loc), + strcat [sc "(", + (L'.ERel 1, loc), + sc " ", + (L'.ERel 2, loc), + sc " ", + (L'.ERel 0, loc), + sc ")"]), loc)), loc)), loc), fm) end | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm) @@ -1568,13 +1572,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, - strcat loc [sc "((", - (L'.ERel 1, loc), - sc ") ", - (L'.ERel 2, loc), - sc " (", - (L'.ERel 0, loc), - sc "))"]), loc)), loc)), loc), + strcat [sc "((", + (L'.ERel 1, loc), + sc ") ", + (L'.ERel 2, loc), + sc " (", + (L'.ERel 0, loc), + sc "))"]), loc)), loc)), loc), fm) end @@ -1606,10 +1610,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), - strcat loc [(L'.ERel 1, loc), - sc "(", - (L'.ERel 0, loc), - sc ")"]), loc)), loc), + strcat [(L'.ERel 1, loc), + sc "(", + (L'.ERel 0, loc), + sc ")"]), loc)), loc), fm) end @@ -1673,9 +1677,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("s", s, s, - strcat loc [sc "(", - (L'.ERel 0, loc), - sc " IS NULL)"]), loc), + strcat [sc "(", + (L'.ERel 0, loc), + sc " IS NULL)"]), loc), fm) end @@ -1757,81 +1761,82 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (tag, targs) = getTag tag val (attrs, fm) = monoExp (env, st, fm) attrs + val attrs = case #1 attrs of + L'.ERecord xes => xes + | _ => raise Fail "Non-record attributes!" fun tagStart tag = - case #1 attrs of - L'.ERecord xes => - let - fun lowercaseFirst "" = "" - | lowercaseFirst s = str (Char.toLower (String.sub (s, 0))) - ^ String.extract (s, 1, NONE) + let + fun lowercaseFirst "" = "" + | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0))) + ^ String.extract (s, 1, NONE) - val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) - in - foldl (fn (("Action", _, _), acc) => acc - | ((x, e, t), (s, fm)) => - case t of - (L'.TFfi ("Basis", "bool"), _) => - let - val s' = " " ^ lowercaseFirst x - in - ((L'.ECase (e, - [((L'.PCon (L'.Enum, - L'.PConFfi {mod = "Basis", - datatyp = "bool", - con = "True", - arg = NONE}, - NONE), loc), - (L'.EStrcat (s, - (L'.EPrim (Prim.String s'), loc)), loc)), - ((L'.PCon (L'.Enum, - L'.PConFfi {mod = "Basis", - datatyp = "bool", - con = "False", - arg = NONE}, - NONE), loc), - s)], - {disc = (L'.TFfi ("Basis", "bool"), loc), - result = (L'.TFfi ("Basis", "string"), loc)}), loc), - fm) - end - | (L'.TFun _, _) => - let - val s' = " " ^ lowercaseFirst x ^ "='" - in - ((L'.EStrcat (s, - (L'.EStrcat ( - (L'.EPrim (Prim.String s'), loc), - (L'.EStrcat ( - (L'.EJavaScript (L'.Attribute, e, NONE), loc), - (L'.EPrim (Prim.String "'"), loc)), loc)), - loc)), loc), - fm) - end - | _ => - let - val fooify = - case x of - "Href" => urlifyExp - | "Link" => urlifyExp - | _ => attrifyExp - - val xp = " " ^ lowercaseFirst x ^ "=\"" - - val (e, fm) = fooify env fm (e, t) - in - ((L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), - (L'.EStrcat (e, - (L'.EPrim (Prim.String "\""), - loc)), - loc)), - loc)), loc), - fm) - end) - (s, fm) xes - end - | _ => raise Fail "Non-record attributes!" + val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) + in + foldl (fn (("Action", _, _), acc) => acc + | (("Source", _, _), acc) => acc + | ((x, e, t), (s, fm)) => + case t of + (L'.TFfi ("Basis", "bool"), _) => + let + val s' = " " ^ lowercaseFirst x + in + ((L'.ECase (e, + [((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, + NONE), loc), + (L'.EStrcat (s, + (L'.EPrim (Prim.String s'), loc)), loc)), + ((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "False", + arg = NONE}, + NONE), loc), + s)], + {disc = (L'.TFfi ("Basis", "bool"), loc), + result = (L'.TFfi ("Basis", "string"), loc)}), loc), + fm) + end + | (L'.TFun _, _) => + let + val s' = " " ^ lowercaseFirst x ^ "='" + in + ((L'.EStrcat (s, + (L'.EStrcat ( + (L'.EPrim (Prim.String s'), loc), + (L'.EStrcat ( + (L'.EJavaScript (L'.Attribute, e, NONE), loc), + (L'.EPrim (Prim.String "'"), loc)), loc)), + loc)), loc), + fm) + end + | _ => + let + val fooify = + case x of + "Href" => urlifyExp + | "Link" => urlifyExp + | _ => attrifyExp + + val xp = " " ^ lowercaseFirst x ^ "=\"" + + val (e, fm) = fooify env fm (e, t) + in + ((L'.EStrcat (s, + (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), + (L'.EStrcat (e, + (L'.EPrim (Prim.String "\""), + loc)), + loc)), + loc)), loc), + fm) + end) + (s, fm) attrs + end fun input typ = case targs of @@ -1888,10 +1893,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc)), loc)) | "dyn" => - (case #1 attrs of - L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), - e), _), _)] => (e, fm) - | L'.ERecord [("Signal", e, _)] => + (case attrs of + [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), + e), _), _)] => (e, fm) + | [("Signal", e, _)] => ((L'.EStrcat ((L'.EPrim (Prim.String ""], + fm)) | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); - raise Fail "No name passed to textarea tag")) + raise Fail "No name passed to textbox tag")) | "password" => input "password" | "textarea" => (case targs of @@ -1955,7 +1967,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (xml, fm) = monoExp (env, st, fm) xml in ((L'.EStrcat ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), + loc)), loc), (L'.EStrcat (xml, (L'.EPrim (Prim.String ""), loc)), loc)), @@ -2025,19 +2038,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => findSubmit xml) | _ => NotFound - val (action, actionT) = case findSubmit xml of - NotFound => raise Fail "No submit found" + val (action, fm) = case findSubmit xml of + NotFound => ((L'.EPrim (Prim.String ""), loc), fm) | Error => raise Fail "Not ready for multi-submit lforms yet" - | Found et => et - - val actionT = monoType env actionT - val (action, fm) = monoExp (env, st, fm) action - val (action, fm) = urlifyExp env fm (action, actionT) + | Found (action, actionT) => + let + val actionT = monoType env actionT + val (action, fm) = monoExp (env, st, fm) action + val (action, fm) = urlifyExp env fm (action, actionT) + in + ((L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc), + (L'.EStrcat (action, + (L'.EPrim (Prim.String "\""), loc)), loc)), loc), + fm) + end + val (xml, fm) = monoExp (env, st, fm) xml in - ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "
"), loc)), loc)), loc), + (L'.EPrim (Prim.String ">"), loc)), loc)), loc), (L'.EStrcat (xml, (L'.EPrim (Prim.String "
"), loc)), loc)), loc), fm) diff --git a/tests/rform.ur b/tests/rform.ur new file mode 100644 index 00000000..17e9a0cf --- /dev/null +++ b/tests/rform.ur @@ -0,0 +1,10 @@ +fun main () : transaction page = + s <- source "Hi"; + return +
+ + + Change it up!
+
+ Latest: +
diff --git a/tests/rform.urp b/tests/rform.urp new file mode 100644 index 00000000..b8cfc369 --- /dev/null +++ b/tests/rform.urp @@ -0,0 +1,3 @@ +debug + +rform -- cgit v1.2.3 From 0c5be5455c4f1e078831cb434bb9df215a410ad9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Jan 2009 10:22:19 -0500 Subject: Use header to set default script type --- src/c/urweb.c | 2 +- src/cjr_print.sml | 2 ++ src/monoize.sml | 4 ++-- 3 files changed, 5 insertions(+), 3 deletions(-) (limited to 'src/monoize.sml') diff --git a/src/c/urweb.c b/src/c/urweb.c index 54646fd8..e28fa5f4 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -382,7 +382,7 @@ char *uw_Basis_get_script(uw_context ctx, uw_unit u) { } else { char *r = uw_malloc(ctx, 41 + (ctx->script_front - ctx->script)); - sprintf(r, "", ctx->script); + sprintf(r, "", ctx->script); return r; } } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 06f9f5ca..f8b1f23b 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2054,6 +2054,8 @@ fun p_file env (ds, ps) = newline, string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", newline, + string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", + newline, string "uw_write(ctx, \"\");", newline, box [string "{", diff --git a/src/monoize.sml b/src/monoize.sml index 4a2f47d7..56310c1b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1898,7 +1898,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = e), _), _)] => (e, fm) | [("Signal", e, _)] => ((L'.EStrcat - ((L'.EPrim (Prim.String ""), loc)), loc)), loc), fm) @@ -1919,7 +1919,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc)), loc), fm) end | SOME (_, src, _) => - (strcat [str ""], fm)) -- cgit v1.2.3 From 0d98ce87ef495ab8652327866b9a2253cbe824d7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Jan 2009 15:17:11 -0500 Subject: Initial experiments with nested --- jslib/urweb.js | 3 +++ lib/basis.urs | 11 +++++++++++ src/compiler.sig | 1 + src/compiler.sml | 3 ++- src/elaborate.sml | 4 ++-- src/jscomp.sml | 33 ++++++++++++++++++++++++++------- src/mono_reduce.sml | 11 ++++++----- src/monoize.sml | 29 +++++++++++++++++++++++++++++ tests/dlist.ur | 22 ++++++++++++++++++++++ tests/dlist.urp | 3 +++ 10 files changed, 105 insertions(+), 15 deletions(-) create mode 100644 tests/dlist.ur create mode 100644 tests/dlist.urp (limited to 'src/monoize.sml') diff --git a/jslib/urweb.js b/jslib/urweb.js index 8e39f9f3..0ee19992 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -13,6 +13,9 @@ function sv(s, v) { s.v = v; callAll(s.h); } +function sg(s) { + return s.v; +} function ss(s) { return s; diff --git a/lib/basis.urs b/lib/basis.urs index 9b09e8d2..b4a40fde 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -86,6 +86,7 @@ val transaction_monad : monad transaction con source :: Type -> Type val source : t ::: Type -> t -> transaction (source t) val set : t ::: Type -> source t -> t -> transaction unit +val get : t ::: Type -> source t -> transaction t con signal :: Type -> Type val signal_monad : monad signal @@ -443,6 +444,16 @@ val submit : ctx ::: {Unit} -> use ::: {Type} -> tag [Value = string, Action = $use -> transaction page] ([Form] ++ ctx) ([Form] ++ ctx) use [] +(*** AJAX-oriented widgets *) + +con cformTag = fn (attrs :: {Type}) => + ctx ::: {Unit} + -> fn [[Body] ~ ctx] => + unit -> tag attrs ([Body] ++ ctx) [] [] [] + +val ctextbox : cformTag [Value = string, Size = int, Source = source string] +val button : cformTag [Value = string, Onclick = transaction unit] + (*** Tables *) val tabl : other ::: {Unit} -> fn [other ~ [Body, Table]] => diff --git a/src/compiler.sig b/src/compiler.sig index c156b268..b126fb51 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -107,6 +107,7 @@ signature COMPILER = sig val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform + val toMono_reduce2 : (string, Mono.file) transform val toMono_shake2 : (string, Mono.file) transform val toPathcheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 6d499283..52181401 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -531,7 +531,8 @@ val toFuse = transform fuse "fuse" o toMono_opt3 val toUntangle2 = transform untangle "untangle2" o toFuse -val toMono_shake2 = transform mono_shake "mono_shake2" o toUntangle2 +val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2 +val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2 val pathcheck = { func = (fn file => (PathCheck.check file; file)), diff --git a/src/elaborate.sml b/src/elaborate.sml index c18cfb49..39cb85b2 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3003,10 +3003,10 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = val env = E.pushDatatype env n xs xcs val d' = (L'.DDatatype (x, n, xs, xcs), loc) in - if positive then + (*if positive then () else - declError env (Nonpositive d'); + declError env (Nonpositive d');*) ([d'], (env, denv, gs' @ gs)) end diff --git a/src/jscomp.sml b/src/jscomp.sml index 64cb1771..1b675abd 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -37,6 +37,7 @@ structure IS = IntBinarySet structure IM = IntBinaryMap val funcs = [(("Basis", "alert"), "alert"), + (("Basis", "get_client_source"), "sg"), (("Basis", "htmlifyBool"), "bs"), (("Basis", "htmlifyFloat"), "ts"), (("Basis", "htmlifyInt"), "ts"), @@ -435,11 +436,22 @@ fun process file = fail, str ")"]) - fun deStrcat (e, _) = + val jsifyString = String.translate (fn #"\"" => "\\\"" + | #"\\" => "\\\\" + | ch => String.str ch) + + fun jsifyStringMulti (n, s) = + case n of + 0 => s + | _ => jsifyStringMulti (n - 1, jsifyString s) + + fun deStrcat level (all as (e, _)) = case e of - EPrim (Prim.String s) => s - | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2 - | _ => raise Fail "Jscomp: deStrcat" + EPrim (Prim.String s) => jsifyStringMulti (level, s) + | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2 + | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\"" + | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; + raise Fail "Jscomp: deStrcat") val quoteExp = quoteExp loc in @@ -474,7 +486,8 @@ fun process file = maxName = #maxName st} val (e, st) = jsExp mode skip [] 0 (e, st) - val e = deStrcat e + val () = Print.prefaces "Pre-e" [("e", MonoPrint.p_exp MonoEnv.empty e)] + val e = deStrcat 0 e val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n" in @@ -745,14 +758,20 @@ fun process file = str ")"], st) end - | EJavaScript (_, _, SOME _) => (e, st) + | EJavaScript (Source _, _, SOME _) => (e, st) + | EJavaScript (_, _, SOME e) => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st) | EClosure _ => unsupported "EClosure" | EQuery _ => unsupported "Query" | EDml _ => unsupported "DML" | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" - | EJavaScript (_, e, _) => unsupported "Nested JavaScript" + | EJavaScript (_, e, _) => + let + val (e, st) = jsE inner (e, st) + in + ((EFfiApp ("Basis", "jsifyString", [e]), loc), st) + end | ESignalReturn e => let diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 0117623f..878fec92 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -479,11 +479,12 @@ fun reduce file = | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs in (*Print.prefaces "verifyCompatible" - [("e'", MonoPrint.p_exp env e'), - ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), - ("effs_e'", Print.p_list p_event effs_e'), - ("effs_b", Print.p_list p_event effs_b)];*) - if List.null effs_e' orelse verifyCompatible effs_b then + [("e'", MonoPrint.p_exp env e'), + ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), + ("effs_e'", Print.p_list p_event effs_e'), + ("effs_b", Print.p_list p_event effs_b)];*) + if List.null effs_e' orelse (List.all (fn eff => eff <> Unsure) effs_e' + andalso verifyCompatible effs_b) then trySub () else e diff --git a/src/monoize.sml b/src/monoize.sml index 56310c1b..993034e4 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1000,6 +1000,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc)), loc)), loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "get"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("src", (L'.TSource, loc), + (L'.TFun ((L'.TRecord [], loc), t), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), t, + (L'.EFfiApp ("Basis", "get_client_source", + [(L'.ERel 1, loc)]), + loc)), loc)), loc), + fm) + end | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _), (L.EFfi ("Basis", "signal_monad"), _)) => @@ -1905,6 +1917,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => raise Fail "Monoize: Bad dyn attributes") | "submit" => normal ("input type=\"submit\"", NONE, NONE) + | "button" => normal ("input type=\"submit\"", NONE, NONE) | "textbox" => (case targs of @@ -1978,6 +1991,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to lselect tag")) + | "ctextbox" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String "/>"), loc)), + loc), fm) + end + | SOME (_, src, _) => + (strcat [str ""], + fm)) + | "option" => normal ("option", NONE, NONE) | "tabl" => normal ("table", NONE, NONE) diff --git a/tests/dlist.ur b/tests/dlist.ur new file mode 100644 index 00000000..211291bc --- /dev/null +++ b/tests/dlist.ur @@ -0,0 +1,22 @@ +datatype dlist = Nil | Cons of string * source dlist + +fun delist dl = + case dl of + Nil => [] + | Cons (x, s) => {[x]} :: {delistSource s} + +and delistSource s = + +fun main () : transaction page = + ns <- source Nil; + s <- source ns; + tb <- source ""; + return +
+
+ +